Erdős problem 18 - b

open Finset Filter

theorem exact_target_type :
    (fcTypeOfName% "Erdos18.erdos_18b") =
      (True ↔ ∀ ε : ℝ, 0 < ε → ∀ᶠ n : ℕ in Filter.atTop,
        (Erdos18.practicalH n.factorial : ℝ) < (n : ℝ) ^ ε) := by
  rfl

def HasShortDivisorSum (N R k : ℕ) : Prop :=
  ∃ D : Finset ℕ, D ⊆ N.divisors ∧ D.sum id = R ∧ D.card ≤ k

theorem short_sum_zero (N k : ℕ) : HasShortDivisorSum N 0 k := by
  refine ⟨∅, ?_, ?_, ?_⟩ <;> simp

theorem short_sum_mono_count {N R k l : ℕ}
    (h : HasShortDivisorSum N R k) (hkl : k ≤ l) :
    HasShortDivisorSum N R l := by
  obtain ⟨D, hD, hsum, hcard⟩ := h
  exact ⟨D, hD, hsum, hcard.trans hkl⟩

theorem short_sum_mono_host {N M R k : ℕ}
    (hNM : N ∣ M) (hM : M ≠ 0) (h : HasShortDivisorSum N R k) :
    HasShortDivisorSum M R k := by
  obtain ⟨D, hD, hsum, hcard⟩ := h
  exact ⟨D, hD.trans (Nat.divisors_subset_of_dvd hM hNM), hsum, hcard⟩

theorem practicalH_le_of_short_sums (N k : ℕ)
    (h : ∀ R ∈ Finset.Icc 1 N, HasShortDivisorSum N R k) :
    Erdos18.practicalH N ≤ k := by
  classical
  unfold Erdos18.practicalH
  apply Finset.sup_le
  intro R hR
  obtain ⟨D, hD, hsum, hcard⟩ := h R hR
  apply le_trans ?_ hcard
  apply Nat.sInf_le
  exact ⟨D, hD, rfl, D, Set.Subset.rfl, hsum.symm⟩

theorem short_sum_of_practicalH {N R : ℕ}
    (hN : Nat.IsPractical N) (hR : R ≤ N) :
    HasShortDivisorSum N R (Erdos18.practicalH N) := by
  classical
  by_cases hzero : R = 0
  · subst R
    exact short_sum_zero _ _
  have hRmem : R ∈ Finset.Icc 1 N := Finset.mem_Icc.mpr ⟨by omega, hR⟩
  have hne : {k | ∃ D : Finset ℕ,
      D ⊆ N.divisors ∧ D.card = k ∧ R ∈ subsetSums D}.Nonempty :=
    ⟨N.divisors.card, N.divisors, Finset.Subset.refl _, rfl, hN R hR⟩
  obtain ⟨D, hD, hcard, E, hED, hsum⟩ := Nat.sInf_mem hne
  have hsub : E ⊆ D := Finset.coe_subset.mp hED
  refine ⟨E, hsub.trans hD, hsum.symm, ?_⟩
  calc
    E.card ≤ D.card := Finset.card_le_card hsub
    _ = sInf {k | ∃ D : Finset ℕ,
        D ⊆ N.divisors ∧ D.card = k ∧ R ∈ subsetSums D} := hcard
    _ ≤ Erdos18.practicalH N := by
      exact Finset.le_sup (f := fun m => sInf {k | ∃ D : Finset ℕ,
        D ⊆ N.divisors ∧ D.card = k ∧ m ∈ subsetSums D}) hRmem

theorem short_sum_radix {M q a r k l : ℕ}
    (hM : 0 < M) (hq : 0 < q) (hrq : r < q)
    (ha : HasShortDivisorSum M a k)
    (hr : HasShortDivisorSum (q * M) r l) :
    HasShortDivisorSum (q * M) (q * a + r) (k + l) := by
  classical
  obtain ⟨A, hA, hAsum, hAcard⟩ := ha
  obtain ⟨B, hB, hBsum, hBcard⟩ := hr
  have hinj : Function.Injective (fun d : ℕ => q * d) :=
    fun _ _ h => mul_left_cancel₀ (ne_of_gt hq) h
  have hdisj : Disjoint (A.image (fun d => q * d)) B := by
    apply Finset.disjoint_left.mpr
    intro x hx hxB
    obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp hx
    have hdpos : 0 < d := Nat.pos_of_dvd_of_pos
      (Nat.dvd_of_mem_divisors (hA hd)) hM
    have hlow : q ≤ q * d := by nlinarith
    have hhigh : q * d ≤ r := by
      rw [← hBsum]
      exact Finset.single_le_sum (f := id) (fun _ _ => Nat.zero_le _) hxB
    omega
  refine ⟨A.image (fun d => q * d) ∪ B, ?_, ?_, ?_⟩
  · intro x hx
    rcases Finset.mem_union.mp hx with hx | hx
    · obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp hx
      exact Nat.mem_divisors.mpr
        ⟨mul_dvd_mul_left q (Nat.dvd_of_mem_divisors (hA hd)),
          ne_of_gt (Nat.mul_pos hq hM)⟩
    · exact hB hx
  · rw [Finset.sum_union hdisj, Finset.sum_image
      (fun x _ y _ h => hinj h)]
    change (∑ x ∈ A, q * x) + B.sum id = q * a + r
    rw [← Finset.mul_sum, show (∑ x ∈ A, x) = a from hAsum, hBsum]
  · rw [Finset.card_union_of_disjoint hdisj,
      Finset.card_image_of_injective A hinj]
    omega

theorem practicalH_radix {M q l : ℕ}
    (hM : Nat.IsPractical M) (hMpos : 0 < M) (hq : 0 < q)
    (hlocal : ∀ r < q, HasShortDivisorSum (q * M) r l) :
    Erdos18.practicalH (q * M) ≤ Erdos18.practicalH M + l := by
  apply practicalH_le_of_short_sums
  intro R hR
  have hquot : R / q ≤ M :=
    Nat.div_le_of_le_mul (Finset.mem_Icc.mp hR).2
  have hrep := short_sum_radix hMpos hq (Nat.mod_lt R hq)
    (short_sum_of_practicalH hM hquot) (hlocal (R % q) (Nat.mod_lt R hq))
  simpa only [Nat.div_add_mod] using hrep

theorem factorial_radix_recurrence {n m l : ℕ} (hmn : m ≤ n)
    (hlocal : ∀ r < n.factorial / m.factorial,
      HasShortDivisorSum n.factorial r l) :
    Erdos18.practicalH n.factorial ≤ Erdos18.practicalH m.factorial + l := by
  have hdiv : m.factorial ∣ n.factorial := Nat.factorial_dvd_factorial hmn
  have heq : n.factorial / m.factorial * m.factorial = n.factorial :=
    Nat.div_mul_cancel hdiv
  have hq : 0 < n.factorial / m.factorial :=
    Nat.div_pos (Nat.le_of_dvd (Nat.factorial_pos n) hdiv) (Nat.factorial_pos m)
  have h := practicalH_radix (Erdos18.factorial_isPractical m)
    (Nat.factorial_pos m) hq (by simpa only [heq] using hlocal)
  simpa only [heq] using h

theorem positive_quotient_of_dvd {R S q : ℕ}
    (hq : 0 < q) (hSR : S < R) (hdvd : q ∣ R - S) :
    ∃ t : ℕ, 0 < t ∧ R = S + q * t ∧ t ≤ R / q := by
  refine ⟨(R - S) / q, ?_, ?_, ?_⟩
  · exact Nat.div_pos (Nat.le_of_dvd (Nat.sub_pos_of_lt hSR) hdvd) hq
  · rw [Nat.mul_div_cancel' hdvd]
    exact (Nat.add_sub_of_le hSR.le).symm
  · exact Nat.div_le_div_right (Nat.sub_le R S)

theorem polynomial_height_below_target {R S q D : ℕ}
    (hq : 2 ≤ q) (hR : q ^ (D + 1) ≤ R) (hS : S ≤ q ^ D) :
    S < R ∧ 2 * S ≤ R := by
  have hpow : 0 < q ^ D := pow_pos (by omega) D
  rw [pow_succ] at hR
  constructor <;> nlinarith

theorem positive_lifting_of_polynomial_height {R S q D : ℕ}
    (hq : 2 ≤ q) (hR : q ^ (D + 1) ≤ R) (hS : S ≤ q ^ D)
    (hdvd : q ∣ R - S) :
    ∃ t : ℕ, 0 < t ∧ R = S + q * t ∧ t ≤ R / q := by
  exact positive_quotient_of_dvd (by omega)
    (polynomial_height_below_target hq hR hS).1 hdvd

theorem positive_lifting_of_congruence {R S q D : ℕ}
    (hq : 2 ≤ q) (hR : q ^ (D + 1) ≤ R) (hS : S ≤ q ^ D)
    (hmod : Nat.ModEq q S R) :
    ∃ t : ℕ, 0 < t ∧ R = S + q * t ∧ t ≤ R / q := by
  exact positive_lifting_of_polynomial_height hq hR hS hmod.dvd'

theorem factorial_power_dvd (m r : ℕ) :
    m.factorial ^ r ∣ (r * m).factorial := by
  simpa using Nat.prod_factorial_dvd_factorial_sum (Finset.range r) (fun _ => m)

theorem factorial_binary_reserve (m k : ℕ) :
    2 ^ k * m.factorial ∣ (m + 2 * k).factorial := by
  have hpow : 2 ^ k ∣ (2 * k).factorial := by
    simpa [Nat.factorial, Nat.mul_comm] using factorial_power_dvd 2 k
  exact (mul_dvd_mul hpow (dvd_refl m.factorial)).trans
    (by simpa [Nat.add_comm] using
      Nat.factorial_mul_factorial_dvd_factorial_add (2 * k) m)

theorem shifted_divisor_dvd_factorial {m k b d : ℕ}
    (hd : d ∣ m.factorial) (hb : b ≤ k) :
    2 ^ b * d ∣ (m + 2 * k).factorial := by
  exact (mul_dvd_mul (pow_dvd_pow 2 hb) hd).trans (factorial_binary_reserve m k)

theorem product_divisors_dvd_factorial_sum {ι : Type*}
    (I : Finset ι) (d a : ι → ℕ)
    (h : ∀ i ∈ I, d i ∣ (a i).factorial) :
    (∏ i ∈ I, d i) ∣ (∑ i ∈ I, a i).factorial := by
  exact (Finset.prod_dvd_prod_of_dvd d (fun i => (a i).factorial) h).trans
    (Nat.prod_factorial_dvd_factorial_sum I a)

theorem distinctify_divisor_multiset (s : Multiset ℕ) {N : ℕ}
    (hN : N ≠ 0) (hs : ∀ d ∈ s, d ∣ N) :
    HasShortDivisorSum (2 ^ s.card * N) s.sum s.card := by
  classical
  have aux : ∀ k : ℕ, ∀ t : Multiset ℕ, t.card = k →
      ∀ M : ℕ, M ≠ 0 → (∀ d ∈ t, d ∣ M) →
      HasShortDivisorSum (2 ^ k * M) t.sum k := by
    intro k
    induction k using Nat.strong_induction_on with
    | h k ih =>
      intro t hk M hM ht
      by_cases hn : t.Nodup
      · refine ⟨t.toFinset, ?_, ?_, ?_⟩
        · intro d hd
          exact Nat.mem_divisors.mpr
            ⟨dvd_mul_of_dvd_right (ht d (Multiset.mem_toFinset.mp hd)) (2 ^ k),
              mul_ne_zero (pow_ne_zero _ (by decide)) hM⟩
        · change (t.toFinset.val.map id).sum = t.sum
          simp [hn.dedup]
        · exact le_of_eq ((Multiset.toFinset_card_of_nodup hn).trans hk)
      · rw [Multiset.nodup_iff_ne_cons_cons] at hn
        push Not at hn
        obtain ⟨a, u, rfl⟩ := hn
        have hc : (2 * a ::ₘ u).card < k := by
          simp only [Multiset.card_cons] at hk ⊢
          omega
        have hnew : ∀ d ∈ (2 * a ::ₘ u), d ∣ 2 * M := by
          intro d hd
          rcases Multiset.mem_cons.mp hd with rfl | hd
          · exact mul_dvd_mul_left 2 (ht a (by simp))
          · exact dvd_mul_of_dvd_right (ht d (by simp [hd])) 2
        have hrep := ih _ hc (2 * a ::ₘ u) rfl (2 * M)
          (mul_ne_zero (by decide) hM) hnew
        have hhost : 2 ^ (2 * a ::ₘ u).card * (2 * M) = 2 ^ k * M := by
          rw [← hk]
          simp only [Multiset.card_cons, pow_succ]
          ring
        have hsum : (2 * a ::ₘ u).sum = (a ::ₘ a ::ₘ u).sum := by
          simp [two_mul, add_assoc]
        have hrep' := short_sum_mono_count hrep hc.le
        simpa only [hhost, hsum] using hrep'
  exact aux s.card s rfl N hN hs

theorem distinctify_factorial_divisors (s : Multiset ℕ) (F : ℕ)
    (hs : ∀ d ∈ s, d ∣ F.factorial) :
    HasShortDivisorSum (F + 2 * s.card).factorial s.sum s.card := by
  exact short_sum_mono_host (factorial_binary_reserve F s.card)
    (Nat.factorial_ne_zero _) (distinctify_divisor_multiset s (Nat.factorial_ne_zero F) hs)

def HasFactorialDivisorMultiset (F R u : ℕ) : Prop :=
  ∃ s : Multiset ℕ, (∀ d ∈ s, d ∣ F.factorial) ∧ s.sum = R ∧ s.card ≤ u

theorem factorial_multiset_zero (F u : ℕ) : HasFactorialDivisorMultiset F 0 u := by
  exact ⟨0, by simp, by simp, by simp⟩

theorem factorial_multiset_singleton {F R : ℕ} (hR : R ∣ F.factorial) :
    HasFactorialDivisorMultiset F R 1 := by
  exact ⟨{R}, by simpa using hR, by simp, by simp⟩

theorem factorial_multiset_mono {F G R u v : ℕ}
    (h : HasFactorialDivisorMultiset F R u) (hFG : F ≤ G) (huv : u ≤ v) :
    HasFactorialDivisorMultiset G R v := by
  obtain ⟨s, hs, hsum, hcard⟩ := h
  exact ⟨s, fun d hd => (hs d hd).trans (Nat.factorial_dvd_factorial hFG),
    hsum, hcard.trans huv⟩

theorem factorial_multiset_to_distinct {F R u : ℕ}
    (h : HasFactorialDivisorMultiset F R u) :
    HasShortDivisorSum (F + 2 * u).factorial R u := by
  obtain ⟨s, hs, hsum, hcard⟩ := h
  have hrep := distinctify_factorial_divisors s F hs
  rw [hsum] at hrep
  exact short_sum_mono_count
    (short_sum_mono_host (Nat.factorial_dvd_factorial (by omega))
      (Nat.factorial_ne_zero (F + 2 * u)) hrep) hcard

theorem factorial_multiset_add {F R S u v : ℕ}
    (hR : HasFactorialDivisorMultiset F R u)
    (hS : HasFactorialDivisorMultiset F S v) :
    HasFactorialDivisorMultiset F (R + S) (u + v) := by
  obtain ⟨s, hs, hsum, hcard⟩ := hR
  obtain ⟨t, ht, htsum, htcard⟩ := hS
  refine ⟨s + t, ?_, ?_, ?_⟩
  · intro d hd
    rcases Multiset.mem_add.mp hd with hd | hd
    · exact hs d hd
    · exact ht d hd
  · simp only [Multiset.sum_add, hsum, htsum]
  · simpa only [Multiset.card_add] using Nat.add_le_add hcard htcard

theorem factorial_multiset_scale {F G q R u : ℕ}
    (hq : q ∣ F.factorial) (h : HasFactorialDivisorMultiset G R u) :
    HasFactorialDivisorMultiset (F + G) (q * R) u := by
  obtain ⟨s, hs, hsum, hcard⟩ := h
  refine ⟨s.map (fun d => q * d), ?_, ?_, ?_⟩
  · intro x hx
    obtain ⟨d, hd, rfl⟩ := Multiset.mem_map.mp hx
    exact (mul_dvd_mul hq (hs d hd)).trans
      (Nat.factorial_mul_factorial_dvd_factorial_add F G)
  · have hmul := Multiset.sum_map_mul_left (s := s) (a := q) (f := id)
    simpa [hsum] using hmul
  · simpa only [Multiset.card_map] using hcard

theorem multiset_sum_expansion (s t : Multiset ℕ) :
    ((s ×ˢ t).map (fun p => p.1 * p.2)).sum = s.sum * t.sum := by
  refine Multiset.induction_on s (by simp) fun a s ih => ?_
  have hmul := Multiset.sum_map_mul_left (s := t) (a := a) (f := id)
  simp only [Multiset.cons_product, Multiset.map_add, Multiset.map_map,
    Multiset.sum_add, Multiset.sum_cons, ih]
  simpa [Function.comp_def, add_mul] using congrArg (fun x => x + s.sum * t.sum) hmul

theorem factorial_multiset_mul {F G R S u v : ℕ}
    (hR : HasFactorialDivisorMultiset F R u)
    (hS : HasFactorialDivisorMultiset G S v) :
    HasFactorialDivisorMultiset (F + G) (R * S) (u * v) := by
  obtain ⟨s, hs, hsum, hcard⟩ := hR
  obtain ⟨t, ht, htsum, htcard⟩ := hS
  refine ⟨(s ×ˢ t).map (fun p => p.1 * p.2), ?_, ?_, ?_⟩
  · intro d hd
    obtain ⟨⟨a, b⟩, hab, rfl⟩ := Multiset.mem_map.mp hd
    obtain ⟨ha, hb⟩ := Multiset.mem_product.mp hab
    exact (mul_dvd_mul (hs a ha) (ht b hb)).trans
      (Nat.factorial_mul_factorial_dvd_factorial_add F G)
  · simp only [multiset_sum_expansion, hsum, htsum]
  · simpa only [Multiset.card_map, Multiset.card_product] using
      Nat.mul_le_mul hcard htcard

theorem factorial_multiset_lift {F G q R S T u v : ℕ}
    (hq : q ∣ F.factorial) (hR : R = S + q * T)
    (hS : HasFactorialDivisorMultiset F S u)
    (hT : HasFactorialDivisorMultiset G T v) :
    HasFactorialDivisorMultiset (F + G) R (u + v) := by
  rw [hR]
  exact factorial_multiset_add (factorial_multiset_mono hS (by omega) le_rfl)
    (factorial_multiset_scale hq hT)

def HasBoundedModularRepresentatives (q F u D : ℕ) : Prop :=
  ∀ R : ℕ, ∃ S : ℕ, S ≤ q ^ D ∧ Nat.ModEq q S R ∧
    HasFactorialDivisorMultiset F S u

theorem positive_modular_lifting_step {q F G u v D R : ℕ}
    (hq : 2 ≤ q) (hdiv : q ∣ F.factorial) (hR : q ^ (D + 1) ≤ R)
    (hmod : HasBoundedModularRepresentatives q F u D)
    (hchild : ∀ T : ℕ, 0 < T → T ≤ R / q → HasFactorialDivisorMultiset G T v) :
    HasFactorialDivisorMultiset (F + G) R (u + v) := by
  obtain ⟨S, hS, hcongr, hrep⟩ := hmod R
  obtain ⟨T, hTpos, hidentity, hTbound⟩ :=
    positive_lifting_of_congruence hq hR hS hcongr
  exact factorial_multiset_lift hdiv hidentity hrep (hchild T hTpos hTbound)

theorem positive_modular_lifting_step_distinct {q F G u v D R : ℕ}
    (hq : 2 ≤ q) (hdiv : q ∣ F.factorial) (hR : q ^ (D + 1) ≤ R)
    (hmod : HasBoundedModularRepresentatives q F u D)
    (hchild : ∀ T : ℕ, 0 < T → T ≤ R / q → HasFactorialDivisorMultiset G T v) :
    HasShortDivisorSum (F + G + 2 * (u + v)).factorial R (u + v) := by
  exact factorial_multiset_to_distinct
    (positive_modular_lifting_step hq hdiv hR hmod hchild)

theorem recursive_modular_lifting
    (indexBudget countBudget : ℕ → ℕ) (threshold : ℕ)
    (hbase : ∀ R < threshold,
      HasFactorialDivisorMultiset (indexBudget R) R (countBudget R))
    (hstep : ∀ R, threshold ≤ R → ∃ q F u D : ℕ,
      2 ≤ q ∧ q ∣ F.factorial ∧ q ^ (D + 1) ≤ R ∧
      HasBoundedModularRepresentatives q F u D ∧
      ∀ T : ℕ, 0 < T → T ≤ R / q →
        F + indexBudget T ≤ indexBudget R ∧
        u + countBudget T ≤ countBudget R) :
    ∀ R : ℕ, HasFactorialDivisorMultiset (indexBudget R) R (countBudget R) := by
  intro R
  induction R using Nat.strong_induction_on with
  | h R ih =>
    by_cases hsmall : R < threshold
    · exact hbase R hsmall
    obtain ⟨q, F, u, D, hq, hdiv, hheight, hmod, hbudget⟩ :=
      hstep R (by omega)
    obtain ⟨S, hS, hcongr, hrep⟩ := hmod R
    obtain ⟨T, hTpos, hidentity, hTbound⟩ :=
      positive_lifting_of_congruence hq hheight hS hcongr
    have hRpos : 0 < R := lt_of_lt_of_le (pow_pos (by omega) _) hheight
    have hTlt : T < R := hTbound.trans_lt (Nat.div_lt_self hRpos (by omega))
    have hchild := ih T hTlt
    obtain ⟨hF, hu⟩ := hbudget T hTpos hTbound
    exact factorial_multiset_mono
      (factorial_multiset_lift hdiv hidentity hrep hchild) hF hu

theorem bounded_recursive_modular_lifting
    (φ ψ : ℕ → ℝ) (threshold : ℕ) (C E A B ρ σ : ℝ)
    (hφ : ∀ R : ℕ, 0 < R → 1 ≤ φ R)
    (hψ : ∀ R : ℕ, 0 < R → 1 ≤ ψ R)
    (hC : (threshold : ℝ) ≤ C) (hCpos : 0 ≤ C)
    (hE : 1 ≤ E)
    (hindex : A + C * ρ ≤ C) (hcount : B + E * σ ≤ E)
    (hstep : ∀ R : ℕ, 0 < R → threshold ≤ R → ∃ q F u D : ℕ,
      2 ≤ q ∧ q ∣ F.factorial ∧ q ^ (D + 1) ≤ R ∧
      HasBoundedModularRepresentatives q F u D ∧
      (F : ℝ) ≤ A * φ R ∧ (u : ℝ) ≤ B * ψ R ∧
      ∀ T : ℕ, 0 < T → T ≤ R / q →
        φ T ≤ ρ * φ R ∧ ψ T ≤ σ * ψ R) :
    ∀ R : ℕ, 0 < R → ∃ F u : ℕ,
      HasFactorialDivisorMultiset F R u ∧
      (F : ℝ) ≤ C * φ R ∧ (u : ℝ) ≤ E * ψ R := by
  have hEpos : 0 ≤ E := by linarith
  intro R
  induction R using Nat.strong_induction_on with
  | h R ih =>
    intro hRpos
    by_cases hsmall : R < threshold
    · refine ⟨R, 1, factorial_multiset_singleton (Nat.dvd_factorial hRpos le_rfl), ?_, ?_⟩
      · have hRle : (R : ℝ) ≤ threshold := by exact_mod_cast hsmall.le
        have hprod : C ≤ C * φ R := by nlinarith [hφ R hRpos]
        exact hRle.trans (hC.trans hprod)
      · have hprod : E ≤ E * ψ R := by nlinarith [hψ R hRpos]
        simpa only [Nat.cast_one] using hE.trans hprod
    obtain ⟨q, F, u, D, hq, hdiv, hheight, hmod, hF, hu, hshrink⟩ :=
      hstep R hRpos (by omega)
    obtain ⟨S, hS, hcongr, hrep⟩ := hmod R
    obtain ⟨T, hTpos, hidentity, hTbound⟩ :=
      positive_lifting_of_congruence hq hheight hS hcongr
    have hTlt : T < R := hTbound.trans_lt (Nat.div_lt_self hRpos (by omega))
    obtain ⟨G, v, hchild, hG, hv⟩ := ih T hTlt hTpos
    obtain ⟨hφT, hψT⟩ := hshrink T hTpos hTbound
    refine ⟨F + G, u + v, factorial_multiset_lift hdiv hidentity hrep hchild, ?_, ?_⟩
    · calc
        ((F + G : ℕ) : ℝ) = (F : ℝ) + G := Nat.cast_add _ _
        _ ≤ A * φ R + C * φ T := add_le_add hF hG
        _ ≤ A * φ R + C * (ρ * φ R) := by gcongr
        _ = (A + C * ρ) * φ R := by ring
        _ ≤ C * φ R := mul_le_mul_of_nonneg_right hindex (by linarith [hφ R hRpos])
    · calc
        ((u + v : ℕ) : ℝ) = (u : ℝ) + v := Nat.cast_add _ _
        _ ≤ B * ψ R + E * ψ T := add_le_add hu hv
        _ ≤ B * ψ R + E * (σ * ψ R) := by gcongr
        _ = (B + E * σ) * ψ R := by ring
        _ ≤ E * ψ R := mul_le_mul_of_nonneg_right hcount (by linarith [hψ R hRpos])

def binaryLength (R : ℕ) : ℕ := Nat.log 2 R + 1

def liftingBits (R D : ℕ) : ℕ := Nat.log 2 R / (D + 1)

theorem binaryLength_pos (R : ℕ) : 0 < binaryLength R := by
  simp [binaryLength]

theorem lifting_modulus_height {R D : ℕ} (hR : 0 < R) :
    (2 ^ liftingBits R D) ^ (D + 1) ≤ R := by
  unfold liftingBits
  rw [← pow_mul]
  exact (Nat.pow_le_pow_right (by decide : 0 < 2)
    (Nat.div_mul_le_self (Nat.log 2 R) (D + 1))).trans
    (Nat.pow_log_le_self 2 hR.ne')

theorem liftingBits_pos {R D : ℕ} (hR : D + 1 ≤ Nat.log 2 R) :
    0 < liftingBits R D := by
  exact Nat.div_pos hR (by omega)

theorem lifting_modulus_ge_two {R D : ℕ} (hR : D + 1 ≤ Nat.log 2 R) :
    2 ≤ 2 ^ liftingBits R D := by
  simpa using Nat.pow_le_pow_right (by decide : 0 < 2) (liftingBits_pos hR)

theorem liftingBits_le_binaryLength (R D : ℕ) :
    liftingBits R D ≤ binaryLength R := by
  exact (Nat.div_le_self _ _).trans (Nat.le_succ _)

noncomputable def liftingRatio (D : ℕ) : ℝ := 1 - 1 / (2 * ((D : ℝ) + 1))

theorem liftingRatio_pos (D : ℕ) : 0 < liftingRatio D := by
  have hD : (0 : ℝ) ≤ D := Nat.cast_nonneg D
  unfold liftingRatio
  have : 1 / (2 * ((D : ℝ) + 1)) < 1 :=
    (div_lt_one (by positivity)).mpr (by linarith)
  linarith

theorem liftingRatio_lt_one (D : ℕ) : liftingRatio D < 1 := by
  unfold liftingRatio
  have : 0 < 1 / (2 * ((D : ℝ) + 1)) := by positivity
  linarith

theorem binaryLength_quotient_shrink {R T D : ℕ}
    (hR : D + 1 ≤ Nat.log 2 R) (hT : T ≤ R / 2 ^ liftingBits R D) :
    (binaryLength T : ℝ) ≤ liftingRatio D * (binaryLength R : ℝ) := by
  have hkpos : 0 < liftingBits R D := liftingBits_pos hR
  have hk : liftingBits R D ≤ Nat.log 2 R := Nat.div_le_self _ _
  have hlog : Nat.log 2 T ≤ Nat.log 2 R - liftingBits R D := by
    calc
      Nat.log 2 T ≤ Nat.log 2 (R / 2 ^ liftingBits R D) := Nat.log_mono_right hT
      _ = Nat.log 2 R - liftingBits R D := Nat.log_div_base_pow 2 R _
  have hsplit : Nat.log 2 T + liftingBits R D ≤ Nat.log 2 R := by omega
  have hdiv : Nat.log 2 R < (D + 1) * (liftingBits R D + 1) :=
    Nat.lt_mul_div_succ _ (by omega)
  have hgap : binaryLength R ≤ 2 * (D + 1) * liftingBits R D := by
    unfold binaryLength
    nlinarith
  have hsplitR : (binaryLength T : ℝ) + (liftingBits R D : ℝ) ≤ binaryLength R := by
    exact_mod_cast (show binaryLength T + liftingBits R D ≤ binaryLength R by
      unfold binaryLength
      omega)
  have hgapR : (binaryLength R : ℝ) ≤
      (2 * ((D : ℝ) + 1)) * (liftingBits R D : ℝ) := by exact_mod_cast hgap
  have hden : (0 : ℝ) < 2 * ((D : ℝ) + 1) := by positivity
  have hquot : (binaryLength R : ℝ) / (2 * ((D : ℝ) + 1)) ≤ liftingBits R D :=
    (div_le_iff₀ hden).mpr (by nlinarith [hgapR])
  unfold liftingRatio
  have hid : (1 - 1 / (2 * ((D : ℝ) + 1))) * (binaryLength R : ℝ) =
      (binaryLength R : ℝ) - (binaryLength R : ℝ) / (2 * ((D : ℝ) + 1)) := by ring
  rw [hid]
  linarith

theorem binaryLength_rpow_quotient_shrink {R T D : ℕ} {a : ℝ}
    (ha : 0 ≤ a) (hR : D + 1 ≤ Nat.log 2 R)
    (hT : T ≤ R / 2 ^ liftingBits R D) :
    (binaryLength T : ℝ) ^ a ≤ liftingRatio D ^ a * (binaryLength R : ℝ) ^ a := by
  have h := Real.rpow_le_rpow (Nat.cast_nonneg (binaryLength T))
    (binaryLength_quotient_shrink hR hT) ha
  simpa only [Real.mul_rpow (liftingRatio_pos D).le (Nat.cast_nonneg _)] using h

def DyadicModularBounds (a b : ℝ) : Prop :=
  ∃ D k₀ : ℕ, ∃ A B : ℝ, 0 < A ∧ 0 < B ∧
    ∀ k : ℕ, k₀ ≤ k → ∃ F u : ℕ,
      2 ^ k ∣ F.factorial ∧ HasBoundedModularRepresentatives (2 ^ k) F u D ∧
      (F : ℝ) ≤ A * (k : ℝ) ^ a ∧ (u : ℝ) ≤ B * (k : ℝ) ^ b

theorem dyadic_modular_bounds_give_local_multisets {a b : ℝ}
    (ha : 0 < a) (hb : 0 < b) (h : DyadicModularBounds a b) :
    ∃ C E : ℝ, 0 < C ∧ 0 < E ∧ ∀ R : ℕ, 0 < R → ∃ F u : ℕ,
      HasFactorialDivisorMultiset F R u ∧
      (F : ℝ) ≤ C * (binaryLength R : ℝ) ^ a ∧
      (u : ℝ) ≤ E * (binaryLength R : ℝ) ^ b := by
  obtain ⟨D, k₀, A, B, hA, hB, hmod⟩ := h
  let threshold : ℕ := 2 ^ ((D + 1) * (k₀ + 1))
  let ρ : ℝ := liftingRatio D ^ a
  let σ : ℝ := liftingRatio D ^ b
  have hρ : ρ < 1 := Real.rpow_lt_one (liftingRatio_pos D).le (liftingRatio_lt_one D) ha
  have hσ : σ < 1 := Real.rpow_lt_one (liftingRatio_pos D).le (liftingRatio_lt_one D) hb
  let C : ℝ := max (threshold : ℝ) (A / (1 - ρ))
  let E : ℝ := max 1 (B / (1 - σ))
  have hC : (threshold : ℝ) ≤ C := le_max_left _ _
  have hE : 1 ≤ E := le_max_left _ _
  have hCA : A / (1 - ρ) ≤ C := le_max_right _ _
  have hEB : B / (1 - σ) ≤ E := le_max_right _ _
  have hCpos : 0 < C := (div_pos hA (by linarith)).trans_le hCA
  have hEpos : 0 < E := lt_of_lt_of_le zero_lt_one hE
  have hindex : A + C * ρ ≤ C := by
    have := (div_le_iff₀ (by linarith : 0 < 1 - ρ)).mp hCA
    nlinarith
  have hcount : B + E * σ ≤ E := by
    have := (div_le_iff₀ (by linarith : 0 < 1 - σ)).mp hEB
    nlinarith
  refine ⟨C, E, hCpos, hEpos, ?_⟩
  refine bounded_recursive_modular_lifting
    (fun R => (binaryLength R : ℝ) ^ a) (fun R => (binaryLength R : ℝ) ^ b)
    threshold C E A B ρ σ
    (fun R _ => Real.one_le_rpow (by exact_mod_cast binaryLength_pos R) ha.le)
    (fun R _ => Real.one_le_rpow (by exact_mod_cast binaryLength_pos R) hb.le)
    hC hCpos.le hE hindex hcount ?_
  intro R hR hlarge
  have hlog : (D + 1) * (k₀ + 1) ≤ Nat.log 2 R :=
    (Nat.le_log_iff_pow_le (by decide : 1 < 2) hR.ne').mpr hlarge
  have hD : D + 1 ≤ Nat.log 2 R := by nlinarith
  have hk₀ : k₀ ≤ liftingBits R D := by
    apply (Nat.le_div_iff_mul_le (by omega : 0 < D + 1)).mpr
    nlinarith
  obtain ⟨F, u, hdiv, hrep, hF, hu⟩ := hmod (liftingBits R D) hk₀
  refine ⟨2 ^ liftingBits R D, F, u, D, lifting_modulus_ge_two hD, hdiv,
    lifting_modulus_height hR, hrep, ?_, ?_, ?_⟩
  · exact hF.trans (mul_le_mul_of_nonneg_left
      (Real.rpow_le_rpow (Nat.cast_nonneg _) (by exact_mod_cast liftingBits_le_binaryLength R D)
        ha.le) hA.le)
  · exact hu.trans (mul_le_mul_of_nonneg_left
      (Real.rpow_le_rpow (Nat.cast_nonneg _) (by exact_mod_cast liftingBits_le_binaryLength R D)
        hb.le) hB.le)
  · intro T _ hT
    exact ⟨binaryLength_rpow_quotient_shrink ha.le hD hT,
      binaryLength_rpow_quotient_shrink hb.le hD hT⟩

def LocalFactorialBounds (a b : ℝ) : Prop :=
  ∃ C : ℝ, 0 < C ∧ ∀ R : ℕ, 0 < R → ∃ F u : ℕ,
    HasShortDivisorSum F.factorial R u ∧
    (F : ℝ) ≤ C * (binaryLength R : ℝ) ^ a ∧
    (u : ℝ) ≤ C * (binaryLength R : ℝ) ^ b

theorem dyadic_modular_bounds_give_local_bounds {a b : ℝ}
    (ha : 0 < a) (hb : 0 < b) (hba : b ≤ a) (h : DyadicModularBounds a b) :
    LocalFactorialBounds a b := by
  obtain ⟨C, E, hC, hE, hlocal⟩ := dyadic_modular_bounds_give_local_multisets ha hb h
  refine ⟨C + 2 * E, by linarith, ?_⟩
  intro R hR
  obtain ⟨F, u, hrep, hF, hu⟩ := hlocal R hR
  refine ⟨F + 2 * u, u, factorial_multiset_to_distinct hrep, ?_, ?_⟩
  · have hpow : (binaryLength R : ℝ) ^ b ≤ (binaryLength R : ℝ) ^ a :=
      Real.rpow_le_rpow_of_exponent_le (by exact_mod_cast binaryLength_pos R) hba
    have htwice := mul_le_mul_of_nonneg_left hpow (by linarith : 0 ≤ 2 * E)
    push_cast
    nlinarith
  · have hpow : 0 ≤ (binaryLength R : ℝ) ^ b := Real.rpow_nonneg (by positivity) _
    nlinarith

theorem binaryLength_mono {R S : ℕ} (h : R ≤ S) : binaryLength R ≤ binaryLength S := by
  exact Nat.add_le_add_right (Nat.log_mono_right h) 1

theorem local_bounds_uniform_remainders {a b C : ℝ} {n Q : ℕ}
    (ha : 0 ≤ a) (hb : 0 ≤ b) (hC : 0 ≤ C)
    (hlocal : ∀ R : ℕ, 0 < R → ∃ F u : ℕ,
      HasShortDivisorSum F.factorial R u ∧
      (F : ℝ) ≤ C * (binaryLength R : ℝ) ^ a ∧
      (u : ℝ) ≤ C * (binaryLength R : ℝ) ^ b)
    (hhost : C * (binaryLength Q : ℝ) ^ a ≤ n) :
    ∀ R < Q, HasShortDivisorSum n.factorial R ⌊C * (binaryLength Q : ℝ) ^ b⌋₊ := by
  intro R hRQ
  by_cases hzero : R = 0
  · subst R
    exact short_sum_zero _ _
  obtain ⟨F, u, hrep, hF, hu⟩ := hlocal R (by omega)
  have hlen : (binaryLength R : ℝ) ≤ binaryLength Q := by
    exact_mod_cast binaryLength_mono hRQ.le
  have hF' : (F : ℝ) ≤ n := hF.trans
    ((mul_le_mul_of_nonneg_left (Real.rpow_le_rpow (Nat.cast_nonneg _) hlen ha) hC).trans hhost)
  have hu' : (u : ℝ) ≤ C * (binaryLength Q : ℝ) ^ b := hu.trans
    (mul_le_mul_of_nonneg_left (Real.rpow_le_rpow (Nat.cast_nonneg _) hlen hb) hC)
  exact short_sum_mono_count
    (short_sum_mono_host (Nat.factorial_dvd_factorial (by exact_mod_cast hF'))
      (Nat.factorial_ne_zero n) hrep) (Nat.le_floor hu')

theorem local_bounds_radix_recurrence {a b C : ℝ} {n m : ℕ}
    (ha : 0 ≤ a) (hb : 0 ≤ b) (hC : 0 ≤ C) (hmn : m ≤ n)
    (hlocal : ∀ R : ℕ, 0 < R → ∃ F u : ℕ,
      HasShortDivisorSum F.factorial R u ∧
      (F : ℝ) ≤ C * (binaryLength R : ℝ) ^ a ∧
      (u : ℝ) ≤ C * (binaryLength R : ℝ) ^ b)
    (hhost : C * (binaryLength (n.factorial / m.factorial) : ℝ) ^ a ≤ n) :
    Erdos18.practicalH n.factorial ≤ Erdos18.practicalH m.factorial +
      ⌊C * (binaryLength (n.factorial / m.factorial) : ℝ) ^ b⌋₊ := by
  exact factorial_radix_recurrence hmn (local_bounds_uniform_remainders ha hb hC hlocal hhost)

theorem binaryLength_le_of_le_pow {R w : ℕ} (h : R ≤ 2 ^ w) :
    binaryLength R ≤ w + 1 := by
  have hlog := Nat.log_mono_right h (b := 2)
  rw [Nat.log_pow (by decide : 1 < 2)] at hlog
  exact Nat.add_le_add_right hlog 1

theorem binaryLength_pow_le (n w : ℕ) : binaryLength (n ^ w) ≤ w * binaryLength n + 1 := by
  apply binaryLength_le_of_le_pow
  calc
    n ^ w ≤ (2 ^ binaryLength n) ^ w :=
      Nat.pow_le_pow_left (Nat.lt_pow_succ_log_self (by decide : 1 < 2) n).le w
    _ = 2 ^ (w * binaryLength n) := by rw [← pow_mul, Nat.mul_comm]

theorem factorial_quotient_le_pow {n w : ℕ} (hw : w ≤ n) :
    n.factorial / (n - w).factorial ≤ n ^ w := by
  rw [← Nat.descFactorial_eq_div hw]
  exact Nat.descFactorial_le_pow n w

theorem binaryLength_factorial_quotient_le {n w : ℕ} (hw : w ≤ n) :
    binaryLength (n.factorial / (n - w).factorial) ≤ w * binaryLength n + 1 := by
  exact (binaryLength_mono (factorial_quotient_le_pow hw)).trans (binaryLength_pow_le n w)

theorem rpow_difference_lower_bound {x y p : ℝ}
    (hx : 0 < x) (hy : 0 ≤ y) (hp : 0 ≤ p) (hp1 : p ≤ 1) :
    p * (x - y) * x ^ (p - 1) ≤ x ^ p - y ^ p := by
  have hB := rpow_one_add_le_one_add_mul_self
    (s := y / x - 1) (by have := div_nonneg hy hx.le; linarith) hp hp1
  have hB' : y ^ p / x ^ p ≤ 1 + p * (y / x - 1) := by
    simpa only [show 1 + (y / x - 1) = y / x by ring,
      Real.div_rpow hy hx.le] using hB
  have hpX : 0 < x ^ p := Real.rpow_pos_of_pos hx p
  have hmul := (div_le_iff₀ hpX).mp hB'
  have hid : (1 + p * (y / x - 1)) * x ^ p =
      x ^ p - p * (x - y) * x ^ (p - 1) := by
    rw [Real.rpow_sub hx, Real.rpow_one]
    field_simp
    ring
  rw [hid] at hmul
  linarith

theorem eventually_const_mul_rpow_le {a b C E : ℝ} (hab : a < b) (hE : 0 < E) :
    ∀ᶠ n : ℕ in Filter.atTop, C * (n : ℝ) ^ a ≤ E * (n : ℝ) ^ b := by
  have h := (tendsto_rpow_atTop (sub_pos.mpr hab)).comp
    (tendsto_natCast_atTop_atTop (R := ℝ))
  filter_upwards [h.eventually_ge_atTop (C / E), eventually_ge_atTop (1 : ℕ)] with n hn hn1
  have hnpos : (0 : ℝ) < n := by exact_mod_cast (show 0 < n by omega)
  have hC : C ≤ E * (n : ℝ) ^ (b - a) := by
    change C / E ≤ (n : ℝ) ^ (b - a) at hn
    simpa only [mul_comm] using (div_le_iff₀ hE).mp hn
  calc
    C * (n : ℝ) ^ a ≤ (E * (n : ℝ) ^ (b - a)) * (n : ℝ) ^ a :=
      mul_le_mul_of_nonneg_right hC (Real.rpow_nonneg (Nat.cast_nonneg n) a)
    _ = E * (n : ℝ) ^ b := by
      rw [mul_assoc, ← Real.rpow_add hnpos, sub_add_cancel]

theorem eventually_binaryLength_le_rpow {ε : ℝ} (hε : 0 < ε) :
    ∀ᶠ n : ℕ in Filter.atTop, (binaryLength n : ℝ) ≤ (n : ℝ) ^ ε := by
  have hlog := ((isLittleO_log_rpow_atTop hε).const_mul_left (1 / Real.log 2)).comp_tendsto
    (tendsto_natCast_atTop_atTop (R := ℝ))
  have hconst := eventually_const_mul_rpow_le (C := 1) (E := 1 / 2) hε (by norm_num)
  filter_upwards [hlog.def (by norm_num : (0 : ℝ) < 1 / 2), hconst] with n hn hc
  have hl : (Nat.log 2 n : ℝ) ≤ (1 / Real.log 2) * Real.log (n : ℝ) := by
    simpa only [Real.logb, Nat.cast_ofNat, div_eq_mul_inv, one_mul, mul_comm]
      using Real.natLog_le_logb n 2
  have hn' : (1 / Real.log 2) * Real.log (n : ℝ) ≤ (1 / 2) * (n : ℝ) ^ ε := by
    have habs : |(1 / Real.log 2) * Real.log (n : ℝ)| ≤ (1 / 2) * (n : ℝ) ^ ε := by
      simpa only [Function.comp_apply, Real.norm_eq_abs,
        abs_of_nonneg (Real.rpow_nonneg (Nat.cast_nonneg n) ε)] using hn
    exact (le_abs_self _).trans habs
  have hc' : 1 ≤ (1 / 2) * (n : ℝ) ^ ε := by simpa using hc
  change ((Nat.log 2 n + 1 : ℕ) : ℝ) ≤ (n : ℝ) ^ ε
  rw [Nat.cast_add, Nat.cast_one]
  calc
    (Nat.log 2 n : ℝ) + 1 ≤ (1 / 2) * (n : ℝ) ^ ε + (1 / 2) * (n : ℝ) ^ ε :=
      add_le_add (hl.trans hn') hc'
    _ = (n : ℝ) ^ ε := by ring

noncomputable def radixWidth (n : ℕ) (θ : ℝ) : ℕ := ⌊(n : ℝ) ^ θ⌋₊

theorem eventually_radix_width_bounds {θ γ : ℝ}
    (hθ : 0 < θ) (hθ1 : θ < 1) (hγ : 0 < γ) :
    ∀ᶠ n : ℕ in Filter.atTop,
      0 < radixWidth n θ ∧ radixWidth n θ < n ∧
      (n : ℝ) ^ θ / 2 ≤ (radixWidth n θ : ℝ) ∧
      (binaryLength (n.factorial / (n - radixWidth n θ).factorial) : ℝ) ≤
        2 * (n : ℝ) ^ (θ + γ) := by
  have hlarge := ((tendsto_rpow_atTop hθ).comp
    (tendsto_natCast_atTop_atTop (R := ℝ))).eventually_ge_atTop 2
  have hsmall := eventually_const_mul_rpow_le (C := 1) (E := 1 / 2) hθ1 (by norm_num)
  filter_upwards [hlarge, hsmall, eventually_binaryLength_le_rpow hγ,
    eventually_ge_atTop (1 : ℕ)] with n hlarge hsmall hlen hn1
  change (2 : ℝ) ≤ (n : ℝ) ^ θ at hlarge
  have hnpos : (0 : ℝ) < n := by exact_mod_cast (show 0 < n by omega)
  have hfloor : (radixWidth n θ : ℝ) ≤ (n : ℝ) ^ θ :=
    Nat.floor_le (Real.rpow_nonneg (Nat.cast_nonneg n) θ)
  have hfloorlt : (n : ℝ) ^ θ < (radixWidth n θ : ℝ) + 1 := Nat.lt_floor_add_one _
  have hwpos : 0 < radixWidth n θ := by
    apply Nat.le_floor
    norm_num only [Nat.cast_succ, Nat.cast_zero, zero_add]
    exact (by norm_num : (1 : ℝ) ≤ 2).trans hlarge
  have hwlt : radixWidth n θ < n := by
    have hsmall' : (n : ℝ) ^ θ ≤ (n : ℝ) / 2 := by
      simpa [div_eq_mul_inv, mul_comm] using hsmall
    exact_mod_cast hfloor.trans_lt (hsmall'.trans_lt (half_lt_self hnpos))
  refine ⟨hwpos, hwlt, by linarith only [hlarge, hfloorlt], ?_⟩
  have hlenQ : (binaryLength (n.factorial / (n - radixWidth n θ).factorial) : ℝ) ≤
      (radixWidth n θ : ℝ) * (binaryLength n : ℝ) + 1 := by
    exact_mod_cast binaryLength_factorial_quotient_le hwlt.le
  have hprod := mul_le_mul hfloor hlen (Nat.cast_nonneg (binaryLength n))
    (Real.rpow_nonneg (Nat.cast_nonneg n) θ)
  have hpowone : 1 ≤ (n : ℝ) ^ (θ + γ) :=
    Real.one_le_rpow (by exact_mod_cast hn1) (by linarith)
  rw [← Real.rpow_add hnpos] at hprod
  calc
    (binaryLength (n.factorial / (n - radixWidth n θ).factorial) : ℝ) ≤
        (radixWidth n θ : ℝ) * (binaryLength n : ℝ) + 1 := hlenQ
    _ ≤ (n : ℝ) ^ (θ + γ) + 1 := add_le_add hprod (le_refl (1 : ℝ))
    _ ≤ 2 * (n : ℝ) ^ (θ + γ) := by linarith only [hpowone]

theorem bounded_of_eventual_potential_decrease (f P : ℕ → ℝ)
    (hP : ∀ n : ℕ, 0 ≤ P n)
    (hstep : ∀ᶠ n : ℕ in Filter.atTop, ∃ m : ℕ, m < n ∧
      f n ≤ f m + P n - P m) :
    ∃ K : ℝ, 0 ≤ K ∧ ∀ n : ℕ, f n ≤ K + P n := by
  obtain ⟨N, hN⟩ := Filter.eventually_atTop.mp hstep
  let K : ℝ := ∑ i ∈ Finset.range N, max 0 (f i)
  refine ⟨K, Finset.sum_nonneg (fun _ _ => le_max_left _ _), ?_⟩
  intro n
  induction n using Nat.strong_induction_on with
  | h n ih =>
    by_cases hn : n < N
    · have hf : f n ≤ K := (le_max_right 0 (f n)).trans
        (Finset.single_le_sum (f := fun i => max 0 (f i))
          (fun _ _ => le_max_left _ _) (Finset.mem_range.mpr hn))
      linarith [hP n]
    · obtain ⟨m, hmn, hfm⟩ := hN n (by omega)
      linarith [ih m hmn]

theorem eventual_factorial_potential_decrease {a b p θ γ C : ℝ}
    (ha : 0 ≤ a) (hb : 0 ≤ b) (hp : 0 < p) (hp1 : p ≤ 1)
    (hθ : 0 < θ) (hθ1 : θ < 1) (hγ : 0 < γ) (hC : 0 ≤ C)
    (hindex : (θ + γ) * a < 1) (hcount : (θ + γ) * b < θ + p - 1)
    (hlocal : ∀ R : ℕ, 0 < R → ∃ F u : ℕ,
      HasShortDivisorSum F.factorial R u ∧
      (F : ℝ) ≤ C * (binaryLength R : ℝ) ^ a ∧
      (u : ℝ) ≤ C * (binaryLength R : ℝ) ^ b) :
    ∀ᶠ n : ℕ in Filter.atTop, ∃ m : ℕ, m < n ∧
      (Erdos18.practicalH n.factorial : ℝ) ≤
        (Erdos18.practicalH m.factorial : ℝ) + (n : ℝ) ^ p - (m : ℝ) ^ p := by
  have hhost := eventually_const_mul_rpow_le (C := C * (2 : ℝ) ^ a) (E := 1)
    hindex zero_lt_one
  have hcost := eventually_const_mul_rpow_le (C := C * (2 : ℝ) ^ b) (E := p / 2)
    hcount (half_pos hp)
  filter_upwards [eventually_radix_width_bounds hθ hθ1 hγ, hhost, hcost,
    eventually_ge_atTop (1 : ℕ)] with n hw hhost hcost hn1
  obtain ⟨hwpos, hwlt, hwhalf, hlen⟩ := hw
  have hnpos : (0 : ℝ) < n := by exact_mod_cast (show 0 < n by omega)
  let m := n - radixWidth n θ
  let Q := n.factorial / m.factorial
  have hpow (t : ℝ) (ht : 0 ≤ t) :
      C * (binaryLength Q : ℝ) ^ t ≤
        (C * (2 : ℝ) ^ t) * (n : ℝ) ^ ((θ + γ) * t) := by
    calc
      C * (binaryLength Q : ℝ) ^ t ≤ C * (2 * (n : ℝ) ^ (θ + γ)) ^ t :=
        mul_le_mul_of_nonneg_left (Real.rpow_le_rpow (Nat.cast_nonneg _) hlen ht) hC
      _ = (C * (2 : ℝ) ^ t) * (n : ℝ) ^ ((θ + γ) * t) := by
        rw [Real.mul_rpow (by norm_num : (0 : ℝ) ≤ 2)
          (Real.rpow_nonneg (Nat.cast_nonneg n) _), ← Real.rpow_mul (Nat.cast_nonneg n)]
        ring
  have hhost' : C * (binaryLength Q : ℝ) ^ a ≤ n :=
    (hpow a ha).trans (by simpa only [Real.rpow_one, one_mul] using hhost)
  have hrec := local_bounds_radix_recurrence ha hb hC (Nat.sub_le n (radixWidth n θ))
    hlocal hhost'
  have hcost' : (⌊C * (binaryLength Q : ℝ) ^ b⌋₊ : ℝ) ≤
      (p / 2) * (n : ℝ) ^ (θ + p - 1) :=
    (Nat.floor_le (mul_nonneg hC (Real.rpow_nonneg (Nat.cast_nonneg _) b))).trans
      ((hpow b hb).trans hcost)
  have hdiff := rpow_difference_lower_bound hnpos (Nat.cast_nonneg m) hp.le hp1
  have hnm : (n : ℝ) - (m : ℝ) = (radixWidth n θ : ℝ) := by
    dsimp [m]
    rw [Nat.cast_sub hwlt.le]
    ring
  rw [hnm] at hdiff
  have hpoweq : (n : ℝ) ^ θ * (n : ℝ) ^ (p - 1) = (n : ℝ) ^ (θ + p - 1) := by
    rw [← Real.rpow_add hnpos]
    congr 1
    ring
  have hgap : (p / 2) * (n : ℝ) ^ (θ + p - 1) ≤
      (n : ℝ) ^ p - (m : ℝ) ^ p := by
    calc
      (p / 2) * (n : ℝ) ^ (θ + p - 1) =
          (p * ((n : ℝ) ^ θ / 2)) * (n : ℝ) ^ (p - 1) := by rw [← hpoweq]; ring
      _ ≤ (p * (radixWidth n θ : ℝ)) * (n : ℝ) ^ (p - 1) :=
        mul_le_mul_of_nonneg_right (mul_le_mul_of_nonneg_left hwhalf hp.le)
          (Real.rpow_nonneg (Nat.cast_nonneg n) _)
      _ ≤ (n : ℝ) ^ p - (m : ℝ) ^ p := hdiff
  have hrec' : (Erdos18.practicalH n.factorial : ℝ) ≤
      (Erdos18.practicalH m.factorial : ℝ) + (⌊C * (binaryLength Q : ℝ) ^ b⌋₊ : ℝ) := by
    exact_mod_cast hrec
  refine ⟨m, Nat.sub_lt (by omega) hwpos, ?_⟩
  linarith

theorem local_bounds_give_power_bound {p : ℝ} (hp : 0 < p) (hp1 : p ≤ 1)
    (hlocal : LocalFactorialBounds (1 + p / 16) (p / 4)) :
    ∃ K : ℝ, 0 ≤ K ∧ ∀ n : ℕ,
      (Erdos18.practicalH n.factorial : ℝ) ≤ K + (n : ℝ) ^ p := by
  obtain ⟨C, hC, hlocal⟩ := hlocal
  apply bounded_of_eventual_potential_decrease
    (fun n => (Erdos18.practicalH n.factorial : ℝ)) (fun n => (n : ℝ) ^ p)
    (fun n => Real.rpow_nonneg (Nat.cast_nonneg n) p)
  exact eventual_factorial_potential_decrease (a := 1 + p / 16) (b := p / 4)
    (θ := 1 - p / 4) (γ := p / 8)
    (by linarith) (by linarith) hp hp1 (by linarith) (by linarith) (by linarith)
    hC.le (by nlinarith [sq_nonneg p]) (by nlinarith [sq_nonneg p]) hlocal

/- This intermediate conditional theorem verifies the
entire subsequent deduction, including both recursions and the strict bound. -/
theorem erdos18b_of_dyadic_modular_bounds
    (h : ∀ a b : ℝ, 1 < a → 0 < b → DyadicModularBounds a b) :
    fcTypeOfName% "Erdos18.erdos_18b" := by
  constructor
  · intro _ δ hδ
    let p : ℝ := min (δ / 2) (1 / 2)
    have hp : 0 < p := lt_min (half_pos hδ) (by norm_num)
    have hp1 : p ≤ 1 := (min_le_right _ _).trans (by norm_num)
    have hpδ : p < δ := (min_le_left _ _).trans_lt (half_lt_self hδ)
    have ha : 0 < 1 + p / 16 := by linarith
    have hb : 0 < p / 4 := by linarith
    have hba : p / 4 ≤ 1 + p / 16 := by linarith
    have hmod := h (1 + p / 16) (p / 4) (by linarith) hb
    have hlocal := dyadic_modular_bounds_give_local_bounds ha hb hba hmod
    obtain ⟨K, _, hbound⟩ := local_bounds_give_power_bound hp hp1 hlocal
    have hpow := eventually_const_mul_rpow_le (C := 1) (E := 1 / 3) hpδ (by norm_num)
    have hconst := eventually_const_mul_rpow_le (C := K) (E := 1 / 3) hδ (by norm_num)
    filter_upwards [hpow, hconst, eventually_ge_atTop (1 : ℕ)] with n hn hK hn1
    have hn' : (n : ℝ) ^ p ≤ (1 / 3) * (n : ℝ) ^ δ := by simpa using hn
    have hK' : K ≤ (1 / 3) * (n : ℝ) ^ δ := by simpa using hK
    have hpos : 0 < (n : ℝ) ^ δ := Real.rpow_pos_of_pos
      (by exact_mod_cast (show 0 < n by omega)) δ
    calc
      (Erdos18.practicalH n.factorial : ℝ) ≤ K + (n : ℝ) ^ p := hbound n
      _ ≤ (1 / 3) * (n : ℝ) ^ δ + (1 / 3) * (n : ℝ) ^ δ := add_le_add hK' hn'
      _ < (n : ℝ) ^ δ := by nlinarith only [hpos]
  · intro _
    trivial

theorem subpolynomial_of_power_log_bounds (f : ℕ → ℝ)
    (h : ∀ ε : ℝ, 0 < ε → ∃ C K : ℝ, ∀ᶠ n : ℕ in Filter.atTop,
      f n ≤ C * (n : ℝ) ^ ε * (Real.log (n : ℝ)) ^ K) :
    ∀ δ : ℝ, 0 < δ → ∀ᶠ n : ℕ in Filter.atTop, f n < (n : ℝ) ^ δ := by
  intro δ hδ
  have hhalf : 0 < δ / 2 := half_pos hδ
  obtain ⟨C, K, hbound⟩ := h (δ / 2) hhalf
  have hsmall := ((isLittleO_log_rpow_rpow_atTop K hhalf).const_mul_left C).comp_tendsto
    (tendsto_natCast_atTop_atTop (R := ℝ))
  have hevent := hsmall.def (by norm_num : (0 : ℝ) < 1 / 2)
  filter_upwards [hbound, hevent, eventually_ge_atTop (1 : ℕ)] with n hn he hn1
  have hnpos : (0 : ℝ) < n := by exact_mod_cast (show 0 < n by omega)
  have hp : 0 < (n : ℝ) ^ (δ / 2) := Real.rpow_pos_of_pos hnpos _
  have hlog : C * (Real.log (n : ℝ)) ^ K < (n : ℝ) ^ (δ / 2) := by
    have he' : |C * (Real.log (n : ℝ)) ^ K| ≤ (1 / 2) * (n : ℝ) ^ (δ / 2) := by
      simpa only [Function.comp_apply, Real.norm_eq_abs, abs_of_pos hp] using he
    have hle := le_abs_self (C * (Real.log (n : ℝ)) ^ K)
    linarith
  calc
    f n ≤ C * (n : ℝ) ^ (δ / 2) * (Real.log (n : ℝ)) ^ K := hn
    _ = (n : ℝ) ^ (δ / 2) * (C * (Real.log (n : ℝ)) ^ K) := by ring
    _ < (n : ℝ) ^ (δ / 2) * (n : ℝ) ^ (δ / 2) :=
      mul_lt_mul_of_pos_left hlog hp
    _ = (n : ℝ) ^ δ := by
      rw [← Real.rpow_add hnpos]
      congr 1
      ring

/- Final asymptotic deduction from the intermediate modular hypothesis. -/
theorem erdos18b_of_power_log_bounds
    (h : ∀ ε : ℝ, 0 < ε → ∃ C K : ℝ, ∀ᶠ n : ℕ in Filter.atTop,
      (Erdos18.practicalH n.factorial : ℝ) ≤
        C * (n : ℝ) ^ ε * (Real.log (n : ℝ)) ^ K) :
    fcTypeOfName% "Erdos18.erdos_18b" := by
  constructor
  · intro _
    exact subpolynomial_of_power_log_bounds _ h
  · intro _
    trivial

noncomputable def cyclicConvolution {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) (x : ZMod q) : ℂ := ∑ y, f y * g (x - y)

theorem dft_cyclicConvolution {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) (k : ZMod q) :
    ZMod.dft (cyclicConvolution f g) k = ZMod.dft f k * ZMod.dft g k := by
  classical
  simp only [ZMod.dft_apply, smul_eq_mul, cyclicConvolution]
  rw [Finset.sum_mul]
  simp_rw [Finset.mul_sum]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro y _
  refine Fintype.sum_equiv (Equiv.subRight y) _ _ ?_
  intro x
  simp only [Equiv.subRight_apply]
  have hchar : ZMod.stdAddChar (-(x * k)) =
      ZMod.stdAddChar (-(y * k)) * ZMod.stdAddChar (-((x - y) * k)) := by
    rw [← AddChar.map_add_eq_mul]
    congr 1
    ring
  rw [hchar]
  ring

noncomputable def cyclicConvolutionPow {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) : ℕ → ZMod q → ℂ
  | 0 => fun x => if x = 0 then 1 else 0
  | s + 1 => cyclicConvolution f (cyclicConvolutionPow f s)

theorem dft_cyclicConvolutionPow {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (s : ℕ) (k : ZMod q) :
    ZMod.dft (cyclicConvolutionPow f s) k = (ZMod.dft f k) ^ s := by
  classical
  induction s with
  | zero => simp [cyclicConvolutionPow, ZMod.dft_apply]
  | succ s ih =>
    rw [cyclicConvolutionPow, dft_cyclicConvolution, ih, pow_succ]
    ring

theorem nonzero_of_fourier_norm_sum_lt_one {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (hzero : ZMod.dft f 0 = 1)
    (hsmall : ∑ k ∈ (Finset.univ : Finset (ZMod q)).erase 0, ‖ZMod.dft f k‖ < 1) :
    ∀ x : ZMod q, f x ≠ 0 := by
  classical
  intro x hx
  have hsum := congrFun (ZMod.dft_dft f) (-x)
  rw [ZMod.dft_apply] at hsum
  simp only [mul_neg, neg_neg, hx, smul_eq_mul, mul_zero] at hsum
  have hsplit := Finset.sum_erase_add (Finset.univ : Finset (ZMod q))
    (fun k => ZMod.stdAddChar (k * x) * ZMod.dft f k) (Finset.mem_univ 0)
  have hrest : (∑ k ∈ (Finset.univ : Finset (ZMod q)).erase 0,
      ZMod.stdAddChar (k * x) * ZMod.dft f k) = -1 := by
    have hz : ZMod.stdAddChar (0 * x) * ZMod.dft f 0 = 1 := by simp [hzero]
    rw [hz, hsum] at hsplit
    exact eq_neg_of_add_eq_zero_left hsplit
  have hnorm : ‖∑ k ∈ (Finset.univ : Finset (ZMod q)).erase 0,
      ZMod.stdAddChar (k * x) * ZMod.dft f k‖ ≤
      ∑ k ∈ (Finset.univ : Finset (ZMod q)).erase 0, ‖ZMod.dft f k‖ := by
    calc
      _ ≤ ∑ k ∈ (Finset.univ : Finset (ZMod q)).erase 0,
          ‖ZMod.stdAddChar (k * x) * ZMod.dft f k‖ := norm_sum_le _ _
      _ = _ := by simp only [norm_mul, ZMod.stdAddChar_apply, Circle.norm_coe, one_mul]
  rw [hrest] at hnorm
  norm_num only [norm_neg, norm_one] at hnorm
  exact (hnorm.trans_lt hsmall).false

theorem convolution_pow_nonzero_of_fourier_bound {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (s : ℕ) (hzero : ZMod.dft f 0 = 1)
    (hsmall : ∑ k ∈ (Finset.univ : Finset (ZMod q)).erase 0, ‖ZMod.dft f k‖ ^ s < 1) :
    ∀ x : ZMod q, cyclicConvolutionPow f s x ≠ 0 := by
  apply nonzero_of_fourier_norm_sum_lt_one
  · rw [dft_cyclicConvolutionPow, hzero, one_pow]
  · simpa only [dft_cyclicConvolutionPow, norm_pow] using hsmall

theorem convolution_pow_support_representatives {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (F u H : ℕ)
    (hsupport : ∀ x : ZMod q, f x ≠ 0 → ∃ S : ℕ,
      S ≤ H ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset F S u) :
    ∀ s : ℕ, ∀ x : ZMod q, cyclicConvolutionPow f s x ≠ 0 → ∃ S : ℕ,
      S ≤ s * H ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset F S (s * u) := by
  classical
  intro s
  induction s with
  | zero =>
    intro x hx
    have hxzero : x = 0 := by
      by_contra hne
      simp only [cyclicConvolutionPow, if_neg hne] at hx
      exact hx rfl
    subst x
    exact ⟨0, by simp, by simp, by simpa using factorial_multiset_zero F 0⟩
  | succ s ih =>
    intro x hx
    change (∑ y : ZMod q, f y * cyclicConvolutionPow f s (x - y)) ≠ 0 at hx
    obtain ⟨y, _, hy⟩ := Finset.exists_ne_zero_of_sum_ne_zero hx
    obtain ⟨hfy, hgs⟩ := mul_ne_zero_iff.mp hy
    obtain ⟨A, hA, hAcast, hArep⟩ := hsupport y hfy
    obtain ⟨B, hB, hBcast, hBrep⟩ := ih (x - y) hgs
    refine ⟨A + B, ?_, ?_, ?_⟩
    · calc
        A + B ≤ H + s * H := Nat.add_le_add hA hB
        _ = (s + 1) * H := by ring
    · rw [Nat.cast_add, hAcast, hBcast]
      abel
    · simpa only [Nat.succ_mul, Nat.add_comm] using factorial_multiset_add hArep hBrep

theorem bounded_modular_representatives_of_fourier {q F u H D s : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (hzero : ZMod.dft f 0 = 1)
    (hsmall : ∑ k ∈ (Finset.univ : Finset (ZMod q)).erase 0, ‖ZMod.dft f k‖ ^ s < 1)
    (hsupport : ∀ x : ZMod q, f x ≠ 0 → ∃ S : ℕ,
      S ≤ H ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset F S u)
    (hheight : s * H ≤ q ^ D) :
    HasBoundedModularRepresentatives q F (s * u) D := by
  intro R
  obtain ⟨S, hS, hScast, hrep⟩ := convolution_pow_support_representatives f F u H hsupport s
    (R : ZMod q) (convolution_pow_nonzero_of_fourier_bound f s hzero hsmall (R : ZMod q))
  exact ⟨S, hS.trans hheight, (ZMod.natCast_eq_natCast_iff S R q).mp hScast, hrep⟩

noncomputable def dyadicConductorLevel {K : ℕ} (x : ZMod (2 ^ K)) : ℕ :=
  Nat.log 2 (addOrderOf x)

theorem dyadic_conductor_spec {K : ℕ} (x : ZMod (2 ^ K)) :
    dyadicConductorLevel x ≤ K ∧ addOrderOf x = 2 ^ dyadicConductorLevel x := by
  have hdvd : addOrderOf x ∣ 2 ^ K := by
    simpa only [ZMod.card] using addOrderOf_dvd_card (x := x)
  obtain ⟨j, hj, heq⟩ := (Nat.dvd_prime_pow Nat.prime_two).mp hdvd
  have hlevel : dyadicConductorLevel x = j := by
    simp only [dyadicConductorLevel, heq, Nat.log_pow (by decide : 1 < 2)]
  exact ⟨hlevel ▸ hj, by rw [hlevel, heq]⟩

theorem dyadic_conductor_pos {K : ℕ} {x : ZMod (2 ^ K)} (hx : x ≠ 0) :
    0 < dyadicConductorLevel x := by
  by_contra h
  have hz : dyadicConductorLevel x = 0 := by omega
  have horder : addOrderOf x = 1 := by simpa only [hz, pow_zero] using (dyadic_conductor_spec x).2
  exact hx (AddMonoid.addOrderOf_eq_one_iff.mp horder)

theorem dyadic_conductor_fiber_card_le {K j : ℕ} (hj : j ≤ K) :
    (((Finset.univ : Finset (ZMod (2 ^ K))).erase 0).filter
      (fun x => dyadicConductorLevel x = j)).card ≤ 2 ^ j := by
  classical
  have hsub : (((Finset.univ : Finset (ZMod (2 ^ K))).erase 0).filter
      (fun x => dyadicConductorLevel x = j)) ⊆
      (Finset.univ.filter (fun x : ZMod (2 ^ K) => addOrderOf x = 2 ^ j)) := by
    intro x hx
    obtain ⟨_, heq⟩ := Finset.mem_filter.mp hx
    exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, by rw [← heq]; exact (dyadic_conductor_spec x).2⟩
  calc
    _ ≤ (Finset.univ.filter (fun x : ZMod (2 ^ K) => addOrderOf x = 2 ^ j)).card :=
      Finset.card_le_card hsub
    _ = Nat.totient (2 ^ j) := IsAddCyclic.card_addOrderOf_eq_totient
      (by simpa only [ZMod.card] using pow_dvd_pow 2 hj)
    _ ≤ 2 ^ j := Nat.totient_le _

theorem dyadic_geometric_sum (K : ℕ) :
    (∑ j ∈ Finset.Icc 1 K, (1 / 2 : ℝ) ^ j) = 1 - (1 / 2 : ℝ) ^ K := by
  induction K with
  | zero => simp
  | succ K ih =>
    rw [Finset.sum_Icc_succ_top (by omega : 1 ≤ K + 1), ih, pow_succ]
    ring

theorem dyadic_fourier_norm_sum_lt_one {K s : ℕ} (f : ZMod (2 ^ K) → ℂ)
    (hdecay : ∀ x : ZMod (2 ^ K), x ≠ 0 →
      ‖ZMod.dft f x‖ ^ s ≤ (1 / 4 : ℝ) ^ dyadicConductorLevel x) :
    ∑ x ∈ (Finset.univ : Finset (ZMod (2 ^ K))).erase 0, ‖ZMod.dft f x‖ ^ s < 1 := by
  classical
  have hmaps : ∀ x ∈ (Finset.univ : Finset (ZMod (2 ^ K))).erase 0,
      dyadicConductorLevel x ∈ Finset.Icc 1 K := by
    intro x hx
    exact Finset.mem_Icc.mpr ⟨dyadic_conductor_pos (Finset.mem_erase.mp hx).1,
      (dyadic_conductor_spec x).1⟩
  have hbound :
      (∑ x ∈ (Finset.univ : Finset (ZMod (2 ^ K))).erase 0, ‖ZMod.dft f x‖ ^ s) ≤
      ∑ j ∈ Finset.Icc 1 K, (1 / 2 : ℝ) ^ j := by
    rw [← Finset.sum_fiberwise_of_maps_to hmaps (fun x => ‖ZMod.dft f x‖ ^ s)]
    apply Finset.sum_le_sum
    intro j hj
    have hcard :
        ((((Finset.univ : Finset (ZMod (2 ^ K))).erase 0).filter
          (fun x => dyadicConductorLevel x = j)).card : ℝ) ≤ (2 : ℝ) ^ j := by
      exact_mod_cast dyadic_conductor_fiber_card_le (Finset.mem_Icc.mp hj).2
    calc
      _ ≤ ∑ x ∈ (((Finset.univ : Finset (ZMod (2 ^ K))).erase 0).filter
          (fun x => dyadicConductorLevel x = j)), (1 / 4 : ℝ) ^ j := by
        apply Finset.sum_le_sum
        intro x hx
        obtain ⟨hx, hlevel⟩ := Finset.mem_filter.mp hx
        simpa only [hlevel] using hdecay x (Finset.mem_erase.mp hx).1
      _ = ((((Finset.univ : Finset (ZMod (2 ^ K))).erase 0).filter
          (fun x => dyadicConductorLevel x = j)).card : ℝ) * (1 / 4 : ℝ) ^ j := by simp
      _ ≤ (2 : ℝ) ^ j * (1 / 4 : ℝ) ^ j :=
        mul_le_mul_of_nonneg_right hcard (by positivity)
      _ = (1 / 2 : ℝ) ^ j := by rw [← mul_pow]; norm_num
  rw [dyadic_geometric_sum] at hbound
  have hpos : 0 < (1 / 2 : ℝ) ^ K := pow_pos (by norm_num) _
  exact hbound.trans_lt (by linarith)

theorem powered_dyadic_decay_le {v t : ℝ} {s j : ℕ} (hv : 0 ≤ v)
    (hdecay : v ≤ (2 : ℝ) ^ (-t * (j : ℝ))) (hs : 2 ≤ t * (s : ℝ)) :
    v ^ s ≤ (1 / 4 : ℝ) ^ j := by
  calc
    v ^ s ≤ ((2 : ℝ) ^ (-t * (j : ℝ))) ^ s := pow_le_pow_left₀ hv hdecay s
    _ = (2 : ℝ) ^ ((-t * (j : ℝ)) * (s : ℝ)) :=
      (Real.rpow_mul_natCast (by norm_num) _ _).symm
    _ ≤ (2 : ℝ) ^ ((-2 : ℝ) * (j : ℝ)) := by
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      nlinarith [mul_le_mul_of_nonneg_right hs (Nat.cast_nonneg j : (0 : ℝ) ≤ j)]
    _ = (1 / 4 : ℝ) ^ j := by
      rw [Real.rpow_mul_natCast (by norm_num)]
      norm_num [Real.rpow_neg, Real.rpow_ofNat]

theorem exists_convolution_power_for_dyadic_decay {t : ℝ} (ht : 0 < t) :
    ∃ s : ℕ, 0 < s ∧ ∀ K : ℕ, ∀ f : ZMod (2 ^ K) → ℂ,
      (∀ x : ZMod (2 ^ K), x ≠ 0 →
        ‖ZMod.dft f x‖ ≤ (2 : ℝ) ^ (-t * (dyadicConductorLevel x : ℝ))) →
      ∑ x ∈ (Finset.univ : Finset (ZMod (2 ^ K))).erase 0, ‖ZMod.dft f x‖ ^ s < 1 := by
  obtain ⟨s, hs⟩ := exists_nat_ge (2 / t)
  have hts : 2 ≤ t * (s : ℝ) := by
    have := (div_le_iff₀ ht).mp hs
    nlinarith
  have hspos : 0 < s := by
    by_contra h
    have : s = 0 := by omega
    simp only [this, Nat.cast_zero, mul_zero] at hts
    norm_num at hts
  refine ⟨s, hspos, ?_⟩
  intro K f hdecay
  apply dyadic_fourier_norm_sum_lt_one
  intro x hx
  exact powered_dyadic_decay_le (norm_nonneg _) (hdecay x hx) hts

noncomputable def cyclicPushforward {α : Type*} [Fintype α] {q : ℕ} [NeZero q]
    (w : α → ℂ) (T : α → ZMod q) (x : ZMod q) : ℂ :=
  ∑ a, if T a = x then w a else 0

theorem dft_cyclicPushforward {α : Type*} [Fintype α] {q : ℕ} [NeZero q]
    (w : α → ℂ) (T : α → ZMod q) (k : ZMod q) :
    ZMod.dft (cyclicPushforward w T) k = ∑ a, ZMod.stdAddChar (-(T a * k)) * w a := by
  classical
  simp only [ZMod.dft_apply, cyclicPushforward, smul_eq_mul, Finset.mul_sum]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro a _
  simp only [mul_ite, mul_zero]
  simp

theorem cyclicPushforward_support {α : Type*} [Fintype α] {q : ℕ} [NeZero q]
    (w : α → ℂ) (T : α → ZMod q) {x : ZMod q}
    (hx : cyclicPushforward w T x ≠ 0) : ∃ a : α, T a = x ∧ w a ≠ 0 := by
  classical
  obtain ⟨a, _, ha⟩ := Finset.exists_ne_zero_of_sum_ne_zero hx
  by_cases h : T a = x
  · exact ⟨a, h, by simpa only [h, if_true] using ha⟩
  · simp only [h, if_false, ne_eq, not_true_eq_false] at ha

theorem dft_translate {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (a k : ZMod q) :
    ZMod.dft (fun x => f (x - a)) k = ZMod.stdAddChar (-(a * k)) * ZMod.dft f k := by
  classical
  simp only [ZMod.dft_apply, smul_eq_mul, Finset.mul_sum]
  refine Fintype.sum_equiv (Equiv.subRight a) _ _ ?_
  intro x
  simp only [Equiv.subRight_apply]
  rw [← mul_assoc, ← AddChar.map_add_eq_mul]
  congr 2
  ring

noncomputable def cyclicBernoulliSmooth {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (x : ZMod q) : ℂ := (f x + f (x - 1)) / 2

theorem dft_cyclicBernoulliSmooth {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (k : ZMod q) :
    ZMod.dft (cyclicBernoulliSmooth f) k =
      ZMod.dft f k * ((1 + ZMod.stdAddChar (-k)) / 2) := by
  have heq : cyclicBernoulliSmooth f =
      (fun x => f x + f (x - 1)) * (fun _ => (2 : ℂ)⁻¹) := by
    ext x
    simp [cyclicBernoulliSmooth, div_eq_mul_inv]
  rw [heq]
  change ZMod.dft (fun x => (f x + f (x - 1)) * (2 : ℂ)⁻¹) k = _
  rw [ZMod.dft_mul_const]
  change ZMod.dft (fun x => f x + f (x - 1)) k * (2 : ℂ)⁻¹ = _
  have hadd : ZMod.dft (fun x => f x + f (x - 1)) k =
      ZMod.dft f k + ZMod.dft (fun x => f (x - 1)) k := by
    exact congrFun (map_add ZMod.dft f (fun x => f (x - 1))) k
  rw [hadd, dft_translate]
  simp only [one_mul]
  ring

theorem norm_dft_cyclicBernoulliSmooth_le {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (k : ZMod q) :
    ‖ZMod.dft (cyclicBernoulliSmooth f) k‖ ≤ ‖ZMod.dft f k‖ := by
  have hnorm : ‖(1 + ZMod.stdAddChar (-k)) / (2 : ℂ)‖ ≤ 1 := by
    rw [norm_div]
    have ht := norm_add_le (1 : ℂ) (ZMod.stdAddChar (-k))
    norm_num only [norm_one, ZMod.stdAddChar_apply, Circle.norm_coe, Complex.norm_ofNat] at *
    linarith
  rw [dft_cyclicBernoulliSmooth, norm_mul]
  simpa only [mul_one] using mul_le_mul_of_nonneg_left hnorm (norm_nonneg _)

theorem dft_cyclicBernoulliSmooth_zero {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) {k : ZMod q} (hk : k ≠ 0) (h2 : (2 : ZMod q) * k = 0) :
    ZMod.dft (cyclicBernoulliSmooth f) k = 0 := by
  have hsq : ZMod.stdAddChar (-k) ^ 2 = (1 : ℂ) := by
    rw [← AddChar.map_nsmul_eq_pow]
    have hz : 2 • (-k) = 0 := by
      norm_num only [nsmul_eq_mul, Nat.cast_ofNat, mul_neg, h2, neg_zero]
    rw [hz, AddChar.map_zero_eq_one]
  have hne : ZMod.stdAddChar (-k) ≠ (1 : ℂ) := by
    intro h
    have hzero : ZMod.stdAddChar (-k) = ZMod.stdAddChar (0 : ZMod q) := by simpa using h
    exact hk (neg_eq_zero.mp (ZMod.injective_stdAddChar hzero))
  have hchar := (sq_eq_one_iff.mp hsq).resolve_left hne
  rw [dft_cyclicBernoulliSmooth, hchar]
  simp

theorem sum_addChar_progression_eq_zero {q : ℕ} [NeZero q]
    (ψ : AddChar (ZMod q) ℂ) (a b : ZMod q) (n : ℕ)
    (hb : ψ b ≠ 1) (hn : ψ (n • b) = 1) :
    ∑ i ∈ Finset.range n, ψ (a + i • b) = 0 := by
  have hpow : (ψ b) ^ n = 1 := by rw [← AddChar.map_nsmul_eq_pow, hn]
  have hgeom := geom_sum_mul (ψ b) n
  rw [hpow, sub_self] at hgeom
  have hsum : (∑ i ∈ Finset.range n, (ψ b) ^ i) = 0 :=
    (mul_eq_zero.mp hgeom).resolve_right (sub_ne_zero.mpr hb)
  simp_rw [AddChar.map_add_eq_mul, AddChar.map_nsmul_eq_pow]
  rw [← Finset.mul_sum, hsum, mul_zero]

theorem dyadic_conductor_twice_ne_zero {K : ℕ} {x : ZMod (2 ^ K)}
    (hx : 2 ≤ dyadicConductorLevel x) : (2 : ZMod (2 ^ K)) * x ≠ 0 := by
  intro hzero
  have hsmul : 2 • x = 0 := by simpa only [nsmul_eq_mul, Nat.cast_ofNat] using hzero
  have hdvd : addOrderOf x ∣ 2 := addOrderOf_dvd_iff_nsmul_eq_zero.mpr hsmul
  rw [(dyadic_conductor_spec x).2] at hdvd
  have hle := Nat.le_of_dvd (by decide : 0 < 2) hdvd
  have hfour : 4 ≤ 2 ^ dyadicConductorLevel x := by
    exact Nat.pow_le_pow_right (by decide : 0 < 2) hx
  omega

theorem dyadic_conductor_power_nsmul_eq_zero {K b : ℕ} {x : ZMod (2 ^ K)}
    (hx : dyadicConductorLevel x ≤ b) : (2 ^ b) • x = 0 := by
  apply addOrderOf_dvd_iff_nsmul_eq_zero.mp
  rw [(dyadic_conductor_spec x).2]
  exact pow_dvd_pow 2 hx

noncomputable def cyclicOddDigit {K : ℕ} (b : ℕ) : ZMod (2 ^ K) → ℂ :=
  cyclicPushforward (fun _ : Fin (2 ^ (b - 1)) => ((2 ^ (b - 1) : ℕ) : ℂ)⁻¹)
    (fun i => ((2 * i.val + 1 : ℕ) : ZMod (2 ^ K)))

theorem dft_cyclicOddDigit_zero {K b : ℕ} {k : ZMod (2 ^ K)}
    (hklo : 2 ≤ dyadicConductorLevel k) (hkhi : dyadicConductorLevel k ≤ b) :
    ZMod.dft (cyclicOddDigit b) k = 0 := by
  have hbpos : 0 < b := by omega
  have hp : 2 ^ (b - 1) * 2 = 2 ^ b := by
    rw [← pow_succ, Nat.sub_add_cancel hbpos]
  have hchar : ZMod.stdAddChar (-(2 * k)) ≠ (1 : ℂ) := by
    intro h
    have hh : ZMod.stdAddChar (-(2 * k)) = ZMod.stdAddChar (0 : ZMod (2 ^ K)) := by
      simpa using h
    exact dyadic_conductor_twice_ne_zero hklo (neg_eq_zero.mp (ZMod.injective_stdAddChar hh))
  have hperiod : ZMod.stdAddChar ((2 ^ (b - 1)) • (-(2 * k))) = (1 : ℂ) := by
    have heq : ((2 ^ (b - 1) : ℕ) • (-(2 * k)) : ZMod (2 ^ K)) =
        -((2 ^ b : ℕ) • k) := by
      simp only [nsmul_eq_mul, Nat.cast_pow, Nat.cast_ofNat, mul_neg]
      rw [← mul_assoc]
      congr 2
      simpa only [Nat.cast_mul, Nat.cast_pow, Nat.cast_ofNat] using
        congrArg (fun n : ℕ => (n : ZMod (2 ^ K))) hp
    rw [heq, dyadic_conductor_power_nsmul_eq_zero hkhi, neg_zero, AddChar.map_zero_eq_one]
  have hsum := sum_addChar_progression_eq_zero ZMod.stdAddChar (-k) (-(2 * k))
    (2 ^ (b - 1)) hchar hperiod
  have hrewrite : ∀ i : ℕ,
      ZMod.stdAddChar (-(((2 * i + 1 : ℕ) : ZMod (2 ^ K)) * k)) =
        ZMod.stdAddChar (-k + i • (-(2 * k))) := by
    intro i
    congr 1
    push_cast
    simp only [nsmul_eq_mul]
    ring
  rw [cyclicOddDigit, dft_cyclicPushforward, ← Finset.sum_mul]
  have hfin : (∑ i : Fin (2 ^ (b - 1)),
      ZMod.stdAddChar (-(((2 * i.val + 1 : ℕ) : ZMod (2 ^ K)) * k))) = 0 := by
    simpa only [hrewrite] using
      (Fin.sum_univ_eq_sum_range
        (fun i : ℕ => ZMod.stdAddChar (-k + i • (-(2 * k)))) (2 ^ (b - 1))).trans hsum
  rw [hfin, zero_mul]

theorem dyadic_conductor_mul_unit {K : ℕ} (x y : ZMod (2 ^ K)) (hy : IsUnit y) :
    dyadicConductorLevel (y * x) = dyadicConductorLevel x := by
  obtain ⟨u, rfl⟩ := hy
  have horder : addOrderOf ((u : ZMod (2 ^ K)) * x) = addOrderOf x :=
    addOrderOf_injective (AddMonoidHom.mulLeft (u : ZMod (2 ^ K)))
      (Units.mulLeft u).injective x
  simp only [dyadicConductorLevel, horder]

noncomputable def cyclicMultiplicativeConvolution {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) : ZMod q → ℂ :=
  cyclicPushforward (fun p : ZMod q × ZMod q => f p.1 * g p.2) (fun p => p.1 * p.2)

theorem dft_cyclicMultiplicativeConvolution {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) (k : ZMod q) :
    ZMod.dft (cyclicMultiplicativeConvolution f g) k =
      ∑ y : ZMod q, g y * ZMod.dft f (y * k) := by
  classical
  rw [cyclicMultiplicativeConvolution, dft_cyclicPushforward]
  simp only [Fintype.sum_prod_type]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro y _
  simp only [ZMod.dft_apply, smul_eq_mul, Finset.mul_sum, mul_assoc]
  apply Finset.sum_congr rfl
  intro x _
  ring

theorem cyclicMultiplicativeConvolution_support_units {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) (hf : ∀ x, f x ≠ 0 → IsUnit x)
    (hg : ∀ x, g x ≠ 0 → IsUnit x) :
    ∀ x, cyclicMultiplicativeConvolution f g x ≠ 0 → IsUnit x := by
  intro x hx
  obtain ⟨⟨a, b⟩, hab, hw⟩ := cyclicPushforward_support
    (fun p : ZMod q × ZMod q => f p.1 * g p.2) (fun p => p.1 * p.2) hx
  obtain ⟨ha, hb⟩ := mul_ne_zero_iff.mp hw
  rw [← hab]
  exact (hf a ha).mul (hg b hb)

theorem cyclicMultiplicativeConvolution_support_representatives {q F G u v H J : ℕ}
    [NeZero q] (f g : ZMod q → ℂ)
    (hf : ∀ x, f x ≠ 0 → ∃ S : ℕ,
      S ≤ H ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset F S u)
    (hg : ∀ x, g x ≠ 0 → ∃ S : ℕ,
      S ≤ J ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset G S v) :
    ∀ x, cyclicMultiplicativeConvolution f g x ≠ 0 → ∃ S : ℕ,
      S ≤ H * J ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset (F + G) S (u * v) := by
  intro x hx
  obtain ⟨⟨a, b⟩, hab, hw⟩ := cyclicPushforward_support
    (fun p : ZMod q × ZMod q => f p.1 * g p.2) (fun p => p.1 * p.2) hx
  obtain ⟨ha, hb⟩ := mul_ne_zero_iff.mp hw
  obtain ⟨A, hA, hAcast, hArep⟩ := hf a ha
  obtain ⟨B, hB, hBcast, hBrep⟩ := hg b hb
  exact ⟨A * B, Nat.mul_le_mul hA hB, by simpa only [Nat.cast_mul, hAcast, hBcast] using hab,
    factorial_multiset_mul hArep hBrep⟩

theorem dft_cyclicMultiplicativeConvolution_zero {K lo hi : ℕ}
    (f g : ZMod (2 ^ K) → ℂ)
    (hf : ∀ x, lo ≤ dyadicConductorLevel x → dyadicConductorLevel x ≤ hi → ZMod.dft f x = 0)
    (hg : ∀ x, g x ≠ 0 → IsUnit x) {k : ZMod (2 ^ K)}
    (hklo : lo ≤ dyadicConductorLevel k) (hkhi : dyadicConductorLevel k ≤ hi) :
    ZMod.dft (cyclicMultiplicativeConvolution f g) k = 0 := by
  rw [dft_cyclicMultiplicativeConvolution]
  apply Finset.sum_eq_zero
  intro y _
  by_cases hy : g y = 0
  · simp only [hy, zero_mul]
  · have hlevel := dyadic_conductor_mul_unit k y (hg y hy)
    rw [hf (y * k) (by rwa [hlevel]) (by rwa [hlevel]), mul_zero]

noncomputable def cyclicProductPow {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) : ℕ → ZMod q → ℂ
  | 0 => fun x => if x = 1 then 1 else 0
  | r + 1 => cyclicMultiplicativeConvolution f (cyclicProductPow f r)

theorem cyclicProductPow_support_units {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (hf : ∀ x, f x ≠ 0 → IsUnit x) :
    ∀ r : ℕ, ∀ x, cyclicProductPow f r x ≠ 0 → IsUnit x := by
  intro r
  induction r with
  | zero =>
    intro x hx
    have hxeq : x = 1 := by
      by_contra h
      simp only [cyclicProductPow, if_neg h, ne_eq, not_true_eq_false] at hx
    rw [hxeq]
    exact isUnit_one
  | succ r ih =>
    exact cyclicMultiplicativeConvolution_support_units f _ hf ih

theorem cyclicProductPow_support_representatives {q F u H : ℕ} [NeZero q]
    (f : ZMod q → ℂ)
    (hf : ∀ x, f x ≠ 0 → ∃ S : ℕ,
      S ≤ H ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset F S u) :
    ∀ r : ℕ, ∀ x, cyclicProductPow f r x ≠ 0 → ∃ S : ℕ,
      S ≤ H ^ r ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset (r * F) S (u ^ r) := by
  intro r
  induction r with
  | zero =>
    intro x hx
    have hxeq : x = 1 := by
      by_contra h
      simp only [cyclicProductPow, if_neg h, ne_eq, not_true_eq_false] at hx
    refine ⟨1, by simp, by simp [hxeq], ?_⟩
    simpa using factorial_multiset_singleton (F := 0) (R := 1) (one_dvd _)
  | succ r ih =>
    intro x hx
    have hrep := cyclicMultiplicativeConvolution_support_representatives f _ hf ih x hx
    simpa only [Nat.succ_mul, pow_succ, Nat.add_comm, Nat.mul_comm] using hrep

theorem dft_cyclicProductPow_zero {K lo hi r : ℕ}
    (f : ZMod (2 ^ K) → ℂ) (hr : 0 < r)
    (hu : ∀ x, f x ≠ 0 → IsUnit x)
    (hf : ∀ x, lo ≤ dyadicConductorLevel x → dyadicConductorLevel x ≤ hi → ZMod.dft f x = 0)
    {k : ZMod (2 ^ K)} (hklo : lo ≤ dyadicConductorLevel k)
    (hkhi : dyadicConductorLevel k ≤ hi) :
    ZMod.dft (cyclicProductPow f r) k = 0 := by
  obtain ⟨r, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.ne_of_gt hr)
  exact dft_cyclicMultiplicativeConvolution_zero f _ hf
    (cyclicProductPow_support_units f hu r) hklo hkhi

theorem dft_cyclicOddDigit_at_zero {K : ℕ} (b : ℕ) :
    ZMod.dft (cyclicOddDigit (K := K) b) 0 = 1 := by
  rw [cyclicOddDigit, dft_cyclicPushforward]
  simp

theorem cyclicOddDigit_support_units {K b : ℕ} :
    ∀ x, cyclicOddDigit (K := K) b x ≠ 0 → IsUnit x := by
  intro x hx
  obtain ⟨i, hi, _⟩ := cyclicPushforward_support
    (fun _ : Fin (2 ^ (b - 1)) => ((2 ^ (b - 1) : ℕ) : ℂ)⁻¹)
    (fun i => ((2 * i.val + 1 : ℕ) : ZMod (2 ^ K))) hx
  rw [← hi]
  apply (ZMod.isUnit_iff_coprime _ _).mpr
  have hc : Nat.Coprime (2 * i.val + 1) 2 := by
    rw [Nat.coprime_comm, Nat.prime_two.coprime_iff_not_dvd]
    omega
  exact hc.pow_right K

theorem cyclicOddDigit_support_representatives {K b F : ℕ} (hb : 0 < b) (hF : 2 ^ b ≤ F) :
    ∀ x, cyclicOddDigit (K := K) b x ≠ 0 → ∃ S : ℕ,
      S ≤ 2 ^ b ∧ (S : ZMod (2 ^ K)) = x ∧ HasFactorialDivisorMultiset F S 1 := by
  intro x hx
  obtain ⟨i, hi, _⟩ := cyclicPushforward_support
    (fun _ : Fin (2 ^ (b - 1)) => ((2 ^ (b - 1) : ℕ) : ℂ)⁻¹)
    (fun i => ((2 * i.val + 1 : ℕ) : ZMod (2 ^ K))) hx
  have hp : 2 ^ b = 2 * 2 ^ (b - 1) := by
    rw [← pow_succ', Nat.sub_add_cancel hb]
  have hS : 2 * i.val + 1 ≤ 2 ^ b := by rw [hp]; omega
  exact ⟨2 * i.val + 1, hS, hi,
    factorial_multiset_singleton (Nat.dvd_factorial (by omega) (hS.trans hF))⟩

theorem dft_cyclicMultiplicativeConvolution_at_zero {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) :
    ZMod.dft (cyclicMultiplicativeConvolution f g) 0 = ZMod.dft f 0 * ZMod.dft g 0 := by
  rw [dft_cyclicMultiplicativeConvolution]
  simp only [mul_zero, ← Finset.sum_mul, ZMod.dft_apply_zero]
  ring

theorem dft_cyclicProductPow_at_zero {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (r : ℕ) : ZMod.dft (cyclicProductPow f r) 0 = (ZMod.dft f 0) ^ r := by
  induction r with
  | zero => simp [cyclicProductPow, ZMod.dft_apply_zero]
  | succ r ih =>
    rw [cyclicProductPow, dft_cyclicMultiplicativeConvolution_at_zero, ih, pow_succ]
    ring

theorem dft_cyclicBernoulliSmooth_at_zero {q : ℕ} [NeZero q] (f : ZMod q → ℂ) :
    ZMod.dft (cyclicBernoulliSmooth f) 0 = ZMod.dft f 0 := by
  rw [dft_cyclicBernoulliSmooth]
  simp

theorem cyclicBernoulliSmooth_support_representatives {q F u H : ℕ} [NeZero q]
    (f : ZMod q → ℂ)
    (hf : ∀ x, f x ≠ 0 → ∃ S : ℕ,
      S ≤ H ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset F S u) :
    ∀ x, cyclicBernoulliSmooth f x ≠ 0 → ∃ S : ℕ,
      S ≤ H + 1 ∧ (S : ZMod q) = x ∧ HasFactorialDivisorMultiset F S (u + 1) := by
  intro x hx
  by_cases hfx : f x = 0
  · have hother : f (x - 1) ≠ 0 := by
      intro h
      simp only [cyclicBernoulliSmooth, hfx, h, add_zero, zero_div, ne_eq, not_true_eq_false] at hx
    obtain ⟨S, hS, hScast, hrep⟩ := hf (x - 1) hother
    refine ⟨S + 1, Nat.add_le_add_right hS 1, ?_, ?_⟩
    · rw [Nat.cast_add, Nat.cast_one, hScast, sub_add_cancel]
    · exact factorial_multiset_add hrep (factorial_multiset_singleton (one_dvd _))
  · obtain ⟨S, hS, hScast, hrep⟩ := hf x hfx
    exact ⟨S, by omega, hScast, factorial_multiset_mono hrep le_rfl (by omega)⟩

theorem dft_smooth_product_zero_at_low_conductor {K b r : ℕ}
    (f : ZMod (2 ^ K) → ℂ) (hr : 0 < r)
    (hu : ∀ x, f x ≠ 0 → IsUnit x)
    (hf : ∀ x, 2 ≤ dyadicConductorLevel x → dyadicConductorLevel x ≤ b → ZMod.dft f x = 0)
    {k : ZMod (2 ^ K)} (hk : k ≠ 0) (hkhi : dyadicConductorLevel k ≤ b) :
    ZMod.dft (cyclicBernoulliSmooth (cyclicProductPow f r)) k = 0 := by
  by_cases hklo : 2 ≤ dyadicConductorLevel k
  · rw [dft_cyclicBernoulliSmooth, dft_cyclicProductPow_zero f hr hu hf hklo hkhi, zero_mul]
  · have hlevel : dyadicConductorLevel k = 1 := by
      have := dyadic_conductor_pos hk
      omega
    apply dft_cyclicBernoulliSmooth_zero _ hk
    have horder : addOrderOf k = 2 := by simpa only [hlevel, pow_one] using (dyadic_conductor_spec k).2
    simpa only [horder, nsmul_eq_mul, Nat.cast_ofNat] using addOrderOf_nsmul_eq_zero k

theorem exists_power_modular_representatives_of_product_decay {t : ℝ} (ht : 0 < t) :
    ∃ s : ℕ, 0 < s ∧ ∀ K b r F u : ℕ, 0 < r →
      ∀ f : ZMod (2 ^ K) → ℂ,
      ZMod.dft f 0 = 1 →
      (∀ x, f x ≠ 0 → IsUnit x) →
      (∀ x, 2 ≤ dyadicConductorLevel x → dyadicConductorLevel x ≤ b → ZMod.dft f x = 0) →
      (∀ x, b < dyadicConductorLevel x →
        ‖ZMod.dft (cyclicProductPow f r) x‖ ≤ (2 : ℝ) ^ (-t * (dyadicConductorLevel x : ℝ))) →
      (∀ x, f x ≠ 0 → ∃ S : ℕ,
        S ≤ 2 ^ K ∧ (S : ZMod (2 ^ K)) = x ∧ HasFactorialDivisorMultiset F S u) →
      2 * s ≤ 2 ^ K →
      HasBoundedModularRepresentatives (2 ^ K) (r * F) (s * (u ^ r + 1)) (r + 1) := by
  obtain ⟨s, hspos, hspower⟩ := exists_convolution_power_for_dyadic_decay ht
  refine ⟨s, hspos, ?_⟩
  intro K b r F u hr f hzero hunits hlow hhigh hsupport hheight
  let g := cyclicBernoulliSmooth (cyclicProductPow f r)
  have hdecay : ∀ x : ZMod (2 ^ K), x ≠ 0 →
      ‖ZMod.dft g x‖ ≤ (2 : ℝ) ^ (-t * (dyadicConductorLevel x : ℝ)) := by
    intro x hx
    by_cases hxlo : dyadicConductorLevel x ≤ b
    · have hz := dft_smooth_product_zero_at_low_conductor f hr hunits hlow hx hxlo
      change ‖ZMod.dft (cyclicBernoulliSmooth (cyclicProductPow f r)) x‖ ≤ _
      rw [hz, norm_zero]
      positivity
    · exact (norm_dft_cyclicBernoulliSmooth_le _ x).trans (hhigh x (by omega))
  have hgzero : ZMod.dft g 0 = 1 := by
    change ZMod.dft (cyclicBernoulliSmooth (cyclicProductPow f r)) 0 = 1
    rw [dft_cyclicBernoulliSmooth_at_zero, dft_cyclicProductPow_at_zero, hzero, one_pow]
  have hgsupport := cyclicBernoulliSmooth_support_representatives (cyclicProductPow f r)
    (cyclicProductPow_support_representatives f hsupport r)
  apply bounded_modular_representatives_of_fourier g hgzero (hspower K g hdecay) hgsupport
  have hqpow : 1 ≤ (2 ^ K) ^ r := Nat.one_le_pow r (2 ^ K) (by positivity)
  calc
    s * ((2 ^ K) ^ r + 1) ≤ s * (2 * (2 ^ K) ^ r) := Nat.mul_le_mul_left s (by omega)
    _ = (2 * s) * (2 ^ K) ^ r := by ring
    _ ≤ (2 ^ K) * (2 ^ K) ^ r := Nat.mul_le_mul_right _ hheight
    _ = (2 ^ K) ^ (r + 1) := (pow_succ' _ _).symm

def shortFactorialDigits (F l : ℕ) : Finset ℕ :=
  insert 0 (F.factorial.divisors.filter (fun d => d < 2 ^ l))

theorem mem_shortFactorialDigits {F l d : ℕ} :
    d ∈ shortFactorialDigits F l ↔ d < 2 ^ l ∧ (d = 0 ∨ d ∣ F.factorial) := by
  constructor
  · intro h
    rcases Finset.mem_insert.mp h with hz | hd
    · exact ⟨by rw [hz]; positivity, Or.inl hz⟩
    · obtain ⟨hdiv, hlt⟩ := Finset.mem_filter.mp hd
      exact ⟨hlt, Or.inr (Nat.dvd_of_mem_divisors hdiv)⟩
  · rintro ⟨hlt, hz | hdvd⟩
    · exact Finset.mem_insert.mpr (Or.inl hz)
    · exact Finset.mem_insert.mpr (Or.inr (Finset.mem_filter.mpr
        ⟨Nat.mem_divisors.mpr ⟨hdvd, Nat.factorial_ne_zero F⟩, hlt⟩))

theorem shortFactorialDigits_small_integers {F l : ℕ} :
    min (F + 1) (2 ^ l) ≤ (shortFactorialDigits F l).card := by
  have hsub : Finset.range (min (F + 1) (2 ^ l)) ⊆ shortFactorialDigits F l := by
    intro d hd
    have hdlt := Finset.mem_range.mp hd
    apply mem_shortFactorialDigits.mpr
    refine ⟨lt_of_lt_of_le hdlt (min_le_right _ _), ?_⟩
    by_cases hz : d = 0
    · exact Or.inl hz
    · exact Or.inr (Nat.dvd_factorial (by omega)
        (by have := min_le_left (F + 1) (2 ^ l); omega))
  simpa only [Finset.card_range] using Finset.card_le_card hsub

theorem prime_dvd_prime_product_iff {p : ℕ} (hp : Nat.Prime p)
    (s : Finset ℕ) (hs : ∀ q ∈ s, Nat.Prime q) :
    p ∣ s.prod id ↔ p ∈ s := by
  constructor
  · intro h
    obtain ⟨q, hq, hpq⟩ := (hp.prime.dvd_finsetProd_iff id).mp h
    have heq : q = p := (hs q hq).dvd_iff_eq hp.ne_one |>.mp hpq
    exact heq ▸ hq
  · exact Finset.dvd_prod_of_mem id

theorem prime_products_injective {s t : Finset ℕ}
    (hs : ∀ p ∈ s, Nat.Prime p) (ht : ∀ p ∈ t, Nat.Prime p)
    (heq : s.prod id = t.prod id) : s = t := by
  apply Finset.Subset.antisymm
  · intro p hp
    apply (prime_dvd_prime_product_iff (hs p hp) t ht).mp
    rw [← heq]
    exact Finset.dvd_prod_of_mem id hp
  · intro p hp
    apply (prime_dvd_prime_product_iff (ht p hp) s hs).mp
    rw [heq]
    exact Finset.dvd_prod_of_mem id hp

theorem prime_subset_product_dvd_factorial {F : ℕ} {s : Finset ℕ}
    (hs : s ⊆ Nat.primesLE F) : s.prod id ∣ F.factorial := by
  rw [← Finset.prod_Ico_id_eq_factorial F]
  apply Finset.prod_dvd_prod_of_subset s (Finset.Ico 1 (F + 1)) id
  intro p hp
  obtain ⟨hpF, hprime⟩ := Nat.mem_primesLE.mp (hs hp)
  exact Finset.mem_Ico.mpr ⟨by have := hprime.two_le; omega, by omega⟩

theorem shortFactorialDigits_choose_lower {F l v : ℕ} (hheight : F ^ v < 2 ^ l) :
    (Nat.primeCounting F).choose v ≤ (shortFactorialDigits F l).card := by
  have hmap : Set.MapsTo (fun s : Finset ℕ => s.prod id)
      ((Nat.primesLE F).powersetCard v) (shortFactorialDigits F l) := by
    intro s hs
    obtain ⟨hs, hcard⟩ := Finset.mem_powersetCard.mp hs
    apply mem_shortFactorialDigits.mpr
    refine ⟨?_, Or.inr (prime_subset_product_dvd_factorial hs)⟩
    have hprod : s.prod id ≤ F ^ v := by
      calc
        s.prod id ≤ ∏ _ ∈ s, F := Finset.prod_le_prod' (fun p hp => Nat.le_of_mem_primesLE (hs hp))
        _ = F ^ v := by rw [Finset.prod_const, hcard]
    exact hprod.trans_lt hheight
  have hinj : Set.InjOn (fun s : Finset ℕ => s.prod id) ((Nat.primesLE F).powersetCard v) := by
    intro s hs t ht heq
    apply prime_products_injective _ _ heq
    · intro p hp
      exact Nat.prime_of_mem_primesLE ((Finset.mem_powersetCard.mp hs).1 hp)
    · intro p hp
      exact Nat.prime_of_mem_primesLE ((Finset.mem_powersetCard.mp ht).1 hp)
  simpa only [Finset.card_powersetCard, Nat.primesLE_card_eq_primeCounting] using
    Finset.card_le_card_of_injOn _ hmap hinj

theorem choose_lower_half_ratio {n v : ℕ} (hv : 0 < v) (hvn : 2 * v ≤ n) :
    ((n : ℝ) / 2 / (v : ℝ)) ^ v ≤ (n.choose v : ℝ) := by
  have hvpos : (0 : ℝ) < v := by exact_mod_cast hv
  have hnsub : (n : ℝ) / 2 ≤ ((n + 1 - v : ℕ) : ℝ) := by
    rw [Nat.cast_sub (by omega : v ≤ n + 1), Nat.cast_add, Nat.cast_one]
    have hh : (2 : ℝ) * v ≤ n := by exact_mod_cast hvn
    linarith
  have hfac : (v.factorial : ℝ) ≤ (v : ℝ) ^ v := by exact_mod_cast Nat.factorial_le_pow v
  calc
    ((n : ℝ) / 2 / (v : ℝ)) ^ v = ((n : ℝ) / 2) ^ v / (v : ℝ) ^ v := div_pow _ _ _
    _ ≤ (((n + 1 - v : ℕ) : ℝ) ^ v) / (v : ℝ) ^ v := by
      exact div_le_div_of_nonneg_right (pow_le_pow_left₀ (by positivity) hnsub v) (by positivity)
    _ ≤ (((n + 1 - v : ℕ) : ℝ) ^ v) / (v.factorial : ℝ) :=
      div_le_div_of_nonneg_left (by positivity) (by positivity) hfac
    _ ≤ (n.choose v : ℝ) := Nat.pow_le_choose v n

theorem eventually_primeCounting_ge_rpow {σ : ℝ} (hσ : σ < 1) :
    ∀ᶠ n : ℕ in Filter.atTop, (n : ℝ) ^ σ ≤ (Nat.primeCounting n : ℝ) := by
  have hlogtwo : 0 < Real.log 2 := Real.log_pos (by norm_num)
  have hlog := (isLittleO_log_rpow_atTop (sub_pos.mpr hσ)).comp_tendsto
    (tendsto_natCast_atTop_atTop (R := ℝ))
  obtain ⟨M, hM⟩ := Filter.eventually_atTop.mp
    (Real.isLittleO_log_id_atTop.def (by positivity : (0 : ℝ) < Real.log 2 / 4))
  filter_upwards [hlog.def (by positivity : (0 : ℝ) < Real.log 2 / 2),
    (tendsto_natCast_atTop_atTop (R := ℝ)).eventually_ge_atTop M,
    eventually_ge_atTop (2 : ℕ)] with n hn hnM hn2
  have hnpos : (0 : ℝ) < n := by exact_mod_cast (show 0 < n by omega)
  have hnreal : (2 : ℝ) ≤ n := by exact_mod_cast hn2
  have hlogn : Real.log (n : ℝ) ≤ (Real.log 2 / 2) * (n : ℝ) ^ (1 - σ) := by
    have hh : |Real.log (n : ℝ)| ≤ (Real.log 2 / 2) * (n : ℝ) ^ (1 - σ) := by
      simpa only [Function.comp_apply, Real.norm_eq_abs,
        abs_of_nonneg (Real.rpow_nonneg (Nat.cast_nonneg n) (1 - σ))] using hn
    exact (le_abs_self _).trans hh
  have hlognext : Real.log ((n : ℝ) + 1) ≤ (Real.log 2 / 2) * n := by
    have hh := hM ((n : ℝ) + 1) (by linarith)
    have hh' : |Real.log ((n : ℝ) + 1)| ≤ (Real.log 2 / 4) * ((n : ℝ) + 1) := by
      simpa only [id_eq, Real.norm_eq_abs, abs_of_nonneg (by positivity : (0 : ℝ) ≤ n + 1)] using hh
    have hle := (le_abs_self _).trans hh'
    nlinarith
  have hpi := Chebyshev.pi_ge n
  have hlogpos : 0 < Real.log (n : ℝ) := Real.log_pos (by linarith)
  have hmain := (div_le_iff₀ hlogpos).mp hpi
  apply (mul_le_mul_iff_left₀
    (show 0 < (Real.log 2 / 2) * (n : ℝ) ^ (1 - σ) by positivity)).mp
  calc
    (n : ℝ) ^ σ * ((Real.log 2 / 2) * (n : ℝ) ^ (1 - σ)) = (Real.log 2 / 2) * n := by
      rw [mul_comm ((n : ℝ) ^ σ)]
      rw [mul_assoc, ← Real.rpow_add hnpos, sub_add_cancel, Real.rpow_one]
    _ ≤ (Nat.primeCounting n : ℝ) * Real.log (n : ℝ) := by linarith
    _ ≤ (Nat.primeCounting n : ℝ) * ((Real.log 2 / 2) * (n : ℝ) ^ (1 - σ)) :=
      mul_le_mul_of_nonneg_left hlogn (Nat.cast_nonneg _)

theorem half_binaryLength_rpow_le {F : ℕ} (hF : 2 ≤ F) :
    (2 : ℝ) ^ ((binaryLength F : ℝ) / 2) ≤ (F : ℝ) := by
  have hlog : 1 ≤ Nat.log 2 F := Nat.le_log_of_pow_le (by decide) (by simpa using hF)
  have hlen : (binaryLength F : ℝ) / 2 ≤ (Nat.log 2 F : ℝ) := by
    simp only [binaryLength, Nat.cast_add, Nat.cast_one]
    have hh : (1 : ℝ) ≤ Nat.log 2 F := by exact_mod_cast hlog
    linarith
  calc
    (2 : ℝ) ^ ((binaryLength F : ℝ) / 2) ≤ (2 : ℝ) ^ (Nat.log 2 F : ℝ) :=
      Real.rpow_le_rpow_of_exponent_le (by norm_num) hlen
    _ = ((2 ^ Nat.log 2 F : ℕ) : ℝ) := by simp
    _ ≤ (F : ℝ) := by exact_mod_cast Nat.pow_log_le_self 2 (by omega : F ≠ 0)

theorem shortFactorialDigits_uniform_lower {F k : ℕ} {δ : ℝ}
    (hF : 2 ≤ F) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hprimes : (2 * (k : ℝ)) * (F : ℝ) ^ δ ≤ (Nat.primeCounting F : ℝ)) :
    ∀ l : ℕ, 1 ≤ l → l ≤ k →
      (2 : ℝ) ^ (δ * (l : ℝ) / 8) ≤ (shortFactorialDigits F l).card := by
  intro l hlpos hlk
  let a := binaryLength F
  have ha : 0 < a := binaryLength_pos F
  have hFa : (2 : ℝ) ^ ((a : ℝ) / 2) ≤ (F : ℝ) := half_binaryLength_rpow_le hF
  by_cases hsmall : l ≤ 4 * a
  · have hsmallreal : (l : ℝ) ≤ 4 * (a : ℝ) := by exact_mod_cast hsmall
    have hfirst : (2 : ℝ) ^ (δ * (l : ℝ) / 8) ≤ (F + 1 : ℕ) := by
      calc
        (2 : ℝ) ^ (δ * (l : ℝ) / 8) ≤ (2 : ℝ) ^ ((a : ℝ) / 2) := by
          apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
          nlinarith [mul_le_mul_of_nonneg_right hδ1 (Nat.cast_nonneg l : (0 : ℝ) ≤ l)]
        _ ≤ (F : ℝ) := hFa
        _ ≤ (F + 1 : ℕ) := by exact_mod_cast Nat.le_succ F
    have hsecond : (2 : ℝ) ^ (δ * (l : ℝ) / 8) ≤ ((2 ^ l : ℕ) : ℝ) := by
      rw [Nat.cast_pow, Nat.cast_ofNat, ← Real.rpow_natCast]
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      nlinarith [mul_le_mul_of_nonneg_right hδ1 (Nat.cast_nonneg l : (0 : ℝ) ≤ l)]
    have hmin : (2 : ℝ) ^ (δ * (l : ℝ) / 8) ≤ (min (F + 1) (2 ^ l) : ℕ) := by
      rw [Nat.cast_min]
      exact le_min hfirst hsecond
    exact hmin.trans (by exact_mod_cast shortFactorialDigits_small_integers (F := F) (l := l))
  · let v := l / (2 * a)
    have hvpos : 0 < v := Nat.div_pos (by omega) (by omega)
    have hvle : v ≤ k := (Nat.div_le_self l (2 * a)).trans hlk
    have hmul : 2 * a * v ≤ l := Nat.mul_div_le l (2 * a)
    have hupper : l < 2 * a * (v + 1) := Nat.lt_mul_div_succ l (by omega)
    have halower : l ≤ 4 * a * v := by nlinarith
    have hheight : F ^ v < 2 ^ l := by
      calc
        F ^ v ≤ (2 ^ a) ^ v := Nat.pow_le_pow_left
          (Nat.lt_pow_succ_log_self (by decide : 1 < 2) F).le v
        _ = 2 ^ (a * v) := (pow_mul _ _ _).symm
        _ < 2 ^ l := Nat.pow_lt_pow_right (by decide : 1 < 2) (by nlinarith)
    have hFpow : 1 ≤ (F : ℝ) ^ δ := Real.one_le_rpow (by exact_mod_cast (show 1 ≤ F by omega)) hδ.le
    have htwov : 2 * v ≤ Nat.primeCounting F := by
      have hkr : (v : ℝ) ≤ k := by exact_mod_cast hvle
      have hk0 : (0 : ℝ) ≤ k := Nat.cast_nonneg k
      have hreal : 2 * (v : ℝ) ≤ (Nat.primeCounting F : ℝ) := by nlinarith
      exact_mod_cast hreal
    have hratio : (F : ℝ) ^ δ ≤ (Nat.primeCounting F : ℝ) / 2 / (v : ℝ) := by
      apply (le_div_iff₀ (by exact_mod_cast hvpos : (0 : ℝ) < v)).mpr
      apply (le_div_iff₀ (by norm_num : (0 : ℝ) < 2)).mpr
      have hkr : (v : ℝ) ≤ k := by exact_mod_cast hvle
      have hF0 : 0 ≤ (F : ℝ) ^ δ := by positivity
      nlinarith [mul_le_mul_of_nonneg_right hkr hF0]
    have halowerreal : (l : ℝ) ≤ 4 * (a : ℝ) * (v : ℝ) := by exact_mod_cast halower
    calc
      (2 : ℝ) ^ (δ * (l : ℝ) / 8) ≤ (2 : ℝ) ^ (((a : ℝ) / 2 * δ) * (v : ℝ)) := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        nlinarith [mul_le_mul_of_nonneg_left halowerreal hδ.le]
      _ = (((2 : ℝ) ^ ((a : ℝ) / 2)) ^ δ) ^ v := by
        rw [Real.rpow_mul_natCast (by norm_num), Real.rpow_mul (by norm_num)]
      _ ≤ ((F : ℝ) ^ δ) ^ v :=
        pow_le_pow_left₀ (by positivity) (Real.rpow_le_rpow (by positivity) hFa hδ.le) v
      _ ≤ ((Nat.primeCounting F : ℝ) / 2 / (v : ℝ)) ^ v :=
        pow_le_pow_left₀ (by positivity) hratio v
      _ ≤ ((Nat.primeCounting F).choose v : ℝ) := choose_lower_half_ratio hvpos htwov
      _ ≤ (shortFactorialDigits F l).card := by exact_mod_cast shortFactorialDigits_choose_lower hheight

noncomputable def factorialDigitHost (a : ℝ) (k : ℕ) : ℕ := ⌈(k : ℝ) ^ a⌉₊

theorem factorialDigitHost_tendsto {a : ℝ} (ha : 0 < a) :
    Filter.Tendsto (factorialDigitHost a) Filter.atTop Filter.atTop := by
  have hp := (tendsto_rpow_atTop ha).comp (tendsto_natCast_atTop_atTop (R := ℝ))
  apply Filter.tendsto_atTop.mpr
  intro M
  filter_upwards [hp.eventually_ge_atTop (M : ℝ)] with k hk
  have hh : (M : ℝ) ≤ (k : ℝ) ^ a := hk
  exact_mod_cast hh.trans (Nat.le_ceil _)

theorem factorialDigitHost_le {a : ℝ} {k : ℕ} (ha : 0 ≤ a) (hk : 1 ≤ k) :
    (factorialDigitHost a k : ℝ) ≤ 2 * (k : ℝ) ^ a := by
  have hone : 1 ≤ (k : ℝ) ^ a := Real.one_le_rpow (by exact_mod_cast hk) ha
  have hceil := Nat.ceil_lt_add_one (Real.rpow_nonneg (Nat.cast_nonneg k) a)
  change (⌈(k : ℝ) ^ a⌉₊ : ℝ) ≤ _
  linarith

theorem shortFactorialDigits_uniform_asymptotic {a : ℝ} (ha : 1 < a) :
    ∃ c : ℝ, 0 < c ∧ ∀ᶠ k : ℕ in Filter.atTop,
      (factorialDigitHost a k : ℝ) ≤ 2 * (k : ℝ) ^ a ∧
      ∀ l : ℕ, 1 ≤ l → l ≤ k →
        (2 : ℝ) ^ (c * (l : ℝ)) ≤ (shortFactorialDigits (factorialDigitHost a k) l).card := by
  let δ : ℝ := (a - 1) / (4 * a)
  let σ : ℝ := 1 - δ
  have hapos : 0 < a := by linarith
  have hδ : 0 < δ := div_pos (by linarith) (by positivity)
  have hδquarter : δ ≤ 1 / 4 := by
    dsimp [δ]
    apply (div_le_iff₀ (by positivity : (0 : ℝ) < 4 * a)).mpr
    linarith
  have hδeq : 4 * a * δ = a - 1 := by
    dsimp [δ]
    field_simp
  have hσ : σ < 1 := by dsimp [σ]; linarith
  have hgap : 0 < σ - δ := by dsimp [σ]; linarith
  have hexponent : 1 < a * (σ - δ) := by
    dsimp [σ]
    nlinarith
  have hhost := factorialDigitHost_tendsto hapos
  have hprime := hhost.eventually (eventually_primeCounting_ge_rpow hσ)
  have hpower := eventually_const_mul_rpow_le (C := 2) (E := 1) hexponent (by norm_num)
  refine ⟨δ / 8, by positivity, ?_⟩
  filter_upwards [hprime, hpower, hhost.eventually_ge_atTop 2, eventually_ge_atTop (1 : ℕ)]
    with k hkprime hkpower hkhost hkone
  refine ⟨factorialDigitHost_le hapos.le hkone, ?_⟩
  have hFpos : (0 : ℝ) < factorialDigitHost a k := by exact_mod_cast (show 0 < factorialDigitHost a k by omega)
  have h2k : 2 * (k : ℝ) ≤ (factorialDigitHost a k : ℝ) ^ (σ - δ) := by
    calc
      2 * (k : ℝ) ≤ (k : ℝ) ^ (a * (σ - δ)) := by
        simpa only [Real.rpow_one, one_mul] using hkpower
      _ = ((k : ℝ) ^ a) ^ (σ - δ) := Real.rpow_mul (Nat.cast_nonneg k) _ _
      _ ≤ (factorialDigitHost a k : ℝ) ^ (σ - δ) :=
        Real.rpow_le_rpow (by positivity) (Nat.le_ceil _) hgap.le
  have hprimes : (2 * (k : ℝ)) * (factorialDigitHost a k : ℝ) ^ δ ≤
      (Nat.primeCounting (factorialDigitHost a k) : ℝ) := by
    calc
      _ ≤ (factorialDigitHost a k : ℝ) ^ (σ - δ) * (factorialDigitHost a k : ℝ) ^ δ :=
        mul_le_mul_of_nonneg_right h2k (by positivity)
      _ = (factorialDigitHost a k : ℝ) ^ σ := by rw [← Real.rpow_add hFpos, sub_add_cancel]
      _ ≤ _ := hkprime
  intro l hl hlk
  have hh := shortFactorialDigits_uniform_lower hkhost hδ (by linarith : δ ≤ 1) hprimes l hl hlk
  convert hh using 1
  congr 1
  ring

def binaryAppend (A D : Finset ℕ) (b : ℕ) : Finset ℕ :=
  (A ×ˢ D).image (fun p => p.1 + 2 ^ b * p.2)

def natResidueFiber (A : Finset ℕ) (q r : ℕ) : Finset ℕ :=
  A.filter (fun x => Nat.ModEq q x r)

noncomputable def natResidueMass (A : Finset ℕ) (q r : ℕ) : ℝ :=
  ((natResidueFiber A q r).card : ℝ) / (A.card : ℝ)

theorem binary_append_injective {A D : Finset ℕ} {b : ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ b) :
    Set.InjOn (fun p : ℕ × ℕ => p.1 + 2 ^ b * p.2) (A ×ˢ D : Finset (ℕ × ℕ)) := by
  intro p hp s hs heq
  change p.1 + 2 ^ b * p.2 = s.1 + 2 ^ b * s.2 at heq
  have hpA := hA p.1 (Finset.mem_product.mp hp).1
  have hsA := hA s.1 (Finset.mem_product.mp hs).1
  have hmod := congrArg (fun n => n % (2 ^ b)) heq
  simp only [Nat.add_mul_mod_self_left, Nat.mod_eq_of_lt hpA, Nat.mod_eq_of_lt hsA] at hmod
  have hmul : 2 ^ b * p.2 = 2 ^ b * s.2 := by omega
  have hright := Nat.eq_of_mul_eq_mul_left (by positivity : 0 < 2 ^ b) hmul
  exact Prod.ext hmod hright

theorem binary_append_card {A D : Finset ℕ} {b : ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ b) : (binaryAppend A D b).card = A.card * D.card := by
  rw [binaryAppend, Finset.card_image_of_injOn (binary_append_injective hA), Finset.card_product]

theorem binary_append_nonempty {A D : Finset ℕ} {b : ℕ}
    (hA : A.Nonempty) (hD : D.Nonempty) : (binaryAppend A D b).Nonempty := by
  exact (hA.product hD).image _

theorem binary_append_lt {A D : Finset ℕ} {b l : ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ b) (hD : ∀ d ∈ D, d < 2 ^ l) :
    ∀ x ∈ binaryAppend A D b, x < 2 ^ (b + l) := by
  intro x hx
  obtain ⟨⟨a, d⟩, had, rfl⟩ := Finset.mem_image.mp hx
  have ha := hA a (Finset.mem_product.mp had).1
  have hd := hD d (Finset.mem_product.mp had).2
  rw [pow_add]
  nlinarith [mul_le_mul_of_nonneg_left (show d + 1 ≤ 2 ^ l by omega) (Nat.zero_le (2 ^ b))]

theorem nat_residue_fiber_mono_modulus {A : Finset ℕ} {q Q r : ℕ} (hq : q ∣ Q) :
    natResidueFiber A Q r ⊆ natResidueFiber A q r := by
  intro x hx
  obtain ⟨hx, hmod⟩ := Finset.mem_filter.mp hx
  exact Finset.mem_filter.mpr ⟨hx, hmod.of_dvd hq⟩

theorem nat_residue_fiber_card_le_one {A : Finset ℕ} {q r : ℕ}
    (hA : ∀ x ∈ A, x < q) : (natResidueFiber A q r).card ≤ 1 := by
  apply Finset.card_le_one.mpr
  intro x hx y hy
  obtain ⟨hxA, hxmod⟩ := Finset.mem_filter.mp hx
  obtain ⟨hyA, hymod⟩ := Finset.mem_filter.mp hy
  have hxy := hxmod.trans hymod.symm
  simpa only [Nat.ModEq, Nat.mod_eq_of_lt (hA x hxA), Nat.mod_eq_of_lt (hA y hyA)] using hxy

theorem binary_append_residue_fiber {A D : Finset ℕ} {b q r : ℕ} (hq : q ∣ 2 ^ b) :
    natResidueFiber (binaryAppend A D b) q r = binaryAppend (natResidueFiber A q r) D b := by
  have hequiv (a d : ℕ) : Nat.ModEq q (a + 2 ^ b * d) r ↔ Nat.ModEq q a r := by
    have hh : Nat.ModEq q (a + 2 ^ b * d) a := by
      simpa only [add_zero] using (Nat.ModEq.refl a).add ((hq.trans (dvd_mul_right _ _)).modEq_zero_nat)
    exact ⟨fun h => hh.symm.trans h, fun h => hh.trans h⟩
  ext x
  constructor
  · intro hx
    obtain ⟨hx, hm⟩ := Finset.mem_filter.mp hx
    obtain ⟨⟨a, d⟩, had, rfl⟩ := Finset.mem_image.mp hx
    exact Finset.mem_image.mpr ⟨(a, d), Finset.mem_product.mpr
      ⟨Finset.mem_filter.mpr ⟨(Finset.mem_product.mp had).1, (hequiv a d).mp hm⟩,
        (Finset.mem_product.mp had).2⟩, rfl⟩
  · intro hx
    obtain ⟨⟨a, d⟩, had, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨ha, hd⟩ := Finset.mem_product.mp had
    obtain ⟨ha, hm⟩ := Finset.mem_filter.mp ha
    exact Finset.mem_filter.mpr ⟨Finset.mem_image.mpr ⟨(a, d), Finset.mem_product.mpr ⟨ha, hd⟩, rfl⟩,
      (hequiv a d).mpr hm⟩

theorem binary_append_residue_fiber_card {A D : Finset ℕ} {b q r : ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ b) (hq : q ∣ 2 ^ b) :
    (natResidueFiber (binaryAppend A D b) q r).card = (natResidueFiber A q r).card * D.card := by
  rw [binary_append_residue_fiber hq]
  exact binary_append_card (fun x hx => hA x (Finset.mem_filter.mp hx).1)

theorem binary_append_residue_mass {A D : Finset ℕ} {b q r : ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ b) (hD : D.Nonempty) (hq : q ∣ 2 ^ b) :
    natResidueMass (binaryAppend A D b) q r = natResidueMass A q r := by
  have hDc : (D.card : ℝ) ≠ 0 := by exact_mod_cast Finset.card_ne_zero.mpr hD
  unfold natResidueMass
  rw [binary_append_residue_fiber_card hA hq, binary_append_card hA, Nat.cast_mul, Nat.cast_mul]
  exact mul_div_mul_right _ _ hDc

theorem binary_append_residue_mass_high {A D : Finset ℕ} {b j r : ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ b) (hne : A.Nonempty) (hD : D.Nonempty) (hj : b ≤ j) :
    natResidueMass (binaryAppend A D b) (2 ^ j) r ≤ 1 / (A.card : ℝ) := by
  have hAc : (0 : ℝ) < A.card := by exact_mod_cast Finset.card_pos.mpr hne
  calc
    natResidueMass (binaryAppend A D b) (2 ^ j) r ≤
        natResidueMass (binaryAppend A D b) (2 ^ b) r := by
      apply div_le_div_of_nonneg_right _ (Nat.cast_nonneg _)
      exact_mod_cast Finset.card_le_card (nat_residue_fiber_mono_modulus (pow_dvd_pow 2 hj))
    _ = natResidueMass A (2 ^ b) r := binary_append_residue_mass hA hD (dvd_refl _)
    _ ≤ 1 / (A.card : ℝ) := by
      apply div_le_div_of_nonneg_right _ hAc.le
      exact_mod_cast nat_residue_fiber_card_le_one hA

theorem nat_residue_fiber_range_card_le {q N r : ℕ} (hq : 0 < q) :
    (natResidueFiber (Finset.range (q * N)) q r).card ≤ N := by
  have hmap : Set.MapsTo (fun x : ℕ => x / q)
      (natResidueFiber (Finset.range (q * N)) q r) (Finset.range N) := by
    intro x hx
    have hxlt := Finset.mem_range.mp (Finset.mem_filter.mp hx).1
    exact Finset.mem_range.mpr ((Nat.div_lt_iff_lt_mul hq).mpr (by simpa only [mul_comm] using hxlt))
  have hinj : Set.InjOn (fun x : ℕ => x / q)
      (natResidueFiber (Finset.range (q * N)) q r) := by
    intro x hx y hy heq
    change x / q = y / q at heq
    have hmod := (Finset.mem_filter.mp hx).2.trans (Finset.mem_filter.mp hy).2.symm
    change x % q = y % q at hmod
    have hxdiv := Nat.mod_add_div x q
    have hydiv := Nat.mod_add_div y q
    rw [heq, hmod] at hxdiv
    omega
  simpa only [Finset.card_range] using Finset.card_le_card_of_injOn _ hmap hinj

theorem nat_residue_fiber_bounded_card_le {A : Finset ℕ} {b j r : ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ b) (hj : j ≤ b) :
    (natResidueFiber A (2 ^ j) r).card ≤ 2 ^ (b - j) := by
  have hpow : 2 ^ b = 2 ^ j * 2 ^ (b - j) := by rw [← pow_add, Nat.add_sub_of_le hj]
  have hsub : natResidueFiber A (2 ^ j) r ⊆ natResidueFiber (Finset.range (2 ^ b)) (2 ^ j) r := by
    intro x hx
    obtain ⟨hxA, hmod⟩ := Finset.mem_filter.mp hx
    exact Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (hA x hxA), hmod⟩
  refine (Finset.card_le_card hsub).trans ?_
  rw [hpow]
  exact nat_residue_fiber_range_card_le (by positivity)

def initialOddDigits (b : ℕ) : Finset ℕ :=
  (Finset.range (2 ^ (b - 1))).image (fun i => 2 * i + 1)

theorem initial_odd_digits_card (b : ℕ) : (initialOddDigits b).card = 2 ^ (b - 1) := by
  rw [initialOddDigits, Finset.card_image_of_injective]
  · exact Finset.card_range _
  · intro x y h
    change 2 * x + 1 = 2 * y + 1 at h
    omega

theorem initial_odd_digits_nonempty (b : ℕ) : (initialOddDigits b).Nonempty := by
  apply Finset.card_pos.mp
  rw [initial_odd_digits_card]
  positivity

theorem initial_odd_digits_lt {b : ℕ} (hb : 0 < b) :
    ∀ x ∈ initialOddDigits b, x < 2 ^ b := by
  intro x hx
  obtain ⟨i, hi, rfl⟩ := Finset.mem_image.mp hx
  have hi := Finset.mem_range.mp hi
  have hp : 2 ^ b = 2 * 2 ^ (b - 1) := by rw [← pow_succ', Nat.sub_add_cancel hb]
  rw [hp]
  omega

theorem initial_odd_digits_odd {b x : ℕ} (hx : x ∈ initialOddDigits b) : Odd x := by
  obtain ⟨i, _, rfl⟩ := Finset.mem_image.mp hx
  exact ⟨i, by ring⟩

theorem initial_odd_digits_entropy {b : ℕ} {c : ℝ} (hb : 2 ≤ b) (hc : c ≤ 1 / 2) :
    (2 : ℝ) ^ (c * (b : ℝ)) ≤ (initialOddDigits b).card := by
  rw [initial_odd_digits_card, Nat.cast_pow, Nat.cast_ofNat, ← Real.rpow_natCast]
  apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
  rw [Nat.cast_sub (by omega : 1 ≤ b), Nat.cast_one]
  have hbr : (2 : ℝ) ≤ b := by exact_mod_cast hb
  nlinarith [mul_le_mul_of_nonneg_right hc (Nat.cast_nonneg b : (0 : ℝ) ≤ b)]

theorem initial_odd_digits_spread {b j r : ℕ} {c : ℝ}
    (hb : 2 ≤ b) (hj : 2 ≤ j) (hjb : j ≤ b) (hc : c ≤ 1) :
    natResidueMass (initialOddDigits b) (2 ^ j) r ≤ (2 : ℝ) ^ (-(c / 2) * (j : ℝ)) := by
  have hcard := nat_residue_fiber_bounded_card_le (r := r)
    (initial_odd_digits_lt (by omega : 0 < b)) hjb
  unfold natResidueMass
  rw [initial_odd_digits_card]
  calc
    ((natResidueFiber (initialOddDigits b) (2 ^ j) r).card : ℝ) / ((2 ^ (b - 1) : ℕ) : ℝ) ≤
        ((2 ^ (b - j) : ℕ) : ℝ) / ((2 ^ (b - 1) : ℕ) : ℝ) := by
      apply div_le_div_of_nonneg_right _ (by positivity)
      exact_mod_cast hcard
    _ = (2 : ℝ) ^ (1 - (j : ℝ)) := by
      simp only [Nat.cast_pow, Nat.cast_ofNat, ← Real.rpow_natCast,
        ← Real.rpow_sub (by norm_num : (0 : ℝ) < 2), Nat.cast_sub hjb,
        Nat.cast_sub (by omega : 1 ≤ b), Nat.cast_one]
      congr 1
      ring
    _ ≤ (2 : ℝ) ^ (-(c / 2) * (j : ℝ)) := by
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      have hjr : (2 : ℝ) ≤ j := by exact_mod_cast hj
      nlinarith [mul_le_mul_of_nonneg_right hc (Nat.cast_nonneg j : (0 : ℝ) ≤ j)]

theorem binary_append_entropy {A D : Finset ℕ} {b l : ℕ} {c : ℝ}
    (hA : ∀ x ∈ A, x < 2 ^ b)
    (hcA : (2 : ℝ) ^ (c * (b : ℝ)) ≤ A.card)
    (hcD : (2 : ℝ) ^ (c * (l : ℝ)) ≤ D.card) :
    (2 : ℝ) ^ (c * ((b + l : ℕ) : ℝ)) ≤ (binaryAppend A D b).card := by
  rw [binary_append_card hA, Nat.cast_mul, Nat.cast_add, mul_add, Real.rpow_add (by norm_num)]
  exact mul_le_mul hcA hcD (by positivity) (Nat.cast_nonneg _)

theorem binary_append_spread {A D : Finset ℕ} {b l : ℕ} {c : ℝ}
    (hA : ∀ x ∈ A, x < 2 ^ b) (hne : A.Nonempty) (hD : D.Nonempty)
    (hl : l ≤ b) (hc : 0 ≤ c)
    (hcA : (2 : ℝ) ^ (c * (b : ℝ)) ≤ A.card)
    (hspread : ∀ j : ℕ, 2 ≤ j → j ≤ b → ∀ r : ℕ,
      natResidueMass A (2 ^ j) r ≤ (2 : ℝ) ^ (-(c / 2) * (j : ℝ))) :
    ∀ j : ℕ, 2 ≤ j → j ≤ b + l → ∀ r : ℕ,
      natResidueMass (binaryAppend A D b) (2 ^ j) r ≤ (2 : ℝ) ^ (-(c / 2) * (j : ℝ)) := by
  intro j hj hjbl r
  by_cases hjb : j ≤ b
  · rw [binary_append_residue_mass hA hD (pow_dvd_pow 2 hjb)]
    exact hspread j hj hjb r
  · calc
      natResidueMass (binaryAppend A D b) (2 ^ j) r ≤ 1 / (A.card : ℝ) :=
        binary_append_residue_mass_high hA hne hD (by omega)
      _ ≤ 1 / (2 : ℝ) ^ (c * (b : ℝ)) :=
        one_div_le_one_div_of_le (by positivity) hcA
      _ = (2 : ℝ) ^ (-(c * (b : ℝ))) := by rw [Real.rpow_neg (by norm_num), one_div]
      _ ≤ (2 : ℝ) ^ (-(c / 2) * (j : ℝ)) := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        have hltwo : (j : ℝ) ≤ 2 * (b : ℝ) := by exact_mod_cast (show j ≤ 2 * b by omega)
        nlinarith [mul_le_mul_of_nonneg_left hltwo hc]

theorem short_factorial_digits_nonempty (F l : ℕ) : (shortFactorialDigits F l).Nonempty := by
  exact ⟨0, Finset.mem_insert_self _ _⟩

theorem short_factorial_digits_entropy {F K : ℕ} {c : ℝ}
    (h : ∀ l : ℕ, 1 ≤ l → l ≤ K → (2 : ℝ) ^ (c * (l : ℝ)) ≤ (shortFactorialDigits F l).card)
    {l : ℕ} (hl : l ≤ K) : (2 : ℝ) ^ (c * (l : ℝ)) ≤ (shortFactorialDigits F l).card := by
  by_cases hz : l = 0
  · subst l
    simp only [Nat.cast_zero, mul_zero, Real.rpow_zero]
    exact_mod_cast Finset.card_pos.mpr (short_factorial_digits_nonempty F 0)
  · exact h l (by omega) hl

theorem binary_append_odd {A D : Finset ℕ} {b : ℕ} (hb : 0 < b)
    (hA : ∀ x ∈ A, Odd x) : ∀ x ∈ binaryAppend A D b, Odd x := by
  intro x hx
  obtain ⟨⟨a, d⟩, had, rfl⟩ := Finset.mem_image.mp hx
  exact (hA a (Finset.mem_product.mp had).1).add_even
    ((even_two.pow_of_ne_zero (Nat.ne_of_gt hb)).mul_right d)

theorem binary_append_representations {A : Finset ℕ} {F K b l u : ℕ} (hb : b ≤ K)
    (hA : ∀ x ∈ A, HasFactorialDivisorMultiset (F + 2 * K) x u) :
    ∀ x ∈ binaryAppend A (shortFactorialDigits F l) b,
      HasFactorialDivisorMultiset (F + 2 * K) x (u + 1) := by
  intro x hx
  obtain ⟨⟨a, d⟩, had, rfl⟩ := Finset.mem_image.mp hx
  obtain ⟨ha, hd⟩ := Finset.mem_product.mp had
  apply factorial_multiset_add (hA a ha)
  rcases (mem_shortFactorialDigits.mp hd).2 with hz | hdiv
  · rw [hz, mul_zero]
    exact factorial_multiset_zero _ _
  · exact factorial_multiset_singleton (shifted_divisor_dvd_factorial hdiv hb)

structure BinaryBlockProfile (F K b u : ℕ) (c : ℝ) (A : Finset ℕ) : Prop where
  nonempty : A.Nonempty
  bounded : ∀ x ∈ A, x < 2 ^ b
  odd : ∀ x ∈ A, Odd x
  representatives : ∀ x ∈ A, HasFactorialDivisorMultiset (F + 2 * K) x u
  entropy : (2 : ℝ) ^ (c * (b : ℝ)) ≤ A.card
  spread : ∀ j : ℕ, 2 ≤ j → j ≤ b → ∀ r : ℕ,
    natResidueMass A (2 ^ j) r ≤ (2 : ℝ) ^ (-(c / 2) * (j : ℝ))

theorem initial_odd_digits_profile {F K b : ℕ} {c : ℝ}
    (hb : 2 ≤ b) (hF : 2 ^ b ≤ F) (hc : c ≤ 1 / 2) :
    BinaryBlockProfile F K b 1 c (initialOddDigits b) := by
  refine ⟨initial_odd_digits_nonempty b, initial_odd_digits_lt (by omega),
    fun _ hx => initial_odd_digits_odd hx, ?_, initial_odd_digits_entropy hb hc, ?_⟩
  · intro x hx
    have hodd := initial_odd_digits_odd hx
    have hpos : 0 < x := by obtain ⟨t, ht⟩ := hodd; omega
    exact factorial_multiset_singleton (Nat.dvd_factorial hpos
      (by have := initial_odd_digits_lt (by omega : 0 < b) x hx; omega))
  · intro j hj hjb r
    exact initial_odd_digits_spread hb hj hjb (by linarith)

theorem binary_append_profile {F K b l u : ℕ} {c : ℝ} {A : Finset ℕ}
    (hA : BinaryBlockProfile F K b u c A) (hb : 0 < b) (hbK : b ≤ K) (hl : l ≤ b) (hc : 0 ≤ c)
    (hD : (2 : ℝ) ^ (c * (l : ℝ)) ≤ (shortFactorialDigits F l).card) :
    BinaryBlockProfile F K (b + l) (u + 1) c (binaryAppend A (shortFactorialDigits F l) b) := by
  refine ⟨binary_append_nonempty hA.nonempty (short_factorial_digits_nonempty F l),
    binary_append_lt hA.bounded (fun _ hd => (mem_shortFactorialDigits.mp hd).1),
    binary_append_odd hb hA.odd, binary_append_representations hbK hA.representatives,
    binary_append_entropy hA.bounded hA.entropy hD, ?_⟩
  exact binary_append_spread hA.bounded hA.nonempty (short_factorial_digits_nonempty F l)
    hl hc hA.entropy hA.spread

def binaryBlockEndpoint (K b₀ i : ℕ) : ℕ := min K (2 ^ i * b₀)

def binaryBlockWidth (K b₀ i : ℕ) : ℕ := binaryBlockEndpoint K b₀ (i + 1) - binaryBlockEndpoint K b₀ i

def binaryBlockSet (F K b₀ : ℕ) : ℕ → Finset ℕ
  | 0 => initialOddDigits b₀
  | i + 1 => binaryAppend (binaryBlockSet F K b₀ i)
      (shortFactorialDigits F (binaryBlockWidth K b₀ i)) (binaryBlockEndpoint K b₀ i)

theorem binary_block_endpoint_zero {K b₀ : ℕ} (hb : b₀ ≤ K) : binaryBlockEndpoint K b₀ 0 = b₀ := by
  simp only [binaryBlockEndpoint, pow_zero, one_mul, min_eq_right hb]

theorem binary_block_endpoint_bounds {K b₀ : ℕ} (hb : b₀ ≤ K) (i : ℕ) :
    b₀ ≤ binaryBlockEndpoint K b₀ i ∧ binaryBlockEndpoint K b₀ i ≤ K := by
  refine ⟨le_min hb ?_, min_le_left _ _⟩
  nlinarith [show 1 ≤ 2 ^ i from Nat.one_le_two_pow]

theorem binary_block_endpoint_mono (K b₀ i : ℕ) :
    binaryBlockEndpoint K b₀ i ≤ binaryBlockEndpoint K b₀ (i + 1) := by
  apply min_le_min_left
  exact Nat.mul_le_mul_right b₀ (Nat.pow_le_pow_right (by decide : 0 < 2) (by omega))

theorem binary_block_endpoint_succ_le_twice (K b₀ i : ℕ) :
    binaryBlockEndpoint K b₀ (i + 1) ≤ 2 * binaryBlockEndpoint K b₀ i := by
  unfold binaryBlockEndpoint
  by_cases h : 2 ^ i * b₀ ≤ K
  · rw [min_eq_right h]
    calc
      min K (2 ^ (i + 1) * b₀) ≤ 2 ^ (i + 1) * b₀ := min_le_right _ _
      _ = 2 * (2 ^ i * b₀) := by rw [pow_succ]; ring
  · rw [min_eq_left (by omega : K ≤ 2 ^ i * b₀)]
    exact (min_le_left _ _).trans (by omega)

theorem binary_block_width_add (K b₀ i : ℕ) :
    binaryBlockEndpoint K b₀ i + binaryBlockWidth K b₀ i = binaryBlockEndpoint K b₀ (i + 1) := by
  exact Nat.add_sub_of_le (binary_block_endpoint_mono K b₀ i)

theorem binary_block_width_le (K b₀ i : ℕ) :
    binaryBlockWidth K b₀ i ≤ binaryBlockEndpoint K b₀ i := by
  have := binary_block_endpoint_succ_le_twice K b₀ i
  unfold binaryBlockWidth
  omega

theorem binary_block_endpoint_top {K b₀ : ℕ} (hb : 1 ≤ b₀) :
    binaryBlockEndpoint K b₀ (binaryLength K) = K := by
  apply min_eq_left
  have hK : K < 2 ^ binaryLength K := Nat.lt_pow_succ_log_self (by decide : 1 < 2) K
  nlinarith

theorem binary_block_set_profile {F K b₀ : ℕ} {c : ℝ}
    (hb : 2 ≤ b₀) (hbK : b₀ ≤ K) (hF : 2 ^ b₀ ≤ F) (hc : 0 ≤ c) (hcsmall : c ≤ 1 / 2)
    (hD : ∀ l : ℕ, 1 ≤ l → l ≤ K → (2 : ℝ) ^ (c * (l : ℝ)) ≤ (shortFactorialDigits F l).card) :
    ∀ i : ℕ, BinaryBlockProfile F K (binaryBlockEndpoint K b₀ i) (i + 1) c (binaryBlockSet F K b₀ i) := by
  intro i
  induction i with
  | zero =>
    rw [binary_block_endpoint_zero hbK]
    exact initial_odd_digits_profile hb hF hcsmall
  | succ i ih =>
    have hbds := binary_block_endpoint_bounds hbK i
    have hw := binary_block_width_le K b₀ i
    have hstep := binary_append_profile ih (by omega) hbds.2 hw hc
      (short_factorial_digits_entropy hD (hw.trans hbds.2))
    rw [binary_block_width_add] at hstep
    exact hstep

theorem binary_block_set_profile_top {F K b₀ : ℕ} {c : ℝ}
    (hb : 2 ≤ b₀) (hbK : b₀ ≤ K) (hF : 2 ^ b₀ ≤ F) (hc : 0 ≤ c) (hcsmall : c ≤ 1 / 2)
    (hD : ∀ l : ℕ, 1 ≤ l → l ≤ K → (2 : ℝ) ^ (c * (l : ℝ)) ≤ (shortFactorialDigits F l).card) :
    BinaryBlockProfile F K K (binaryLength K + 1) c (binaryBlockSet F K b₀ (binaryLength K)) := by
  have h := binary_block_set_profile hb hbK hF hc hcsmall hD (binaryLength K)
  rwa [binary_block_endpoint_top (by omega : 1 ≤ b₀)] at h

noncomputable def cyclicUniformNatSet {q : ℕ} [NeZero q] (A : Finset ℕ) : ZMod q → ℂ :=
  cyclicPushforward (fun _ : A => (A.card : ℂ)⁻¹) (fun n => (n.val : ZMod q))

theorem dft_cyclicUniformNatSet {q : ℕ} [NeZero q] (A : Finset ℕ) (k : ZMod q) :
    ZMod.dft (cyclicUniformNatSet A) k =
      (∑ n ∈ A, ZMod.stdAddChar (-((n : ZMod q) * k))) * (A.card : ℂ)⁻¹ := by
  rw [cyclicUniformNatSet, dft_cyclicPushforward, ← Finset.sum_mul]
  congr 1
  exact Finset.sum_coe_sort A (fun n => ZMod.stdAddChar (-((n : ZMod q) * k)))

theorem dft_cyclicUniformNatSet_at_zero {q : ℕ} [NeZero q] {A : Finset ℕ} (hA : A.Nonempty) :
    ZMod.dft (cyclicUniformNatSet (q := q) A) 0 = 1 := by
  rw [dft_cyclicUniformNatSet]
  have hcard : (A.card : ℂ) ≠ 0 := by exact_mod_cast Finset.card_ne_zero.mpr hA
  simp [hcard]

theorem cyclicUniformNatSet_support {q : ℕ} [NeZero q] (A : Finset ℕ) {x : ZMod q}
    (hx : cyclicUniformNatSet A x ≠ 0) : ∃ n ∈ A, (n : ZMod q) = x := by
  obtain ⟨n, hn, _⟩ := cyclicPushforward_support (fun _ : A => (A.card : ℂ)⁻¹)
    (fun n => (n.val : ZMod q)) hx
  exact ⟨n.val, n.property, hn⟩

theorem dft_binary_append {q b : ℕ} [NeZero q] {A D : Finset ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ b) (k : ZMod q) :
    ZMod.dft (cyclicUniformNatSet (binaryAppend A D b)) k =
      ZMod.dft (cyclicUniformNatSet A) k *
      ((∑ d ∈ D, ZMod.stdAddChar (-(((2 ^ b * d : ℕ) : ZMod q) * k))) * (D.card : ℂ)⁻¹) := by
  classical
  rw [dft_cyclicUniformNatSet, binary_append_card hA, Nat.cast_mul, mul_inv_rev,
    dft_cyclicUniformNatSet]
  unfold binaryAppend
  rw [Finset.sum_image (binary_append_injective hA), Finset.sum_product]
  have hchar (a d : ℕ) : ZMod.stdAddChar (-(((a + 2 ^ b * d : ℕ) : ZMod q) * k)) =
      ZMod.stdAddChar (-((a : ZMod q) * k)) * ZMod.stdAddChar (-(((2 ^ b * d : ℕ) : ZMod q) * k)) := by
    rw [← AddChar.map_add_eq_mul]
    congr 1
    push_cast
    ring
  simp_rw [hchar, ← Finset.mul_sum, ← Finset.sum_mul]
  ring

theorem dft_initialOddDigits {K b : ℕ} (k : ZMod (2 ^ K)) :
    ZMod.dft (cyclicUniformNatSet (initialOddDigits b)) k = ZMod.dft (cyclicOddDigit b) k := by
  rw [dft_cyclicUniformNatSet, initial_odd_digits_card, cyclicOddDigit, dft_cyclicPushforward,
    ← Finset.sum_mul]
  congr 1
  unfold initialOddDigits
  rw [Finset.sum_image (by intro x hx y hy h; change 2 * x + 1 = 2 * y + 1 at h; omega)]
  exact (Fin.sum_univ_eq_sum_range
    (fun i : ℕ => ZMod.stdAddChar (-(((2 * i + 1 : ℕ) : ZMod (2 ^ K)) * k))) _).symm

theorem dft_binary_block_set_low {F K b₀ : ℕ} {c : ℝ}
    (hb : 2 ≤ b₀) (hbK : b₀ ≤ K) (hF : 2 ^ b₀ ≤ F) (hc : 0 ≤ c) (hcsmall : c ≤ 1 / 2)
    (hD : ∀ l : ℕ, 1 ≤ l → l ≤ K → (2 : ℝ) ^ (c * (l : ℝ)) ≤ (shortFactorialDigits F l).card)
    {k : ZMod (2 ^ K)} (hklo : 2 ≤ dyadicConductorLevel k) (hkhi : dyadicConductorLevel k ≤ b₀) :
    ∀ i : ℕ, ZMod.dft (cyclicUniformNatSet (binaryBlockSet F K b₀ i)) k = 0 := by
  intro i
  induction i with
  | zero =>
    rw [binaryBlockSet, dft_initialOddDigits]
    exact dft_cyclicOddDigit_zero hklo hkhi
  | succ i ih =>
    rw [binaryBlockSet, dft_binary_append (binary_block_set_profile hb hbK hF hc hcsmall hD i).bounded,
      ih, zero_mul]

theorem cyclicUniformNatSet_eq_residue_mass {q : ℕ} [NeZero q] (A : Finset ℕ) (x : ZMod q) :
    cyclicUniformNatSet A x = (natResidueMass A q x.val : ℂ) := by
  classical
  have hpred (n : ℕ) : ((n : ZMod q) = x) ↔ Nat.ModEq q n x.val := by
    simpa only [ZMod.natCast_zmod_val] using (ZMod.natCast_eq_natCast_iff n x.val q)
  unfold cyclicUniformNatSet cyclicPushforward
  rw [Finset.sum_coe_sort A (fun n => if (n : ZMod q) = x then (A.card : ℂ)⁻¹ else 0)]
  simp_rw [hpred]
  rw [← Finset.sum_filter]
  simp [natResidueMass, natResidueFiber, div_eq_mul_inv]

theorem norm_cyclicUniformNatSet {q : ℕ} [NeZero q] (A : Finset ℕ) (x : ZMod q) :
    ‖cyclicUniformNatSet A x‖ = natResidueMass A q x.val := by
  rw [cyclicUniformNatSet_eq_residue_mass]
  apply Complex.norm_of_nonneg
  unfold natResidueMass
  positivity

theorem cyclicUniformNatSet_probability {q : ℕ} [NeZero q] {A : Finset ℕ} (hA : A.Nonempty) :
    (∀ x : ZMod q, 0 ≤ (cyclicUniformNatSet A x).re ∧ (cyclicUniformNatSet A x).im = 0) ∧
      ZMod.dft (cyclicUniformNatSet (q := q) A) 0 = 1 := by
  refine ⟨?_, dft_cyclicUniformNatSet_at_zero hA⟩
  intro x
  rw [cyclicUniformNatSet_eq_residue_mass]
  simp only [Complex.ofReal_re, Complex.ofReal_im, and_true]
  unfold natResidueMass
  positivity

theorem binary_block_profile_law {F K u : ℕ} {c : ℝ} {A : Finset ℕ}
    (hA : BinaryBlockProfile F K K u c A) :
    (∀ x : ZMod (2 ^ K), cyclicUniformNatSet A x ≠ 0 → IsUnit x) ∧
    (∀ x : ZMod (2 ^ K), cyclicUniformNatSet A x ≠ 0 → ∃ S : ℕ,
      S ≤ 2 ^ K ∧ (S : ZMod (2 ^ K)) = x ∧ HasFactorialDivisorMultiset (F + 2 * K) S u) ∧
    (∀ j : ℕ, 2 ≤ j → j ≤ K → ∀ x : ZMod (2 ^ j),
      ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-(c / 2) * (j : ℝ))) := by
  refine ⟨?_, ?_, ?_⟩
  · intro x hx
    obtain ⟨n, hn, hcast⟩ := cyclicUniformNatSet_support A hx
    rw [← hcast]
    apply (ZMod.isUnit_iff_coprime _ _).mpr
    have hnodd := hA.odd n hn
    have hcop : Nat.Coprime n 2 := by
      rw [Nat.coprime_comm, Nat.prime_two.coprime_iff_not_dvd]
      obtain ⟨t, ht⟩ := hnodd
      omega
    exact hcop.pow_right K
  · intro x hx
    obtain ⟨n, hn, hcast⟩ := cyclicUniformNatSet_support A hx
    exact ⟨n, (hA.bounded n hn).le, hcast, hA.representatives n hn⟩
  · intro j hj hjK x
    rw [norm_cyclicUniformNatSet]
    exact hA.spread j hj hjK x.val

noncomputable def factorialDigitBase (a : ℝ) (K : ℕ) : ℕ := Nat.log 2 (factorialDigitHost a K)

noncomputable def factorialBlockSet (a : ℝ) (K : ℕ) : Finset ℕ :=
  binaryBlockSet (factorialDigitHost a K) K (factorialDigitBase a K) (binaryLength K)

noncomputable def factorialBlockLaw (a : ℝ) (K : ℕ) : ZMod (2 ^ K) → ℂ :=
  cyclicUniformNatSet (factorialBlockSet a K)

theorem factorialDigitBase_tendsto {a : ℝ} (ha : 0 < a) :
    Filter.Tendsto (factorialDigitBase a) Filter.atTop Filter.atTop := by
  apply Filter.tendsto_atTop.mpr
  intro M
  filter_upwards [(factorialDigitHost_tendsto ha).eventually_ge_atTop (2 ^ M)] with K hK
  exact Nat.le_log_of_pow_le (by decide) hK

theorem eventually_factorialDigitBase_bounds {a : ℝ} (ha : 0 < a) :
    ∀ᶠ K : ℕ in Filter.atTop, 2 ≤ factorialDigitBase a K ∧ factorialDigitBase a K ≤ K ∧
      2 ^ factorialDigitBase a K ≤ factorialDigitHost a K := by
  let ε : ℝ := 1 / (2 * a)
  have hε : 0 < ε := by dsimp [ε]; positivity
  have haε : a * ε = 1 / 2 := by dsimp [ε]; field_simp
  have hhost := factorialDigitHost_tendsto ha
  have hbit := hhost.eventually (eventually_binaryLength_le_rpow hε)
  have hpower := eventually_const_mul_rpow_le (a := 1 / 2) (b := 1) (C := (2 : ℝ) ^ ε)
    (E := 1) (by norm_num) (by norm_num)
  filter_upwards [hbit, hpower, (factorialDigitBase_tendsto ha).eventually_ge_atTop 2,
    hhost.eventually_ge_atTop 1, eventually_ge_atTop (1 : ℕ)] with K hKbit hKpower hKbase hKhost hKone
  refine ⟨hKbase, ?_, Nat.pow_log_le_self 2 (by omega)⟩
  have hlen : (binaryLength (factorialDigitHost a K) : ℝ) ≤ (K : ℝ) := by
    calc
      (binaryLength (factorialDigitHost a K) : ℝ) ≤ (factorialDigitHost a K : ℝ) ^ ε := hKbit
      _ ≤ (2 * (K : ℝ) ^ a) ^ ε := Real.rpow_le_rpow (Nat.cast_nonneg _)
        (factorialDigitHost_le ha.le hKone) hε.le
      _ = (2 : ℝ) ^ ε * (K : ℝ) ^ (1 / 2 : ℝ) := by
        rw [Real.mul_rpow (by norm_num) (by positivity), ← Real.rpow_mul (Nat.cast_nonneg K), haε]
      _ ≤ (K : ℝ) := by simpa only [one_mul, Real.rpow_one] using hKpower
  have hbitle : factorialDigitBase a K ≤ binaryLength (factorialDigitHost a K) := Nat.le_succ _
  exact_mod_cast (show (factorialDigitBase a K : ℝ) ≤ (K : ℝ) from
    (by exact_mod_cast hbitle : (factorialDigitBase a K : ℝ) ≤ binaryLength (factorialDigitHost a K)).trans hlen)

theorem factorial_block_set_profiles {a : ℝ} (ha : 1 < a) :
    ∃ c : ℝ, 0 < c ∧ c ≤ 1 / 2 ∧ ∀ᶠ K : ℕ in Filter.atTop,
      BinaryBlockProfile (factorialDigitHost a K) K K (binaryLength K + 1) c (factorialBlockSet a K) ∧
      (∀ x : ZMod (2 ^ K), 2 ≤ dyadicConductorLevel x →
        dyadicConductorLevel x ≤ factorialDigitBase a K → ZMod.dft (factorialBlockLaw a K) x = 0) := by
  obtain ⟨c₀, hc₀, hshort⟩ := shortFactorialDigits_uniform_asymptotic ha
  let c := min c₀ (1 / 2)
  have hc : 0 < c := lt_min hc₀ (by norm_num)
  have hcc : c ≤ c₀ := min_le_left _ _
  have hchalf : c ≤ 1 / 2 := min_le_right _ _
  refine ⟨c, hc, hchalf, ?_⟩
  filter_upwards [hshort, eventually_factorialDigitBase_bounds (by linarith : 0 < a)]
    with K hKshort hKb
  obtain ⟨hblo, hbK, hF⟩ := hKb
  have hD : ∀ l : ℕ, 1 ≤ l → l ≤ K →
      (2 : ℝ) ^ (c * (l : ℝ)) ≤ (shortFactorialDigits (factorialDigitHost a K) l).card := by
    intro l hl hlK
    exact (Real.rpow_le_rpow_of_exponent_le (by norm_num)
      (mul_le_mul_of_nonneg_right hcc (Nat.cast_nonneg l))).trans (hKshort.2 l hl hlK)
  refine ⟨binary_block_set_profile_top hblo hbK hF hc.le hchalf hD, ?_⟩
  intro x hxlo hxhi
  exact dft_binary_block_set_low hblo hbK hF hc.le hchalf hD hxlo hxhi (binaryLength K)

theorem factorial_block_laws {a : ℝ} (ha : 1 < a) :
    ∃ g : ℝ, 0 < g ∧ g ≤ 1 / 2 ∧ ∀ᶠ K : ℕ in Filter.atTop,
      ZMod.dft (factorialBlockLaw a K) 0 = 1 ∧
      (∀ x : ZMod (2 ^ K), 0 ≤ (factorialBlockLaw a K x).re ∧ (factorialBlockLaw a K x).im = 0) ∧
      (∀ x : ZMod (2 ^ K), factorialBlockLaw a K x ≠ 0 → IsUnit x) ∧
      (∀ x : ZMod (2 ^ K), factorialBlockLaw a K x ≠ 0 → ∃ S : ℕ,
        S ≤ 2 ^ K ∧ (S : ZMod (2 ^ K)) = x ∧
          HasFactorialDivisorMultiset (factorialDigitHost a K + 2 * K) S (binaryLength K + 1)) ∧
      (∀ x : ZMod (2 ^ K), 2 ≤ dyadicConductorLevel x → dyadicConductorLevel x ≤ factorialDigitBase a K →
        ZMod.dft (factorialBlockLaw a K) x = 0) ∧
      (∀ j : ℕ, 2 ≤ j → j ≤ K → ∀ x : ZMod (2 ^ j),
        ‖cyclicUniformNatSet (factorialBlockSet a K) x‖ ≤ (2 : ℝ) ^ (-g * (j : ℝ))) := by
  obtain ⟨c, hc, hchalf, hprofiles⟩ := factorial_block_set_profiles ha
  refine ⟨c / 2, by positivity, by linarith, ?_⟩
  filter_upwards [hprofiles] with K hK
  obtain ⟨hprofile, hlow⟩ := hK
  obtain ⟨hprob, hzero⟩ := cyclicUniformNatSet_probability (q := 2 ^ K) hprofile.nonempty
  obtain ⟨hunit, hrep, hspread⟩ := binary_block_profile_law hprofile
  exact ⟨hzero, hprob, hunit, hrep, hlow, hspread⟩

theorem dyadic_frequency_factor {K : ℕ} {x : ZMod (2 ^ K)} (hx : x ≠ 0) :
    ∃ a : ℕ, Odd a ∧ x = ((2 ^ (K - dyadicConductorLevel x) * a : ℕ) : ZMod (2 ^ K)) := by
  let j := dyadicConductorLevel x
  have hj : 0 < j := dyadic_conductor_pos hx
  have hjK : j ≤ K := (dyadic_conductor_spec x).1
  have horder : addOrderOf x = 2 ^ j := (dyadic_conductor_spec x).2
  have hperiod : ((2 ^ j * x.val : ℕ) : ZMod (2 ^ K)) = 0 := by
    have hh := addOrderOf_nsmul_eq_zero x
    rw [horder] at hh
    simpa only [nsmul_eq_mul, Nat.cast_mul, ZMod.natCast_zmod_val] using hh
  have hdiv := (ZMod.natCast_eq_zero_iff _ _).mp hperiod
  have hQ : 2 ^ K = 2 ^ j * 2 ^ (K - j) := by rw [← pow_add, Nat.add_sub_of_le hjK]
  have hdiv' : 2 ^ j * 2 ^ (K - j) ∣ 2 ^ j * x.val := hQ.symm.dvd.trans hdiv
  have hfactor := Nat.dvd_of_mul_dvd_mul_left (by positivity : 0 < 2 ^ j) hdiv'
  obtain ⟨a, ha⟩ := hfactor
  have hxa : x = ((2 ^ (K - j) * a : ℕ) : ZMod (2 ^ K)) := by
    rw [← ha, ZMod.natCast_zmod_val]
  refine ⟨a, ?_, hxa⟩
  by_contra hodd
  have heven : Even a := Nat.not_odd_iff_even.mp hodd
  obtain ⟨t, ht⟩ := heven
  have hnat : 2 ^ (j - 1) * (2 ^ (K - j) * a) = 2 ^ K * t := by
    rw [ht, hQ]
    have hp : 2 ^ j = 2 ^ (j - 1) * 2 := by rw [← pow_succ, Nat.sub_add_cancel hj]
    rw [hp]
    ring
  have hsmul : (2 ^ (j - 1)) • x = 0 := by
    rw [hxa, nsmul_eq_mul, ← Nat.cast_mul, hnat]
    exact (ZMod.natCast_eq_zero_iff _ _).mpr (dvd_mul_right _ _)
  have hdvd : 2 ^ j ∣ 2 ^ (j - 1) := by
    rw [← horder]
    exact addOrderOf_dvd_iff_nsmul_eq_zero.mpr hsmul
  have hle := (Nat.pow_dvd_pow_iff_le_right (by decide : 1 < 2)).mp hdvd
  omega

theorem stdAddChar_scaled_modulus {Q q d : ℕ} [NeZero Q] [NeZero q]
    (hQ : Q = d * q) (m : ℤ) :
    ZMod.stdAddChar (((d : ℤ) * m : ℤ) : ZMod Q) = ZMod.stdAddChar (m : ZMod q) := by
  have hd : d ≠ 0 := by
    intro h
    have := NeZero.ne Q
    simp [hQ, h] at this
  rw [ZMod.stdAddChar_coe, ZMod.stdAddChar_coe]
  congr 1
  rw [hQ]
  push_cast
  have hdc : (d : ℂ) ≠ 0 := by exact_mod_cast hd
  have hqc : (q : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne q
  field_simp

theorem dyadic_frequency_phase {K j a : ℕ} (hj : j ≤ K)
    {x : ZMod (2 ^ K)} (hx : x = ((2 ^ (K - j) * a : ℕ) : ZMod (2 ^ K))) (n : ℕ) :
    ZMod.stdAddChar (-((n : ZMod (2 ^ K)) * x)) =
      ZMod.stdAddChar (-((n : ZMod (2 ^ j)) * (a : ZMod (2 ^ j)))) := by
  have hQ : 2 ^ K = 2 ^ (K - j) * 2 ^ j := by rw [← pow_add, Nat.sub_add_cancel hj]
  have hphase := stdAddChar_scaled_modulus hQ (-((n : ℤ) * (a : ℤ)))
  rw [hx]
  convert hphase using 1
  · push_cast
    congr 1
    ring
  · push_cast
    rfl

theorem dft_product_uniform_succ {q : ℕ} [NeZero q]
    (A : Finset ℕ) (r : ℕ) (k : ZMod q) :
    ZMod.dft (cyclicProductPow (cyclicUniformNatSet A) (r + 1)) k =
      (∑ a ∈ A, ZMod.dft (cyclicProductPow (cyclicUniformNatSet A) r) ((a : ZMod q) * k)) *
        (A.card : ℂ)⁻¹ := by
  classical
  rw [cyclicProductPow, dft_cyclicMultiplicativeConvolution]
  simp_rw [dft_cyclicUniformNatSet, ← mul_assoc, Finset.mul_sum]
  rw [← Finset.sum_mul, Finset.sum_comm]
  congr 1
  apply Finset.sum_congr rfl
  intro a _
  rw [ZMod.dft_apply]
  apply Finset.sum_congr rfl
  intro y _
  simp only [smul_eq_mul]
  rw [show (a : ZMod q) * y * k = y * ((a : ZMod q) * k) by ring]
  ring

theorem dft_product_uniform_transfer {Q q : ℕ} [NeZero Q] [NeZero q]
    (A : Finset ℕ) : ∀ r : ℕ, ∀ x : ZMod Q, ∀ y : ZMod q,
      (∀ n : ℕ, ZMod.stdAddChar (-((n : ZMod Q) * x)) = ZMod.stdAddChar (-((n : ZMod q) * y))) →
      ZMod.dft (cyclicProductPow (cyclicUniformNatSet A) r) x =
        ZMod.dft (cyclicProductPow (cyclicUniformNatSet A) r) y := by
  intro r
  induction r with
  | zero =>
    intro x y hphase
    simpa [cyclicProductPow, ZMod.dft_apply] using hphase 1
  | succ r ih =>
    intro x y hphase
    rw [dft_product_uniform_succ, dft_product_uniform_succ]
    congr 1
    apply Finset.sum_congr rfl
    intro a _
    apply ih
    intro n
    simpa only [Nat.cast_mul, mul_assoc] using hphase (n * a)

/-- The odd-law mixing property proved below by `weighted_dyadic_mixing`. -/
def WeightedDyadicMixing : Prop :=
  ∀ g : ℝ, 0 < g → g ≤ 1 / 2 → ∃ r : ℕ, ∃ t : ℝ, ∃ J₀ : ℕ,
    0 < r ∧ 0 < t ∧ ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset ℕ,
      A.Nonempty → (∀ n ∈ A, Odd n) →
      (∀ l : ℕ, 2 ≤ l → l ≤ J → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-g * (l : ℝ))) →
      ∀ a : ℕ, Odd a →
        ‖ZMod.dft (cyclicProductPow (cyclicUniformNatSet A) r) (a : ZMod (2 ^ J))‖ ≤
          (2 : ℝ) ^ (-t * (J : ℝ))

theorem block_product_decay_of_weighted_mixing {a : ℝ} (ha : 1 < a) (hmix : WeightedDyadicMixing) :
    ∃ r : ℕ, ∃ t : ℝ, 0 < r ∧ 0 < t ∧ ∀ᶠ K : ℕ in Filter.atTop,
      ∀ x : ZMod (2 ^ K), factorialDigitBase a K < dyadicConductorLevel x →
        ‖ZMod.dft (cyclicProductPow (factorialBlockLaw a K) r) x‖ ≤
          (2 : ℝ) ^ (-t * (dyadicConductorLevel x : ℝ)) := by
  obtain ⟨c, hc, hchalf, hprofiles⟩ := factorial_block_set_profiles ha
  obtain ⟨r, t, J₀, hr, ht, hmix⟩ := hmix (c / 2) (by positivity) (by linarith)
  refine ⟨r, t, hr, ht, ?_⟩
  filter_upwards [hprofiles, (factorialDigitBase_tendsto (by linarith : 0 < a)).eventually_ge_atTop J₀]
    with K hK hKbase
  intro x hx
  have hxne : x ≠ 0 := by
    intro hzero
    subst x
    simp [dyadicConductorLevel] at hx
  obtain ⟨m, hm, hfactor⟩ := dyadic_frequency_factor hxne
  have hjK := (dyadic_conductor_spec x).1
  have hspread := (binary_block_profile_law hK.1).2.2
  have hbound := hmix (dyadicConductorLevel x) (by omega) (factorialBlockSet a K)
    hK.1.nonempty hK.1.odd (fun l hl hlj => hspread l hl (hlj.trans hjK)) m hm
  have htransfer := dft_product_uniform_transfer (factorialBlockSet a K) r x
    (m : ZMod (2 ^ dyadicConductorLevel x)) (fun n => dyadic_frequency_phase hjK hfactor n)
  change ‖ZMod.dft (cyclicProductPow (cyclicUniformNatSet (factorialBlockSet a K)) r) x‖ ≤ _
  rw [htransfer]
  exact hbound

theorem block_product_host_bound {a : ℝ} {K r : ℕ} (ha : 1 ≤ a) (hK : 1 ≤ K) :
    ((r * (factorialDigitHost a K + 2 * K) : ℕ) : ℝ) ≤
      (4 * (r : ℝ)) * (K : ℝ) ^ a := by
  have hhost := factorialDigitHost_le (by linarith : 0 ≤ a) hK
  have hKpow : (K : ℝ) ≤ (K : ℝ) ^ a := by
    simpa only [Real.rpow_one] using
      Real.rpow_le_rpow_of_exponent_le (by exact_mod_cast hK : (1 : ℝ) ≤ K) ha
  simp only [Nat.cast_mul, Nat.cast_add, Nat.cast_ofNat]
  calc
    (r : ℝ) * ((factorialDigitHost a K : ℝ) + 2 * K) ≤ (r : ℝ) * (4 * (K : ℝ) ^ a) :=
      mul_le_mul_of_nonneg_left (by linarith) (Nat.cast_nonneg r)
    _ = (4 * (r : ℝ)) * (K : ℝ) ^ a := by ring

theorem eventually_block_sum_count_bound {b : ℝ} {r : ℕ} (hb : 0 < b) (hr : 0 < r) (s : ℕ) :
    ∀ᶠ K : ℕ in Filter.atTop,
      ((s * ((binaryLength K + 1) ^ r + 1) : ℕ) : ℝ) ≤
        ((s : ℝ) * ((2 : ℝ) ^ r + 1)) * (K : ℝ) ^ b := by
  have hrpos : (0 : ℝ) < r := by exact_mod_cast hr
  have hε : 0 < b / (r : ℝ) := div_pos hb hrpos
  filter_upwards [eventually_binaryLength_le_rpow hε, eventually_ge_atTop (1 : ℕ)] with K hK hKone
  have hlenone : (1 : ℝ) ≤ binaryLength K := by exact_mod_cast binaryLength_pos K
  have hlen : ((binaryLength K + 1 : ℕ) : ℝ) ≤ 2 * (K : ℝ) ^ (b / (r : ℝ)) := by
    rw [Nat.cast_add, Nat.cast_one]
    linarith
  have hpow : (((binaryLength K + 1 : ℕ) : ℝ) ^ r) ≤ (2 : ℝ) ^ r * (K : ℝ) ^ b := by
    calc
      _ ≤ (2 * (K : ℝ) ^ (b / (r : ℝ))) ^ r := pow_le_pow_left₀ (by positivity) hlen r
      _ = (2 : ℝ) ^ r * (K : ℝ) ^ b := by
        rw [mul_pow, ← Real.rpow_mul_natCast (Nat.cast_nonneg K), div_mul_cancel₀ b hrpos.ne']
  have hKpow : 1 ≤ (K : ℝ) ^ b := Real.one_le_rpow (by exact_mod_cast hKone) hb.le
  simp only [Nat.cast_mul, Nat.cast_add, Nat.cast_pow, Nat.cast_one]
  calc
    (s : ℝ) * (((binaryLength K : ℝ) + 1) ^ r + 1) ≤
        (s : ℝ) * (((2 : ℝ) ^ r + 1) * (K : ℝ) ^ b) := by
      apply mul_le_mul_of_nonneg_left _ (Nat.cast_nonneg s)
      push_cast at hpow
      nlinarith
    _ = ((s : ℝ) * ((2 : ℝ) ^ r + 1)) * (K : ℝ) ^ b := by ring

theorem dyadic_modular_bounds_of_block_product_decay {a b : ℝ}
    (ha : 1 < a) (hb : 0 < b)
    (hdecay : ∃ r : ℕ, ∃ t : ℝ, 0 < r ∧ 0 < t ∧ ∀ᶠ K : ℕ in Filter.atTop,
      ∀ x : ZMod (2 ^ K), factorialDigitBase a K < dyadicConductorLevel x →
        ‖ZMod.dft (cyclicProductPow (factorialBlockLaw a K) r) x‖ ≤
          (2 : ℝ) ^ (-t * (dyadicConductorLevel x : ℝ))) : DyadicModularBounds a b := by
  obtain ⟨r, t, hr, ht, hdecay⟩ := hdecay
  obtain ⟨s, hs, hmod⟩ := exists_power_modular_representatives_of_product_decay ht
  obtain ⟨g, hg, hghalf, hlaws⟩ := factorial_block_laws ha
  have hevent : ∀ᶠ K : ℕ in Filter.atTop, ∃ F u : ℕ,
      2 ^ K ∣ F.factorial ∧ HasBoundedModularRepresentatives (2 ^ K) F u (r + 1) ∧
      (F : ℝ) ≤ (4 * (r : ℝ)) * (K : ℝ) ^ a ∧
      (u : ℝ) ≤ ((s : ℝ) * ((2 : ℝ) ^ r + 1)) * (K : ℝ) ^ b := by
    filter_upwards [hdecay, hlaws, eventually_block_sum_count_bound hb hr s,
      eventually_ge_atTop (2 * s), eventually_ge_atTop (1 : ℕ)] with K hKdecay hKlaw hKcount hKs hKone
    obtain ⟨hzero, _, hunit, hrep, hlow, _⟩ := hKlaw
    have hheight : 2 * s ≤ 2 ^ K := hKs.trans (Nat.lt_two_pow_self : K < 2 ^ K).le
    have hmodK := hmod K (factorialDigitBase a K) r (factorialDigitHost a K + 2 * K)
      (binaryLength K + 1) hr (factorialBlockLaw a K) hzero hunit hlow hKdecay hrep hheight
    refine ⟨r * (factorialDigitHost a K + 2 * K), s * ((binaryLength K + 1) ^ r + 1),
      ?_, hmodK, block_product_host_bound ha.le hKone, hKcount⟩
    have hreserve : 2 ^ K ∣ (factorialDigitHost a K + 2 * K).factorial :=
      (dvd_mul_right (2 ^ K) (factorialDigitHost a K).factorial).trans
        (factorial_binary_reserve (factorialDigitHost a K) K)
    exact hreserve.trans (Nat.factorial_dvd_factorial (by nlinarith))
  obtain ⟨K₀, hK₀⟩ := Filter.eventually_atTop.mp hevent
  refine ⟨r + 1, K₀, 4 * (r : ℝ), (s : ℝ) * ((2 : ℝ) ^ r + 1), ?_, ?_, hK₀⟩ <;>
    positivity

theorem dyadic_modular_bounds_of_weighted_dyadic_mixing {a b : ℝ}
    (ha : 1 < a) (hb : 0 < b) (hmix : WeightedDyadicMixing) : DyadicModularBounds a b := by
  exact dyadic_modular_bounds_of_block_product_decay ha hb (block_product_decay_of_weighted_mixing ha hmix)

theorem erdos18b_of_weighted_dyadic_mixing (hmix : WeightedDyadicMixing) :
    fcTypeOfName% "Erdos18.erdos_18b" := by
  exact erdos18b_of_dyadic_modular_bounds
    (fun _ _ ha hb => dyadic_modular_bounds_of_weighted_dyadic_mixing ha hb hmix)

theorem binary_block_profile_spread_extended {F K b u J : ℕ} {c : ℝ} {A : Finset ℕ}
    (hA : BinaryBlockProfile F K b u c A) (hc : 0 ≤ c) (hJ : J ≤ 2 * b) :
    ∀ l : ℕ, 2 ≤ l → l ≤ J → ∀ r : ℕ,
      natResidueMass A (2 ^ l) r ≤ (2 : ℝ) ^ (-(c / 2) * (l : ℝ)) := by
  intro l hl hlJ r
  by_cases hlb : l ≤ b
  · exact hA.spread l hl hlb r
  · have hbound : ∀ x ∈ A, x < 2 ^ l := by
      intro x hx
      exact (hA.bounded x hx).trans_le (Nat.pow_le_pow_right (by decide : 0 < 2) (by omega))
    calc
      natResidueMass A (2 ^ l) r ≤ 1 / (A.card : ℝ) := by
        apply div_le_div_of_nonneg_right _ (Nat.cast_nonneg _)
        exact_mod_cast nat_residue_fiber_card_le_one hbound
      _ ≤ 1 / (2 : ℝ) ^ (c * (b : ℝ)) := one_div_le_one_div_of_le (by positivity) hA.entropy
      _ = (2 : ℝ) ^ (-(c * (b : ℝ))) := by rw [Real.rpow_neg (by norm_num), one_div]
      _ ≤ (2 : ℝ) ^ (-(c / 2) * (l : ℝ)) := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        have hh : (l : ℝ) ≤ 2 * (b : ℝ) := by exact_mod_cast hlJ.trans hJ
        nlinarith [mul_le_mul_of_nonneg_left hh hc]

def natTranslate (A : Finset ℕ) (c : ℕ) : Finset ℕ := A.image (fun n => n + c)

theorem nat_translate_card (A : Finset ℕ) (c : ℕ) : (natTranslate A c).card = A.card := by
  apply Finset.card_image_of_injective
  intro x y h
  exact Nat.add_right_cancel h

theorem nat_translate_nonempty {A : Finset ℕ} (hA : A.Nonempty) (c : ℕ) : (natTranslate A c).Nonempty :=
  hA.image _

theorem nat_translate_residue_mass {q : ℕ} [NeZero q] (A : Finset ℕ) (c r : ℕ) :
    natResidueMass (natTranslate A c) q r = natResidueMass A q ((r : ZMod q) - (c : ZMod q)).val := by
  let z : ZMod q := (r : ZMod q) - (c : ZMod q)
  have hpred (n : ℕ) : Nat.ModEq q (n + c) r ↔ Nat.ModEq q n z.val := by
    rw [← ZMod.natCast_eq_natCast_iff, ← ZMod.natCast_eq_natCast_iff]
    simp only [Nat.cast_add, ZMod.natCast_zmod_val, z]
    exact eq_sub_iff_add_eq.symm
  have hfiber : natResidueFiber (natTranslate A c) q r = natTranslate (natResidueFiber A q z.val) c := by
    ext x
    constructor
    · intro hx
      obtain ⟨hxA, hxmod⟩ := Finset.mem_filter.mp hx
      obtain ⟨n, hn, rfl⟩ := Finset.mem_image.mp hxA
      exact Finset.mem_image.mpr ⟨n, Finset.mem_filter.mpr ⟨hn, (hpred n).mp hxmod⟩, rfl⟩
    · intro hx
      obtain ⟨n, hn, rfl⟩ := Finset.mem_image.mp hx
      obtain ⟨hnA, hnmod⟩ := Finset.mem_filter.mp hn
      exact Finset.mem_filter.mpr ⟨Finset.mem_image.mpr ⟨n, hnA, rfl⟩, (hpred n).mpr hnmod⟩
  unfold natResidueMass
  rw [hfiber, nat_translate_card, nat_translate_card]

theorem bounded_nat_set_cast_injective {q : ℕ} {A : Finset ℕ} (hA : ∀ n ∈ A, n < q) :
    Set.InjOn (fun n : ℕ => (n : ZMod q)) A := by
  intro n hn m hm h
  have heq := (ZMod.natCast_eq_natCast_iff n m q).mp h
  simpa only [Nat.ModEq, Nat.mod_eq_of_lt (hA n hn), Nat.mod_eq_of_lt (hA m hm)] using heq

theorem translated_nat_set_cast_injective {q : ℕ} {A : Finset ℕ}
    (hA : Set.InjOn (fun n : ℕ => (n : ZMod q)) A) (c : ℕ) :
    Set.InjOn (fun n : ℕ => (n : ZMod q)) (natTranslate A c) := by
  intro n hn m hm h
  obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hn
  obtain ⟨b, hb, rfl⟩ := Finset.mem_image.mp hm
  have hab : (a : ZMod q) = (b : ZMod q) := by
    change ((a + c : ℕ) : ZMod q) = ((b + c : ℕ) : ZMod q) at h
    simpa only [Nat.cast_add, add_left_inj] using h
  rw [hA ha hb hab]

theorem translated_binary_prefix_spread {F K b u J : ℕ} {c : ℝ} {A : Finset ℕ}
    (hA : BinaryBlockProfile F K b u c A) (hc : 0 ≤ c) (hbJ : b ≤ J) (hJ : J ≤ 2 * b)
    (d : ℕ) :
    (natTranslate A d).Nonempty ∧
      Set.InjOn (fun n : ℕ => (n : ZMod (2 ^ J))) (natTranslate A d) ∧
      ∀ l : ℕ, 2 ≤ l → l ≤ J → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet (natTranslate A d) x‖ ≤ (2 : ℝ) ^ (-(c / 2) * (l : ℝ)) := by
  refine ⟨nat_translate_nonempty hA.nonempty d, ?_, ?_⟩
  · apply translated_nat_set_cast_injective
    apply bounded_nat_set_cast_injective
    intro n hn
    exact (hA.bounded n hn).trans_le (Nat.pow_le_pow_right (by decide : 0 < 2) hbJ)
  · intro l hl hlJ x
    rw [norm_cyclicUniformNatSet, nat_translate_residue_mass]
    exact binary_block_profile_spread_extended hA hc hJ l hl hlJ _

theorem binary_block_endpoint_monotone (K b₀ : ℕ) : Monotone (binaryBlockEndpoint K b₀) := by
  exact monotone_nat_of_le_succ (binary_block_endpoint_mono K b₀)

theorem binary_block_prefix_at_level {K b₀ J : ℕ}
    (hb : 1 ≤ b₀) (hbJ : b₀ < J) (hJK : J ≤ K) :
    ∃ i : ℕ, i ≤ binaryLength K ∧ binaryBlockEndpoint K b₀ i ≤ J ∧
      J ≤ 2 * binaryBlockEndpoint K b₀ i := by
  have hex : ∃ i : ℕ, J ≤ binaryBlockEndpoint K b₀ i := by
    refine ⟨binaryLength K, ?_⟩
    rwa [binary_block_endpoint_top hb]
  let m := Nat.find hex
  have hm : J ≤ binaryBlockEndpoint K b₀ m := Nat.find_spec hex
  have hmN : m ≤ binaryLength K := Nat.find_min' hex (by rwa [binary_block_endpoint_top hb])
  have hmpos : 0 < m := by
    by_contra h
    have hmzero : m = 0 := by omega
    rw [hmzero, binary_block_endpoint_zero (by omega)] at hm
    omega
  have hprev : binaryBlockEndpoint K b₀ (m - 1) < J := by
    exact Nat.lt_of_not_ge (Nat.find_min hex (by change m - 1 < m; omega))
  refine ⟨m - 1, by omega, hprev.le, ?_⟩
  have hnext := binary_block_endpoint_succ_le_twice K b₀ (m - 1)
  rw [Nat.sub_add_cancel hmpos] at hnext
  exact hm.trans hnext

theorem binary_append_singleton_zero (A : Finset ℕ) (b : ℕ) : binaryAppend A {0} b = A := by
  ext x
  simp [binaryAppend]

theorem binary_append_assoc (A D E : Finset ℕ) (b l : ℕ) :
    binaryAppend (binaryAppend A D b) E (b + l) = binaryAppend A (binaryAppend D E l) b := by
  ext x
  constructor
  · intro hx
    obtain ⟨⟨ad, e⟩, hade, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨had, he⟩ := Finset.mem_product.mp hade
    obtain ⟨⟨a, d⟩, hapair, rfl⟩ := Finset.mem_image.mp had
    obtain ⟨ha, hd⟩ := Finset.mem_product.mp hapair
    refine Finset.mem_image.mpr ⟨(a, d + 2 ^ l * e), Finset.mem_product.mpr ⟨ha, ?_⟩, ?_⟩
    · exact Finset.mem_image.mpr ⟨(d, e), Finset.mem_product.mpr ⟨hd, he⟩, rfl⟩
    · simp only [pow_add]
      ring
  · intro hx
    obtain ⟨⟨a, de⟩, hade, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨ha, hde⟩ := Finset.mem_product.mp hade
    obtain ⟨⟨d, e⟩, hdepair, rfl⟩ := Finset.mem_image.mp hde
    obtain ⟨hd, he⟩ := Finset.mem_product.mp hdepair
    refine Finset.mem_image.mpr ⟨(a + 2 ^ b * d, e), Finset.mem_product.mpr ⟨?_, he⟩, ?_⟩
    · exact Finset.mem_image.mpr ⟨(a, d), Finset.mem_product.mpr ⟨ha, hd⟩, rfl⟩
    · simp only [pow_add]
      ring

theorem binary_block_set_factors_at_prefix (F K b₀ i N : ℕ) (hiN : i ≤ N) :
    ∃ D : Finset ℕ, D.Nonempty ∧ binaryBlockSet F K b₀ N =
      binaryAppend (binaryBlockSet F K b₀ i) D (binaryBlockEndpoint K b₀ i) := by
  induction N, hiN using Nat.le_induction with
  | base =>
    exact ⟨{0}, Finset.singleton_nonempty 0, (binary_append_singleton_zero _ _).symm⟩
  | succ N hiN ih =>
    obtain ⟨D, hD, hfactor⟩ := ih
    have hbN := binary_block_endpoint_monotone K b₀ hiN
    have hsplit : binaryBlockEndpoint K b₀ N = binaryBlockEndpoint K b₀ i +
        (binaryBlockEndpoint K b₀ N - binaryBlockEndpoint K b₀ i) := by omega
    refine ⟨binaryAppend D (shortFactorialDigits F (binaryBlockWidth K b₀ N))
      (binaryBlockEndpoint K b₀ N - binaryBlockEndpoint K b₀ i),
      binary_append_nonempty hD (short_factorial_digits_nonempty _ _), ?_⟩
    rw [binaryBlockSet, hfactor, hsplit, binary_append_assoc]
    simp only [Nat.add_sub_cancel_left]

noncomputable def natProductAverage : List (Finset ℕ) → (ℕ → ℂ) → ℂ
  | [], f => f 1
  | A :: L, f => (∑ n ∈ A, natProductAverage L (fun m => f (n * m))) * (A.card : ℂ)⁻¹

theorem nat_product_average_congr (L : List (Finset ℕ)) {f g : ℕ → ℂ}
    (h : ∀ n, f n = g n) : natProductAverage L f = natProductAverage L g := by
  congr 1
  exact funext h

theorem nat_product_average_binary_append_head {A D : Finset ℕ} {b : ℕ}
    (hA : ∀ n ∈ A, n < 2 ^ b) (L : List (Finset ℕ)) (f : ℕ → ℂ) :
    natProductAverage (binaryAppend A D b :: L) f =
      (∑ d ∈ D, natProductAverage (natTranslate A (2 ^ b * d) :: L) f) * (D.card : ℂ)⁻¹ := by
  simp only [natProductAverage, binary_append_card hA, Nat.cast_mul, mul_inv_rev,
    nat_translate_card]
  rw [binaryAppend, Finset.sum_image (binary_append_injective hA), Finset.sum_product,
    Finset.sum_comm]
  simp only [natTranslate, Finset.sum_image (fun _ _ _ _ h => Nat.add_right_cancel h)]
  rw [← Finset.sum_mul]
  ring

theorem nat_product_average_binary_append {A D : Finset ℕ} {b : ℕ}
    (hA : ∀ n ∈ A, n < 2 ^ b) (P L : List (Finset ℕ)) (f : ℕ → ℂ) :
    natProductAverage (P ++ binaryAppend A D b :: L) f =
      (∑ d ∈ D, natProductAverage (P ++ natTranslate A (2 ^ b * d) :: L) f) * (D.card : ℂ)⁻¹ := by
  induction P generalizing f with
  | nil => exact nat_product_average_binary_append_head hA L f
  | cons B P ih =>
    simp only [List.cons_append, natProductAverage]
    simp_rw [ih]
    simp only [← Finset.sum_mul]
    rw [Finset.sum_comm]
    ring

theorem norm_finset_average_le {D : Finset ℕ} (hD : D.Nonempty) {f : ℕ → ℂ} {B : ℝ}
    (h : ∀ d ∈ D, ‖f d‖ ≤ B) : ‖(∑ d ∈ D, f d) * (D.card : ℂ)⁻¹‖ ≤ B := by
  have hDc : (0 : ℝ) < D.card := by exact_mod_cast Finset.card_pos.mpr hD
  have hsum : ‖∑ d ∈ D, f d‖ ≤ (D.card : ℝ) * B := by
    calc
      _ ≤ ∑ d ∈ D, ‖f d‖ := norm_sum_le _ _
      _ ≤ ∑ _d ∈ D, B := Finset.sum_le_sum h
      _ = (D.card : ℝ) * B := by simp
  calc
    ‖(∑ d ∈ D, f d) * (D.card : ℂ)⁻¹‖ = ‖∑ d ∈ D, f d‖ / (D.card : ℝ) := by
      rw [norm_mul, norm_inv, Complex.norm_natCast, div_eq_mul_inv]
    _ ≤ ((D.card : ℝ) * B) / (D.card : ℝ) := div_le_div_of_nonneg_right hsum hDc.le
    _ = B := by field_simp

theorem norm_product_average_binary_append_le {A D : Finset ℕ} {b r : ℕ}
    (hA : ∀ n ∈ A, n < 2 ^ b) (hD : D.Nonempty) (f : ℕ → ℂ) (M : ℝ)
    (hbound : ∀ L : List (Finset ℕ), L.length = r →
      (∀ B ∈ L, ∃ d ∈ D, B = natTranslate A (2 ^ b * d)) → ‖natProductAverage L f‖ ≤ M) :
    ‖natProductAverage (List.replicate r (binaryAppend A D b)) f‖ ≤ M := by
  have haux : ∀ k : ℕ, ∀ P : List (Finset ℕ), P.length + k = r →
      (∀ B ∈ P, ∃ d ∈ D, B = natTranslate A (2 ^ b * d)) →
      ‖natProductAverage (P ++ List.replicate k (binaryAppend A D b)) f‖ ≤ M := by
    intro k
    induction k with
    | zero =>
      intro P hlen hP
      simp only [List.replicate_zero, List.append_nil]
      apply hbound P (by simpa using hlen) hP
    | succ k ih =>
      intro P hlen hP
      rw [List.replicate_succ, nat_product_average_binary_append hA]
      apply norm_finset_average_le hD
      intro d hd
      have heq : P ++ natTranslate A (2 ^ b * d) :: List.replicate k (binaryAppend A D b) =
          (P ++ [natTranslate A (2 ^ b * d)]) ++ List.replicate k (binaryAppend A D b) := by simp
      rw [heq]
      apply ih
      · simp only [List.length_append, List.length_singleton]
        omega
      · intro B hB
        rcases List.mem_append.mp hB with hBP | hBd
        · exact hP B hBP
        · exact ⟨d, hd, List.mem_singleton.mp hBd⟩
  exact haux r [] (by simp) (by simp)

theorem nat_product_average_replicate_dft {q : ℕ} [NeZero q] (A : Finset ℕ) (r : ℕ) :
    ∀ k : ZMod q,
      natProductAverage (List.replicate r A) (fun n => ZMod.stdAddChar (-((n : ZMod q) * k))) =
        ZMod.dft (cyclicProductPow (cyclicUniformNatSet A) r) k := by
  induction r with
  | zero =>
    intro k
    simp [natProductAverage, cyclicProductPow, ZMod.dft_apply]
  | succ r ih =>
    intro k
    rw [List.replicate_succ, natProductAverage, dft_product_uniform_succ]
    congr 1
    apply Finset.sum_congr rfl
    intro n _
    have heq : (fun m : ℕ => ZMod.stdAddChar (-(((n * m : ℕ) : ZMod q) * k))) =
        (fun m : ℕ => ZMod.stdAddChar (-((m : ZMod q) * ((n : ZMod q) * k)))) := by
      funext m
      rw [Nat.cast_mul]
      congr 2
      ring
    rw [heq]
    exact ih _

def DyadicSetAdmissible (g : ℝ) (J : ℕ) (A : Finset ℕ) : Prop :=
  A.Nonempty ∧ Set.InjOn (fun n : ℕ => (n : ZMod (2 ^ J))) A ∧
    ∀ l : ℕ, 2 ≤ l → l ≤ J → ∀ x : ZMod (2 ^ l),
      ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-g * (l : ℝ))

/-- A set-valued analytic input. This proposition is not asserted as a theorem. -/
def DyadicSetMixing : Prop :=
  ∀ g : ℝ, 0 < g → g ≤ 1 / 2 → ∃ r : ℕ, ∃ t : ℝ, ∃ J₀ : ℕ,
    0 < r ∧ 0 < t ∧ ∀ J : ℕ, J₀ ≤ J → ∀ L : List (Finset ℕ),
      L.length = r → (∀ A ∈ L, DyadicSetAdmissible g J A) → ∀ a : ℕ, Odd a →
        ‖natProductAverage L (fun n => ZMod.stdAddChar (-((n : ZMod (2 ^ J)) * (a : ZMod (2 ^ J)))))‖ ≤
          (2 : ℝ) ^ (-t * (J : ℝ))

theorem factorial_block_all_profiles {a : ℝ} (ha : 1 < a) :
    ∃ c : ℝ, 0 < c ∧ c ≤ 1 / 2 ∧ ∀ᶠ K : ℕ in Filter.atTop,
      2 ≤ factorialDigitBase a K ∧ factorialDigitBase a K ≤ K ∧
      ∀ i : ℕ, BinaryBlockProfile (factorialDigitHost a K) K
        (binaryBlockEndpoint K (factorialDigitBase a K) i) (i + 1) c
        (binaryBlockSet (factorialDigitHost a K) K (factorialDigitBase a K) i) := by
  obtain ⟨c₀, hc₀, hshort⟩ := shortFactorialDigits_uniform_asymptotic ha
  let c := min c₀ (1 / 2)
  have hc : 0 < c := lt_min hc₀ (by norm_num)
  have hcc : c ≤ c₀ := min_le_left _ _
  have hchalf : c ≤ 1 / 2 := min_le_right _ _
  refine ⟨c, hc, hchalf, ?_⟩
  filter_upwards [hshort, eventually_factorialDigitBase_bounds (by linarith : 0 < a)]
    with K hKshort hKb
  obtain ⟨hblo, hbK, hF⟩ := hKb
  have hD : ∀ l : ℕ, 1 ≤ l → l ≤ K →
      (2 : ℝ) ^ (c * (l : ℝ)) ≤ (shortFactorialDigits (factorialDigitHost a K) l).card := by
    intro l hl hlK
    exact (Real.rpow_le_rpow_of_exponent_le (by norm_num)
      (mul_le_mul_of_nonneg_right hcc (Nat.cast_nonneg l))).trans (hKshort.2 l hl hlK)
  exact ⟨hblo, hbK, binary_block_set_profile hblo hbK hF hc.le hchalf hD⟩

theorem block_product_decay_of_set_mixing {a : ℝ} (ha : 1 < a) (hmix : DyadicSetMixing) :
    ∃ r : ℕ, ∃ t : ℝ, 0 < r ∧ 0 < t ∧ ∀ᶠ K : ℕ in Filter.atTop,
      ∀ x : ZMod (2 ^ K), factorialDigitBase a K < dyadicConductorLevel x →
        ‖ZMod.dft (cyclicProductPow (factorialBlockLaw a K) r) x‖ ≤
          (2 : ℝ) ^ (-t * (dyadicConductorLevel x : ℝ)) := by
  obtain ⟨c, hc, hchalf, hprofiles⟩ := factorial_block_all_profiles ha
  obtain ⟨r, t, J₀, hr, ht, hmix⟩ := hmix (c / 2) (by positivity) (by linarith)
  refine ⟨r, t, hr, ht, ?_⟩
  filter_upwards [hprofiles, (factorialDigitBase_tendsto (by linarith : 0 < a)).eventually_ge_atTop J₀]
    with K hK hKbase
  intro x hx
  have hxne : x ≠ 0 := by
    intro hzero
    subst x
    simp [dyadicConductorLevel] at hx
  obtain ⟨m, hm, hfrequency⟩ := dyadic_frequency_factor hxne
  have hjK := (dyadic_conductor_spec x).1
  obtain ⟨i, hi, hbi, hjb⟩ := binary_block_prefix_at_level (by omega : 1 ≤ factorialDigitBase a K) hx hjK
  have hprefix := hK.2.2 i
  obtain ⟨D, hD, hfactor⟩ := binary_block_set_factors_at_prefix (factorialDigitHost a K) K
    (factorialDigitBase a K) i (binaryLength K) hi
  have hfactor' : factorialBlockSet a K = binaryAppend
      (binaryBlockSet (factorialDigitHost a K) K (factorialDigitBase a K) i) D
      (binaryBlockEndpoint K (factorialDigitBase a K) i) := hfactor
  have hbound : ‖natProductAverage (List.replicate r (factorialBlockSet a K))
      (fun n => ZMod.stdAddChar (-((n : ZMod (2 ^ dyadicConductorLevel x)) *
        (m : ZMod (2 ^ dyadicConductorLevel x)))))‖ ≤
          (2 : ℝ) ^ (-t * (dyadicConductorLevel x : ℝ)) := by
    rw [hfactor']
    apply norm_product_average_binary_append_le hprefix.bounded hD
    intro L hlen hL
    apply hmix (dyadicConductorLevel x) (by omega) L hlen _ m hm
    intro B hB
    obtain ⟨d, _, rfl⟩ := hL B hB
    exact translated_binary_prefix_spread hprefix hc.le hbi hjb _
  have htransfer := dft_product_uniform_transfer (factorialBlockSet a K) r x
    (m : ZMod (2 ^ dyadicConductorLevel x)) (fun n => dyadic_frequency_phase hjK hfrequency n)
  change ‖ZMod.dft (cyclicProductPow (cyclicUniformNatSet (factorialBlockSet a K)) r) x‖ ≤ _
  rw [htransfer, ← nat_product_average_replicate_dft]
  exact hbound

theorem dyadic_modular_bounds_of_dyadic_set_mixing {a b : ℝ}
    (ha : 1 < a) (hb : 0 < b) (hmix : DyadicSetMixing) : DyadicModularBounds a b := by
  exact dyadic_modular_bounds_of_block_product_decay ha hb (block_product_decay_of_set_mixing ha hmix)

theorem erdos18b_of_dyadic_set_mixing (hmix : DyadicSetMixing) :
    fcTypeOfName% "Erdos18.erdos_18b" := by
  exact erdos18b_of_dyadic_modular_bounds
    (fun _ _ ha hb => dyadic_modular_bounds_of_dyadic_set_mixing ha hb hmix)

theorem nat_residue_mass_mod (A : Finset ℕ) (q y : ℕ) :
    natResidueMass A q (y % q) = natResidueMass A q y := by
  unfold natResidueMass natResidueFiber
  simp only [Nat.ModEq, Nat.mod_mod]
  rfl

theorem nat_residue_mass_lt_iff {A : Finset ℕ} (hA : A.Nonempty) (q y : ℕ) (z : ℝ) :
    natResidueMass A q y < z ↔ ((natResidueFiber A q y).card : ℝ) < z * (A.card : ℝ) := by
  have hcard : (0 : ℝ) < A.card := by exact_mod_cast Finset.card_pos.mpr hA
  exact div_lt_iff₀ hcard

theorem dyadic_large_divisor_iff (ε : ℝ) (J l : ℕ) :
    (((2 ^ J : ℕ) : ℝ) ^ ε < ((2 ^ l : ℕ) : ℝ)) ↔ ε * (J : ℝ) < (l : ℝ) := by
  simp only [Nat.cast_pow, Nat.cast_ofNat, ← Real.rpow_natCast]
  rw [← Real.rpow_mul (by norm_num), Real.rpow_lt_rpow_left_iff (by norm_num)]
  rw [mul_comm]

/-- The dyadic specialization of the set estimate in Bourgain (2007), Theorem 2.
The casts are injective so that the natural-number sets represent uniform sets
modulo the full modulus. Only sufficiently large divisors have a fiber hypothesis.
This stronger optional proposition is not used by the final proof of `target`. -/
def BourgainDyadicSetEstimate : Prop :=
  ∀ γ : ℝ, 0 < γ → ∃ ε t : ℝ, ∃ r J₀ : ℕ,
    0 < ε ∧ 0 < t ∧ 0 < r ∧ ∀ J : ℕ, J₀ ≤ J → ∀ L : List (Finset ℕ),
      L.length = r →
      (∀ A ∈ L, A.Nonempty ∧ Set.InjOn (fun n : ℕ => (n : ZMod (2 ^ J))) A ∧
        ∀ l : ℕ, l ≤ J → ε * (J : ℝ) < (l : ℝ) → ∀ y : ℕ,
          natResidueMass A (2 ^ l) y < (2 : ℝ) ^ (-γ * (l : ℝ))) →
      ∀ a : ℕ, Odd a →
        ‖natProductAverage L (fun n => ZMod.stdAddChar (-((n : ZMod (2 ^ J)) * (a : ZMod (2 ^ J)))))‖ <
          (2 : ℝ) ^ (-t * (J : ℝ))

theorem dyadic_set_mixing_of_bourgain_dyadic_set_estimate
    (hB : BourgainDyadicSetEstimate) : DyadicSetMixing := by
  intro g hg _
  obtain ⟨ε, t, r, J₀, hε, ht, hr, hB⟩ := hB (g / 2) (by positivity)
  refine ⟨r, t, max J₀ ⌈2 / ε⌉₊, hr, ht, ?_⟩
  intro J hJ L hlen hL a ha
  have hJ₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hJceil : ⌈2 / ε⌉₊ ≤ J := (le_max_right _ _).trans hJ
  have hJeps : 2 ≤ ε * (J : ℝ) := by
    have hcast : (2 / ε : ℝ) ≤ J := (Nat.le_ceil _).trans (by exact_mod_cast hJceil)
    have hprod := (div_le_iff₀ hε).mp hcast
    simpa only [mul_comm] using hprod
  apply le_of_lt (hB J hJ₀ L hlen _ a ha)
  intro A hA
  obtain ⟨hne, hinj, hspread⟩ := hL A hA
  refine ⟨hne, hinj, ?_⟩
  intro l hlJ hlε y
  have hlreal : (2 : ℝ) < l := hJeps.trans_lt hlε
  have hl : 2 ≤ l := by exact_mod_cast hlreal.le
  have hmass : natResidueMass A (2 ^ l) y ≤ (2 : ℝ) ^ (-g * (l : ℝ)) := by
    simpa only [norm_cyclicUniformNatSet, ZMod.val_natCast, nat_residue_mass_mod]
      using hspread l hl hlJ (y : ZMod (2 ^ l))
  refine hmass.trans_lt (Real.rpow_lt_rpow_of_exponent_lt (by norm_num) ?_)
  nlinarith [mul_pos hg (show (0 : ℝ) < l by linarith)]

theorem erdos18b_of_bourgain_dyadic_set_estimate (hB : BourgainDyadicSetEstimate) :
    fcTypeOfName% "Erdos18.erdos_18b" := by
  exact erdos18b_of_dyadic_set_mixing (dyadic_set_mixing_of_bourgain_dyadic_set_estimate hB)

/- Elementary Fourier estimates used in the fixed-prime analytic argument. -/

theorem conjugate_stdAddChar {q : ℕ} [NeZero q] (x : ZMod q) :
    starRingEnd ℂ (ZMod.stdAddChar x) = ZMod.stdAddChar (-x) := by
  rw [ZMod.stdAddChar_apply, ZMod.stdAddChar_apply, AddChar.map_neg_eq_inv,
    Circle.coe_inv_eq_conj]

theorem dft_conjugate {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (k : ZMod q) :
    ZMod.dft (fun x => starRingEnd ℂ (f x)) k = starRingEnd ℂ (ZMod.dft f (-k)) := by
  simp only [ZMod.dft_apply, smul_eq_mul, map_sum, map_mul, mul_neg, neg_neg,
    conjugate_stdAddChar]

theorem dft_bilinear_pairing {q : ℕ} [NeZero q] (f g : ZMod q → ℂ) :
    (∑ k : ZMod q, ZMod.dft f k * g k) = ∑ x : ZMod q, f x * ZMod.dft g x := by
  simp only [ZMod.dft_apply, smul_eq_mul, Finset.sum_mul, Finset.mul_sum]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro x _
  apply Finset.sum_congr rfl
  intro k _
  rw [mul_comm k x]
  ring

theorem dft_parseval {q : ℕ} [NeZero q] (f : ZMod q → ℂ) :
    (∑ k : ZMod q, ‖ZMod.dft f k‖ ^ 2) = (q : ℝ) * ∑ x : ZMod q, ‖f x‖ ^ 2 := by
  have hpair := dft_bilinear_pairing f (fun k => starRingEnd ℂ (ZMod.dft f k))
  simp_rw [dft_conjugate] at hpair
  simp only [ZMod.dft_dft, neg_neg, smul_eq_mul, map_mul, map_natCast] at hpair
  have hcomplex : (∑ k : ZMod q, ZMod.dft f k * starRingEnd ℂ (ZMod.dft f k)) =
      (q : ℂ) * ∑ x : ZMod q, f x * starRingEnd ℂ (f x) := by
    rw [hpair, Finset.mul_sum]
    apply Finset.sum_congr rfl
    intro x _
    ring
  simp only [Complex.mul_conj'] at hcomplex
  apply Complex.ofReal_injective
  push_cast
  exact hcomplex

theorem norm_dft_mulconv_sq_le {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) {k : ZMod q} (hk : IsUnit k) :
    ‖ZMod.dft (cyclicMultiplicativeConvolution f g) k‖ ^ 2 ≤
      (∑ x : ZMod q, ‖g x‖ ^ 2) * ((q : ℝ) * ∑ x : ZMod q, ‖f x‖ ^ 2) := by
  obtain ⟨u, rfl⟩ := hk
  have hperm : (∑ x : ZMod q, ‖ZMod.dft f (x * (u : ZMod q))‖ ^ 2) =
      ∑ x : ZMod q, ‖ZMod.dft f x‖ ^ 2 := by
    exact Fintype.sum_equiv u.mulRight _ _ (fun _ => rfl)
  rw [dft_cyclicMultiplicativeConvolution]
  calc
    ‖∑ x : ZMod q, g x * ZMod.dft f (x * (u : ZMod q))‖ ^ 2 ≤
        (∑ x : ZMod q, ‖g x‖ * ‖ZMod.dft f (x * (u : ZMod q))‖) ^ 2 := by
      apply pow_le_pow_left₀ (norm_nonneg _) _ 2
      simpa only [norm_mul] using norm_sum_le Finset.univ
        (fun x : ZMod q => g x * ZMod.dft f (x * (u : ZMod q)))
    _ ≤ (∑ x : ZMod q, ‖g x‖ ^ 2) *
        ∑ x : ZMod q, ‖ZMod.dft f (x * (u : ZMod q))‖ ^ 2 :=
      Finset.sum_mul_sq_le_sq_mul_sq _ _ _
    _ = _ := by rw [hperm, dft_parseval]

theorem sum_norm_cyclicUniformNatSet {q : ℕ} [NeZero q] {A : Finset ℕ} (hA : A.Nonempty) :
    (∑ x : ZMod q, ‖cyclicUniformNatSet A x‖) = 1 := by
  have hsum := dft_cyclicUniformNatSet_at_zero (q := q) hA
  rw [ZMod.dft_apply_zero] at hsum
  have hre := congrArg Complex.re hsum
  simp only [norm_cyclicUniformNatSet]
  simpa only [Complex.re_sum, cyclicUniformNatSet_eq_residue_mass, Complex.ofReal_re,
    Complex.one_re] using hre

theorem sum_sq_norm_cyclicUniformNatSet_le {q : ℕ} [NeZero q]
    {A : Finset ℕ} (hA : A.Nonempty) {M : ℝ}
    (hM : ∀ x : ZMod q, ‖cyclicUniformNatSet A x‖ ≤ M) :
    (∑ x : ZMod q, ‖cyclicUniformNatSet A x‖ ^ 2) ≤ M := by
  calc
    _ ≤ ∑ x : ZMod q, M * ‖cyclicUniformNatSet A x‖ := by
      apply Finset.sum_le_sum
      intro x _
      simpa only [pow_two] using mul_le_mul_of_nonneg_right (hM x) (norm_nonneg _)
    _ = M := by rw [← Finset.mul_sum, sum_norm_cyclicUniformNatSet hA, mul_one]

theorem norm_dft_mulconv_uniform_sq_le {q : ℕ} [NeZero q]
    {A B : Finset ℕ} (hA : A.Nonempty) (hB : B.Nonempty) {M₁ M₂ : ℝ}
    (hM₁ : ∀ x : ZMod q, ‖cyclicUniformNatSet A x‖ ≤ M₁)
    (hM₂ : ∀ x : ZMod q, ‖cyclicUniformNatSet B x‖ ≤ M₂)
    {k : ZMod q} (hk : IsUnit k) :
    ‖ZMod.dft (cyclicMultiplicativeConvolution (cyclicUniformNatSet A)
      (cyclicUniformNatSet B)) k‖ ^ 2 ≤ (q : ℝ) * M₁ * M₂ := by
  have hM₂pos : 0 ≤ M₂ := (norm_nonneg (cyclicUniformNatSet B (0 : ZMod q))).trans (hM₂ 0)
  calc
    _ ≤ (∑ x : ZMod q, ‖cyclicUniformNatSet B x‖ ^ 2) *
        ((q : ℝ) * ∑ x : ZMod q, ‖cyclicUniformNatSet A x‖ ^ 2) :=
      norm_dft_mulconv_sq_le _ _ hk
    _ ≤ M₂ * ((q : ℝ) * M₁) := by
      apply mul_le_mul (sum_sq_norm_cyclicUniformNatSet_le hB hM₂)
        (mul_le_mul_of_nonneg_left (sum_sq_norm_cyclicUniformNatSet_le hA hM₁)
          (Nat.cast_nonneg q))
      · positivity
      · exact hM₂pos
    _ = _ := by ring

theorem norm_dft_mulconv_uniform_dyadic_le {J : ℕ} {A B : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) {g₁ g₂ : ℝ}
    (hM₁ : ∀ x : ZMod (2 ^ J), ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-g₁ * (J : ℝ)))
    (hM₂ : ∀ x : ZMod (2 ^ J), ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-g₂ * (J : ℝ)))
    {k : ZMod (2 ^ J)} (hk : IsUnit k) :
    ‖ZMod.dft (cyclicMultiplicativeConvolution (cyclicUniformNatSet A)
      (cyclicUniformNatSet B)) k‖ ≤ (2 : ℝ) ^ (-((g₁ + g₂ - 1) / 2) * (J : ℝ)) := by
  have hs := norm_dft_mulconv_uniform_sq_le hA hB hM₁ hM₂ hk
  have heq : ((2 ^ J : ℕ) : ℝ) * (2 : ℝ) ^ (-g₁ * (J : ℝ)) *
      (2 : ℝ) ^ (-g₂ * (J : ℝ)) =
      ((2 : ℝ) ^ (-((g₁ + g₂ - 1) / 2) * (J : ℝ))) ^ 2 := by
    rw [show ((2 ^ J : ℕ) : ℝ) = (2 : ℝ) ^ (J : ℝ) by simp,
      ← Real.rpow_add (by norm_num), ← Real.rpow_add (by norm_num),
      ← Real.rpow_mul_natCast (by norm_num)]
    congr 1
    push_cast
    ring
  rw [heq] at hs
  have hp : 0 < (2 : ℝ) ^ (-((g₁ + g₂ - 1) / 2) * (J : ℝ)) :=
    Real.rpow_pos_of_pos (by norm_num) _
  nlinarith [norm_nonneg (ZMod.dft (cyclicMultiplicativeConvolution
    (cyclicUniformNatSet A) (cyclicUniformNatSet B)) k)]

theorem sum_uniformNatSet_mul {q : ℕ} [NeZero q] (A : Finset ℕ) (F : ZMod q → ℂ) :
    (∑ x : ZMod q, cyclicUniformNatSet A x * F x) =
      (∑ n ∈ A, F (n : ZMod q)) * (A.card : ℂ)⁻¹ := by
  classical
  unfold cyclicUniformNatSet cyclicPushforward
  simp only [Finset.sum_mul]
  rw [Finset.sum_comm]
  simp only [ite_mul, zero_mul]
  simp only [Finset.sum_ite_eq, Finset.mem_univ, if_true]
  rw [Finset.sum_coe_sort A (fun n : ℕ => (A.card : ℂ)⁻¹ * F (n : ZMod q))]
  apply Finset.sum_congr rfl
  intro n _
  ring

theorem dft_mulconv_uniform {q : ℕ} [NeZero q] (A B : Finset ℕ) (k : ZMod q) :
    ZMod.dft (cyclicMultiplicativeConvolution (cyclicUniformNatSet A)
      (cyclicUniformNatSet B)) k =
      (∑ b ∈ B, ZMod.dft (cyclicUniformNatSet A) ((b : ZMod q) * k)) * (B.card : ℂ)⁻¹ := by
  rw [dft_cyclicMultiplicativeConvolution, sum_uniformNatSet_mul]

theorem dft_mulconv_uniform_transfer {Q q : ℕ} [NeZero Q] [NeZero q]
    (A B : Finset ℕ) (x : ZMod Q) (y : ZMod q)
    (hphase : ∀ n : ℕ, ZMod.stdAddChar (-((n : ZMod Q) * x)) =
      ZMod.stdAddChar (-((n : ZMod q) * y))) :
    ZMod.dft (cyclicMultiplicativeConvolution (cyclicUniformNatSet A)
      (cyclicUniformNatSet B)) x =
      ZMod.dft (cyclicMultiplicativeConvolution (cyclicUniformNatSet A)
        (cyclicUniformNatSet B)) y := by
  rw [dft_mulconv_uniform, dft_mulconv_uniform]
  congr 1
  apply Finset.sum_congr rfl
  intro b _
  rw [dft_cyclicUniformNatSet, dft_cyclicUniformNatSet]
  congr 1
  apply Finset.sum_congr rfl
  intro a _
  simpa only [Nat.cast_mul, mul_assoc] using hphase (a * b)

theorem odd_natCast_isUnit_dyadic (J : ℕ) {m : ℕ} (hm : Odd m) :
    IsUnit (m : ZMod (2 ^ J)) := by
  apply (ZMod.isUnit_iff_coprime _ _).mpr
  have hcop : Nat.Coprime m 2 := by
    rw [Nat.coprime_comm, Nat.prime_two.coprime_iff_not_dvd]
    obtain ⟨t, ht⟩ := hm
    omega
  exact hcop.pow_right J

theorem norm_dft_mulconv_uniform_conductor_le {K : ℕ} {A B : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) {g₁ g₂ : ℝ}
    (hM₁ : ∀ j : ℕ, 1 ≤ j → j ≤ K → ∀ x : ZMod (2 ^ j),
      ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-g₁ * (j : ℝ)))
    (hM₂ : ∀ j : ℕ, 1 ≤ j → j ≤ K → ∀ x : ZMod (2 ^ j),
      ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-g₂ * (j : ℝ)))
    {x : ZMod (2 ^ K)} (hx : x ≠ 0) :
    ‖ZMod.dft (cyclicMultiplicativeConvolution (cyclicUniformNatSet A)
      (cyclicUniformNatSet B)) x‖ ≤
      (2 : ℝ) ^ (-((g₁ + g₂ - 1) / 2) * (dyadicConductorLevel x : ℝ)) := by
  have hj : 1 ≤ dyadicConductorLevel x := dyadic_conductor_pos hx
  have hjK : dyadicConductorLevel x ≤ K := (dyadic_conductor_spec x).1
  obtain ⟨m, hm, hfactor⟩ := dyadic_frequency_factor hx
  rw [dft_mulconv_uniform_transfer A B x (m : ZMod (2 ^ dyadicConductorLevel x))
    (fun n => dyadic_frequency_phase hjK hfactor n)]
  exact norm_dft_mulconv_uniform_dyadic_le hA hB (hM₁ _ hj hjK) (hM₂ _ hj hjK)
    (odd_natCast_isUnit_dyadic _ hm)

theorem exists_power_mulconv_uniform_nonzero {g₁ g₂ : ℝ} (hg : 1 < g₁ + g₂) :
    ∃ s : ℕ, 0 < s ∧ ∀ K : ℕ, ∀ A B : Finset ℕ, A.Nonempty → B.Nonempty →
      (∀ j : ℕ, 1 ≤ j → j ≤ K → ∀ x : ZMod (2 ^ j),
        ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-g₁ * (j : ℝ))) →
      (∀ j : ℕ, 1 ≤ j → j ≤ K → ∀ x : ZMod (2 ^ j),
        ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-g₂ * (j : ℝ))) →
      ∀ x : ZMod (2 ^ K), cyclicConvolutionPow
        (cyclicMultiplicativeConvolution (cyclicUniformNatSet A) (cyclicUniformNatSet B)) s x ≠ 0 := by
  obtain ⟨s, hs, hsum⟩ := exists_convolution_power_for_dyadic_decay
    (show 0 < (g₁ + g₂ - 1) / 2 by linarith)
  refine ⟨s, hs, ?_⟩
  intro K A B hA hB hM₁ hM₂
  apply convolution_pow_nonzero_of_fourier_bound
  · rw [dft_cyclicMultiplicativeConvolution_at_zero, dft_cyclicUniformNatSet_at_zero hA,
      dft_cyclicUniformNatSet_at_zero hB, mul_one]
  · apply hsum
    intro x hx
    exact norm_dft_mulconv_uniform_conductor_le hA hB hM₁ hM₂ hx

theorem exists_subset_with_prescribed_fiber_card {α β : Type*} [DecidableEq α] [DecidableEq β]
    (S : Finset α) (f : α → β) (P : Finset β) (k : ℕ)
    (hk : ∀ b ∈ P, k ≤ (S.filter (fun a => f a = b)).card) :
    ∃ U : Finset α, U ⊆ S ∧ U.image f ⊆ P ∧
      (∀ b ∈ P, (U.filter (fun a => f a = b)).card = k) ∧ U.card = P.card * k := by
  classical
  have hchoose : ∀ b : β, ∃ V : Finset α,
      V ⊆ S.filter (fun a => f a = b) ∧ (b ∈ P → V.card = k) := by
    intro b
    by_cases hb : b ∈ P
    · obtain ⟨V, hV, hcard⟩ := Finset.exists_subset_card_eq (hk b hb)
      exact ⟨V, hV, fun _ => hcard⟩
    · exact ⟨∅, Finset.empty_subset _, by simp [hb]⟩
  choose V hV hcard using hchoose
  let U := P.biUnion V
  have hU : U ⊆ S := by
    intro a ha
    obtain ⟨b, hb, hab⟩ := Finset.mem_biUnion.mp ha
    exact (Finset.mem_filter.mp (hV b hab)).1
  have himage : U.image f ⊆ P := by
    intro b hb
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hb
    obtain ⟨c, hc, hac⟩ := Finset.mem_biUnion.mp ha
    exact (Finset.mem_filter.mp (hV c hac)).2.symm ▸ hc
  have hfiber : ∀ b ∈ P, U.filter (fun a => f a = b) = V b := by
    intro b hb
    ext a
    constructor
    · intro ha
      obtain ⟨haU, hab⟩ := Finset.mem_filter.mp ha
      obtain ⟨c, hc, hac⟩ := Finset.mem_biUnion.mp haU
      have hcb : c = b := (Finset.mem_filter.mp (hV c hac)).2.symm.trans hab
      exact hcb ▸ hac
    · intro ha
      exact Finset.mem_filter.mpr ⟨Finset.mem_biUnion.mpr ⟨b, hb, ha⟩,
        (Finset.mem_filter.mp (hV b ha)).2⟩
  have hdisjoint : (P : Set β).PairwiseDisjoint V := by
    intro b hb c hc hbc
    apply Finset.disjoint_left.mpr
    intro a hab hac
    exact hbc ((Finset.mem_filter.mp (hV b hab)).2.symm.trans (Finset.mem_filter.mp (hV c hac)).2)
  refine ⟨U, hU, himage, ?_, ?_⟩
  · intro b hb
    rw [hfiber b hb, hcard b hb]
  · change (P.biUnion V).card = _
    rw [Finset.card_biUnion hdisjoint]
    calc
      ∑ b ∈ P, (V b).card = ∑ _b ∈ P, k := Finset.sum_congr rfl hcard
      _ = _ := by simp

theorem exists_dyadic_uniform_fibers {α β : Type*} [DecidableEq α] [DecidableEq β]
    (S : Finset α) (f : α → β) (T : ℕ)
    (hbound : ∀ b ∈ S.image f, (S.filter (fun a => f a = b)).card ≤ 2 ^ T) :
    ∃ k : ℕ, k ≤ T ∧ ∃ U : Finset α, U ⊆ S ∧
      S.card ≤ 2 * (T + 1) * U.card ∧
      ∀ b ∈ U.image f, (U.filter (fun a => f a = b)).card = 2 ^ k := by
  classical
  let P := S.image f
  let c : β → ℕ := fun b => (S.filter (fun a => f a = b)).card
  let bucket : ℕ → Finset β := fun k => P.filter (fun b => Nat.log 2 (c b) = k)
  let w : ℕ → ℕ := fun k => ∑ b ∈ bucket k, c b
  have hcpos : ∀ b ∈ P, c b ≠ 0 := by
    intro b hb
    obtain ⟨a, ha, hab⟩ := Finset.mem_image.mp hb
    exact Finset.card_ne_zero.mpr ⟨a, Finset.mem_filter.mpr ⟨ha, hab⟩⟩
  have hmaps : ∀ b ∈ P, Nat.log 2 (c b) ∈ Finset.range (T + 1) := by
    intro b hb
    apply Finset.mem_range.mpr
    have hlog := Nat.log_monotone (b := 2) (hbound b hb)
    rw [Nat.log_pow (by decide : 1 < 2)] at hlog
    change Nat.log 2 (c b) ≤ T at hlog
    omega
  have hsum : (∑ k ∈ Finset.range (T + 1), w k) = S.card := by
    change (∑ k ∈ Finset.range (T + 1), ∑ b ∈ P.filter (fun b => Nat.log 2 (c b) = k), c b) = _
    rw [Finset.sum_fiberwise_of_maps_to hmaps]
    exact (Finset.card_eq_sum_card_image f S).symm
  obtain ⟨k, hk, hmax⟩ := Finset.exists_max_image (Finset.range (T + 1)) w
    (Finset.nonempty_range_iff.mpr (by omega))
  have hbig : S.card ≤ (T + 1) * w k := by
    rw [← hsum]
    calc
      _ ≤ ∑ _i ∈ Finset.range (T + 1), w k := Finset.sum_le_sum hmax
      _ = _ := by simp
  have hlo : ∀ b ∈ bucket k, 2 ^ k ≤ c b := by
    intro b hb
    obtain ⟨hbP, hlog⟩ := Finset.mem_filter.mp hb
    rw [← hlog]
    exact Nat.pow_log_le_self 2 (hcpos b hbP)
  have hhi : ∀ b ∈ bucket k, c b ≤ 2 * 2 ^ k := by
    intro b hb
    have hlog := (Finset.mem_filter.mp hb).2
    have hpow := (Nat.lt_pow_succ_log_self (by decide : 1 < 2) (c b)).le
    simpa only [hlog, Nat.succ_eq_add_one, pow_succ, Nat.mul_comm] using hpow
  obtain ⟨U, hUS, hUP, hfiber, hcard⟩ :=
    exists_subset_with_prescribed_fiber_card S f (bucket k) (2 ^ k) hlo
  have hw : w k ≤ 2 * U.card := by
    change (∑ b ∈ bucket k, c b) ≤ _
    calc
      _ ≤ ∑ _b ∈ bucket k, 2 * 2 ^ k := Finset.sum_le_sum hhi
      _ = 2 * U.card := by simp only [Finset.sum_const, smul_eq_mul, hcard]; ring
  refine ⟨k, by have := Finset.mem_range.mp hk; omega, U, hUS, ?_, ?_⟩
  · calc
      S.card ≤ (T + 1) * w k := hbig
      _ ≤ (T + 1) * (2 * U.card) := Nat.mul_le_mul_left _ hw
      _ = _ := by ring
  · intro b hb
    exact hfiber b (hUP hb)

theorem exists_dyadic_first_split {A : Finset ℕ} {b e : ℕ}
    (hcard : 1 < A.card) (hbound : ∀ x ∈ A, x < 2 ^ e)
    (hbase : ∀ x ∈ A, ∀ y ∈ A, x % 2 ^ b = y % 2 ^ b) :
    ∃ m : ℕ, b ≤ m ∧ m < e ∧
      (∀ x ∈ A, ∀ y ∈ A, x % 2 ^ m = y % 2 ^ m) ∧
      ∃ x ∈ A, ∃ y ∈ A, x % 2 ^ (m + 1) ≠ y % 2 ^ (m + 1) := by
  classical
  let P : ℕ → Prop := fun l => ∃ x ∈ A, ∃ y ∈ A, x % 2 ^ l ≠ y % 2 ^ l
  have hPe : P e := by
    obtain ⟨x, hx, y, hy, hxy⟩ := Finset.one_lt_card.mp hcard
    refine ⟨x, hx, y, hy, ?_⟩
    simpa only [Nat.mod_eq_of_lt (hbound x hx), Nat.mod_eq_of_lt (hbound y hy)] using hxy
  have hex : ∃ l, P l := ⟨e, hPe⟩
  let l := Nat.find hex
  have hl : P l := Nat.find_spec hex
  have hle : l ≤ e := Nat.find_min' hex hPe
  have hbl : b < l := by
    by_contra hn
    have hlb : l ≤ b := by omega
    obtain ⟨x, hx, y, hy, hxy⟩ := hl
    have hmod : Nat.ModEq (2 ^ b) x y := hbase x hx y hy
    exact hxy (hmod.of_dvd (pow_dvd_pow 2 hlb))
  refine ⟨l - 1, by omega, by omega, ?_, ?_⟩
  · intro x hx y hy
    by_contra hxy
    exact (Nat.find_min hex (show l - 1 < l by omega)) ⟨x, hx, y, hy, hxy⟩
  · simpa only [Nat.sub_add_cancel (show 1 ≤ l by omega)] using hl

theorem dyadic_residue_fiber_card_le {A : Finset ℕ} {b T : ℕ}
    (hbound : ∀ x ∈ A, x < 2 ^ (b + T)) (r : ℕ) :
    (A.filter (fun x => x % 2 ^ b = r)).card ≤ 2 ^ T := by
  classical
  let S := A.filter (fun x => x % 2 ^ b = r)
  have hinj : Set.InjOn (fun x : ℕ => x / 2 ^ b) S := by
    intro x hx y hy hdiv
    have hmod : x % 2 ^ b = y % 2 ^ b :=
      (Finset.mem_filter.mp hx).2.trans (Finset.mem_filter.mp hy).2.symm
    change x / 2 ^ b = y / 2 ^ b at hdiv
    calc
      x = x % 2 ^ b + 2 ^ b * (x / 2 ^ b) := (Nat.mod_add_div x (2 ^ b)).symm
      _ = y % 2 ^ b + 2 ^ b * (y / 2 ^ b) := by rw [hmod, hdiv]
      _ = y := Nat.mod_add_div y (2 ^ b)
  have himage : S.image (fun x => x / 2 ^ b) ⊆ Finset.range (2 ^ T) := by
    intro n hn
    obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hn
    apply Finset.mem_range.mpr
    apply (Nat.div_lt_iff_lt_mul (by positivity : 0 < 2 ^ b)).mpr
    simpa only [pow_add, Nat.mul_comm] using hbound x (Finset.mem_filter.mp hx).1
  calc
    _ = (S.image (fun x => x / 2 ^ b)).card := (Finset.card_image_of_injOn hinj).symm
    _ ≤ (Finset.range (2 ^ T)).card := Finset.card_le_card himage
    _ = _ := Finset.card_range _

theorem exists_large_fiber {α β : Type*} [DecidableEq α] [DecidableEq β]
    (S : Finset α) (f : α → β) (P : Finset β) (hP : P.Nonempty)
    (hmaps : ∀ a ∈ S, f a ∈ P) :
    ∃ b ∈ P, S.card ≤ P.card * (S.filter (fun a => f a = b)).card := by
  classical
  obtain ⟨b, hb, hmax⟩ := Finset.exists_max_image P
    (fun b => (S.filter (fun a => f a = b)).card) hP
  refine ⟨b, hb, ?_⟩
  calc
    S.card = ∑ c ∈ P, (S.filter (fun a => f a = c)).card :=
      Finset.card_eq_sum_card_fiberwise hmaps
    _ ≤ ∑ _c ∈ P, (S.filter (fun a => f a = b)).card := Finset.sum_le_sum hmax
    _ = _ := by simp

-- The auxiliary choice of a level is intentionally unconstrained outside the image of S.
theorem exists_dyadic_regular_block {A : Finset ℕ} {b T : ℕ} (hT : 0 < T)
    (hbound : ∀ x ∈ A, x < 2 ^ (b + T)) :
    ∃ U : Finset ℕ, U ⊆ A ∧ ∃ m k : ℕ, b ≤ m ∧ m < b + T ∧ k ≤ T ∧
      A.card ≤ 2 * (T + 1) ^ 2 * U.card ∧
      (∀ x ∈ U, ∀ y ∈ U, x % 2 ^ b = y % 2 ^ b → x % 2 ^ m = y % 2 ^ m) ∧
      ∀ r ∈ U.image (fun x => x % 2 ^ m),
        (U.filter (fun x => x % 2 ^ m = r)).card = 2 ^ k ∧
        (0 < k → ∃ x ∈ U.filter (fun x => x % 2 ^ m = r),
          ∃ y ∈ U.filter (fun x => x % 2 ^ m = r), x % 2 ^ (m + 1) ≠ y % 2 ^ (m + 1)) := by
  classical
  obtain ⟨k, hkT, S, hSA, hsize, hcard⟩ := exists_dyadic_uniform_fibers A
    (fun x => x % 2 ^ b) T (fun r _ => dyadic_residue_fiber_card_le hbound r)
  by_cases hk : k = 0
  · refine ⟨S, hSA, b, k, le_rfl, by omega, hkT, ?_, ?_, ?_⟩
    · exact hsize.trans (Nat.mul_le_mul_right S.card (by nlinarith))
    · intro x hx y hy hxy
      exact hxy
    · intro r hr
      exact ⟨hcard r hr, by simp [hk]⟩
  have hkpos : 0 < k := Nat.pos_of_ne_zero hk
  let P := S.image (fun x => x % 2 ^ b)
  let F : ℕ → Finset ℕ := fun r => S.filter (fun x => x % 2 ^ b = r)
  have hchoose : ∀ r : ℕ, ∃ m : ℕ, r ∈ P → b ≤ m ∧ m < b + T ∧
      (∀ x ∈ F r, ∀ y ∈ F r, x % 2 ^ m = y % 2 ^ m) ∧
      ∃ x ∈ F r, ∃ y ∈ F r, x % 2 ^ (m + 1) ≠ y % 2 ^ (m + 1) := by
    intro r
    by_cases hr : r ∈ P
    · have hFr : 1 < (F r).card := by
        rw [show (F r).card = 2 ^ k from hcard r hr]
        exact one_lt_pow₀ (by decide : 1 < (2 : ℕ)) hkpos.ne'
      obtain ⟨m, hm⟩ := exists_dyadic_first_split hFr
        (fun x hx => hbound x (hSA (Finset.mem_filter.mp hx).1))
        (fun x hx y hy => (Finset.mem_filter.mp hx).2.trans (Finset.mem_filter.mp hy).2.symm)
      exact ⟨m, fun _ => hm⟩
    · exact ⟨b, fun h => (hr h).elim⟩
  choose level hlevel using hchoose
  have hmaps : ∀ x ∈ S, level (x % 2 ^ b) ∈ Finset.Ico b (b + T) := by
    intro x hx
    have hh := hlevel (x % 2 ^ b) (Finset.mem_image_of_mem _ hx)
    exact Finset.mem_Ico.mpr ⟨hh.1, hh.2.1⟩
  obtain ⟨m, hm, hlarge⟩ := exists_large_fiber S (fun x => level (x % 2 ^ b))
    (Finset.Ico b (b + T)) (Finset.nonempty_Ico.mpr (by omega)) hmaps
  have hbm : b ≤ m := (Finset.mem_Ico.mp hm).1
  have hme : m < b + T := (Finset.mem_Ico.mp hm).2
  let U := S.filter (fun x => level (x % 2 ^ b) = m)
  have hUS : U ⊆ S := Finset.filter_subset _ _
  have hlarge' : S.card ≤ T * U.card := by simpa only [Nat.card_Ico, Nat.add_sub_cancel_left] using hlarge
  have hcommon : ∀ x ∈ U, ∀ y ∈ U, x % 2 ^ b = y % 2 ^ b → x % 2 ^ m = y % 2 ^ m := by
    intro x hx y hy hxy
    have hxS : x ∈ S := hUS hx
    have hh := hlevel (x % 2 ^ b) (Finset.mem_image_of_mem _ hxS)
    have hxm : level (x % 2 ^ b) = m := (Finset.mem_filter.mp hx).2
    rw [hxm] at hh
    exact hh.2.2.1 x (Finset.mem_filter.mpr ⟨hxS, rfl⟩) y
      (Finset.mem_filter.mpr ⟨hUS hy, hxy.symm⟩)
  refine ⟨U, hUS.trans hSA, m, k, hbm, hme, hkT, ?_, hcommon, ?_⟩
  · calc
      A.card ≤ 2 * (T + 1) * S.card := hsize
      _ ≤ 2 * (T + 1) * (T * U.card) := Nat.mul_le_mul_left _ hlarge'
      _ = (2 * (T + 1) * T) * U.card := by ring
      _ ≤ 2 * (T + 1) ^ 2 * U.card := Nat.mul_le_mul_right _ (by nlinarith)
  · intro r hr
    obtain ⟨a, haU, har⟩ := Finset.mem_image.mp hr
    have haS := hUS haU
    have habP : a % 2 ^ b ∈ P := Finset.mem_image_of_mem _ haS
    have hla : level (a % 2 ^ b) = m := (Finset.mem_filter.mp haU).2
    have hh := hlevel (a % 2 ^ b) habP
    rw [hla] at hh
    have hfiber : U.filter (fun x => x % 2 ^ m = r) = F (a % 2 ^ b) := by
      ext x
      constructor
      · intro hx
        obtain ⟨hxU, hxr⟩ := Finset.mem_filter.mp hx
        have hxm : Nat.ModEq (2 ^ m) x a := hxr.trans har.symm
        exact Finset.mem_filter.mpr ⟨hUS hxU, hxm.of_dvd (pow_dvd_pow 2 hbm)⟩
      · intro hx
        obtain ⟨hxS, hxb⟩ := Finset.mem_filter.mp hx
        have hxU : x ∈ U := Finset.mem_filter.mpr ⟨hxS, by rw [hxb, hla]⟩
        have hxa := hh.2.2.1 x (Finset.mem_filter.mpr ⟨hxS, hxb⟩) a
          (Finset.mem_filter.mpr ⟨haS, rfl⟩)
        exact Finset.mem_filter.mpr ⟨hxU, hxa.trans har⟩
    refine ⟨?_, fun _ => ?_⟩
    · rw [hfiber]
      exact hcard _ habP
    · rw [hfiber]
      exact hh.2.2.2

def dyadicProjection (A : Finset ℕ) (j : ℕ) : Finset ℕ :=
  A.image (fun x => x % 2 ^ j)

def dyadicLift (A : Finset ℕ) (j : ℕ) (P : Finset ℕ) : Finset ℕ :=
  A.filter (fun x => x % 2 ^ j ∈ P)

theorem dyadic_projection_bounded (A : Finset ℕ) (j : ℕ) :
    ∀ x ∈ dyadicProjection A j, x < 2 ^ j := by
  intro x hx
  obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
  exact Nat.mod_lt _ (by positivity)

theorem dyadic_projection_self {A : Finset ℕ} {j : ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ j) : dyadicProjection A j = A := by
  ext x
  constructor
  · intro hx
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
    simpa only [Nat.mod_eq_of_lt (hA a ha)] using ha
  · intro hx
    exact Finset.mem_image.mpr ⟨x, hx, Nat.mod_eq_of_lt (hA x hx)⟩

theorem dyadic_projection_trans (A : Finset ℕ) {j k : ℕ} (hjk : j ≤ k) :
    dyadicProjection (dyadicProjection A k) j = dyadicProjection A j := by
  unfold dyadicProjection
  rw [Finset.image_image]
  apply Finset.image_congr
  intro x hx
  exact Nat.mod_mod_of_dvd x (pow_dvd_pow 2 hjk)

theorem dyadic_lift_subset (A : Finset ℕ) (j : ℕ) (P : Finset ℕ) :
    dyadicLift A j P ⊆ A := Finset.filter_subset _ _

theorem dyadic_projection_lift {A P : Finset ℕ} {j : ℕ}
    (hP : P ⊆ dyadicProjection A j) : dyadicProjection (dyadicLift A j P) j = P := by
  ext r
  constructor
  · intro hr
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hr
    exact (Finset.mem_filter.mp ha).2
  · intro hr
    obtain ⟨a, ha, har⟩ := Finset.mem_image.mp (hP hr)
    exact Finset.mem_image.mpr ⟨a, Finset.mem_filter.mpr ⟨ha, har.symm ▸ hr⟩, har⟩

theorem dyadic_lift_fiber {A P : Finset ℕ} {j r : ℕ} (hr : r ∈ P) :
    (dyadicLift A j P).filter (fun x => x % 2 ^ j = r) =
      A.filter (fun x => x % 2 ^ j = r) := by
  ext x
  constructor
  · intro hx
    obtain ⟨hx, hxr⟩ := Finset.mem_filter.mp hx
    exact Finset.mem_filter.mpr ⟨(Finset.mem_filter.mp hx).1, hxr⟩
  · intro hx
    obtain ⟨hx, hxr⟩ := Finset.mem_filter.mp hx
    exact Finset.mem_filter.mpr ⟨Finset.mem_filter.mpr ⟨hx, hxr.symm ▸ hr⟩, hxr⟩

theorem dyadic_lift_card {A P : Finset ℕ} {j v : ℕ}
    (hcard : ∀ r ∈ P, (A.filter (fun x => x % 2 ^ j = r)).card = v) :
    (dyadicLift A j P).card = P.card * v := by
  have hmaps : ∀ x ∈ dyadicLift A j P, x % 2 ^ j ∈ P := by
    intro x hx
    exact (Finset.mem_filter.mp hx).2
  rw [Finset.card_eq_sum_card_fiberwise hmaps]
  calc
    _ = ∑ _r ∈ P, v := by
      apply Finset.sum_congr rfl
      intro r hr
      rw [dyadic_lift_fiber hr, hcard r hr]
    _ = _ := by simp

structure DyadicTreeBlock (A : Finset ℕ) (b T m k : ℕ) : Prop where
  base_le : b ≤ m
  split_lt : m < b + T
  count_le : k ≤ T
  common : ∀ x ∈ A, ∀ y ∈ A, x % 2 ^ b = y % 2 ^ b → x % 2 ^ m = y % 2 ^ m
  fiber_card : ∀ r ∈ dyadicProjection A m,
    (A.filter (fun x => x % 2 ^ m = r)).card = 2 ^ k
  splits : ∀ r ∈ dyadicProjection A m, 0 < k →
    ∃ x ∈ A.filter (fun x => x % 2 ^ m = r),
      ∃ y ∈ A.filter (fun x => x % 2 ^ m = r), x % 2 ^ (m + 1) ≠ y % 2 ^ (m + 1)

theorem exists_dyadic_tree_block {A : Finset ℕ} {b T : ℕ} (hT : 0 < T)
    (hbound : ∀ x ∈ A, x < 2 ^ (b + T)) :
    ∃ U : Finset ℕ, U ⊆ A ∧ ∃ m k : ℕ,
      DyadicTreeBlock U b T m k ∧ A.card ≤ 2 * (T + 1) ^ 2 * U.card := by
  obtain ⟨U, hUA, m, k, hbm, hme, hk, hsize, hcommon, hfiber⟩ :=
    exists_dyadic_regular_block hT hbound
  exact ⟨U, hUA, m, k, ⟨hbm, hme, hk, hcommon,
    fun r hr => (hfiber r hr).1, fun r hr => (hfiber r hr).2⟩, hsize⟩

theorem dyadic_tree_block_base_fiber {A : Finset ℕ} {b T m k a : ℕ}
    (hA : DyadicTreeBlock A b T m k) (ha : a ∈ A) :
    A.filter (fun x => x % 2 ^ b = a % 2 ^ b) =
      A.filter (fun x => x % 2 ^ m = a % 2 ^ m) := by
  ext x
  constructor
  · intro hx
    obtain ⟨hxA, hxb⟩ := Finset.mem_filter.mp hx
    exact Finset.mem_filter.mpr ⟨hxA, hA.common x hxA a ha hxb⟩
  · intro hx
    obtain ⟨hxA, hxm⟩ := Finset.mem_filter.mp hx
    have hmod : Nat.ModEq (2 ^ m) x a := hxm
    exact Finset.mem_filter.mpr ⟨hxA, hmod.of_dvd (pow_dvd_pow 2 hA.base_le)⟩

theorem dyadic_tree_block_base_card {A : Finset ℕ} {b T m k : ℕ}
    (hA : DyadicTreeBlock A b T m k) :
    ∀ r ∈ dyadicProjection A b, (A.filter (fun x => x % 2 ^ b = r)).card = 2 ^ k := by
  intro r hr
  obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hr
  rw [dyadic_tree_block_base_fiber hA ha]
  exact hA.fiber_card _ (Finset.mem_image_of_mem _ ha)

theorem dyadic_tree_block_card {A : Finset ℕ} {b T m k : ℕ}
    (hA : DyadicTreeBlock A b T m k) : A.card = (dyadicProjection A b).card * 2 ^ k := by
  rw [Finset.card_eq_sum_card_image (fun x => x % 2 ^ b) A]
  calc
    _ = ∑ _r ∈ dyadicProjection A b, 2 ^ k :=
      Finset.sum_congr rfl (dyadic_tree_block_base_card hA)
    _ = _ := by simp

theorem dyadic_tree_block_lift {A : Finset ℕ} {b T m k : ℕ}
    (hA : DyadicTreeBlock A b T m k) (P : Finset ℕ) :
    DyadicTreeBlock (dyadicLift A b P) b T m k := by
  have hsub := dyadic_lift_subset A b P
  have hfiber : ∀ r ∈ dyadicProjection (dyadicLift A b P) m,
      (dyadicLift A b P).filter (fun x => x % 2 ^ m = r) =
        A.filter (fun x => x % 2 ^ m = r) := by
    intro r hr
    obtain ⟨a, ha, har⟩ := Finset.mem_image.mp hr
    have haP : a % 2 ^ b ∈ P := (Finset.mem_filter.mp ha).2
    ext x
    constructor
    · intro hx
      obtain ⟨hx, hxr⟩ := Finset.mem_filter.mp hx
      exact Finset.mem_filter.mpr ⟨hsub hx, hxr⟩
    · intro hx
      obtain ⟨hxA, hxr⟩ := Finset.mem_filter.mp hx
      have hmod : Nat.ModEq (2 ^ m) x a := hxr.trans har.symm
      have hxb : x % 2 ^ b = a % 2 ^ b := hmod.of_dvd (pow_dvd_pow 2 hA.base_le)
      exact Finset.mem_filter.mpr ⟨Finset.mem_filter.mpr ⟨hxA, hxb.symm ▸ haP⟩, hxr⟩
  have hproj : dyadicProjection (dyadicLift A b P) m ⊆ dyadicProjection A m :=
    Finset.image_subset_image hsub
  refine ⟨hA.base_le, hA.split_lt, hA.count_le, ?_, ?_, ?_⟩
  · intro x hx y hy hxy
    exact hA.common x (hsub hx) y (hsub hy) hxy
  · intro r hr
    rw [hfiber r hr]
    exact hA.fiber_card r (hproj hr)
  · intro r hr hk
    rw [hfiber r hr]
    exact hA.splits r (hproj hr) hk

def DyadicRegularTree (A : Finset ℕ) (T N : ℕ) : Prop :=
  ∀ i : ℕ, i < N → ∃ m k : ℕ,
    DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T m k

theorem exists_dyadic_regular_tree (T : ℕ) (hT : 0 < T) :
    ∀ N : ℕ, ∀ A : Finset ℕ, (∀ x ∈ A, x < 2 ^ (T * N)) →
      ∃ B : Finset ℕ, B ⊆ A ∧ DyadicRegularTree B T N ∧
        A.card ≤ (2 * (T + 1) ^ 2) ^ N * B.card := by
  intro N
  induction N with
  | zero =>
    intro A hA
    exact ⟨A, Finset.Subset.refl _, by intro i hi; omega, by simp⟩
  | succ N ih =>
    intro A hA
    have hA' : ∀ x ∈ A, x < 2 ^ (T * N + T) := by
      simpa only [Nat.mul_add, Nat.mul_one] using hA
    obtain ⟨U, hUA, m, k, hblock, hsize⟩ := exists_dyadic_tree_block hT hA'
    obtain ⟨B, hBP, htree, hBsize⟩ := ih (dyadicProjection U (T * N))
      (dyadic_projection_bounded U (T * N))
    let V := dyadicLift U (T * N) B
    have hVU : V ⊆ U := dyadic_lift_subset _ _ _
    have hVA : V ⊆ A := hVU.trans hUA
    have hVB : dyadicProjection V (T * N) = B := dyadic_projection_lift hBP
    have hVcard : V.card = B.card * 2 ^ k :=
      dyadic_lift_card (fun r hr => dyadic_tree_block_base_card hblock r (hBP hr))
    refine ⟨V, hVA, ?_, ?_⟩
    · intro i hi
      by_cases hiN : i < N
      · obtain ⟨mi, ki, hBi⟩ := htree i hiN
        have hle : T * (i + 1) ≤ T * N := Nat.mul_le_mul_left T (by omega)
        have hproj : dyadicProjection V (T * (i + 1)) = dyadicProjection B (T * (i + 1)) := by
          rw [← hVB]
          exact (dyadic_projection_trans V hle).symm
        exact ⟨mi, ki, hproj.symm ▸ hBi⟩
      · have hiEq : i = N := by omega
        subst i
        refine ⟨m, k, ?_⟩
        rw [dyadic_projection_self (fun x hx => hA x (hVA hx))]
        exact dyadic_tree_block_lift hblock B
    · calc
        A.card ≤ 2 * (T + 1) ^ 2 * U.card := hsize
        _ = (2 * (T + 1) ^ 2) * ((dyadicProjection U (T * N)).card * 2 ^ k) := by
          rw [dyadic_tree_block_card hblock]
        _ ≤ (2 * (T + 1) ^ 2) * (((2 * (T + 1) ^ 2) ^ N * B.card) * 2 ^ k) :=
          Nat.mul_le_mul_left _ (Nat.mul_le_mul_right _ hBsize)
        _ = (2 * (T + 1) ^ 2) ^ (N + 1) * V.card := by rw [hVcard, pow_succ]; ring

theorem eventually_dyadic_regularization_cost_le {η : ℝ} (hη : 0 < η) :
    ∀ᶠ T : ℕ in Filter.atTop,
      (2 : ℝ) * ((T : ℝ) + 1) ^ 2 ≤ (2 : ℝ) ^ (η * (T : ℝ)) := by
  have hb : 0 < Real.log 2 * η := mul_pos (Real.log_pos (by norm_num)) hη
  have hsmall := ((isLittleO_pow_exp_pos_mul_atTop 2 hb).const_mul_left (8 : ℝ)).comp_tendsto
    (tendsto_natCast_atTop_atTop (R := ℝ))
  filter_upwards [hsmall.def (by norm_num : (0 : ℝ) < 1), eventually_ge_atTop (1 : ℕ)] with T hT hTpos
  have hTreal : (1 : ℝ) ≤ T := by exact_mod_cast hTpos
  have hexp : 8 * (T : ℝ) ^ 2 ≤ Real.exp ((Real.log 2 * η) * (T : ℝ)) := by
    simpa only [Function.comp_apply, Real.norm_eq_abs, one_mul,
      abs_of_nonneg (by positivity : (0 : ℝ) ≤ 8 * (T : ℝ) ^ 2),
      abs_of_pos (Real.exp_pos _)] using hT
  calc
    (2 : ℝ) * ((T : ℝ) + 1) ^ 2 ≤ 8 * (T : ℝ) ^ 2 := by nlinarith
    _ ≤ Real.exp ((Real.log 2 * η) * (T : ℝ)) := hexp
    _ = (2 : ℝ) ^ (η * (T : ℝ)) := by rw [Real.rpow_def_of_pos (by norm_num), mul_assoc]

theorem exists_dyadic_regular_tree_small_loss {η : ℝ} (hη : 0 < η) :
    ∃ T : ℕ, 0 < T ∧ ∀ N : ℕ, ∀ A : Finset ℕ, (∀ x ∈ A, x < 2 ^ (T * N)) →
      ∃ B : Finset ℕ, B ⊆ A ∧ DyadicRegularTree B T N ∧
        (A.card : ℝ) ≤ (2 : ℝ) ^ (η * ((T * N : ℕ) : ℝ)) * (B.card : ℝ) := by
  obtain ⟨T₀, hT₀⟩ := Filter.eventually_atTop.mp (eventually_dyadic_regularization_cost_le hη)
  let T := max T₀ 1
  have hT : 0 < T := lt_of_lt_of_le (by decide : 0 < 1) (le_max_right _ _)
  have hcost : (2 : ℝ) * ((T : ℝ) + 1) ^ 2 ≤ (2 : ℝ) ^ (η * (T : ℝ)) :=
    hT₀ T (le_max_left _ _)
  refine ⟨T, hT, ?_⟩
  intro N A hA
  obtain ⟨B, hBA, htree, hsize⟩ := exists_dyadic_regular_tree T hT N A hA
  refine ⟨B, hBA, htree, ?_⟩
  have hsize' : (A.card : ℝ) ≤ ((2 : ℝ) * ((T : ℝ) + 1) ^ 2) ^ N * (B.card : ℝ) := by
    exact_mod_cast hsize
  calc
    (A.card : ℝ) ≤ ((2 : ℝ) * ((T : ℝ) + 1) ^ 2) ^ N * (B.card : ℝ) := hsize'
    _ ≤ ((2 : ℝ) ^ (η * (T : ℝ))) ^ N * (B.card : ℝ) :=
      mul_le_mul_of_nonneg_right (pow_le_pow_left₀ (by positivity) hcost N) (Nat.cast_nonneg _)
    _ = (2 : ℝ) ^ (η * ((T * N : ℕ) : ℝ)) * (B.card : ℝ) := by
      rw [← Real.rpow_mul_natCast (by norm_num), Nat.cast_mul, mul_assoc]

theorem dyadic_projection_fiber_self {A : Finset ℕ} {j r : ℕ}
    (hr : r ∈ dyadicProjection A j) :
    (dyadicProjection A j).filter (fun x => x % 2 ^ j = r) = {r} := by
  ext x
  constructor
  · intro hx
    obtain ⟨hxP, hxr⟩ := Finset.mem_filter.mp hx
    have hxlt := dyadic_projection_bounded A j x hxP
    rw [Nat.mod_eq_of_lt hxlt] at hxr
    exact Finset.mem_singleton.mpr hxr
  · intro hx
    have hxr := Finset.mem_singleton.mp hx
    subst x
    exact Finset.mem_filter.mpr ⟨hr, Nat.mod_eq_of_lt (dyadic_projection_bounded A j r hr)⟩

theorem dyadic_lift_coarse_fiber (A : Finset ℕ) {b e : ℕ} (hbe : b ≤ e) (r : ℕ) :
    dyadicLift A e ((dyadicProjection A e).filter (fun y => y % 2 ^ b = r)) =
      A.filter (fun x => x % 2 ^ b = r) := by
  ext x
  constructor
  · intro hx
    obtain ⟨hxA, hxf⟩ := Finset.mem_filter.mp hx
    have hmod := (Finset.mem_filter.mp hxf).2
    rw [Nat.mod_mod_of_dvd x (pow_dvd_pow 2 hbe)] at hmod
    exact Finset.mem_filter.mpr ⟨hxA, hmod⟩
  · intro hx
    obtain ⟨hxA, hxr⟩ := Finset.mem_filter.mp hx
    refine Finset.mem_filter.mpr ⟨hxA, Finset.mem_filter.mpr ⟨Finset.mem_image_of_mem _ hxA, ?_⟩⟩
    rwa [Nat.mod_mod_of_dvd x (pow_dvd_pow 2 hbe)]

theorem dyadic_fiber_card_mul (A : Finset ℕ) {b e v : ℕ} (hbe : b ≤ e)
    (hcard : ∀ s ∈ dyadicProjection A e, (A.filter (fun x => x % 2 ^ e = s)).card = v) (r : ℕ) :
    (A.filter (fun x => x % 2 ^ b = r)).card =
      ((dyadicProjection A e).filter (fun x => x % 2 ^ b = r)).card * v := by
  rw [← dyadic_lift_coarse_fiber A hbe r]
  exact dyadic_lift_card (fun s hs => hcard s (Finset.mem_filter.mp hs).1)

theorem dyadic_regular_tree_uniform_fibers {A : Finset ℕ} {T N : ℕ}
    (htree : DyadicRegularTree A T N) : ∀ j : ℕ, j ≤ N → ∀ i : ℕ, i ≤ j →
      ∃ v : ℕ, 0 < v ∧ ∀ r ∈ dyadicProjection A (T * i),
        ((dyadicProjection A (T * j)).filter (fun x => x % 2 ^ (T * i) = r)).card = v := by
  intro j
  induction j with
  | zero =>
    intro hj i hi
    have hi0 : i = 0 := by omega
    subst i
    refine ⟨1, by decide, ?_⟩
    intro r hr
    rw [dyadic_projection_fiber_self hr, Finset.card_singleton]
  | succ j ih =>
    intro hj i hi
    by_cases hij : i = j + 1
    · subst i
      refine ⟨1, by decide, ?_⟩
      intro r hr
      rw [dyadic_projection_fiber_self hr, Finset.card_singleton]
    have hij' : i ≤ j := by omega
    obtain ⟨v, hv, hvc⟩ := ih (by omega) i hij'
    obtain ⟨m, k, hblock⟩ := htree j (by omega)
    refine ⟨v * 2 ^ k, by positivity, ?_⟩
    intro r hr
    rw [dyadic_fiber_card_mul _ (Nat.mul_le_mul_left T hij')
      (dyadic_tree_block_base_card hblock) r]
    rw [dyadic_projection_trans A (Nat.mul_le_mul_left T (show j ≤ j + 1 by omega)), hvc r hr]

theorem dyadic_regular_tree_residue_mass {A : Finset ℕ} {T N i r : ℕ}
    (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N))
    (hi : i ≤ N) (hr : r ∈ dyadicProjection A (T * i)) :
    natResidueMass A (2 ^ (T * i)) r = 1 / ((dyadicProjection A (T * i)).card : ℝ) := by
  obtain ⟨v, hv, hvc⟩ := dyadic_regular_tree_uniform_fibers htree N le_rfl i hi
  rw [dyadic_projection_self hbound] at hvc
  have hcard : A.card = (dyadicProjection A (T * i)).card * v := by
    rw [Finset.card_eq_sum_card_image (fun x => x % 2 ^ (T * i)) A]
    calc
      _ = ∑ _s ∈ dyadicProjection A (T * i), v := Finset.sum_congr rfl hvc
      _ = _ := by simp
  have hfiber : (natResidueFiber A (2 ^ (T * i)) r).card = v := by
    simpa only [natResidueFiber, Nat.ModEq,
      Nat.mod_eq_of_lt (dyadic_projection_bounded A (T * i) r hr)] using hvc r hr
  have hvR : (v : ℝ) ≠ 0 := by exact_mod_cast hv.ne'
  have hcR : ((dyadicProjection A (T * i)).card : ℝ) ≠ 0 := by
    exact_mod_cast Finset.card_ne_zero.mpr ⟨r, hr⟩
  unfold natResidueMass
  rw [hfiber, hcard, Nat.cast_mul]
  field_simp

theorem nat_sumset_card_ge_projection_mul_fiber (A B : Finset ℕ) (q : ℕ)
    (hB : ∀ x ∈ B, ∀ y ∈ B, x % q = y % q) :
    (A.image (fun x => x % q)).card * B.card ≤
      ((A ×ˢ B).image (fun p => p.1 + p.2)).card := by
  classical
  have hnonempty : ∀ r ∈ A.image (fun x => x % q),
      1 ≤ (A.filter (fun x => x % q = r)).card := by
    intro r hr
    obtain ⟨x, hx, hxr⟩ := Finset.mem_image.mp hr
    exact Finset.card_pos.mpr ⟨x, Finset.mem_filter.mpr ⟨hx, hxr⟩⟩
  obtain ⟨R, hRA, hRP, hfiber, hRcard⟩ := exists_subset_with_prescribed_fiber_card A
    (fun x => x % q) (A.image (fun x => x % q)) 1 hnonempty
  have hRinj : Set.InjOn (fun x : ℕ => x % q) R := by
    intro x hx y hy hxy
    have hcard : (R.filter (fun z => z % q = x % q)).card ≤ 1 := by
      rw [hfiber _ (Finset.mem_image_of_mem _ (hRA hx))]
    exact Finset.card_le_one.mp hcard x (Finset.mem_filter.mpr ⟨hx, rfl⟩) y
      (Finset.mem_filter.mpr ⟨hy, hxy.symm⟩)
  have hinj : Set.InjOn (fun p : ℕ × ℕ => p.1 + p.2) (R ×ˢ B : Finset (ℕ × ℕ)) := by
    intro p hp s hs hsum
    change p.1 + p.2 = s.1 + s.2 at hsum
    obtain ⟨hpR, hpB⟩ := Finset.mem_product.mp hp
    obtain ⟨hsR, hsB⟩ := Finset.mem_product.mp hs
    have hmodB : Nat.ModEq q p.2 s.2 := hB _ hpB _ hsB
    have hmodsum : Nat.ModEq q (p.1 + p.2) (s.1 + s.2) := by rw [hsum]
    have hfst : p.1 = s.1 := hRinj hpR hsR (hmodB.add_right_cancel hmodsum)
    have hsnd : p.2 = s.2 := by omega
    exact Prod.ext hfst hsnd
  calc
    _ = R.card * B.card := by rw [hRcard, mul_one]
    _ = (R ×ˢ B).card := (Finset.card_product R B).symm
    _ = ((R ×ˢ B).image (fun p => p.1 + p.2)).card := (Finset.card_image_of_injOn hinj).symm
    _ ≤ _ := Finset.card_le_card (Finset.image_subset_image
      (Finset.product_subset_product hRA (Finset.Subset.refl B)))

theorem dyadic_projection_zero {A : Finset ℕ} (hA : A.Nonempty) : dyadicProjection A 0 = {0} := by
  simpa only [dyadicProjection, pow_zero, Nat.mod_one] using Finset.image_const hA (0 : ℕ)

theorem exists_dyadic_prefix_growth {A : Finset ℕ} (hA : A.Nonempty) (T N : ℕ) (δ : ℝ) :
    ∃ i : ℕ, i ≤ N ∧ ((dyadicProjection A (T * i)).card : ℝ) ≤ (2 : ℝ) ^ (δ * ((T * i : ℕ) : ℝ)) ∧
      ∀ j : ℕ, i ≤ j → j ≤ N →
        ((dyadicProjection A (T * i)).card : ℝ) * (2 : ℝ) ^ (δ * ((T * (j - i) : ℕ) : ℝ)) ≤
          ((dyadicProjection A (T * j)).card : ℝ) := by
  classical
  let w : ℕ → ℝ := fun i => ((dyadicProjection A (T * i)).card : ℝ) /
    (2 : ℝ) ^ (δ * ((T * i : ℕ) : ℝ))
  obtain ⟨i, hi, hmin⟩ := Finset.exists_min_image (Finset.range (N + 1)) w
    (Finset.nonempty_range_iff.mpr (by omega))
  have hpow (j : ℕ) : 0 < (2 : ℝ) ^ (δ * ((T * j : ℕ) : ℝ)) :=
    Real.rpow_pos_of_pos (by norm_num) _
  have hzero : w 0 = 1 := by
    simp only [w, dyadic_projection_zero hA, Finset.card_singleton,
      Nat.cast_one, Nat.cast_zero, mul_zero, Real.rpow_zero, div_one]
  have hiupper : ((dyadicProjection A (T * i)).card : ℝ) ≤ (2 : ℝ) ^ (δ * ((T * i : ℕ) : ℝ)) := by
    have hh := hmin 0 (Finset.mem_range.mpr (by omega : 0 < N + 1))
    rw [hzero] at hh
    exact (div_le_one (hpow i)).mp hh
  refine ⟨i, by have := Finset.mem_range.mp hi; omega, hiupper, ?_⟩
  intro j hij hjN
  have hh : ((dyadicProjection A (T * i)).card : ℝ) / (2 : ℝ) ^ (δ * ((T * i : ℕ) : ℝ)) ≤
      ((dyadicProjection A (T * j)).card : ℝ) / (2 : ℝ) ^ (δ * ((T * j : ℕ) : ℝ)) :=
    hmin j (Finset.mem_range.mpr (by omega))
  have hcross := (div_le_div_iff₀ (hpow i) (hpow j)).mp hh
  have hfactor : (2 : ℝ) ^ (δ * ((T * j : ℕ) : ℝ)) =
      (2 : ℝ) ^ (δ * ((T * i : ℕ) : ℝ)) * (2 : ℝ) ^ (δ * ((T * (j - i) : ℕ) : ℝ)) := by
    rw [← Real.rpow_add (by norm_num)]
    congr 1
    simp only [Nat.cast_mul, Nat.cast_sub hij]
    ring
  rw [hfactor] at hcross
  apply (mul_le_mul_iff_left₀ (hpow i)).mp
  convert hcross using 1
  ring

theorem dyadic_regular_tree_projection_growth_bound {A B : Finset ℕ} {T N i : ℕ}
    (hBA : B ⊆ A) (hB : B.Nonempty) (htree : DyadicRegularTree B T N)
    (hbound : ∀ x ∈ B, x < 2 ^ (T * N)) (hi : i ≤ N) :
    (dyadicProjection A (T * i)).card * B.card ≤
      (dyadicProjection B (T * i)).card * ((A ×ˢ A).image (fun p => p.1 + p.2)).card := by
  obtain ⟨v, hv, hvc⟩ := dyadic_regular_tree_uniform_fibers htree N le_rfl i hi
  rw [dyadic_projection_self hbound] at hvc
  obtain ⟨a, ha⟩ := hB
  let r := a % 2 ^ (T * i)
  have hr : r ∈ dyadicProjection B (T * i) := Finset.mem_image_of_mem _ ha
  let C := B.filter (fun x => x % 2 ^ (T * i) = r)
  have hCB : C ⊆ B := Finset.filter_subset _ _
  have hCA : C ⊆ A := hCB.trans hBA
  have hCcard : C.card = v := hvc r hr
  have hBcard : B.card = (dyadicProjection B (T * i)).card * v := by
    rw [Finset.card_eq_sum_card_image (fun x => x % 2 ^ (T * i)) B]
    calc
      _ = ∑ _s ∈ dyadicProjection B (T * i), v := Finset.sum_congr rfl hvc
      _ = _ := by simp
  have hsum : (dyadicProjection A (T * i)).card * v ≤
      ((A ×ˢ A).image (fun p => p.1 + p.2)).card := by
    rw [← hCcard]
    calc
      _ ≤ ((A ×ˢ C).image (fun p => p.1 + p.2)).card :=
        nat_sumset_card_ge_projection_mul_fiber A C (2 ^ (T * i))
          (fun x hx y hy => (Finset.mem_filter.mp hx).2.trans (Finset.mem_filter.mp hy).2.symm)
      _ ≤ _ := Finset.card_le_card (Finset.image_subset_image
        (Finset.product_subset_product (Finset.Subset.refl A) hCA))
  rw [hBcard]
  calc
    _ = (dyadicProjection B (T * i)).card * ((dyadicProjection A (T * i)).card * v) := by ring
    _ ≤ _ := Nat.mul_le_mul_left _ hsum

theorem nat_modular_sumset_card_ge_projection_mul_fiber (A B : Finset ℕ) {q Q : ℕ}
    (hq : q ∣ Q) (hbound : ∀ x ∈ B, x < Q)
    (hB : ∀ x ∈ B, ∀ y ∈ B, x % q = y % q) :
    (A.image (fun x => x % q)).card * B.card ≤
      ((A ×ˢ B).image (fun p => (p.1 + p.2) % Q)).card := by
  classical
  have hnonempty : ∀ r ∈ A.image (fun x => x % q),
      1 ≤ (A.filter (fun x => x % q = r)).card := by
    intro r hr
    obtain ⟨x, hx, hxr⟩ := Finset.mem_image.mp hr
    exact Finset.card_pos.mpr ⟨x, Finset.mem_filter.mpr ⟨hx, hxr⟩⟩
  obtain ⟨R, hRA, hRP, hfiber, hRcard⟩ := exists_subset_with_prescribed_fiber_card A
    (fun x => x % q) (A.image (fun x => x % q)) 1 hnonempty
  have hRinj : Set.InjOn (fun x : ℕ => x % q) R := by
    intro x hx y hy hxy
    have hcard : (R.filter (fun z => z % q = x % q)).card ≤ 1 := by
      rw [hfiber _ (Finset.mem_image_of_mem _ (hRA hx))]
    exact Finset.card_le_one.mp hcard x (Finset.mem_filter.mpr ⟨hx, rfl⟩) y
      (Finset.mem_filter.mpr ⟨hy, hxy.symm⟩)
  have hinj : Set.InjOn (fun p : ℕ × ℕ => (p.1 + p.2) % Q) (R ×ˢ B : Finset (ℕ × ℕ)) := by
    intro p hp s hs hsum
    change (p.1 + p.2) % Q = (s.1 + s.2) % Q at hsum
    obtain ⟨hpR, hpB⟩ := Finset.mem_product.mp hp
    obtain ⟨hsR, hsB⟩ := Finset.mem_product.mp hs
    have hmodB : Nat.ModEq q p.2 s.2 := hB _ hpB _ hsB
    have hmodsum : Nat.ModEq Q (p.1 + p.2) (s.1 + s.2) := hsum
    have hfst : p.1 = s.1 := hRinj hpR hsR (hmodB.add_right_cancel (hmodsum.of_dvd hq))
    have hmodsnd : Nat.ModEq Q p.2 s.2 := by
      rw [hfst] at hmodsum
      exact (Nat.ModEq.refl s.1).add_left_cancel hmodsum
    have hsnd : p.2 = s.2 := by
      simpa only [Nat.ModEq, Nat.mod_eq_of_lt (hbound _ hpB), Nat.mod_eq_of_lt (hbound _ hsB)] using hmodsnd
    exact Prod.ext hfst hsnd
  calc
    _ = R.card * B.card := by rw [hRcard, mul_one]
    _ = (R ×ˢ B).card := (Finset.card_product R B).symm
    _ = ((R ×ˢ B).image (fun p => (p.1 + p.2) % Q)).card := (Finset.card_image_of_injOn hinj).symm
    _ ≤ _ := Finset.card_le_card (Finset.image_subset_image
      (Finset.product_subset_product hRA (Finset.Subset.refl B)))

theorem dyadic_regular_tree_modular_growth_bound {A B : Finset ℕ} {T N i : ℕ}
    (hBA : B ⊆ A) (hB : B.Nonempty) (htree : DyadicRegularTree B T N)
    (hbound : ∀ x ∈ B, x < 2 ^ (T * N)) (hi : i ≤ N) :
    (dyadicProjection A (T * i)).card * B.card ≤
      (dyadicProjection B (T * i)).card *
        ((A ×ˢ A).image (fun p => (p.1 + p.2) % 2 ^ (T * N))).card := by
  obtain ⟨v, hv, hvc⟩ := dyadic_regular_tree_uniform_fibers htree N le_rfl i hi
  rw [dyadic_projection_self hbound] at hvc
  obtain ⟨a, ha⟩ := hB
  let r := a % 2 ^ (T * i)
  have hr : r ∈ dyadicProjection B (T * i) := Finset.mem_image_of_mem _ ha
  let C := B.filter (fun x => x % 2 ^ (T * i) = r)
  have hCB : C ⊆ B := Finset.filter_subset _ _
  have hCA : C ⊆ A := hCB.trans hBA
  have hCcard : C.card = v := hvc r hr
  have hBcard : B.card = (dyadicProjection B (T * i)).card * v := by
    rw [Finset.card_eq_sum_card_image (fun x => x % 2 ^ (T * i)) B]
    calc
      _ = ∑ _s ∈ dyadicProjection B (T * i), v := Finset.sum_congr rfl hvc
      _ = _ := by simp
  have hsum : (dyadicProjection A (T * i)).card * v ≤
      ((A ×ˢ A).image (fun p => (p.1 + p.2) % 2 ^ (T * N))).card := by
    rw [← hCcard]
    calc
      _ ≤ ((A ×ˢ C).image (fun p => (p.1 + p.2) % 2 ^ (T * N))).card :=
        nat_modular_sumset_card_ge_projection_mul_fiber A C (pow_dvd_pow 2 (Nat.mul_le_mul_left T hi))
          (fun x hx => hbound x (hCB hx))
          (fun x hx y hy => (Finset.mem_filter.mp hx).2.trans (Finset.mem_filter.mp hy).2.symm)
      _ ≤ _ := Finset.card_le_card (Finset.image_subset_image
        (Finset.product_subset_product (Finset.Subset.refl A) hCA))
  rw [hBcard]
  calc
    _ = (dyadicProjection B (T * i)).card * ((dyadicProjection A (T * i)).card * v) := by ring
    _ ≤ _ := Nat.mul_le_mul_left _ hsum

theorem dyadic_projection_card_of_common {A : Finset ℕ} {b m : ℕ} (hbm : b ≤ m)
    (hcommon : ∀ x ∈ A, ∀ y ∈ A, x % 2 ^ b = y % 2 ^ b → x % 2 ^ m = y % 2 ^ m) :
    (dyadicProjection A m).card = (dyadicProjection A b).card := by
  have hinj : Set.InjOn (fun x : ℕ => x % 2 ^ b) (dyadicProjection A m) := by
    intro x hx y hy hxy
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨c, hc, rfl⟩ := Finset.mem_image.mp hy
    have hac : a % 2 ^ b = c % 2 ^ b := by
      simpa only [Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 hbm)] using hxy
    exact hcommon a ha c hc hac
  calc
    _ = (dyadicProjection (dyadicProjection A m) b).card := (Finset.card_image_of_injOn hinj).symm
    _ = _ := by rw [dyadic_projection_trans A hbm]

theorem exists_regular_tree_dense_tail {A B : Finset ℕ} {T N : ℕ}
    (hT : 0 < T) (hBA : B ⊆ A) (hB : B.Nonempty) (htree : DyadicRegularTree B T N)
    (hbound : ∀ x ∈ B, x < 2 ^ (T * N)) {γ δ ε η κ : ℝ}
    (hgap : δ < γ) (hbudget : κ + η ≤ ε * (γ - δ))
    (hlarge : (A.card : ℝ) ≤ (2 : ℝ) ^ (η * ((T * N : ℕ) : ℝ)) * (B.card : ℝ))
    (hsmall : (((A ×ˢ A).image (fun p => (p.1 + p.2) % 2 ^ (T * N))).card : ℝ) ≤
      (2 : ℝ) ^ (κ * ((T * N : ℕ) : ℝ)) * (A.card : ℝ))
    (hprojection : ∀ j : ℕ, j ≤ N → ε * (N : ℝ) < (j : ℝ) →
      (2 : ℝ) ^ (γ * ((T * j : ℕ) : ℝ)) ≤ ((dyadicProjection A (T * j)).card : ℝ)) :
    ∃ i : ℕ, i ≤ N ∧ (i : ℝ) ≤ ε * (N : ℝ) ∧
      ((dyadicProjection B (T * i)).card : ℝ) ≤ (2 : ℝ) ^ (δ * ((T * i : ℕ) : ℝ)) ∧
      ∀ j : ℕ, i ≤ j → j ≤ N →
        ((dyadicProjection B (T * i)).card : ℝ) * (2 : ℝ) ^ (δ * ((T * (j - i) : ℕ) : ℝ)) ≤
          ((dyadicProjection B (T * j)).card : ℝ) := by
  obtain ⟨i, hiN, hPi, htail⟩ := exists_dyadic_prefix_growth hB T N δ
  refine ⟨i, hiN, ?_, hPi, htail⟩
  by_contra hi
  have hiε : ε * (N : ℝ) < (i : ℝ) := lt_of_not_ge hi
  have hPA := hprojection i hiN hiε
  have hgrowth : ((dyadicProjection A (T * i)).card : ℝ) * (B.card : ℝ) ≤
      ((dyadicProjection B (T * i)).card : ℝ) *
        (((A ×ˢ A).image (fun p => (p.1 + p.2) % 2 ^ (T * N))).card : ℝ) := by
    exact_mod_cast dyadic_regular_tree_modular_growth_bound hBA hB htree hbound hiN
  have hprod : (2 : ℝ) ^ (γ * ((T * i : ℕ) : ℝ)) * (B.card : ℝ) ≤
      (2 : ℝ) ^ (δ * ((T * i : ℕ) : ℝ) + (κ + η) * ((T * N : ℕ) : ℝ)) * (B.card : ℝ) := by
    calc
      _ ≤ ((dyadicProjection A (T * i)).card : ℝ) * (B.card : ℝ) :=
        mul_le_mul_of_nonneg_right hPA (Nat.cast_nonneg _)
      _ ≤ _ := hgrowth
      _ ≤ (2 : ℝ) ^ (δ * ((T * i : ℕ) : ℝ)) *
          ((2 : ℝ) ^ (κ * ((T * N : ℕ) : ℝ)) * (A.card : ℝ)) :=
        mul_le_mul hPi hsmall (Nat.cast_nonneg _) (Real.rpow_nonneg (by norm_num) _)
      _ ≤ (2 : ℝ) ^ (δ * ((T * i : ℕ) : ℝ)) *
          ((2 : ℝ) ^ (κ * ((T * N : ℕ) : ℝ)) *
            ((2 : ℝ) ^ (η * ((T * N : ℕ) : ℝ)) * (B.card : ℝ))) := by
        apply mul_le_mul_of_nonneg_left
        · exact mul_le_mul_of_nonneg_left hlarge (Real.rpow_nonneg (by norm_num) _)
        · exact Real.rpow_nonneg (by norm_num) _
      _ = _ := by
        simp only [← mul_assoc]
        rw [← Real.rpow_add (show (0 : ℝ) < 2 by norm_num),
          ← Real.rpow_add (show (0 : ℝ) < 2 by norm_num)]
        congr 2
        ring
  have hBpos : (0 : ℝ) < B.card := by exact_mod_cast Finset.card_pos.mpr hB
  have hpow := (mul_le_mul_iff_of_pos_right hBpos).mp hprod
  have hexp := (Real.rpow_le_rpow_left_iff (by norm_num : (1 : ℝ) < 2)).mp hpow
  simp only [Nat.cast_mul] at hexp
  have hTpos : (0 : ℝ) < T := by exact_mod_cast hT
  have htailbound : (γ - δ) * (i : ℝ) ≤ (κ + η) * (N : ℝ) := by
    apply (mul_le_mul_iff_of_pos_left hTpos).mp
    nlinarith [hexp]
  have hbudgetN := mul_le_mul_of_nonneg_right hbudget (Nat.cast_nonneg N : (0 : ℝ) ≤ N)
  have hcancel : (γ - δ) * (i : ℝ) ≤ (γ - δ) * (ε * (N : ℝ)) := by nlinarith
  exact hi ((mul_le_mul_iff_of_pos_left (sub_pos.mpr hgap)).mp hcancel)

def dyadicZoom (A : Finset ℕ) (b r : ℕ) : Finset ℕ :=
  (A.filter (fun x => x % 2 ^ b = r)).image (fun x => x / 2 ^ b)

theorem dyadic_zoom_card (A : Finset ℕ) (b r : ℕ) :
    (dyadicZoom A b r).card = (A.filter (fun x => x % 2 ^ b = r)).card := by
  apply Finset.card_image_of_injOn
  intro x hx y hy hdiv
  change x / 2 ^ b = y / 2 ^ b at hdiv
  have hmod : x % 2 ^ b = y % 2 ^ b :=
    (Finset.mem_filter.mp hx).2.trans (Finset.mem_filter.mp hy).2.symm
  calc
    x = x % 2 ^ b + 2 ^ b * (x / 2 ^ b) := (Nat.mod_add_div x (2 ^ b)).symm
    _ = y % 2 ^ b + 2 ^ b * (y / 2 ^ b) := by rw [hmod, hdiv]
    _ = y := Nat.mod_add_div y (2 ^ b)

theorem dyadic_zoom_nonempty {A : Finset ℕ} {b r : ℕ} (hr : r ∈ dyadicProjection A b) :
    (dyadicZoom A b r).Nonempty := by
  obtain ⟨a, ha, har⟩ := Finset.mem_image.mp hr
  exact (show (A.filter (fun x => x % 2 ^ b = r)).Nonempty from
    ⟨a, Finset.mem_filter.mpr ⟨ha, har⟩⟩).image _

theorem dyadic_zoom_bounded {A : Finset ℕ} {b e : ℕ}
    (hA : ∀ x ∈ A, x < 2 ^ (b + e)) (r : ℕ) :
    ∀ x ∈ dyadicZoom A b r, x < 2 ^ e := by
  intro x hx
  obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
  apply (Nat.div_lt_iff_lt_mul (by positivity : 0 < 2 ^ b)).mpr
  simpa only [pow_add, Nat.mul_comm] using hA a (Finset.mem_filter.mp ha).1

theorem dyadic_projection_zoom (A : Finset ℕ) (b r l : ℕ) :
    dyadicProjection (dyadicZoom A b r) l = dyadicZoom (dyadicProjection A (b + l)) b r := by
  have hmod (a : ℕ) : a % 2 ^ (b + l) % 2 ^ b = a % 2 ^ b :=
    Nat.mod_mod_of_dvd a (pow_dvd_pow 2 (by omega))
  have hdiv (a : ℕ) : a % 2 ^ (b + l) / 2 ^ b = a / 2 ^ b % 2 ^ l := by
    rw [pow_add]
    exact Nat.mod_mul_right_div_self _ _ _
  ext z
  constructor
  · intro hz
    obtain ⟨y, hy, hyz⟩ := Finset.mem_image.mp hz
    obtain ⟨a, ha, hay⟩ := Finset.mem_image.mp hy
    obtain ⟨haA, har⟩ := Finset.mem_filter.mp ha
    refine Finset.mem_image.mpr ⟨a % 2 ^ (b + l), ?_, ?_⟩
    · exact Finset.mem_filter.mpr ⟨Finset.mem_image_of_mem _ haA, (hmod a).trans har⟩
    · rw [hdiv a, hay, hyz]
  · intro hz
    obtain ⟨y, hy, hyz⟩ := Finset.mem_image.mp hz
    obtain ⟨hyP, hyr⟩ := Finset.mem_filter.mp hy
    obtain ⟨a, haA, hay⟩ := Finset.mem_image.mp hyP
    have har : a % 2 ^ b = r := by rw [← hmod a, hay, hyr]
    refine Finset.mem_image.mpr ⟨a / 2 ^ b, ?_, ?_⟩
    · exact Finset.mem_image.mpr ⟨a, Finset.mem_filter.mpr ⟨haA, har⟩, rfl⟩
    · rw [← hdiv a, hay, hyz]

theorem dyadic_regular_tree_zoom_projection_card {A : Finset ℕ} {T N i j r : ℕ}
    (htree : DyadicRegularTree A T N) (hij : i + j ≤ N)
    (hr : r ∈ dyadicProjection A (T * i)) :
    (dyadicProjection A (T * i)).card *
      (dyadicProjection (dyadicZoom A (T * i) r) (T * j)).card =
      (dyadicProjection A (T * (i + j))).card := by
  have hlevel : T * i ≤ T * (i + j) := Nat.mul_le_mul_left T (by omega)
  obtain ⟨v, hv, hvc⟩ := dyadic_regular_tree_uniform_fibers htree (i + j) hij i (by omega)
  have hcard : (dyadicProjection A (T * (i + j))).card = (dyadicProjection A (T * i)).card * v := by
    rw [Finset.card_eq_sum_card_image (fun x => x % 2 ^ (T * i)) (dyadicProjection A (T * (i + j)))]
    change (∑ s ∈ dyadicProjection (dyadicProjection A (T * (i + j))) (T * i), _) = _
    rw [dyadic_projection_trans A hlevel]
    calc
      _ = ∑ _s ∈ dyadicProjection A (T * i), v := Finset.sum_congr rfl hvc
      _ = _ := by simp
  rw [dyadic_projection_zoom, ← Nat.mul_add, dyadic_zoom_card, hvc r hr, hcard]

theorem dyadic_regular_tree_zoom_card {A : Finset ℕ} {T N i r : ℕ}
    (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N)) (hi : i ≤ N)
    (hr : r ∈ dyadicProjection A (T * i)) :
    (dyadicProjection A (T * i)).card * (dyadicZoom A (T * i) r).card = A.card := by
  have hzoom := dyadic_zoom_bounded (b := T * i) (e := T * (N - i))
    (by simpa only [← Nat.mul_add, Nat.add_sub_of_le hi] using hbound) r
  have hh := dyadic_regular_tree_zoom_projection_card (j := N - i) htree (by omega) hr
  simpa only [dyadic_projection_self hzoom, Nat.add_sub_of_le hi, dyadic_projection_self hbound] using hh

theorem dyadic_regular_tree_zoom_growth {A : Finset ℕ} {T N i r : ℕ} {δ : ℝ}
    (htree : DyadicRegularTree A T N) (hr : r ∈ dyadicProjection A (T * i))
    (hgrowth : ∀ j : ℕ, i ≤ j → j ≤ N →
      ((dyadicProjection A (T * i)).card : ℝ) * (2 : ℝ) ^ (δ * ((T * (j - i) : ℕ) : ℝ)) ≤
        ((dyadicProjection A (T * j)).card : ℝ)) :
    ∀ j : ℕ, i + j ≤ N → (2 : ℝ) ^ (δ * ((T * j : ℕ) : ℝ)) ≤
      ((dyadicProjection (dyadicZoom A (T * i) r) (T * j)).card : ℝ) := by
  intro j hj
  have hpos : (0 : ℝ) < (dyadicProjection A (T * i)).card := by
    exact_mod_cast Finset.card_pos.mpr ⟨r, hr⟩
  have hh := hgrowth (i + j) (by omega) hj
  rw [Nat.add_sub_cancel_left] at hh
  have heq : ((dyadicProjection A (T * i)).card : ℝ) *
      ((dyadicProjection (dyadicZoom A (T * i) r) (T * j)).card : ℝ) =
      ((dyadicProjection A (T * (i + j))).card : ℝ) := by
    exact_mod_cast dyadic_regular_tree_zoom_projection_card htree hj hr
  rw [← heq] at hh
  exact (mul_le_mul_iff_of_pos_left hpos).mp hh

theorem dyadic_join_injective (d r : ℕ) :
    Function.Injective (fun x : ℕ => r + 2 ^ d * x) := by
  intro x y hxy
  exact Nat.eq_of_mul_eq_mul_left (by positivity : 0 < 2 ^ d) (Nat.add_left_cancel hxy)

theorem dyadic_join_div {d r : ℕ} (hr : r < 2 ^ d) (x : ℕ) :
    (r + 2 ^ d * x) / 2 ^ d = x := by
  rw [Nat.add_mul_div_left _ _ (by positivity), Nat.div_eq_of_lt hr, zero_add]

theorem dyadic_join_mod {d r : ℕ} (hr : r < 2 ^ d) (l x : ℕ) :
    (r + 2 ^ d * x) % 2 ^ (d + l) = r + 2 ^ d * (x % 2 ^ l) := by
  have hx : x % 2 ^ l < 2 ^ l := Nat.mod_lt _ (by positivity)
  have hbound : r + 2 ^ d * (x % 2 ^ l) < 2 ^ (d + l) := by
    rw [pow_add]
    have hmul := Nat.mul_le_mul_left (2 ^ d) (show x % 2 ^ l + 1 ≤ 2 ^ l by omega)
    nlinarith
  have hdecomp : r + 2 ^ d * x =
      (r + 2 ^ d * (x % 2 ^ l)) + 2 ^ (d + l) * (x / 2 ^ l) := by
    calc
      _ = r + 2 ^ d * (x % 2 ^ l + 2 ^ l * (x / 2 ^ l)) := by rw [Nat.mod_add_div]
      _ = _ := by rw [pow_add]; ring
  rw [hdecomp, Nat.add_mul_mod_self_left, Nat.mod_eq_of_lt hbound]

theorem dyadic_join_mod_eq_iff {d r : ℕ} (hr : r < 2 ^ d) (l x y : ℕ) :
    (r + 2 ^ d * x) % 2 ^ (d + l) = (r + 2 ^ d * y) % 2 ^ (d + l) ↔
      x % 2 ^ l = y % 2 ^ l := by
  rw [dyadic_join_mod hr, dyadic_join_mod hr]
  exact (dyadic_join_injective d r).eq_iff

theorem dyadic_zoom_mem {A : Finset ℕ} {d r x : ℕ} (hr : r < 2 ^ d) :
    x ∈ dyadicZoom A d r ↔ r + 2 ^ d * x ∈ A := by
  constructor
  · intro hx
    obtain ⟨a, ha, hax⟩ := Finset.mem_image.mp hx
    obtain ⟨haA, har⟩ := Finset.mem_filter.mp ha
    have hjoin : r + 2 ^ d * x = a := by rw [← hax, ← har, Nat.mod_add_div]
    rwa [hjoin]
  · intro hx
    refine Finset.mem_image.mpr ⟨r + 2 ^ d * x, ?_, dyadic_join_div hr x⟩
    exact Finset.mem_filter.mpr ⟨hx, by rw [Nat.add_mul_mod_self_left, Nat.mod_eq_of_lt hr]⟩

theorem dyadic_projection_zoom_mem_iff {A : Finset ℕ} {d r l s : ℕ} (hr : r < 2 ^ d) :
    s ∈ dyadicProjection (dyadicZoom A d r) l ↔
      r + 2 ^ d * s ∈ dyadicProjection A (d + l) := by
  rw [dyadic_projection_zoom, dyadic_zoom_mem hr]

theorem dyadic_zoom_fiber_image (A : Finset ℕ) {d r : ℕ} (hr : r < 2 ^ d) (l s : ℕ) :
    (((dyadicZoom A d r).filter (fun x => x % 2 ^ l = s)).image (fun x => r + 2 ^ d * x)) =
      A.filter (fun y => y % 2 ^ (d + l) = r + 2 ^ d * s) := by
  ext a
  constructor
  · intro ha
    obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp ha
    obtain ⟨hxZ, hxs⟩ := Finset.mem_filter.mp hx
    exact Finset.mem_filter.mpr ⟨(dyadic_zoom_mem hr).mp hxZ,
      by rw [dyadic_join_mod hr, hxs]⟩
  · intro ha
    obtain ⟨haA, har⟩ := Finset.mem_filter.mp ha
    have hlow : a % 2 ^ d = r := by
      calc
        _ = (a % 2 ^ (d + l)) % 2 ^ d := (Nat.mod_mod_of_dvd a (pow_dvd_pow 2 (by omega))).symm
        _ = (r + 2 ^ d * s) % 2 ^ d := by rw [har]
        _ = r := by rw [Nat.add_mul_mod_self_left, Nat.mod_eq_of_lt hr]
    have hjoin : r + 2 ^ d * (a / 2 ^ d) = a := by rw [← hlow, Nat.mod_add_div]
    have hhigh : a / 2 ^ d % 2 ^ l = s := by
      have hh := congrArg (fun n => n / 2 ^ d) har
      simpa only [pow_add, Nat.mod_mul_right_div_self, dyadic_join_div hr] using hh
    refine Finset.mem_image.mpr ⟨a / 2 ^ d, Finset.mem_filter.mpr ⟨?_, hhigh⟩, hjoin⟩
    exact (dyadic_zoom_mem hr).mpr (hjoin.symm ▸ haA)

theorem dyadic_zoom_fiber_card (A : Finset ℕ) {d r : ℕ} (hr : r < 2 ^ d) (l s : ℕ) :
    ((dyadicZoom A d r).filter (fun x => x % 2 ^ l = s)).card =
      (A.filter (fun y => y % 2 ^ (d + l) = r + 2 ^ d * s)).card := by
  rw [← dyadic_zoom_fiber_image A hr l s,
    Finset.card_image_of_injective _ (dyadic_join_injective d r)]

theorem dyadic_tree_block_zoom {A : Finset ℕ} {b T m k d r : ℕ}
    (hA : DyadicTreeBlock A b T m k) (hdb : d ≤ b) (hr : r < 2 ^ d) :
    DyadicTreeBlock (dyadicZoom A d r) (b - d) T (m - d) k := by
  have hdm : d ≤ m := hdb.trans hA.base_le
  have hproj : ∀ s ∈ dyadicProjection (dyadicZoom A d r) (m - d),
      r + 2 ^ d * s ∈ dyadicProjection A m := by
    intro s hs
    simpa only [Nat.add_sub_of_le hdm] using (dyadic_projection_zoom_mem_iff hr).mp hs
  refine ⟨by have := hA.base_le; omega, by have := hA.split_lt; omega, hA.count_le, ?_, ?_, ?_⟩
  · intro x hx y hy hxy
    have hxyA : (r + 2 ^ d * x) % 2 ^ b = (r + 2 ^ d * y) % 2 ^ b := by
      simpa only [Nat.add_sub_of_le hdb] using (dyadic_join_mod_eq_iff hr (b - d) x y).mpr hxy
    have hxyM := hA.common _ ((dyadic_zoom_mem hr).mp hx) _ ((dyadic_zoom_mem hr).mp hy) hxyA
    apply (dyadic_join_mod_eq_iff hr (m - d) x y).mp
    simpa only [Nat.add_sub_of_le hdm] using hxyM
  · intro s hs
    rw [dyadic_zoom_fiber_card A hr, Nat.add_sub_of_le hdm]
    exact hA.fiber_card _ (hproj s hs)
  · intro s hs hk
    obtain ⟨a, ha, c, hc, hac⟩ := hA.splits _ (hproj s hs) hk
    have himage : (((dyadicZoom A d r).filter (fun x => x % 2 ^ (m - d) = s)).image
        (fun x => r + 2 ^ d * x)) = A.filter (fun y => y % 2 ^ m = r + 2 ^ d * s) := by
      simpa only [Nat.add_sub_of_le hdm] using dyadic_zoom_fiber_image A hr (m - d) s
    rw [← himage] at ha hc
    obtain ⟨x, hx, hxa⟩ := Finset.mem_image.mp ha
    obtain ⟨y, hy, hyc⟩ := Finset.mem_image.mp hc
    refine ⟨x, hx, y, hy, ?_⟩
    intro hxy
    have hjoined := (dyadic_join_mod_eq_iff hr (m - d + 1) x y).mpr hxy
    have hindex : d + (m - d + 1) = m + 1 := by omega
    rw [hindex, hxa, hyc] at hjoined
    exact hac hjoined

theorem dyadic_regular_tree_zoom {A : Finset ℕ} {T N i r : ℕ}
    (htree : DyadicRegularTree A T N) (hi : i ≤ N) (hr : r < 2 ^ (T * i)) :
    DyadicRegularTree (dyadicZoom A (T * i) r) T (N - i) := by
  intro j hj
  obtain ⟨m, k, hblock⟩ := htree (i + j) (by omega)
  have hdi : T * i ≤ T * (i + j) := Nat.mul_le_mul_left T (by omega)
  have hzoom := dyadic_tree_block_zoom hblock hdi hr
  have hbase : T * (i + j) - T * i = T * j := by rw [Nat.mul_add, Nat.add_sub_cancel_left]
  have hend : T * i + T * (j + 1) = T * (i + j + 1) := by ring
  refine ⟨m - T * i, k, ?_⟩
  rw [dyadic_projection_zoom, hend]
  simpa only [hbase] using hzoom

def branchPrefix (c : ℕ → ℕ) (n : ℕ) : ℕ := ∑ i ∈ Finset.range n, c i

theorem branch_prefix_zero (c : ℕ → ℕ) : branchPrefix c 0 = 0 := by simp [branchPrefix]

theorem branch_prefix_succ (c : ℕ → ℕ) (n : ℕ) :
    branchPrefix c (n + 1) = branchPrefix c n + c n := Finset.sum_range_succ c n

theorem branch_prefix_mono (c : ℕ → ℕ) : Monotone (branchPrefix c) := by
  intro a b hab
  exact Finset.sum_le_sum_of_subset_of_nonneg (Finset.range_subset_range.mpr hab)
    (fun _ _ _ => Nat.zero_le _)

theorem branch_prefix_add_interval (c : ℕ → ℕ) {a b : ℕ} (hab : a ≤ b) :
    branchPrefix c a + (∑ i ∈ Finset.Ico a b, c i) = branchPrefix c b :=
  Finset.sum_range_add_sum_Ico c hab

theorem branch_prefix_sub_eq_sum (c : ℕ → ℕ) {a b : ℕ} (hab : a ≤ b) :
    branchPrefix c b - branchPrefix c a = ∑ i ∈ Finset.Ico a b, c i := by
  have hh := branch_prefix_add_interval c hab
  omega

theorem branch_prefix_sub_le (c : ℕ → ℕ) {a b T : ℕ} (hab : a ≤ b)
    (hcap : ∀ i : ℕ, a ≤ i → i < b → c i ≤ T) :
    branchPrefix c b - branchPrefix c a ≤ T * (b - a) := by
  rw [branch_prefix_sub_eq_sum c hab]
  calc
    _ ≤ ∑ _i ∈ Finset.Ico a b, T := by
      apply Finset.sum_le_sum
      intro i hi
      exact hcap i (Finset.mem_Ico.mp hi).1 (Finset.mem_Ico.mp hi).2
    _ = _ := by simp [Nat.mul_comm]

theorem branch_prefix_eq_of_zero (c : ℕ → ℕ) {a b : ℕ} (hab : a ≤ b)
    (hzero : ∀ i : ℕ, a ≤ i → i < b → c i = 0) : branchPrefix c b = branchPrefix c a := by
  have hh := branch_prefix_add_interval c hab
  have hsum : (∑ i ∈ Finset.Ico a b, c i) = 0 := by
    apply Finset.sum_eq_zero
    intro i hi
    exact hzero i (Finset.mem_Ico.mp hi).1 (Finset.mem_Ico.mp hi).2
  rw [hsum, add_zero] at hh
  exact hh.symm

theorem dyadic_regular_tree_profile {A : Finset ℕ} {T N : ℕ}
    (hA : A.Nonempty) (htree : DyadicRegularTree A T N) :
    ∃ m c : ℕ → ℕ,
      (∀ i : ℕ, i < N → DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i)) ∧
      ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j := by
  classical
  unfold DyadicRegularTree at htree
  choose! m c hmc using htree
  refine ⟨m, c, hmc, ?_⟩
  intro j
  induction j with
  | zero =>
    intro hj
    simp only [Nat.mul_zero, dyadic_projection_zero hA, Finset.card_singleton, branch_prefix_zero, pow_zero]
  | succ j ih =>
    intro hj
    have hblock := hmc j (by omega)
    rw [branch_prefix_succ, pow_add, ← ih (by omega)]
    have hc := dyadic_tree_block_card hblock
    simpa only [dyadic_projection_trans A (Nat.mul_le_mul_left T (show j ≤ j + 1 by omega))] using hc

structure BranchingInterval (c : ℕ → ℕ) (T N R : ℕ) (α : ℝ) (a b : ℕ) : Prop where
  width : a + R ≤ b
  end_le : b ≤ N
  branching : 0 < c a
  sparse : ((branchPrefix c b - branchPrefix c a : ℕ) : ℝ) < α * (T : ℝ) * ((b - a : ℕ) : ℝ)
  dense : ∀ j : ℕ, a + R ≤ j → j < b →
    α * (T : ℝ) * ((j - a : ℕ) : ℝ) ≤ ((branchPrefix c j - branchPrefix c a : ℕ) : ℝ)

def BranchingIntervalChain (c : ℕ → ℕ) (T N R : ℕ) (α : ℝ) :
    ℕ → List (ℕ × ℕ) → ℕ → Prop
  | z, [], w => w = z
  | z, (a, b) :: L, w => z ≤ a ∧ branchPrefix c a = branchPrefix c z ∧
      BranchingInterval c T N R α a b ∧ BranchingIntervalChain c T N R α b L w

def BranchingIntervalTerminal (c : ℕ → ℕ) (T N R : ℕ) (α : ℝ) (z : ℕ) : Prop :=
  branchPrefix c N - branchPrefix c z ≤ T * R ∨
    ∃ a : ℕ, z ≤ a ∧ a + R ≤ N ∧ branchPrefix c a = branchPrefix c z ∧
      α * (T : ℝ) * ((N - a : ℕ) : ℝ) ≤ ((branchPrefix c N - branchPrefix c a : ℕ) : ℝ)

theorem exists_branching_interval_chain (c : ℕ → ℕ) (T N R : ℕ) (α : ℝ)
    (hR : 0 < R) (hcap : ∀ i : ℕ, i < N → c i ≤ T) :
    ∀ z : ℕ, z ≤ N → ∃ L : List (ℕ × ℕ), ∃ w : ℕ,
      z ≤ w ∧ w ≤ N ∧ BranchingIntervalChain c T N R α z L w ∧
        BranchingIntervalTerminal c T N R α w := by
  have aux : ∀ d : ℕ, ∀ z : ℕ, N - z = d → z ≤ N →
      ∃ L : List (ℕ × ℕ), ∃ w : ℕ,
        z ≤ w ∧ w ≤ N ∧ BranchingIntervalChain c T N R α z L w ∧
          BranchingIntervalTerminal c T N R α w := by
    intro d
    induction d using Nat.strong_induction_on with
    | h d ih =>
      intro z hdz hzN
      by_cases hex : ∃ a : ℕ, z ≤ a ∧ a < N ∧ 0 < c a
      · let a := Nat.find hex
        obtain ⟨hza, haN, hac⟩ := Nat.find_spec hex
        have hgap : branchPrefix c a = branchPrefix c z := by
          apply branch_prefix_eq_of_zero c hza
          intro i hzi hia
          by_contra hi
          exact (Nat.find_min hex hia) ⟨hzi, by omega, Nat.pos_of_ne_zero hi⟩
        by_cases haR : a + R ≤ N
        · let Q : ℕ → Prop := fun b => a + R ≤ b ∧ b ≤ N ∧
            ((branchPrefix c b - branchPrefix c a : ℕ) : ℝ) < α * (T : ℝ) * ((b - a : ℕ) : ℝ)
          by_cases hdrop : ∃ b, Q b
          · let b := Nat.find hdrop
            obtain ⟨hab, hbN, hstop⟩ := Nat.find_spec hdrop
            have hzb : z < b := by omega
            have hinterval : BranchingInterval c T N R α a b := by
              refine ⟨hab, hbN, hac, hstop, ?_⟩
              intro j hjR hjb
              by_contra hj
              exact (Nat.find_min hdrop hjb) ⟨hjR, by omega, lt_of_not_ge hj⟩
            obtain ⟨L, w, hbw, hwN, hchain, hterminal⟩ := ih (N - b) (by omega) b rfl hbN
            refine ⟨(a, b) :: L, w, hzb.le.trans hbw, hwN, ?_, hterminal⟩
            exact ⟨hza, hgap, hinterval, hchain⟩
          · refine ⟨[], z, le_rfl, hzN, rfl, Or.inr ⟨a, hza, haR, hgap, ?_⟩⟩
            apply le_of_not_gt
            intro hfail
            exact hdrop ⟨N, haR, le_rfl, hfail⟩
        · refine ⟨[], z, le_rfl, hzN, rfl, Or.inl ?_⟩
          rw [← hgap]
          exact (branch_prefix_sub_le c (le_of_lt haN) (fun i _ hiN => hcap i hiN)).trans
            (Nat.mul_le_mul_left T (by omega))
      · have hgap : branchPrefix c N = branchPrefix c z := by
          apply branch_prefix_eq_of_zero c hzN
          intro i hzi hiN
          by_contra hi
          exact hex ⟨i, hzi, hiN, Nat.pos_of_ne_zero hi⟩
        exact ⟨[], z, le_rfl, hzN, rfl, Or.inl (by rw [hgap, Nat.sub_self]; omega)⟩
  intro z hzN
  exact aux (N - z) z rfl hzN

theorem branching_interval_chain_le {c : ℕ → ℕ} {T N R : ℕ} {α : ℝ}
    {z w : ℕ} {L : List (ℕ × ℕ)} (hchain : BranchingIntervalChain c T N R α z L w) :
    z ≤ w := by
  induction L generalizing z with
  | nil =>
    change w = z at hchain
    omega
  | cons p L ih =>
    rcases p with ⟨a, b⟩
    obtain ⟨hza, _, hblock, htail⟩ := hchain
    have hab := hblock.width
    have hbw := ih htail
    omega

theorem branching_interval_chain_length {c : ℕ → ℕ} {T N R : ℕ} {α : ℝ}
    {z w : ℕ} {L : List (ℕ × ℕ)} (hchain : BranchingIntervalChain c T N R α z L w) :
    L.length * R ≤ w - z := by
  induction L generalizing z with
  | nil => simp
  | cons p L ih =>
    rcases p with ⟨a, b⟩
    obtain ⟨hza, _, hblock, htail⟩ := hchain
    have hab := hblock.width
    have hbw := branching_interval_chain_le htail
    have hlen := ih htail
    simp only [List.length_cons, Nat.add_mul, Nat.one_mul]
    omega

theorem branching_interval_chain_entropy {c : ℕ → ℕ} {T N R : ℕ} {α : ℝ}
    {z w : ℕ} {L : List (ℕ × ℕ)} (hchain : BranchingIntervalChain c T N R α z L w) :
    (L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum =
      branchPrefix c w - branchPrefix c z := by
  induction L generalizing z with
  | nil =>
    change w = z at hchain
    simp [hchain]
  | cons p L ih =>
    rcases p with ⟨a, b⟩
    obtain ⟨hza, hgap, hblock, htail⟩ := hchain
    have hab : a ≤ b := by have := hblock.width; omega
    have hbw := branching_interval_chain_le htail
    have hEab := branch_prefix_mono c hab
    have hEbw := branch_prefix_mono c hbw
    simp only [List.map_cons, List.sum_cons]
    rw [ih htail, hgap] at *
    omega

theorem branching_interval_chain_mem {c : ℕ → ℕ} {T N R : ℕ} {α : ℝ}
    {z w : ℕ} {L : List (ℕ × ℕ)} (hchain : BranchingIntervalChain c T N R α z L w) :
    ∀ p ∈ L, z ≤ p.1 ∧ p.2 ≤ w ∧ BranchingInterval c T N R α p.1 p.2 := by
  induction L generalizing z with
  | nil => simp
  | cons p L ih =>
    rcases p with ⟨a, b⟩
    obtain ⟨hza, _, hblock, htail⟩ := hchain
    intro q hq
    rcases List.mem_cons.mp hq with rfl | hq
    · exact ⟨hza, branching_interval_chain_le htail, hblock⟩
    · obtain ⟨hbq, hqw, hqblock⟩ := ih htail q hq
      have hab := hblock.width
      exact ⟨by omega, hqw, hqblock⟩

theorem branching_terminal_entropy {c : ℕ → ℕ} {T N R w : ℕ} {α γ δ : ℝ}
    (hT : 0 < T) (hwN : w ≤ N) (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hα : 1 - δ / 2 ≤ α)
    (hprefix : ∀ j : ℕ, j ≤ N → γ * (T : ℝ) * (j : ℝ) ≤ (branchPrefix c j : ℝ))
    (hsize : (branchPrefix c N : ℝ) ≤ (1 - δ) * (T : ℝ) * (N : ℝ))
    (hR : 2 * (R : ℝ) ≤ γ * (N : ℝ))
    (hterminal : BranchingIntervalTerminal c T N R α w) :
    γ * δ / 2 * (T : ℝ) * (N : ℝ) ≤ (branchPrefix c w : ℝ) := by
  have hTr : (0 : ℝ) < T := by exact_mod_cast hT
  have hNr : (0 : ℝ) ≤ N := Nat.cast_nonneg N
  have hlower := hprefix N le_rfl
  rcases hterminal with hshort | ⟨a, hwa, haR, hgap, hlong⟩
  · have hEwN := branch_prefix_mono c hwN
    have hshortR : (branchPrefix c N : ℝ) - (branchPrefix c w : ℝ) ≤ (T : ℝ) * (R : ℝ) := by
      exact_mod_cast hshort
    have hRmul := mul_le_mul_of_nonneg_left hR hTr.le
    have hδmul : γ * δ / 2 * (T : ℝ) * (N : ℝ) ≤ γ / 2 * (T : ℝ) * (N : ℝ) := by
      nlinarith [mul_nonneg hγ.le hTr.le,
        mul_nonneg (mul_nonneg hγ.le hTr.le) hNr,
        mul_nonneg (sub_nonneg.mpr hδ1) (mul_nonneg (mul_nonneg hγ.le hTr.le) hNr)]
    nlinarith
  · have haN : a ≤ N := by omega
    have hEaN := branch_prefix_mono c haN
    have hNa : (0 : ℝ) ≤ (N : ℝ) - (a : ℝ) := sub_nonneg.mpr (by exact_mod_cast haN)
    have hlongR : α * (T : ℝ) * ((N : ℝ) - (a : ℝ)) ≤
        (branchPrefix c N : ℝ) - (branchPrefix c a : ℝ) := by
      simpa only [Nat.cast_sub haN, Nat.cast_sub hEaN] using hlong
    have hαmul := mul_le_mul_of_nonneg_right
      (mul_le_mul_of_nonneg_right hα hTr.le) hNa
    have hEanonneg : (0 : ℝ) ≤ branchPrefix c a := Nat.cast_nonneg _
    have hhalf : δ / 2 * (T : ℝ) * (N : ℝ) ≤ (T : ℝ) * (a : ℝ) := by
      have hδa := mul_nonneg (mul_nonneg hδ.le hTr.le) (Nat.cast_nonneg a)
      nlinarith
    have hscaled := mul_le_mul_of_nonneg_left hhalf hγ.le
    have hlowerA := hprefix a haN
    have hgapR : (branchPrefix c a : ℝ) = (branchPrefix c w : ℝ) := by exact_mod_cast hgap
    nlinarith

theorem exists_branching_intervals (c : ℕ → ℕ) (T N R : ℕ) (α γ δ : ℝ)
    (hT : 0 < T) (hR : 0 < R) (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hα : 1 - δ / 2 ≤ α) (hcap : ∀ i : ℕ, i < N → c i ≤ T)
    (hprefix : ∀ j : ℕ, j ≤ N → γ * (T : ℝ) * (j : ℝ) ≤ (branchPrefix c j : ℝ))
    (hsize : (branchPrefix c N : ℝ) ≤ (1 - δ) * (T : ℝ) * (N : ℝ))
    (hRN : 2 * (R : ℝ) ≤ γ * (N : ℝ)) :
    ∃ L : List (ℕ × ℕ), ∃ w : ℕ,
      w ≤ N ∧ BranchingIntervalChain c T N R α 0 L w ∧ L.length * R ≤ N ∧
      γ * δ / 2 * (T : ℝ) * (N : ℝ) ≤
        ((L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum : ℝ) := by
  obtain ⟨L, w, _, hwN, hchain, hterminal⟩ :=
    exists_branching_interval_chain c T N R α hR hcap 0 (Nat.zero_le N)
  refine ⟨L, w, hwN, hchain, ?_, ?_⟩
  · have hlen : L.length * R ≤ w := by
      simpa only [Nat.sub_zero] using branching_interval_chain_length hchain
    exact hlen.trans hwN
  · rw [branching_interval_chain_entropy hchain, branch_prefix_zero, Nat.sub_zero]
    exact branching_terminal_entropy hT hwN hγ hδ hδ1 hα hprefix hsize hRN hterminal

theorem dyadic_projection_card_mono (A : Finset ℕ) {j k : ℕ} (hjk : j ≤ k) :
    (dyadicProjection A j).card ≤ (dyadicProjection A k).card := by
  rw [← dyadic_projection_trans A hjk]
  exact Finset.card_image_le

theorem dyadic_projection_common_lift {A : Finset ℕ} {b m e : ℕ}
    (hbm : b ≤ m) (hme : m ≤ e)
    (hcommon : ∀ x ∈ dyadicProjection A e, ∀ y ∈ dyadicProjection A e,
      x % 2 ^ b = y % 2 ^ b → x % 2 ^ m = y % 2 ^ m) :
    ∀ x ∈ A, ∀ y ∈ A, x % 2 ^ b = y % 2 ^ b → x % 2 ^ m = y % 2 ^ m := by
  intro x hx y hy hxy
  have heq := hcommon (x % 2 ^ e) (Finset.mem_image_of_mem _ hx)
    (y % 2 ^ e) (Finset.mem_image_of_mem _ hy)
  simp only [Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 (hbm.trans hme)),
    Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 hme)] at heq
  exact heq hxy

theorem dyadic_projection_common {A : Finset ℕ} {b m e : ℕ}
    (hbm : b ≤ m) (hme : m ≤ e)
    (hcommon : ∀ x ∈ A, ∀ y ∈ A,
      x % 2 ^ b = y % 2 ^ b → x % 2 ^ m = y % 2 ^ m) :
    ∀ x ∈ dyadicProjection A e, ∀ y ∈ dyadicProjection A e,
      x % 2 ^ b = y % 2 ^ b → x % 2 ^ m = y % 2 ^ m := by
  intro x hx y hy hxy
  obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
  obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp hy
  simp only [Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 (hbm.trans hme))] at hxy
  simpa only [Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 hme)] using hcommon a ha d hd hxy

theorem dyadic_fiber_eq_of_common {A : Finset ℕ} {b m r : ℕ} (hbm : b ≤ m)
    (hcommon : ∀ x ∈ A, ∀ y ∈ A,
      x % 2 ^ b = y % 2 ^ b → x % 2 ^ m = y % 2 ^ m)
    (hr : r ∈ dyadicProjection A m) :
    A.filter (fun x => x % 2 ^ m = r) = A.filter (fun x => x % 2 ^ b = r % 2 ^ b) := by
  obtain ⟨a, ha, har⟩ := Finset.mem_image.mp hr
  ext x
  constructor
  · intro hx
    obtain ⟨hxA, hxr⟩ := Finset.mem_filter.mp hx
    refine Finset.mem_filter.mpr ⟨hxA, ?_⟩
    calc
      _ = (x % 2 ^ m) % 2 ^ b := (Nat.mod_mod_of_dvd x (pow_dvd_pow 2 hbm)).symm
      _ = _ := by rw [hxr]
  · intro hx
    obtain ⟨hxA, hxr⟩ := Finset.mem_filter.mp hx
    have hxa : x % 2 ^ b = a % 2 ^ b := by
      rw [hxr, ← har, Nat.mod_mod_of_dvd a (pow_dvd_pow 2 hbm)]
    exact Finset.mem_filter.mpr ⟨hxA, (hcommon x hxA a ha hxa).trans har⟩

theorem dyadic_regular_profile_fiber_card {A : Finset ℕ} {T N : ℕ} {c : ℕ → ℕ}
    (htree : DyadicRegularTree A T N)
    (hprofile : ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j)
    {a b r : ℕ} (hab : a ≤ b) (hbN : b ≤ N) (hr : r ∈ dyadicProjection A (T * a)) :
    ((dyadicProjection A (T * b)).filter (fun x => x % 2 ^ (T * a) = r)).card =
      2 ^ (branchPrefix c b - branchPrefix c a) := by
  have hmul := dyadic_regular_tree_zoom_projection_card (i := a) (j := b - a) htree
    (by omega) hr
  rw [dyadic_projection_zoom, ← Nat.mul_add, Nat.add_sub_of_le hab,
    dyadic_zoom_card, hprofile a (hab.trans hbN), hprofile b hbN] at hmul
  have hEab := branch_prefix_mono c hab
  have hpow : 2 ^ branchPrefix c b = 2 ^ branchPrefix c a * 2 ^ (branchPrefix c b - branchPrefix c a) := by
    rw [← pow_add, Nat.add_sub_of_le hEab]
  rw [hpow] at hmul
  exact Nat.eq_of_mul_eq_mul_left (by positivity) hmul

theorem dyadic_regular_profile_fiber_card_le {A : Finset ℕ} {T N : ℕ} {c : ℕ → ℕ}
    (htree : DyadicRegularTree A T N)
    (hprofile : ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j)
    {a b : ℕ} (hab : a ≤ b) (hbN : b ≤ N) (r : ℕ) :
    ((dyadicProjection A (T * b)).filter (fun x => x % 2 ^ (T * a) = r)).card ≤
      2 ^ (branchPrefix c b - branchPrefix c a) := by
  by_cases hr : r ∈ dyadicProjection A (T * a)
  · exact (dyadic_regular_profile_fiber_card htree hprofile hab hbN hr).le
  · have hempty : (dyadicProjection A (T * b)).filter (fun x => x % 2 ^ (T * a) = r) = ∅ := by
      apply Finset.eq_empty_iff_forall_notMem.mpr
      intro x hx
      obtain ⟨hxP, hxr⟩ := Finset.mem_filter.mp hx
      apply hr
      rw [← dyadic_projection_trans A (Nat.mul_le_mul_left T hab), ← hxr]
      exact Finset.mem_image_of_mem _ hxP
    rw [hempty, Finset.card_empty]
    exact Nat.zero_le _

theorem dyadic_regular_profile_split_fiber_card {A : Finset ℕ} {T N : ℕ} {m c : ℕ → ℕ}
    (hblocks : ∀ i : ℕ, i < N →
      DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i))
    (hprofile : ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j)
    {a b r : ℕ} (hab : a < b) (hbN : b ≤ N) (hr : r ∈ dyadicProjection A (m a)) :
    ((dyadicProjection A (T * b)).filter (fun x => x % 2 ^ (m a) = r)).card =
      2 ^ (branchPrefix c b - branchPrefix c a) := by
  have hblock := hblocks a (hab.trans_le hbN)
  have hma : m a ≤ T * (a + 1) := by have := hblock.split_lt; nlinarith
  have hmb : m a ≤ T * b := hma.trans (Nat.mul_le_mul_left T (by omega))
  have hcommon := dyadic_projection_common_lift hblock.base_le hma hblock.common
  have hprojected := dyadic_projection_common hblock.base_le hmb hcommon
  have hr' : r ∈ dyadicProjection (dyadicProjection A (T * b)) (m a) := by
    rwa [dyadic_projection_trans A hmb]
  rw [dyadic_fiber_eq_of_common hblock.base_le hprojected hr']
  apply dyadic_regular_profile_fiber_card (fun i hi => ⟨m i, c i, hblocks i hi⟩) hprofile hab.le hbN
  rw [← dyadic_projection_trans A hblock.base_le]
  exact Finset.mem_image_of_mem _ hr

theorem dyadic_fiber_card_antitone (A : Finset ℕ) {j k : ℕ} (hjk : j ≤ k) (r : ℕ) :
    (A.filter (fun x => x % 2 ^ k = r)).card ≤
      (A.filter (fun x => x % 2 ^ j = r % 2 ^ j)).card := by
  apply Finset.card_le_card
  intro x hx
  obtain ⟨hxA, hxr⟩ := Finset.mem_filter.mp hx
  refine Finset.mem_filter.mpr ⟨hxA, ?_⟩
  calc
    _ = (x % 2 ^ k) % 2 ^ j := (Nat.mod_mod_of_dvd x (pow_dvd_pow 2 hjk)).symm
    _ = _ := by rw [hxr]

theorem dyadic_regular_profile_intermediate_fiber_card_le {A : Finset ℕ} {T N : ℕ}
    {c : ℕ → ℕ} (htree : DyadicRegularTree A T N)
    (hprofile : ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j)
    {j b k : ℕ} (hjb : j ≤ b) (hbN : b ≤ N) (hjk : T * j ≤ k) (r : ℕ) :
    ((dyadicProjection A (T * b)).filter (fun x => x % 2 ^ k = r)).card ≤
      2 ^ (branchPrefix c b - branchPrefix c j) := by
  exact (dyadic_fiber_card_antitone _ hjk r).trans
    (dyadic_regular_profile_fiber_card_le htree hprofile hjb hbN _)

theorem dyadic_regular_profile_split_fiber_mass_le {A : Finset ℕ} {T N : ℕ} {m c : ℕ → ℕ}
    (hblocks : ∀ i : ℕ, i < N →
      DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i))
    (hprofile : ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j)
    {a b j k r : ℕ} (hab : a < b) (hbN : b ≤ N) (haj : a ≤ j) (hjb : j ≤ b)
    (hjk : T * j ≤ k) (hr : r ∈ dyadicProjection A (m a)) (s : ℕ) :
    natResidueMass ((dyadicProjection A (T * b)).filter (fun x => x % 2 ^ (m a) = r))
      (2 ^ k) s ≤ (2 : ℝ) ^ (-((branchPrefix c j - branchPrefix c a : ℕ) : ℝ)) := by
  let S := (dyadicProjection A (T * b)).filter (fun x => x % 2 ^ (m a) = r)
  have hS : S.card = 2 ^ (branchPrefix c b - branchPrefix c a) :=
    dyadic_regular_profile_split_fiber_card hblocks hprofile hab hbN hr
  have hsub : natResidueFiber S (2 ^ k) s ⊆
      (dyadicProjection A (T * b)).filter (fun x => x % 2 ^ k = s % 2 ^ k) := by
    intro x hx
    obtain ⟨hxS, hxs⟩ := Finset.mem_filter.mp hx
    exact Finset.mem_filter.mpr ⟨(Finset.mem_filter.mp hxS).1, hxs⟩
  have hfiber := (Finset.card_le_card hsub).trans
    (dyadic_regular_profile_intermediate_fiber_card_le
      (fun i hi => ⟨m i, c i, hblocks i hi⟩) hprofile hjb hbN hjk (s % 2 ^ k))
  have hEaj := branch_prefix_mono c haj
  have hEjb := branch_prefix_mono c hjb
  have hEab := branch_prefix_mono c hab.le
  have hpow : (2 : ℝ) ^ (-((branchPrefix c j - branchPrefix c a : ℕ) : ℝ)) *
      (2 : ℝ) ^ (branchPrefix c b - branchPrefix c a) =
      (2 : ℝ) ^ (branchPrefix c b - branchPrefix c j) := by
    simp only [← Real.rpow_natCast, ← Real.rpow_add (show (0 : ℝ) < 2 by norm_num)]
    congr 1
    simp only [Nat.cast_sub hEaj, Nat.cast_sub hEjb, Nat.cast_sub hEab]
    ring
  change ((natResidueFiber S (2 ^ k) s).card : ℝ) / (S.card : ℝ) ≤ _
  rw [hS, Nat.cast_pow, Nat.cast_ofNat]
  apply (div_le_iff₀ (pow_pos (by norm_num : (0 : ℝ) < 2) _)).mpr
  rw [hpow]
  exact_mod_cast hfiber

theorem dyadic_regular_profile_split_witnesses {A : Finset ℕ} {T N : ℕ} {m c : ℕ → ℕ}
    (hblocks : ∀ i : ℕ, i < N →
      DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i))
    {a b r : ℕ} (hab : a < b) (hbN : b ≤ N) (hca : 0 < c a)
    (hr : r ∈ dyadicProjection A (m a)) :
    ∃ x ∈ (dyadicProjection A (T * b)).filter (fun x => x % 2 ^ (m a) = r),
      ∃ y ∈ (dyadicProjection A (T * b)).filter (fun x => x % 2 ^ (m a) = r),
        x % 2 ^ (m a + 1) ≠ y % 2 ^ (m a + 1) := by
  have hblock := hblocks a (hab.trans_le hbN)
  have hme : m a + 1 ≤ T * (a + 1) := by have := hblock.split_lt; nlinarith
  have heb : T * (a + 1) ≤ T * b := Nat.mul_le_mul_left T (by omega)
  have hmb : m a + 1 ≤ T * b := hme.trans heb
  have hr' : r ∈ dyadicProjection (dyadicProjection A (T * (a + 1))) (m a) := by
    rwa [dyadic_projection_trans A (show m a ≤ T * (a + 1) by omega)]
  obtain ⟨x, hx, y, hy, hxy⟩ := hblock.splits r hr' hca
  obtain ⟨hxP, hxr⟩ := Finset.mem_filter.mp hx
  obtain ⟨hyP, hyr⟩ := Finset.mem_filter.mp hy
  obtain ⟨u, hu, hux⟩ := Finset.mem_image.mp hxP
  obtain ⟨v, hv, hvy⟩ := Finset.mem_image.mp hyP
  have hur : u % 2 ^ (m a) = r := by
    rw [← hux, Nat.mod_mod_of_dvd u (pow_dvd_pow 2 (show m a ≤ T * (a + 1) by omega))] at hxr
    exact hxr
  have hvr : v % 2 ^ (m a) = r := by
    rw [← hvy, Nat.mod_mod_of_dvd v (pow_dvd_pow 2 (show m a ≤ T * (a + 1) by omega))] at hyr
    exact hyr
  refine ⟨u % 2 ^ (T * b), Finset.mem_filter.mpr ⟨Finset.mem_image_of_mem _ hu, ?_⟩,
    v % 2 ^ (T * b), Finset.mem_filter.mpr ⟨Finset.mem_image_of_mem _ hv, ?_⟩, ?_⟩
  · rwa [Nat.mod_mod_of_dvd u (pow_dvd_pow 2 (show m a ≤ T * b by omega))]
  · rwa [Nat.mod_mod_of_dvd v (pow_dvd_pow 2 (show m a ≤ T * b by omega))]
  · intro heq
    apply hxy
    rw [← hux, ← hvy]
    simpa only [Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 hme),
      Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 hmb)] using heq

theorem branching_interval_sparse_physical {c : ℕ → ℕ} {T N R a b m : ℕ} {ρ : ℝ}
    (hR : 0 < R) (hρ : 0 < ρ) (hρ1 : ρ ≤ 1)
    (hρR : 1 ≤ ρ * (R : ℝ)) (hm : m < T * (a + 1))
    (hinterval : BranchingInterval c T N R (1 - 2 * ρ) a b) :
    ((branchPrefix c b - branchPrefix c a : ℕ) : ℝ) < (1 - ρ) * ((T * b - m : ℕ) : ℝ) := by
  have hab : a < b := by have := hinterval.width; omega
  have hmb : m ≤ T * b := hm.le.trans (Nat.mul_le_mul_left T (by omega))
  have hwidth : (R : ℝ) ≤ (b : ℝ) - (a : ℝ) := by
    have hh : (a : ℝ) + (R : ℝ) ≤ (b : ℝ) := by exact_mod_cast hinterval.width
    linarith
  have hmR : (m : ℝ) ≤ (T : ℝ) * ((a : ℝ) + 1) := by exact_mod_cast hm.le
  have hTr : (0 : ℝ) ≤ T := Nat.cast_nonneg T
  have hρwidth := mul_le_mul_of_nonneg_left hwidth hρ.le
  have hwidthT := mul_le_mul_of_nonneg_right (hρR.trans hρwidth) hTr
  have hshift := mul_le_mul_of_nonneg_left hmR (sub_nonneg.mpr hρ1)
  have hsparse := hinterval.sparse
  rw [Nat.cast_sub hab.le] at hsparse
  rw [Nat.cast_sub hmb, Nat.cast_mul]
  nlinarith [mul_nonneg hρ.le hTr]

theorem branching_interval_dense_physical {c : ℕ → ℕ} {T N R a b m k : ℕ} {ρ : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hρ : 0 < ρ) (hρhalf : ρ ≤ 1 / 2)
    (hρR : 1 ≤ ρ * (R : ℝ)) (hma : T * a ≤ m)
    (hkmin : m + 2 * (T * R) ≤ k) (hkmax : k ≤ T * b)
    (hinterval : BranchingInterval c T N R (1 - 2 * ρ) a b) :
    ∃ j : ℕ, a + R ≤ j ∧ j < b ∧ T * j ≤ k ∧
      (1 - 3 * ρ) * ((k - m : ℕ) : ℝ) ≤
        ((branchPrefix c j - branchPrefix c a : ℕ) : ℝ) := by
  let j := (k - 1) / T
  have hTR : 0 < T * R := Nat.mul_pos hT hR
  have hkpos : 0 < k := by omega
  have hnear : k ≤ T * j + T := by
    have hh := Nat.mod_lt (k - 1) hT
    have hd := Nat.mod_add_div (k - 1) T
    change (k - 1) % T + T * j = k - 1 at hd
    omega
  have hjk : T * j ≤ k := by
    have hh := Nat.mul_div_le (k - 1) T
    change T * j ≤ k - 1 at hh
    omega
  have haj : a + R ≤ j := by
    apply (Nat.le_div_iff_mul_le hT).mpr
    have hh : T * (a + R) < k := by
      rw [Nat.mul_add]
      omega
    rw [Nat.mul_comm]
    omega
  have hjb : j < b := by
    apply (Nat.div_lt_iff_lt_mul hT).mpr
    rw [Nat.mul_comm]
    omega
  have hmkle : m ≤ k := by omega
  have hajle : a ≤ j := by omega
  have hTr : (0 : ℝ) ≤ T := Nat.cast_nonneg T
  have hkmR : (T : ℝ) * (R : ℝ) ≤ (k : ℝ) - (m : ℝ) := by
    have hh : (m : ℝ) + (T : ℝ) * (R : ℝ) ≤ (k : ℝ) := by
      exact_mod_cast (show m + T * R ≤ k by omega)
    linarith
  have hρkm := mul_le_mul_of_nonneg_left hkmR hρ.le
  have hρRT := mul_le_mul_of_nonneg_right hρR hTr
  have hnearR : (k : ℝ) ≤ (T : ℝ) * (j : ℝ) + (T : ℝ) := by exact_mod_cast hnear
  have hmaR : (T : ℝ) * (a : ℝ) ≤ (m : ℝ) := by exact_mod_cast hma
  have hstep : (k : ℝ) - (m : ℝ) - (T : ℝ) ≤ (T : ℝ) * ((j : ℝ) - (a : ℝ)) := by nlinarith
  have hstepmul := mul_le_mul_of_nonneg_left hstep (show 0 ≤ 1 - 2 * ρ by linarith)
  have hdense := hinterval.dense j haj hjb
  rw [Nat.cast_sub hajle] at hdense
  refine ⟨j, haj, hjb, hjk, ?_⟩
  rw [Nat.cast_sub hmkle]
  nlinarith [mul_nonneg hρ.le hTr]

structure DyadicAmplificationBlock (A : Finset ℕ) (u v M e : ℕ) (ρ : ℝ) : Prop where
  start_lt : u < v
  fiber_card : ∀ r ∈ dyadicProjection A u,
    ((dyadicProjection A v).filter (fun x => x % 2 ^ u = r)).card = 2 ^ e
  sparse : (e : ℝ) < (1 - ρ) * ((v - u : ℕ) : ℝ)
  splits : ∀ r ∈ dyadicProjection A u,
    ∃ x ∈ (dyadicProjection A v).filter (fun x => x % 2 ^ u = r),
      ∃ y ∈ (dyadicProjection A v).filter (fun x => x % 2 ^ u = r),
        x % 2 ^ (u + 1) ≠ y % 2 ^ (u + 1)
  mass_le : ∀ k : ℕ, u + M ≤ k → k ≤ v → ∀ r ∈ dyadicProjection A u, ∀ s : ℕ,
    natResidueMass ((dyadicProjection A v).filter (fun x => x % 2 ^ u = r)) (2 ^ k) s ≤
      (2 : ℝ) ^ (-(1 - 3 * ρ) * ((k - u : ℕ) : ℝ))

theorem dyadic_amplification_block_of_branching_interval {A : Finset ℕ} {T N R : ℕ}
    {m c : ℕ → ℕ} {a b : ℕ} {ρ : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hρ : 0 < ρ) (hρhalf : ρ ≤ 1 / 2)
    (hρR : 1 ≤ ρ * (R : ℝ))
    (hblocks : ∀ i : ℕ, i < N →
      DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i))
    (hprofile : ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j)
    (hinterval : BranchingInterval c T N R (1 - 2 * ρ) a b) :
    DyadicAmplificationBlock A (m a) (T * b) (2 * (T * R))
      (branchPrefix c b - branchPrefix c a) ρ := by
  have hab : a < b := by have := hinterval.width; omega
  have haN : a < N := hab.trans_le hinterval.end_le
  have hblock := hblocks a haN
  have hm : m a < T * (a + 1) := by simpa only [Nat.mul_add, Nat.mul_one] using hblock.split_lt
  refine ⟨hm.trans_le (Nat.mul_le_mul_left T (by omega)),
    fun r hr => dyadic_regular_profile_split_fiber_card hblocks hprofile hab hinterval.end_le hr,
    branching_interval_sparse_physical hR hρ (by linarith) hρR hm hinterval,
    fun r hr => dyadic_regular_profile_split_witnesses hblocks hab hinterval.end_le hinterval.branching hr,
    ?_⟩
  intro k hkmin hkmax r hr s
  obtain ⟨j, haj, hjb, hjk, hbits⟩ := branching_interval_dense_physical hT hR hρ hρhalf hρR
    hblock.base_le hkmin hkmax hinterval
  have hmass := dyadic_regular_profile_split_fiber_mass_le hblocks hprofile hab hinterval.end_le
    (show a ≤ j by omega) hjb.le hjk hr s
  refine hmass.trans ?_
  apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
  nlinarith

theorem exists_dyadic_amplification_intervals {A : Finset ℕ} {T N R : ℕ} {γ δ ρ : ℝ}
    (hA : A.Nonempty) (hT : 0 < T) (hR : 0 < R) (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hρ : 0 < ρ) (hρδ : ρ ≤ δ / 4) (hρR : 1 ≤ ρ * (R : ℝ))
    (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N))
    (hprefix : ∀ j : ℕ, j ≤ N →
      (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤ ((dyadicProjection A (T * j)).card : ℝ))
    (hsize : (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)))
    (hRN : 2 * (R : ℝ) ≤ γ * (N : ℝ)) :
    ∃ m c : ℕ → ℕ, ∃ L : List (ℕ × ℕ), ∃ w : ℕ,
      (∀ i : ℕ, i < N →
        DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i)) ∧
      (∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j) ∧
      w ≤ N ∧ BranchingIntervalChain c T N R (1 - 2 * ρ) 0 L w ∧ L.length * R ≤ N ∧
      γ * δ / 2 * (T : ℝ) * (N : ℝ) ≤
        ((L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum : ℝ) ∧
      ∀ p ∈ L, DyadicAmplificationBlock A (m p.1) (T * p.2) (2 * (T * R))
        (branchPrefix c p.2 - branchPrefix c p.1) ρ := by
  obtain ⟨m, c, hblocks, hprofile⟩ := dyadic_regular_tree_profile hA htree
  have hprefixE : ∀ j : ℕ, j ≤ N → γ * (T : ℝ) * (j : ℝ) ≤ (branchPrefix c j : ℝ) := by
    intro j hj
    have hh := hprefix j hj
    rw [hprofile j hj, Nat.cast_pow, Nat.cast_ofNat, ← Real.rpow_natCast] at hh
    exact (Real.rpow_le_rpow_left_iff (by norm_num : (1 : ℝ) < 2)).mp hh
  have hsizeE : (branchPrefix c N : ℝ) ≤ (1 - δ) * (T : ℝ) * (N : ℝ) := by
    have hcard : A.card = 2 ^ branchPrefix c N := by
      simpa only [dyadic_projection_self hbound] using hprofile N le_rfl
    rw [hcard, Nat.cast_pow, Nat.cast_ofNat, ← Real.rpow_natCast] at hsize
    exact (Real.rpow_le_rpow_left_iff (by norm_num : (1 : ℝ) < 2)).mp hsize
  obtain ⟨L, w, hwN, hchain, hlength, hbits⟩ :=
    exists_branching_intervals c T N R (1 - 2 * ρ) γ δ hT hR hγ hδ hδ1
      (by linarith) (fun i hi => (hblocks i hi).count_le) hprefixE hsizeE hRN
  refine ⟨m, c, L, w, hblocks, hprofile, hwN, hchain, hlength, hbits, ?_⟩
  intro p hp
  exact dyadic_amplification_block_of_branching_interval hT hR hρ (by linarith) hρR
    hblocks hprofile (branching_interval_chain_mem hchain p hp).2.2

theorem nat_residue_mass_mono_modulus (A : Finset ℕ) {q Q : ℕ} (hq : q ∣ Q) (r : ℕ) :
    natResidueMass A Q r ≤ natResidueMass A q r := by
  unfold natResidueMass
  exact div_le_div_of_nonneg_right
    (by exact_mod_cast Finset.card_le_card (nat_residue_fiber_mono_modulus (A := A) (r := r) hq))
    (Nat.cast_nonneg A.card)

theorem dyadic_regular_tree_residue_mass_le {A : Finset ℕ} {T N i : ℕ}
    (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N))
    (hi : i ≤ N) (r : ℕ) :
    natResidueMass A (2 ^ (T * i)) r ≤ 1 / ((dyadicProjection A (T * i)).card : ℝ) := by
  by_cases hr : r % 2 ^ (T * i) ∈ dyadicProjection A (T * i)
  · rw [← nat_residue_mass_mod A (2 ^ (T * i)) r]
    exact (dyadic_regular_tree_residue_mass htree hbound hi hr).le
  · have hempty : natResidueFiber A (2 ^ (T * i)) r = ∅ := by
      apply Finset.eq_empty_iff_forall_notMem.mpr
      intro x hx
      obtain ⟨hxA, hxr⟩ := Finset.mem_filter.mp hx
      apply hr
      exact Finset.mem_image.mpr ⟨x, hxA, hxr⟩
    simp only [natResidueMass, hempty, Finset.card_empty, Nat.cast_zero, zero_div]
    positivity

theorem dyadic_regular_tree_mass_le_at_all_levels {A : Finset ℕ} {T N : ℕ} {γ : ℝ}
    (hT : 0 < T) (hγ : 0 ≤ γ) (htree : DyadicRegularTree A T N)
    (hbound : ∀ x ∈ A, x < 2 ^ (T * N))
    (hprefix : ∀ j : ℕ, j ≤ N →
      (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤ ((dyadicProjection A (T * j)).card : ℝ))
    {k : ℕ} (hkmin : 2 * T ≤ k) (hkmax : k ≤ T * N) (r : ℕ) :
    natResidueMass A (2 ^ k) r ≤ (2 : ℝ) ^ (-(γ / 2) * (k : ℝ)) := by
  let j := k / T
  have hjk : T * j ≤ k := Nat.mul_div_le k T
  have hjN : j ≤ N := by nlinarith
  have hrem := Nat.mod_lt k hT
  have hdiv := Nat.mod_add_div k T
  change k % T + T * j = k at hdiv
  have hgrid : k ≤ 2 * (T * j) := by omega
  have hgridR : (k : ℝ) ≤ 2 * ((T : ℝ) * (j : ℝ)) := by exact_mod_cast hgrid
  have hprefixJ := hprefix j hjN
  calc
    _ ≤ natResidueMass A (2 ^ (T * j)) r :=
      nat_residue_mass_mono_modulus A (pow_dvd_pow 2 hjk) r
    _ ≤ 1 / ((dyadicProjection A (T * j)).card : ℝ) :=
      dyadic_regular_tree_residue_mass_le htree hbound hjN r
    _ ≤ 1 / ((2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ))) :=
      one_div_le_one_div_of_le (Real.rpow_pos_of_pos (by norm_num) _) hprefixJ
    _ = (2 : ℝ) ^ (-(γ * (T : ℝ) * (j : ℝ))) := by
      rw [Real.rpow_neg (by norm_num : (0 : ℝ) ≤ 2), one_div]
    _ ≤ _ := by
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      nlinarith [mul_le_mul_of_nonneg_left hgridR hγ]

theorem branching_interval_chain_width_sum {c : ℕ → ℕ} {T N R : ℕ} {α : ℝ}
    {z w : ℕ} {L : List (ℕ × ℕ)} (hchain : BranchingIntervalChain c T N R α z L w) :
    (L.map (fun p => p.2 - p.1)).sum ≤ w - z := by
  induction L generalizing z with
  | nil => simp
  | cons p L ih =>
    rcases p with ⟨a, b⟩
    obtain ⟨hza, _, hblock, htail⟩ := hchain
    have hab := hblock.width
    have hbw := branching_interval_chain_le htail
    have hsum := ih htail
    simp only [List.map_cons, List.sum_cons]
    omega

theorem branching_interval_chain_physical_width_sum {c m : ℕ → ℕ} {T N R : ℕ} {α : ℝ}
    {z w : ℕ} {L : List (ℕ × ℕ)} (hchain : BranchingIntervalChain c T N R α z L w)
    (hm : ∀ i : ℕ, i < N → T * i ≤ m i) (hR : 0 < R) :
    (L.map (fun p => T * p.2 - m p.1)).sum ≤ T * (w - z) := by
  have hsum : (L.map (fun p => T * p.2 - m p.1)).sum ≤
      T * (L.map (fun p => p.2 - p.1)).sum := by
    induction L generalizing z with
    | nil => simp
    | cons p L ih =>
      rcases p with ⟨a, b⟩
      obtain ⟨_, _, hblock, htail⟩ := hchain
      have hab : a < b := by have := hblock.width; omega
      have haN : a < N := hab.trans_le hblock.end_le
      have hma := hm a haN
      have hsub : T * b - m a ≤ T * (b - a) := by
        rw [Nat.mul_sub_left_distrib]
        omega
      have htailbound := ih htail
      simp only [List.map_cons, List.sum_cons, Nat.mul_add]
      omega
  exact hsum.trans (Nat.mul_le_mul_left T (branching_interval_chain_width_sum hchain))

theorem dyadic_amplification_blocks_entropy_budget {A : Finset ℕ} {T M : ℕ}
    {m c : ℕ → ℕ} {ρ : ℝ} {L : List (ℕ × ℕ)}
    (hblocks : ∀ p ∈ L, DyadicAmplificationBlock A (m p.1) (T * p.2) M
      (branchPrefix c p.2 - branchPrefix c p.1) ρ) :
    ((L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum : ℝ) ≤
      (1 - ρ) * ((L.map (fun p => T * p.2 - m p.1)).sum : ℝ) := by
  induction L with
  | nil => simp
  | cons p L ih =>
    have hhead := (hblocks p (by simp)).sparse.le
    have htail := ih (fun q hq => hblocks q (List.mem_cons_of_mem p hq))
    simp only [List.map_cons, List.sum_cons, Nat.cast_add]
    nlinarith

theorem dyadic_amplification_blocks_entropy_gain {A : Finset ℕ} {T M : ℕ}
    {m c : ℕ → ℕ} {ρ : ℝ} {L : List (ℕ × ℕ)} (hρ : 0 ≤ ρ)
    (hblocks : ∀ p ∈ L, DyadicAmplificationBlock A (m p.1) (T * p.2) M
      (branchPrefix c p.2 - branchPrefix c p.1) ρ) :
    ρ * ((L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum : ℝ) ≤
      ((L.map (fun p => T * p.2 - m p.1)).sum : ℝ) -
        ((L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum : ℝ) := by
  have hbudget := dyadic_amplification_blocks_entropy_budget hblocks
  have hwidth_nonneg : (0 : ℝ) ≤ (L.map (fun p => T * p.2 - m p.1)).sum := Nat.cast_nonneg _
  have hbits_width : ((L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum : ℝ) ≤
      ((L.map (fun p => T * p.2 - m p.1)).sum : ℝ) := by
    nlinarith [mul_nonneg hρ hwidth_nonneg]
  nlinarith [mul_le_mul_of_nonneg_left hbits_width hρ]

theorem dyadic_regular_profile_no_branching_gap {A : Finset ℕ} {T N : ℕ} {m c : ℕ → ℕ}
    (hblocks : ∀ i : ℕ, i < N →
      DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i))
    (hprofile : ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j)
    {z a : ℕ} (hza : z ≤ a) (haN : a < N) (hgap : branchPrefix c a = branchPrefix c z) :
    (dyadicProjection A (m a)).card = (dyadicProjection A (T * z)).card := by
  have hblock := hblocks a haN
  have hma : m a ≤ T * (a + 1) := by have := hblock.split_lt; nlinarith
  have hcommon := dyadic_projection_common_lift hblock.base_le hma hblock.common
  rw [dyadic_projection_card_of_common hblock.base_le hcommon,
    hprofile a haN.le, hprofile z (hza.trans haN.le), hgap]

noncomputable def finiteEntropy {ι : Type*} (S : Finset ι) (p : ι → ℝ) : ℝ :=
  ∑ x ∈ S, Real.negMulLog (p x)

theorem sum_mul_log_le_log_bound {ι : Type*} (S : Finset ι) (p : ι → ℝ) {M : ℝ}
    (hp : ∀ x ∈ S, 0 ≤ p x) (hbound : ∀ x ∈ S, p x ≤ M) :
    (∑ x ∈ S, p x * Real.log (p x)) ≤ (∑ x ∈ S, p x) * Real.log M := by
  rw [Finset.sum_mul]
  apply Finset.sum_le_sum
  intro x hx
  by_cases hpx : p x = 0
  · simp [hpx]
  · exact mul_le_mul_of_nonneg_left
      (Real.log_le_log (lt_of_le_of_ne (hp x hx) (Ne.symm hpx)) (hbound x hx)) (hp x hx)

theorem finite_entropy_fiber_defect {ι : Type*} (S : Finset ι) (p : ι → ℝ) {q M : ℝ}
    (hp : ∀ x ∈ S, 0 ≤ p x) (hq : 0 < q) (hM : 0 ≤ M) (hbound : ∀ x ∈ S, p x ≤ M) :
    Real.negMulLog (∑ x ∈ S, p x) + (∑ x ∈ S, p x) * Real.log q - finiteEntropy S p ≤
      q * M - ∑ x ∈ S, p x := by
  let s := ∑ x ∈ S, p x
  have hs : 0 ≤ s := Finset.sum_nonneg hp
  by_cases hMzero : M = 0
  · have hzero : ∀ x ∈ S, p x = 0 := fun x hx => le_antisymm (hMzero ▸ hbound x hx) (hp x hx)
    have hsumzero : ∑ x ∈ S, p x = 0 := Finset.sum_eq_zero hzero
    have hentropy : finiteEntropy S p = 0 := by
      apply Finset.sum_eq_zero
      intro x hx
      simp [hzero x hx, Real.negMulLog_def]
    simp [hsumzero, hentropy, hMzero, Real.negMulLog_def]
  have hMpos : 0 < M := lt_of_le_of_ne hM (Ne.symm hMzero)
  have hlog := sum_mul_log_le_log_bound S p hp hbound
  have hentropy : finiteEntropy S p = -(∑ x ∈ S, p x * Real.log (p x)) := by
    simp [finiteEntropy, Real.negMulLog_def, neg_mul, Finset.sum_neg_distrib]
  change Real.negMulLog s + s * Real.log q - finiteEntropy S p ≤ q * M - s
  rw [hentropy]
  change -s * Real.log s + s * Real.log q - -(∑ x ∈ S, p x * Real.log (p x)) ≤ q * M - s
  change (∑ x ∈ S, p x * Real.log (p x)) ≤ s * Real.log M at hlog
  by_cases hszero : s = 0
  · have hlogzero : (∑ x ∈ S, p x * Real.log (p x)) ≤ 0 := by
      simpa only [hszero, zero_mul] using hlog
    simpa only [hszero, neg_zero, zero_mul, zero_add, sub_neg_eq_add, sub_zero] using
      hlogzero.trans (mul_nonneg hq.le hM)
  have hspos : 0 < s := lt_of_le_of_ne hs (Ne.symm hszero)
  have hratio := Real.log_le_sub_one_of_pos (div_pos (mul_pos hq hMpos) hspos)
  rw [Real.log_div (mul_ne_zero hq.ne' hMpos.ne') hspos.ne', Real.log_mul hq.ne' hMpos.ne'] at hratio
  have hscaled := mul_le_mul_of_nonneg_left hratio hs
  have hcancel : s * (q * M / s) = q * M := by field_simp
  nlinarith

theorem finite_entropy_le_log_card {ι : Type*} (S : Finset ι) (p : ι → ℝ)
    (hp : ∀ x ∈ S, 0 ≤ p x) (hsum : ∑ x ∈ S, p x = 1) :
    finiteEntropy S p ≤ Real.log (S.card : ℝ) := by
  have hSne : S.Nonempty := by
    by_contra hS
    have he := Finset.not_nonempty_iff_eq_empty.mp hS
    norm_num [he] at hsum
  have hcard : (0 : ℝ) < S.card := by exact_mod_cast Finset.card_pos.mpr hSne
  have hpoint : ∀ x ∈ S,
      (S.card : ℝ) * Real.negMulLog (p x) ≤
        1 - (S.card : ℝ) * p x + p x * (S.card : ℝ) * Real.log (S.card : ℝ) := by
    intro x hx
    have hh := Real.negMulLog_le_one_sub_self (mul_nonneg hcard.le (hp x hx))
    rw [Real.negMulLog_mul] at hh
    change p x * (-(S.card : ℝ) * Real.log (S.card : ℝ)) +
      (S.card : ℝ) * Real.negMulLog (p x) ≤ 1 - (S.card : ℝ) * p x at hh
    nlinarith
  have htotal := Finset.sum_le_sum hpoint
  simp only [Finset.sum_add_distrib, Finset.sum_sub_distrib, ← Finset.mul_sum,
    ← Finset.sum_mul, Finset.sum_const, nsmul_eq_mul, mul_one, hsum, one_mul] at htotal
  apply (mul_le_mul_iff_of_pos_left hcard).mp
  simpa only [finiteEntropy, sub_self, zero_add] using htotal

noncomputable def finitePushforward {ι κ : Type*} [Fintype ι] [DecidableEq κ]
    (p : ι → ℝ) (π : ι → κ) (b : κ) : ℝ := ∑ a : ι with π a = b, p a

theorem finite_pushforward_sum {ι κ : Type*} [Fintype ι] [Fintype κ] [DecidableEq κ]
    (p : ι → ℝ) (π : ι → κ) : ∑ b : κ, finitePushforward p π b = ∑ a : ι, p a := by
  exact Finset.sum_fiberwise Finset.univ π p

theorem finite_entropy_projection_defect {ι κ : Type*} [Fintype ι] [Fintype κ] [DecidableEq κ]
    (p : ι → ℝ) (π : ι → κ) (M : κ → ℝ) {q : ℝ}
    (hp : ∀ a, 0 ≤ p a) (hq : 0 < q) (hM : ∀ b, 0 ≤ M b)
    (hbound : ∀ a, p a ≤ M (π a)) :
    finiteEntropy Finset.univ (finitePushforward p π) + (∑ a : ι, p a) * Real.log q -
      finiteEntropy Finset.univ p ≤ q * (∑ b : κ, M b) - ∑ a : ι, p a := by
  have hfiber : ∀ b : κ,
      Real.negMulLog (finitePushforward p π b) + finitePushforward p π b * Real.log q -
        finiteEntropy (Finset.univ.filter (fun a => π a = b)) p ≤ q * M b - finitePushforward p π b := by
    intro b
    apply finite_entropy_fiber_defect _ p (fun a _ => hp a) hq (hM b)
    intro a ha
    have heq := (Finset.mem_filter.mp ha).2
    simpa only [heq] using hbound a
  have htotal := Finset.sum_le_sum (s := Finset.univ) (fun b _ => hfiber b)
  have hentropy : (∑ b : κ, finiteEntropy (Finset.univ.filter (fun a => π a = b)) p) =
      finiteEntropy Finset.univ p := Finset.sum_fiberwise Finset.univ π (fun a => Real.negMulLog (p a))
  simp only [Finset.sum_add_distrib, Finset.sum_sub_distrib, ← Finset.sum_mul, ← Finset.mul_sum,
    hentropy, finite_pushforward_sum] at htotal
  exact htotal

theorem finite_pushforward_nonneg {ι κ : Type*} [Fintype ι] [DecidableEq κ]
    (p : ι → ℝ) (π : ι → κ) (hp : ∀ a, 0 ≤ p a) (b : κ) :
    0 ≤ finitePushforward p π b := Finset.sum_nonneg (fun a _ => hp a)

theorem le_finite_pushforward {ι κ : Type*} [Fintype ι] [DecidableEq κ]
    (p : ι → ℝ) (π : ι → κ) (hp : ∀ a, 0 ≤ p a) (a : ι) :
    p a ≤ finitePushforward p π (π a) := by
  exact Finset.single_le_sum (fun b _ => hp b) (by simp)

theorem finite_entropy_mono_projection {ι κ : Type*} [Fintype ι] [Fintype κ] [DecidableEq κ]
    (p : ι → ℝ) (π : ι → κ) (hp : ∀ a, 0 ≤ p a) :
    finiteEntropy Finset.univ (finitePushforward p π) ≤ finiteEntropy Finset.univ p := by
  have hh := finite_entropy_projection_defect p π (finitePushforward p π) hp
    (show (0 : ℝ) < 1 by norm_num) (finite_pushforward_nonneg p π hp) (le_finite_pushforward p π hp)
  simp only [Real.log_one, mul_zero, add_zero, one_mul, finite_pushforward_sum, sub_self] at hh
  linarith

theorem finite_entropy_le_log_support {ι : Type*} [Fintype ι] (p : ι → ℝ) (S : Finset ι)
    (hp : ∀ a, 0 ≤ p a) (hmass : ∑ a : ι, p a = 1) (hzero : ∀ a, a ∉ S → p a = 0) :
    finiteEntropy Finset.univ p ≤ Real.log (S.card : ℝ) := by
  classical
  have hsum : ∑ a ∈ S, p a = 1 := by
    rw [Finset.sum_subset (Finset.subset_univ S) (fun a _ ha => hzero a ha)]
    exact hmass
  have hentropy : finiteEntropy S p = finiteEntropy Finset.univ p := by
    apply Finset.sum_subset (Finset.subset_univ S)
    intro a _ ha
    simp [hzero a ha, Real.negMulLog_def]
  rw [← hentropy]
  exact finite_entropy_le_log_card S p (fun a _ => hp a) hsum

theorem branching_interval_chain_entropy_lower_bound {c m : ℕ → ℕ} {T N R : ℕ}
    {α C : ℝ} {z w : ℕ} {L : List (ℕ × ℕ)} (H : ℕ → ℝ)
    (hchain : BranchingIntervalChain c T N R α z L w) (hR : 0 < R)
    (hH : Monotone H) (hm : ∀ i : ℕ, i < N → T * i ≤ m i)
    (hstep : ∀ p ∈ L,
      H (m p.1) + ((T * p.2 - m p.1 : ℕ) : ℝ) * Real.log 2 - C ≤ H (T * p.2)) :
    H (T * z) + ((L.map (fun p => T * p.2 - m p.1)).sum : ℝ) * Real.log 2 -
      C * (L.length : ℝ) ≤ H (T * w) := by
  induction L generalizing z with
  | nil =>
    change w = z at hchain
    simp [hchain]
  | cons p L ih =>
    rcases p with ⟨a, b⟩
    obtain ⟨hza, _, hblock, htail⟩ := hchain
    have hab : a < b := by have := hblock.width; omega
    have haN : a < N := hab.trans_le hblock.end_le
    have hstart := hH ((Nat.mul_le_mul_left T hza).trans (hm a haN))
    have hhead := hstep (a, b) (by simp)
    have hlast := ih htail (fun q hq => hstep q (List.mem_cons_of_mem (a, b) hq))
    simp only [List.map_cons, List.sum_cons, List.length_cons, Nat.cast_add, Nat.cast_one]
    nlinarith

theorem finite_entropy_projection_gain {ι κ : Type*} [Fintype ι] [Fintype κ] [DecidableEq κ]
    (p : ι → ℝ) (π : ι → κ) (M : κ → ℝ) {q C : ℝ}
    (hp : ∀ a, 0 ≤ p a) (hmass : ∑ a : ι, p a = 1) (hq : 0 < q) (hM : ∀ b, 0 ≤ M b)
    (hbound : ∀ a, p a ≤ M (π a)) (hpeak : q * (∑ b : κ, M b) ≤ C + 1) :
    finiteEntropy Finset.univ (finitePushforward p π) + Real.log q - C ≤ finiteEntropy Finset.univ p := by
  have hh := finite_entropy_projection_defect p π M hp hq hM hbound
  rw [hmass, one_mul] at hh
  linarith

theorem finite_pushforward_comp {ι κ ν : Type*} [Fintype ι] [Fintype κ]
    [DecidableEq κ] [DecidableEq ν] (p : ι → ℝ) (π : ι → κ) (σ : κ → ν) :
    finitePushforward (finitePushforward p π) σ = finitePushforward p (σ ∘ π) := by
  funext b
  unfold finitePushforward
  simpa only [Finset.mem_filter, Finset.mem_univ, true_and, Function.comp_apply] using
    Finset.sum_fiberwise_eq_sum_filter (Finset.univ : Finset ι)
      (Finset.univ.filter (fun a => σ a = b)) π p

theorem finite_entropy_pushforward_le_log_image {ι κ : Type*} [Fintype ι] [Fintype κ]
    [DecidableEq κ] (p : ι → ℝ) (π : ι → κ) (hp : ∀ a, 0 ≤ p a) (hmass : ∑ a : ι, p a = 1) :
    finiteEntropy Finset.univ (finitePushforward p π) ≤
      Real.log ((Finset.univ.image π).card : ℝ) := by
  classical
  apply finite_entropy_le_log_support (finitePushforward p π) (Finset.univ.image π)
    (finite_pushforward_nonneg p π hp) (by rw [finite_pushforward_sum, hmass])
  intro b hb
  have he : Finset.univ.filter (fun a => π a = b) = ∅ := by
    apply Finset.eq_empty_iff_forall_notMem.mpr
    intro a ha
    exact hb (Finset.mem_image.mpr ⟨a, Finset.mem_univ a, (Finset.mem_filter.mp ha).2⟩)
  simp only [finitePushforward, he, Finset.sum_empty]

def dyadicIndex (k n : ℕ) : Fin (2 ^ k) := ⟨n % 2 ^ k, Nat.mod_lt n (by positivity)⟩

noncomputable def dyadicDistribution {ι : Type*} [Fintype ι] (p : ι → ℝ) (f : ι → ℕ) (k : ℕ) :
    Fin (2 ^ k) → ℝ := finitePushforward p (fun a => dyadicIndex k (f a))

noncomputable def dyadicEntropy {ι : Type*} [Fintype ι] (p : ι → ℝ) (f : ι → ℕ) (k : ℕ) : ℝ :=
  finiteEntropy Finset.univ (dyadicDistribution p f k)

theorem dyadic_distribution_project {ι : Type*} [Fintype ι] (p : ι → ℝ) (f : ι → ℕ)
    {u v : ℕ} (huv : u ≤ v) :
    finitePushforward (dyadicDistribution p f v) (fun a => dyadicIndex u a.val) = dyadicDistribution p f u := by
  rw [dyadicDistribution, finite_pushforward_comp]
  unfold dyadicDistribution
  congr 1
  funext a
  apply Fin.ext
  exact Nat.mod_mod_of_dvd (f a) (pow_dvd_pow 2 huv)

theorem dyadic_entropy_mono {ι : Type*} [Fintype ι] (p : ι → ℝ) (f : ι → ℕ)
    (hp : ∀ a, 0 ≤ p a) : Monotone (dyadicEntropy p f) := by
  intro u v huv
  have hh := finite_entropy_mono_projection (dyadicDistribution p f v) (fun a => dyadicIndex u a.val)
    (finite_pushforward_nonneg p _ hp)
  rw [dyadic_distribution_project p f huv] at hh
  exact hh

theorem dyadic_entropy_zero {ι : Type*} [Fintype ι] (p : ι → ℝ) (f : ι → ℕ)
    (hmass : ∑ a : ι, p a = 1) : dyadicEntropy p f 0 = 0 := by
  have hi : ∀ a : ι, dyadicIndex 0 (f a) = (0 : Fin (2 ^ 0)) := by
    intro a
    apply Fin.ext
    simp [dyadicIndex]
  have hvalue : dyadicDistribution p f 0 0 = 1 := by
    simpa only [dyadicDistribution, finitePushforward, hi, Finset.filter_true] using hmass
  have hr : ∀ r : Fin (2 ^ 0), r = 0 := by
    intro r
    apply Fin.ext
    have hh := r.isLt
    norm_num at hh
    omega
  unfold dyadicEntropy finiteEntropy
  apply Finset.sum_eq_zero
  intro r _
  rw [hr r, hvalue]
  simp [Real.negMulLog_def]

theorem dyadic_entropy_le_log_projection {ι : Type*} [Fintype ι] (p : ι → ℝ) (f : ι → ℕ)
    (hp : ∀ a, 0 ≤ p a) (hmass : ∑ a : ι, p a = 1) (k : ℕ) :
    dyadicEntropy p f k ≤ Real.log ((dyadicProjection (Finset.univ.image f) k).card : ℝ) := by
  classical
  have hh := finite_entropy_pushforward_le_log_image p (fun a => dyadicIndex k (f a)) hp hmass
  have himage : (Finset.univ.image (fun a => dyadicIndex k (f a))).image Fin.val =
      dyadicProjection (Finset.univ.image f) k := by
    simp only [Finset.image_image, dyadicProjection, dyadicIndex]
    rfl
  have hcard : (Finset.univ.image (fun a => dyadicIndex k (f a))).card =
      (dyadicProjection (Finset.univ.image f) k).card := by
    rw [← himage, Finset.card_image_of_injective _ Fin.val_injective]
  rw [hcard] at hh
  exact hh

theorem dyadic_entropy_interval_gain {ι : Type*} [Fintype ι] (p : ι → ℝ) (f : ι → ℕ)
    (hp : ∀ a, 0 ≤ p a) (hmass : ∑ a : ι, p a = 1) {u v : ℕ} (huv : u ≤ v)
    (M : Fin (2 ^ u) → ℝ) {C : ℝ} (hM : ∀ b, 0 ≤ M b)
    (hbound : ∀ a : Fin (2 ^ v), dyadicDistribution p f v a ≤ M (dyadicIndex u a.val))
    (hpeak : (2 : ℝ) ^ (v - u) * (∑ b, M b) ≤ C + 1) :
    dyadicEntropy p f u + ((v - u : ℕ) : ℝ) * Real.log 2 - C ≤ dyadicEntropy p f v := by
  have hh := finite_entropy_projection_gain (dyadicDistribution p f v) (fun a => dyadicIndex u a.val) M
    (finite_pushforward_nonneg p _ hp) (by rw [dyadicDistribution, finite_pushforward_sum, hmass])
    (pow_pos (by norm_num : (0 : ℝ) < 2) _) hM hbound hpeak
  rw [dyadic_distribution_project p f huv, Real.log_pow] at hh
  exact hh

theorem branching_interval_chain_entropy_amplification {A : Finset ℕ} {c m : ℕ → ℕ}
    {T N R M w : ℕ} {α C ρ B : ℝ} {L : List (ℕ × ℕ)} (H : ℕ → ℝ)
    (hchain : BranchingIntervalChain c T N R α 0 L w) (hR : 0 < R) (hρ : 0 ≤ ρ)
    (hH : Monotone H) (hH0 : H 0 = 0) (hm : ∀ i : ℕ, i < N → T * i ≤ m i)
    (hblocks : ∀ p ∈ L, DyadicAmplificationBlock A (m p.1) (T * p.2) M
      (branchPrefix c p.2 - branchPrefix c p.1) ρ)
    (hstep : ∀ p ∈ L,
      H (m p.1) + ((T * p.2 - m p.1 : ℕ) : ℝ) * Real.log 2 - C ≤ H (T * p.2))
    (hbits : B ≤ ((L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum : ℝ))
    (hloss : C * (L.length : ℝ) ≤ ρ / 2 * B * Real.log 2) :
    (branchPrefix c w : ℝ) * Real.log 2 + ρ / 2 * B * Real.log 2 ≤ H (T * w) := by
  have hchainH := branching_interval_chain_entropy_lower_bound H hchain hR hH hm hstep
  rw [Nat.mul_zero, hH0, zero_add] at hchainH
  have hgain := dyadic_amplification_blocks_entropy_gain hρ hblocks
  have hlog : (0 : ℝ) ≤ Real.log 2 := Real.log_nonneg (by norm_num)
  have hgainlog := mul_le_mul_of_nonneg_right hgain hlog
  have hbitslog := mul_le_mul_of_nonneg_right (mul_le_mul_of_nonneg_left hbits hρ) hlog
  have hsum : ((L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum : ℝ) =
      (branchPrefix c w : ℝ) := by
    rw [branching_interval_chain_entropy hchain, branch_prefix_zero, Nat.sub_zero]
  rw [hsum] at hgainlog hbitslog
  nlinarith

theorem sum_test_cyclicPushforward {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (w : ι → ℂ) (π : ι → ZMod q) (h : ZMod q → ℂ) :
    (∑ a : ZMod q, h a * cyclicPushforward w π a) = ∑ x : ι, h (π x) * w x := by
  classical
  simp only [cyclicPushforward, Finset.mul_sum]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro x _
  simp only [mul_ite, mul_zero]
  simp

theorem sum_test_cyclicConvolution {q : ℕ} [NeZero q] (f g h : ZMod q → ℂ) :
    (∑ a : ZMod q, h a * cyclicConvolution f g a) =
      ∑ x : ZMod q, ∑ y : ZMod q, h (x + y) * f x * g y := by
  simp only [cyclicConvolution, Finset.mul_sum]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro x _
  refine Fintype.sum_equiv (Equiv.subRight x) _ _ ?_
  intro z
  simp only [Equiv.subRight_apply]
  have hh : x + (z - x) = z := by abel
  rw [hh]
  ring

theorem cyclicConvolution_pushforward_left {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (w : ι → ℂ) (π : ι → ZMod q) (g : ZMod q → ℂ) (a : ZMod q) :
    cyclicConvolution (cyclicPushforward w π) g a = ∑ x : ι, w x * g (a - π x) := by
  simpa only [cyclicConvolution, mul_comm] using sum_test_cyclicPushforward w π (fun b => g (a - b))

theorem cyclicPushforward_convolution {Q q : ℕ} [NeZero Q] [NeZero q]
    (f g : ZMod Q → ℂ) (π : ZMod Q →+ ZMod q) :
    cyclicPushforward (cyclicConvolution f g) π =
      cyclicConvolution (cyclicPushforward f π) (cyclicPushforward g π) := by
  classical
  funext a
  calc
    _ = ∑ z : ZMod Q, (if π z = a then (1 : ℂ) else 0) * cyclicConvolution f g z := by
      simp only [cyclicPushforward, ite_mul, one_mul, zero_mul]
    _ = ∑ x : ZMod Q, ∑ y : ZMod Q, (if π (x + y) = a then (1 : ℂ) else 0) * f x * g y :=
      sum_test_cyclicConvolution f g _
    _ = ∑ x : ZMod Q, f x * cyclicPushforward g π (a - π x) := by
      apply Finset.sum_congr rfl
      intro x _
      rw [cyclicPushforward, Finset.mul_sum]
      apply Finset.sum_congr rfl
      intro y _
      rw [map_add]
      by_cases hy : π y = a - π x
      · simp [hy]
      · have hxy : π x + π y ≠ a := by
          intro heq
          apply hy
          exact (eq_sub_iff_add_eq').mpr heq
        simp [hy, hxy]
    _ = _ := (cyclicConvolution_pushforward_left f π (cyclicPushforward g π) a).symm

noncomputable def cyclicTwist {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (k x : ZMod q) : ℂ :=
  ZMod.stdAddChar (-(x * k)) * f x

theorem cyclicTwist_convolution {q : ℕ} [NeZero q] (f g : ZMod q → ℂ) (k : ZMod q) :
    cyclicTwist (cyclicConvolution f g) k = cyclicConvolution (cyclicTwist f k) (cyclicTwist g k) := by
  funext x
  simp only [cyclicTwist, cyclicConvolution, Finset.mul_sum]
  apply Finset.sum_congr rfl
  intro y _
  have hchar : ZMod.stdAddChar (-(x * k)) =
      ZMod.stdAddChar (-(y * k)) * ZMod.stdAddChar (-((x - y) * k)) := by
    rw [← AddChar.map_add_eq_mul]
    congr 1
    ring
  rw [hchar]
  ring

theorem sum_norm_cyclicConvolution_le {q : ℕ} [NeZero q] (f g : ZMod q → ℂ) :
    (∑ x : ZMod q, ‖cyclicConvolution f g x‖) ≤
      (∑ x : ZMod q, ‖f x‖) * (∑ x : ZMod q, ‖g x‖) := by
  calc
    _ ≤ ∑ x : ZMod q, ∑ y : ZMod q, ‖f y‖ * ‖g (x - y)‖ := by
      apply Finset.sum_le_sum
      intro x _
      simpa only [cyclicConvolution, norm_mul] using norm_sum_le Finset.univ (fun y => f y * g (x - y))
    _ = ∑ y : ZMod q, ‖f y‖ * (∑ x : ZMod q, ‖g x‖) := by
      rw [Finset.sum_comm]
      apply Finset.sum_congr rfl
      intro y _
      rw [← Finset.mul_sum]
      congr 1
      exact Fintype.sum_equiv (Equiv.subRight y) _ _ (fun _ => rfl)
    _ = _ := (Finset.sum_mul _ _ _).symm

theorem sum_norm_cyclicConvolutionPow_le {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (r : ℕ) :
    (∑ x : ZMod q, ‖cyclicConvolutionPow f r x‖) ≤ (∑ x : ZMod q, ‖f x‖) ^ r := by
  induction r with
  | zero =>
    simp only [cyclicConvolutionPow, pow_zero]
    have hh : (∑ x : ZMod q, ‖if x = 0 then (1 : ℂ) else 0‖) = 1 := by
      calc
        _ = ∑ x : ZMod q, if x = 0 then (1 : ℝ) else 0 := by
          apply Finset.sum_congr rfl
          intro x _
          by_cases hx : x = 0 <;> simp [hx]
        _ = _ := by simp
    exact hh.le
  | succ r ih =>
    calc
      _ ≤ (∑ x : ZMod q, ‖f x‖) * (∑ x : ZMod q, ‖cyclicConvolutionPow f r x‖) :=
        sum_norm_cyclicConvolution_le f _
      _ ≤ (∑ x : ZMod q, ‖f x‖) * (∑ x : ZMod q, ‖f x‖) ^ r :=
        mul_le_mul_of_nonneg_left ih (Finset.sum_nonneg (fun _ _ => norm_nonneg _))
      _ = _ := by rw [pow_succ]; ring

noncomputable def cyclicFiberDFT {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (f : ZMod Q → ℂ) (k : ZMod Q) : ZMod q → ℂ :=
  cyclicPushforward (cyclicTwist f k) π

noncomputable def cyclicFiberFourierNorm {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (f : ZMod Q → ℂ) (k : ZMod Q) : ℝ :=
  ∑ a : ZMod q, ‖cyclicFiberDFT π f k a‖

theorem cyclicFiberDFT_convolution {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (f g : ZMod Q → ℂ) (k : ZMod Q) :
    cyclicFiberDFT π (cyclicConvolution f g) k =
      cyclicConvolution (cyclicFiberDFT π f k) (cyclicFiberDFT π g k) := by
  unfold cyclicFiberDFT
  rw [cyclicTwist_convolution, cyclicPushforward_convolution]

theorem cyclicFiberDFT_convolutionPow {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (f : ZMod Q → ℂ) (k : ZMod Q) (r : ℕ) :
    cyclicFiberDFT π (cyclicConvolutionPow f r) k = cyclicConvolutionPow (cyclicFiberDFT π f k) r := by
  induction r with
  | zero =>
    funext a
    change (∑ x : ZMod Q, if π x = a then
      ZMod.stdAddChar (-(x * k)) * (if x = 0 then (1 : ℂ) else 0) else 0) = if a = 0 then 1 else 0
    have hh : ∀ x : ZMod Q,
        (if π x = a then ZMod.stdAddChar (-(x * k)) * (if x = 0 then (1 : ℂ) else 0) else 0) =
          if x = 0 then (if a = 0 then 1 else 0) else 0 := by
      intro x
      by_cases hx : x = 0
      · subst x
        simp [eq_comm]
      · simp [hx]
    simp_rw [hh]
    simp
  | succ r ih => rw [cyclicConvolutionPow, cyclicFiberDFT_convolution, ih, cyclicConvolutionPow]

theorem cyclicFiberFourierNorm_convolutionPow_le {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (f : ZMod Q → ℂ) (k : ZMod Q) (r : ℕ) :
    cyclicFiberFourierNorm π (cyclicConvolutionPow f r) k ≤ (cyclicFiberFourierNorm π f k) ^ r := by
  unfold cyclicFiberFourierNorm
  rw [cyclicFiberDFT_convolutionPow]
  exact sum_norm_cyclicConvolutionPow_le _ r

theorem mul_norm_le_sum_norm_dft {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (x : ZMod q) :
    (q : ℝ) * ‖f x‖ ≤ ∑ k : ZMod q, ‖ZMod.dft f k‖ := by
  have hsum := congrFun (ZMod.dft_dft f) (-x)
  rw [ZMod.dft_apply] at hsum
  simp only [mul_neg, neg_neg, smul_eq_mul] at hsum
  calc
    _ = ‖(q : ℂ) * f x‖ := by simp
    _ = ‖∑ k : ZMod q, ZMod.stdAddChar (k * x) * ZMod.dft f k‖ := by rw [hsum]
    _ ≤ ∑ k : ZMod q, ‖ZMod.stdAddChar (k * x) * ZMod.dft f k‖ := norm_sum_le _ _
    _ = _ := by simp only [norm_mul, ZMod.stdAddChar_apply, Circle.norm_coe, one_mul]

theorem dft_restrict_cyclic_fiber {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (f : ZMod Q → ℂ) (a : ZMod q) (k : ZMod Q) :
    ZMod.dft (fun x => if π x = a then f x else 0) k = cyclicFiberDFT π f k a := by
  simp only [ZMod.dft_apply, smul_eq_mul, cyclicFiberDFT, cyclicPushforward, cyclicTwist,
    mul_ite, mul_zero]

theorem cyclic_fiber_norm_bound {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (f : ZMod Q → ℂ) (x : ZMod Q) :
    (Q : ℝ) * ‖f x‖ ≤ ∑ k : ZMod Q, ‖cyclicFiberDFT π f k (π x)‖ := by
  have hh := mul_norm_le_sum_norm_dft (fun y => if π y = π x then f y else 0) x
  simpa only [if_true, dft_restrict_cyclic_fiber] using hh

theorem exists_cyclic_convolution_power_fiber_bound {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (f : ZMod Q → ℂ) (r : ℕ) :
    ∃ M : ZMod q → ℝ, (∀ a, 0 ≤ M a) ∧
      (∀ x, ‖cyclicConvolutionPow f r x‖ ≤ M (π x)) ∧
      (Q : ℝ) * (∑ a : ZMod q, M a) ≤ ∑ k : ZMod Q, (cyclicFiberFourierNorm π f k) ^ r := by
  let M : ZMod q → ℝ := fun a => (∑ k : ZMod Q, ‖cyclicFiberDFT π (cyclicConvolutionPow f r) k a‖) / Q
  have hQ : (0 : ℝ) < Q := by exact_mod_cast NeZero.pos Q
  refine ⟨M, fun a => div_nonneg (Finset.sum_nonneg (fun _ _ => norm_nonneg _)) hQ.le, ?_, ?_⟩
  · intro x
    apply (le_div_iff₀ hQ).mpr
    simpa only [mul_comm] using cyclic_fiber_norm_bound π (cyclicConvolutionPow f r) x
  · change (Q : ℝ) * (∑ a : ZMod q, (∑ k : ZMod Q, ‖cyclicFiberDFT π (cyclicConvolutionPow f r) k a‖) / Q) ≤ _
    rw [← Finset.sum_div, mul_div_cancel₀ _ hQ.ne', Finset.sum_comm]
    exact Finset.sum_le_sum (fun k _ => cyclicFiberFourierNorm_convolutionPow_le π f k r)

theorem sum_norm_cyclicPushforward_le {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (w : ι → ℂ) (π : ι → ZMod q) :
    (∑ a : ZMod q, ‖cyclicPushforward w π a‖) ≤ ∑ x : ι, ‖w x‖ := by
  classical
  calc
    _ ≤ ∑ a : ZMod q, ∑ x : ι, ‖if π x = a then w x else 0‖ :=
      Finset.sum_le_sum (fun a _ => norm_sum_le _ _)
    _ = _ := by
      rw [Finset.sum_comm]
      apply Finset.sum_congr rfl
      intro x _
      simp [apply_ite]

theorem weighted_sum_sq_le {ι : Type*} (S : Finset ι) (w t : ι → ℝ)
    (hw : ∀ i ∈ S, 0 ≤ w i) (hmass : ∑ i ∈ S, w i = 1) :
    (∑ i ∈ S, w i * t i) ^ 2 ≤ ∑ i ∈ S, w i * (t i) ^ 2 := by
  have hleft : (∑ i ∈ S, Real.sqrt (w i) * (Real.sqrt (w i) * t i)) = ∑ i ∈ S, w i * t i := by
    apply Finset.sum_congr rfl
    intro i hi
    rw [← mul_assoc, Real.mul_self_sqrt (hw i hi)]
  have hfirst : (∑ i ∈ S, (Real.sqrt (w i)) ^ 2) = 1 := by
    calc
      _ = ∑ i ∈ S, w i := Finset.sum_congr rfl (fun i hi => Real.sq_sqrt (hw i hi))
      _ = _ := hmass
  have hsecond : (∑ i ∈ S, (Real.sqrt (w i) * t i) ^ 2) = ∑ i ∈ S, w i * (t i) ^ 2 := by
    apply Finset.sum_congr rfl
    intro i hi
    rw [mul_pow, Real.sq_sqrt (hw i hi)]
  have hh := Finset.sum_mul_sq_le_sq_mul_sq S (fun i => Real.sqrt (w i)) (fun i => Real.sqrt (w i) * t i)
  rwa [hleft, hfirst, hsecond, one_mul] at hh

noncomputable def cyclicMixture {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (w : ι → ℝ) (F : ι → ZMod q → ℂ) (x : ZMod q) : ℂ := ∑ i : ι, (w i : ℂ) * F i x

theorem cyclicFiberDFT_mixture {ι : Type*} [Fintype ι] {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (w : ι → ℝ) (F : ι → ZMod Q → ℂ) (k : ZMod Q) (a : ZMod q) :
    cyclicFiberDFT π (cyclicMixture w F) k a = ∑ i : ι, (w i : ℂ) * cyclicFiberDFT π (F i) k a := by
  classical
  unfold cyclicFiberDFT cyclicPushforward cyclicTwist cyclicMixture
  have hh : ∀ x : ZMod Q,
      (if π x = a then ZMod.stdAddChar (-(x * k)) * (∑ i : ι, (w i : ℂ) * F i x) else 0) =
        ∑ i : ι, (w i : ℂ) * (if π x = a then ZMod.stdAddChar (-(x * k)) * F i x else 0) := by
    intro x
    by_cases hx : π x = a
    · simp only [hx, if_true, Finset.mul_sum]
      apply Finset.sum_congr rfl
      intro i _
      ring
    · simp [hx]
  simp_rw [hh, Finset.mul_sum]
  rw [Finset.sum_comm]

theorem cyclicFiberDFT_of_coset_support {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (f : ZMod Q → ℂ) (k : ZMod Q) (b a : ZMod q)
    (hsupport : ∀ x, f x ≠ 0 → π x = b) :
    cyclicFiberDFT π f k a = if b = a then ZMod.dft f k else 0 := by
  classical
  by_cases hba : b = a
  · subst b
    rw [if_pos rfl, ← dft_restrict_cyclic_fiber]
    have hrestrict : (fun x => if π x = a then f x else 0) = f := by
      funext x
      by_cases hx : π x = a
      · simp [hx]
      · have hzero : f x = 0 := by
          by_contra hn
          exact hx (hsupport x hn)
        simp [hx, hzero]
    rw [hrestrict]
  · rw [if_neg hba]
    unfold cyclicFiberDFT cyclicPushforward cyclicTwist
    apply Finset.sum_eq_zero
    intro x _
    by_cases hx : π x = a
    · have hzero : f x = 0 := by
        by_contra hn
        exact hba ((hsupport x hn).symm.trans hx)
      simp [hx, hzero]
    · simp [hx]

theorem cyclicFiberDFT_coset_mixture {ι : Type*} [Fintype ι] {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (w : ι → ℝ) (F : ι → ZMod Q → ℂ) (b : ι → ZMod q)
    (hsupport : ∀ i x, F i x ≠ 0 → π x = b i) (k : ZMod Q) :
    cyclicFiberDFT π (cyclicMixture w F) k =
      cyclicPushforward (fun i => (w i : ℂ) * ZMod.dft (F i) k) b := by
  funext a
  rw [cyclicFiberDFT_mixture]
  unfold cyclicPushforward
  apply Finset.sum_congr rfl
  intro i _
  rw [cyclicFiberDFT_of_coset_support π (F i) k (b i) a (hsupport i)]
  simp only [mul_ite, mul_zero]

theorem cyclicFiberFourierNorm_mixture_sq_le {ι : Type*} [Fintype ι] {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (w : ι → ℝ) (F : ι → ZMod Q → ℂ) (b : ι → ZMod q)
    (hw : ∀ i, 0 ≤ w i) (hmass : ∑ i : ι, w i = 1)
    (hsupport : ∀ i x, F i x ≠ 0 → π x = b i) (k : ZMod Q) :
    (cyclicFiberFourierNorm π (cyclicMixture w F) k) ^ 2 ≤
      ∑ i : ι, w i * ‖ZMod.dft (F i) k‖ ^ 2 := by
  have hnorm : cyclicFiberFourierNorm π (cyclicMixture w F) k ≤
      ∑ i : ι, w i * ‖ZMod.dft (F i) k‖ := by
    unfold cyclicFiberFourierNorm
    rw [cyclicFiberDFT_coset_mixture π w F b hsupport k]
    calc
      _ ≤ ∑ i : ι, ‖(w i : ℂ) * ZMod.dft (F i) k‖ := sum_norm_cyclicPushforward_le _ b
      _ = _ := by
        apply Finset.sum_congr rfl
        intro i _
        rw [norm_mul, Complex.norm_real, Real.norm_eq_abs, abs_of_nonneg (hw i)]
  calc
    _ ≤ (∑ i : ι, w i * ‖ZMod.dft (F i) k‖) ^ 2 :=
      pow_le_pow_left₀ (Finset.sum_nonneg (fun _ _ => norm_nonneg _)) hnorm 2
    _ ≤ _ := weighted_sum_sq_le Finset.univ w (fun i => ‖ZMod.dft (F i) k‖) (fun i _ => hw i) hmass

theorem exists_cyclic_mixture_power_fiber_bound {ι : Type*} [Fintype ι] {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+ ZMod q) (w : ι → ℝ) (F : ι → ZMod Q → ℂ) (b : ι → ZMod q)
    (hw : ∀ i, 0 ≤ w i) (hmass : ∑ i : ι, w i = 1)
    (hsupport : ∀ i x, F i x ≠ 0 → π x = b i) (B : ZMod Q → ℝ)
    (henergy : ∀ k, (∑ i : ι, w i * ‖ZMod.dft (F i) k‖ ^ 2) ≤ B k) (r : ℕ) :
    ∃ M : ZMod q → ℝ, (∀ a, 0 ≤ M a) ∧
      (∀ x, ‖cyclicConvolutionPow (cyclicMixture w F) (2 * r) x‖ ≤ M (π x)) ∧
      (Q : ℝ) * (∑ a : ZMod q, M a) ≤ ∑ k : ZMod Q, (B k) ^ r := by
  obtain ⟨M, hM, hbound, hsum⟩ := exists_cyclic_convolution_power_fiber_bound π (cyclicMixture w F) (2 * r)
  refine ⟨M, hM, hbound, hsum.trans (Finset.sum_le_sum ?_)⟩
  intro k _
  have hh := (cyclicFiberFourierNorm_mixture_sq_le π w F b hw hmass hsupport k).trans (henergy k)
  simpa only [pow_mul] using pow_le_pow_left₀ (sq_nonneg _) hh r

theorem sum_sq_norm_le_of_sum_norm_one {ι : Type*} [Fintype ι] (f : ι → ℂ) {M : ℝ}
    (hmass : ∑ x : ι, ‖f x‖ = 1) (hbound : ∀ x, ‖f x‖ ≤ M) :
    (∑ x : ι, ‖f x‖ ^ 2) ≤ M := by
  calc
    _ ≤ ∑ x : ι, M * ‖f x‖ := Finset.sum_le_sum (fun x _ => by
      simpa only [pow_two] using mul_le_mul_of_nonneg_right (hbound x) (norm_nonneg _))
    _ = M := by rw [← Finset.mul_sum, hmass, mul_one]

theorem weighted_fourier_energy_le {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (w : ZMod q → ℝ)
    {M₁ M₂ : ℝ} (hmass : ∑ x : ZMod q, ‖f x‖ = 1)
    (hM₁ : ∀ x, ‖f x‖ ≤ M₁) (hM₂ : ∀ x, w x ≤ M₂) (hM₂pos : 0 ≤ M₂)
    {k : ZMod q} (hk : IsUnit k) :
    (∑ x : ZMod q, w x * ‖ZMod.dft f (x * k)‖ ^ 2) ≤ (q : ℝ) * M₁ * M₂ := by
  obtain ⟨u, rfl⟩ := hk
  have hperm : (∑ x : ZMod q, ‖ZMod.dft f (x * (u : ZMod q))‖ ^ 2) =
      ∑ x : ZMod q, ‖ZMod.dft f x‖ ^ 2 :=
    Fintype.sum_equiv u.mulRight _ _ (fun _ => rfl)
  calc
    _ ≤ ∑ x : ZMod q, M₂ * ‖ZMod.dft f (x * (u : ZMod q))‖ ^ 2 :=
      Finset.sum_le_sum (fun x _ => mul_le_mul_of_nonneg_right (hM₂ x) (sq_nonneg _))
    _ = M₂ * ((q : ℝ) * ∑ x : ZMod q, ‖f x‖ ^ 2) := by rw [← Finset.mul_sum, hperm, dft_parseval]
    _ ≤ M₂ * ((q : ℝ) * M₁) := mul_le_mul_of_nonneg_left
      (mul_le_mul_of_nonneg_left (sum_sq_norm_le_of_sum_norm_one f hmass hM₁) (Nat.cast_nonneg q)) hM₂pos
    _ = _ := by ring

theorem norm_dft_le_sum_norm {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (k : ZMod q) :
    ‖ZMod.dft f k‖ ≤ ∑ x : ZMod q, ‖f x‖ := by
  rw [ZMod.dft_apply]
  calc
    _ ≤ ∑ x : ZMod q, ‖ZMod.stdAddChar (-(x * k)) • f x‖ := norm_sum_le _ _
    _ = _ := by simp only [smul_eq_mul, norm_mul, ZMod.stdAddChar_apply, Circle.norm_coe, one_mul]

theorem weighted_fourier_energy_le_one {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (w : ZMod q → ℝ)
    (hfnorm : ∑ x : ZMod q, ‖f x‖ = 1) (hw : ∀ x, 0 ≤ w x) (hmass : ∑ x : ZMod q, w x = 1)
    (k : ZMod q) : (∑ x : ZMod q, w x * ‖ZMod.dft f (x * k)‖ ^ 2) ≤ 1 := by
  calc
    _ ≤ ∑ x : ZMod q, w x := by
      apply Finset.sum_le_sum
      intro x _
      have hnorm : ‖ZMod.dft f (x * k)‖ ≤ 1 := by simpa only [hfnorm] using norm_dft_le_sum_norm f (x * k)
      have hsq : ‖ZMod.dft f (x * k)‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg (ZMod.dft f (x * k))]
      simpa only [mul_one] using mul_le_mul_of_nonneg_left hsq (hw x)
    _ = _ := hmass

theorem uniform_fourier_energy_eq {q : ℕ} [NeZero q] (f : ZMod q → ℂ) {k : ZMod q} (hk : IsUnit k) :
    (∑ x : ZMod q, (1 / (q : ℝ)) * ‖ZMod.dft f (x * k)‖ ^ 2) = ∑ x : ZMod q, ‖f x‖ ^ 2 := by
  obtain ⟨u, rfl⟩ := hk
  have hperm : (∑ x : ZMod q, ‖ZMod.dft f (x * (u : ZMod q))‖ ^ 2) =
      ∑ x : ZMod q, ‖ZMod.dft f x‖ ^ 2 := Fintype.sum_equiv u.mulRight _ _ (fun _ => rfl)
  rw [← Finset.mul_sum, hperm, dft_parseval]
  have hq : (q : ℝ) ≠ 0 := by exact_mod_cast NeZero.ne q
  field_simp

theorem probability_point_mass_le_of_two_atoms {ι : Type*} [Fintype ι] (p : ι → ℝ)
    (hp : ∀ i, 0 ≤ p i) (hmass : ∑ i : ι, p i = 1) {a b : ι} (hab : a ≠ b)
    {β : ℝ} (ha : β ≤ p a) (hb : β ≤ p b) : ∀ i, p i ≤ 1 - β := by
  classical
  have hpair : ∀ i j : ι, i ≠ j → p i + p j ≤ 1 := by
    intro i j hij
    have hh := Finset.sum_le_sum_of_subset_of_nonneg
      (Finset.subset_univ ({i, j} : Finset ι)) (fun x _ _ => hp x)
    simpa only [Finset.sum_pair hij, hmass] using hh
  intro i
  by_cases hia : i = a
  · subst i
    have hh := hpair a b hab
    linarith
  · have hh := hpair i a hia
    linarith

theorem finite_probability_collision_le_of_two_atoms {ι : Type*} [Fintype ι] (p : ι → ℝ)
    (hp : ∀ i, 0 ≤ p i) (hmass : ∑ i : ι, p i = 1) {a b : ι} (hab : a ≠ b)
    {β : ℝ} (ha : β ≤ p a) (hb : β ≤ p b) : (∑ i : ι, (p i) ^ 2) ≤ 1 - β := by
  have hbound := probability_point_mass_le_of_two_atoms p hp hmass hab ha hb
  calc
    _ ≤ ∑ i : ι, (1 - β) * p i := Finset.sum_le_sum (fun i _ => by
      simpa only [pow_two] using mul_le_mul_of_nonneg_right (hbound i) (hp i))
    _ = _ := by rw [← Finset.mul_sum, hmass, mul_one]

theorem finite_collision_le_pushforward_collision {ι κ : Type*} [Fintype ι] [Fintype κ]
    [DecidableEq κ] (p : ι → ℝ) (π : ι → κ) (hp : ∀ i, 0 ≤ p i) :
    (∑ i : ι, (p i) ^ 2) ≤ ∑ b : κ, (finitePushforward p π b) ^ 2 := by
  calc
    _ ≤ ∑ i : ι, p i * finitePushforward p π (π i) := Finset.sum_le_sum (fun i _ => by
      simpa only [pow_two] using mul_le_mul_of_nonneg_left (le_finite_pushforward p π hp i) (hp i))
    _ = ∑ b : κ, ∑ i : ι with π i = b, p i * finitePushforward p π (π i) :=
      (Finset.sum_fiberwise Finset.univ π _).symm
    _ = _ := by
      apply Finset.sum_congr rfl
      intro b _
      calc
        _ = ∑ i : ι with π i = b, p i * finitePushforward p π b := by
          apply Finset.sum_congr rfl
          intro i hi
          rw [(Finset.mem_filter.mp hi).2]
        _ = _ := by rw [← Finset.sum_mul, pow_two]; rfl

theorem uniform_fourier_energy_le_of_projected_atoms {κ : Type*} [Fintype κ] [DecidableEq κ]
    {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (π : ZMod q → κ)
    (hmass : ∑ x : ZMod q, ‖f x‖ = 1) {a b : κ} (hab : a ≠ b) {β : ℝ}
    (ha : β ≤ finitePushforward (fun x => ‖f x‖) π a)
    (hb : β ≤ finitePushforward (fun x => ‖f x‖) π b)
    {k : ZMod q} (hk : IsUnit k) :
    (∑ x : ZMod q, (1 / (q : ℝ)) * ‖ZMod.dft f (x * k)‖ ^ 2) ≤ 1 - β := by
  rw [uniform_fourier_energy_eq f hk]
  exact (finite_collision_le_pushforward_collision (fun x => ‖f x‖) π (fun _ => norm_nonneg _)).trans
    (finite_probability_collision_le_of_two_atoms _ (finite_pushforward_nonneg _ π (fun _ => norm_nonneg _))
      (by rw [finite_pushforward_sum, hmass]) hab ha hb)

theorem sum_comp_le_of_fiber_card_le {ι κ : Type*} [Fintype ι] [Fintype κ] [DecidableEq κ]
    (π : ι → κ) (f : κ → ℝ) {m : ℕ} (hf : ∀ a, 0 ≤ f a)
    (hcard : ∀ a, (Finset.univ.filter (fun i => π i = a)).card ≤ m) :
    (∑ i : ι, f (π i)) ≤ (m : ℝ) * ∑ a : κ, f a := by
  rw [← Finset.sum_fiberwise' Finset.univ π f]
  calc
    _ = ∑ a : κ, ((Finset.univ.filter (fun i => π i = a)).card : ℝ) * f a := by
      simp only [Finset.sum_const, nsmul_eq_mul]
    _ ≤ ∑ a : κ, (m : ℝ) * f a := Finset.sum_le_sum (fun a _ =>
      mul_le_mul_of_nonneg_right (by exact_mod_cast hcard a) (hf a))
    _ = _ := (Finset.mul_sum _ _ _).symm

theorem dyadic_frequency_reduction_fiber_card_le (u L : ℕ) (a : ZMod (2 ^ L)) :
    ((Finset.univ : Finset (ZMod (2 ^ (u + L)))).filter
      (fun k => (k.val : ZMod (2 ^ L)) = a)).card ≤ 2 ^ u := by
  classical
  let S := (Finset.univ : Finset (ZMod (2 ^ (u + L)))).filter
    (fun k => (k.val : ZMod (2 ^ L)) = a)
  have hsub : S.image ZMod.val ⊆ (Finset.range (2 ^ (u + L))).filter (fun x => x % 2 ^ L = a.val) := by
    intro x hx
    obtain ⟨k, hk, rfl⟩ := Finset.mem_image.mp hx
    refine Finset.mem_filter.mpr ⟨Finset.mem_range.mpr k.val_lt, ?_⟩
    have hh := congrArg ZMod.val (Finset.mem_filter.mp hk).2
    simpa only [ZMod.val_natCast] using hh
  calc
    _ = (S.image ZMod.val).card := (Finset.card_image_of_injective S (ZMod.val_injective _)).symm
    _ ≤ ((Finset.range (2 ^ (u + L))).filter (fun x => x % 2 ^ L = a.val)).card := Finset.card_le_card hsub
    _ ≤ 2 ^ u := dyadic_residue_fiber_card_le (b := L) (T := u)
      (fun x hx => by simpa only [Nat.add_comm] using Finset.mem_range.mp hx) a.val

theorem sum_dyadic_frequency_reduction_le (u L : ℕ) (f : ZMod (2 ^ L) → ℝ) (hf : ∀ a, 0 ≤ f a) :
    (∑ k : ZMod (2 ^ (u + L)), f (k.val : ZMod (2 ^ L))) ≤
      (2 : ℝ) ^ u * ∑ a : ZMod (2 ^ L), f a := by
  simpa only [Nat.cast_pow, Nat.cast_ofNat] using sum_comp_le_of_fiber_card_le
    (fun k : ZMod (2 ^ (u + L)) => (k.val : ZMod (2 ^ L))) f hf
    (dyadic_frequency_reduction_fiber_card_le u L)

theorem dyadic_nonzero_sum_lt_one_of_quarter_bound {K : ℕ} (f : ZMod (2 ^ K) → ℝ)
    (hbound : ∀ x, x ≠ 0 → f x ≤ (1 / 4 : ℝ) ^ dyadicConductorLevel x) :
    (∑ x ∈ (Finset.univ : Finset (ZMod (2 ^ K))).erase 0, f x) < 1 := by
  classical
  have hmaps : ∀ x ∈ (Finset.univ : Finset (ZMod (2 ^ K))).erase 0,
      dyadicConductorLevel x ∈ Finset.Icc 1 K := by
    intro x hx
    exact Finset.mem_Icc.mpr ⟨dyadic_conductor_pos (Finset.mem_erase.mp hx).1,
      (dyadic_conductor_spec x).1⟩
  have hsum : (∑ x ∈ (Finset.univ : Finset (ZMod (2 ^ K))).erase 0, f x) ≤
      ∑ j ∈ Finset.Icc 1 K, (1 / 2 : ℝ) ^ j := by
    rw [← Finset.sum_fiberwise_of_maps_to hmaps f]
    apply Finset.sum_le_sum
    intro j hj
    have hcard : ((((Finset.univ : Finset (ZMod (2 ^ K))).erase 0).filter
        (fun x => dyadicConductorLevel x = j)).card : ℝ) ≤ (2 : ℝ) ^ j := by
      exact_mod_cast dyadic_conductor_fiber_card_le (Finset.mem_Icc.mp hj).2
    calc
      _ ≤ ∑ x ∈ (((Finset.univ : Finset (ZMod (2 ^ K))).erase 0).filter
          (fun x => dyadicConductorLevel x = j)), (1 / 4 : ℝ) ^ j := by
        apply Finset.sum_le_sum
        intro x hx
        obtain ⟨hx, hlevel⟩ := Finset.mem_filter.mp hx
        simpa only [hlevel] using hbound x (Finset.mem_erase.mp hx).1
      _ = ((((Finset.univ : Finset (ZMod (2 ^ K))).erase 0).filter
          (fun x => dyadicConductorLevel x = j)).card : ℝ) * (1 / 4 : ℝ) ^ j := by simp
      _ ≤ (2 : ℝ) ^ j * (1 / 4 : ℝ) ^ j := mul_le_mul_of_nonneg_right hcard (by positivity)
      _ = (1 / 2 : ℝ) ^ j := by rw [← mul_pow]; norm_num
  rw [dyadic_geometric_sum] at hsum
  exact hsum.trans_lt (by have := pow_pos (by norm_num : (0 : ℝ) < 1 / 2) K; linarith)

theorem exists_power_for_piecewise_dyadic_energy (S : ℕ) {θ t : ℝ}
    (hθ : 0 ≤ θ) (hθ1 : θ < 1) (ht : 0 < t) :
    ∃ r : ℕ, 0 < r ∧ ∀ K : ℕ, ∀ B : ZMod (2 ^ K) → ℝ,
      (∀ x, 0 ≤ B x) → B 0 ≤ 1 →
      (∀ x, x ≠ 0 → dyadicConductorLevel x ≤ S → B x ≤ θ) →
      (∀ x, S < dyadicConductorLevel x → B x ≤ (2 : ℝ) ^ (-t * (dyadicConductorLevel x : ℝ))) →
      (∑ x : ZMod (2 ^ K), (B x) ^ r) < 2 := by
  obtain ⟨r₀, hr₀⟩ : ∃ r₀ : ℕ, θ ^ r₀ < (1 / 4 : ℝ) ^ S :=
    exists_pow_lt_of_lt_one (by positivity) hθ1
  obtain ⟨r₁, hr₁⟩ := exists_nat_ge (2 / t)
  let r := r₀ + r₁ + 1
  have htr₁ : 2 ≤ t * (r₁ : ℝ) := by
    have hh := (div_le_iff₀ ht).mp hr₁
    nlinarith
  have htr : 2 ≤ t * (r : ℝ) := htr₁.trans
    (mul_le_mul_of_nonneg_left (by exact_mod_cast (show r₁ ≤ r by omega)) ht.le)
  refine ⟨r, by omega, ?_⟩
  intro K B hB hBzero hshort hlong
  have hpoint : ∀ x : ZMod (2 ^ K), x ≠ 0 → (B x) ^ r ≤ (1 / 4 : ℝ) ^ dyadicConductorLevel x := by
    intro x hx
    by_cases hlevel : dyadicConductorLevel x ≤ S
    · calc
        _ ≤ θ ^ r := pow_le_pow_left₀ (hB x) (hshort x hx hlevel) r
        _ ≤ θ ^ r₀ := pow_le_pow_of_le_one hθ hθ1.le (by omega)
        _ ≤ (1 / 4 : ℝ) ^ S := hr₀.le
        _ ≤ _ := pow_le_pow_of_le_one (by norm_num) (by norm_num) hlevel
    · exact powered_dyadic_decay_le (hB x) (hlong x (by omega)) htr
  have hnonzero := dyadic_nonzero_sum_lt_one_of_quarter_bound (fun x => (B x) ^ r) hpoint
  have hzero : (B 0) ^ r ≤ 1 := by
    simpa only [one_pow] using pow_le_pow_left₀ (hB 0) hBzero r
  have hsum := Finset.sum_erase_add (Finset.univ : Finset (ZMod (2 ^ K)))
    (fun x => (B x) ^ r) (Finset.mem_univ 0)
  linarith

theorem dyadic_coset_mixture_peak_bound {ι : Type*} [Fintype ι] (u L r : ℕ)
    (π : ZMod (2 ^ (u + L)) →+ ZMod (2 ^ u))
    (w : ι → ℝ) (F : ι → ZMod (2 ^ (u + L)) → ℂ) (b : ι → ZMod (2 ^ u))
    (hw : ∀ i, 0 ≤ w i) (hmass : ∑ i : ι, w i = 1)
    (hsupport : ∀ i x, F i x ≠ 0 → π x = b i) (B : ZMod (2 ^ L) → ℝ) (hB : ∀ k, 0 ≤ B k)
    (henergy : ∀ k : ZMod (2 ^ (u + L)),
      (∑ i : ι, w i * ‖ZMod.dft (F i) k‖ ^ 2) ≤ B (k.val : ZMod (2 ^ L)))
    (hsumB : (∑ k : ZMod (2 ^ L), (B k) ^ r) < 2) :
    ∃ M : ZMod (2 ^ u) → ℝ, (∀ a, 0 ≤ M a) ∧
      (∀ x, ‖cyclicConvolutionPow (cyclicMixture w F) (2 * r) x‖ ≤ M (π x)) ∧
      (2 : ℝ) ^ L * (∑ a : ZMod (2 ^ u), M a) < 2 := by
  obtain ⟨M, hM, hbound, hsum⟩ := exists_cyclic_mixture_power_fiber_bound π w F b hw hmass hsupport
    (fun k => B (k.val : ZMod (2 ^ L))) henergy r
  refine ⟨M, hM, hbound, ?_⟩
  have hreduce := sum_dyadic_frequency_reduction_le u L (fun k => (B k) ^ r) (fun k => pow_nonneg (hB k) r)
  have hU : (0 : ℝ) < (2 : ℝ) ^ u := pow_pos (by norm_num) u
  have hscaled := (hsum.trans hreduce).trans_lt (mul_lt_mul_of_pos_left hsumB hU)
  simp only [Nat.cast_mul, Nat.cast_pow, Nat.cast_ofNat, pow_add, mul_assoc] at hscaled
  exact (mul_lt_mul_iff_of_pos_left hU).mp hscaled

theorem dyadic_fiber_nested (A : Finset ℕ) {d r : ℕ} (hr : r < 2 ^ d) (l s : ℕ) :
    (A.filter (fun x => x % 2 ^ d = r)).filter (fun x => x % 2 ^ (d + l) = r + 2 ^ d * s) =
      A.filter (fun x => x % 2 ^ (d + l) = r + 2 ^ d * s) := by
  ext x
  constructor
  · intro hx
    obtain ⟨hxA, hxh⟩ := Finset.mem_filter.mp hx
    exact Finset.mem_filter.mpr ⟨(Finset.mem_filter.mp hxA).1, hxh⟩
  · intro hx
    obtain ⟨hxA, hxh⟩ := Finset.mem_filter.mp hx
    refine Finset.mem_filter.mpr ⟨Finset.mem_filter.mpr ⟨hxA, ?_⟩, hxh⟩
    calc
      x % 2 ^ d = (x % 2 ^ (d + l)) % 2 ^ d := (Nat.mod_mod_of_dvd x (pow_dvd_pow 2 (by omega))).symm
      _ = (r + 2 ^ d * s) % 2 ^ d := by rw [hxh]
      _ = r := by rw [Nat.add_mul_mod_self_left, Nat.mod_eq_of_lt hr]

theorem dyadic_zoom_residue_mass (A : Finset ℕ) {d r : ℕ} (hr : r < 2 ^ d) (l s : ℕ) :
    natResidueMass (dyadicZoom A d r) (2 ^ l) s =
      natResidueMass (A.filter (fun x => x % 2 ^ d = r)) (2 ^ (d + l))
        (r + 2 ^ d * (s % 2 ^ l)) := by
  classical
  have hs : s % 2 ^ l < 2 ^ l := Nat.mod_lt s (by positivity)
  have hjoin : r + 2 ^ d * (s % 2 ^ l) < 2 ^ (d + l) := by
    rw [pow_add]
    have hpow : 0 < 2 ^ d := by positivity
    nlinarith
  have hleft : natResidueFiber (dyadicZoom A d r) (2 ^ l) s =
      (dyadicZoom A d r).filter (fun x => x % 2 ^ l = s % 2 ^ l) := by
    ext x
    simp only [natResidueFiber, Finset.mem_filter]
    rfl
  have hright : natResidueFiber (A.filter (fun x => x % 2 ^ d = r)) (2 ^ (d + l))
      (r + 2 ^ d * (s % 2 ^ l)) = A.filter (fun x => x % 2 ^ (d + l) = r + 2 ^ d * (s % 2 ^ l)) := by
    rw [← dyadic_fiber_nested A hr l (s % 2 ^ l)]
    ext x
    simp only [natResidueFiber, Finset.mem_filter, Nat.ModEq, Nat.mod_eq_of_lt hjoin]
  unfold natResidueMass
  rw [hleft, hright, dyadic_zoom_fiber_card A hr l (s % 2 ^ l), dyadic_zoom_card A d r]

theorem dyadic_amplification_block_zoom_card {A : Finset ℕ} {u v M e : ℕ} {ρ : ℝ}
    (hblock : DyadicAmplificationBlock A u v M e ρ) {r : ℕ} (hr : r ∈ dyadicProjection A u) :
    (dyadicZoom (dyadicProjection A v) u r).card = 2 ^ e := by
  rw [dyadic_zoom_card, hblock.fiber_card r hr]

theorem dyadic_amplification_block_zoom_mass {A : Finset ℕ} {u v M e : ℕ} {ρ : ℝ}
    (hblock : DyadicAmplificationBlock A u v M e ρ) {r : ℕ} (hr : r ∈ dyadicProjection A u)
    {l : ℕ} (hlM : M ≤ l) (hlv : u + l ≤ v) (s : ℕ) :
    natResidueMass (dyadicZoom (dyadicProjection A v) u r) (2 ^ l) s ≤
      (2 : ℝ) ^ (-(1 - 3 * ρ) * (l : ℝ)) := by
  rw [dyadic_zoom_residue_mass _ (dyadic_projection_bounded A u r hr)]
  simpa only [Nat.add_sub_cancel_left] using
    hblock.mass_le (u + l) (by omega) hlv r hr (r + 2 ^ u * (s % 2 ^ l))

theorem dyadic_zoom_residue_mass_of_mod (A : Finset ℕ) {d r x : ℕ} (hr : r < 2 ^ d)
    (hxr : x % 2 ^ d = r) (l : ℕ) :
    natResidueMass (dyadicZoom A d r) (2 ^ l) (x / 2 ^ d) =
      natResidueMass (A.filter (fun y => y % 2 ^ d = r)) (2 ^ (d + l)) x := by
  have hjoin : r + 2 ^ d * (x / 2 ^ d) = x := by rw [← hxr, Nat.mod_add_div]
  have hmod := dyadic_join_mod hr l (x / 2 ^ d)
  rw [hjoin] at hmod
  rw [dyadic_zoom_residue_mass A hr l (x / 2 ^ d), ← hmod, nat_residue_mass_mod]

theorem dyadic_regular_profile_split_child_mass {A : Finset ℕ} {T N : ℕ} {m c : ℕ → ℕ}
    (hblocks : ∀ i : ℕ, i < N →
      DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i))
    (hprofile : ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j)
    {a b r x : ℕ} (hab : a < b) (hbN : b ≤ N)
    (hx : x ∈ dyadicProjection A (T * (a + 1))) (hxr : x % 2 ^ (m a) = r) :
    (2 : ℝ) ^ (-(T : ℝ)) ≤
      natResidueMass ((dyadicProjection A (T * b)).filter (fun y => y % 2 ^ (m a) = r))
        (2 ^ (m a + 1)) x := by
  classical
  let F := (dyadicProjection A (T * b)).filter (fun y => y % 2 ^ (m a) = r)
  let G := (dyadicProjection A (T * b)).filter (fun y => y % 2 ^ (T * (a + 1)) = x)
  have hblock := hblocks a (hab.trans_le hbN)
  have hme : m a + 1 ≤ T * (a + 1) := by have := hblock.split_lt; nlinarith
  have hm : m a ≤ T * (a + 1) := by omega
  have hr : r ∈ dyadicProjection A (m a) := by
    rw [← dyadic_projection_trans A hm]
    exact Finset.mem_image.mpr ⟨x, hx, hxr⟩
  have hF : F.card = 2 ^ (branchPrefix c b - branchPrefix c a) :=
    dyadic_regular_profile_split_fiber_card hblocks hprofile hab hbN hr
  have hG : G.card = 2 ^ (branchPrefix c b - branchPrefix c (a + 1)) :=
    dyadic_regular_profile_fiber_card (fun i hi => ⟨m i, c i, hblocks i hi⟩) hprofile (by omega) hbN hx
  have hsub : G ⊆ natResidueFiber F (2 ^ (m a + 1)) x := by
    intro y hy
    obtain ⟨hyA, hyx⟩ := Finset.mem_filter.mp hy
    have hlow : y % 2 ^ (m a) = r := by
      calc
        _ = (y % 2 ^ (T * (a + 1))) % 2 ^ (m a) := (Nat.mod_mod_of_dvd y (pow_dvd_pow 2 hm)).symm
        _ = x % 2 ^ (m a) := by rw [hyx]
        _ = r := hxr
    refine Finset.mem_filter.mpr ⟨Finset.mem_filter.mpr ⟨hyA, hlow⟩, ?_⟩
    change y % 2 ^ (m a + 1) = x % 2 ^ (m a + 1)
    calc
      _ = (y % 2 ^ (T * (a + 1))) % 2 ^ (m a + 1) := (Nat.mod_mod_of_dvd y (pow_dvd_pow 2 hme)).symm
      _ = _ := by rw [hyx]
  have hE := branch_prefix_mono c (show a + 1 ≤ b by omega)
  have hsucc := branch_prefix_succ c a
  have hsplit : branchPrefix c b - branchPrefix c a = c a + (branchPrefix c b - branchPrefix c (a + 1)) := by omega
  have hcount : F.card ≤ 2 ^ T * (natResidueFiber F (2 ^ (m a + 1)) x).card := by
    rw [hF, hsplit, pow_add, ← hG]
    exact Nat.mul_le_mul (Nat.pow_le_pow_right (by decide : 0 < 2) hblock.count_le) (Finset.card_le_card hsub)
  have hFR : (0 : ℝ) < F.card := by rw [hF]; positivity
  have hTR : (0 : ℝ) < (2 : ℝ) ^ T := pow_pos (by norm_num) T
  have hcountR : (F.card : ℝ) ≤ (2 : ℝ) ^ T * ((natResidueFiber F (2 ^ (m a + 1)) x).card : ℝ) := by
    exact_mod_cast hcount
  change (2 : ℝ) ^ (-(T : ℝ)) ≤ ((natResidueFiber F (2 ^ (m a + 1)) x).card : ℝ) / (F.card : ℝ)
  rw [Real.rpow_neg (by norm_num : (0 : ℝ) ≤ 2), Real.rpow_natCast]
  apply (le_div_iff₀ hFR).mpr
  apply (mul_le_mul_iff_of_pos_left hTR).mp
  calc
    _ = (F.card : ℝ) := by rw [← mul_assoc, mul_inv_cancel₀ hTR.ne', one_mul]
    _ ≤ _ := hcountR

theorem dyadic_regular_profile_zoom_split_mass {A : Finset ℕ} {T N : ℕ} {m c : ℕ → ℕ}
    (hblocks : ∀ i : ℕ, i < N →
      DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i))
    (hprofile : ∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j)
    {a b r : ℕ} (hab : a < b) (hbN : b ≤ N) (hca : 0 < c a)
    (hr : r ∈ dyadicProjection A (m a)) :
    ∃ x y : ℕ, x % 2 ≠ y % 2 ∧
      (2 : ℝ) ^ (-(T : ℝ)) ≤ natResidueMass (dyadicZoom (dyadicProjection A (T * b)) (m a) r) 2 x ∧
      (2 : ℝ) ^ (-(T : ℝ)) ≤ natResidueMass (dyadicZoom (dyadicProjection A (T * b)) (m a) r) 2 y := by
  have hblock := hblocks a (hab.trans_le hbN)
  have hm : m a ≤ T * (a + 1) := by have := hblock.split_lt; nlinarith
  have hr' : r ∈ dyadicProjection (dyadicProjection A (T * (a + 1))) (m a) := by
    rwa [dyadic_projection_trans A hm]
  obtain ⟨x, hx, y, hy, hxy⟩ := hblock.splits r hr' hca
  obtain ⟨hxA, hxr⟩ := Finset.mem_filter.mp hx
  obtain ⟨hyA, hyr⟩ := Finset.mem_filter.mp hy
  have hrbound := dyadic_projection_bounded A (m a) r hr
  have hxjoin : r + 2 ^ (m a) * (x / 2 ^ (m a)) = x := by rw [← hxr, Nat.mod_add_div]
  have hyjoin : r + 2 ^ (m a) * (y / 2 ^ (m a)) = y := by rw [← hyr, Nat.mod_add_div]
  refine ⟨x / 2 ^ (m a), y / 2 ^ (m a), ?_, ?_, ?_⟩
  · intro heq
    have hh := (dyadic_join_mod_eq_iff hrbound 1 (x / 2 ^ (m a)) (y / 2 ^ (m a))).mpr
      (by simpa only [pow_one] using heq)
    rw [hxjoin, hyjoin] at hh
    exact hxy hh
  · have hmass := dyadic_regular_profile_split_child_mass hblocks hprofile hab hbN hxA hxr
    have heq := dyadic_zoom_residue_mass_of_mod (dyadicProjection A (T * b)) hrbound hxr 1
    rw [pow_one] at heq
    rw [heq]
    exact hmass
  · have hmass := dyadic_regular_profile_split_child_mass hblocks hprofile hab hbN hyA hyr
    have heq := dyadic_zoom_residue_mass_of_mod (dyadicProjection A (T * b)) hrbound hyr 1
    rw [pow_one] at heq
    rw [heq]
    exact hmass

theorem zmod_mul_zero_fiber_card_le {q : ℕ} [NeZero q] (z : ℕ) :
    (Finset.univ.filter (fun x : ZMod q => x * (z : ZMod q) = 0)).card ≤ q.gcd z := by
  classical
  let d := addOrderOf (z : ZMod q)
  have hdq : d * q.gcd z = q := by
    rw [show d = q / q.gcd z from ZMod.addOrderOf_coe z (NeZero.ne q)]
    exact Nat.div_mul_cancel (Nat.gcd_dvd_left q z)
  have hd : 0 < d := by
    have hq : 0 < q := NeZero.pos q
    nlinarith
  have hmap : Set.MapsTo (fun x : ZMod q => x.val)
      (Finset.univ.filter (fun x : ZMod q => x * (z : ZMod q) = 0))
      (natResidueFiber (Finset.range (d * q.gcd z)) d 0) := by
    intro x hx
    have hxz := (Finset.mem_filter.mp hx).2
    have hdiv : d ∣ x.val := by
      apply addOrderOf_dvd_iff_nsmul_eq_zero.mpr
      simpa only [nsmul_eq_mul, ZMod.natCast_zmod_val] using hxz
    refine Finset.mem_filter.mpr ⟨Finset.mem_range.mpr ?_, ?_⟩
    · rw [hdq]
      exact ZMod.val_lt x
    · change x.val % d = 0 % d
      simp only [Nat.mod_eq_zero_of_dvd hdiv, Nat.zero_mod]
  have hinj : Set.InjOn (fun x : ZMod q => x.val)
      (Finset.univ.filter (fun x : ZMod q => x * (z : ZMod q) = 0)) :=
    (ZMod.val_injective q).injOn
  exact (Finset.card_le_card_of_injOn _ hmap hinj).trans (nat_residue_fiber_range_card_le hd)

theorem zmod_mul_fiber_card_le {q : ℕ} [NeZero q] (z : ℕ) (a : ZMod q) :
    (Finset.univ.filter (fun x : ZMod q => x * (z : ZMod q) = a)).card ≤ q.gcd z := by
  classical
  let F := Finset.univ.filter (fun x : ZMod q => x * (z : ZMod q) = a)
  by_cases hF : F.Nonempty
  · obtain ⟨x₀, hx₀⟩ := hF
    have hx₀a := (Finset.mem_filter.mp hx₀).2
    have hmap : Set.MapsTo (fun x : ZMod q => x - x₀) F
        (Finset.univ.filter (fun x : ZMod q => x * (z : ZMod q) = 0)) := by
      intro x hx
      refine Finset.mem_filter.mpr ⟨Finset.mem_univ _, ?_⟩
      rw [sub_mul, (Finset.mem_filter.mp hx).2, hx₀a, sub_self]
    have hinj : Set.InjOn (fun x : ZMod q => x - x₀) F := by
      intro x hx y hy hxy
      exact sub_left_injective hxy
    exact (Finset.card_le_card_of_injOn _ hmap hinj).trans (zmod_mul_zero_fiber_card_le z)
  · change F.card ≤ q.gcd z
    simpa only [Finset.not_nonempty_iff_eq_empty.mp hF, Finset.card_empty] using Nat.zero_le (q.gcd z)

theorem finite_pushforward_mul_le {q : ℕ} [NeZero q] (w : ZMod q → ℝ)
    {M : ℝ} (hM : 0 ≤ M) (hw : ∀ x, w x ≤ M) (z : ℕ) (a : ZMod q) :
    finitePushforward w (fun x => x * (z : ZMod q)) a ≤ (q.gcd z : ℝ) * M := by
  classical
  calc
    _ ≤ ∑ x : ZMod q with x * (z : ZMod q) = a, M :=
      Finset.sum_le_sum (fun x _ => hw x)
    _ = ((Finset.univ.filter (fun x : ZMod q => x * (z : ZMod q) = a)).card : ℝ) * M := by
      rw [Finset.sum_const, nsmul_eq_mul]
    _ ≤ _ := mul_le_mul_of_nonneg_right (by exact_mod_cast zmod_mul_fiber_card_le z a) hM

theorem dyadic_gcd_le_divisor_sum {L S n : ℕ} (hn : 0 < n) (hnS : n ≤ 2 ^ S) :
    (2 ^ L).gcd n ≤ ∑ v ∈ Finset.range (S + 1), if 2 ^ v ∣ n then 2 ^ v else 0 := by
  obtain ⟨a, haL, hga⟩ := (Nat.dvd_prime_pow Nat.prime_two).mp (Nat.gcd_dvd_left (2 ^ L) n)
  have hgn : (2 ^ L).gcd n ≤ n := Nat.le_of_dvd hn (Nat.gcd_dvd_right (2 ^ L) n)
  have haS : a ≤ S := by
    by_contra h
    have hh := Nat.pow_le_pow_right (by decide : 0 < 2) (show S + 1 ≤ a by omega)
    have hp : 0 < 2 ^ S := by positivity
    rw [pow_succ] at hh
    rw [hga] at hgn
    nlinarith
  have hadvd : 2 ^ a ∣ n := by rw [← hga]; exact Nat.gcd_dvd_right _ _
  rw [hga]
  calc
    _ = (if 2 ^ a ∣ n then (2 : ℕ) ^ a else 0) := (if_pos hadvd).symm
    _ ≤ _ := Finset.single_le_sum (s := Finset.range (S + 1))
      (f := fun v : ℕ => if 2 ^ v ∣ n then (2 : ℕ) ^ v else 0) (a := a)
      (fun v _ => Nat.zero_le _)
      (Finset.mem_range.mpr (show a < S + 1 by omega))

theorem sum_dyadic_gcd_Ioc_le (L S : ℕ) :
    (∑ n ∈ Finset.Ioc 0 (2 ^ S), (2 ^ L).gcd n) ≤ (S + 1) * 2 ^ S := by
  classical
  calc
    _ ≤ ∑ n ∈ Finset.Ioc 0 (2 ^ S), ∑ v ∈ Finset.range (S + 1),
        if 2 ^ v ∣ n then 2 ^ v else 0 := by
      apply Finset.sum_le_sum
      intro n hn
      exact dyadic_gcd_le_divisor_sum (Finset.mem_Ioc.mp hn).1 (Finset.mem_Ioc.mp hn).2
    _ = ∑ v ∈ Finset.range (S + 1), ∑ n ∈ Finset.Ioc 0 (2 ^ S),
        if 2 ^ v ∣ n then 2 ^ v else 0 := Finset.sum_comm
    _ = ∑ v ∈ Finset.range (S + 1), 2 ^ S := by
      apply Finset.sum_congr rfl
      intro v hv
      have hvS : v ≤ S := by have := Finset.mem_range.mp hv; omega
      rw [← Finset.sum_filter, Finset.sum_const, nsmul_eq_mul, Nat.Ioc_filter_dvd_card_eq_div,
        Nat.pow_div hvS (by decide : 0 < 2), Nat.cast_id, ← pow_add, Nat.sub_add_cancel hvS]
    _ = _ := by simp

noncomputable def cyclicMultiplierAverage {q : ℕ} [NeZero q]
    (w : ZMod q → ℝ) (C : Finset ℕ) (a : ZMod q) : ℝ :=
  (∑ c ∈ C, finitePushforward w (fun x => x * (c : ZMod q)) a) / (C.card : ℝ)

theorem cyclic_multiplier_average_nonneg {q : ℕ} [NeZero q]
    (w : ZMod q → ℝ) (C : Finset ℕ) (hw : ∀ x, 0 ≤ w x) (a : ZMod q) :
    0 ≤ cyclicMultiplierAverage w C a := by
  apply div_nonneg _ (Nat.cast_nonneg _)
  exact Finset.sum_nonneg (fun c _ => finite_pushforward_nonneg w _ hw a)

theorem cyclic_multiplier_average_sum {q : ℕ} [NeZero q]
    (w : ZMod q → ℝ) {C : Finset ℕ} (hC : C.Nonempty) :
    ∑ a : ZMod q, cyclicMultiplierAverage w C a = ∑ x : ZMod q, w x := by
  classical
  have hcard : (C.card : ℝ) ≠ 0 := by exact_mod_cast (Finset.card_pos.mpr hC).ne'
  simp only [cyclicMultiplierAverage, ← Finset.sum_div]
  rw [Finset.sum_comm]
  simp only [finite_pushforward_sum, Finset.sum_const, nsmul_eq_mul]
  exact mul_div_cancel_left₀ _ hcard

theorem cyclic_multiplier_average_le {q : ℕ} [NeZero q]
    (w : ZMod q → ℝ) (C : Finset ℕ) {M : ℝ} (hM : 0 ≤ M) (hw : ∀ x, w x ≤ M)
    (a : ZMod q) :
    cyclicMultiplierAverage w C a ≤ ((∑ c ∈ C, (q.gcd c : ℝ)) / (C.card : ℝ)) * M := by
  calc
    _ ≤ (∑ c ∈ C, (q.gcd c : ℝ) * M) / (C.card : ℝ) := by
      apply div_le_div_of_nonneg_right _ (Nat.cast_nonneg _)
      exact Finset.sum_le_sum (fun c _ => finite_pushforward_mul_le w hM hw c a)
    _ = _ := by rw [← Finset.sum_mul]; ring

theorem dyadic_multiplier_average_le (L S : ℕ) (w : ZMod (2 ^ L) → ℝ)
    {M : ℝ} (hM : 0 ≤ M) (hw : ∀ x, w x ≤ M) (a : ZMod (2 ^ L)) :
    cyclicMultiplierAverage w (Finset.Ioc 0 (2 ^ S)) a ≤ ((S : ℝ) + 1) * M := by
  have hcard : ((Finset.Ioc 0 (2 ^ S)).card : ℝ) = (2 : ℝ) ^ S := by simp
  have hsum : (∑ c ∈ Finset.Ioc 0 (2 ^ S), ((2 ^ L).gcd c : ℝ)) ≤
      ((S : ℝ) + 1) * (2 : ℝ) ^ S := by
    exact_mod_cast sum_dyadic_gcd_Ioc_le L S
  refine (cyclic_multiplier_average_le w _ hM hw a).trans (mul_le_mul_of_nonneg_right ?_ hM)
  rw [hcard]
  exact (div_le_iff₀ (by positivity : (0 : ℝ) < (2 : ℝ) ^ S)).mpr hsum

theorem nat_residue_fiber_range_card {q N : ℕ} (hq : 0 < q) (r : ℕ) :
    (natResidueFiber (Finset.range (q * N)) q r).card = N := by
  have hh := Nat.count_modEq_card (q * N) hq r
  rw [Nat.count_eq_card_filter_range] at hh
  simpa only [natResidueFiber, Nat.mul_div_right _ hq, Nat.mul_mod_right,
    Nat.not_lt_zero, if_false, add_zero] using hh

theorem nat_residue_mass_range_mul {q N : ℕ} (hq : 0 < q) (hN : 0 < N) (r : ℕ) :
    natResidueMass (Finset.range (q * N)) q r = 1 / (q : ℝ) := by
  have hqR : (q : ℝ) ≠ 0 := by exact_mod_cast hq.ne'
  have hNR : (N : ℝ) ≠ 0 := by exact_mod_cast hN.ne'
  unfold natResidueMass
  rw [nat_residue_fiber_range_card hq, Finset.card_range, Nat.cast_mul]
  field_simp

theorem nat_Ioc_eq_translate_range (N : ℕ) :
    Finset.Ioc 0 N = natTranslate (Finset.range N) 1 := by
  ext x
  constructor
  · intro hx
    obtain ⟨hx0, hxN⟩ := Finset.mem_Ioc.mp hx
    exact Finset.mem_image.mpr ⟨x - 1, Finset.mem_range.mpr (by omega), by omega⟩
  · intro hx
    obtain ⟨n, hn, rfl⟩ := Finset.mem_image.mp hx
    have hnN := Finset.mem_range.mp hn
    exact Finset.mem_Ioc.mpr ⟨by omega, by omega⟩

theorem nat_residue_mass_Ioc_mul {q N : ℕ} (hq : 0 < q) (hN : 0 < N) (r : ℕ) :
    natResidueMass (Finset.Ioc 0 (q * N)) q r = 1 / (q : ℝ) := by
  have : NeZero q := ⟨hq.ne'⟩
  rw [nat_Ioc_eq_translate_range, nat_translate_residue_mass]
  exact nat_residue_mass_range_mul hq hN _

theorem nat_residue_mass_dyadic_Ioc {l S : ℕ} (hlS : l ≤ S) (r : ℕ) :
    natResidueMass (Finset.Ioc 0 (2 ^ S)) (2 ^ l) r = 1 / (2 : ℝ) ^ l := by
  have hpow : 2 ^ S = 2 ^ l * 2 ^ (S - l) := by rw [← pow_add, Nat.add_sub_of_le hlS]
  rw [hpow]
  simpa only [Nat.cast_pow, Nat.cast_ofNat] using
    nat_residue_mass_Ioc_mul (by positivity : 0 < 2 ^ l) (by positivity : 0 < 2 ^ (S - l)) r

theorem cyclic_multiplier_average_uniform {q : ℕ} [NeZero q]
    (w : ZMod q → ℝ) (C : Finset ℕ) (hmass : ∑ x : ZMod q, w x = 1)
    (hsupport : ∀ x, w x ≠ 0 → IsUnit x)
    (hC : ∀ r : ℕ, natResidueMass C q r = 1 / (q : ℝ)) (a : ZMod q) :
    cyclicMultiplierAverage w C a = 1 / (q : ℝ) := by
  classical
  unfold cyclicMultiplierAverage finitePushforward
  simp only [Finset.sum_filter]
  rw [Finset.sum_comm, Finset.sum_div]
  calc
    _ = ∑ x : ZMod q, w x * (1 / (q : ℝ)) := by
      apply Finset.sum_congr rfl
      intro x hx
      by_cases hx0 : w x = 0
      · simp only [hx0, ite_self, Finset.sum_const_zero, zero_div, zero_mul]
      · obtain ⟨u, rfl⟩ := hsupport x hx0
        let b : ZMod q := ↑(u⁻¹) * a
        have hpred (c : ℕ) : (u : ZMod q) * (c : ZMod q) = a ↔ Nat.ModEq q c b.val := by
          rw [← ZMod.natCast_eq_natCast_iff, ZMod.natCast_zmod_val]
          constructor
          · intro hc
            have hh := congrArg (fun z : ZMod q => ↑(u⁻¹) * z) hc
            simpa only [← mul_assoc, Units.inv_mul, one_mul] using hh
          · intro hc
            rw [hc]
            simp only [b, ← mul_assoc, Units.mul_inv, one_mul]
        have hsum : (∑ c ∈ C, if (u : ZMod q) * (c : ZMod q) = a then w ↑u else 0) =
            ((natResidueFiber C q b.val).card : ℝ) * w ↑u := by
          simp_rw [hpred]
          rw [← Finset.sum_filter, Finset.sum_const, nsmul_eq_mul]
          rfl
        rw [hsum]
        calc
          _ = w ↑u * natResidueMass C q b.val := by unfold natResidueMass; ring
          _ = _ := by rw [hC]
    _ = _ := by rw [← Finset.sum_mul, hmass, one_mul]

theorem dyadic_multiplier_average_uniform {l S : ℕ} (hlS : l ≤ S)
    (w : ZMod (2 ^ l) → ℝ) (hmass : ∑ x : ZMod (2 ^ l), w x = 1)
    (hsupport : ∀ x, w x ≠ 0 → IsUnit x) (a : ZMod (2 ^ l)) :
    cyclicMultiplierAverage w (Finset.Ioc 0 (2 ^ S)) a = 1 / (2 : ℝ) ^ l := by
  simpa only [Nat.cast_pow, Nat.cast_ofNat] using
    cyclic_multiplier_average_uniform w (Finset.Ioc 0 (2 ^ S)) hmass hsupport
      (fun r => by simpa only [Nat.cast_pow, Nat.cast_ofNat] using nat_residue_mass_dyadic_Ioc hlS r) a

theorem sum_test_finitePushforward {ι κ : Type*} [Fintype ι] [Fintype κ] [DecidableEq κ]
    (p : ι → ℝ) (π : ι → κ) (h : κ → ℝ) :
    (∑ b : κ, finitePushforward p π b * h b) = ∑ a : ι, p a * h (π a) := by
  classical
  calc
    _ = ∑ b : κ, ∑ a : ι with π a = b, p a * h b := by
      simp only [finitePushforward, Finset.sum_mul]
    _ = ∑ b : κ, ∑ a : ι with π a = b, p a * h (π a) := by
      apply Finset.sum_congr rfl
      intro b _
      apply Finset.sum_congr rfl
      intro a ha
      rw [(Finset.mem_filter.mp ha).2]
    _ = _ := Finset.sum_fiberwise Finset.univ π _

theorem sum_test_cyclicMultiplierAverage {q : ℕ} [NeZero q]
    (w : ZMod q → ℝ) (C : Finset ℕ) (h : ZMod q → ℝ) :
    (∑ a : ZMod q, cyclicMultiplierAverage w C a * h a) =
      (∑ c ∈ C, ∑ x : ZMod q, w x * h (x * (c : ZMod q))) / (C.card : ℝ) := by
  classical
  calc
    _ = (∑ a : ZMod q, ∑ c ∈ C,
        finitePushforward w (fun x => x * (c : ZMod q)) a * h a) / (C.card : ℝ) := by
      simp only [cyclicMultiplierAverage, Finset.sum_mul, Finset.sum_div, div_mul_eq_mul_div]
    _ = _ := by
      rw [Finset.sum_comm]
      congr 1
      apply Finset.sum_congr rfl
      intro c hc
      exact sum_test_finitePushforward w _ h

theorem finite_pushforward_cyclicMultiplierAverage {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+* ZMod q) (w : ZMod Q → ℝ) (C : Finset ℕ) :
    finitePushforward (cyclicMultiplierAverage w C) π =
      cyclicMultiplierAverage (finitePushforward w π) C := by
  classical
  funext a
  unfold finitePushforward cyclicMultiplierAverage
  simp only [← Finset.sum_div]
  rw [Finset.sum_comm]
  congr 1
  apply Finset.sum_congr rfl
  intro c hc
  change finitePushforward (finitePushforward w (fun x => x * (c : ZMod Q))) π a =
    finitePushforward (finitePushforward w π) (fun x => x * (c : ZMod q)) a
  rw [finite_pushforward_comp, finite_pushforward_comp]
  congr 1
  funext x
  simp only [Function.comp_apply, map_mul, map_natCast]

theorem cyclicUniformNatSet_support_odd {A : Finset ℕ} (hodd : ∀ n ∈ A, Odd n)
    (L : ℕ) (x : ZMod (2 ^ L)) (hx : ‖cyclicUniformNatSet A x‖ ≠ 0) : IsUnit x := by
  have hx' : cyclicUniformNatSet A x ≠ 0 := by
    intro h
    exact hx (by rw [h, norm_zero])
  obtain ⟨n, hn, hnx⟩ := cyclicUniformNatSet_support A hx'
  rw [← hnx]
  exact odd_natCast_isUnit_dyadic L (hodd n hn)

theorem dyadic_multiplier_average_decay {g : ℝ} (hg : 0 ≤ g) {S l : ℕ}
    (hS : (S : ℝ) + 1 ≤ (2 : ℝ) ^ (g * (S : ℝ))) (hSl : S ≤ l)
    (w : ZMod (2 ^ l) → ℝ) (hw : ∀ x, w x ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ)))
    (a : ZMod (2 ^ l)) :
    cyclicMultiplierAverage w (Finset.Ioc 0 (2 ^ S)) a ≤ (2 : ℝ) ^ (-g * (l : ℝ)) := by
  have hSlR : (S : ℝ) ≤ l := by exact_mod_cast hSl
  have hfactor : (S : ℝ) + 1 ≤ (2 : ℝ) ^ (g * (l : ℝ)) := hS.trans
    (Real.rpow_le_rpow_of_exponent_le (by norm_num) (mul_le_mul_of_nonneg_left hSlR hg))
  calc
    _ ≤ ((S : ℝ) + 1) * (2 : ℝ) ^ (-(2 * g) * (l : ℝ)) :=
      dyadic_multiplier_average_le l S w (by positivity) hw a
    _ ≤ (2 : ℝ) ^ (g * (l : ℝ)) * (2 : ℝ) ^ (-(2 * g) * (l : ℝ)) :=
      mul_le_mul_of_nonneg_right hfactor (by positivity)
    _ = _ := by rw [← Real.rpow_add (by norm_num)]; congr 1; ring

theorem dyadic_multiplier_fourier_energy_le {S l : ℕ}
    (f : ZMod (2 ^ l) → ℂ) (w : ZMod (2 ^ l) → ℝ) {M₁ M₂ : ℝ}
    (hmass : ∑ x : ZMod (2 ^ l), ‖f x‖ = 1) (hf : ∀ x, ‖f x‖ ≤ M₁)
    (hM₂ : 0 ≤ M₂) (hw : ∀ x, w x ≤ M₂) {k : ZMod (2 ^ l)} (hk : IsUnit k) :
    (∑ x : ZMod (2 ^ l), cyclicMultiplierAverage w (Finset.Ioc 0 (2 ^ S)) x *
      ‖ZMod.dft f (x * k)‖ ^ 2) ≤ (2 : ℝ) ^ l * M₁ * (((S : ℝ) + 1) * M₂) := by
  simpa only [Nat.cast_pow, Nat.cast_ofNat] using weighted_fourier_energy_le f
    (cyclicMultiplierAverage w (Finset.Ioc 0 (2 ^ S))) hmass hf
    (dyadic_multiplier_average_le l S w hM₂ hw) (by positivity) hk

theorem dyadic_multiplier_fourier_energy_decay {g ρ : ℝ} (hg : 0 ≤ g) {S l : ℕ}
    (hS : (S : ℝ) + 1 ≤ (2 : ℝ) ^ (g * (S : ℝ))) (hSl : S ≤ l)
    (f : ZMod (2 ^ l) → ℂ) (w : ZMod (2 ^ l) → ℝ)
    (hmass : ∑ x : ZMod (2 ^ l), ‖f x‖ = 1)
    (hf : ∀ x, ‖f x‖ ≤ (2 : ℝ) ^ (-(1 - 3 * ρ) * (l : ℝ)))
    (hw : ∀ x, w x ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ)))
    {k : ZMod (2 ^ l)} (hk : IsUnit k) :
    (∑ x : ZMod (2 ^ l), cyclicMultiplierAverage w (Finset.Ioc 0 (2 ^ S)) x *
      ‖ZMod.dft f (x * k)‖ ^ 2) ≤ (2 : ℝ) ^ (-(g - 3 * ρ) * (l : ℝ)) := by
  have hh := weighted_fourier_energy_le f (cyclicMultiplierAverage w (Finset.Ioc 0 (2 ^ S)))
    hmass hf (dyadic_multiplier_average_decay hg hS hSl w hw) (by positivity) hk
  apply hh.trans_eq
  rw [Nat.cast_pow, Nat.cast_ofNat, ← Real.rpow_natCast, ← Real.rpow_add (by norm_num),
    ← Real.rpow_add (by norm_num)]
  congr 1; ring

theorem dyadic_multiplier_fourier_energy_gap {κ : Type*} [Fintype κ] [DecidableEq κ]
    {l S : ℕ} (hlS : l ≤ S) (f : ZMod (2 ^ l) → ℂ) (w : ZMod (2 ^ l) → ℝ)
    (π : ZMod (2 ^ l) → κ) (hfnorm : ∑ x : ZMod (2 ^ l), ‖f x‖ = 1)
    (hmass : ∑ x : ZMod (2 ^ l), w x = 1) (hsupport : ∀ x, w x ≠ 0 → IsUnit x)
    {a b : κ} (hab : a ≠ b) {β : ℝ}
    (ha : β ≤ finitePushforward (fun x => ‖f x‖) π a)
    (hb : β ≤ finitePushforward (fun x => ‖f x‖) π b)
    {k : ZMod (2 ^ l)} (hk : IsUnit k) :
    (∑ x : ZMod (2 ^ l), cyclicMultiplierAverage w (Finset.Ioc 0 (2 ^ S)) x *
      ‖ZMod.dft f (x * k)‖ ^ 2) ≤ 1 - β := by
  simp_rw [dyadic_multiplier_average_uniform hlS w hmass hsupport]
  simpa only [Nat.cast_pow, Nat.cast_ofNat] using
    uniform_fourier_energy_le_of_projected_atoms f π hfnorm hab ha hb hk

theorem exists_dyadic_multiplier_cutoff {g : ℝ} (hg : 0 < g) (M : ℕ) :
    ∃ S : ℕ, M ≤ S ∧ 0 < S ∧ (S : ℝ) + 1 ≤ (2 : ℝ) ^ (g * (S : ℝ)) := by
  obtain ⟨S₀, hS₀⟩ := Filter.eventually_atTop.mp (eventually_dyadic_regularization_cost_le hg)
  let S := max S₀ (max M 1)
  have hS : 0 < S := lt_of_lt_of_le (by decide : 0 < 1)
    ((le_max_right M 1).trans (le_max_right S₀ (max M 1)))
  refine ⟨S, (le_max_left M 1).trans (le_max_right S₀ (max M 1)), hS, ?_⟩
  have hh := hS₀ S (le_max_left _ _)
  have hnonneg : (0 : ℝ) ≤ S := Nat.cast_nonneg _
  nlinarith [sq_nonneg (S : ℝ)]

theorem cyclicPushforward_ofReal {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (p : ι → ℝ) (π : ι → ZMod q) (a : ZMod q) :
    cyclicPushforward (fun i => (p i : ℂ)) π a = (finitePushforward p π a : ℂ) := by
  classical
  simp only [cyclicPushforward, finitePushforward, Finset.sum_filter, Complex.ofReal_sum,
    apply_ite, Complex.ofReal_zero]

theorem norm_cyclicPushforward_ofReal {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (p : ι → ℝ) (π : ι → ZMod q) (hp : ∀ i, 0 ≤ p i) (a : ZMod q) :
    ‖cyclicPushforward (fun i => (p i : ℂ)) π a‖ = finitePushforward p π a := by
  rw [cyclicPushforward_ofReal]
  exact Complex.norm_of_nonneg (finite_pushforward_nonneg p π hp a)

theorem norm_cyclicUniformNatSet_eq_pushforward {q : ℕ} [NeZero q] (A : Finset ℕ) :
    (fun x : ZMod q => ‖cyclicUniformNatSet A x‖) =
      finitePushforward (fun _ : A => (A.card : ℝ)⁻¹) (fun n => (n.val : ZMod q)) := by
  funext x
  have hh := norm_cyclicPushforward_ofReal (fun _ : A => (A.card : ℝ)⁻¹)
    (fun n : A => (n.val : ZMod q)) (fun _ => by positivity) x
  simpa only [cyclicUniformNatSet, Complex.ofReal_inv, Complex.ofReal_natCast] using hh

theorem finite_pushforward_norm_cyclicUniformNatSet {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+* ZMod q) (A : Finset ℕ) :
    finitePushforward (fun x : ZMod Q => ‖cyclicUniformNatSet A x‖) π =
      (fun x : ZMod q => ‖cyclicUniformNatSet A x‖) := by
  rw [norm_cyclicUniformNatSet_eq_pushforward, finite_pushforward_comp,
    norm_cyclicUniformNatSet_eq_pushforward]
  congr 1
  funext n
  simp only [Function.comp_apply, map_natCast]

theorem sum_test_norm_cyclicUniformNatSet {q : ℕ} [NeZero q]
    (A : Finset ℕ) (h : ZMod q → ℝ) :
    (∑ x : ZMod q, ‖cyclicUniformNatSet A x‖ * h x) =
      (∑ n ∈ A, h (n : ZMod q)) / (A.card : ℝ) := by
  have hp (x : ZMod q) : ‖cyclicUniformNatSet A x‖ =
      finitePushforward (fun _ : A => (A.card : ℝ)⁻¹) (fun n => (n.val : ZMod q)) x :=
    congrFun (norm_cyclicUniformNatSet_eq_pushforward A) x
  simp_rw [hp]
  rw [sum_test_finitePushforward]
  simp only [← Finset.mul_sum]
  rw [Finset.sum_coe_sort A (fun n => h (n : ZMod q))]
  ring

theorem dyadic_uniform_parity_mass {A : Finset ℕ} {l : ℕ} (hl : 1 ≤ l) (r : ℕ) :
    finitePushforward (fun x : ZMod (2 ^ l) => ‖cyclicUniformNatSet A x‖)
      (ZMod.castHom (pow_dvd_pow 2 hl) (ZMod 2)) (r : ZMod 2) = natResidueMass A 2 r := by
  rw [finite_pushforward_norm_cyclicUniformNatSet]
  dsimp only
  rw [norm_cyclicUniformNatSet, ZMod.val_natCast, nat_residue_mass_mod]

theorem dyadic_uniform_multiplier_energy_gap {A B : Finset ℕ} {l S : ℕ}
    (hl : 1 ≤ l) (hlS : l ≤ S) (hA : A.Nonempty) (hB : B.Nonempty)
    (hBodd : ∀ n ∈ B, Odd n) {a b : ℕ} (hab : a % 2 ≠ b % 2) {β : ℝ}
    (ha : β ≤ natResidueMass A 2 a) (hb : β ≤ natResidueMass A 2 b)
    {k : ZMod (2 ^ l)} (hk : IsUnit k) :
    (∑ x : ZMod (2 ^ l),
      cyclicMultiplierAverage (fun y : ZMod (2 ^ l) => ‖cyclicUniformNatSet B y‖)
        (Finset.Ioc 0 (2 ^ S)) x * ‖ZMod.dft (cyclicUniformNatSet A) (x * k)‖ ^ 2) ≤ 1 - β := by
  apply dyadic_multiplier_fourier_energy_gap hlS (cyclicUniformNatSet A) _
    (ZMod.castHom (pow_dvd_pow 2 hl) (ZMod 2))
    (sum_norm_cyclicUniformNatSet hA) (sum_norm_cyclicUniformNatSet hB)
    (cyclicUniformNatSet_support_odd hBodd l) (a := (a : ZMod 2)) (b := (b : ZMod 2)) ?_ ?_ ?_ hk
  · intro heq
    have hh := congrArg ZMod.val heq
    exact hab (by simpa only [ZMod.val_natCast] using hh)
  · rwa [dyadic_uniform_parity_mass hl]
  · rwa [dyadic_uniform_parity_mass hl]

noncomputable def natMultiplierEnergy {q : ℕ} [NeZero q]
    (A B C : Finset ℕ) (k : ZMod q) : ℝ :=
  (∑ c ∈ C, ∑ b ∈ B, ‖ZMod.dft (cyclicUniformNatSet A)
    (((b * c : ℕ) : ZMod q) * k)‖ ^ 2) / ((B.card : ℝ) * (C.card : ℝ))

theorem natMultiplierEnergy_eq_weighted {q : ℕ} [NeZero q]
    (A B C : Finset ℕ) (k : ZMod q) :
    natMultiplierEnergy A B C k =
      ∑ x : ZMod q, cyclicMultiplierAverage (fun y : ZMod q => ‖cyclicUniformNatSet B y‖) C x *
        ‖ZMod.dft (cyclicUniformNatSet A) (x * k)‖ ^ 2 := by
  rw [sum_test_cyclicMultiplierAverage]
  simp_rw [sum_test_norm_cyclicUniformNatSet]
  rw [← Finset.sum_div, div_div]
  simp only [natMultiplierEnergy, Nat.cast_mul]

theorem natMultiplierEnergy_nonneg {q : ℕ} [NeZero q]
    (A B C : Finset ℕ) (k : ZMod q) : 0 ≤ natMultiplierEnergy A B C k := by
  unfold natMultiplierEnergy
  positivity

theorem natMultiplierEnergy_le_one {q : ℕ} [NeZero q]
    {A B C : Finset ℕ} (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) (k : ZMod q) :
    natMultiplierEnergy A B C k ≤ 1 := by
  rw [natMultiplierEnergy_eq_weighted]
  exact weighted_fourier_energy_le_one (cyclicUniformNatSet A) _ (sum_norm_cyclicUniformNatSet hA)
    (cyclic_multiplier_average_nonneg _ C (fun _ => norm_nonneg _))
    (by rw [cyclic_multiplier_average_sum _ hC, sum_norm_cyclicUniformNatSet hB]) k

theorem natMultiplierEnergy_transfer {Q q : ℕ} [NeZero Q] [NeZero q]
    (A B C : Finset ℕ) (x : ZMod Q) (y : ZMod q)
    (hphase : ∀ n : ℕ, ZMod.stdAddChar (-((n : ZMod Q) * x)) =
      ZMod.stdAddChar (-((n : ZMod q) * y))) :
    natMultiplierEnergy A B C x = natMultiplierEnergy A B C y := by
  unfold natMultiplierEnergy
  congr 1
  apply Finset.sum_congr rfl
  intro c hc
  apply Finset.sum_congr rfl
  intro b hb
  have hterm : ZMod.dft (cyclicUniformNatSet A) (((b * c : ℕ) : ZMod Q) * x) =
      ZMod.dft (cyclicUniformNatSet A) (((b * c : ℕ) : ZMod q) * y) := by
    rw [dft_cyclicUniformNatSet, dft_cyclicUniformNatSet]
    congr 1
    apply Finset.sum_congr rfl
    intro n hn
    simpa only [Nat.cast_mul, mul_assoc] using hphase (n * (b * c))
  rw [hterm]

theorem natMultiplierEnergy_dyadic_short {K S : ℕ} {A B : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hBodd : ∀ n ∈ B, Odd n)
    {a b : ℕ} (hab : a % 2 ≠ b % 2) {β : ℝ}
    (ha : β ≤ natResidueMass A 2 a) (hb : β ≤ natResidueMass A 2 b)
    {k : ZMod (2 ^ K)} (hk : k ≠ 0) (hlevel : dyadicConductorLevel k ≤ S) :
    natMultiplierEnergy A B (Finset.Ioc 0 (2 ^ S)) k ≤ 1 - β := by
  have hl : 1 ≤ dyadicConductorLevel k := dyadic_conductor_pos hk
  have hlK : dyadicConductorLevel k ≤ K := (dyadic_conductor_spec k).1
  obtain ⟨m, hm, hfactor⟩ := dyadic_frequency_factor hk
  rw [natMultiplierEnergy_transfer A B (Finset.Ioc 0 (2 ^ S)) k
    (m : ZMod (2 ^ dyadicConductorLevel k)) (fun n => dyadic_frequency_phase hlK hfactor n),
    natMultiplierEnergy_eq_weighted]
  exact dyadic_uniform_multiplier_energy_gap hl hlevel hA hB hBodd hab ha hb
    (odd_natCast_isUnit_dyadic _ hm)

theorem natMultiplierEnergy_dyadic_long {g ρ : ℝ} (hg : 0 ≤ g) {K S : ℕ}
    (hS : (S : ℝ) + 1 ≤ (2 : ℝ) ^ (g * (S : ℝ))) {A B : Finset ℕ} (hA : A.Nonempty)
    (hAmass : ∀ l : ℕ, S < l → l ≤ K → ∀ x : ZMod (2 ^ l),
      ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-(1 - 3 * ρ) * (l : ℝ)))
    (hBmass : ∀ l : ℕ, S < l → l ≤ K → ∀ x : ZMod (2 ^ l),
      ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ)))
    {k : ZMod (2 ^ K)} (hlevel : S < dyadicConductorLevel k) :
    natMultiplierEnergy A B (Finset.Ioc 0 (2 ^ S)) k ≤
      (2 : ℝ) ^ (-(g - 3 * ρ) * (dyadicConductorLevel k : ℝ)) := by
  have hk : k ≠ 0 := by
    intro hk
    subst k
    simp [dyadicConductorLevel] at hlevel
  have hlK : dyadicConductorLevel k ≤ K := (dyadic_conductor_spec k).1
  obtain ⟨m, hm, hfactor⟩ := dyadic_frequency_factor hk
  rw [natMultiplierEnergy_transfer A B (Finset.Ioc 0 (2 ^ S)) k
    (m : ZMod (2 ^ dyadicConductorLevel k)) (fun n => dyadic_frequency_phase hlK hfactor n),
    natMultiplierEnergy_eq_weighted]
  exact dyadic_multiplier_fourier_energy_decay hg hS hlevel.le (cyclicUniformNatSet A) _
    (sum_norm_cyclicUniformNatSet hA) (hAmass _ hlevel hlK) (hBmass _ hlevel hlK)
    (odd_natCast_isUnit_dyadic _ hm)

theorem exists_power_for_dyadic_multiplier_energy {g ρ β : ℝ}
    (hg : 0 < g) (hρ : 3 * ρ < g) (hβ : 0 < β) (hβ1 : β ≤ 1) (M : ℕ) :
    ∃ S r : ℕ, M ≤ S ∧ 0 < S ∧ 0 < r ∧
      ∀ K : ℕ, ∀ A B : Finset ℕ, A.Nonempty → B.Nonempty → (∀ n ∈ B, Odd n) →
      (∃ a b : ℕ, a % 2 ≠ b % 2 ∧ β ≤ natResidueMass A 2 a ∧ β ≤ natResidueMass A 2 b) →
      (∀ l : ℕ, S < l → l ≤ K → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-(1 - 3 * ρ) * (l : ℝ))) →
      (∀ l : ℕ, S < l → l ≤ K → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ))) →
      (∑ k : ZMod (2 ^ K), (natMultiplierEnergy A B (Finset.Ioc 0 (2 ^ S)) k) ^ r) < 2 := by
  obtain ⟨S, hMS, hSpos, hS⟩ := exists_dyadic_multiplier_cutoff hg M
  obtain ⟨r, hr, hpower⟩ := exists_power_for_piecewise_dyadic_energy S
    (show 0 ≤ 1 - β by linarith) (show 1 - β < 1 by linarith) (show 0 < g - 3 * ρ by linarith)
  refine ⟨S, r, hMS, hSpos, hr, ?_⟩
  intro K A B hA hB hBodd hsplit hAmass hBmass
  obtain ⟨a, b, hab, ha, hb⟩ := hsplit
  have hC : (Finset.Ioc 0 (2 ^ S)).Nonempty := Finset.nonempty_Ioc.mpr (by positivity)
  exact hpower K _ (natMultiplierEnergy_nonneg _ _ _)
    (natMultiplierEnergy_le_one hA hB hC 0)
    (fun k hk hlevel => natMultiplierEnergy_dyadic_short hA hB hBodd hab ha hb hk hlevel)
    (fun k hlevel => natMultiplierEnergy_dyadic_long hg.le hS hA hAmass hBmass hlevel)

theorem stdAddChar_dyadic_affine_phase (u L r n z : ℕ) (k : ZMod (2 ^ (u + L))) :
    ZMod.stdAddChar (-((((r + 2 ^ u * n) * z : ℕ) : ZMod (2 ^ (u + L))) * k)) =
      ZMod.stdAddChar (-(((r * z : ℕ) : ZMod (2 ^ (u + L))) * k)) *
        ZMod.stdAddChar (-(((n * z : ℕ) : ZMod (2 ^ L)) * (k.val : ZMod (2 ^ L)))) := by
  have hs : ZMod.stdAddChar (-((((2 ^ u * n) * z : ℕ) : ZMod (2 ^ (u + L))) * k)) =
      ZMod.stdAddChar (-(((n * z : ℕ) : ZMod (2 ^ L)) * (k.val : ZMod (2 ^ L)))) := by
    have hh := stdAddChar_scaled_modulus (show 2 ^ (u + L) = 2 ^ u * 2 ^ L by rw [pow_add])
      (-((n : ℤ) * (z : ℤ) * (k.val : ℤ)))
    convert hh using 1
    · push_cast
      rw [ZMod.natCast_zmod_val]
      congr 1
      ring
    · push_cast
      rfl
  rw [← hs, ← AddChar.map_add_eq_mul]
  congr 1
  push_cast
  ring

noncomputable def cyclicAffineNatSet {q : ℕ} [NeZero q]
    (A : Finset ℕ) (r d z : ℕ) : ZMod q → ℂ :=
  cyclicPushforward (fun _ : A => (A.card : ℂ)⁻¹)
    (fun n => (((r + d * n.val) * z : ℕ) : ZMod q))

theorem dft_cyclicAffineNatSet (u L : ℕ) (A : Finset ℕ) (r z : ℕ) (k : ZMod (2 ^ (u + L))) :
    ZMod.dft (cyclicAffineNatSet A r (2 ^ u) z) k =
      ZMod.stdAddChar (-(((r * z : ℕ) : ZMod (2 ^ (u + L))) * k)) *
        ZMod.dft (cyclicUniformNatSet A) ((z : ZMod (2 ^ L)) * (k.val : ZMod (2 ^ L))) := by
  rw [cyclicAffineNatSet, dft_cyclicPushforward, dft_cyclicUniformNatSet]
  simp_rw [stdAddChar_dyadic_affine_phase, Nat.cast_mul, mul_assoc]
  rw [← Finset.mul_sum, ← Finset.sum_mul]
  rw [Finset.sum_coe_sort A (fun n : ℕ => ZMod.stdAddChar
    (-((n : ZMod (2 ^ L)) * ((z : ZMod (2 ^ L)) * (k.val : ZMod (2 ^ L))))))]

theorem norm_dft_cyclicAffineNatSet (u L : ℕ) (A : Finset ℕ) (r z : ℕ)
    (k : ZMod (2 ^ (u + L))) :
    ‖ZMod.dft (cyclicAffineNatSet A r (2 ^ u) z) k‖ =
      ‖ZMod.dft (cyclicUniformNatSet A) ((z : ZMod (2 ^ L)) * (k.val : ZMod (2 ^ L)))‖ := by
  rw [dft_cyclicAffineNatSet, norm_mul]
  simp only [ZMod.stdAddChar_apply, Circle.norm_coe, one_mul]

theorem cyclicAffineNatSet_coset_support (u L : ℕ) (A : Finset ℕ) (r z : ℕ)
    (x : ZMod (2 ^ (u + L))) (hx : cyclicAffineNatSet A r (2 ^ u) z x ≠ 0) :
    ZMod.castHom (pow_dvd_pow 2 (show u ≤ u + L by omega)) (ZMod (2 ^ u)) x =
      ((r * z : ℕ) : ZMod (2 ^ u)) := by
  obtain ⟨n, hn, hnw⟩ := cyclicPushforward_support (fun _ : A => (A.card : ℂ)⁻¹)
    (fun n : A => (((r + 2 ^ u * n.val) * z : ℕ) : ZMod (2 ^ (u + L)))) hx
  rw [← hn, map_natCast]
  have hd : ((2 ^ u : ℕ) : ZMod (2 ^ u)) = 0 := ZMod.natCast_self _
  simp only [Nat.cast_mul, Nat.cast_add, hd, zero_mul, add_zero]

noncomputable def cyclicAffineProductLaw {q : ℕ} [NeZero q]
    (A B C : Finset ℕ) (r d : ℕ) : ZMod q → ℂ :=
  cyclicMixture (fun _ : B × C => ((B.card : ℝ) * (C.card : ℝ))⁻¹)
    (fun i => cyclicAffineNatSet A r d (i.1.val * i.2.val))

theorem sum_uniform_pair_weight {B C : Finset ℕ} (hB : B.Nonempty) (hC : C.Nonempty) :
    (∑ _ : B × C, ((B.card : ℝ) * (C.card : ℝ))⁻¹) = 1 := by
  have hBcard : (B.card : ℝ) ≠ 0 := by exact_mod_cast (Finset.card_pos.mpr hB).ne'
  have hCcard : (C.card : ℝ) ≠ 0 := by exact_mod_cast (Finset.card_pos.mpr hC).ne'
  simp only [Finset.sum_const, nsmul_eq_mul, Finset.card_univ, Fintype.card_prod,
    Fintype.card_coe, Nat.cast_mul]
  exact mul_inv_cancel₀ (mul_ne_zero hBcard hCcard)

theorem cyclicAffineProductLaw_energy (u L : ℕ) (A B C : Finset ℕ) (r : ℕ)
    (k : ZMod (2 ^ (u + L))) :
    (∑ i : B × C, ((B.card : ℝ) * (C.card : ℝ))⁻¹ *
      ‖ZMod.dft (cyclicAffineNatSet A r (2 ^ u) (i.1.val * i.2.val)) k‖ ^ 2) =
        natMultiplierEnergy A B C (k.val : ZMod (2 ^ L)) := by
  simp only [norm_dft_cyclicAffineNatSet]
  rw [← Finset.mul_sum]
  have hsum : (∑ i : B × C,
      ‖ZMod.dft (cyclicUniformNatSet A)
        (((i.1.val * i.2.val : ℕ) : ZMod (2 ^ L)) * (k.val : ZMod (2 ^ L)))‖ ^ 2) =
      ∑ c ∈ C, ∑ b ∈ B, ‖ZMod.dft (cyclicUniformNatSet A)
        (((b * c : ℕ) : ZMod (2 ^ L)) * (k.val : ZMod (2 ^ L)))‖ ^ 2 := by
    rw [Fintype.sum_prod_type, Finset.sum_comm]
    rw [Finset.sum_coe_sort C (fun c : ℕ => ∑ b : B, ‖ZMod.dft (cyclicUniformNatSet A)
      (((b.val * c : ℕ) : ZMod (2 ^ L)) * (k.val : ZMod (2 ^ L)))‖ ^ 2)]
    apply Finset.sum_congr rfl
    intro c hc
    exact Finset.sum_coe_sort B (fun b : ℕ => ‖ZMod.dft (cyclicUniformNatSet A)
      (((b * c : ℕ) : ZMod (2 ^ L)) * (k.val : ZMod (2 ^ L)))‖ ^ 2)
  rw [hsum]
  unfold natMultiplierEnergy
  ring

theorem dyadic_affine_product_peak_bound (u L s : ℕ) (A B C : Finset ℕ) (r : ℕ)
    (hB : B.Nonempty) (hC : C.Nonempty)
    (henergy : (∑ k : ZMod (2 ^ L), (natMultiplierEnergy A B C k) ^ s) < 2) :
    ∃ M : ZMod (2 ^ u) → ℝ, (∀ a, 0 ≤ M a) ∧
      (∀ x : ZMod (2 ^ (u + L)), ‖cyclicConvolutionPow (cyclicAffineProductLaw A B C r (2 ^ u))
        (2 * s) x‖ ≤ M ((ZMod.castHom (pow_dvd_pow 2 (show u ≤ u + L by omega))
          (ZMod (2 ^ u))) x)) ∧
      (2 : ℝ) ^ L * (∑ a : ZMod (2 ^ u), M a) < 2 := by
  exact dyadic_coset_mixture_peak_bound u L s
    (ZMod.castHom (pow_dvd_pow 2 (show u ≤ u + L by omega)) (ZMod (2 ^ u))).toAddMonoidHom
    (fun _ : B × C => ((B.card : ℝ) * (C.card : ℝ))⁻¹)
    (fun i => cyclicAffineNatSet A r (2 ^ u) (i.1.val * i.2.val))
    (fun i => ((r * (i.1.val * i.2.val) : ℕ) : ZMod (2 ^ u)))
    (fun _ => by positivity) (sum_uniform_pair_weight hB hC)
    (fun i x hx => cyclicAffineNatSet_coset_support u L A r (i.1.val * i.2.val) x hx)
    (natMultiplierEnergy A B C) (natMultiplierEnergy_nonneg A B C)
    (fun k => (cyclicAffineProductLaw_energy u L A B C r k).le) henergy

theorem exists_dyadic_multiplier_energy_majorant {g ρ β : ℝ}
    (hg : 0 < g) (hρ : 3 * ρ < g) (hβ : 0 < β) (hβ1 : β ≤ 1) (M : ℕ) :
    ∃ S s : ℕ, M ≤ S ∧ 0 < S ∧ 0 < s ∧ ∀ K : ℕ,
      ∃ E : ZMod (2 ^ K) → ℝ, (∀ k, 0 ≤ E k) ∧ (∑ k : ZMod (2 ^ K), (E k) ^ s) < 2 ∧
        ∀ A B : Finset ℕ, A.Nonempty → B.Nonempty → (∀ n ∈ B, Odd n) →
        (∃ a b : ℕ, a % 2 ≠ b % 2 ∧ β ≤ natResidueMass A 2 a ∧ β ≤ natResidueMass A 2 b) →
        (∀ l : ℕ, S < l → l ≤ K → ∀ x : ZMod (2 ^ l),
          ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-(1 - 3 * ρ) * (l : ℝ))) →
        (∀ l : ℕ, S < l → l ≤ K → ∀ x : ZMod (2 ^ l),
          ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ))) →
        ∀ k : ZMod (2 ^ K), natMultiplierEnergy A B (Finset.Ioc 0 (2 ^ S)) k ≤ E k := by
  obtain ⟨S, hMS, hSpos, hS⟩ := exists_dyadic_multiplier_cutoff hg M
  obtain ⟨s, hs, hpower⟩ := exists_power_for_piecewise_dyadic_energy S
    (show 0 ≤ 1 - β by linarith) (show 1 - β < 1 by linarith) (show 0 < g - 3 * ρ by linarith)
  refine ⟨S, s, hMS, hSpos, hs, ?_⟩
  intro K
  let E : ZMod (2 ^ K) → ℝ := fun k => if k = 0 then 1 else
    if dyadicConductorLevel k ≤ S then 1 - β else (2 : ℝ) ^ (-(g - 3 * ρ) * (dyadicConductorLevel k : ℝ))
  have hE : ∀ k, 0 ≤ E k := by
    intro k
    dsimp only [E]
    split_ifs <;> positivity
  have hEzero : E 0 ≤ 1 := by simp only [E, if_pos rfl, le_refl]
  have hshort : ∀ k, k ≠ 0 → dyadicConductorLevel k ≤ S → E k ≤ 1 - β := by
    intro k hk hlevel
    simp only [E, if_neg hk, if_pos hlevel, le_refl]
  have hlong : ∀ k, S < dyadicConductorLevel k → E k ≤
      (2 : ℝ) ^ (-(g - 3 * ρ) * (dyadicConductorLevel k : ℝ)) := by
    intro k hlevel
    have hk : k ≠ 0 := by
      intro hk
      subst k
      simp [dyadicConductorLevel] at hlevel
    simp only [E, if_neg hk, if_neg (not_le.mpr hlevel), le_refl]
  refine ⟨E, hE, hpower K E hE hEzero hshort hlong, ?_⟩
  intro A B hA hB hBodd hsplit hAmass hBmass k
  obtain ⟨a, b, hab, ha, hb⟩ := hsplit
  by_cases hk : k = 0
  · subst k
    simpa only [E, if_pos rfl] using natMultiplierEnergy_le_one hA hB
      (Finset.nonempty_Ioc.mpr (by positivity : 0 < 2 ^ S)) (0 : ZMod (2 ^ K))
  · by_cases hlevel : dyadicConductorLevel k ≤ S
    · simpa only [E, if_neg hk, if_pos hlevel] using
        natMultiplierEnergy_dyadic_short hA hB hBodd hab ha hb hk hlevel
    · simpa only [E, if_neg hk, if_neg hlevel] using
        natMultiplierEnergy_dyadic_long hg.le hS hA hAmass hBmass (lt_of_not_ge hlevel)

noncomputable def cyclicAffineMixtureProductLaw {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (w : ι → ℝ) (A : ι → Finset ℕ) (B C : Finset ℕ) (r : ι → ℕ) (d : ℕ) : ZMod q → ℂ :=
  cyclicMixture (fun i : ι × (B × C) => w i.1 / ((B.card : ℝ) * (C.card : ℝ)))
    (fun i => cyclicAffineNatSet (A i.1) (r i.1) d (i.2.1.val * i.2.2.val))

theorem sum_mixture_pair_weight {ι : Type*} [Fintype ι] (w : ι → ℝ)
    (hmass : ∑ i : ι, w i = 1) {B C : Finset ℕ} (hB : B.Nonempty) (hC : C.Nonempty) :
    (∑ i : ι × (B × C), w i.1 / ((B.card : ℝ) * (C.card : ℝ))) = 1 := by
  rw [Fintype.sum_prod_type]
  simp only [div_eq_mul_inv, ← Finset.mul_sum, sum_uniform_pair_weight hB hC, mul_one, hmass]

theorem cyclicAffineMixtureProductLaw_energy {ι : Type*} [Fintype ι] (u L : ℕ)
    (w : ι → ℝ) (A : ι → Finset ℕ) (B C : Finset ℕ) (r : ι → ℕ) (k : ZMod (2 ^ (u + L))) :
    (∑ i : ι × (B × C), (w i.1 / ((B.card : ℝ) * (C.card : ℝ))) *
      ‖ZMod.dft (cyclicAffineNatSet (A i.1) (r i.1) (2 ^ u) (i.2.1.val * i.2.2.val)) k‖ ^ 2) =
      ∑ i : ι, w i * natMultiplierEnergy (A i) B C (k.val : ZMod (2 ^ L)) := by
  rw [Fintype.sum_prod_type]
  apply Finset.sum_congr rfl
  intro i hi
  rw [← cyclicAffineProductLaw_energy u L (A i) B C (r i) k, Finset.mul_sum]
  apply Finset.sum_congr rfl
  intro j hj
  dsimp only
  ring

theorem dyadic_affine_mixture_peak_bound {ι : Type*} [Fintype ι] (u L s : ℕ)
    (w : ι → ℝ) (A : ι → Finset ℕ) (B C : Finset ℕ) (r : ι → ℕ)
    (hw : ∀ i, 0 ≤ w i) (hmass : ∑ i : ι, w i = 1) (hB : B.Nonempty) (hC : C.Nonempty)
    (E : ZMod (2 ^ L) → ℝ) (hE : ∀ k, 0 ≤ E k)
    (hmajor : ∀ i k, natMultiplierEnergy (A i) B C k ≤ E k)
    (henergy : (∑ k : ZMod (2 ^ L), (E k) ^ s) < 2) :
    ∃ M : ZMod (2 ^ u) → ℝ, (∀ a, 0 ≤ M a) ∧
      (∀ x : ZMod (2 ^ (u + L)),
        ‖cyclicConvolutionPow (cyclicAffineMixtureProductLaw w A B C r (2 ^ u)) (2 * s) x‖ ≤
          M ((ZMod.castHom (pow_dvd_pow 2 (show u ≤ u + L by omega)) (ZMod (2 ^ u))) x)) ∧
      (2 : ℝ) ^ L * (∑ a : ZMod (2 ^ u), M a) < 2 := by
  apply dyadic_coset_mixture_peak_bound u L s
    (ZMod.castHom (pow_dvd_pow 2 (show u ≤ u + L by omega)) (ZMod (2 ^ u))).toAddMonoidHom
    (fun i : ι × (B × C) => w i.1 / ((B.card : ℝ) * (C.card : ℝ)))
    (fun i => cyclicAffineNatSet (A i.1) (r i.1) (2 ^ u) (i.2.1.val * i.2.2.val))
    (fun i => ((r i.1 * (i.2.1.val * i.2.2.val) : ℕ) : ZMod (2 ^ u)))
    (fun i => div_nonneg (hw i.1) (by positivity)) (sum_mixture_pair_weight w hmass hB hC)
    (fun i x hx => cyclicAffineNatSet_coset_support u L (A i.1) (r i.1)
      (i.2.1.val * i.2.2.val) x hx) E hE ?_ henergy
  intro k
  rw [cyclicAffineMixtureProductLaw_energy]
  calc
    _ ≤ ∑ i : ι, w i * E (k.val : ZMod (2 ^ L)) :=
      Finset.sum_le_sum (fun i _ => mul_le_mul_of_nonneg_left (hmajor i _) (hw i))
    _ = _ := by rw [← Finset.sum_mul, hmass, one_mul]

theorem exists_dyadic_affine_mixture_peak {g ρ β : ℝ}
    (hg : 0 < g) (hρ : 3 * ρ < g) (hβ : 0 < β) (hβ1 : β ≤ 1) (M₀ : ℕ) :
    ∃ S s : ℕ, M₀ ≤ S ∧ 0 < S ∧ 0 < s ∧
      ∀ u L : ℕ, ∀ (ι : Type) [Fintype ι], ∀ (w : ι → ℝ) (A : ι → Finset ℕ)
        (r : ι → ℕ) (B : Finset ℕ),
      (∀ i, 0 ≤ w i) → (∑ i : ι, w i = 1) → (∀ i, (A i).Nonempty) → B.Nonempty →
      (∀ n ∈ B, Odd n) →
      (∀ i, ∃ a b : ℕ, a % 2 ≠ b % 2 ∧ β ≤ natResidueMass (A i) 2 a ∧ β ≤ natResidueMass (A i) 2 b) →
      (∀ i, ∀ l : ℕ, S < l → l ≤ L → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet (A i) x‖ ≤ (2 : ℝ) ^ (-(1 - 3 * ρ) * (l : ℝ))) →
      (∀ l : ℕ, S < l → l ≤ L → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ))) →
      ∃ M : ZMod (2 ^ u) → ℝ, (∀ a, 0 ≤ M a) ∧
        (∀ x : ZMod (2 ^ (u + L)),
          ‖cyclicConvolutionPow
            (cyclicAffineMixtureProductLaw w A B (Finset.Ioc 0 (2 ^ S)) r (2 ^ u)) (2 * s) x‖ ≤
            M ((ZMod.castHom (pow_dvd_pow 2 (show u ≤ u + L by omega)) (ZMod (2 ^ u))) x)) ∧
        (2 : ℝ) ^ L * (∑ a : ZMod (2 ^ u), M a) < 2 := by
  obtain ⟨S, s, hMS, hS, hs, hbound⟩ := exists_dyadic_multiplier_energy_majorant hg hρ hβ hβ1 M₀
  refine ⟨S, s, hMS, hS, hs, ?_⟩
  intro u L ι inst w A r B hw hmass hA hB hBodd hsplit hAmass hBmass
  obtain ⟨E, hE, hEsum, hmajor⟩ := hbound L
  exact dyadic_affine_mixture_peak_bound u L s w A B (Finset.Ioc 0 (2 ^ S)) r hw hmass hB
    (Finset.nonempty_Ioc.mpr (by positivity)) E hE
    (fun i k => hmajor (A i) B (hA i) hB hBodd (hsplit i) (hAmass i) hBmass k) hEsum

theorem sum_dyadic_zoom {R : Type*} [AddCommMonoid R] (A : Finset ℕ) (u r : ℕ) (h : ℕ → R) :
    (∑ n ∈ dyadicZoom A u r, h (r + 2 ^ u * n)) =
      ∑ n ∈ A.filter (fun n => n % 2 ^ u = r), h n := by
  rw [dyadicZoom, Finset.sum_image]
  · apply Finset.sum_congr rfl
    intro n hn
    rw [← (Finset.mem_filter.mp hn).2, Nat.mod_add_div]
  · intro x hx y hy hxy
    change x / 2 ^ u = y / 2 ^ u at hxy
    have hmod : x % 2 ^ u = y % 2 ^ u :=
      (Finset.mem_filter.mp hx).2.trans (Finset.mem_filter.mp hy).2.symm
    calc
      x = x % 2 ^ u + 2 ^ u * (x / 2 ^ u) := (Nat.mod_add_div x (2 ^ u)).symm
      _ = y % 2 ^ u + 2 ^ u * (y / 2 ^ u) := by rw [hmod, hxy]
      _ = y := Nat.mod_add_div y (2 ^ u)

theorem sum_dyadic_fibers {R : Type*} [AddCommMonoid R] (A : Finset ℕ) (u : ℕ) (h : ℕ → R) :
    (∑ r ∈ dyadicProjection A u, ∑ n ∈ A.filter (fun n => n % 2 ^ u = r), h n) = ∑ n ∈ A, h n := by
  have hmaps : ∀ n ∈ A, n % 2 ^ u ∈ dyadicProjection A u :=
    fun n hn => Finset.mem_image.mpr ⟨n, hn, rfl⟩
  exact Finset.sum_fiberwise_of_maps_to hmaps h

noncomputable def dyadicFiberWeight (A : Finset ℕ) (u r : ℕ) : ℝ :=
  ((dyadicZoom A u r).card : ℝ) / (A.card : ℝ)

theorem dyadic_fiber_weight_nonneg (A : Finset ℕ) (u r : ℕ) : 0 ≤ dyadicFiberWeight A u r := by
  unfold dyadicFiberWeight
  positivity

theorem sum_dyadic_fiber_weight {A : Finset ℕ} (hA : A.Nonempty) (u : ℕ) :
    (∑ r : dyadicProjection A u, dyadicFiberWeight A u r.val) = 1 := by
  have hcard : (A.card : ℝ) ≠ 0 := by exact_mod_cast (Finset.card_pos.mpr hA).ne'
  rw [Finset.sum_coe_sort (dyadicProjection A u) (dyadicFiberWeight A u)]
  simp only [dyadicFiberWeight, dyadic_zoom_card, ← Finset.sum_div]
  have hh := sum_dyadic_fibers A u (fun _ => (1 : ℝ))
  simp only [Finset.sum_const, nsmul_eq_mul, mul_one] at hh
  rw [hh, div_self hcard]

theorem cyclicAffineNatSet_apply {q : ℕ} [NeZero q] (A : Finset ℕ) (r d z : ℕ) (x : ZMod q) :
    cyclicAffineNatSet A r d z x =
      (∑ n ∈ A, if ((((r + d * n) * z : ℕ) : ZMod q)) = x then (1 : ℂ) else 0) / (A.card : ℂ) := by
  classical
  rw [cyclicAffineNatSet, cyclicPushforward]
  rw [Finset.sum_coe_sort A (fun n => if ((((r + d * n) * z : ℕ) : ZMod q)) = x then
    (A.card : ℂ)⁻¹ else 0)]
  rw [div_eq_mul_inv, Finset.sum_mul]
  apply Finset.sum_congr rfl
  intro n hn
  split_ifs <;> simp only [one_mul, zero_mul]

theorem cyclicAffineNatSet_zoom_apply {q : ℕ} [NeZero q]
    (A : Finset ℕ) (u r z : ℕ) (x : ZMod q) :
    cyclicAffineNatSet (dyadicZoom A u r) r (2 ^ u) z x =
      (∑ n ∈ A.filter (fun n => n % 2 ^ u = r),
        if ((n * z : ℕ) : ZMod q) = x then (1 : ℂ) else 0) /
          ((A.filter (fun n => n % 2 ^ u = r)).card : ℂ) := by
  rw [cyclicAffineNatSet_apply, dyadic_zoom_card]
  congr 1
  exact sum_dyadic_zoom A u r (fun n => if ((n * z : ℕ) : ZMod q) = x then (1 : ℂ) else 0)

theorem cyclicAffineNatSet_dyadic_disintegration {q : ℕ} [NeZero q]
    {A : Finset ℕ} (hA : A.Nonempty) (u z : ℕ) :
    cyclicMixture (fun r : dyadicProjection A u => dyadicFiberWeight A u r.val)
      (fun r => cyclicAffineNatSet (dyadicZoom A u r.val) r.val (2 ^ u) z) =
        (cyclicAffineNatSet A 0 1 z : ZMod q → ℂ) := by
  classical
  have hAcard : (A.card : ℂ) ≠ 0 := by exact_mod_cast (Finset.card_pos.mpr hA).ne'
  funext x
  unfold cyclicMixture
  have hterm (r : dyadicProjection A u) :
      (dyadicFiberWeight A u r.val : ℂ) *
        cyclicAffineNatSet (dyadicZoom A u r.val) r.val (2 ^ u) z x =
      (∑ n ∈ A.filter (fun n => n % 2 ^ u = r.val),
        if ((n * z : ℕ) : ZMod q) = x then (1 : ℂ) else 0) / (A.card : ℂ) := by
    have hcard : ((dyadicZoom A u r.val).card : ℂ) ≠ 0 := by
      exact_mod_cast (Finset.card_pos.mpr (dyadic_zoom_nonempty r.property)).ne'
    rw [dyadic_zoom_card] at hcard
    rw [cyclicAffineNatSet_zoom_apply]
    simp only [dyadicFiberWeight, dyadic_zoom_card, Complex.ofReal_div, Complex.ofReal_natCast]
    field_simp
  simp_rw [hterm]
  rw [Finset.sum_coe_sort (dyadicProjection A u) (fun r =>
    (∑ n ∈ A.filter (fun n => n % 2 ^ u = r),
      if ((n * z : ℕ) : ZMod q) = x then (1 : ℂ) else 0) / (A.card : ℂ))]
  rw [← Finset.sum_div, sum_dyadic_fibers, cyclicAffineNatSet_apply]
  simp only [one_mul, zero_add]

theorem cyclicAffineProductLaw_dyadic_disintegration {q : ℕ} [NeZero q]
    {A : Finset ℕ} (hA : A.Nonempty) (u : ℕ) (B C : Finset ℕ) :
    cyclicAffineMixtureProductLaw
      (fun r : dyadicProjection A u => dyadicFiberWeight A u r.val)
      (fun r => dyadicZoom A u r.val) B C (fun r => r.val) (2 ^ u) =
        (cyclicAffineProductLaw A B C 0 1 : ZMod q → ℂ) := by
  funext x
  unfold cyclicAffineMixtureProductLaw cyclicAffineProductLaw cyclicMixture
  rw [Fintype.sum_prod_type, Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro j hj
  dsimp only
  have hdis := congrFun (cyclicAffineNatSet_dyadic_disintegration (q := q) hA u
    (j.1.val * j.2.val)) x
  change (∑ r : dyadicProjection A u, (dyadicFiberWeight A u r.val : ℂ) *
    cyclicAffineNatSet (dyadicZoom A u r.val) r.val (2 ^ u) (j.1.val * j.2.val) x) =
      cyclicAffineNatSet A 0 1 (j.1.val * j.2.val) x at hdis
  rw [← hdis, Finset.mul_sum]
  apply Finset.sum_congr rfl
  intro r hr
  simp only [Complex.ofReal_div, Complex.ofReal_inv]
  ring

theorem exists_dyadic_set_product_peak {g ρ β : ℝ}
    (hg : 0 < g) (hρ : 3 * ρ < g) (hβ : 0 < β) (hβ1 : β ≤ 1) (M₀ : ℕ) :
    ∃ S s : ℕ, M₀ ≤ S ∧ 0 < S ∧ 0 < s ∧ ∀ u L : ℕ, ∀ A B : Finset ℕ,
      A.Nonempty → B.Nonempty → (∀ n ∈ B, Odd n) →
      (∀ r ∈ dyadicProjection A u, ∃ a b : ℕ, a % 2 ≠ b % 2 ∧
        β ≤ natResidueMass (dyadicZoom A u r) 2 a ∧ β ≤ natResidueMass (dyadicZoom A u r) 2 b) →
      (∀ r ∈ dyadicProjection A u, ∀ l : ℕ, S < l → l ≤ L → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet (dyadicZoom A u r) x‖ ≤ (2 : ℝ) ^ (-(1 - 3 * ρ) * (l : ℝ))) →
      (∀ l : ℕ, S < l → l ≤ L → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ))) →
      ∃ M : ZMod (2 ^ u) → ℝ, (∀ a, 0 ≤ M a) ∧
        (∀ x : ZMod (2 ^ (u + L)),
          ‖cyclicConvolutionPow (cyclicAffineProductLaw A B (Finset.Ioc 0 (2 ^ S)) 0 1) (2 * s) x‖ ≤
            M ((ZMod.castHom (pow_dvd_pow 2 (show u ≤ u + L by omega)) (ZMod (2 ^ u))) x)) ∧
        (2 : ℝ) ^ L * (∑ a : ZMod (2 ^ u), M a) < 2 := by
  obtain ⟨S, s, hMS, hS, hs, hpeak⟩ := exists_dyadic_affine_mixture_peak hg hρ hβ hβ1 M₀
  refine ⟨S, s, hMS, hS, hs, ?_⟩
  intro u L A B hA hB hBodd hsplit hAmass hBmass
  obtain ⟨M, hM, hpoint, hsum⟩ := hpeak u L (dyadicProjection A u)
    (fun r => dyadicFiberWeight A u r.val) (fun r => dyadicZoom A u r.val) (fun r => r.val) B
    (fun r => dyadic_fiber_weight_nonneg A u r.val) (sum_dyadic_fiber_weight hA u)
    (fun r => dyadic_zoom_nonempty r.property) hB hBodd
    (fun r => hsplit r.val r.property) (fun r => hAmass r.val r.property) hBmass
  refine ⟨M, hM, ?_, hsum⟩
  rw [cyclicAffineProductLaw_dyadic_disintegration hA u B (Finset.Ioc 0 (2 ^ S))] at hpoint
  exact hpoint

structure FiniteComplexProbability {ι : Type*} [Fintype ι] (f : ι → ℂ) : Prop where
  norm_cast : ∀ x, f x = (‖f x‖ : ℂ)
  sum_eq_one : ∑ x : ι, f x = 1

theorem finite_complex_probability_ofReal {ι : Type*} [Fintype ι] (p : ι → ℝ)
    (hp : ∀ x, 0 ≤ p x) (hmass : ∑ x : ι, p x = 1) :
    FiniteComplexProbability (fun x => (p x : ℂ)) := by
  refine ⟨?_, ?_⟩
  · intro x
    rw [Complex.norm_of_nonneg (hp x)]
  · rw [← Complex.ofReal_sum, hmass, Complex.ofReal_one]

theorem finite_complex_probability_sum_norm {ι : Type*} [Fintype ι] {f : ι → ℂ}
    (hf : FiniteComplexProbability f) : ∑ x : ι, ‖f x‖ = 1 := by
  have hre (x : ι) : (f x).re = ‖f x‖ := by
    simpa only [Complex.ofReal_re] using congrArg Complex.re (hf.norm_cast x)
  have hh := congrArg Complex.re hf.sum_eq_one
  simpa only [Complex.re_sum, Complex.one_re, hre] using hh

theorem sum_cyclicPushforward {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (p : ι → ℂ) (π : ι → ZMod q) : ∑ x : ZMod q, cyclicPushforward p π x = ∑ i : ι, p i := by
  simpa only [one_mul] using sum_test_cyclicPushforward p π (fun _ => 1)

theorem cyclicPushforward_eq_norm_pushforward {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (p : ι → ℂ) (π : ι → ZMod q) (hp : ∀ i, p i = (‖p i‖ : ℂ)) (x : ZMod q) :
    cyclicPushforward p π x = (finitePushforward (fun i => ‖p i‖) π x : ℂ) := by
  calc
    _ = cyclicPushforward (fun i => (‖p i‖ : ℂ)) π x := by
      congr 1
      exact funext hp
    _ = _ := cyclicPushforward_ofReal _ π x

theorem norm_cyclicPushforward_of_probability {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    {p : ι → ℂ} (hp : FiniteComplexProbability p) (π : ι → ZMod q) (x : ZMod q) :
    ‖cyclicPushforward p π x‖ = finitePushforward (fun i => ‖p i‖) π x := by
  rw [cyclicPushforward_eq_norm_pushforward p π hp.norm_cast]
  exact Complex.norm_of_nonneg (finite_pushforward_nonneg _ π (fun _ => norm_nonneg _) x)

theorem cyclicPushforward_probability {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    {p : ι → ℂ} (hp : FiniteComplexProbability p) (π : ι → ZMod q) :
    FiniteComplexProbability (cyclicPushforward p π) := by
  refine ⟨?_, ?_⟩
  · intro x
    rw [norm_cyclicPushforward_of_probability hp]
    exact cyclicPushforward_eq_norm_pushforward p π hp.norm_cast x
  · rw [sum_cyclicPushforward, hp.sum_eq_one]

theorem sum_cyclicConvolution {q : ℕ} [NeZero q] (f g : ZMod q → ℂ) :
    (∑ x : ZMod q, cyclicConvolution f g x) = (∑ x : ZMod q, f x) * ∑ x : ZMod q, g x := by
  simpa only [one_mul, ← Finset.mul_sum, ← Finset.sum_mul] using
    sum_test_cyclicConvolution f g (fun _ => 1)

theorem cyclicConvolution_probability {q : ℕ} [NeZero q] {f g : ZMod q → ℂ}
    (hf : FiniteComplexProbability f) (hg : FiniteComplexProbability g) :
    FiniteComplexProbability (cyclicConvolution f g) := by
  refine ⟨?_, ?_⟩
  · intro x
    have hrep : cyclicConvolution f g x =
        ((∑ y : ZMod q, ‖f y‖ * ‖g (x - y)‖ : ℝ) : ℂ) := by
      unfold cyclicConvolution
      rw [Complex.ofReal_sum]
      apply Finset.sum_congr rfl
      intro y hy
      calc
        _ = (‖f y‖ : ℂ) * (‖g (x - y)‖ : ℂ) :=
          congrArg₂ (fun a b : ℂ => a * b) (hf.norm_cast y) (hg.norm_cast (x - y))
        _ = _ := (Complex.ofReal_mul _ _).symm
    have hnonneg : 0 ≤ ∑ y : ZMod q, ‖f y‖ * ‖g (x - y)‖ :=
      Finset.sum_nonneg (fun y _ => mul_nonneg (norm_nonneg _) (norm_nonneg _))
    rw [hrep, Complex.norm_of_nonneg hnonneg]
  · rw [sum_cyclicConvolution, hf.sum_eq_one, hg.sum_eq_one, mul_one]

theorem cyclicConvolutionPow_probability {q : ℕ} [NeZero q] {f : ZMod q → ℂ}
    (hf : FiniteComplexProbability f) (s : ℕ) : FiniteComplexProbability (cyclicConvolutionPow f s) := by
  classical
  induction s with
  | zero =>
    refine ⟨?_, ?_⟩
    · intro x
      by_cases hx : x = 0 <;> simp [cyclicConvolutionPow, hx]
    · simp [cyclicConvolutionPow]
  | succ s ih => exact cyclicConvolution_probability hf ih

theorem cyclicMixture_probability {ι : Type*} [Fintype ι] {q : ℕ} [NeZero q]
    (w : ι → ℝ) (F : ι → ZMod q → ℂ) (hw : ∀ i, 0 ≤ w i) (hmass : ∑ i : ι, w i = 1)
    (hF : ∀ i, FiniteComplexProbability (F i)) : FiniteComplexProbability (cyclicMixture w F) := by
  refine ⟨?_, ?_⟩
  · intro x
    have hrep : cyclicMixture w F x = ((∑ i : ι, w i * ‖F i x‖ : ℝ) : ℂ) := by
      unfold cyclicMixture
      rw [Complex.ofReal_sum]
      apply Finset.sum_congr rfl
      intro i hi
      calc
        _ = (w i : ℂ) * (‖F i x‖ : ℂ) := congrArg (fun z : ℂ => (w i : ℂ) * z) ((hF i).norm_cast x)
        _ = _ := (Complex.ofReal_mul _ _).symm
    have hnonneg : 0 ≤ ∑ i : ι, w i * ‖F i x‖ :=
      Finset.sum_nonneg (fun i _ => mul_nonneg (hw i) (norm_nonneg _))
    rw [hrep, Complex.norm_of_nonneg hnonneg]
  · have hFsum (i : ι) : ∑ x : ZMod q, F i x = 1 := (hF i).sum_eq_one
    unfold cyclicMixture
    rw [Finset.sum_comm]
    simp only [← Finset.mul_sum, hFsum, mul_one, ← Complex.ofReal_sum, hmass, Complex.ofReal_one]

theorem cyclicAffineNatSet_probability {q : ℕ} [NeZero q] {A : Finset ℕ}
    (hA : A.Nonempty) (r d z : ℕ) : FiniteComplexProbability (cyclicAffineNatSet (q := q) A r d z) := by
  have hcard : (A.card : ℝ) ≠ 0 := by exact_mod_cast (Finset.card_pos.mpr hA).ne'
  have hmass : (∑ _ : A, (A.card : ℝ)⁻¹) = 1 := by
    simp only [Finset.sum_const, nsmul_eq_mul, Finset.card_univ, Fintype.card_coe]
    exact mul_inv_cancel₀ hcard
  have hp := finite_complex_probability_ofReal (fun _ : A => (A.card : ℝ)⁻¹)
    (fun _ => by positivity) hmass
  have hh := cyclicPushforward_probability hp (fun n : A => (((r + d * n.val) * z : ℕ) : ZMod q))
  simpa only [cyclicAffineNatSet, Complex.ofReal_inv, Complex.ofReal_natCast] using hh

theorem cyclicAffineProductLaw_probability {q : ℕ} [NeZero q] {A B C : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) (r d : ℕ) :
    FiniteComplexProbability (cyclicAffineProductLaw (q := q) A B C r d) := by
  exact cyclicMixture_probability _ _ (fun _ => by positivity) (sum_uniform_pair_weight hB hC)
    (fun i => cyclicAffineNatSet_probability hA r d (i.1.val * i.2.val))

theorem cyclicPushforward_comp {ι : Type*} [Fintype ι] {Q q : ℕ} [NeZero Q] [NeZero q]
    (w : ι → ℂ) (T : ι → ZMod Q) (π : ZMod Q → ZMod q) :
    cyclicPushforward (cyclicPushforward w T) π = cyclicPushforward w (π ∘ T) := by
  classical
  funext a
  simpa only [cyclicPushforward, Function.comp_apply, ite_mul, one_mul, zero_mul] using
    sum_test_cyclicPushforward w T (fun x => if π x = a then (1 : ℂ) else 0)

theorem cyclicPushforward_mixture {ι : Type*} [Fintype ι] {Q q : ℕ} [NeZero Q] [NeZero q]
    (w : ι → ℝ) (F : ι → ZMod Q → ℂ) (π : ZMod Q → ZMod q) :
    cyclicPushforward (cyclicMixture w F) π = cyclicMixture w (fun i => cyclicPushforward (F i) π) := by
  classical
  funext a
  have hterm (x : ZMod Q) : (if π x = a then ∑ i : ι, (w i : ℂ) * F i x else 0) =
      ∑ i : ι, (w i : ℂ) * (if π x = a then F i x else 0) := by
    by_cases hx : π x = a <;> simp [hx]
  change (∑ x : ZMod Q, if π x = a then ∑ i : ι, (w i : ℂ) * F i x else 0) =
    ∑ i : ι, (w i : ℂ) * ∑ x : ZMod Q, if π x = a then F i x else 0
  simp_rw [hterm, Finset.mul_sum]
  rw [Finset.sum_comm]

theorem cyclicPushforward_convolutionPow {Q q : ℕ} [NeZero Q] [NeZero q]
    (f : ZMod Q → ℂ) (π : ZMod Q →+ ZMod q) (s : ℕ) :
    cyclicPushforward (cyclicConvolutionPow f s) π = cyclicConvolutionPow (cyclicPushforward f π) s := by
  classical
  induction s with
  | zero =>
    funext a
    have hterm (x : ZMod Q) : (if π x = a then (if x = 0 then (1 : ℂ) else 0) else 0) =
        if x = 0 then (if a = 0 then (1 : ℂ) else 0) else 0 := by
      by_cases hx : x = 0
      · subst x
        simp [eq_comm]
      · simp only [if_neg hx, ite_self]
    simp only [cyclicConvolutionPow, cyclicPushforward, hterm]
    simp
  | succ s ih => rw [cyclicConvolutionPow, cyclicPushforward_convolution, ih, cyclicConvolutionPow]

theorem cyclicPushforward_cyclicUniformNatSet {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+* ZMod q) (A : Finset ℕ) :
    cyclicPushforward (cyclicUniformNatSet (q := Q) A) π = cyclicUniformNatSet (q := q) A := by
  unfold cyclicUniformNatSet
  rw [cyclicPushforward_comp]
  congr 1
  funext n
  simp only [Function.comp_apply, map_natCast]

theorem cyclicPushforward_cyclicAffineNatSet {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+* ZMod q) (A : Finset ℕ) (r d z : ℕ) :
    cyclicPushforward (cyclicAffineNatSet (q := Q) A r d z) π = cyclicAffineNatSet (q := q) A r d z := by
  unfold cyclicAffineNatSet
  rw [cyclicPushforward_comp]
  congr 1
  funext n
  simp only [Function.comp_apply, map_natCast]

theorem cyclicPushforward_cyclicAffineProductLaw {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+* ZMod q) (A B C : Finset ℕ) (r d : ℕ) :
    cyclicPushforward (cyclicAffineProductLaw (q := Q) A B C r d) π =
      cyclicAffineProductLaw (q := q) A B C r d := by
  unfold cyclicAffineProductLaw
  rw [cyclicPushforward_mixture]
  congr 1
  funext i
  exact cyclicPushforward_cyclicAffineNatSet π A r d (i.1.val * i.2.val)

noncomputable def dyadicProductSumLaw (A B C : Finset ℕ) (s k : ℕ) : ZMod (2 ^ k) → ℂ :=
  cyclicConvolutionPow (cyclicAffineProductLaw A B C 0 1) s

noncomputable def dyadicProductSumEntropy (A B C : Finset ℕ) (s k : ℕ) : ℝ :=
  finiteEntropy Finset.univ (fun x : ZMod (2 ^ k) => ‖dyadicProductSumLaw A B C s k x‖)

theorem dyadic_product_sum_law_probability {A B C : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) (s k : ℕ) :
    FiniteComplexProbability (dyadicProductSumLaw A B C s k) :=
  cyclicConvolutionPow_probability (cyclicAffineProductLaw_probability hA hB hC 0 1) s

theorem dyadic_product_sum_law_project (A B C : Finset ℕ) (s : ℕ) {u v : ℕ} (huv : u ≤ v) :
    cyclicPushforward (dyadicProductSumLaw A B C s v)
      (ZMod.castHom (pow_dvd_pow 2 huv) (ZMod (2 ^ u))) = dyadicProductSumLaw A B C s u := by
  unfold dyadicProductSumLaw
  have hh := cyclicPushforward_convolutionPow (cyclicAffineProductLaw A B C 0 1)
    (ZMod.castHom (pow_dvd_pow 2 huv) (ZMod (2 ^ u))).toAddMonoidHom s
  change cyclicPushforward (cyclicConvolutionPow (cyclicAffineProductLaw A B C 0 1) s)
    (ZMod.castHom (pow_dvd_pow 2 huv) (ZMod (2 ^ u))) =
      cyclicConvolutionPow (cyclicPushforward (cyclicAffineProductLaw A B C 0 1)
        (ZMod.castHom (pow_dvd_pow 2 huv) (ZMod (2 ^ u)))) s at hh
  rw [cyclicPushforward_cyclicAffineProductLaw] at hh
  exact hh

theorem dyadic_product_sum_mass_project {A B C : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) (s : ℕ) {u v : ℕ} (huv : u ≤ v) :
    finitePushforward (fun x : ZMod (2 ^ v) => ‖dyadicProductSumLaw A B C s v x‖)
      (ZMod.castHom (pow_dvd_pow 2 huv) (ZMod (2 ^ u))) =
        (fun x : ZMod (2 ^ u) => ‖dyadicProductSumLaw A B C s u x‖) := by
  funext x
  rw [← norm_cyclicPushforward_of_probability (dyadic_product_sum_law_probability hA hB hC s v),
    dyadic_product_sum_law_project A B C s huv]

theorem dyadic_product_sum_entropy_mono {A B C : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) (s : ℕ) :
    Monotone (dyadicProductSumEntropy A B C s) := by
  intro u v huv
  have hh := finite_entropy_mono_projection (fun x : ZMod (2 ^ v) => ‖dyadicProductSumLaw A B C s v x‖)
    (ZMod.castHom (pow_dvd_pow 2 huv) (ZMod (2 ^ u))) (fun _ => norm_nonneg _)
  rw [dyadic_product_sum_mass_project hA hB hC s huv] at hh
  exact hh

theorem dyadic_product_sum_entropy_zero {A B C : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) (s : ℕ) :
    dyadicProductSumEntropy A B C s 0 = 0 := by
  have hz : ∀ x : ZMod (2 ^ 0), x = 0 := by
    have : Subsingleton (ZMod (2 ^ 0)) := ZMod.subsingleton_iff.mpr (by norm_num)
    exact fun x => Subsingleton.elim x 0
  have hmass := finite_complex_probability_sum_norm (dyadic_product_sum_law_probability hA hB hC s 0)
  have hvalue : ‖dyadicProductSumLaw A B C s 0 0‖ = 1 := by
    have hu : (Finset.univ : Finset (ZMod (2 ^ 0))) = {0} := by
      ext x
      simp only [Finset.mem_univ, Finset.mem_singleton, hz x]
    rw [hu, Finset.sum_singleton] at hmass
    exact hmass
  unfold dyadicProductSumEntropy finiteEntropy
  apply Finset.sum_eq_zero
  intro x hx
  change Real.negMulLog (‖dyadicProductSumLaw A B C s 0 x‖) = 0
  rw [hz x, hvalue]
  simp [Real.negMulLog_def]

theorem dyadic_product_sum_entropy_interval_gain {A B C : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) (s u L : ℕ)
    (M : ZMod (2 ^ u) → ℝ) (hM : ∀ a, 0 ≤ M a)
    (hbound : ∀ x : ZMod (2 ^ (u + L)), ‖dyadicProductSumLaw A B C s (u + L) x‖ ≤
      M ((ZMod.castHom (pow_dvd_pow 2 (show u ≤ u + L by omega)) (ZMod (2 ^ u))) x))
    (hpeak : (2 : ℝ) ^ L * (∑ a : ZMod (2 ^ u), M a) ≤ 2) :
    dyadicProductSumEntropy A B C s u + (L : ℝ) * Real.log 2 - 1 ≤
      dyadicProductSumEntropy A B C s (u + L) := by
  have hh := finite_entropy_projection_gain
    (fun x : ZMod (2 ^ (u + L)) => ‖dyadicProductSumLaw A B C s (u + L) x‖)
    (ZMod.castHom (pow_dvd_pow 2 (show u ≤ u + L by omega)) (ZMod (2 ^ u))) M
    (fun _ => norm_nonneg _) (finite_complex_probability_sum_norm
      (dyadic_product_sum_law_probability hA hB hC s (u + L)))
    (show (0 : ℝ) < (2 : ℝ) ^ L by positivity) hM hbound
    (show (2 : ℝ) ^ L * (∑ a : ZMod (2 ^ u), M a) ≤ (1 : ℝ) + 1 by linarith)
  rw [dyadic_product_sum_mass_project hA hB hC s (show u ≤ u + L by omega), Real.log_pow] at hh
  exact hh

theorem exists_dyadic_set_product_entropy_gain {g ρ β : ℝ}
    (hg : 0 < g) (hρ : 3 * ρ < g) (hβ : 0 < β) (hβ1 : β ≤ 1) (M₀ : ℕ) :
    ∃ S s : ℕ, M₀ ≤ S ∧ 0 < S ∧ 0 < s ∧ ∀ u L : ℕ, ∀ A B : Finset ℕ,
      A.Nonempty → B.Nonempty → (∀ n ∈ B, Odd n) →
      (∀ r ∈ dyadicProjection A u, ∃ a b : ℕ, a % 2 ≠ b % 2 ∧
        β ≤ natResidueMass (dyadicZoom A u r) 2 a ∧ β ≤ natResidueMass (dyadicZoom A u r) 2 b) →
      (∀ r ∈ dyadicProjection A u, ∀ l : ℕ, S < l → l ≤ L → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet (dyadicZoom A u r) x‖ ≤ (2 : ℝ) ^ (-(1 - 3 * ρ) * (l : ℝ))) →
      (∀ l : ℕ, S < l → l ≤ L → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ))) →
      dyadicProductSumEntropy A B (Finset.Ioc 0 (2 ^ S)) (2 * s) u + (L : ℝ) * Real.log 2 - 1 ≤
        dyadicProductSumEntropy A B (Finset.Ioc 0 (2 ^ S)) (2 * s) (u + L) := by
  obtain ⟨S, s, hMS, hS, hs, hpeak⟩ := exists_dyadic_set_product_peak hg hρ hβ hβ1 M₀
  refine ⟨S, s, hMS, hS, hs, ?_⟩
  intro u L A B hA hB hBodd hsplit hAmass hBmass
  obtain ⟨M, hM, hbound, hsum⟩ := hpeak u L A B hA hB hBodd hsplit hAmass hBmass
  exact dyadic_product_sum_entropy_interval_gain hA hB (Finset.nonempty_Ioc.mpr (by positivity))
    (2 * s) u L M hM hbound hsum.le

theorem cyclicUniformNatSet_bounded_apply {q : ℕ} [NeZero q] (A : Finset ℕ)
    (hA : ∀ n ∈ A, n < q) (x : ZMod q) :
    cyclicUniformNatSet A x = if x.val ∈ A then (A.card : ℂ)⁻¹ else 0 := by
  classical
  unfold cyclicUniformNatSet cyclicPushforward
  rw [Finset.sum_coe_sort A (fun n => if (n : ZMod q) = x then (A.card : ℂ)⁻¹ else 0)]
  have hsum : (∑ n ∈ A, if (n : ZMod q) = x then (A.card : ℂ)⁻¹ else 0) =
      ∑ n ∈ A, if n = x.val then (A.card : ℂ)⁻¹ else 0 := by
    apply Finset.sum_congr rfl
    intro n hn
    have heq : (n : ZMod q) = x ↔ n = x.val := by
      constructor
      · intro h
        have hh := congrArg ZMod.val h
        simpa only [ZMod.val_natCast, Nat.mod_eq_of_lt (hA n hn)] using hh
      · intro h
        rw [h, ZMod.natCast_zmod_val]
    by_cases h : n = x.val
    · simp only [if_pos h, if_pos (heq.mpr h)]
    · simp only [if_neg h, if_neg (fun hc => h (heq.mp hc))]
  rw [hsum]
  simp

theorem cyclicUniformNatSet_regular_projection {A : Finset ℕ} {T N i : ℕ}
    (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N)) (hi : i ≤ N) :
    cyclicUniformNatSet (q := 2 ^ (T * i)) A = cyclicUniformNatSet (dyadicProjection A (T * i)) := by
  funext x
  rw [cyclicUniformNatSet_bounded_apply _ (dyadic_projection_bounded A (T * i))]
  by_cases hx : x.val ∈ dyadicProjection A (T * i)
  · rw [if_pos hx, cyclicUniformNatSet_eq_residue_mass, dyadic_regular_tree_residue_mass htree hbound hi hx]
    simp only [one_div, Complex.ofReal_inv, Complex.ofReal_natCast]
  · rw [if_neg hx]
    by_contra hn
    obtain ⟨n, hnA, hnx⟩ := cyclicUniformNatSet_support A hn
    apply hx
    have hh := congrArg ZMod.val hnx
    exact Finset.mem_image.mpr ⟨n, hnA, by simpa only [ZMod.val_natCast] using hh⟩

theorem cyclicUniformNatSet_congr_reduction {Q q : ℕ} [NeZero Q] [NeZero q]
    (π : ZMod Q →+* ZMod q) {A A' : Finset ℕ}
    (hA : cyclicUniformNatSet (q := Q) A = cyclicUniformNatSet A') :
    cyclicUniformNatSet (q := q) A = cyclicUniformNatSet A' := by
  have hh := congrArg (fun f : ZMod Q → ℂ => cyclicPushforward f π) hA
  simpa only [cyclicPushforward_cyclicUniformNatSet] using hh

theorem cyclicUniformNatSet_regular_projection_lower {A : Finset ℕ} {T N i k : ℕ}
    (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N))
    (hi : i ≤ N) (hk : k ≤ T * i) :
    cyclicUniformNatSet (q := 2 ^ k) A = cyclicUniformNatSet (dyadicProjection A (T * i)) := by
  exact cyclicUniformNatSet_congr_reduction (ZMod.castHom (pow_dvd_pow 2 hk) (ZMod (2 ^ k)))
    (cyclicUniformNatSet_regular_projection htree hbound hi)

theorem cyclicAffineNatSet_eq_mul_pushforward {q : ℕ} [NeZero q] (A : Finset ℕ) (z : ℕ) :
    cyclicAffineNatSet (q := q) A 0 1 z =
      cyclicPushforward (cyclicUniformNatSet A) (fun x : ZMod q => x * (z : ZMod q)) := by
  unfold cyclicAffineNatSet cyclicUniformNatSet
  rw [cyclicPushforward_comp]
  congr 1
  funext n
  simp only [Function.comp_apply, one_mul, zero_add, Nat.cast_mul]

theorem cyclicAffineProductLaw_congr_input {q : ℕ} [NeZero q] {A A' : Finset ℕ}
    (hA : cyclicUniformNatSet (q := q) A = cyclicUniformNatSet A') (B C : Finset ℕ) :
    cyclicAffineProductLaw (q := q) A B C 0 1 = cyclicAffineProductLaw A' B C 0 1 := by
  funext x
  unfold cyclicAffineProductLaw cyclicMixture
  apply Finset.sum_congr rfl
  intro i hi
  dsimp only
  rw [cyclicAffineNatSet_eq_mul_pushforward, cyclicAffineNatSet_eq_mul_pushforward, hA]

theorem dyadic_product_sum_entropy_congr_input {A A' : Finset ℕ} {k : ℕ}
    (hA : cyclicUniformNatSet (q := 2 ^ k) A = cyclicUniformNatSet A') (B C : Finset ℕ) (s : ℕ) :
    dyadicProductSumEntropy A B C s k = dyadicProductSumEntropy A' B C s k := by
  unfold dyadicProductSumEntropy dyadicProductSumLaw
  rw [cyclicAffineProductLaw_congr_input hA B C]

theorem exists_regular_tree_product_entropy_step (T M₀ : ℕ) {g ρ : ℝ}
    (hg : 0 < g) (hρ : 3 * ρ < g) :
    ∃ S s : ℕ, M₀ ≤ S ∧ 0 < S ∧ 0 < s ∧
      ∀ (N : ℕ) (A B : Finset ℕ) (m c : ℕ → ℕ) (a b e : ℕ),
      A.Nonempty → B.Nonempty → (∀ x ∈ A, x < 2 ^ (T * N)) → (∀ n ∈ B, Odd n) →
      (∀ i : ℕ, i < N → DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i)) →
      (∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j) →
      a < b → b ≤ N → 0 < c a → DyadicAmplificationBlock A (m a) (T * b) M₀ e ρ →
      (∀ l : ℕ, S < l → l ≤ T * N → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ))) →
      dyadicProductSumEntropy A B (Finset.Ioc 0 (2 ^ S)) (2 * s) (m a) +
        ((T * b - m a : ℕ) : ℝ) * Real.log 2 - 1 ≤
          dyadicProductSumEntropy A B (Finset.Ioc 0 (2 ^ S)) (2 * s) (T * b) := by
  have hβ : (0 : ℝ) < (2 : ℝ) ^ (-(T : ℝ)) := by positivity
  have hβ1 : (2 : ℝ) ^ (-(T : ℝ)) ≤ 1 := by
    calc
      _ ≤ (2 : ℝ) ^ (0 : ℝ) := Real.rpow_le_rpow_of_exponent_le (by norm_num)
        (neg_nonpos.mpr (Nat.cast_nonneg T))
      _ = _ := by rw [Real.rpow_zero]
  obtain ⟨S, s, hMS, hS, hs, hstep⟩ := exists_dyadic_set_product_entropy_gain hg hρ hβ hβ1 M₀
  refine ⟨S, s, hMS, hS, hs, ?_⟩
  intro N A B m c a b e hA hB hbound hBodd hblocks hprofile hab hbN hca hblock hBmass
  have huv : m a ≤ T * b := hblock.start_lt.le
  have hwidth : m a + (T * b - m a) = T * b := Nat.add_sub_of_le huv
  have htree : DyadicRegularTree A T N := fun i hi => ⟨m i, c i, hblocks i hi⟩
  have hlocal := hstep (m a) (T * b - m a) (dyadicProjection A (T * b)) B (hA.image _) hB hBodd
    (fun r hr => dyadic_regular_profile_zoom_split_mass hblocks hprofile hab hbN hca
      (by simpa only [dyadic_projection_trans A huv] using hr))
    (fun r hr l hl hlL x => by
      rw [norm_cyclicUniformNatSet]
      exact dyadic_amplification_block_zoom_mass hblock
        (by simpa only [dyadic_projection_trans A huv] using hr) (by omega) (by omega) x.val)
    (fun l hl hlL => hBmass l hl (by
      have hh := Nat.mul_le_mul_left T hbN
      omega))
  rw [hwidth] at hlocal
  have hlow := dyadic_product_sum_entropy_congr_input
    (cyclicUniformNatSet_regular_projection_lower htree hbound hbN huv) B (Finset.Ioc 0 (2 ^ S)) (2 * s)
  have hhigh := dyadic_product_sum_entropy_congr_input
    (cyclicUniformNatSet_regular_projection htree hbound hbN) B (Finset.Ioc 0 (2 ^ S)) (2 * s)
  rw [← hlow, ← hhigh] at hlocal
  exact hlocal

theorem exists_regular_tree_product_entropy_amplification (T R M₀ : ℕ) (hR : 0 < R) {g ρ : ℝ}
    (hg : 0 < g) (hρ : 0 ≤ ρ) (hρg : 3 * ρ < g) :
    ∃ S s : ℕ, M₀ ≤ S ∧ 0 < S ∧ 0 < s ∧
      ∀ (N : ℕ) (A B : Finset ℕ) (m c : ℕ → ℕ) (L : List (ℕ × ℕ)) (w : ℕ) (B₀ : ℝ),
      A.Nonempty → B.Nonempty → (∀ x ∈ A, x < 2 ^ (T * N)) → (∀ n ∈ B, Odd n) →
      (∀ i : ℕ, i < N → DyadicTreeBlock (dyadicProjection A (T * (i + 1))) (T * i) T (m i) (c i)) →
      (∀ j : ℕ, j ≤ N → (dyadicProjection A (T * j)).card = 2 ^ branchPrefix c j) →
      BranchingIntervalChain c T N R (1 - 2 * ρ) 0 L w →
      (∀ p ∈ L, DyadicAmplificationBlock A (m p.1) (T * p.2) M₀
        (branchPrefix c p.2 - branchPrefix c p.1) ρ) →
      (∀ l : ℕ, S < l → l ≤ T * N → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ))) →
      B₀ ≤ ((L.map (fun p => branchPrefix c p.2 - branchPrefix c p.1)).sum : ℝ) →
      (L.length : ℝ) ≤ ρ / 2 * B₀ * Real.log 2 →
      (branchPrefix c w : ℝ) * Real.log 2 + ρ / 2 * B₀ * Real.log 2 ≤
        dyadicProductSumEntropy A B (Finset.Ioc 0 (2 ^ S)) (2 * s) (T * w) := by
  obtain ⟨S, s, hMS, hS, hs, hstep⟩ := exists_regular_tree_product_entropy_step T M₀ hg hρg
  refine ⟨S, s, hMS, hS, hs, ?_⟩
  intro N A B m c L w B₀ hA hB hbound hBodd hblocks hprofile hchain hselected hBmass hbits hloss
  have hC : (Finset.Ioc 0 (2 ^ S)).Nonempty := Finset.nonempty_Ioc.mpr (by positivity)
  have hlocal : ∀ p ∈ L,
      dyadicProductSumEntropy A B (Finset.Ioc 0 (2 ^ S)) (2 * s) (m p.1) +
        ((T * p.2 - m p.1 : ℕ) : ℝ) * Real.log 2 - 1 ≤
          dyadicProductSumEntropy A B (Finset.Ioc 0 (2 ^ S)) (2 * s) (T * p.2) := by
    intro p hp
    have hinterval := (branching_interval_chain_mem hchain p hp).2.2
    have hab : p.1 < p.2 := by have := hinterval.width; omega
    exact hstep N A B m c p.1 p.2 (branchPrefix c p.2 - branchPrefix c p.1)
      hA hB hbound hBodd hblocks hprofile hab hinterval.end_le hinterval.branching (hselected p hp) hBmass
  exact branching_interval_chain_entropy_amplification (C := 1)
    (dyadicProductSumEntropy A B (Finset.Ioc 0 (2 ^ S)) (2 * s)) hchain hR hρ
    (dyadic_product_sum_entropy_mono hA hB hC (2 * s)) (dyadic_product_sum_entropy_zero hA hB hC (2 * s))
    (fun i hi => (hblocks i hi).base_le) hselected hlocal hbits (by simpa only [one_mul] using hloss)

theorem nat_residue_mass_subset_le {D A : Finset ℕ} (hDA : D ⊆ A) (hD : D.Nonempty)
    {K : ℝ} (hsize : (A.card : ℝ) ≤ K * (D.card : ℝ)) (q r : ℕ) :
    natResidueMass D q r ≤ K * natResidueMass A q r := by
  have hA : A.Nonempty := hD.mono hDA
  have hDc : (0 : ℝ) < D.card := by exact_mod_cast Finset.card_pos.mpr hD
  have hAc : (0 : ℝ) < A.card := by exact_mod_cast Finset.card_pos.mpr hA
  have hsub : natResidueFiber D q r ⊆ natResidueFiber A q r := by
    intro n hn
    exact Finset.mem_filter.mpr ⟨hDA (Finset.mem_filter.mp hn).1, (Finset.mem_filter.mp hn).2⟩
  have hcard : ((natResidueFiber D q r).card : ℝ) ≤ (natResidueFiber A q r).card := by
    exact_mod_cast Finset.card_le_card hsub
  unfold natResidueMass
  rw [← mul_div_assoc]
  apply (div_le_div_iff₀ hDc hAc).mpr
  calc
    _ ≤ ((natResidueFiber A q r).card : ℝ) * (A.card : ℝ) := mul_le_mul_of_nonneg_right hcard hAc.le
    _ ≤ ((natResidueFiber A q r).card : ℝ) * (K * (D.card : ℝ)) :=
      mul_le_mul_of_nonneg_left hsize (Nat.cast_nonneg _)
    _ = _ := by ring

theorem exists_large_odd_translated_subset {A : Finset ℕ} (hA : A.Nonempty) :
    ∃ D : Finset ℕ, ∃ δ : ℕ, D ⊆ A ∧ D.Nonempty ∧ δ ≤ 1 ∧
      A.card ≤ 2 * D.card ∧ ∀ n ∈ D, Odd (n + δ) := by
  classical
  have hcard := Finset.card_filter_add_card_filter_not (s := A) (fun n : ℕ => Even n)
  have hApos := Finset.card_pos.mpr hA
  by_cases heven : A.card ≤ 2 * (A.filter (fun n => Even n)).card
  · refine ⟨A.filter (fun n => Even n), 1, Finset.filter_subset _ _, ?_, le_rfl, heven, ?_⟩
    · exact Finset.card_pos.mp (by omega)
    · intro n hn
      have hn0 := Nat.mod_eq_zero_of_dvd (Finset.mem_filter.mp hn).2.two_dvd
      exact Nat.odd_iff.mpr (by omega)
  · refine ⟨A.filter (fun n => ¬Even n), 0, Finset.filter_subset _ _, ?_, by omega, by omega, ?_⟩
    · exact Finset.card_pos.mp (by omega)
    · intro n hn
      simpa only [Nat.add_zero] using Nat.not_even_iff_odd.mp (Finset.mem_filter.mp hn).2

theorem norm_cyclicUniformNatSet_translate_subset_le {q : ℕ} [NeZero q] {D A : Finset ℕ}
    (hDA : D ⊆ A) (hD : D.Nonempty) (hsize : A.card ≤ 2 * D.card) (δ : ℕ)
    {M : ℝ} (hM : ∀ x : ZMod q, ‖cyclicUniformNatSet A x‖ ≤ M) (x : ZMod q) :
    ‖cyclicUniformNatSet (natTranslate D δ) x‖ ≤ 2 * M := by
  rw [norm_cyclicUniformNatSet, nat_translate_residue_mass]
  have hh := nat_residue_mass_subset_le hDA hD
    (show (A.card : ℝ) ≤ (2 : ℝ) * (D.card : ℝ) by exact_mod_cast hsize)
    q ((x.val : ZMod q) - (δ : ZMod q)).val
  rw [← norm_cyclicUniformNatSet A ((x.val : ZMod q) - (δ : ZMod q))] at hh
  exact hh.trans (mul_le_mul_of_nonneg_left (hM _) (by norm_num))

theorem two_mul_dyadic_decay_le {a b : ℝ} {l : ℕ}
    (hmargin : 1 ≤ (a - b) * (l : ℝ)) :
    2 * (2 : ℝ) ^ (-a * (l : ℝ)) ≤ (2 : ℝ) ^ (-b * (l : ℝ)) := by
  calc
    _ = (2 : ℝ) ^ ((1 : ℝ) + (-a * (l : ℝ))) := by
      rw [Real.rpow_add (by norm_num), Real.rpow_one]
    _ ≤ _ := Real.rpow_le_rpow_of_exponent_le (by norm_num) (by nlinarith)

theorem odd_translated_subset_dyadic_mass {D A : Finset ℕ} (hDA : D ⊆ A)
    (hD : D.Nonempty) (hsize : A.card ≤ 2 * D.card) (δ : ℕ) {a b : ℝ} {l : ℕ}
    (hmargin : 1 ≤ (a - b) * (l : ℝ))
    (hA : ∀ x : ZMod (2 ^ l), ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-a * (l : ℝ))) :
    ∀ x : ZMod (2 ^ l), ‖cyclicUniformNatSet (natTranslate D δ) x‖ ≤ (2 : ℝ) ^ (-b * (l : ℝ)) := by
  intro x
  exact (norm_cyclicUniformNatSet_translate_subset_le hDA hD hsize δ hA x).trans
    (two_mul_dyadic_decay_le hmargin)

def natTripleProductSet (A B C : Finset ℕ) : Finset ℕ :=
  ((A ×ˢ B) ×ˢ C).image (fun p => p.1.1 * p.1.2 * p.2)

def natProductSumSet (A B C : Finset ℕ) : ℕ → Finset ℕ
  | 0 => {0}
  | s + 1 => (natTripleProductSet A B C ×ˢ natProductSumSet A B C s).image (fun p => p.1 + p.2)

theorem nat_triple_product_set_nonempty {A B C : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) : (natTripleProductSet A B C).Nonempty :=
  ((hA.product hB).product hC).image _

theorem nat_product_sum_set_nonempty {A B C : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) (s : ℕ) :
    (natProductSumSet A B C s).Nonempty := by
  induction s with
  | zero => exact Finset.singleton_nonempty 0
  | succ s ih => exact ((nat_triple_product_set_nonempty hA hB hC).product ih).image _

theorem cyclicAffineProductLaw_support {q : ℕ} [NeZero q] (A B C : Finset ℕ)
    {x : ZMod q} (hx : cyclicAffineProductLaw A B C 0 1 x ≠ 0) :
    ∃ n ∈ natTripleProductSet A B C, (n : ZMod q) = x := by
  classical
  obtain ⟨i, hi, hterm⟩ := Finset.exists_ne_zero_of_sum_ne_zero hx
  have hF : cyclicAffineNatSet A 0 1 (i.1.val * i.2.val) x ≠ 0 := (mul_ne_zero_iff.mp hterm).2
  obtain ⟨n, hnx, hnw⟩ := cyclicPushforward_support (fun _ : A => (A.card : ℂ)⁻¹)
    (fun n : A => (((0 + 1 * n.val) * (i.1.val * i.2.val) : ℕ) : ZMod q)) hF
  refine ⟨n.val * i.1.val * i.2.val, ?_, ?_⟩
  · exact Finset.mem_image.mpr ⟨((n.val, i.1.val), i.2.val),
      Finset.mem_product.mpr ⟨Finset.mem_product.mpr ⟨n.property, i.1.property⟩, i.2.property⟩, rfl⟩
  · simpa only [one_mul, zero_add, mul_assoc] using hnx

theorem dyadic_product_sum_law_support (A B C : Finset ℕ) (s k : ℕ)
    {x : ZMod (2 ^ k)} (hx : dyadicProductSumLaw A B C s k x ≠ 0) :
    ∃ n ∈ natProductSumSet A B C s, (n : ZMod (2 ^ k)) = x := by
  classical
  induction s generalizing x with
  | zero =>
    have hx0 : x = 0 := by
      by_contra h
      exact hx (by simp [dyadicProductSumLaw, cyclicConvolutionPow, h])
    exact ⟨0, Finset.mem_singleton_self _, by simpa only [Nat.cast_zero] using hx0.symm⟩
  | succ s ih =>
    change (∑ y : ZMod (2 ^ k), cyclicAffineProductLaw A B C 0 1 y *
      dyadicProductSumLaw A B C s k (x - y)) ≠ 0 at hx
    obtain ⟨y, hy, hterm⟩ := Finset.exists_ne_zero_of_sum_ne_zero hx
    obtain ⟨hfy, hgy⟩ := mul_ne_zero_iff.mp hterm
    obtain ⟨a, ha, hay⟩ := cyclicAffineProductLaw_support A B C hfy
    obtain ⟨b, hb, hbx⟩ := ih hgy
    refine ⟨a + b, Finset.mem_image.mpr ⟨(a, b), Finset.mem_product.mpr ⟨ha, hb⟩, rfl⟩, ?_⟩
    rw [Nat.cast_add, hay, hbx]
    abel

theorem dyadic_product_sum_entropy_le_log_card {A B C : Finset ℕ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hC : C.Nonempty) (s k : ℕ) :
    dyadicProductSumEntropy A B C s k ≤
      Real.log ((dyadicProjection (natProductSumSet A B C s) k).card : ℝ) := by
  classical
  let S : Finset (ZMod (2 ^ k)) := (natProductSumSet A B C s).image (fun n : ℕ => (n : ZMod (2 ^ k)))
  have hzero : ∀ x : ZMod (2 ^ k), x ∉ S → ‖dyadicProductSumLaw A B C s k x‖ = 0 := by
    intro x hx
    apply norm_eq_zero.mpr
    by_contra hn
    obtain ⟨n, hnS, hnx⟩ := dyadic_product_sum_law_support A B C s k hn
    exact hx (Finset.mem_image.mpr ⟨n, hnS, hnx⟩)
  have hh := finite_entropy_le_log_support (fun x : ZMod (2 ^ k) => ‖dyadicProductSumLaw A B C s k x‖)
    S (fun _ => norm_nonneg _) (finite_complex_probability_sum_norm
      (dyadic_product_sum_law_probability hA hB hC s k)) hzero
  have himage : S.image ZMod.val = dyadicProjection (natProductSumSet A B C s) k := by
    simp only [S, Finset.image_image, Function.comp_def, ZMod.val_natCast, dyadicProjection]
  have hcard : S.card = (dyadicProjection (natProductSumSet A B C s) k).card := by
    rw [← himage, Finset.card_image_of_injective _ (ZMod.val_injective _)]
  rw [hcard] at hh
  exact hh

theorem exists_regular_tree_product_growth (T R : ℕ) {γ δ ρ g : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hρ : 0 < ρ) (hρδ : ρ ≤ δ / 4) (hρR : 1 ≤ ρ * (R : ℝ))
    (hg : 0 < g) (hρg : 3 * ρ < g)
    (hbudget : 1 ≤ (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (R : ℝ)) :
    ∃ S s : ℕ, 2 * (T * R) ≤ S ∧ 0 < S ∧ 0 < s ∧ ∀ (N : ℕ) (A B : Finset ℕ),
      A.Nonempty → B.Nonempty → (∀ n ∈ B, Odd n) →
      DyadicRegularTree A T N → (∀ x ∈ A, x < 2 ^ (T * N)) →
      (∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
        ((dyadicProjection A (T * j)).card : ℝ)) →
      (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
      2 * (R : ℝ) ≤ γ * (N : ℝ) →
      (∀ l : ℕ, S < l → l ≤ T * N → ∀ x : ZMod (2 ^ l),
        ‖cyclicUniformNatSet B x‖ ≤ (2 : ℝ) ^ (-(2 * g) * (l : ℝ))) →
      ∃ w : ℕ, w ≤ N ∧
        Real.log ((dyadicProjection A (T * w)).card : ℝ) +
          ρ / 2 * (γ * δ / 2 * (T : ℝ) * (N : ℝ)) * Real.log 2 ≤
            Real.log ((dyadicProjection (natProductSumSet A B (Finset.Ioc 0 (2 ^ S)) (2 * s)) (T * w)).card : ℝ) := by
  obtain ⟨S, s, hMS, hS, hs, hamp⟩ := exists_regular_tree_product_entropy_amplification
    T R (2 * (T * R)) hR hg hρ.le hρg
  refine ⟨S, s, hMS, hS, hs, ?_⟩
  intro N A B hA hB hBodd htree hbound hprefix hsize hRN hBmass
  obtain ⟨m, c, L, w, hblocks, hprofile, hwN, hchain, hlength, hbits, hselected⟩ :=
    exists_dyadic_amplification_intervals hA hT hR hγ hδ hδ1 hρ hρδ hρR htree hbound hprefix hsize hRN
  have hlengthR : (L.length : ℝ) * (R : ℝ) ≤ N := by exact_mod_cast hlength
  have hcoef : 0 ≤ ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2 := by
    have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num)
    positivity
  have hloss : (L.length : ℝ) ≤ ρ / 2 * (γ * δ / 2 * (T : ℝ) * (N : ℝ)) * Real.log 2 := by
    calc
      _ = (L.length : ℝ) * 1 := (mul_one _).symm
      _ ≤ (L.length : ℝ) * ((ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (R : ℝ)) :=
        mul_le_mul_of_nonneg_left hbudget (Nat.cast_nonneg _)
      _ = (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * ((L.length : ℝ) * (R : ℝ)) := by ring
      _ ≤ (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (N : ℝ) :=
        mul_le_mul_of_nonneg_left hlengthR hcoef
      _ = _ := by ring
  have hgain := hamp N A B m c L w (γ * δ / 2 * (T : ℝ) * (N : ℝ))
    hA hB hbound hBodd hblocks hprofile hchain hselected hBmass hbits hloss
  have hlogP : Real.log ((dyadicProjection A (T * w)).card : ℝ) =
      (branchPrefix c w : ℝ) * Real.log 2 := by
    rw [hprofile w hwN, Nat.cast_pow, Nat.cast_ofNat, Real.log_pow]
  refine ⟨w, hwN, ?_⟩
  rw [hlogP]
  exact hgain.trans (dyadic_product_sum_entropy_le_log_card hA hB
    (Finset.nonempty_Ioc.mpr (by positivity)) (2 * s) (T * w))

theorem odd_translated_subset_regular_mass {T R N S l : ℕ} {γ ρ g : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hg : 0 < g) (hγg : 8 * g ≤ γ)
    (hρg : 3 * ρ < g) (hρR : 1 ≤ ρ * (R : ℝ)) (hS : 2 * (T * R) ≤ S)
    {A D : Finset ℕ} (hDA : D ⊆ A) (hD : D.Nonempty) (hsize : A.card ≤ 2 * D.card) (τ : ℕ)
    (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N))
    (hprefix : ∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
      ((dyadicProjection A (T * j)).card : ℝ)) (hl : S < l) (hlN : l ≤ T * N) :
    ∀ x : ZMod (2 ^ l), ‖cyclicUniformNatSet (natTranslate D τ) x‖ ≤
      (2 : ℝ) ^ (-(2 * g) * (l : ℝ)) := by
  have hTR : T ≤ T * R := by simpa only [Nat.mul_one] using Nat.mul_le_mul_left T (show 1 ≤ R by omega)
  have hRT : R ≤ T * R := by simpa only [Nat.one_mul] using Nat.mul_le_mul_right R (show 1 ≤ T by omega)
  have hmin : 2 * T ≤ l := by omega
  have hRl : (R : ℝ) ≤ l := by exact_mod_cast (show R ≤ l by omega)
  have hRpos : (0 : ℝ) < R := by exact_mod_cast hR
  have hgap : 0 ≤ γ / 2 - 2 * g := by linarith
  have hmarginR : 1 ≤ (γ / 2 - 2 * g) * (R : ℝ) := by
    have hh := mul_le_mul_of_nonneg_right hγg hRpos.le
    have hh' := mul_lt_mul_of_pos_right hρg hRpos
    nlinarith
  apply odd_translated_subset_dyadic_mass hDA hD hsize τ
    (hmarginR.trans (mul_le_mul_of_nonneg_left hRl hgap))
  intro x
  rw [norm_cyclicUniformNatSet]
  exact dyadic_regular_tree_mass_le_at_all_levels hT (by linarith : 0 ≤ γ)
    htree hbound hprefix hmin hlN x.val

theorem exists_regular_tree_translated_product_growth (T R : ℕ) {γ δ ρ g : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hρ : 0 < ρ) (hρδ : ρ ≤ δ / 4) (hρR : 1 ≤ ρ * (R : ℝ))
    (hg : 0 < g) (hγg : 8 * g ≤ γ) (hρg : 3 * ρ < g)
    (hbudget : 1 ≤ (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (R : ℝ)) :
    ∃ S s : ℕ, 2 * (T * R) ≤ S ∧ 0 < S ∧ 0 < s ∧ ∀ (N : ℕ) (A : Finset ℕ),
      A.Nonempty → DyadicRegularTree A T N → (∀ x ∈ A, x < 2 ^ (T * N)) →
      (∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
        ((dyadicProjection A (T * j)).card : ℝ)) →
      (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
      2 * (R : ℝ) ≤ γ * (N : ℝ) →
      ∃ D : Finset ℕ, ∃ τ w : ℕ, D ⊆ A ∧ D.Nonempty ∧ τ ≤ 1 ∧ A.card ≤ 2 * D.card ∧ w ≤ N ∧
        Real.log ((dyadicProjection A (T * w)).card : ℝ) +
          ρ / 2 * (γ * δ / 2 * (T : ℝ) * (N : ℝ)) * Real.log 2 ≤
            Real.log ((dyadicProjection
              (natProductSumSet A (natTranslate D τ) (Finset.Ioc 0 (2 ^ S)) (2 * s)) (T * w)).card : ℝ) := by
  obtain ⟨S, s, hMS, hS, hs, hgrowth⟩ := exists_regular_tree_product_growth T R
    hT hR hγ hδ hδ1 hρ hρδ hρR hg hρg hbudget
  refine ⟨S, s, hMS, hS, hs, ?_⟩
  intro N A hA htree hbound hprefix hsize hRN
  obtain ⟨D, τ, hDA, hD, hτ, hDsize, hDodd⟩ := exists_large_odd_translated_subset hA
  have hBodd : ∀ n ∈ natTranslate D τ, Odd n := by
    intro n hn
    obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp hn
    exact hDodd d hd
  obtain ⟨w, hwN, hgain⟩ := hgrowth N A (natTranslate D τ) hA (nat_translate_nonempty hD τ)
    hBodd htree hbound hprefix hsize hRN
    (fun l hl hlN => odd_translated_subset_regular_mass hT hR hg hγg hρg hρR hMS
      hDA hD hDsize τ htree hbound hprefix hl hlN)
  exact ⟨D, τ, w, hDA, hD, hτ, hDsize, hwN, hgain⟩

def natBoundedSums (A : Finset ℕ) : ℕ → Finset ℕ
  | 0 => {0}
  | k + 1 => (insert 0 A ×ˢ natBoundedSums A k).image (fun p => p.1 + p.2)

def natLinearQuadraticSet (A : Finset ℕ) : Finset ℕ := A ∪ (A ×ˢ A).image (fun p => p.1 * p.2)

theorem zero_mem_nat_bounded_sums (A : Finset ℕ) (k : ℕ) : 0 ∈ natBoundedSums A k := by
  induction k with
  | zero => exact Finset.mem_singleton_self _
  | succ k ih =>
    exact Finset.mem_image.mpr ⟨(0, 0), Finset.mem_product.mpr ⟨Finset.mem_insert_self _ _, ih⟩, by simp⟩

theorem nat_bounded_sums_mono (A : Finset ℕ) : Monotone (natBoundedSums A) := by
  apply monotone_nat_of_le_succ
  intro k n hn
  exact Finset.mem_image.mpr ⟨(0, n), Finset.mem_product.mpr ⟨Finset.mem_insert_self _ _, hn⟩, by simp⟩

theorem mem_nat_bounded_sums_one {A : Finset ℕ} {n : ℕ} (hn : n ∈ A) : n ∈ natBoundedSums A 1 := by
  exact Finset.mem_image.mpr ⟨(n, 0), Finset.mem_product.mpr
    ⟨Finset.mem_insert_of_mem hn, Finset.mem_singleton_self _⟩, by simp⟩

theorem add_mem_nat_bounded_sums {A : Finset ℕ} {k l a b : ℕ}
    (ha : a ∈ natBoundedSums A k) (hb : b ∈ natBoundedSums A l) :
    a + b ∈ natBoundedSums A (k + l) := by
  induction k generalizing a with
  | zero =>
    have ha0 : a = 0 := Finset.mem_singleton.mp ha
    simpa only [ha0, Nat.zero_add] using hb
  | succ k ih =>
    obtain ⟨⟨x, y⟩, hxy, rfl⟩ := Finset.mem_image.mp ha
    obtain ⟨hx, hy⟩ := Finset.mem_product.mp hxy
    have hi := ih hy
    have hkl : k + 1 + l = (k + l) + 1 := by omega
    rw [hkl]
    exact Finset.mem_image.mpr ⟨(x, y + b), Finset.mem_product.mpr ⟨hx, hi⟩, by simp [Nat.add_assoc]⟩

theorem mul_mem_nat_bounded_sums {A : Finset ℕ} {k a : ℕ}
    (ha : a ∈ natBoundedSums A k) (c : ℕ) : a * c ∈ natBoundedSums A (k * c) := by
  induction c with
  | zero => simpa only [Nat.mul_zero] using zero_mem_nat_bounded_sums A 0
  | succ c ih =>
    simpa only [Nat.mul_succ] using add_mem_nat_bounded_sums ih ha

theorem translated_product_mem_bounded_sums {A D : Finset ℕ} (hDA : D ⊆ A) {τ : ℕ} (hτ : τ ≤ 1)
    {a b c M : ℕ} (ha : a ∈ A) (hb : b ∈ natTranslate D τ) (hc : c ≤ M) :
    a * b * c ∈ natBoundedSums (natLinearQuadraticSet A) (2 * M) := by
  obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp hb
  have had : a * d ∈ natBoundedSums (natLinearQuadraticSet A) 1 :=
    mem_nat_bounded_sums_one (Finset.mem_union_right A
      (Finset.mem_image.mpr ⟨(a, d), Finset.mem_product.mpr ⟨ha, hDA hd⟩, rfl⟩))
  have ha' : a ∈ natBoundedSums (natLinearQuadraticSet A) 1 :=
    mem_nat_bounded_sums_one (Finset.mem_union_left _ ha)
  have haτ : a * τ ∈ natBoundedSums (natLinearQuadraticSet A) 1 := by
    have hh := mul_mem_nat_bounded_sums ha' τ
    exact nat_bounded_sums_mono _ (by simpa only [Nat.one_mul] using hτ) hh
  have hbase : a * (d + τ) ∈ natBoundedSums (natLinearQuadraticSet A) 2 := by
    simpa only [Nat.mul_add] using add_mem_nat_bounded_sums had haτ
  exact nat_bounded_sums_mono _ (Nat.mul_le_mul_left 2 hc) (mul_mem_nat_bounded_sums hbase c)

theorem nat_product_sum_set_subset_bounded_sums (A B C E : Finset ℕ) (K : ℕ)
    (hproducts : natTripleProductSet A B C ⊆ natBoundedSums E K) (s : ℕ) :
    natProductSumSet A B C s ⊆ natBoundedSums E (K * s) := by
  induction s with
  | zero =>
    intro n hn
    have hn0 : n = 0 := Finset.mem_singleton.mp hn
    simpa only [hn0, Nat.mul_zero] using zero_mem_nat_bounded_sums E 0
  | succ s ih =>
    intro n hn
    obtain ⟨⟨a, b⟩, hab, rfl⟩ := Finset.mem_image.mp hn
    obtain ⟨ha, hb⟩ := Finset.mem_product.mp hab
    have hh := add_mem_nat_bounded_sums (hproducts ha) (ih hb)
    have hindex : K * (s + 1) = K + K * s := by ring
    rw [hindex]
    exact hh

theorem translated_product_sum_subset_bounded_sums {A D : Finset ℕ}
    (hDA : D ⊆ A) {τ : ℕ} (hτ : τ ≤ 1) (M s : ℕ) :
    natProductSumSet A (natTranslate D τ) (Finset.Ioc 0 M) s ⊆
      natBoundedSums (natLinearQuadraticSet A) (2 * M * s) := by
  apply nat_product_sum_set_subset_bounded_sums
  intro n hn
  obtain ⟨⟨⟨a, b⟩, c⟩, habc, rfl⟩ := Finset.mem_image.mp hn
  obtain ⟨hab, hc⟩ := Finset.mem_product.mp habc
  obtain ⟨ha, hb⟩ := Finset.mem_product.mp hab
  exact translated_product_mem_bounded_sums hDA hτ ha hb (Finset.mem_Ioc.mp hc).2

theorem log_gain_implies_dyadic_growth {x y t : ℝ} (hx : 0 < x) (hy : 0 < y)
    (hgain : Real.log x + t * Real.log 2 ≤ Real.log y) : (2 : ℝ) ^ t * x ≤ y := by
  have hh := Real.exp_le_exp.mpr hgain
  rw [Real.exp_add, Real.exp_log hx, Real.exp_log hy] at hh
  calc
    _ = x * Real.exp (t * Real.log 2) := by
      rw [Real.rpow_def_of_pos (by norm_num), mul_comm t (Real.log 2)]
      ring
    _ ≤ _ := hh

theorem exists_regular_tree_bounded_sum_projected_growth (T R : ℕ) {γ δ ρ g : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hρ : 0 < ρ) (hρδ : ρ ≤ δ / 4) (hρR : 1 ≤ ρ * (R : ℝ))
    (hg : 0 < g) (hγg : 8 * g ≤ γ) (hρg : 3 * ρ < g)
    (hbudget : 1 ≤ (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (R : ℝ)) :
    ∃ K : ℕ, 0 < K ∧ ∀ (N : ℕ) (A : Finset ℕ),
      A.Nonempty → DyadicRegularTree A T N → (∀ x ∈ A, x < 2 ^ (T * N)) →
      (∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
        ((dyadicProjection A (T * j)).card : ℝ)) →
      (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
      2 * (R : ℝ) ≤ γ * (N : ℝ) →
      ∃ w : ℕ, w ≤ N ∧ (2 : ℝ) ^ (ρ / 2 * (γ * δ / 2 * (T : ℝ) * (N : ℝ))) *
        ((dyadicProjection A (T * w)).card : ℝ) ≤
          ((dyadicProjection (natBoundedSums (natLinearQuadraticSet A) K) (T * w)).card : ℝ) := by
  obtain ⟨S, s, hMS, hS, hs, hgrowth⟩ := exists_regular_tree_translated_product_growth T R
    hT hR hγ hδ hδ1 hρ hρδ hρR hg hγg hρg hbudget
  let K := 2 * 2 ^ S * (2 * s)
  refine ⟨K, by dsimp [K]; positivity, ?_⟩
  intro N A hA htree hbound hprefix hsize hRN
  obtain ⟨D, τ, w, hDA, hD, hτ, hDsize, hwN, hgain⟩ :=
    hgrowth N A hA htree hbound hprefix hsize hRN
  have hsub := translated_product_sum_subset_bounded_sums hDA hτ (2 ^ S) (2 * s)
  have hcard : ((dyadicProjection
      (natProductSumSet A (natTranslate D τ) (Finset.Ioc 0 (2 ^ S)) (2 * s)) (T * w)).card : ℝ) ≤
      ((dyadicProjection (natBoundedSums (natLinearQuadraticSet A) K) (T * w)).card : ℝ) := by
    exact_mod_cast Finset.card_le_card (Finset.image_subset_image hsub)
  have hprod : (0 : ℝ) < (dyadicProjection
      (natProductSumSet A (natTranslate D τ) (Finset.Ioc 0 (2 ^ S)) (2 * s)) (T * w)).card := by
    exact_mod_cast Finset.card_pos.mpr ((nat_product_sum_set_nonempty hA (nat_translate_nonempty hD τ)
      (Finset.nonempty_Ioc.mpr (by positivity)) (2 * s)).image (fun n => n % 2 ^ (T * w)))
  have hAP : (0 : ℝ) < (dyadicProjection A (T * w)).card := by
    exact_mod_cast Finset.card_pos.mpr (hA.image (fun n => n % 2 ^ (T * w)))
  exact ⟨w, hwN, log_gain_implies_dyadic_growth hAP (hprod.trans_le hcard)
    (hgain.trans (Real.log_le_log hprod hcard))⟩

theorem regular_tree_bounded_sum_growth_of_projected {A : Finset ℕ} {T N w K : ℕ}
    (hA : A.Nonempty) (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N))
    (hwN : w ≤ N) (hK : 0 < K) {Λ : ℝ}
    (hprojected : Λ * ((dyadicProjection A (T * w)).card : ℝ) ≤
      ((dyadicProjection (natBoundedSums (natLinearQuadraticSet A) K) (T * w)).card : ℝ)) :
    Λ * (A.card : ℝ) ≤ ((dyadicProjection
      (natBoundedSums (natLinearQuadraticSet A) (2 * K)) (T * N)).card : ℝ) := by
  let G := natBoundedSums (natLinearQuadraticSet A) K
  have hAG : A ⊆ G := by
    intro a ha
    exact nat_bounded_sums_mono _ (show 1 ≤ K by omega)
      (mem_nat_bounded_sums_one (Finset.mem_union_left _ ha))
  have hraw := dyadic_regular_tree_modular_growth_bound hAG hA htree hbound hwN
  have hsub : ((G ×ˢ G).image (fun p => (p.1 + p.2) % 2 ^ (T * N))) ⊆
      dyadicProjection (natBoundedSums (natLinearQuadraticSet A) (2 * K)) (T * N) := by
    intro n hn
    obtain ⟨⟨a, b⟩, hab, rfl⟩ := Finset.mem_image.mp hn
    obtain ⟨ha, hb⟩ := Finset.mem_product.mp hab
    refine Finset.mem_image.mpr ⟨a + b, ?_, rfl⟩
    simpa only [two_mul] using add_mem_nat_bounded_sums ha hb
  have hrawR : ((dyadicProjection G (T * w)).card : ℝ) * (A.card : ℝ) ≤
      ((dyadicProjection A (T * w)).card : ℝ) *
        ((dyadicProjection (natBoundedSums (natLinearQuadraticSet A) (2 * K)) (T * N)).card : ℝ) := by
    exact_mod_cast hraw.trans (Nat.mul_le_mul_left _ (Finset.card_le_card hsub))
  have hP : (0 : ℝ) < (dyadicProjection A (T * w)).card := by
    exact_mod_cast Finset.card_pos.mpr (hA.image (fun n => n % 2 ^ (T * w)))
  apply (mul_le_mul_iff_of_pos_left hP).mp
  calc
    _ = (Λ * ((dyadicProjection A (T * w)).card : ℝ)) * (A.card : ℝ) := by ring
    _ ≤ ((dyadicProjection G (T * w)).card : ℝ) * (A.card : ℝ) :=
      mul_le_mul_of_nonneg_right hprojected (Nat.cast_nonneg _)
    _ ≤ _ := hrawR

theorem exists_regular_tree_bounded_sum_growth (T R : ℕ) {γ δ ρ g : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hρ : 0 < ρ) (hρδ : ρ ≤ δ / 4) (hρR : 1 ≤ ρ * (R : ℝ))
    (hg : 0 < g) (hγg : 8 * g ≤ γ) (hρg : 3 * ρ < g)
    (hbudget : 1 ≤ (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (R : ℝ)) :
    ∃ K : ℕ, 0 < K ∧ ∀ (N : ℕ) (A : Finset ℕ),
      A.Nonempty → DyadicRegularTree A T N → (∀ x ∈ A, x < 2 ^ (T * N)) →
      (∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
        ((dyadicProjection A (T * j)).card : ℝ)) →
      (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
      2 * (R : ℝ) ≤ γ * (N : ℝ) →
      (2 : ℝ) ^ (ρ / 2 * (γ * δ / 2 * (T : ℝ) * (N : ℝ))) * (A.card : ℝ) ≤
        ((dyadicProjection (natBoundedSums (natLinearQuadraticSet A) K) (T * N)).card : ℝ) := by
  obtain ⟨K, hK, hgrowth⟩ := exists_regular_tree_bounded_sum_projected_growth T R
    hT hR hγ hδ hδ1 hρ hρδ hρR hg hγg hρg hbudget
  refine ⟨2 * K, by positivity, ?_⟩
  intro N A hA htree hbound hprefix hsize hRN
  obtain ⟨w, hwN, hprojected⟩ := hgrowth N A hA htree hbound hprefix hsize hRN
  exact regular_tree_bounded_sum_growth_of_projected hA htree hbound hwN hK hprojected

theorem exists_uniform_regular_tree_amplification {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ η : ℝ, 0 < η ∧ ∀ T : ℕ, 0 < T → ∃ K N₀ : ℕ, 0 < K ∧
      ∀ N : ℕ, N₀ ≤ N → ∀ A : Finset ℕ, A.Nonempty → DyadicRegularTree A T N →
      (∀ x ∈ A, x < 2 ^ (T * N)) →
      (∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
        ((dyadicProjection A (T * j)).card : ℝ)) →
      (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
      (2 : ℝ) ^ (η * (T : ℝ) * (N : ℝ)) * (A.card : ℝ) ≤
        ((dyadicProjection (natBoundedSums (natLinearQuadraticSet A) K) (T * N)).card : ℝ) := by
  let g := γ / 16
  let ρ := min (δ / 8) (γ / 128)
  let η := ρ / 2 * (γ * δ / 2)
  have hg : 0 < g := by dsimp [g]; positivity
  have hρ : 0 < ρ := lt_min (by positivity) (by positivity)
  have hρδ8 : ρ ≤ δ / 8 := min_le_left _ _
  have hργ128 : ρ ≤ γ / 128 := min_le_right _ _
  have hρδ : ρ ≤ δ / 4 := by linarith
  have hγg : 8 * g ≤ γ := by dsimp [g]; linarith
  have hρg : 3 * ρ < g := by dsimp [g]; linarith
  have hη : 0 < η := by dsimp [η]; positivity
  refine ⟨η, hη, ?_⟩
  intro T hT
  have hTr : (0 : ℝ) < T := by exact_mod_cast hT
  have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num)
  have hcoef : 0 < η * (T : ℝ) * Real.log 2 := by positivity
  obtain ⟨R, hRbound⟩ := exists_nat_ge (max (1 : ℝ) (max (1 / ρ) (1 / (η * (T : ℝ) * Real.log 2))))
  have hR1 : (1 : ℝ) ≤ R := (le_max_left _ _).trans hRbound
  have hR : 0 < R := by
    have hh : 1 ≤ R := by exact_mod_cast hR1
    omega
  have hρrecip : 1 / ρ ≤ (R : ℝ) := (le_max_left _ _).trans ((le_max_right _ _).trans hRbound)
  have hcoefrecip : 1 / (η * (T : ℝ) * Real.log 2) ≤ (R : ℝ) :=
    (le_max_right _ _).trans ((le_max_right _ _).trans hRbound)
  have hρR : 1 ≤ ρ * (R : ℝ) := by
    have hh := (div_le_iff₀ hρ).mp hρrecip
    nlinarith
  have hcoefR : 1 ≤ (η * (T : ℝ) * Real.log 2) * (R : ℝ) := by
    have hh := (div_le_iff₀ hcoef).mp hcoefrecip
    nlinarith
  have hbudget : 1 ≤ (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (R : ℝ) := by
    calc
      _ ≤ (η * (T : ℝ) * Real.log 2) * (R : ℝ) := hcoefR
      _ = _ := by dsimp [η]; ring
  obtain ⟨K, hK, hgrowth⟩ := exists_regular_tree_bounded_sum_growth T R
    hT hR hγ hδ hδ1 hρ hρδ hρR hg hγg hρg hbudget
  obtain ⟨N₀, hN₀⟩ := exists_nat_ge (2 * (R : ℝ) / γ)
  refine ⟨K, N₀, hK, ?_⟩
  intro N hN A hA htree hbound hprefix hsize
  have hRN : 2 * (R : ℝ) ≤ γ * (N : ℝ) := by
    have hh := (div_le_iff₀ hγ).mp (hN₀.trans (show (N₀ : ℝ) ≤ N by exact_mod_cast hN))
    nlinarith
  have hh := hgrowth N A hA htree hbound hprefix hsize hRN
  have hexponent : ρ / 2 * (γ * δ / 2 * (T : ℝ) * (N : ℝ)) = η * (T : ℝ) * (N : ℝ) := by
    dsimp [η]
    ring
  rwa [hexponent] at hh

theorem dyadic_projection_card_le (A : Finset ℕ) (k : ℕ) :
    (dyadicProjection A k).card ≤ 2 ^ k := by
  calc
    _ ≤ (Finset.range (2 ^ k)).card := Finset.card_le_card (by
      intro x hx
      exact Finset.mem_range.mpr (dyadic_projection_bounded A k x hx))
    _ = _ := Finset.card_range _

theorem nat_factor_of_dyadic_residue {n r T v u : ℕ} (hv : v < T)
    (hr : r = 2 ^ v * u) (hu : Odd u) (hn : n % 2 ^ T = r) :
    ∃ b : ℕ, Odd b ∧ n = 2 ^ v * b := by
  have hpow : 2 ^ T = 2 ^ v * 2 ^ (T - v) := by
    rw [← pow_add, Nat.add_sub_of_le hv.le]
  have heven : Even (2 ^ (T - v) * (n / 2 ^ T)) := by
    apply even_iff_two_dvd.mpr
    exact (pow_dvd_pow 2 (show 1 ≤ T - v by omega)).trans (dvd_mul_right _ _)
  refine ⟨u + 2 ^ (T - v) * (n / 2 ^ T), hu.add_even heven, ?_⟩
  calc
    n = n % 2 ^ T + 2 ^ T * (n / 2 ^ T) := (Nat.mod_add_div _ _).symm
    _ = _ := by rw [hn, hr, hpow]; ring

theorem exists_regular_tree_odd_divided_subset {A : Finset ℕ} {T N : ℕ}
    (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N))
    (hN : 1 ≤ N) (hsize : 1 < (dyadicProjection A T).card) :
    ∃ v : ℕ, v < T ∧ ∃ B : Finset ℕ, B.Nonempty ∧ (∀ b ∈ B, Odd b) ∧
      (∀ b ∈ B, 2 ^ v * b ∈ A) ∧ A.card ≤ 2 ^ T * B.card := by
  obtain ⟨r, hr, hr0⟩ : ∃ r ∈ dyadicProjection A T, r ≠ 0 := by
    by_contra h
    push Not at h
    have hsub : dyadicProjection A T ⊆ {0} := by
      intro x hx
      exact Finset.mem_singleton.mpr (h x hx)
    have hh := Finset.card_le_card hsub
    simp only [Finset.card_singleton] at hh
    omega
  obtain ⟨v, u, hu, hru⟩ := Nat.exists_eq_two_pow_mul_odd hr0
  have hv : v < T := by
    have hrbound := dyadic_projection_bounded A T r hr
    have hu0 : 0 < u := by obtain ⟨t, ht⟩ := hu; omega
    have hvr : 2 ^ v ≤ r := by rw [hru]; nlinarith [pow_pos (by decide : 0 < 2) v]
    by_contra h
    have hp := Nat.pow_le_pow_right (by decide : 0 < 2) (show T ≤ v by omega)
    omega
  let D := A.filter (fun x => x % 2 ^ T = r)
  let B := D.image (fun x => x / 2 ^ v)
  have hfactor : ∀ n ∈ D, ∃ b : ℕ, Odd b ∧ n = 2 ^ v * b := by
    intro n hn
    exact nat_factor_of_dyadic_residue hv hru hu (Finset.mem_filter.mp hn).2
  have hD : D.Nonempty := by
    obtain ⟨a, ha, har⟩ := Finset.mem_image.mp hr
    exact ⟨a, Finset.mem_filter.mpr ⟨ha, har⟩⟩
  have hcard : B.card = D.card := by
    apply Finset.card_image_of_injOn
    intro x hx y hy hxy
    obtain ⟨b, hb, rfl⟩ := hfactor x hx
    obtain ⟨c, hc, rfl⟩ := hfactor y hy
    simp only [Nat.mul_div_right _ (by positivity : 0 < 2 ^ v)] at hxy
    rw [hxy]
  refine ⟨v, hv, B, hD.image _, ?_, ?_, ?_⟩
  · intro b hb
    obtain ⟨n, hn, rfl⟩ := Finset.mem_image.mp hb
    obtain ⟨c, hc, rfl⟩ := hfactor n hn
    simpa only [Nat.mul_div_right _ (by positivity : 0 < 2 ^ v)] using hc
  · intro b hb
    obtain ⟨n, hn, rfl⟩ := Finset.mem_image.mp hb
    obtain ⟨c, hc, hnc⟩ := hfactor n hn
    have heq : 2 ^ v * (n / 2 ^ v) = n := by
      rw [hnc, Nat.mul_div_right _ (by positivity : 0 < 2 ^ v)]
    rw [heq]
    exact (Finset.mem_filter.mp hn).1
  · obtain ⟨c, hc, hfiber⟩ := dyadic_regular_tree_uniform_fibers htree N le_rfl 1 hN
    rw [dyadic_projection_self hbound] at hfiber
    simp only [Nat.mul_one] at hfiber
    have hDcard : D.card = c := hfiber r hr
    have hAcard : A.card = (dyadicProjection A T).card * c := by
      rw [Finset.card_eq_sum_card_image (fun x => x % 2 ^ T) A]
      calc
        _ = ∑ _r ∈ dyadicProjection A T, c := Finset.sum_congr rfl hfiber
        _ = _ := by simp
    rw [hcard, hDcard, hAcard]
    exact Nat.mul_le_mul_right _ (dyadic_projection_card_le A T)

theorem nat_residue_mass_scaled_subset_le {A B : Finset ℕ} {d : ℕ} (hd : 0 < d)
    (hBA : ∀ b ∈ B, d * b ∈ A) {L : ℝ} (hB : B.Nonempty)
    (hsize : (A.card : ℝ) ≤ L * (B.card : ℝ)) (q r : ℕ) :
    natResidueMass B q r ≤ L * natResidueMass A q (d * r) := by
  have hA : A.Nonempty := by obtain ⟨b, hb⟩ := hB; exact ⟨d * b, hBA b hb⟩
  have hmap : Set.MapsTo (fun b : ℕ => d * b) (natResidueFiber B q r)
      (natResidueFiber A q (d * r)) := by
    intro b hb
    obtain ⟨hbB, hbr⟩ := Finset.mem_filter.mp hb
    exact Finset.mem_filter.mpr ⟨hBA b hbB, (Nat.ModEq.refl d).mul hbr⟩
  have hinj : Function.Injective (fun b : ℕ => d * b) := fun _ _ h => Nat.mul_left_cancel hd h
  have hfiber : ((natResidueFiber B q r).card : ℝ) ≤
      ((natResidueFiber A q (d * r)).card : ℝ) := by
    exact_mod_cast Finset.card_le_card_of_injOn _ hmap hinj.injOn
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast Finset.card_pos.mpr hA
  have hBp : (0 : ℝ) < B.card := by exact_mod_cast Finset.card_pos.mpr hB
  unfold natResidueMass
  rw [← mul_div_assoc, div_le_div_iff₀ hBp hAp]
  calc
    _ ≤ ((natResidueFiber A q (d * r)).card : ℝ) * (A.card : ℝ) :=
      mul_le_mul_of_nonneg_right hfiber hAp.le
    _ ≤ ((natResidueFiber A q (d * r)).card : ℝ) * (L * (B.card : ℝ)) :=
      mul_le_mul_of_nonneg_left hsize (Nat.cast_nonneg _)
    _ = _ := by ring

theorem dyadic_power_times_decay_le {T : ℕ} {a b l : ℝ}
    (hmargin : (T : ℝ) ≤ (a - b) * l) :
    (2 : ℝ) ^ T * (2 : ℝ) ^ (-a * l) ≤ (2 : ℝ) ^ (-b * l) := by
  rw [← Real.rpow_natCast, ← Real.rpow_add (by norm_num)]
  exact Real.rpow_le_rpow_of_exponent_le (by norm_num) (by linarith)

theorem odd_divided_subset_regular_mass {T R N S l v : ℕ} {γ ρ g : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hg : 0 < g) (hγg : 8 * g ≤ γ)
    (hρg : 3 * ρ < g) (hρR : 1 ≤ ρ * (R : ℝ)) (hS : 2 * (T * R) ≤ S)
    {A B : Finset ℕ} (hB : B.Nonempty) (hBA : ∀ b ∈ B, 2 ^ v * b ∈ A)
    (hsize : A.card ≤ 2 ^ T * B.card)
    (htree : DyadicRegularTree A T N) (hbound : ∀ x ∈ A, x < 2 ^ (T * N))
    (hprefix : ∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
      ((dyadicProjection A (T * j)).card : ℝ)) (hl : S < l) (hlN : l ≤ T * N) :
    ∀ x : ZMod (2 ^ l), ‖cyclicUniformNatSet B x‖ ≤
      (2 : ℝ) ^ (-(2 * g) * (l : ℝ)) := by
  have hTR : T ≤ T * R := by simpa only [Nat.mul_one] using Nat.mul_le_mul_left T (show 1 ≤ R by omega)
  have hmin : 2 * T ≤ l := by omega
  have hTl : (T : ℝ) * (R : ℝ) ≤ l := by exact_mod_cast (show T * R ≤ l by omega)
  have hRpos : (0 : ℝ) < R := by exact_mod_cast hR
  have hTpos : (0 : ℝ) < T := by exact_mod_cast hT
  have hgap : 0 ≤ γ / 2 - 2 * g := by linarith
  have hmarginR : 1 ≤ (γ / 2 - 2 * g) * (R : ℝ) := by
    have hh := mul_le_mul_of_nonneg_right hγg hRpos.le
    have hh' := mul_lt_mul_of_pos_right hρg hRpos
    nlinarith
  have hmargin : (T : ℝ) ≤ (γ / 2 - 2 * g) * (l : ℝ) := by
    have hh := mul_le_mul_of_nonneg_left hmarginR hTpos.le
    have hh' := mul_le_mul_of_nonneg_left hTl hgap
    nlinarith
  intro x
  rw [norm_cyclicUniformNatSet]
  calc
    _ ≤ (2 : ℝ) ^ T * natResidueMass A (2 ^ l) (2 ^ v * x.val) :=
      nat_residue_mass_scaled_subset_le (by positivity) hBA hB (by exact_mod_cast hsize) _ _
    _ ≤ (2 : ℝ) ^ T * (2 : ℝ) ^ (-(γ / 2) * (l : ℝ)) :=
      mul_le_mul_of_nonneg_left (dyadic_regular_tree_mass_le_at_all_levels hT (by linarith)
        htree hbound hprefix hmin hlN _) (by positivity)
    _ ≤ _ := dyadic_power_times_decay_le hmargin

theorem zmod_card_le_gcd_mul_image {q : ℕ} [NeZero q] (S : Finset (ZMod q)) (d : ℕ) :
    S.card ≤ q.gcd d * (S.image (fun x => x * (d : ZMod q))).card := by
  rw [Finset.card_eq_sum_card_image (fun x : ZMod q => x * (d : ZMod q)) S]
  calc
    _ ≤ ∑ _y ∈ S.image (fun x => x * (d : ZMod q)), q.gcd d := by
      apply Finset.sum_le_sum
      intro y hy
      exact (Finset.card_le_card (Finset.filter_subset_filter _ (Finset.subset_univ S))).trans
        (zmod_mul_fiber_card_le d y)
    _ = _ := by simp [Nat.mul_comm]

theorem nat_modular_projection_mul_card (A : Finset ℕ) {q : ℕ} [NeZero q] (d : ℕ) :
    (A.image (fun x => x % q)).card ≤
      q.gcd d * (A.image (fun x => (d * x) % q)).card := by
  let S := A.image (fun x : ℕ => (x : ZMod q))
  have hfirst : S.card = (A.image (fun x => x % q)).card := by
    rw [← Finset.card_image_of_injective S (ZMod.val_injective q)]
    simp only [S, Finset.image_image, Function.comp_def, ZMod.val_natCast]
  have hsecond : (S.image (fun x => x * (d : ZMod q))).card =
      (A.image (fun x => (d * x) % q)).card := by
    rw [← Finset.card_image_of_injective (S.image (fun x => x * (d : ZMod q))) (ZMod.val_injective q)]
    simp only [S, Finset.image_image, Function.comp_def]
    congr 1
    apply Finset.image_congr
    intro x hx
    dsimp only
    rw [mul_comm, ← Nat.cast_mul, ZMod.val_natCast]
  have hh := zmod_card_le_gcd_mul_image S d
  rwa [hfirst, hsecond] at hh

theorem dyadic_projection_mul_card_le (A : Finset ℕ) (k d D : ℕ)
    (hgcd : (2 ^ k).gcd d ≤ D) :
    (dyadicProjection A k).card ≤ D * (dyadicProjection (A.image (fun x => d * x)) k).card := by
  have hh := nat_modular_projection_mul_card (q := 2 ^ k) A d
  have heq : A.image (fun x => d * x % 2 ^ k) = dyadicProjection (A.image (fun x => d * x)) k := by
    simp only [dyadicProjection, Finset.image_image, Function.comp_def]
  rw [heq] at hh
  exact hh.trans (Nat.mul_le_mul_right _ hgcd)

theorem dyadic_gcd_scaled_odd_le {b v T : ℕ} (hb : Odd b) (hv : v ≤ T) (k : ℕ) :
    (2 ^ k).gcd (2 ^ v * b) ≤ 2 ^ T := by
  have hcop : (2 ^ k).gcd b = 1 := by
    have hh := (ZMod.isUnit_iff_coprime b (2 ^ k)).mp (odd_natCast_isUnit_dyadic k hb)
    exact hh.symm
  rw [Nat.gcd_mul_left_right_of_gcd_eq_one hcop]
  exact (Nat.gcd_le_right _ (by positivity : 0 < 2 ^ v)).trans
    (Nat.pow_le_pow_right (by decide : 0 < 2) hv)

def natQuadraticSet (A : Finset ℕ) : Finset ℕ := (A ×ˢ A).image (fun p => p.1 * p.2)

theorem scaled_product_sum_mem_quadratic_sums {A B : Finset ℕ} {d : ℕ}
    (hBA : ∀ b ∈ B, d * b ∈ A) (M s : ℕ) :
    ∀ n ∈ natProductSumSet A B (Finset.Ioc 0 M) s,
      d * n ∈ natBoundedSums (natQuadraticSet A) (M * s) := by
  induction s with
  | zero =>
    intro n hn
    have hn0 : n = 0 := Finset.mem_singleton.mp hn
    simpa only [hn0, Nat.mul_zero] using zero_mem_nat_bounded_sums (natQuadraticSet A) 0
  | succ s ih =>
    intro n hn
    obtain ⟨⟨x, y⟩, hxy, rfl⟩ := Finset.mem_image.mp hn
    obtain ⟨hx, hy⟩ := Finset.mem_product.mp hxy
    obtain ⟨⟨⟨a, b⟩, c⟩, habc, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨hab, hc⟩ := Finset.mem_product.mp habc
    obtain ⟨ha, hb⟩ := Finset.mem_product.mp hab
    have hprod : a * (d * b) ∈ natBoundedSums (natQuadraticSet A) 1 :=
      mem_nat_bounded_sums_one (Finset.mem_image.mpr ⟨(a, d * b),
        Finset.mem_product.mpr ⟨ha, hBA b hb⟩, rfl⟩)
    have hterm : d * (a * b * c) ∈ natBoundedSums (natQuadraticSet A) M := by
      have hh := nat_bounded_sums_mono (natQuadraticSet A)
        (show 1 * c ≤ M by simpa only [Nat.one_mul] using (Finset.mem_Ioc.mp hc).2)
        (mul_mem_nat_bounded_sums hprod c)
      have heq : d * (a * b * c) = a * (d * b) * c := by ring
      rw [heq]
      exact hh
    have hindex : M * (s + 1) = M + M * s := by ring
    rw [hindex, Nat.mul_add]
    exact add_mem_nat_bounded_sums hterm (ih y hy)

theorem exists_regular_tree_quadratic_projected_growth (T R : ℕ) {γ δ ρ g : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hρ : 0 < ρ) (hρδ : ρ ≤ δ / 4) (hρR : 1 ≤ ρ * (R : ℝ))
    (hg : 0 < g) (hγg : 8 * g ≤ γ) (hρg : 3 * ρ < g)
    (hbudget : 1 ≤ (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (R : ℝ)) :
    ∃ K : ℕ, 0 < K ∧ ∀ (N : ℕ) (A : Finset ℕ),
      A.Nonempty → DyadicRegularTree A T N → (∀ x ∈ A, x < 2 ^ (T * N)) →
      (∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
        ((dyadicProjection A (T * j)).card : ℝ)) →
      (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
      1 ≤ N → 2 * (R : ℝ) ≤ γ * (N : ℝ) →
      ∃ w a : ℕ, w ≤ N ∧ a ∈ A ∧ (∀ k : ℕ, (2 ^ k).gcd a ≤ 2 ^ T) ∧
        (2 : ℝ) ^ (ρ / 2 * (γ * δ / 2 * (T : ℝ) * (N : ℝ))) *
          ((dyadicProjection A (T * w)).card : ℝ) ≤
            (2 : ℝ) ^ T * ((dyadicProjection (natBoundedSums (natQuadraticSet A) K) (T * w)).card : ℝ) := by
  obtain ⟨S, s, hMS, hS, hs, hgrowth⟩ := exists_regular_tree_product_growth T R
    hT hR hγ hδ hδ1 hρ hρδ hρR hg hρg hbudget
  let K := 2 ^ S * (2 * s)
  refine ⟨K, by dsimp [K]; positivity, ?_⟩
  intro N A hA htree hbound hprefix hsize hN hRN
  have hfirst : 1 < (dyadicProjection A T).card := by
    have hh := hprefix 1 hN
    simp only [Nat.cast_one, mul_one] at hh
    have hp : (1 : ℝ) < (2 : ℝ) ^ (γ * (T : ℝ)) :=
      Real.one_lt_rpow (by norm_num) (mul_pos hγ (by exact_mod_cast hT))
    exact_mod_cast hp.trans_le hh
  obtain ⟨v, hv, B, hB, hBodd, hBA, hAB⟩ :=
    exists_regular_tree_odd_divided_subset htree hbound hN hfirst
  obtain ⟨w, hwN, hgain⟩ := hgrowth N A B hA hB hBodd htree hbound hprefix hsize hRN
    (fun l hl hlN => odd_divided_subset_regular_mass hT hR hg hγg hρg hρR hMS
      hB hBA hAB htree hbound hprefix hl hlN)
  obtain ⟨b, hb⟩ := hB
  have hB : B.Nonempty := ⟨b, hb⟩
  refine ⟨w, 2 ^ v * b, hwN, hBA b hb,
    fun k => dyadic_gcd_scaled_odd_le (hBodd b hb) hv.le k, ?_⟩
  let P := natProductSumSet A B (Finset.Ioc 0 (2 ^ S)) (2 * s)
  have hP : (0 : ℝ) < (dyadicProjection P (T * w)).card := by
    exact_mod_cast Finset.card_pos.mpr ((nat_product_sum_set_nonempty hA hB
      (Finset.nonempty_Ioc.mpr (by positivity)) (2 * s)).image (fun n => n % 2 ^ (T * w)))
  have hAP : (0 : ℝ) < (dyadicProjection A (T * w)).card := by
    exact_mod_cast Finset.card_pos.mpr (hA.image (fun n => n % 2 ^ (T * w)))
  have hscale : (dyadicProjection P (T * w)).card ≤
      2 ^ T * (dyadicProjection (natBoundedSums (natQuadraticSet A) K) (T * w)).card := by
    have hh := dyadic_projection_mul_card_le P (T * w) (2 ^ v) (2 ^ T)
      ((Nat.gcd_le_right _ (by positivity : 0 < 2 ^ v)).trans
        (Nat.pow_le_pow_right (by decide : 0 < 2) hv.le))
    apply hh.trans
    apply Nat.mul_le_mul_left
    apply Finset.card_le_card
    apply Finset.image_subset_image
    intro n hn
    obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hn
    exact scaled_product_sum_mem_quadratic_sums hBA (2 ^ S) (2 * s) x hx
  exact (log_gain_implies_dyadic_growth hAP hP hgain).trans (by exact_mod_cast hscale)

theorem nat_modular_scaled_fiber_growth (H F : Finset ℕ) {q Q a D : ℕ}
    [NeZero Q] (hq : q ∣ Q) (hbound : ∀ x ∈ F, x < Q)
    (hcommon : ∀ x ∈ F, ∀ y ∈ F, x % q = y % q) (hgcd : Q.gcd a ≤ D) :
    (H.image (fun x => x % q)).card * F.card ≤
      D * ((H ×ˢ F).image (fun p => (p.1 + a * p.2) % Q)).card := by
  let V := F.image (fun x => a * x % Q)
  have hself : F.image (fun x => x % Q) = F := by
    calc
      _ = F.image id := Finset.image_congr (fun x hx => Nat.mod_eq_of_lt (hbound x hx))
      _ = F := Finset.image_id
  have hcard : F.card ≤ D * V.card := by
    have hh := nat_modular_projection_mul_card (q := Q) F a
    rw [hself] at hh
    exact hh.trans (Nat.mul_le_mul_right _ hgcd)
  have hVbound : ∀ x ∈ V, x < Q := by
    intro x hx
    obtain ⟨y, hy, rfl⟩ := Finset.mem_image.mp hx
    exact Nat.mod_lt _ (NeZero.pos Q)
  have hVcommon : ∀ x ∈ V, ∀ y ∈ V, x % q = y % q := by
    intro x hx y hy
    obtain ⟨s, hs, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨t, ht, rfl⟩ := Finset.mem_image.mp hy
    rw [Nat.mod_mod_of_dvd _ hq, Nat.mod_mod_of_dvd _ hq]
    exact (Nat.ModEq.refl a).mul (hcommon s hs t ht)
  have hsub : ((H ×ˢ V).image (fun p => (p.1 + p.2) % Q)) ⊆
      ((H ×ˢ F).image (fun p => (p.1 + a * p.2) % Q)) := by
    intro z hz
    obtain ⟨⟨h, v⟩, hhv, rfl⟩ := Finset.mem_image.mp hz
    obtain ⟨hh, hv⟩ := Finset.mem_product.mp hhv
    obtain ⟨f, hf, rfl⟩ := Finset.mem_image.mp hv
    exact Finset.mem_image.mpr ⟨(h, f), Finset.mem_product.mpr ⟨hh, hf⟩,
      by simp only [Nat.add_mod_mod]⟩
  calc
    _ ≤ (H.image (fun x => x % q)).card * (D * V.card) := Nat.mul_le_mul_left _ hcard
    _ = D * ((H.image (fun x => x % q)).card * V.card) := by ring
    _ ≤ D * ((H ×ˢ V).image (fun p => (p.1 + p.2) % Q)).card :=
      Nat.mul_le_mul_left _ (nat_modular_sumset_card_ge_projection_mul_fiber H V hq hVbound hVcommon)
    _ ≤ _ := Nat.mul_le_mul_left _ (Finset.card_le_card hsub)

theorem regular_tree_quadratic_growth_of_projected {A : Finset ℕ} {T N w K a D : ℕ}
    (hA : A.Nonempty) (htree : DyadicRegularTree A T N)
    (hbound : ∀ x ∈ A, x < 2 ^ (T * N)) (hwN : w ≤ N) (ha : a ∈ A)
    (hgcd : (2 ^ (T * N)).gcd a ≤ D) {Λ : ℝ}
    (hprojected : Λ * ((dyadicProjection A (T * w)).card : ℝ) ≤
      (D : ℝ) * ((dyadicProjection (natBoundedSums (natQuadraticSet A) K) (T * w)).card : ℝ)) :
    Λ * (A.card : ℝ) ≤ (D : ℝ) ^ 2 *
      ((dyadicProjection (natBoundedSums (natQuadraticSet A) (K + 1)) (T * N)).card : ℝ) := by
  let H := natBoundedSums (natQuadraticSet A) K
  obtain ⟨c, hc, hfiber⟩ := dyadic_regular_tree_uniform_fibers htree N le_rfl w hwN
  rw [dyadic_projection_self hbound] at hfiber
  obtain ⟨x₀, hx₀⟩ := hA
  let r := x₀ % 2 ^ (T * w)
  let F := A.filter (fun x => x % 2 ^ (T * w) = r)
  have hFA : F ⊆ A := Finset.filter_subset _ _
  have hr : r ∈ dyadicProjection A (T * w) := Finset.mem_image_of_mem _ hx₀
  have hFc : F.card = c := hfiber r hr
  have hAcard : A.card = (dyadicProjection A (T * w)).card * c := by
    rw [Finset.card_eq_sum_card_image (fun x => x % 2 ^ (T * w)) A]
    calc
      _ = ∑ _s ∈ dyadicProjection A (T * w), c := Finset.sum_congr rfl hfiber
      _ = _ := by simp
  have hraw := nat_modular_scaled_fiber_growth H F (pow_dvd_pow 2 (Nat.mul_le_mul_left T hwN))
    (fun x hx => hbound x (hFA hx))
    (fun x hx y hy => (Finset.mem_filter.mp hx).2.trans (Finset.mem_filter.mp hy).2.symm) hgcd
  have hsub : ((H ×ˢ F).image (fun p => (p.1 + a * p.2) % 2 ^ (T * N))) ⊆
      dyadicProjection (natBoundedSums (natQuadraticSet A) (K + 1)) (T * N) := by
    intro z hz
    obtain ⟨⟨h, f⟩, hhf, rfl⟩ := Finset.mem_image.mp hz
    obtain ⟨hh, hf⟩ := Finset.mem_product.mp hhf
    refine Finset.mem_image.mpr ⟨h + a * f, ?_, rfl⟩
    exact add_mem_nat_bounded_sums hh (mem_nat_bounded_sums_one
      (Finset.mem_image.mpr ⟨(a, f), Finset.mem_product.mpr ⟨ha, hFA hf⟩, rfl⟩))
  rw [hFc] at hraw
  have hrawR : ((dyadicProjection H (T * w)).card : ℝ) * (c : ℝ) ≤ (D : ℝ) *
      ((dyadicProjection (natBoundedSums (natQuadraticSet A) (K + 1)) (T * N)).card : ℝ) := by
    exact_mod_cast hraw.trans (Nat.mul_le_mul_left _ (Finset.card_le_card hsub))
  calc
    _ = (Λ * ((dyadicProjection A (T * w)).card : ℝ)) * (c : ℝ) := by
      rw [hAcard, Nat.cast_mul]; ring
    _ ≤ ((D : ℝ) * ((dyadicProjection H (T * w)).card : ℝ)) * (c : ℝ) :=
      mul_le_mul_of_nonneg_right hprojected (Nat.cast_nonneg _)
    _ = (D : ℝ) * (((dyadicProjection H (T * w)).card : ℝ) * (c : ℝ)) := by ring
    _ ≤ (D : ℝ) * ((D : ℝ) *
        ((dyadicProjection (natBoundedSums (natQuadraticSet A) (K + 1)) (T * N)).card : ℝ)) :=
      mul_le_mul_of_nonneg_left hrawR (Nat.cast_nonneg _)
    _ = _ := by ring

theorem exists_regular_tree_quadratic_growth (T R : ℕ) {γ δ ρ g : ℝ}
    (hT : 0 < T) (hR : 0 < R) (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1)
    (hρ : 0 < ρ) (hρδ : ρ ≤ δ / 4) (hρR : 1 ≤ ρ * (R : ℝ))
    (hg : 0 < g) (hγg : 8 * g ≤ γ) (hρg : 3 * ρ < g)
    (hbudget : 1 ≤ (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (R : ℝ)) :
    ∃ K : ℕ, 0 < K ∧ ∀ (N : ℕ) (A : Finset ℕ),
      A.Nonempty → DyadicRegularTree A T N → (∀ x ∈ A, x < 2 ^ (T * N)) →
      (∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
        ((dyadicProjection A (T * j)).card : ℝ)) →
      (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
      1 ≤ N → 2 * (R : ℝ) ≤ γ * (N : ℝ) →
      (2 : ℝ) ^ (ρ / 2 * (γ * δ / 2 * (T : ℝ) * (N : ℝ))) * (A.card : ℝ) ≤
        ((2 : ℝ) ^ T) ^ 2 *
          ((dyadicProjection (natBoundedSums (natQuadraticSet A) K) (T * N)).card : ℝ) := by
  obtain ⟨K, hK, hgrowth⟩ := exists_regular_tree_quadratic_projected_growth T R
    hT hR hγ hδ hδ1 hρ hρδ hρR hg hγg hρg hbudget
  refine ⟨K + 1, by omega, ?_⟩
  intro N A hA htree hbound hprefix hsize hN hRN
  obtain ⟨w, a, hwN, ha, hgcd, hprojected⟩ := hgrowth N A hA htree hbound hprefix hsize hN hRN
  have hh := regular_tree_quadratic_growth_of_projected hA htree hbound hwN ha (hgcd (T * N))
    (by simpa only [Nat.cast_pow, Nat.cast_ofNat] using hprojected)
  simpa only [Nat.cast_pow, Nat.cast_ofNat] using hh

theorem dyadic_quadratic_growth_absorb_loss {α : ℝ} {T N : ℕ} {a b : ℝ}
    (ha : 0 ≤ a) (hN : 4 ≤ α * (N : ℝ))
    (hgain : (2 : ℝ) ^ (α * (T : ℝ) * (N : ℝ)) * a ≤ ((2 : ℝ) ^ T) ^ 2 * b) :
    (2 : ℝ) ^ (α / 2 * (T : ℝ) * (N : ℝ)) * a ≤ b := by
  have hpow : ((2 : ℝ) ^ T) ^ 2 = (2 : ℝ) ^ (2 * (T : ℝ)) := by
    rw [← pow_mul, ← Real.rpow_natCast, Nat.cast_mul, Nat.cast_ofNat, mul_comm]
  rw [hpow] at hgain
  apply (mul_le_mul_iff_of_pos_left (Real.rpow_pos_of_pos (by norm_num : (0 : ℝ) < 2) (2 * (T : ℝ)))).mp
  calc
    _ = (2 : ℝ) ^ (2 * (T : ℝ) + α / 2 * (T : ℝ) * (N : ℝ)) * a := by
      rw [Real.rpow_add (by norm_num)]; ring
    _ ≤ (2 : ℝ) ^ (α * (T : ℝ) * (N : ℝ)) * a := by
      apply mul_le_mul_of_nonneg_right _ ha
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      have hh := mul_le_mul_of_nonneg_right hN (Nat.cast_nonneg T : (0 : ℝ) ≤ T)
      nlinarith
    _ ≤ _ := hgain

theorem exists_uniform_regular_tree_quadratic_amplification {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ η : ℝ, 0 < η ∧ ∀ T : ℕ, 0 < T → ∃ K N₀ : ℕ, 0 < K ∧
      ∀ N : ℕ, N₀ ≤ N → ∀ A : Finset ℕ, A.Nonempty → DyadicRegularTree A T N →
      (∀ x ∈ A, x < 2 ^ (T * N)) →
      (∀ j : ℕ, j ≤ N → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
        ((dyadicProjection A (T * j)).card : ℝ)) →
      (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
      (2 : ℝ) ^ (η * (T : ℝ) * (N : ℝ)) * (A.card : ℝ) ≤
        ((dyadicProjection (natBoundedSums (natQuadraticSet A) K) (T * N)).card : ℝ) := by
  let g := γ / 16
  let ρ := min (δ / 8) (γ / 128)
  let α := ρ / 2 * (γ * δ / 2)
  have hg : 0 < g := by dsimp [g]; positivity
  have hρ : 0 < ρ := lt_min (by positivity) (by positivity)
  have hρδ8 : ρ ≤ δ / 8 := min_le_left _ _
  have hργ128 : ρ ≤ γ / 128 := min_le_right _ _
  have hρδ : ρ ≤ δ / 4 := by linarith
  have hγg : 8 * g ≤ γ := by dsimp [g]; linarith
  have hρg : 3 * ρ < g := by dsimp [g]; linarith
  have hα : 0 < α := by dsimp [α]; positivity
  refine ⟨α / 2, by positivity, ?_⟩
  intro T hT
  have hTr : (0 : ℝ) < T := by exact_mod_cast hT
  have hlog : 0 < Real.log 2 := Real.log_pos (by norm_num)
  have hcoef : 0 < α * (T : ℝ) * Real.log 2 := by positivity
  obtain ⟨R, hRbound⟩ := exists_nat_ge (max (1 : ℝ) (max (1 / ρ) (1 / (α * (T : ℝ) * Real.log 2))))
  have hR1 : (1 : ℝ) ≤ R := (le_max_left _ _).trans hRbound
  have hR : 0 < R := by
    have hh : 1 ≤ R := by exact_mod_cast hR1
    omega
  have hρrecip : 1 / ρ ≤ (R : ℝ) := (le_max_left _ _).trans ((le_max_right _ _).trans hRbound)
  have hcoefrecip : 1 / (α * (T : ℝ) * Real.log 2) ≤ (R : ℝ) :=
    (le_max_right _ _).trans ((le_max_right _ _).trans hRbound)
  have hρR : 1 ≤ ρ * (R : ℝ) := by
    have hh := (div_le_iff₀ hρ).mp hρrecip
    nlinarith
  have hcoefR : 1 ≤ (α * (T : ℝ) * Real.log 2) * (R : ℝ) := by
    have hh := (div_le_iff₀ hcoef).mp hcoefrecip
    nlinarith
  have hbudget : 1 ≤ (ρ / 2 * (γ * δ / 2 * (T : ℝ)) * Real.log 2) * (R : ℝ) := by
    calc
      _ ≤ (α * (T : ℝ) * Real.log 2) * (R : ℝ) := hcoefR
      _ = _ := by dsimp [α]; ring
  obtain ⟨K, hK, hgrowth⟩ := exists_regular_tree_quadratic_growth T R
    hT hR hγ hδ hδ1 hρ hρδ hρR hg hγg hρg hbudget
  obtain ⟨N₀, hN₀⟩ := exists_nat_ge (max (1 : ℝ) (max (2 * (R : ℝ) / γ) (4 / α)))
  refine ⟨K, N₀, hK, ?_⟩
  intro N hN A hA htree hbound hprefix hsize
  have hNbound : max (1 : ℝ) (max (2 * (R : ℝ) / γ) (4 / α)) ≤ N :=
    hN₀.trans (by exact_mod_cast hN)
  have hN1 : 1 ≤ N := by exact_mod_cast (le_max_left _ _).trans hNbound
  have hRN : 2 * (R : ℝ) ≤ γ * (N : ℝ) := by
    have hh := (div_le_iff₀ hγ).mp ((le_max_left _ _).trans ((le_max_right _ _).trans hNbound))
    nlinarith
  have hαN : 4 ≤ α * (N : ℝ) := by
    have hh := (div_le_iff₀ hα).mp ((le_max_right _ _).trans ((le_max_right _ _).trans hNbound))
    nlinarith
  have hh := hgrowth N A hA htree hbound hprefix hsize hN1 hRN
  have hexponent : ρ / 2 * (γ * δ / 2 * (T : ℝ) * (N : ℝ)) = α * (T : ℝ) * (N : ℝ) := by
    dsimp [α]
    ring
  rw [hexponent] at hh
  exact dyadic_quadratic_growth_absorb_loss (Nat.cast_nonneg _) hαN hh

theorem dyadic_tree_block_image {A : Finset ℕ} {b T m k : ℕ} (hA : DyadicTreeBlock A b T m k)
    (f : ℕ → ℕ) (hinj : Set.InjOn f A)
    (hmod : ∀ j : ℕ, j ≤ b + T → ∀ x ∈ A, ∀ y ∈ A,
      f x % 2 ^ j = f y % 2 ^ j ↔ x % 2 ^ j = y % 2 ^ j) :
    DyadicTreeBlock (A.image f) b T m k := by
  have hfiber : ∀ a ∈ A,
      (A.image f).filter (fun y => y % 2 ^ m = f a % 2 ^ m) =
        (A.filter (fun x => x % 2 ^ m = a % 2 ^ m)).image f := by
    intro a ha
    ext y
    constructor
    · intro hy
      obtain ⟨hyA, hym⟩ := Finset.mem_filter.mp hy
      obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hyA
      exact Finset.mem_image.mpr ⟨x, Finset.mem_filter.mpr
        ⟨hx, (hmod m hA.split_lt.le x hx a ha).mp hym⟩, rfl⟩
    · intro hy
      obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hy
      obtain ⟨hxA, hxm⟩ := Finset.mem_filter.mp hx
      exact Finset.mem_filter.mpr ⟨Finset.mem_image_of_mem _ hxA,
        (hmod m hA.split_lt.le x hxA a ha).mpr hxm⟩
  refine ⟨hA.base_le, hA.split_lt, hA.count_le, ?_, ?_, ?_⟩
  · intro x hx y hy hxy
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨c, hc, rfl⟩ := Finset.mem_image.mp hy
    exact (hmod m hA.split_lt.le a ha c hc).mpr
      (hA.common a ha c hc ((hmod b (by omega) a ha c hc).mp hxy))
  · intro r hr
    obtain ⟨y, hy, rfl⟩ := Finset.mem_image.mp hr
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hy
    rw [hfiber a ha, Finset.card_image_of_injOn (hinj.mono (Finset.filter_subset _ _))]
    exact hA.fiber_card _ (Finset.mem_image_of_mem _ ha)
  · intro r hr hk
    obtain ⟨y, hy, rfl⟩ := Finset.mem_image.mp hr
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hy
    obtain ⟨x, hx, z, hz, hxz⟩ := hA.splits _ (Finset.mem_image_of_mem _ ha) hk
    rw [hfiber a ha]
    refine ⟨f x, Finset.mem_image_of_mem _ hx, f z, Finset.mem_image_of_mem _ hz, ?_⟩
    intro h
    exact hxz ((hmod (m + 1) (by have := hA.split_lt; omega) x (Finset.mem_filter.mp hx).1
      z (Finset.mem_filter.mp hz).1).mp h)

theorem dyadic_translation_mod_eq_iff {j e : ℕ} (hje : j ≤ e) (c x y : ℕ) :
    (x + c) % 2 ^ e % 2 ^ j = (y + c) % 2 ^ e % 2 ^ j ↔ x % 2 ^ j = y % 2 ^ j := by
  rw [Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 hje), Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 hje)]
  constructor
  · exact (Nat.ModEq.refl c).add_right_cancel
  · intro h
    exact (show Nat.ModEq (2 ^ j) x y from h).add (Nat.ModEq.refl c)

theorem dyadic_translation_injOn {A : Finset ℕ} {e : ℕ} (hA : ∀ x ∈ A, x < 2 ^ e) (c : ℕ) :
    Set.InjOn (fun x => (x + c) % 2 ^ e) A := by
  intro x hx y hy hxy
  have h := (dyadic_translation_mod_eq_iff (le_refl e) c x y).mp (congrArg (fun n => n % 2 ^ e) hxy)
  simpa only [Nat.mod_eq_of_lt (hA x hx), Nat.mod_eq_of_lt (hA y hy)] using h

theorem dyadic_projection_translate_trans (A : Finset ℕ) (e c : ℕ) :
    dyadicProjection (natTranslate (dyadicProjection A e) c) e =
      dyadicProjection (natTranslate A c) e := by
  simp only [dyadicProjection, natTranslate, Finset.image_image, Function.comp_def]
  apply Finset.image_congr
  intro x hx
  dsimp only
  exact Nat.mod_add_mod _ _ _

theorem dyadic_tree_block_mod_translate {A : Finset ℕ} {b T m k : ℕ}
    (hA : DyadicTreeBlock A b T m k) (hbound : ∀ x ∈ A, x < 2 ^ (b + T)) (c : ℕ) :
    DyadicTreeBlock (dyadicProjection (natTranslate A c) (b + T)) b T m k := by
  have hh := dyadic_tree_block_image hA (fun x => (x + c) % 2 ^ (b + T))
    (dyadic_translation_injOn hbound c)
    (fun j hj x hx y hy => dyadic_translation_mod_eq_iff hj c x y)
  simpa only [dyadicProjection, natTranslate, Finset.image_image, Function.comp_def] using hh

theorem dyadic_regular_tree_mod_translate {A : Finset ℕ} {T N : ℕ}
    (htree : DyadicRegularTree A T N) (c : ℕ) :
    DyadicRegularTree (dyadicProjection (natTranslate A c) (T * N)) T N := by
  intro i hi
  obtain ⟨m, k, hblock⟩ := htree i hi
  have he : T * i + T = T * (i + 1) := by ring
  have hh := dyadic_tree_block_mod_translate hblock
    (by simpa only [he] using dyadic_projection_bounded A (T * (i + 1))) c
  rw [he, dyadic_projection_translate_trans] at hh
  refine ⟨m, k, ?_⟩
  rw [dyadic_projection_trans _ (Nat.mul_le_mul_left T (show i + 1 ≤ N by omega))]
  exact hh

theorem dyadic_projection_translate_card (A : Finset ℕ) (e c : ℕ) :
    (dyadicProjection (natTranslate A c) e).card = (dyadicProjection A e).card := by
  rw [← dyadic_projection_translate_trans A e c]
  change (((dyadicProjection A e).image (fun x => x + c)).image (fun x => x % 2 ^ e)).card = _
  rw [Finset.image_image]
  exact Finset.card_image_of_injOn (dyadic_translation_injOn (dyadic_projection_bounded A e) c)

def natCenter (A : Finset ℕ) (a : ℕ) : Finset ℕ := A.image (fun x => x - a)

theorem nat_center_eq_mod_translate {A : Finset ℕ} {a e : ℕ}
    (ha : a < 2 ^ e) (hbase : ∀ x ∈ A, a ≤ x) (hbound : ∀ x ∈ A, x < 2 ^ e) :
    natCenter A a = dyadicProjection (natTranslate A (2 ^ e - a)) e := by
  simp only [natCenter, dyadicProjection, natTranslate, Finset.image_image, Function.comp_def]
  apply Finset.image_congr
  intro x hx
  have heq : x + (2 ^ e - a) = x - a + 2 ^ e := by have := hbase x hx; omega
  dsimp only
  rw [heq, Nat.add_mod_right, Nat.mod_eq_of_lt (lt_of_le_of_lt (Nat.sub_le x a) (hbound x hx))]

theorem nat_center_card {A : Finset ℕ} {a : ℕ} (hbase : ∀ x ∈ A, a ≤ x) :
    (natCenter A a).card = A.card := by
  apply Finset.card_image_of_injOn
  intro x hx y hy hxy
  change x - a = y - a at hxy
  have := hbase x hx
  have := hbase y hy
  omega

theorem dyadic_regular_tree_center {A : Finset ℕ} {a T N : ℕ}
    (htree : DyadicRegularTree A T N) (ha : a ∈ A)
    (hbase : ∀ x ∈ A, a ≤ x) (hbound : ∀ x ∈ A, x < 2 ^ (T * N)) :
    DyadicRegularTree (natCenter A a) T N := by
  rw [nat_center_eq_mod_translate (hbound a ha) hbase hbound]
  exact dyadic_regular_tree_mod_translate htree _

theorem dyadic_center_projection_card {A : Finset ℕ} {a e j : ℕ}
    (ha : a ∈ A) (hbase : ∀ x ∈ A, a ≤ x) (hbound : ∀ x ∈ A, x < 2 ^ e) (hj : j ≤ e) :
    (dyadicProjection (natCenter A a) j).card = (dyadicProjection A j).card := by
  rw [nat_center_eq_mod_translate (hbound a ha) hbase hbound,
    dyadic_projection_trans _ hj, dyadic_projection_translate_card]

theorem scaled_mem_nat_bounded_sums {A B : Finset ℕ} {d : ℕ}
    (hmap : ∀ a ∈ A, d * a ∈ B) (K : ℕ) :
    ∀ n ∈ natBoundedSums A K, d * n ∈ natBoundedSums B K := by
  induction K with
  | zero =>
    intro n hn
    have hn0 : n = 0 := Finset.mem_singleton.mp hn
    simpa only [hn0, Nat.mul_zero] using zero_mem_nat_bounded_sums B 0
  | succ K ih =>
    intro n hn
    obtain ⟨⟨a, x⟩, hax, rfl⟩ := Finset.mem_image.mp hn
    obtain ⟨ha, hx⟩ := Finset.mem_product.mp hax
    have hda : d * a ∈ insert 0 B := by
      rcases Finset.mem_insert.mp ha with rfl | ha
      · simp only [Nat.mul_zero, Finset.mem_insert_self]
      · exact Finset.mem_insert_of_mem (hmap a ha)
    exact Finset.mem_image.mpr ⟨(d * a, d * x), Finset.mem_product.mpr ⟨hda, ih x hx⟩,
      (Nat.mul_add d a x).symm⟩

theorem scaled_quadratic_sums_mem {A B : Finset ℕ} {d : ℕ}
    (hmap : ∀ a ∈ A, d * a ∈ B) (K : ℕ) :
    ∀ n ∈ natBoundedSums (natQuadraticSet A) K,
      d ^ 2 * n ∈ natBoundedSums (natQuadraticSet B) K := by
  apply scaled_mem_nat_bounded_sums
  intro a ha
  obtain ⟨⟨x, y⟩, hxy, rfl⟩ := Finset.mem_image.mp ha
  obtain ⟨hx, hy⟩ := Finset.mem_product.mp hxy
  exact Finset.mem_image.mpr ⟨(d * x, d * y), Finset.mem_product.mpr ⟨hmap x hx, hmap y hy⟩,
    by dsimp only; ring⟩

theorem dyadic_scaled_quadratic_card {A B : Finset ℕ} {d e J : ℕ}
    (hmap : ∀ a ∈ A, 2 ^ d * a ∈ B) (heJ : e ≤ J) (K : ℕ) :
    (dyadicProjection (natBoundedSums (natQuadraticSet A) K) e).card ≤
      2 ^ (2 * d) * (dyadicProjection (natBoundedSums (natQuadraticSet B) K) J).card := by
  have hpow : (2 ^ d : ℕ) ^ 2 = 2 ^ (2 * d) := by rw [← pow_mul, Nat.mul_comm]
  have hsub : (natBoundedSums (natQuadraticSet A) K).image (fun x => 2 ^ (2 * d) * x) ⊆
      natBoundedSums (natQuadraticSet B) K := by
    intro n hn
    obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hn
    simpa only [hpow] using scaled_quadratic_sums_mem hmap K x hx
  calc
    _ ≤ (dyadicProjection (natBoundedSums (natQuadraticSet A) K) J).card :=
      dyadic_projection_card_mono _ heJ
    _ ≤ 2 ^ (2 * d) * (dyadicProjection
        ((natBoundedSums (natQuadraticSet A) K).image (fun x => 2 ^ (2 * d) * x)) J).card :=
      dyadic_projection_mul_card_le _ J _ _ (Nat.gcd_le_right _ (by positivity))
    _ ≤ _ := Nat.mul_le_mul_left _ (Finset.card_le_card (Finset.image_subset_image hsub))

def natDifferenceSet (A : Finset ℕ) : Finset ℕ := (A ×ˢ A).image (fun p => p.1 - p.2)

theorem centered_zoom_scaled_mem_difference {A B : Finset ℕ} {d r a : ℕ}
    (hBA : B ⊆ A) (hr : r < 2 ^ d) (ha : a ∈ dyadicZoom B d r) :
    ∀ x ∈ natCenter (dyadicZoom B d r) a, 2 ^ d * x ∈ natDifferenceSet A := by
  intro x hx
  obtain ⟨y, hy, rfl⟩ := Finset.mem_image.mp hx
  have hyB := (dyadic_zoom_mem hr).mp hy
  have haB := (dyadic_zoom_mem hr).mp ha
  refine Finset.mem_image.mpr ⟨(r + 2 ^ d * y, r + 2 ^ d * a),
    Finset.mem_product.mpr ⟨hBA hyB, hBA haB⟩, ?_⟩
  dsimp only
  rw [Nat.add_sub_add_left, Nat.mul_sub_left_distrib]

theorem exists_centered_regular_tail {A B : Finset ℕ} {T N i : ℕ} {γ : ℝ}
    (hBA : B ⊆ A) (hB : B.Nonempty) (htree : DyadicRegularTree B T N)
    (hbound : ∀ x ∈ B, x < 2 ^ (T * N)) (hiN : i ≤ N)
    (htail : ∀ j : ℕ, i ≤ j → j ≤ N →
      ((dyadicProjection B (T * i)).card : ℝ) * (2 : ℝ) ^ (γ * ((T * (j - i) : ℕ) : ℝ)) ≤
        ((dyadicProjection B (T * j)).card : ℝ)) :
    ∃ C : Finset ℕ, C.Nonempty ∧ DyadicRegularTree C T (N - i) ∧
      (∀ x ∈ C, x < 2 ^ (T * (N - i))) ∧
      (∀ j : ℕ, j ≤ N - i → (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤
        ((dyadicProjection C (T * j)).card : ℝ)) ∧
      C.card ≤ A.card ∧ B.card ≤ 2 ^ (T * i) * C.card ∧
      (∀ x ∈ C, 2 ^ (T * i) * x ∈ natDifferenceSet A) := by
  obtain ⟨r, hr⟩ := hB.image (fun x => x % 2 ^ (T * i))
  have hrB : r ∈ dyadicProjection B (T * i) := hr
  have hrlt := dyadic_projection_bounded B (T * i) r hrB
  let Z := dyadicZoom B (T * i) r
  have hZ : Z.Nonempty := dyadic_zoom_nonempty hrB
  have hZbound : ∀ x ∈ Z, x < 2 ^ (T * (N - i)) :=
    dyadic_zoom_bounded (by simpa only [← Nat.mul_add, Nat.add_sub_of_le hiN] using hbound) r
  obtain ⟨a, ha, hamin⟩ := Finset.exists_min_image Z id hZ
  have hbase : ∀ x ∈ Z, a ≤ x := hamin
  let C := natCenter Z a
  have hCcard : C.card = Z.card := nat_center_card hbase
  refine ⟨C, hZ.image _, dyadic_regular_tree_center (dyadic_regular_tree_zoom htree hiN hrlt)
    ha hbase hZbound, ?_, ?_, ?_, ?_, ?_⟩
  · intro x hx
    obtain ⟨y, hy, rfl⟩ := Finset.mem_image.mp hx
    exact lt_of_le_of_lt (Nat.sub_le _ _) (hZbound y hy)
  · intro j hj
    rw [dyadic_center_projection_card ha hbase hZbound (Nat.mul_le_mul_left T hj)]
    simpa only [Nat.cast_mul, mul_assoc] using
      dyadic_regular_tree_zoom_growth htree hrB htail j (by omega)
  · rw [hCcard, dyadic_zoom_card]
    exact (Finset.card_filter_le _ _).trans (Finset.card_le_card hBA)
  · rw [hCcard, ← dyadic_regular_tree_zoom_card htree hbound hiN hrB]
    exact Nat.mul_le_mul_right _ (dyadic_projection_card_le B (T * i))
  · exact centered_zoom_scaled_mem_difference hBA hrlt ha

theorem exists_general_dyadic_growth_dichotomy {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ κ ε : ℝ, 0 < κ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧
      ∃ T K N₀ : ℕ, 0 < T ∧ 0 < K ∧ ∀ N : ℕ, N₀ ≤ N →
        ∀ A : Finset ℕ, A.Nonempty → (∀ x ∈ A, x < 2 ^ (T * N)) →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
        (∀ j : ℕ, j ≤ N → ε * (N : ℝ) < (j : ℝ) →
          (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤ ((dyadicProjection A (T * j)).card : ℝ)) →
        (2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ)) * (A.card : ℝ) ≤
          (((A ×ˢ A).image (fun p => (p.1 + p.2) % 2 ^ (T * N))).card : ℝ) ∨
        (2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ)) * (A.card : ℝ) ≤
          ((dyadicProjection (natBoundedSums (natQuadraticSet (natDifferenceSet A)) K) (T * N)).card : ℝ) := by
  obtain ⟨α, hα, hamp⟩ := exists_uniform_regular_tree_quadratic_amplification
    (show 0 < γ / 2 by positivity) (show 0 < δ / 2 by positivity) (show δ / 2 ≤ 1 by linarith)
  let ε := min (1 / 4 : ℝ) (min (δ / 4) (α / 16))
  let κ := min (ε * γ / 8) (α / 16)
  have hε : 0 < ε := lt_min (by norm_num) (lt_min (by positivity) (by positivity))
  have hε4 : ε ≤ 1 / 4 := min_le_left _ _
  have hεδ : ε ≤ δ / 4 := (min_le_right _ _).trans (min_le_left _ _)
  have hεα : ε ≤ α / 16 := (min_le_right _ _).trans (min_le_right _ _)
  have hκ : 0 < κ := lt_min (by positivity) (by positivity)
  have hκε : κ ≤ ε * γ / 8 := min_le_left _ _
  have hκα : κ ≤ α / 16 := min_le_right _ _
  have hbudget : κ + κ ≤ ε * (γ - γ / 2) := by nlinarith [mul_pos hε hγ]
  have htotal : 2 * κ + (α + 3) * ε ≤ α := by
    have hh := mul_le_mul_of_nonneg_left hε4 hα.le
    nlinarith
  obtain ⟨T, hT, hregular⟩ := exists_dyadic_regular_tree_small_loss hκ
  obtain ⟨K, N₁, hK, hampT⟩ := hamp T hT
  refine ⟨κ, ε, hκ, hε, hε4, T, K, 2 * N₁ + 1, hT, hK, ?_⟩
  intro N hN A hA hbound hsize hprojection
  by_cases hsum : (2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ)) * (A.card : ℝ) ≤
      (((A ×ˢ A).image (fun p => (p.1 + p.2) % 2 ^ (T * N))).card : ℝ)
  · exact Or.inl hsum
  apply Or.inr
  have hsmall : (((A ×ˢ A).image (fun p => (p.1 + p.2) % 2 ^ (T * N))).card : ℝ) ≤
      (2 : ℝ) ^ (κ * ((T * N : ℕ) : ℝ)) * (A.card : ℝ) := by
    simpa only [Nat.cast_mul, mul_assoc] using (lt_of_not_ge hsum).le
  obtain ⟨B, hBA, htree, hlarge⟩ := hregular N A hbound
  have hB : B.Nonempty := by
    apply Finset.card_pos.mp
    have hApos : (0 : ℝ) < A.card := by exact_mod_cast Finset.card_pos.mpr hA
    have hpow : 0 < (2 : ℝ) ^ (κ * ((T * N : ℕ) : ℝ)) := by positivity
    have hBpos : (0 : ℝ) < B.card := by nlinarith
    exact_mod_cast hBpos
  have hBbound : ∀ x ∈ B, x < 2 ^ (T * N) := fun x hx => hbound x (hBA hx)
  obtain ⟨i, hiN, hiε, hPi, htail⟩ := exists_regular_tree_dense_tail hT hBA hB htree hBbound
    (show γ / 2 < γ by linarith) hbudget hlarge hsmall
    (by intro j hj hεj; simpa only [Nat.cast_mul, mul_assoc] using hprojection j hj hεj)
  obtain ⟨C, hC, hCtree, hCbound, hCprefix, hCA, hBC, hmap⟩ :=
    exists_centered_regular_tail hBA hB htree hBbound hiN htail
  have hi2 : 2 * i ≤ N := by
    have hh := mul_le_mul_of_nonneg_right hε4 (Nat.cast_nonneg N : (0 : ℝ) ≤ N)
    have hh' : (2 : ℝ) * (i : ℝ) ≤ N := by nlinarith
    exact_mod_cast hh'
  have htailN : N₁ ≤ N - i := by omega
  have hdensity : (1 - δ) * (N : ℝ) ≤ (1 - δ / 2) * ((N - i : ℕ) : ℝ) := by
    have hh := mul_le_mul_of_nonneg_right hεδ (Nat.cast_nonneg N : (0 : ℝ) ≤ N)
    rw [Nat.cast_sub hiN]
    nlinarith [mul_nonneg hδ.le (Nat.cast_nonneg i : (0 : ℝ) ≤ i)]
  have hCsize : (C.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ / 2) * (T : ℝ) * ((N - i : ℕ) : ℝ)) := by
    calc
      _ ≤ (A.card : ℝ) := by exact_mod_cast hCA
      _ ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) := hsize
      _ ≤ _ := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        have hh := mul_le_mul_of_nonneg_left hdensity (Nat.cast_nonneg T : (0 : ℝ) ≤ T)
        nlinarith
  have hgrowth := hampT (N - i) htailN C hC hCtree hCbound hCprefix hCsize
  let Z := ((dyadicProjection (natBoundedSums (natQuadraticSet (natDifferenceSet A)) K) (T * N)).card : ℝ)
  have hlift : ((dyadicProjection (natBoundedSums (natQuadraticSet C) K) (T * (N - i))).card : ℝ) ≤
      (2 : ℝ) ^ (2 * (T : ℝ) * (i : ℝ)) * Z := by
    have hh := dyadic_scaled_quadratic_card hmap (Nat.mul_le_mul_left T (Nat.sub_le N i)) K
    have hhR : ((dyadicProjection (natBoundedSums (natQuadraticSet C) K) (T * (N - i))).card : ℝ) ≤
        (2 : ℝ) ^ (2 * (T * i)) * Z := by dsimp only [Z]; exact_mod_cast hh
    simpa only [← Real.rpow_natCast, Nat.cast_mul, Nat.cast_ofNat, mul_assoc] using hhR
  have hlargeC : (A.card : ℝ) ≤
      (2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ) + (T : ℝ) * (i : ℝ)) * (C.card : ℝ) := by
    have hBCR : (B.card : ℝ) ≤ (2 : ℝ) ^ ((T : ℝ) * (i : ℝ)) * (C.card : ℝ) := by
      have hh : (B.card : ℝ) ≤ (2 : ℝ) ^ (T * i) * (C.card : ℝ) := by exact_mod_cast hBC
      simpa only [← Real.rpow_natCast, Nat.cast_mul] using hh
    calc
      _ ≤ (2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ)) * (B.card : ℝ) := by
        simpa only [Nat.cast_mul, mul_assoc] using hlarge
      _ ≤ (2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ)) *
          ((2 : ℝ) ^ ((T : ℝ) * (i : ℝ)) * (C.card : ℝ)) :=
        mul_le_mul_of_nonneg_left hBCR (by positivity)
      _ = _ := by rw [← mul_assoc, ← Real.rpow_add (by norm_num)]
  have hexp : 2 * κ * (T : ℝ) * (N : ℝ) + 3 * (T : ℝ) * (i : ℝ) ≤
      α * (T : ℝ) * ((N - i : ℕ) : ℝ) := by
    have hh := mul_le_mul_of_nonneg_right htotal (Nat.cast_nonneg N : (0 : ℝ) ≤ N)
    have hh' := mul_le_mul_of_nonneg_left hiε (show 0 ≤ α + 3 by linarith)
    have hi : 2 * κ * (N : ℝ) + 3 * (i : ℝ) ≤ α * ((N - i : ℕ) : ℝ) := by
      rw [Nat.cast_sub hiN]
      nlinarith
    have hh'' := mul_le_mul_of_nonneg_left hi (Nat.cast_nonneg T : (0 : ℝ) ≤ T)
    nlinarith
  apply (mul_le_mul_iff_of_pos_left
    (Real.rpow_pos_of_pos (by norm_num : (0 : ℝ) < 2) (2 * (T : ℝ) * (i : ℝ)))).mp
  calc
    _ ≤ (2 : ℝ) ^ (2 * (T : ℝ) * (i : ℝ)) *
        ((2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ)) *
          ((2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ) + (T : ℝ) * (i : ℝ)) * (C.card : ℝ))) :=
      mul_le_mul_of_nonneg_left (mul_le_mul_of_nonneg_left hlargeC (by positivity)) (by positivity)
    _ = (2 : ℝ) ^ (2 * κ * (T : ℝ) * (N : ℝ) + 3 * (T : ℝ) * (i : ℝ)) * (C.card : ℝ) := by
      simp only [← mul_assoc]
      rw [← Real.rpow_add (by norm_num : (0 : ℝ) < 2),
        ← Real.rpow_add (by norm_num : (0 : ℝ) < 2)]
      congr 2
      ring
    _ ≤ (2 : ℝ) ^ (α * (T : ℝ) * ((N - i : ℕ) : ℝ)) * (C.card : ℝ) :=
      mul_le_mul_of_nonneg_right (Real.rpow_le_rpow_of_exponent_le (by norm_num) hexp) (Nat.cast_nonneg _)
    _ ≤ _ := hgrowth.trans hlift

def natSignedResidueHull (E : Finset ℕ) (K q : ℕ) : Finset ℕ :=
  (natBoundedSums E K ×ˢ natBoundedSums E K).image
    (fun p => ((p.1 : ZMod q) - (p.2 : ZMod q)).val)

theorem quadratic_difference_signed_representation (A : Finset ℕ) (q : ℕ) :
    ∀ x ∈ natQuadraticSet (natDifferenceSet A),
      ∃ p ∈ natBoundedSums (natLinearQuadraticSet A) 2,
        ∃ n ∈ natBoundedSums (natLinearQuadraticSet A) 2,
          (x : ZMod q) = (p : ZMod q) - (n : ZMod q) := by
  intro x hx
  obtain ⟨⟨s, t⟩, hst, rfl⟩ := Finset.mem_image.mp hx
  obtain ⟨hs, ht⟩ := Finset.mem_product.mp hst
  obtain ⟨⟨a, b⟩, hab, rfl⟩ := Finset.mem_image.mp hs
  obtain ⟨⟨c, d⟩, hcd, rfl⟩ := Finset.mem_image.mp ht
  obtain ⟨ha, hb⟩ := Finset.mem_product.mp hab
  obtain ⟨hc, hd⟩ := Finset.mem_product.mp hcd
  have hzero : 0 ∈ natBoundedSums (natLinearQuadraticSet A) 2 := zero_mem_nat_bounded_sums _ _
  by_cases hba : b ≤ a
  · by_cases hdc : d ≤ c
    · have hprod : ∀ u ∈ A, ∀ v ∈ A, u * v ∈ natBoundedSums (natLinearQuadraticSet A) 1 := by
        intro u hu v hv
        exact mem_nat_bounded_sums_one (Finset.mem_union_right A
          (Finset.mem_image.mpr ⟨(u, v), Finset.mem_product.mpr ⟨hu, hv⟩, rfl⟩))
      refine ⟨a * c + b * d, add_mem_nat_bounded_sums (hprod a ha c hc) (hprod b hb d hd),
        a * d + b * c, add_mem_nat_bounded_sums (hprod a ha d hd) (hprod b hb c hc), ?_⟩
      simp only [Nat.cast_mul, Nat.cast_sub hba, Nat.cast_sub hdc, Nat.cast_add]
      ring
    · refine ⟨0, hzero, 0, hzero, ?_⟩
      simp only [Nat.sub_eq_zero_of_le (by omega : c ≤ d), Nat.mul_zero, Nat.cast_zero, sub_self]
  · refine ⟨0, hzero, 0, hzero, ?_⟩
    simp only [Nat.sub_eq_zero_of_le (by omega : a ≤ b), Nat.zero_mul, Nat.cast_zero, sub_self]

theorem nat_bounded_sums_signed_representation {A E : Finset ℕ} {q K : ℕ}
    (hrep : ∀ a ∈ A, ∃ p ∈ natBoundedSums E K, ∃ n ∈ natBoundedSums E K,
      (a : ZMod q) = (p : ZMod q) - (n : ZMod q)) (s : ℕ) :
    ∀ x ∈ natBoundedSums A s, ∃ p ∈ natBoundedSums E (K * s),
      ∃ n ∈ natBoundedSums E (K * s), (x : ZMod q) = (p : ZMod q) - (n : ZMod q) := by
  induction s with
  | zero =>
    intro x hx
    have hx0 : x = 0 := Finset.mem_singleton.mp hx
    refine ⟨0, ?_, 0, ?_, ?_⟩
    · exact zero_mem_nat_bounded_sums _ _
    · exact zero_mem_nat_bounded_sums _ _
    · simp only [hx0, Nat.cast_zero, sub_self]
  | succ s ih =>
    intro x hx
    obtain ⟨⟨a, y⟩, hay, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨ha, hy⟩ := Finset.mem_product.mp hay
    have harep : ∃ p ∈ natBoundedSums E K, ∃ n ∈ natBoundedSums E K,
        (a : ZMod q) = (p : ZMod q) - (n : ZMod q) := by
      rcases Finset.mem_insert.mp ha with rfl | ha
      · exact ⟨0, zero_mem_nat_bounded_sums _ _, 0, zero_mem_nat_bounded_sums _ _, by simp⟩
      · exact hrep a ha
    obtain ⟨p, hp, n, hn, hapn⟩ := harep
    obtain ⟨p', hp', n', hn', hyrep⟩ := ih y hy
    have hindex : K * (s + 1) = K + K * s := by ring
    refine ⟨p + p', ?_, n + n', ?_, ?_⟩
    · rw [hindex]
      exact add_mem_nat_bounded_sums hp hp'
    · rw [hindex]
      exact add_mem_nat_bounded_sums hn hn'
    · simp only [Nat.cast_add, hapn, hyrep]
      ring

theorem mem_nat_signed_residue_hull {E : Finset ℕ} {K q x p n : ℕ} [NeZero q]
    (hp : p ∈ natBoundedSums E K) (hn : n ∈ natBoundedSums E K)
    (hrep : (x : ZMod q) = (p : ZMod q) - (n : ZMod q)) :
    x % q ∈ natSignedResidueHull E K q := by
  refine Finset.mem_image.mpr ⟨(p, n), Finset.mem_product.mpr ⟨hp, hn⟩, ?_⟩
  dsimp only
  rw [← hrep, ZMod.val_natCast]

theorem quadratic_difference_projection_subset_signed_hull (A : Finset ℕ) (K J : ℕ) :
    dyadicProjection (natBoundedSums (natQuadraticSet (natDifferenceSet A)) K) J ⊆
      natSignedResidueHull (natLinearQuadraticSet A) (2 * K + 2) (2 ^ J) := by
  intro x hx
  obtain ⟨y, hy, rfl⟩ := Finset.mem_image.mp hx
  obtain ⟨p, hp, n, hn, hrep⟩ := nat_bounded_sums_signed_representation
    (quadratic_difference_signed_representation A (2 ^ J)) K y hy
  exact mem_nat_signed_residue_hull (nat_bounded_sums_mono _ (by omega : 2 * K ≤ 2 * K + 2) hp)
    (nat_bounded_sums_mono _ (by omega : 2 * K ≤ 2 * K + 2) hn) hrep

theorem nat_sumset_subset_signed_linear_quadratic_hull (A : Finset ℕ) (K J : ℕ) :
    ((A ×ˢ A).image (fun p => (p.1 + p.2) % 2 ^ J)) ⊆
      natSignedResidueHull (natLinearQuadraticSet A) (2 * K + 2) (2 ^ J) := by
  intro x hx
  obtain ⟨⟨a, b⟩, hab, rfl⟩ := Finset.mem_image.mp hx
  obtain ⟨ha, hb⟩ := Finset.mem_product.mp hab
  have hp : a + b ∈ natBoundedSums (natLinearQuadraticSet A) 2 :=
    add_mem_nat_bounded_sums (mem_nat_bounded_sums_one (Finset.mem_union_left _ ha))
      (mem_nat_bounded_sums_one (Finset.mem_union_left _ hb))
  exact mem_nat_signed_residue_hull (nat_bounded_sums_mono _ (by omega : 2 ≤ 2 * K + 2) hp)
    (zero_mem_nat_bounded_sums _ _) (by simp)

theorem exists_general_dyadic_signed_sum_product_growth {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ κ ε : ℝ, 0 < κ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧
      ∃ T K N₀ : ℕ, 0 < T ∧ 0 < K ∧ ∀ N : ℕ, N₀ ≤ N →
        ∀ A : Finset ℕ, A.Nonempty → (∀ x ∈ A, x < 2 ^ (T * N)) →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) →
        (∀ j : ℕ, j ≤ N → ε * (N : ℝ) < (j : ℝ) →
          (2 : ℝ) ^ (γ * (T : ℝ) * (j : ℝ)) ≤ ((dyadicProjection A (T * j)).card : ℝ)) →
        (2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ)) * (A.card : ℝ) ≤
          ((natSignedResidueHull (natLinearQuadraticSet A) K (2 ^ (T * N))).card : ℝ) := by
  obtain ⟨κ, ε, hκ, hε, hε4, T, K, N₀, hT, hK, hgrowth⟩ :=
    exists_general_dyadic_growth_dichotomy hγ hδ hδ1
  refine ⟨κ, ε, hκ, hε, hε4, T, 2 * K + 2, N₀, hT, by omega, ?_⟩
  intro N hN A hA hbound hsize hprojection
  rcases hgrowth N hN A hA hbound hsize hprojection with hsum | hquad
  · apply hsum.trans
    exact_mod_cast Finset.card_le_card (nat_sumset_subset_signed_linear_quadratic_hull A K (T * N))
  · apply hquad.trans
    exact_mod_cast Finset.card_le_card (quadratic_difference_projection_subset_signed_hull A K (T * N))

theorem dyadic_card_le_projection_mul {A : Finset ℕ} {b d : ℕ}
    (hbound : ∀ x ∈ A, x < 2 ^ (b + d)) :
    A.card ≤ 2 ^ d * (dyadicProjection A b).card := by
  rw [Finset.card_eq_sum_card_image (fun x => x % 2 ^ b) A]
  calc
    _ ≤ ∑ _r ∈ dyadicProjection A b, 2 ^ d :=
      Finset.sum_le_sum (fun r _ => dyadic_residue_fiber_card_le hbound r)
    _ = _ := by simp [Nat.mul_comm]

theorem dyadic_sub_val_mod {j m : ℕ} (hjm : j ≤ m) (a b : ℕ) :
    ((a : ZMod (2 ^ m)) - (b : ZMod (2 ^ m))).val % 2 ^ j =
      ((a : ZMod (2 ^ j)) - (b : ZMod (2 ^ j))).val := by
  let π : ZMod (2 ^ m) →+* ZMod (2 ^ j) := ZMod.castHom (pow_dvd_pow 2 hjm) _
  have heq : (((((a : ZMod (2 ^ m)) - (b : ZMod (2 ^ m))).val) : ℕ) : ZMod (2 ^ j)) =
      (a : ZMod (2 ^ j)) - (b : ZMod (2 ^ j)) := by
    calc
      _ = π ((a : ZMod (2 ^ m)) - (b : ZMod (2 ^ m))) := by
        rw [ZMod.castHom_apply, ZMod.cast_eq_val]
      _ = _ := by rw [map_sub, map_natCast, map_natCast]
  have hh := congrArg ZMod.val heq
  simpa only [ZMod.val_natCast] using hh

theorem dyadic_signed_hull_project (E : Finset ℕ) (K : ℕ) {j m : ℕ} (hjm : j ≤ m) :
    dyadicProjection (natSignedResidueHull E K (2 ^ m)) j = natSignedResidueHull E K (2 ^ j) := by
  unfold dyadicProjection natSignedResidueHull
  rw [Finset.image_image]
  apply Finset.image_congr
  intro p hp
  exact dyadic_sub_val_mod hjm p.1 p.2

theorem nat_signed_residue_hull_bounded (E : Finset ℕ) (K : ℕ) {q : ℕ} [NeZero q] :
    ∀ x ∈ natSignedResidueHull E K q, x < q := by
  intro x hx
  obtain ⟨p, hp, rfl⟩ := Finset.mem_image.mp hx
  exact ZMod.val_lt _

theorem dyadic_signed_hull_card_le (E : Finset ℕ) (K : ℕ) {j m d : ℕ}
    (hjm : j ≤ m) (hmd : m ≤ j + d) :
    (natSignedResidueHull E K (2 ^ m)).card ≤ 2 ^ d * (natSignedResidueHull E K (2 ^ j)).card := by
  have hb : ∀ x ∈ natSignedResidueHull E K (2 ^ m), x < 2 ^ (j + d) := by
    intro x hx
    exact (nat_signed_residue_hull_bounded E K x hx).trans_le
      (Nat.pow_le_pow_right (by decide : 0 < 2) hmd)
  have hh := dyadic_card_le_projection_mul hb
  rwa [dyadic_signed_hull_project E K hjm] at hh

theorem exists_dyadic_signed_sum_product_growth {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ κ ε : ℝ, 0 < κ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧
      ∃ K J₀ : ℕ, 0 < K ∧ ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset ℕ,
        A.Nonempty → (∀ x ∈ A, x < 2 ^ J) →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ j : ℕ, j ≤ J → ε * (J : ℝ) < (j : ℝ) →
          (2 : ℝ) ^ (γ * (j : ℝ)) ≤ ((dyadicProjection A j).card : ℝ)) →
        (2 : ℝ) ^ (κ * (J : ℝ)) * (A.card : ℝ) ≤
          ((natSignedResidueHull (natLinearQuadraticSet A) K (2 ^ J)).card : ℝ) := by
  obtain ⟨κ, ε, hκ, hε, hε4, T, K, N₀, hT, hK, hgrowth⟩ :=
    exists_general_dyadic_signed_sum_product_growth (show 0 < γ / 2 by positivity) hδ hδ1
  obtain ⟨J₀, hJ₀⟩ := exists_nat_ge (max (T : ℝ) (max ((T * N₀ : ℕ) : ℝ) (2 * (T : ℝ) / κ)))
  refine ⟨κ / 2, ε, by positivity, hε, hε4, K, J₀, hK, ?_⟩
  intro J hJ A hA hbound hsize hprojection
  have hJbound : max (T : ℝ) (max ((T * N₀ : ℕ) : ℝ) (2 * (T : ℝ) / κ)) ≤ J :=
    hJ₀.trans (by exact_mod_cast hJ)
  have hTJ : T ≤ J := by exact_mod_cast (le_max_left _ _).trans hJbound
  have hTNJ : T * N₀ ≤ J := by
    exact_mod_cast (le_max_left _ _).trans ((le_max_right _ _).trans hJbound)
  have hκJ : 2 * (T : ℝ) ≤ κ * (J : ℝ) := by
    have hh := (div_le_iff₀ hκ).mp ((le_max_right _ _).trans ((le_max_right _ _).trans hJbound))
    nlinarith
  let N := J / T + 1
  have hdecomp : J % T + T * (J / T) = J := Nat.mod_add_div J T
  have hrem : J % T < T := Nat.mod_lt J hT
  have hJm : J ≤ T * N := by dsimp only [N]; rw [Nat.mul_add, Nat.mul_one]; omega
  have hmJ : T * N ≤ J + T := by dsimp only [N]; rw [Nat.mul_add, Nat.mul_one]; omega
  have hm2J : T * N ≤ 2 * J := by omega
  have hN : N₀ ≤ N := by
    have hh : N₀ ≤ J / T := (Nat.le_div_iff_mul_le hT).mpr (by simpa only [Nat.mul_comm] using hTNJ)
    dsimp [N]
    omega
  have hJpos : (0 : ℝ) < J := by exact_mod_cast (lt_of_lt_of_le hT hTJ)
  have hεJ : ε * (J : ℝ) < J := by nlinarith
  have hfull : (2 : ℝ) ^ (γ * (J : ℝ)) ≤ (A.card : ℝ) := by
    simpa only [dyadic_projection_self hbound] using hprojection J le_rfl hεJ
  have hbound' : ∀ x ∈ A, x < 2 ^ (T * N) := fun x hx =>
    (hbound x hx).trans_le (Nat.pow_le_pow_right (by decide : 0 < 2) hJm)
  have hsize' : (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (T : ℝ) * (N : ℝ)) := by
    apply hsize.trans
    apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
    have hh := mul_le_mul_of_nonneg_left (show (J : ℝ) ≤ (T : ℝ) * (N : ℝ) by exact_mod_cast hJm)
      (show 0 ≤ 1 - δ by linarith)
    nlinarith
  have hprefix : ∀ j : ℕ, j ≤ N → ε * (N : ℝ) < (j : ℝ) →
      (2 : ℝ) ^ (γ / 2 * (T : ℝ) * (j : ℝ)) ≤ ((dyadicProjection A (T * j)).card : ℝ) := by
    intro j hj hεj
    by_cases hjJ : T * j ≤ J
    · have hlarge : ε * (J : ℝ) < ((T * j : ℕ) : ℝ) := by
        have hh := mul_lt_mul_of_pos_left hεj (show (0 : ℝ) < T by exact_mod_cast hT)
        have hh' := mul_le_mul_of_nonneg_left (show (J : ℝ) ≤ (T : ℝ) * (N : ℝ) by exact_mod_cast hJm) hε.le
        simp only [Nat.cast_mul]
        nlinarith
      apply (Real.rpow_le_rpow_of_exponent_le (by norm_num : (1 : ℝ) ≤ 2) ?_).trans
        (hprojection (T * j) hjJ hlarge)
      simp only [Nat.cast_mul]
      nlinarith [mul_nonneg (mul_nonneg hγ.le (Nat.cast_nonneg T)) (Nat.cast_nonneg j)]
    · have hJtj : J ≤ T * j := by omega
      rw [dyadic_projection_self (fun x hx => (hbound x hx).trans_le
        (Nat.pow_le_pow_right (by decide : 0 < 2) hJtj))]
      apply (Real.rpow_le_rpow_of_exponent_le (by norm_num : (1 : ℝ) ≤ 2) ?_).trans hfull
      have hle : (T : ℝ) * (j : ℝ) ≤ 2 * (J : ℝ) := by
        exact_mod_cast (Nat.mul_le_mul_left T hj).trans hm2J
      nlinarith [mul_le_mul_of_nonneg_left hle hγ.le]
  have hh := hgrowth N hN A hA hbound' hsize' hprefix
  have hreduce : ((natSignedResidueHull (natLinearQuadraticSet A) K (2 ^ (T * N))).card : ℝ) ≤
      (2 : ℝ) ^ T * ((natSignedResidueHull (natLinearQuadraticSet A) K (2 ^ J)).card : ℝ) := by
    exact_mod_cast dyadic_signed_hull_card_le (natLinearQuadraticSet A) K hJm hmJ
  apply (mul_le_mul_iff_of_pos_left (pow_pos (by norm_num : (0 : ℝ) < 2) T)).mp
  calc
    _ = (2 : ℝ) ^ ((T : ℝ) + κ / 2 * (J : ℝ)) * (A.card : ℝ) := by
      rw [Real.rpow_add (by norm_num), Real.rpow_natCast]; ring
    _ ≤ (2 : ℝ) ^ (κ * (T : ℝ) * (N : ℝ)) * (A.card : ℝ) := by
      apply mul_le_mul_of_nonneg_right _ (Nat.cast_nonneg _)
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      have hm : (J : ℝ) ≤ (T : ℝ) * (N : ℝ) := by exact_mod_cast hJm
      nlinarith [mul_le_mul_of_nonneg_left hm hκ.le]
    _ ≤ _ := hh.trans hreduce

theorem one_le_projection_card_mul_mass {A : Finset ℕ} (hA : A.Nonempty) (j : ℕ) {M : ℝ}
    (hM : ∀ r : ℕ, natResidueMass A (2 ^ j) r ≤ M) :
    1 ≤ ((dyadicProjection A j).card : ℝ) * M := by
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast Finset.card_pos.mpr hA
  have hfiber : ∀ r ∈ dyadicProjection A j,
      ((A.filter (fun x => x % 2 ^ j = r)).card : ℝ) ≤ M * (A.card : ℝ) := by
    intro r hr
    have hh := (div_le_iff₀ hAp).mp (hM r)
    simpa only [natResidueFiber, Nat.ModEq,
      Nat.mod_eq_of_lt (dyadic_projection_bounded A j r hr)] using hh
  have hcard : (A.card : ℝ) ≤ ((dyadicProjection A j).card : ℝ) * (M * (A.card : ℝ)) := by
    conv_lhs => rw [Finset.card_eq_sum_card_image (fun x => x % 2 ^ j) A, Nat.cast_sum]
    calc
      _ ≤ ∑ _r ∈ dyadicProjection A j, M * (A.card : ℝ) := Finset.sum_le_sum hfiber
      _ = _ := by simp
  apply (mul_le_mul_iff_of_pos_right hAp).mp
  simpa only [one_mul, mul_assoc] using hcard

theorem dyadic_projection_growth_of_mass {A : Finset ℕ} (hA : A.Nonempty) (j : ℕ) {γ : ℝ}
    (hM : ∀ r : ℕ, natResidueMass A (2 ^ j) r ≤ (2 : ℝ) ^ (-γ * (j : ℝ))) :
    (2 : ℝ) ^ (γ * (j : ℝ)) ≤ ((dyadicProjection A j).card : ℝ) := by
  have hh := one_le_projection_card_mul_mass hA j hM
  have hinv : (2 : ℝ) ^ (-γ * (j : ℝ)) * (2 : ℝ) ^ (γ * (j : ℝ)) = 1 := by
    rw [← Real.rpow_add (by norm_num), show -γ * (j : ℝ) + γ * (j : ℝ) = 0 by ring, Real.rpow_zero]
  calc
    _ = 1 * (2 : ℝ) ^ (γ * (j : ℝ)) := (one_mul _).symm
    _ ≤ (((dyadicProjection A j).card : ℝ) * (2 : ℝ) ^ (-γ * (j : ℝ))) *
        (2 : ℝ) ^ (γ * (j : ℝ)) := mul_le_mul_of_nonneg_right hh (by positivity)
    _ = _ := by rw [mul_assoc, hinv, mul_one]

theorem exists_dyadic_signed_sum_product_growth_of_mass {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ κ ε : ℝ, 0 < κ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧
      ∃ K J₀ : ℕ, 0 < K ∧ ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset ℕ,
        A.Nonempty → (∀ x ∈ A, x < 2 ^ J) →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ j : ℕ, j ≤ J → ε * (J : ℝ) < (j : ℝ) → ∀ r : ℕ,
          natResidueMass A (2 ^ j) r ≤ (2 : ℝ) ^ (-γ * (j : ℝ))) →
        (2 : ℝ) ^ (κ * (J : ℝ)) * (A.card : ℝ) ≤
          ((natSignedResidueHull (natLinearQuadraticSet A) K (2 ^ J)).card : ℝ) := by
  obtain ⟨κ, ε, hκ, hε, hε4, K, J₀, hK, hgrowth⟩ := exists_dyadic_signed_sum_product_growth hγ hδ hδ1
  refine ⟨κ, ε, hκ, hε, hε4, K, J₀, hK, ?_⟩
  intro J hJ A hA hbound hsize hmass
  exact hgrowth J hJ A hA hbound hsize (fun j hj hεj =>
    dyadic_projection_growth_of_mass hA j (hmass j hj hεj))

open scoped Pointwise

def natResidueGenerators (E : Finset ℕ) (q : ℕ) : Finset (ZMod q) :=
  insert 0 (E.image (fun n : ℕ => (n : ZMod q)))

theorem nat_sumset_cast_image (A B : Finset ℕ) (q : ℕ) :
    (((A ×ˢ B).image (fun p => p.1 + p.2)).image (fun n : ℕ => (n : ZMod q))) =
      A.image (fun n : ℕ => (n : ZMod q)) + B.image (fun n : ℕ => (n : ZMod q)) := by
  ext z
  constructor
  · intro hz
    obtain ⟨n, hn, rfl⟩ := Finset.mem_image.mp hz
    obtain ⟨⟨a, b⟩, hab, rfl⟩ := Finset.mem_image.mp hn
    obtain ⟨ha, hb⟩ := Finset.mem_product.mp hab
    exact Finset.mem_add.mpr ⟨(a : ZMod q), Finset.mem_image_of_mem _ ha,
      (b : ZMod q), Finset.mem_image_of_mem _ hb, (Nat.cast_add a b).symm⟩
  · intro hz
    obtain ⟨x, hx, y, hy, rfl⟩ := Finset.mem_add.mp hz
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨b, hb, rfl⟩ := Finset.mem_image.mp hy
    exact Finset.mem_image.mpr ⟨a + b, Finset.mem_image.mpr
      ⟨(a, b), Finset.mem_product.mpr ⟨ha, hb⟩, rfl⟩, Nat.cast_add a b⟩

theorem nat_bounded_sums_cast_image (E : Finset ℕ) (K q : ℕ) :
    (natBoundedSums E K).image (fun n : ℕ => (n : ZMod q)) = K • natResidueGenerators E q := by
  induction K with
  | zero =>
    simp only [natBoundedSums, Finset.image_singleton, Nat.cast_zero, zero_nsmul]
    rfl
  | succ K ih =>
    rw [natBoundedSums, nat_sumset_cast_image, ih, succ_nsmul']
    simp only [Finset.image_insert, Nat.cast_zero, natResidueGenerators]

theorem nat_signed_residue_hull_eq_image (E : Finset ℕ) (K q : ℕ) :
    natSignedResidueHull E K q =
      (K • natResidueGenerators E q - K • natResidueGenerators E q).image ZMod.val := by
  rw [← nat_bounded_sums_cast_image]
  ext z
  constructor
  · intro hz
    obtain ⟨⟨p, n⟩, hpn, rfl⟩ := Finset.mem_image.mp hz
    obtain ⟨hp, hn⟩ := Finset.mem_product.mp hpn
    exact Finset.mem_image.mpr ⟨(p : ZMod q) - (n : ZMod q),
      Finset.mem_sub.mpr ⟨(p : ZMod q), Finset.mem_image_of_mem _ hp,
        (n : ZMod q), Finset.mem_image_of_mem _ hn, rfl⟩, rfl⟩
  · intro hz
    obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hz
    obtain ⟨p, hp, n, hn, rfl⟩ := Finset.mem_sub.mp hx
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hp
    obtain ⟨b, hb, rfl⟩ := Finset.mem_image.mp hn
    exact Finset.mem_image.mpr ⟨(a, b), Finset.mem_product.mpr ⟨ha, hb⟩, rfl⟩

theorem nat_signed_residue_hull_card (E : Finset ℕ) (K : ℕ) {q : ℕ} [NeZero q] :
    (natSignedResidueHull E K q).card =
      (K • natResidueGenerators E q - K • natResidueGenerators E q).card := by
  rw [nat_signed_residue_hull_eq_image, Finset.card_image_of_injective _ (ZMod.val_injective q)]

theorem nat_signed_hull_pluennecke_bound (E : Finset ℕ) (K : ℕ) {q : ℕ} [NeZero q] :
    ((natSignedResidueHull E K q).card : ℝ) ≤
      (((natResidueGenerators E q + natResidueGenerators E q).card : ℝ) /
        ((natResidueGenerators E q).card : ℝ)) ^ (2 * K) * ((natResidueGenerators E q).card : ℝ) := by
  have hF : (natResidueGenerators E q).Nonempty := ⟨0, Finset.mem_insert_self _ _⟩
  have hh := Finset.pluennecke_ruzsa_inequality_nsmul_sub_nsmul_add hF (natResidueGenerators E q) K K
  have hhR : ((K • natResidueGenerators E q - K • natResidueGenerators E q).card : ℝ) ≤
      (((natResidueGenerators E q + natResidueGenerators E q).card : ℝ) /
        ((natResidueGenerators E q).card : ℝ)) ^ (K + K) * ((natResidueGenerators E q).card : ℝ) := by
    have hhQ : ((K • natResidueGenerators E q - K • natResidueGenerators E q).card : ℚ) ≤
        (((natResidueGenerators E q + natResidueGenerators E q).card : ℚ) /
          ((natResidueGenerators E q).card : ℚ)) ^ (K + K) * ((natResidueGenerators E q).card : ℚ) := by
      exact_mod_cast (NNRat.coe_mono hh)
    have hhCast := (Rat.cast_le (K := ℝ)).mpr hhQ
    push_cast at hhCast
    exact hhCast
  simpa only [nat_signed_residue_hull_card, two_mul] using hhR

theorem nat_linear_quadratic_generators_card_ge {A : Finset ℕ} {q : ℕ} [NeZero q]
    (hbound : ∀ x ∈ A, x < q) :
    A.card ≤ (natResidueGenerators (natLinearQuadraticSet A) q).card := by
  have hinj : Set.InjOn (fun n : ℕ => (n : ZMod q)) A := by
    intro x hx y hy hxy
    have hh := congrArg ZMod.val hxy
    simpa only [ZMod.val_natCast, Nat.mod_eq_of_lt (hbound x hx), Nat.mod_eq_of_lt (hbound y hy)] using hh
  calc
    _ = (A.image (fun n : ℕ => (n : ZMod q))).card := (Finset.card_image_of_injOn hinj).symm
    _ ≤ _ := Finset.card_le_card (by
      intro x hx
      obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
      exact Finset.mem_insert_of_mem (Finset.mem_image_of_mem _ (Finset.mem_union_left _ ha)))

theorem nat_signed_hull_bound_of_double_bound (E : Finset ℕ) (K : ℕ) {q : ℕ} [NeZero q]
    {a L : ℝ} (ha : a ≤ ((natResidueGenerators E q).card : ℝ)) (hL : 0 ≤ L)
    (hdouble : ((natResidueGenerators E q + natResidueGenerators E q).card : ℝ) ≤ L * a) :
    ((natSignedResidueHull E K q).card : ℝ) ≤ L ^ (2 * K + 1) * a := by
  let F := natResidueGenerators E q
  have hF : F.Nonempty := ⟨0, Finset.mem_insert_self _ _⟩
  have hFp : (0 : ℝ) < F.card := by exact_mod_cast Finset.card_pos.mpr hF
  have hsub : F ⊆ F + F := by
    intro x hx
    exact Finset.mem_add.mpr ⟨x, hx, 0, Finset.mem_insert_self _ _, add_zero x⟩
  have hsize : (F.card : ℝ) ≤ L * a := (show (F.card : ℝ) ≤ (F + F).card by
    exact_mod_cast Finset.card_le_card hsub).trans hdouble
  have hratio : ((F + F).card : ℝ) / (F.card : ℝ) ≤ L :=
    (div_le_iff₀ hFp).mpr (hdouble.trans (mul_le_mul_of_nonneg_left ha hL))
  have hratio0 : 0 ≤ ((F + F).card : ℝ) / (F.card : ℝ) := by positivity
  calc
    _ ≤ (((F + F).card : ℝ) / (F.card : ℝ)) ^ (2 * K) * (F.card : ℝ) :=
      nat_signed_hull_pluennecke_bound E K
    _ ≤ L ^ (2 * K) * (F.card : ℝ) :=
      mul_le_mul_of_nonneg_right (pow_le_pow_left₀ hratio0 hratio _) hFp.le
    _ ≤ L ^ (2 * K) * (L * a) := mul_le_mul_of_nonneg_left hsize (pow_nonneg hL _)
    _ = _ := by rw [pow_succ]; ring

theorem exists_dyadic_sum_product_double_growth {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ σ ε : ℝ, 0 < σ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset ℕ,
        A.Nonempty → (∀ x ∈ A, x < 2 ^ J) →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ j : ℕ, j ≤ J → ε * (J : ℝ) < (j : ℝ) → ∀ r : ℕ,
          natResidueMass A (2 ^ j) r ≤ (2 : ℝ) ^ (-γ * (j : ℝ))) →
        (2 : ℝ) ^ (σ * (J : ℝ)) * (A.card : ℝ) ≤
          ((natResidueGenerators (natLinearQuadraticSet A) (2 ^ J) +
            natResidueGenerators (natLinearQuadraticSet A) (2 ^ J)).card : ℝ) := by
  obtain ⟨κ, ε, hκ, hε, hε4, K, J₀, hK, hgrowth⟩ :=
    exists_dyadic_signed_sum_product_growth_of_mass hγ hδ hδ1
  let σ := κ / (4 * (K : ℝ) + 2)
  have hden : 0 < 4 * (K : ℝ) + 2 := by positivity
  have hσ : 0 < σ := div_pos hκ hden
  have hexp : σ * ((2 * K + 1 : ℕ) : ℝ) = κ / 2 := by
    dsimp [σ]
    push_cast
    field_simp
    ring
  refine ⟨σ, ε, hσ, hε, hε4, max J₀ 1, ?_⟩
  intro J hJ A hA hbound hsize hmass
  have hJ₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hJ1 : 1 ≤ J := (le_max_right _ _).trans hJ
  have hJp : (0 : ℝ) < J := by exact_mod_cast (show 0 < J by omega)
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast Finset.card_pos.mpr hA
  by_contra h
  have hupper := nat_signed_hull_bound_of_double_bound (natLinearQuadraticSet A) K
    (q := 2 ^ J) (by exact_mod_cast nat_linear_quadratic_generators_card_ge hbound)
    (show 0 ≤ (2 : ℝ) ^ (σ * (J : ℝ)) by positivity) (lt_of_not_ge h).le
  have hpowlt : ((2 : ℝ) ^ (σ * (J : ℝ))) ^ (2 * K + 1) < (2 : ℝ) ^ (κ * (J : ℝ)) := by
    rw [← Real.rpow_mul_natCast (by norm_num)]
    apply Real.rpow_lt_rpow_of_exponent_lt (by norm_num)
    have hEq : σ * (J : ℝ) * ((2 * K + 1 : ℕ) : ℝ) = κ / 2 * (J : ℝ) := by
      rw [mul_right_comm, hexp]
    rw [hEq]
    nlinarith [mul_pos hκ hJp]
  exact (not_lt_of_ge (hgrowth J hJ₀ A hA hbound hsize hmass))
    (hupper.trans_lt (mul_lt_mul_of_pos_right hpowlt hAp))

theorem nat_productset_cast_image (A B : Finset ℕ) (q : ℕ) :
    (((A ×ˢ B).image (fun p => p.1 * p.2)).image (fun n : ℕ => (n : ZMod q))) =
      A.image (fun n : ℕ => (n : ZMod q)) * B.image (fun n : ℕ => (n : ZMod q)) := by
  ext z
  constructor
  · intro hz
    obtain ⟨n, hn, rfl⟩ := Finset.mem_image.mp hz
    obtain ⟨⟨a, b⟩, hab, rfl⟩ := Finset.mem_image.mp hn
    obtain ⟨ha, hb⟩ := Finset.mem_product.mp hab
    exact Finset.mem_mul.mpr ⟨(a : ZMod q), Finset.mem_image_of_mem _ ha,
      (b : ZMod q), Finset.mem_image_of_mem _ hb, (Nat.cast_mul a b).symm⟩
  · intro hz
    obtain ⟨x, hx, y, hy, rfl⟩ := Finset.mem_mul.mp hz
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨b, hb, rfl⟩ := Finset.mem_image.mp hy
    exact Finset.mem_image.mpr ⟨a * b, Finset.mem_image.mpr
      ⟨(a, b), Finset.mem_product.mpr ⟨ha, hb⟩, rfl⟩, Nat.cast_mul a b⟩

theorem nat_linear_quadratic_residue_generators (A : Finset ℕ) (q : ℕ) :
    natResidueGenerators (natLinearQuadraticSet A) q =
      insert 0 (A.image (fun n : ℕ => (n : ZMod q)) ∪
        A.image (fun n : ℕ => (n : ZMod q)) * A.image (fun n : ℕ => (n : ZMod q))) := by
  unfold natResidueGenerators natLinearQuadraticSet
  rw [Finset.image_union, nat_productset_cast_image]

theorem dyadic_projection_cast_image (A : Finset ℕ) (J : ℕ) :
    (dyadicProjection A J).image (fun n : ℕ => (n : ZMod (2 ^ J))) =
      A.image (fun n : ℕ => (n : ZMod (2 ^ J))) := by
  unfold dyadicProjection
  rw [Finset.image_image]
  apply Finset.image_congr
  intro n hn
  exact (ZMod.natCast_eq_natCast_iff' _ _ _).mpr (Nat.mod_mod n _)

theorem dyadic_projection_card_of_cast_inj {A : Finset ℕ} {J : ℕ}
    (hinj : Set.InjOn (fun n : ℕ => (n : ZMod (2 ^ J))) A) :
    (dyadicProjection A J).card = A.card := by
  apply Finset.card_image_of_injOn
  intro a ha b hb hab
  exact hinj ha hb ((ZMod.natCast_eq_natCast_iff' _ _ _).mpr hab)

theorem nat_residue_mass_dyadic_projection {A : Finset ℕ} {J j : ℕ}
    (hinj : Set.InjOn (fun n : ℕ => (n : ZMod (2 ^ J))) A) (hj : j ≤ J) (r : ℕ) :
    natResidueMass (dyadicProjection A J) (2 ^ j) r = natResidueMass A (2 ^ j) r := by
  have heq : natResidueFiber (dyadicProjection A J) (2 ^ j) r =
      (natResidueFiber A (2 ^ j) r).image (fun n => n % 2 ^ J) := by
    ext x
    constructor
    · intro hx
      obtain ⟨hxP, hxr⟩ := Finset.mem_filter.mp hx
      obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hxP
      have har : Nat.ModEq (2 ^ j) a r := by
        simpa only [Nat.ModEq, Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 hj)] using hxr
      exact Finset.mem_image.mpr ⟨a, Finset.mem_filter.mpr ⟨ha, har⟩, rfl⟩
    · intro hx
      obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
      obtain ⟨haA, har⟩ := Finset.mem_filter.mp ha
      refine Finset.mem_filter.mpr ⟨Finset.mem_image_of_mem _ haA, ?_⟩
      simpa only [Nat.ModEq, Nat.mod_mod_of_dvd _ (pow_dvd_pow 2 hj)] using har
  have hi : Set.InjOn (fun n : ℕ => n % 2 ^ J) (natResidueFiber A (2 ^ j) r) := by
    intro a ha b hb hab
    exact hinj (Finset.mem_filter.mp ha).1 (Finset.mem_filter.mp hb).1
      ((ZMod.natCast_eq_natCast_iff' _ _ _).mpr hab)
  unfold natResidueMass
  rw [heq, Finset.card_image_of_injOn hi, dyadic_projection_card_of_cast_inj hinj]

theorem dyadic_linear_quadratic_generators_projection (A : Finset ℕ) (J : ℕ) :
    natResidueGenerators (natLinearQuadraticSet (dyadicProjection A J)) (2 ^ J) =
      natResidueGenerators (natLinearQuadraticSet A) (2 ^ J) := by
  rw [nat_linear_quadratic_residue_generators, nat_linear_quadratic_residue_generators,
    dyadic_projection_cast_image]

theorem exists_dyadic_sum_product_double_growth_injective {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ σ ε : ℝ, 0 < σ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset ℕ, A.Nonempty →
        Set.InjOn (fun n : ℕ => (n : ZMod (2 ^ J))) A →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ j : ℕ, j ≤ J → ε * (J : ℝ) < (j : ℝ) → ∀ r : ℕ,
          natResidueMass A (2 ^ j) r ≤ (2 : ℝ) ^ (-γ * (j : ℝ))) →
        (2 : ℝ) ^ (σ * (J : ℝ)) * (A.card : ℝ) ≤
          ((natResidueGenerators (natLinearQuadraticSet A) (2 ^ J) +
            natResidueGenerators (natLinearQuadraticSet A) (2 ^ J)).card : ℝ) := by
  obtain ⟨σ, ε, hσ, hε, hε4, J₀, hgrowth⟩ := exists_dyadic_sum_product_double_growth hγ hδ hδ1
  refine ⟨σ, ε, hσ, hε, hε4, J₀, ?_⟩
  intro J hJ A hA hinj hsize hmass
  have hh := hgrowth J hJ (dyadicProjection A J) (hA.image _) (dyadic_projection_bounded A J)
    (by simpa only [dyadic_projection_card_of_cast_inj hinj] using hsize)
    (fun j hj hεj r => by rw [nat_residue_mass_dyadic_projection hinj hj]; exact hmass j hj hεj r)
  simpa only [dyadic_projection_card_of_cast_inj hinj, dyadic_linear_quadratic_generators_projection] using hh

theorem dyadic_large_subset_mass {A B : Finset ℕ} {J j : ℕ} {γ ε τ : ℝ}
    (hBA : B ⊆ A) (hB : B.Nonempty) (hγ : 0 < γ) (hτ : τ ≤ γ * ε / 2)
    (hlarge : (A.card : ℝ) ≤ (2 : ℝ) ^ (τ * (J : ℝ)) * (B.card : ℝ))
    (hj : ε * (J : ℝ) < (j : ℝ))
    (hmass : ∀ r : ℕ, natResidueMass A (2 ^ j) r ≤ (2 : ℝ) ^ (-γ * (j : ℝ))) :
    ∀ r : ℕ, natResidueMass B (2 ^ j) r ≤ (2 : ℝ) ^ (-(γ / 2) * (j : ℝ)) := by
  intro r
  calc
    _ ≤ (2 : ℝ) ^ (τ * (J : ℝ)) * natResidueMass A (2 ^ j) r :=
      nat_residue_mass_subset_le hBA hB hlarge _ _
    _ ≤ (2 : ℝ) ^ (τ * (J : ℝ)) * (2 : ℝ) ^ (-γ * (j : ℝ)) :=
      mul_le_mul_of_nonneg_left (hmass r) (by positivity)
    _ = (2 : ℝ) ^ (τ * (J : ℝ) - γ * (j : ℝ)) := by
      rw [← Real.rpow_add (by norm_num)]
      congr 1
      ring
    _ ≤ _ := by
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      have hh := mul_le_mul_of_nonneg_right hτ (Nat.cast_nonneg J : (0 : ℝ) ≤ J)
      have hh' := mul_lt_mul_of_pos_left hj hγ
      nlinarith

theorem exists_hereditary_dyadic_sum_product_growth {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ σ ε τ : ℝ, 0 < σ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ 0 < τ ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A B : Finset ℕ,
        B ⊆ A → B.Nonempty → Set.InjOn (fun n : ℕ => (n : ZMod (2 ^ J))) A →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (A.card : ℝ) ≤ (2 : ℝ) ^ (τ * (J : ℝ)) * (B.card : ℝ) →
        (∀ j : ℕ, j ≤ J → ε * (J : ℝ) < (j : ℝ) → ∀ r : ℕ,
          natResidueMass A (2 ^ j) r ≤ (2 : ℝ) ^ (-γ * (j : ℝ))) →
        (2 : ℝ) ^ (σ * (J : ℝ)) * (B.card : ℝ) ≤
          ((natResidueGenerators (natLinearQuadraticSet B) (2 ^ J) +
            natResidueGenerators (natLinearQuadraticSet B) (2 ^ J)).card : ℝ) := by
  obtain ⟨σ, ε, hσ, hε, hε4, J₀, hgrowth⟩ :=
    exists_dyadic_sum_product_double_growth_injective (show 0 < γ / 2 by positivity) hδ hδ1
  refine ⟨σ, ε, γ * ε / 4, hσ, hε, hε4, by positivity, J₀, ?_⟩
  intro J hJ A B hBA hB hinj hsize hlarge hmass
  apply hgrowth J hJ B hB (hinj.mono hBA)
  · exact (show (B.card : ℝ) ≤ A.card by exact_mod_cast Finset.card_le_card hBA).trans hsize
  · intro j hj hεj
    exact dyadic_large_subset_mass hBA hB hγ (by nlinarith [mul_pos hγ hε]) hlarge hεj (hmass j hj hεj)

/- Quantitative inverse energy via weighted translate selection and common-neighbor counting. -/

open scoped BigOperators Pointwise

section FiniteInverseEnergy
variable {G : Type*} [AddCommGroup G] [Fintype G] [DecidableEq G]

def finiteDifferenceFiber (A B : Finset G) (x : G) : Finset (G × G) :=
  (A ×ˢ B).filter (fun p => p.1 - p.2 = x)

def finiteDifferenceCount (A B : Finset G) (x : G) : ℕ :=
  (finiteDifferenceFiber A B x).card

def finiteDifferenceEnergy (A B : Finset G) : ℕ :=
  ∑ x : G, finiteDifferenceCount A B x ^ 2

def finiteShiftOverlap (A B : Finset G) (s : G) : Finset G :=
  A.filter (fun a => a - s ∈ B)

theorem finite_difference_count_eq_overlap (A B : Finset G) (s : G) :
    finiteDifferenceCount A B s = (finiteShiftOverlap A B s).card := by
  unfold finiteDifferenceCount finiteDifferenceFiber finiteShiftOverlap
  apply Finset.card_bij (fun p _ => p.1)
  · rintro ⟨a, b⟩ hp
    obtain ⟨⟨ha, hb⟩, hs⟩ := by simpa only [Finset.mem_filter, Finset.mem_product] using hp
    refine Finset.mem_filter.mpr ⟨ha, ?_⟩
    rw [← hs, sub_sub_cancel]
    exact hb
  · intro p hp q hq hpq
    apply Prod.ext hpq
    have hh := (Finset.mem_filter.mp hp).2.trans (Finset.mem_filter.mp hq).2.symm
    simpa only [hpq, sub_right_inj] using hh
  · intro a ha
    obtain ⟨haA, haB⟩ := Finset.mem_filter.mp ha
    exact ⟨(a, a - s), Finset.mem_filter.mpr
      ⟨Finset.mem_product.mpr ⟨haA, haB⟩, sub_sub_cancel a s⟩, rfl⟩

theorem finite_difference_count_le_right (A B : Finset G) (s : G) :
    finiteDifferenceCount A B s ≤ B.card := by
  apply Finset.card_le_card_of_injOn (fun p => p.2)
  · intro p hp
    exact (Finset.mem_product.mp (Finset.mem_filter.mp hp).1).2
  · intro p hp q hq hpq
    apply Prod.ext ?_ hpq
    have hh := (Finset.mem_filter.mp hp).2.trans (Finset.mem_filter.mp hq).2.symm
    simpa only [hpq, sub_left_inj] using hh

theorem finite_difference_count_sum (A B : Finset G) :
    ∑ s : G, finiteDifferenceCount A B s = A.card * B.card := by
  unfold finiteDifferenceCount finiteDifferenceFiber
  rw [← Finset.card_product]
  exact (Finset.card_eq_sum_card_fiberwise (f := fun p : G × G => p.1 - p.2)
    (t := Finset.univ) (fun _ _ => Finset.mem_univ _)).symm

theorem finite_difference_count_sum_real (A B : Finset G) :
    ∑ s : G, (finiteDifferenceCount A B s : ℝ) = (A.card : ℝ) * (B.card : ℝ) := by
  exact_mod_cast finite_difference_count_sum A B

theorem finite_difference_energy_sum_real (A B : Finset G) :
    ∑ s : G, (finiteDifferenceCount A B s : ℝ) ^ 2 = (finiteDifferenceEnergy A B : ℝ) := by
  unfold finiteDifferenceEnergy
  push_cast
  rfl

theorem finite_difference_cubic_moment (A B : Finset G) :
    (finiteDifferenceEnergy A B : ℝ) ^ 2 ≤
      ((A.card : ℝ) * (B.card : ℝ)) * ∑ s : G, (finiteDifferenceCount A B s : ℝ) ^ 3 := by
  let r := fun s => (finiteDifferenceCount A B s : ℝ)
  let f := fun s => Real.sqrt (r s)
  have hf (s : G) : f s ^ 2 = r s := Real.sq_sqrt (Nat.cast_nonneg _)
  have h₁ : ∑ s : G, f s ^ 2 = (A.card : ℝ) * (B.card : ℝ) := by
    simp_rw [hf]
    exact finite_difference_count_sum_real A B
  have h₂ : ∑ s : G, f s * (f s * r s) = (finiteDifferenceEnergy A B : ℝ) := by
    calc
      _ = ∑ s : G, r s ^ 2 := Finset.sum_congr rfl (fun s _ => by
        calc _ = f s ^ 2 * r s := by ring
             _ = r s ^ 2 := by rw [hf]; ring)
      _ = _ := finite_difference_energy_sum_real A B
  have h₃ : ∑ s : G, (f s * r s) ^ 2 = ∑ s : G, r s ^ 3 := by
    apply Finset.sum_congr rfl
    intro s hs
    rw [mul_pow, hf]
    ring
  have hh := Finset.sum_mul_sq_le_sq_mul_sq Finset.univ f (fun s => f s * r s)
  rwa [h₁, h₂, h₃] at hh

theorem finite_common_shift_count (B : Finset G) (a b : G) :
    (Finset.univ.filter (fun s : G => a - s ∈ B ∧ b - s ∈ B)).card =
      finiteDifferenceCount B B (a - b) := by
  unfold finiteDifferenceCount finiteDifferenceFiber
  apply Finset.card_bij (fun s _ => (a - s, b - s))
  · intro s hs
    obtain ⟨ha, hb⟩ := (Finset.mem_filter.mp hs).2
    exact Finset.mem_filter.mpr ⟨Finset.mem_product.mpr ⟨ha, hb⟩, sub_sub_sub_cancel_right a b s⟩
  · intro s hs t ht hst
    simpa only [Prod.mk.injEq, sub_right_inj, and_self] using hst
  · rintro ⟨c, d⟩ hp
    obtain ⟨⟨hc, hd⟩, hcd⟩ := by simpa only [Finset.mem_filter, Finset.mem_product] using hp
    have heq : b - (a - c) = d := by
      rw [(sub_eq_iff_eq_add).mp hcd]
      abel
    refine ⟨a - c, Finset.mem_filter.mpr ⟨Finset.mem_univ _, ?_⟩, ?_⟩
    · simpa only [sub_sub_cancel, heq] using And.intro hc hd
    · simp only [sub_sub_cancel, heq]

def finiteShiftPairCount (B : Finset G) (H : Finset (G × G)) (s : G) : ℕ :=
  (H.filter (fun p => p.1 - s ∈ B ∧ p.2 - s ∈ B)).card

theorem finite_shift_pair_count_sum (B : Finset G) (H : Finset (G × G)) :
    ∑ s : G, finiteShiftPairCount B H s =
      ∑ p ∈ H, finiteDifferenceCount B B (p.1 - p.2) := by
  unfold finiteShiftPairCount
  simp_rw [Finset.card_eq_sum_ones, Finset.sum_filter]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro p hp
  simpa only [Finset.card_eq_sum_ones, Finset.sum_filter] using finite_common_shift_count B p.1 p.2

theorem finite_weighted_shift_pair_bound (A B : Finset G) (H : Finset (G × G)) :
    ∑ s : G, (finiteDifferenceCount A B s : ℝ) * (finiteShiftPairCount B H s : ℝ) ≤
      (B.card : ℝ) * ∑ p ∈ H, (finiteDifferenceCount B B (p.1 - p.2) : ℝ) := by
  calc
    _ ≤ ∑ s : G, (B.card : ℝ) * (finiteShiftPairCount B H s : ℝ) := by
      apply Finset.sum_le_sum
      intro s hs
      exact mul_le_mul_of_nonneg_right (by exact_mod_cast finite_difference_count_le_right A B s)
        (Nat.cast_nonneg _)
    _ = _ := by
      rw [← Finset.mul_sum]
      congr 1
      exact_mod_cast finite_shift_pair_count_sum B H

theorem finite_difference_energy_eq_card (A B : Finset G) :
    finiteDifferenceEnergy A B =
      (((A ×ˢ B) ×ˢ (A ×ˢ B)).filter
        (fun p => p.1.1 - p.1.2 = p.2.1 - p.2.2)).card := by
  let Q := (((A ×ˢ B) ×ˢ (A ×ˢ B)).filter
    (fun p => p.1.1 - p.1.2 = p.2.1 - p.2.2))
  have hf (x : G) : Q.filter (fun p => p.1.1 - p.1.2 = x) =
      finiteDifferenceFiber A B x ×ˢ finiteDifferenceFiber A B x := by
    ext p
    simp only [Q, finiteDifferenceFiber, Finset.mem_filter, Finset.mem_product]
    aesop
  calc
    _ = ∑ x : G, (finiteDifferenceFiber A B x ×ˢ finiteDifferenceFiber A B x).card := by
      simp only [finiteDifferenceEnergy, finiteDifferenceCount, Finset.card_product, pow_two]
    _ = ∑ x : G, (Q.filter (fun p => p.1.1 - p.1.2 = x)).card := by simp only [hf]
    _ = Q.card := (Finset.card_eq_sum_card_fiberwise
      (f := fun p : (G × G) × (G × G) => p.1.1 - p.1.2)
      (t := Finset.univ) (fun _ _ => Finset.mem_univ _)).symm

theorem finite_difference_energy_eq_addEnergy (A B : Finset G) :
    finiteDifferenceEnergy A B = Finset.addEnergy A B := by
  rw [finite_difference_energy_eq_card]
  unfold Finset.addEnergy
  apply Finset.card_bij (fun p _ => ((p.1.1, p.2.1), (p.2.2, p.1.2)))
  · intro p hp
    simpa only [Finset.mem_filter, Finset.mem_product, sub_eq_sub_iff_add_eq_add, and_assoc] using
      (show (p.1.1 ∈ A ∧ p.2.1 ∈ A) ∧ (p.2.2 ∈ B ∧ p.1.2 ∈ B) ∧
          p.1.1 - p.1.2 = p.2.1 - p.2.2 from by
        simpa only [Finset.mem_filter, Finset.mem_product, and_assoc, and_left_comm, and_comm] using hp)
  · intro p hp q hq hpq
    aesop
  · intro p hp
    refine ⟨((p.1.1, p.2.2), (p.1.2, p.2.1)), ?_, by simp⟩
    simpa only [Finset.mem_filter, Finset.mem_product, sub_eq_sub_iff_add_eq_add,
      and_assoc, and_left_comm, and_comm] using hp

theorem finite_energy_lower_cubic {A B : Finset G} {K : ℝ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hK : 0 ≤ K)
    (hE : (A.card : ℝ) ^ 2 * (B.card : ℝ) ≤ K * (finiteDifferenceEnergy A B : ℝ)) :
    (A.card : ℝ) ^ 3 * (B.card : ℝ) ≤
      K ^ 2 * ∑ s : G, (finiteDifferenceCount A B s : ℝ) ^ 3 := by
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  have hBp : (0 : ℝ) < B.card := by exact_mod_cast hB.card_pos
  have hsq := pow_le_pow_left₀ (by positivity : (0 : ℝ) ≤ (A.card : ℝ) ^ 2 * B.card) hE 2
  have hmoment := mul_le_mul_of_nonneg_left (finite_difference_cubic_moment A B)
    (sq_nonneg K)
  apply (mul_le_mul_iff_left₀ (mul_pos hAp hBp)).mp
  calc
    _ = ((A.card : ℝ) ^ 2 * (B.card : ℝ)) ^ 2 := by ring
    _ ≤ (K * (finiteDifferenceEnergy A B : ℝ)) ^ 2 := hsq
    _ = K ^ 2 * (finiteDifferenceEnergy A B : ℝ) ^ 2 := mul_pow _ _ _
    _ ≤ _ := hmoment
    _ = _ := by ring

theorem finite_weighted_bad_pair_bound {A B : Finset G} {H : Finset (G × G)} {K : ℝ}
    (hH : H ⊆ A ×ˢ A)
    (hbad : ∀ p ∈ H, 16 * K ^ 2 * (finiteDifferenceCount B B (p.1 - p.2) : ℝ) ≤ A.card) :
    16 * K ^ 2 *
        (∑ s : G, (finiteDifferenceCount A B s : ℝ) * (finiteShiftPairCount B H s : ℝ)) ≤
      (A.card : ℝ) ^ 3 * (B.card : ℝ) := by
  have hcard : (H.card : ℝ) ≤ (A.card : ℝ) ^ 2 := by
    exact_mod_cast (Finset.card_le_card hH).trans_eq (by simp [pow_two])
  calc
    _ ≤ 16 * K ^ 2 * ((B.card : ℝ) * ∑ p ∈ H,
        (finiteDifferenceCount B B (p.1 - p.2) : ℝ)) :=
      mul_le_mul_of_nonneg_left (finite_weighted_shift_pair_bound A B H) (by positivity)
    _ = (B.card : ℝ) * ∑ p ∈ H, 16 * K ^ 2 * (finiteDifferenceCount B B (p.1 - p.2) : ℝ) := by
      rw [← Finset.mul_sum]
      ring
    _ ≤ (B.card : ℝ) * ∑ _p ∈ H, (A.card : ℝ) :=
      mul_le_mul_of_nonneg_left (Finset.sum_le_sum hbad) (Nat.cast_nonneg _)
    _ = (B.card : ℝ) * ((H.card : ℝ) * (A.card : ℝ)) := by simp
    _ ≤ (B.card : ℝ) * ((A.card : ℝ) ^ 2 * (A.card : ℝ)) := by gcongr
    _ = _ := by ring

theorem finite_exists_good_shift {A B : Finset G} {H : Finset (G × G)} {K : ℝ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hK : 0 ≤ K)
    (hE : (A.card : ℝ) ^ 2 * (B.card : ℝ) ≤ K * (finiteDifferenceEnergy A B : ℝ))
    (hH : H ⊆ A ×ˢ A)
    (hbad : ∀ p ∈ H, 16 * K ^ 2 * (finiteDifferenceCount B B (p.1 - p.2) : ℝ) ≤ A.card) :
    ∃ s : G, (A.card : ℝ) ^ 2 + 16 * K ^ 2 * (finiteShiftPairCount B H s : ℝ) ≤
      2 * K ^ 2 * ((finiteShiftOverlap A B s).card : ℝ) ^ 2 := by
  have htotal :
      (∑ s : G, (finiteDifferenceCount A B s : ℝ) *
        ((A.card : ℝ) ^ 2 + 16 * K ^ 2 * (finiteShiftPairCount B H s : ℝ))) ≤
      ∑ s : G, (finiteDifferenceCount A B s : ℝ) *
        (2 * K ^ 2 * ((finiteShiftOverlap A B s).card : ℝ) ^ 2) := by
    calc
      _ = (A.card : ℝ) ^ 3 * (B.card : ℝ) + 16 * K ^ 2 *
          (∑ s : G, (finiteDifferenceCount A B s : ℝ) * (finiteShiftPairCount B H s : ℝ)) := by
        simp only [mul_add, Finset.sum_add_distrib]
        rw [← Finset.sum_mul, finite_difference_count_sum_real]
        have heq : (∑ s : G, (finiteDifferenceCount A B s : ℝ) *
            (16 * K ^ 2 * (finiteShiftPairCount B H s : ℝ))) =
            16 * K ^ 2 * ∑ s : G, (finiteDifferenceCount A B s : ℝ) * (finiteShiftPairCount B H s : ℝ) := by
          rw [Finset.mul_sum]
          apply Finset.sum_congr rfl
          intro s hs
          ring
        rw [heq]
        ring
      _ ≤ 2 * ((A.card : ℝ) ^ 3 * (B.card : ℝ)) := by
        linarith [finite_weighted_bad_pair_bound hH hbad]
      _ ≤ 2 * (K ^ 2 * ∑ s : G, (finiteDifferenceCount A B s : ℝ) ^ 3) :=
        mul_le_mul_of_nonneg_left (finite_energy_lower_cubic hA hB hK hE) (by norm_num)
      _ = _ := by
        rw [← mul_assoc, Finset.mul_sum]
        apply Finset.sum_congr rfl
        intro s hs
        rw [← finite_difference_count_eq_overlap]
        ring
  by_contra! hn
  apply not_lt_of_ge htotal
  apply Finset.sum_lt_sum
  · intro s hs
    exact mul_le_mul_of_nonneg_left (hn s).le (Nat.cast_nonneg _)
  · obtain ⟨a, ha⟩ := hA
    obtain ⟨b, hb⟩ := hB
    have hpos : (0 : ℝ) < finiteDifferenceCount A B (a - b) := by
      exact_mod_cast (Finset.card_pos.mpr
        ⟨(a, b), Finset.mem_filter.mpr ⟨Finset.mem_product.mpr ⟨ha, hb⟩, rfl⟩⟩ :
          0 < (finiteDifferenceFiber A B (a - b)).card)
    exact ⟨a - b, Finset.mem_univ _, mul_lt_mul_of_pos_left (hn _) hpos⟩

theorem finite_energy_dense_overlap {A B : Finset G} {K : ℝ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hK : 0 < K)
    (hE : (A.card : ℝ) ^ 2 * (B.card : ℝ) ≤ K * (Finset.addEnergy A B : ℝ)) :
    ∃ s : G, (A.card : ℝ) / (2 * K) ≤ ((finiteShiftOverlap A B s).card : ℝ) ∧
      (7 / 8 : ℝ) * ((finiteShiftOverlap A B s).card : ℝ) ^ 2 ≤
        (((finiteShiftOverlap A B s ×ˢ finiteShiftOverlap A B s).filter
          (fun p => (A.card : ℝ) ≤ 16 * K ^ 2 *
            (finiteDifferenceCount B B (p.1 - p.2) : ℝ))).card : ℝ) := by
  classical
  let P := fun p : G × G => (A.card : ℝ) ≤
    16 * K ^ 2 * (finiteDifferenceCount B B (p.1 - p.2) : ℝ)
  let H := (A ×ˢ A).filter (fun p => ¬ P p)
  have hbad : ∀ p ∈ H, 16 * K ^ 2 * (finiteDifferenceCount B B (p.1 - p.2) : ℝ) ≤ A.card := by
    intro p hp
    exact (lt_of_not_ge (Finset.mem_filter.mp hp).2).le
  obtain ⟨s, hs⟩ := finite_exists_good_shift hA hB hK.le
    (by rwa [finite_difference_energy_eq_addEnergy]) (Finset.filter_subset _ _) hbad
  let X := finiteShiftOverlap A B s
  have hbadEq : finiteShiftPairCount B H s = ((X ×ˢ X).filter (fun p => ¬ P p)).card := by
    unfold finiteShiftPairCount
    congr 1
    ext p
    simp only [H, X, finiteShiftOverlap, Finset.mem_filter, Finset.mem_product]
    aesop
  have hpart : (((X ×ˢ X).filter P).card : ℝ) + (finiteShiftPairCount B H s : ℝ) = (X.card : ℝ) ^ 2 := by
    rw [hbadEq]
    exact_mod_cast (Finset.card_filter_add_card_filter_not (s := X ×ˢ X) P).trans
      (by simp [pow_two])
  have hs' : (A.card : ℝ) ^ 2 ≤ 2 * K ^ 2 * (X.card : ℝ) ^ 2 :=
    (le_add_of_nonneg_right (by positivity)).trans hs
  have hsize : (A.card : ℝ) ≤ 2 * K * (X.card : ℝ) := by
    apply (sq_le_sq₀ (Nat.cast_nonneg _) (by positivity)).mp
    nlinarith [sq_nonneg (K * (X.card : ℝ))]
  have hbadSmall : 8 * (finiteShiftPairCount B H s : ℝ) ≤ (X.card : ℝ) ^ 2 := by
    apply (mul_le_mul_iff_left₀ (show 0 < 2 * K ^ 2 by positivity)).mp
    nlinarith [sq_nonneg (A.card : ℝ)]
  refine ⟨s, (div_le_iff₀ (by positivity)).mpr (by nlinarith [hsize]), ?_⟩
  change (7 / 8 : ℝ) * (X.card : ℝ) ^ 2 ≤ (((X ×ˢ X).filter P).card : ℝ)
  nlinarith

def finiteGraphRow (X : Finset G) (H : Finset (G × G)) (a : G) : Finset G :=
  X.filter (fun b => (a, b) ∈ H)

noncomputable def finiteGraphCore (X : Finset G) (H : Finset (G × G)) : Finset G := by
  classical
  exact X.filter (fun a => (3 / 4 : ℝ) * (X.card : ℝ) ≤ (finiteGraphRow X H a).card)

theorem finite_graph_row_fiber {X : Finset G} {H : Finset (G × G)}
    (hH : H ⊆ X ×ˢ X) (a : G) :
    (H.filter (fun p => p.1 = a)).card = (finiteGraphRow X H a).card := by
  apply Finset.card_bij (fun p _ => p.2)
  · intro p hp
    obtain ⟨hpH, hpa⟩ := Finset.mem_filter.mp hp
    exact Finset.mem_filter.mpr ⟨(Finset.mem_product.mp (hH hpH)).2, by simpa only [← hpa] using hpH⟩
  · intro p hp q hq hpq
    exact Prod.ext ((Finset.mem_filter.mp hp).2.trans (Finset.mem_filter.mp hq).2.symm) hpq
  · intro b hb
    exact ⟨(a, b), Finset.mem_filter.mpr ⟨(Finset.mem_filter.mp hb).2, rfl⟩, rfl⟩

theorem finite_graph_row_sum {X : Finset G} {H : Finset (G × G)}
    (hH : H ⊆ X ×ˢ X) :
    ∑ a ∈ X, (finiteGraphRow X H a).card = H.card := by
  simp_rw [← finite_graph_row_fiber hH]
  exact (Finset.card_eq_sum_card_fiberwise (f := Prod.fst)
    (fun _ hp => (Finset.mem_product.mp (hH hp)).1)).symm

theorem finite_graph_core_card {X : Finset G} {H : Finset (G × G)}
    (hH : H ⊆ X ×ˢ X) (hdense : (7 / 8 : ℝ) * (X.card : ℝ) ^ 2 ≤ H.card) :
    (X.card : ℝ) / 8 ≤ (finiteGraphCore X H).card := by
  classical
  let C := finiteGraphCore X H
  have hCX : C ⊆ X := Finset.filter_subset _ _
  have hrow : ∀ a ∈ X, ((finiteGraphRow X H a).card : ℝ) ≤
      (3 / 4 : ℝ) * (X.card : ℝ) + if a ∈ C then (X.card : ℝ) else 0 := by
    intro a ha
    by_cases hc : a ∈ C
    · rw [if_pos hc]
      have hh : ((finiteGraphRow X H a).card : ℝ) ≤ X.card := by
        exact_mod_cast Finset.card_le_card (Finset.filter_subset _ _)
      nlinarith [show (0 : ℝ) ≤ X.card from Nat.cast_nonneg _]
    · rw [if_neg hc, add_zero]
      have hn : ¬ (3 / 4 : ℝ) * (X.card : ℝ) ≤ (finiteGraphRow X H a).card := by
        intro hh
        exact hc (Finset.mem_filter.mpr ⟨ha, hh⟩)
      exact (lt_of_not_ge hn).le
  have hbound : (H.card : ℝ) ≤ (3 / 4 : ℝ) * (X.card : ℝ) ^ 2 + (C.card : ℝ) * (X.card : ℝ) := by
    calc
      _ = ∑ a ∈ X, ((finiteGraphRow X H a).card : ℝ) := by
        exact_mod_cast (finite_graph_row_sum hH).symm
      _ ≤ ∑ a ∈ X, ((3 / 4 : ℝ) * (X.card : ℝ) + if a ∈ C then (X.card : ℝ) else 0) :=
        Finset.sum_le_sum hrow
      _ = _ := by
        rw [Finset.sum_add_distrib, ← Finset.sum_filter, Finset.filter_mem_eq_inter,
          Finset.inter_eq_right.mpr hCX]
        simp only [Finset.sum_const, nsmul_eq_mul]
        ring
  by_cases hX : X.card = 0
  · simp only [hX, Nat.cast_zero, zero_div]
    positivity
  · have hXp : (0 : ℝ) < X.card := by exact_mod_cast Nat.pos_of_ne_zero hX
    apply (mul_le_mul_iff_left₀ hXp).mp
    nlinarith

theorem finite_graph_core_common {X : Finset G} {H : Finset (G × G)} {a b : G}
    (ha : a ∈ finiteGraphCore X H) (hb : b ∈ finiteGraphCore X H) :
    (X.card : ℝ) / 2 ≤ ((finiteGraphRow X H a ∩ finiteGraphRow X H b).card : ℝ) := by
  have ha' := (Finset.mem_filter.mp ha).2
  have hb' := (Finset.mem_filter.mp hb).2
  have hu : (finiteGraphRow X H a ∪ finiteGraphRow X H b) ⊆ X :=
    Finset.union_subset (Finset.filter_subset _ _) (Finset.filter_subset _ _)
  have huc : ((finiteGraphRow X H a ∪ finiteGraphRow X H b).card : ℝ) ≤ X.card := by
    exact_mod_cast Finset.card_le_card hu
  have hh : ((finiteGraphRow X H a ∪ finiteGraphRow X H b).card : ℝ) +
      ((finiteGraphRow X H a ∩ finiteGraphRow X H b).card : ℝ) =
      ((finiteGraphRow X H a).card : ℝ) + ((finiteGraphRow X H b).card : ℝ) := by
    exact_mod_cast Finset.card_union_add_card_inter (finiteGraphRow X H a) (finiteGraphRow X H b)
  nlinarith

def finiteQuadDifferenceFiber (B : Finset G) (x : G) : Finset ((G × G) × (G × G)) :=
  ((B ×ˢ B) ×ˢ (B ×ˢ B)).filter (fun p => (p.1.1 - p.1.2) - (p.2.1 - p.2.2) = x)

theorem finite_quad_difference_sum (B : Finset G) :
    ∑ x : G, (finiteQuadDifferenceFiber B x).card = B.card ^ 4 := by
  unfold finiteQuadDifferenceFiber
  calc
    _ = ((B ×ˢ B) ×ˢ (B ×ˢ B)).card :=
      (Finset.card_eq_sum_card_fiberwise
        (f := fun p : (G × G) × (G × G) => (p.1.1 - p.1.2) - (p.2.1 - p.2.2))
        (t := Finset.univ) (fun _ _ => Finset.mem_univ _)).symm
    _ = _ := by simp only [Finset.card_product]; ring

theorem finite_common_neighbors_inject_quad (B C : Finset G) (a b : G) :
    (C.sigma (fun c => finiteDifferenceFiber B B (a - c) ×ˢ finiteDifferenceFiber B B (b - c))).card ≤
      (finiteQuadDifferenceFiber B (a - b)).card := by
  apply Finset.card_le_card_of_injOn (fun p : Σ _c : G, (G × G) × (G × G) => p.2)
  · intro p hp
    obtain ⟨hc, hp'⟩ := Finset.mem_sigma.mp hp
    obtain ⟨hu, hv⟩ := Finset.mem_product.mp hp'
    obtain ⟨huB, hue⟩ := Finset.mem_filter.mp hu
    obtain ⟨hvB, hve⟩ := Finset.mem_filter.mp hv
    exact Finset.mem_filter.mpr ⟨Finset.mem_product.mpr ⟨huB, hvB⟩,
      by rw [hue, hve, sub_sub_sub_cancel_right]⟩
  · intro p hp q hq hpq
    dsimp only at hpq
    have hp₁ := (Finset.mem_filter.mp (Finset.mem_product.mp (Finset.mem_sigma.mp hp).2).1).2
    have hq₁ := (Finset.mem_filter.mp (Finset.mem_product.mp (Finset.mem_sigma.mp hq).2).1).2
    have heq : a - p.1 = a - q.1 := by
      rw [← hp₁, ← hq₁, hpq]
    have hpq₁ : p.1 = q.1 := sub_right_injective heq
    exact Sigma.ext hpq₁ (heq_of_eq hpq)

theorem finite_graph_core_quad_lower {X B : Finset G} {H : Finset (G × G)} {a b : G} {L : ℝ}
    (hL : 0 ≤ L) (ha : a ∈ finiteGraphCore X H) (hb : b ∈ finiteGraphCore X H)
    (hrep : ∀ p ∈ H, L ≤ (finiteDifferenceCount B B (p.1 - p.2) : ℝ)) :
    (X.card : ℝ) / 2 * L ^ 2 ≤ (finiteQuadDifferenceFiber B (a - b)).card := by
  let C := finiteGraphRow X H a ∩ finiteGraphRow X H b
  calc
    _ ≤ (C.card : ℝ) * L ^ 2 :=
      mul_le_mul_of_nonneg_right (finite_graph_core_common ha hb) (sq_nonneg L)
    _ = ∑ _c ∈ C, L ^ 2 := by simp
    _ ≤ ∑ c ∈ C, ((finiteDifferenceFiber B B (a - c) ×ˢ finiteDifferenceFiber B B (b - c)).card : ℝ) := by
      apply Finset.sum_le_sum
      intro c hc
      obtain ⟨hca, hcb⟩ := Finset.mem_inter.mp hc
      have h₁ := hrep (a, c) (Finset.mem_filter.mp hca).2
      have h₂ := hrep (b, c) (Finset.mem_filter.mp hcb).2
      simpa only [Finset.card_product, Nat.cast_mul, pow_two, finiteDifferenceCount] using
        mul_le_mul h₁ h₂ hL (Nat.cast_nonneg _)
    _ = ((C.sigma (fun c => finiteDifferenceFiber B B (a - c) ×ˢ finiteDifferenceFiber B B (b - c))).card : ℝ) := by
      rw [Finset.card_sigma, Nat.cast_sum]
    _ ≤ _ := by exact_mod_cast finite_common_neighbors_inject_quad B C a b

theorem finite_graph_core_difference_bound {X B : Finset G} {H : Finset (G × G)} {L : ℝ}
    (hL : 0 ≤ L)
    (hrep : ∀ p ∈ H, L ≤ (finiteDifferenceCount B B (p.1 - p.2) : ℝ)) :
    ((finiteGraphCore X H - finiteGraphCore X H).card : ℝ) * ((X.card : ℝ) / 2 * L ^ 2) ≤
      (B.card : ℝ) ^ 4 := by
  let C := finiteGraphCore X H
  calc
    _ = ∑ _x ∈ C - C, (X.card : ℝ) / 2 * L ^ 2 := by simp [C]
    _ ≤ ∑ x ∈ C - C, ((finiteQuadDifferenceFiber B x).card : ℝ) := by
      apply Finset.sum_le_sum
      intro x hx
      obtain ⟨a, ha, b, hb, rfl⟩ := Finset.mem_sub.mp hx
      exact finite_graph_core_quad_lower hL ha hb hrep
    _ ≤ ∑ x : G, ((finiteQuadDifferenceFiber B x).card : ℝ) :=
      Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) (fun _ _ _ => Nat.cast_nonneg _)
    _ = _ := by exact_mod_cast finite_quad_difference_sum B

/-- A quantitative inverse-energy theorem for two sets in any finite abelian group.
The extracted set lies in a translate overlap and has a controlled difference set. -/
theorem finite_bsg_overlap {A B : Finset G} {K : ℝ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hK : 0 < K)
    (hE : (A.card : ℝ) ^ 2 * (B.card : ℝ) ≤ K * (Finset.addEnergy A B : ℝ)) :
    ∃ s : G, ∃ C : Finset G, C ⊆ finiteShiftOverlap A B s ∧
      (A.card : ℝ) ≤ 16 * K * (C.card : ℝ) ∧
      (A.card : ℝ) ^ 3 * ((C - C).card : ℝ) ≤ 1024 * K ^ 5 * (B.card : ℝ) ^ 4 := by
  classical
  obtain ⟨s, hlarge, hdense⟩ := finite_energy_dense_overlap hA hB hK hE
  let X := finiteShiftOverlap A B s
  let H := (X ×ˢ X).filter (fun p => (A.card : ℝ) ≤
    16 * K ^ 2 * (finiteDifferenceCount B B (p.1 - p.2) : ℝ))
  let C := finiteGraphCore X H
  have hH : H ⊆ X ×ˢ X := Finset.filter_subset _ _
  have hcore : (X.card : ℝ) / 8 ≤ (C.card : ℝ) := finite_graph_core_card hH hdense
  have hrep : ∀ p ∈ H, (A.card : ℝ) / (16 * K ^ 2) ≤
      (finiteDifferenceCount B B (p.1 - p.2) : ℝ) := by
    intro p hp
    exact (div_le_iff₀ (by positivity)).mpr (by
      simpa only [mul_comm] using (Finset.mem_filter.mp hp).2)
  have hdiff := finite_graph_core_difference_bound
    (X := X) (B := B) (H := H) (by positivity : (0 : ℝ) ≤ (A.card : ℝ) / (16 * K ^ 2)) hrep
  have hpref : (A.card : ℝ) ^ 3 / (1024 * K ^ 5) ≤
      (X.card : ℝ) / 2 * ((A.card : ℝ) / (16 * K ^ 2)) ^ 2 := by
    calc
      _ = ((A.card : ℝ) / (2 * K)) / 2 * ((A.card : ℝ) / (16 * K ^ 2)) ^ 2 := by
        field_simp
        ring
      _ ≤ _ := mul_le_mul_of_nonneg_right (div_le_div_of_nonneg_right hlarge (by norm_num)) (by positivity)
  have hdiff' : ((C - C).card : ℝ) * ((A.card : ℝ) ^ 3 / (1024 * K ^ 5)) ≤ (B.card : ℝ) ^ 4 :=
    (mul_le_mul_of_nonneg_left hpref (Nat.cast_nonneg _)).trans hdiff
  refine ⟨s, C, Finset.filter_subset _ _, ?_, ?_⟩
  · have hh : (A.card : ℝ) / (16 * K) ≤ (C.card : ℝ) := by
      calc
        _ = ((A.card : ℝ) / (2 * K)) / 8 := by ring
        _ ≤ (X.card : ℝ) / 8 := div_le_div_of_nonneg_right hlarge (by norm_num)
        _ ≤ _ := hcore
    have hh' := (div_le_iff₀ (show 0 < 16 * K by positivity)).mp hh
    nlinarith
  · rw [← mul_div_assoc] at hdiff'
    have hh := (div_le_iff₀ (show 0 < 1024 * K ^ 5 by positivity)).mp hdiff'
    nlinarith

/-- Self-energy at least `|A|³/K` yields a subset of size at least `|A|/(16K)`
whose difference set is bounded by an explicit power of `K`. -/
theorem finite_bsg_self {A : Finset G} {K : ℝ}
    (hA : A.Nonempty) (hK : 0 < K)
    (hE : (A.card : ℝ) ^ 3 ≤ K * (Finset.addEnergy A A : ℝ)) :
    ∃ C : Finset G, C ⊆ A ∧ C.Nonempty ∧
      (A.card : ℝ) ≤ 16 * K * (C.card : ℝ) ∧
      ((C - C).card : ℝ) ≤ 16384 * K ^ 6 * (C.card : ℝ) := by
  obtain ⟨s, C, hCA, hsize, hdiff⟩ := finite_bsg_overlap hA hA hK (by nlinarith [hE])
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  have hCp : (0 : ℝ) < C.card := by
    by_contra hn
    have hc : (C.card : ℝ) = 0 := le_antisymm (le_of_not_gt hn) (Nat.cast_nonneg _)
    rw [hc, mul_zero] at hsize
    exact not_le_of_gt hAp hsize
  refine ⟨C, hCA.trans (Finset.filter_subset _ _), by exact_mod_cast Finset.card_pos.mp (show 0 < C.card by exact_mod_cast hCp), hsize, ?_⟩
  have hdiff' : ((C - C).card : ℝ) ≤ 1024 * K ^ 5 * (A.card : ℝ) := by
    apply (mul_le_mul_iff_right₀ (show (0 : ℝ) < (A.card : ℝ) ^ 3 by positivity)).mp
    calc
      _ ≤ 1024 * K ^ 5 * (A.card : ℝ) ^ 4 := hdiff
      _ = _ := by ring
  calc
    _ ≤ 1024 * K ^ 5 * (A.card : ℝ) := hdiff'
    _ ≤ 1024 * K ^ 5 * (16 * K * (C.card : ℝ)) :=
      mul_le_mul_of_nonneg_left hsize (by positivity)
    _ = _ := by ring

theorem finite_sub_translated_image (C : Finset G) (s : G) :
    C - C.image (fun x => x - s) = (C - C).image (fun x => x + s) := by
  ext z
  constructor
  · intro hz
    obtain ⟨a, ha, y, hy, rfl⟩ := Finset.mem_sub.mp hz
    obtain ⟨b, hb, rfl⟩ := Finset.mem_image.mp hy
    exact Finset.mem_image.mpr ⟨a - b, Finset.mem_sub.mpr ⟨a, ha, b, hb, rfl⟩, by
      simp only [sub_eq_add_neg, neg_add_rev, neg_neg]
      abel⟩
  · intro hz
    obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hz
    obtain ⟨a, ha, b, hb, rfl⟩ := Finset.mem_sub.mp hx
    exact Finset.mem_sub.mpr ⟨a, ha, b - s, Finset.mem_image_of_mem _ hb, by
      simp only [sub_eq_add_neg, neg_add_rev, neg_neg]
      abel⟩

/-- Two subsets of equal cardinality with a controlled mixed difference set. -/
theorem finite_bsg_two_sets {A B : Finset G} {K : ℝ}
    (hA : A.Nonempty) (hB : B.Nonempty) (hK : 0 < K)
    (hE : (A.card : ℝ) ^ 2 * (B.card : ℝ) ≤ K * (Finset.addEnergy A B : ℝ)) :
    ∃ C D : Finset G, C ⊆ A ∧ D ⊆ B ∧ C.Nonempty ∧ D.card = C.card ∧
      (A.card : ℝ) ≤ 16 * K * (C.card : ℝ) ∧
      (A.card : ℝ) ^ 3 * ((C - D).card : ℝ) ≤ 1024 * K ^ 5 * (B.card : ℝ) ^ 4 := by
  obtain ⟨s, C, hC, hsize, hdiff⟩ := finite_bsg_overlap hA hB hK hE
  let D := C.image (fun x => x - s)
  have hDB : D ⊆ B := by
    intro d hd
    obtain ⟨c, hc, rfl⟩ := Finset.mem_image.mp hd
    exact (Finset.mem_filter.mp (hC hc)).2
  have hDcard : D.card = C.card := Finset.card_image_of_injective C (fun _ _ h => sub_left_injective h)
  have hdiffcard : (C - D).card = (C - C).card := by
    dsimp only [D]
    rw [finite_sub_translated_image, Finset.card_image_of_injective _ (fun _ _ h => add_right_cancel h)]
  have hCp : (0 : ℝ) < C.card := by
    have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
    by_contra hn
    have hc : (C.card : ℝ) = 0 := le_antisymm (le_of_not_gt hn) (Nat.cast_nonneg _)
    rw [hc, mul_zero] at hsize
    exact not_le_of_gt hAp hsize
  refine ⟨C, D, hC.trans (Finset.filter_subset _ _), hDB,
    Finset.card_pos.mp (by exact_mod_cast hCp), hDcard, hsize, ?_⟩
  simpa only [hdiffcard] using hdiff

end FiniteInverseEnergy

noncomputable def cyclicSetIndicator {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (x : ZMod q) : ℂ := if x ∈ A then 1 else 0

theorem finite_sum_fiber_card {G : Type*} [AddCommGroup G] [DecidableEq G]
    (A B : Finset G) (x : G) :
    ((A ×ˢ B).filter (fun p => p.1 + p.2 = x)).card =
      (A.filter (fun a => x - a ∈ B)).card := by
  apply Finset.card_bij (fun p _ => p.1)
  · intro p hp
    obtain ⟨hpAB, heq⟩ := Finset.mem_filter.mp hp
    obtain ⟨ha, hb⟩ := Finset.mem_product.mp hpAB
    exact Finset.mem_filter.mpr ⟨ha, by simpa only [← heq, add_sub_cancel_left] using hb⟩
  · intro p hp q hq hpq
    apply Prod.ext hpq
    have hh := (Finset.mem_filter.mp hp).2.trans (Finset.mem_filter.mp hq).2.symm
    simpa only [hpq, add_left_cancel_iff] using hh
  · intro a ha
    obtain ⟨haA, haB⟩ := Finset.mem_filter.mp ha
    exact ⟨(a, x - a), Finset.mem_filter.mpr
      ⟨Finset.mem_product.mpr ⟨haA, haB⟩, add_sub_cancel a x⟩, rfl⟩

theorem cyclic_set_indicator_convolution {q : ℕ} [NeZero q]
    (A B : Finset (ZMod q)) (x : ZMod q) :
    cyclicConvolution (cyclicSetIndicator A) (cyclicSetIndicator B) x =
      (((A ×ˢ B).filter (fun p => p.1 + p.2 = x)).card : ℂ) := by
  classical
  rw [finite_sum_fiber_card]
  simp only [cyclicConvolution, cyclicSetIndicator, ite_mul, one_mul, zero_mul,
    ← Finset.sum_filter, Finset.filter_mem_eq_inter, Finset.univ_inter,
    Finset.sum_const, nsmul_eq_mul, mul_one]

theorem cyclic_set_convolution_energy {q : ℕ} [NeZero q] (A B : Finset (ZMod q)) :
    (∑ x : ZMod q, ‖cyclicConvolution (cyclicSetIndicator A) (cyclicSetIndicator B) x‖ ^ 2) =
      (Finset.addEnergy A B : ℝ) := by
  simp_rw [cyclic_set_indicator_convolution, Complex.norm_natCast]
  exact_mod_cast (Finset.addEnergy_eq_sum_sq A B).symm

theorem cyclic_set_fourier_energy {q : ℕ} [NeZero q] (A B : Finset (ZMod q)) :
    (∑ k : ZMod q, ‖ZMod.dft (cyclicSetIndicator A) k‖ ^ 2 *
      ‖ZMod.dft (cyclicSetIndicator B) k‖ ^ 2) = (q : ℝ) * (Finset.addEnergy A B : ℝ) := by
  have hh := dft_parseval (cyclicConvolution (cyclicSetIndicator A) (cyclicSetIndicator B))
  simpa only [dft_cyclicConvolution, norm_mul, mul_pow, cyclic_set_convolution_energy] using hh

theorem cyclic_large_fourier_energy_subset {q : ℕ} [NeZero q]
    {A : Finset (ZMod q)} {K : ℝ} (hA : A.Nonempty) (hK : 0 < K)
    (hFourier : (q : ℝ) * (A.card : ℝ) ^ 3 ≤
      K * ∑ k : ZMod q, ‖ZMod.dft (cyclicSetIndicator A) k‖ ^ 4) :
    ∃ C : Finset (ZMod q), C ⊆ A ∧ C.Nonempty ∧
      (A.card : ℝ) ≤ 16 * K * (C.card : ℝ) ∧
      ((C - C).card : ℝ) ≤ 16384 * K ^ 6 * (C.card : ℝ) := by
  apply finite_bsg_self hA hK
  have hsum : (∑ k : ZMod q, ‖ZMod.dft (cyclicSetIndicator A) k‖ ^ 4) =
      (q : ℝ) * (Finset.addEnergy A A : ℝ) := by
    convert cyclic_set_fourier_energy A A using 1
    apply Finset.sum_congr rfl
    intro k hk
    ring
  rw [hsum] at hFourier
  have hq : (0 : ℝ) < q := by exact_mod_cast NeZero.pos q
  apply (mul_le_mul_iff_right₀ hq).mp
  simpa only [mul_left_comm K (q : ℝ)] using hFourier


/- Common intersections and Ruzsa bounds for assembling inverse-energy subsets. -/

theorem finite_sub_card_comm {G : Type*} [AddCommGroup G] [DecidableEq G]
    (A B : Finset G) : (A - B).card = (B - A).card := by
  apply Finset.card_bij (fun x _ => -x)
  · intro x hx
    obtain ⟨a, ha, b, hb, rfl⟩ := Finset.mem_sub.mp hx
    exact Finset.mem_sub.mpr ⟨b, hb, a, ha, (neg_sub a b).symm⟩
  · intro x hx y hy hxy
    exact neg_injective hxy
  · intro y hy
    obtain ⟨b, hb, a, ha, rfl⟩ := Finset.mem_sub.mp hy
    exact ⟨a - b, Finset.mem_sub.mpr ⟨a, ha, b, hb, rfl⟩, neg_sub a b⟩

theorem finite_sum_card_common_difference {G : Type*} [AddCommGroup G] [DecidableEq G]
    (X Y U V : Finset G) :
    (U + V).card * (X ∩ Y).card ≤ (X - U).card * (Y - V).card := by
  have hh := Finset.ruzsa_triangle_inequality_add_add_add U (-(X ∩ Y)) V
  have h₁ : (U + -(X ∩ Y)).card ≤ (X - U).card := by
    rw [← sub_eq_add_neg, finite_sub_card_comm]
    exact Finset.card_le_card (Finset.sub_subset_sub_right Finset.inter_subset_left)
  have h₂ : (-(X ∩ Y) + V).card ≤ (Y - V).card := by
    rw [add_comm, ← sub_eq_add_neg, finite_sub_card_comm]
    exact Finset.card_le_card (Finset.sub_subset_sub_right Finset.inter_subset_right)
  simp only [Finset.card_neg] at hh
  exact hh.trans (Nat.mul_le_mul h₁ h₂)

theorem finite_sum_card_common_middle {G : Type*} [AddCommGroup G] [DecidableEq G]
    (U V W : Finset G) :
    (U + W).card * (V ∩ W).card ≤ (U + V).card * (W + W).card := by
  have hh := Finset.ruzsa_triangle_inequality_add_add_add U (V ∩ W) W
  apply hh.trans
  apply Nat.mul_le_mul
  · exact Finset.card_le_card (Finset.add_subset_add_left Finset.inter_subset_left)
  · exact Finset.card_le_card (Finset.add_subset_add_right Finset.inter_subset_right)

theorem finite_common_structure_card_bound {G : Type*} [AddCommGroup G] [DecidableEq G]
    (X Y U V W : Finset G) (hdouble : (W + W).card = (U + U).card) :
    (U + W).card * (V ∩ W).card * (X ∩ Y).card * X.card ≤
      (X - U).card ^ 3 * (Y - V).card := by
  have hcross := finite_sum_card_common_difference X Y U V
  have hself : (U + U).card * X.card ≤ (X - U).card ^ 2 := by
    simpa only [Finset.inter_self, pow_two] using finite_sum_card_common_difference X X U U
  calc
    _ ≤ ((U + V).card * (W + W).card) * (X ∩ Y).card * X.card :=
      Nat.mul_le_mul_right _ (Nat.mul_le_mul_right _ (finite_sum_card_common_middle U V W))
    _ = ((U + V).card * (X ∩ Y).card) * ((U + U).card * X.card) := by rw [hdouble]; ring
    _ ≤ ((X - U).card * (Y - V).card) * (X - U).card ^ 2 := Nat.mul_le_mul hcross hself
    _ = _ := by ring

theorem finite_family_incidence_sum {α ι : Type*} [DecidableEq α] [DecidableEq ι]
    (I : Finset ι) (S : Finset α) (F : ι → Finset α)
    (hF : ∀ i ∈ I, F i ⊆ S) :
    (∑ x ∈ S, (I.filter (fun i => x ∈ F i)).card) = ∑ i ∈ I, (F i).card := by
  classical
  calc
    _ = ∑ i ∈ I, (S.filter (fun x => x ∈ F i)).card := by
      simp only [Finset.card_eq_sum_ones, Finset.sum_filter]
      exact Finset.sum_comm
    _ = _ := Finset.sum_congr rfl (fun i hi => by
      rw [Finset.filter_mem_eq_inter, Finset.inter_eq_right.mpr (hF i hi)])

theorem finite_family_intersection_moment {α ι : Type*} [DecidableEq α] [DecidableEq ι]
    (I : Finset ι) (S : Finset α) (F : ι → Finset α)
    (hF : ∀ i ∈ I, F i ⊆ S) :
    (∑ i ∈ I, ∑ j ∈ I, (F i ∩ F j).card) =
      ∑ x ∈ S, (I.filter (fun i => x ∈ F i)).card ^ 2 := by
  classical
  let f := fun x i => if x ∈ F i then (1 : ℕ) else 0
  have hinter (i j : ι) (hi : i ∈ I) :
      (F i ∩ F j).card = ∑ x ∈ S, f x i * f x j := by
    have heq : S.filter (fun x => x ∈ F i ∧ x ∈ F j) = F i ∩ F j := by
      ext x
      simp only [Finset.mem_filter, Finset.mem_inter]
      exact ⟨fun h => h.2, fun h => ⟨hF i hi h.1, h⟩⟩
    rw [← heq, Finset.card_eq_sum_ones, Finset.sum_filter]
    apply Finset.sum_congr rfl
    intro x hx
    simp only [f]
    split_ifs <;> simp_all
  calc
    _ = ∑ i ∈ I, ∑ j ∈ I, ∑ x ∈ S, f x i * f x j := by
      apply Finset.sum_congr rfl
      intro i hi
      exact Finset.sum_congr rfl (fun j hj => hinter i j hi)
    _ = ∑ i ∈ I, ∑ x ∈ S, ∑ j ∈ I, f x i * f x j := by
      apply Finset.sum_congr rfl
      intro i hi
      exact Finset.sum_comm
    _ = ∑ x ∈ S, ∑ i ∈ I, ∑ j ∈ I, f x i * f x j := Finset.sum_comm
    _ = _ := by
      apply Finset.sum_congr rfl
      intro x hx
      rw [← Finset.sum_mul_sum]
      simp only [f, Finset.card_eq_sum_ones, Finset.sum_filter, pow_two]

theorem finite_family_intersection_lower {α ι : Type*} [DecidableEq α] [DecidableEq ι]
    {I : Finset ι} {S : Finset α} {F : ι → Finset α} {δ : ℝ}
    (hS : S.Nonempty) (hδ : 0 ≤ δ) (hF : ∀ i ∈ I, F i ⊆ S)
    (hlarge : ∀ i ∈ I, δ * (S.card : ℝ) ≤ (F i).card) :
    δ ^ 2 * (I.card : ℝ) ^ 2 * (S.card : ℝ) ≤
      ∑ i ∈ I, ∑ j ∈ I, ((F i ∩ F j).card : ℝ) := by
  classical
  have hsum : δ * (I.card : ℝ) * (S.card : ℝ) ≤ ∑ i ∈ I, ((F i).card : ℝ) := by
    calc
      _ = ∑ _i ∈ I, δ * (S.card : ℝ) := by simp; ring
      _ ≤ _ := Finset.sum_le_sum hlarge
  have hsum' : δ * (I.card : ℝ) * (S.card : ℝ) ≤
      ∑ x ∈ S, ((I.filter (fun i => x ∈ F i)).card : ℝ) := by
    have heq : (∑ x ∈ S, ((I.filter (fun i => x ∈ F i)).card : ℝ)) =
        ∑ i ∈ I, ((F i).card : ℝ) := by exact_mod_cast finite_family_incidence_sum I S F hF
    rwa [heq]
  have hsq := pow_le_pow_left₀ (by positivity : (0 : ℝ) ≤ δ * I.card * S.card) hsum' 2
  have hc := Finset.sum_mul_sq_le_sq_mul_sq S (fun _ => (1 : ℝ))
    (fun x => ((I.filter (fun i => x ∈ F i)).card : ℝ))
  simp only [one_mul, one_pow, Finset.sum_const, nsmul_eq_mul, mul_one] at hc
  have hm : (∑ x ∈ S, ((I.filter (fun i => x ∈ F i)).card : ℝ) ^ 2) =
      ∑ i ∈ I, ∑ j ∈ I, ((F i ∩ F j).card : ℝ) := by
    exact_mod_cast (finite_family_intersection_moment I S F hF).symm
  rw [hm] at hc
  have hSp : (0 : ℝ) < S.card := by exact_mod_cast hS.card_pos
  apply (mul_le_mul_iff_right₀ hSp).mp
  calc
    _ = (δ * (I.card : ℝ) * (S.card : ℝ)) ^ 2 := by ring
    _ ≤ _ := hsq.trans hc

theorem finite_family_large_intersections {α ι : Type*} [DecidableEq α] [DecidableEq ι]
    {I : Finset ι} {S : Finset α} {F : ι → Finset α} {δ : ℝ}
    (hI : I.Nonempty) (hS : S.Nonempty) (hδ : 0 ≤ δ) (hF : ∀ i ∈ I, F i ⊆ S)
    (hlarge : ∀ i ∈ I, δ * (S.card : ℝ) ≤ (F i).card) :
    ∃ i ∈ I, δ ^ 2 / 2 * (I.card : ℝ) ≤
      ((I.filter (fun j => δ ^ 2 / 2 * (S.card : ℝ) ≤ ((F i ∩ F j).card : ℝ))).card : ℝ) := by
  classical
  have htotal := finite_family_intersection_lower hS hδ hF hlarge
  have hex : ∃ i ∈ I, δ ^ 2 * (I.card : ℝ) * (S.card : ℝ) ≤
      ∑ j ∈ I, ((F i ∩ F j).card : ℝ) := by
    by_contra! hn
    have hh : (∑ i ∈ I, ∑ j ∈ I, ((F i ∩ F j).card : ℝ)) <
        ∑ _i ∈ I, δ ^ 2 * (I.card : ℝ) * (S.card : ℝ) := by
      apply Finset.sum_lt_sum
      · intro i hi
        exact (hn i hi).le
      · obtain ⟨i, hi⟩ := hI
        exact ⟨i, hi, hn i hi⟩
    have heq : (∑ _i ∈ I, δ ^ 2 * (I.card : ℝ) * (S.card : ℝ)) =
        δ ^ 2 * (I.card : ℝ) ^ 2 * (S.card : ℝ) := by simp; ring
    rw [heq] at hh
    exact not_lt_of_ge htotal hh
  obtain ⟨i, hi, hrow⟩ := hex
  let C := I.filter (fun j => δ ^ 2 / 2 * (S.card : ℝ) ≤ ((F i ∩ F j).card : ℝ))
  have hpoint : ∀ j ∈ I, ((F i ∩ F j).card : ℝ) ≤
      δ ^ 2 / 2 * (S.card : ℝ) + if j ∈ C then (S.card : ℝ) else 0 := by
    intro j hj
    by_cases hc : j ∈ C
    · rw [if_pos hc]
      have hcard : ((F i ∩ F j).card : ℝ) ≤ S.card := by
        exact_mod_cast Finset.card_le_card ((Finset.inter_subset_left).trans (hF i hi))
      have hnonneg : 0 ≤ δ ^ 2 / 2 * (S.card : ℝ) := by positivity
      linarith
    · rw [if_neg hc, add_zero]
      have hn : ¬ δ ^ 2 / 2 * (S.card : ℝ) ≤ ((F i ∩ F j).card : ℝ) := by
        intro hh
        exact hc (Finset.mem_filter.mpr ⟨hj, hh⟩)
      exact (lt_of_not_ge hn).le
  have hbound : (∑ j ∈ I, ((F i ∩ F j).card : ℝ)) ≤
      (I.card : ℝ) * (δ ^ 2 / 2 * (S.card : ℝ)) + (C.card : ℝ) * (S.card : ℝ) := by
    calc
      _ ≤ ∑ j ∈ I, (δ ^ 2 / 2 * (S.card : ℝ) + if j ∈ C then (S.card : ℝ) else 0) :=
        Finset.sum_le_sum hpoint
      _ = _ := by
        rw [Finset.sum_add_distrib, ← Finset.sum_filter, Finset.filter_mem_eq_inter,
          Finset.inter_eq_right.mpr (Finset.filter_subset _ _)]
        simp [C]
  refine ⟨i, hi, ?_⟩
  have hSp : (0 : ℝ) < S.card := by exact_mod_cast hS.card_pos
  apply (mul_le_mul_iff_left₀ hSp).mp
  change δ ^ 2 / 2 * (I.card : ℝ) * (S.card : ℝ) ≤ (C.card : ℝ) * (S.card : ℝ)
  nlinarith

theorem finite_common_structure_quantitative {G : Type*} [AddCommGroup G] [DecidableEq G]
    {X Y U V W : Finset G} {a α δ M : ℝ}
    (ha : 0 < a) (hα : 0 < α) (hδ : 0 < δ) (hM : 0 ≤ M)
    (hX : α * a ≤ (X.card : ℝ)) (hU : α * a ≤ (U.card : ℝ))
    (hXY : δ * a ≤ ((X ∩ Y).card : ℝ)) (hVW : δ * a ≤ ((V ∩ W).card : ℝ))
    (hXU : ((X - U).card : ℝ) ≤ M * a) (hYV : ((Y - V).card : ℝ) ≤ M * a)
    (hdouble : (W + W).card = (U + U).card) :
    ((U + W).card : ℝ) ≤ M ^ 4 / (α ^ 2 * δ ^ 2) * (U.card : ℝ) := by
  have hc : ((U + W).card : ℝ) * ((V ∩ W).card : ℝ) * ((X ∩ Y).card : ℝ) * (X.card : ℝ) ≤
      ((X - U).card : ℝ) ^ 3 * ((Y - V).card : ℝ) := by
    exact_mod_cast finite_common_structure_card_bound X Y U V W hdouble
  have hprefix : α * δ ^ 2 * a ^ 3 ≤ ((V ∩ W).card : ℝ) * ((X ∩ Y).card : ℝ) * (X.card : ℝ) := by
    calc
      _ = (δ * a) * (δ * a) * (α * a) := by ring
      _ ≤ _ := by gcongr
  have hpow : ((X - U).card : ℝ) ^ 3 * ((Y - V).card : ℝ) ≤ M ^ 4 * a ^ 4 := by
    calc
      _ ≤ (M * a) ^ 3 * (M * a) := by gcongr
      _ = _ := by ring
  have htotal : ((U + W).card : ℝ) * (α * δ ^ 2 * a ^ 3) ≤ M ^ 4 * a ^ 4 := by
    calc
      _ ≤ ((U + W).card : ℝ) * (((V ∩ W).card : ℝ) * ((X ∩ Y).card : ℝ) * (X.card : ℝ)) :=
        mul_le_mul_of_nonneg_left hprefix (Nat.cast_nonneg _)
      _ = ((U + W).card : ℝ) * ((V ∩ W).card : ℝ) * ((X ∩ Y).card : ℝ) * (X.card : ℝ) := by ring
      _ ≤ _ := hc.trans hpow
  have hcancel : ((U + W).card : ℝ) * (α * δ ^ 2) ≤ M ^ 4 * a := by
    apply (mul_le_mul_iff_left₀ (show 0 < a ^ 3 by positivity)).mp
    calc
      _ = ((U + W).card : ℝ) * (α * δ ^ 2 * a ^ 3) := by ring
      _ ≤ M ^ 4 * a ^ 4 := htotal
      _ = _ := by ring
  have hfinal : ((U + W).card : ℝ) * (α ^ 2 * δ ^ 2) ≤ M ^ 4 * (U.card : ℝ) := by
    calc
      _ = (((U + W).card : ℝ) * (α * δ ^ 2)) * α := by ring
      _ ≤ (M ^ 4 * a) * α := mul_le_mul_of_nonneg_right hcancel hα.le
      _ = M ^ 4 * (α * a) := by ring
      _ ≤ _ := mul_le_mul_of_nonneg_left hU (by positivity)
  calc
    _ ≤ M ^ 4 * (U.card : ℝ) / (α ^ 2 * δ ^ 2) :=
      (le_div_iff₀ (by positivity)).mpr hfinal
    _ = _ := by ring

theorem finite_bsg_common_structure {G : Type*} [AddCommGroup G] [DecidableEq G]
    {X Y U V W : Finset G} {a K : ℝ} (ha : 0 < a) (hK : 0 < K)
    (hX : a / (16 * K) ≤ (X.card : ℝ)) (hU : a / (16 * K) ≤ (U.card : ℝ))
    (hXY : a / (131072 * K ^ 4) ≤ ((X ∩ Y).card : ℝ))
    (hVW : a / (131072 * K ^ 4) ≤ ((V ∩ W).card : ℝ))
    (hXU : ((X - U).card : ℝ) ≤ 1024 * K ^ 5 * a)
    (hYV : ((Y - V).card : ℝ) ≤ 1024 * K ^ 5 * a)
    (hdouble : (W + W).card = (U + U).card) :
    ((U + W).card : ℝ) ≤ (2 : ℝ) ^ (82 : ℕ) * K ^ 30 * (U.card : ℝ) := by
  have hh := finite_common_structure_quantitative (X := X) (Y := Y) (U := U) (V := V) (W := W)
    (a := a) (α := (16 * K)⁻¹) (δ := (131072 * K ^ 4)⁻¹) (M := 1024 * K ^ 5)
    ha (by positivity) (by positivity) (by positivity)
    (by simpa only [inv_mul_eq_div] using hX) (by simpa only [inv_mul_eq_div] using hU)
    (by simpa only [inv_mul_eq_div] using hXY) (by simpa only [inv_mul_eq_div] using hVW)
    hXU hYV hdouble
  have heq : (1024 * K ^ 5) ^ 4 / ((16 * K)⁻¹ ^ 2 * (131072 * K ^ 4)⁻¹ ^ 2) =
      (2 : ℝ) ^ (82 : ℕ) * K ^ 30 := by
    field_simp
    ring
  rwa [heq] at hh


/- Simultaneous inverse energy and sum-product closure of additive stabilizers. -/

theorem finite_add_equiv_image_add {G : Type*} [AddCommGroup G] [DecidableEq G]
    (φ : G ≃+ G) (A B : Finset G) :
    (A + B).image φ = A.image φ + B.image φ := by
  ext z
  constructor
  · intro hz
    obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hz
    obtain ⟨a, ha, b, hb, rfl⟩ := Finset.mem_add.mp hx
    exact Finset.mem_add.mpr ⟨φ a, Finset.mem_image_of_mem _ ha,
      φ b, Finset.mem_image_of_mem _ hb, (map_add φ a b).symm⟩
  · intro hz
    obtain ⟨x, hx, y, hy, rfl⟩ := Finset.mem_add.mp hz
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
    obtain ⟨b, hb, rfl⟩ := Finset.mem_image.mp hy
    exact Finset.mem_image.mpr ⟨a + b, Finset.mem_add.mpr ⟨a, ha, b, hb, rfl⟩, map_add φ a b⟩

theorem finite_add_equiv_sum_card {G : Type*} [AddCommGroup G] [DecidableEq G]
    (φ : G ≃+ G) (A B : Finset G) :
    (A.image φ + B.image φ).card = (A + B).card := by
  rw [← finite_add_equiv_image_add, Finset.card_image_of_injective _ φ.injective]

theorem finite_add_equiv_inter_card {G : Type*} [AddCommGroup G] [DecidableEq G]
    (φ : G ≃+ G) (A B : Finset G) :
    (A.image φ ∩ B.image φ).card = (A ∩ B).card := by
  rw [← Finset.image_inter _ _ φ.injective, Finset.card_image_of_injective _ φ.injective]

theorem finite_bsg_add_equiv {G : Type*} [AddCommGroup G] [Fintype G] [DecidableEq G]
    {A : Finset G} {K : ℝ} (φ : G ≃+ G) (hA : A.Nonempty) (hK : 0 < K)
    (hE : (A.card : ℝ) ^ 3 ≤ K * (Finset.addEnergy A (A.image φ) : ℝ)) :
    ∃ X Y : Finset G, X ⊆ A ∧ Y ⊆ A ∧
      (A.card : ℝ) / (16 * K) ≤ (X.card : ℝ) ∧
      (A.card : ℝ) / (16 * K) ≤ (Y.card : ℝ) ∧
      ((X - Y.image φ).card : ℝ) ≤ 1024 * K ^ 5 * (A.card : ℝ) := by
  have hBcard : (A.image φ).card = A.card := Finset.card_image_of_injective _ φ.injective
  have hE' : (A.card : ℝ) ^ 2 * ((A.image φ).card : ℝ) ≤
      K * (Finset.addEnergy A (A.image φ) : ℝ) := by
    calc
      _ = (A.card : ℝ) ^ 3 := by rw [hBcard]; ring
      _ ≤ _ := hE
  obtain ⟨X, D, hXA, hDB, hX, hDcard, hsize, hdiff⟩ := finite_bsg_two_sets hA (hA.image φ) hK hE'
  let Y := D.image φ.symm
  have hYA : Y ⊆ A := by
    intro y hy
    obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp hy
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp (hDB hd)
    simpa only [AddEquiv.symm_apply_apply] using ha
  have hYcard : Y.card = X.card := (Finset.card_image_of_injective _ φ.symm.injective).trans hDcard
  have hYimage : Y.image φ = D := by
    ext d
    simp only [Y, Finset.mem_image]
    constructor
    · rintro ⟨y, ⟨x, hx, rfl⟩, rfl⟩
      simpa only [AddEquiv.apply_symm_apply] using hx
    · intro hd
      exact ⟨φ.symm d, ⟨d, hd, rfl⟩, φ.apply_symm_apply d⟩
  have hsize' : (A.card : ℝ) / (16 * K) ≤ (X.card : ℝ) :=
    (div_le_iff₀ (by positivity)).mpr (by simpa only [mul_comm] using hsize)
  refine ⟨X, Y, hXA, hYA, hsize', by simpa only [hYcard] using hsize', ?_⟩
  rw [hYimage]
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  apply (mul_le_mul_iff_right₀ (show (0 : ℝ) < (A.card : ℝ) ^ 3 by positivity)).mp
  calc
    _ ≤ 1024 * K ^ 5 * ((A.image φ).card : ℝ) ^ 4 := hdiff
    _ = _ := by rw [hBcard]; ring

theorem finite_large_product_intersections {G : Type*} [DecidableEq G]
    {A X Y U V : Finset G} {d : ℝ} (hA : A.Nonempty) (hXA : X ⊆ A) (hYA : Y ⊆ A)
    (hlarge : d * (A.card : ℝ) ^ 2 ≤ (((X ×ˢ Y) ∩ (U ×ˢ V)).card : ℝ)) :
    d * (A.card : ℝ) ≤ ((X ∩ U).card : ℝ) ∧ d * (A.card : ℝ) ≤ ((Y ∩ V).card : ℝ) := by
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  have hX : ((X ∩ U).card : ℝ) ≤ A.card := by
    exact_mod_cast Finset.card_le_card ((Finset.inter_subset_left).trans hXA)
  have hY : ((Y ∩ V).card : ℝ) ≤ A.card := by
    exact_mod_cast Finset.card_le_card ((Finset.inter_subset_left).trans hYA)
  rw [Finset.product_inter_product, Finset.card_product, Nat.cast_mul] at hlarge
  constructor
  · apply (mul_le_mul_iff_left₀ hAp).mp
    calc
      _ = d * (A.card : ℝ) ^ 2 := by ring
      _ ≤ _ := hlarge
      _ ≤ _ := mul_le_mul_of_nonneg_left hY (Nat.cast_nonneg _)
  · apply (mul_le_mul_iff_right₀ hAp).mp
    calc
      _ = d * (A.card : ℝ) ^ 2 := by ring
      _ ≤ _ := hlarge
      _ ≤ _ := mul_le_mul_of_nonneg_right hX (Nat.cast_nonneg _)

/-- High additive energy for many automorphisms gives one common large subset
with controlled mixed sumsets for a large subfamily. -/
theorem finite_many_automorphisms_small_sumsets {G ι : Type*}
    [AddCommGroup G] [Fintype G] [DecidableEq G] [DecidableEq ι]
    {A : Finset G} {I : Finset ι} {K : ℝ} (φ : ι → G ≃+ G)
    (hA : A.Nonempty) (hI : I.Nonempty) (hK : 0 < K)
    (hE : ∀ i ∈ I, (A.card : ℝ) ^ 3 ≤ K * (Finset.addEnergy A (A.image (φ i)) : ℝ)) :
    ∃ B : Finset G, B ⊆ A ∧ B.Nonempty ∧ (A.card : ℝ) / (16 * K) ≤ (B.card : ℝ) ∧
      ∃ i₀ ∈ I, ∃ J : Finset ι, J ⊆ I ∧
        (I.card : ℝ) / (131072 * K ^ 4) ≤ (J.card : ℝ) ∧
        ∀ i ∈ J, ((B.image (φ i₀) + B.image (φ i)).card : ℝ) ≤
          (2 : ℝ) ^ (82 : ℕ) * K ^ 30 * (B.card : ℝ) := by
  classical
  have hex : ∀ i : ι, ∃ X Y : Finset G, i ∈ I → X ⊆ A ∧ Y ⊆ A ∧
      (A.card : ℝ) / (16 * K) ≤ (X.card : ℝ) ∧
      (A.card : ℝ) / (16 * K) ≤ (Y.card : ℝ) ∧
      ((X - Y.image (φ i)).card : ℝ) ≤ 1024 * K ^ 5 * (A.card : ℝ) := by
    intro i
    by_cases hi : i ∈ I
    · obtain ⟨X, Y, hXY⟩ := finite_bsg_add_equiv (φ i) hA hK (hE i hi)
      exact ⟨X, Y, fun _ => hXY⟩
    · exact ⟨∅, ∅, fun h => False.elim (hi h)⟩
  choose X Y hXY using hex
  let F := fun i => X i ×ˢ Y i
  let δ : ℝ := (16 * K)⁻¹ ^ 2
  have hF : ∀ i ∈ I, F i ⊆ A ×ˢ A := by
    intro i hi
    exact Finset.product_subset_product (hXY i hi).1 (hXY i hi).2.1
  have hlarge : ∀ i ∈ I, δ * ((A ×ˢ A).card : ℝ) ≤ (F i).card := by
    intro i hi
    obtain ⟨hXi, hYi, hXsize, hYsize, hsmall⟩ := hXY i hi
    dsimp only [F, δ]
    rw [Finset.card_product, Finset.card_product, Nat.cast_mul, Nat.cast_mul]
    calc
      _ = ((A.card : ℝ) / (16 * K)) * ((A.card : ℝ) / (16 * K)) := by ring
      _ ≤ _ := mul_le_mul hXsize hYsize (by positivity) (Nat.cast_nonneg _)
  obtain ⟨i₀, hi₀, hmany⟩ := finite_family_large_intersections hI (hA.product hA)
    (show 0 ≤ δ by positivity) hF hlarge
  let J := I.filter (fun i => δ ^ 2 / 2 * ((A ×ˢ A).card : ℝ) ≤ ((F i₀ ∩ F i).card : ℝ))
  have hconstant : δ ^ 2 / 2 = (131072 * K ^ 4)⁻¹ := by
    dsimp only [δ]
    field_simp
    ring
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  have hYpos : (0 : ℝ) < (Y i₀).card :=
    (div_pos hAp (by positivity)).trans_le (hXY i₀ hi₀).2.2.2.1
  refine ⟨Y i₀, (hXY i₀ hi₀).2.1, Finset.card_pos.mp (by exact_mod_cast hYpos),
    (hXY i₀ hi₀).2.2.2.1, i₀, hi₀, J, Finset.filter_subset _ _, ?_, ?_⟩
  · have hh : δ ^ 2 / 2 * (I.card : ℝ) ≤ (J.card : ℝ) := hmany
    simpa only [hconstant, inv_mul_eq_div] using hh
  · intro i hi
    obtain ⟨hiI, hgood⟩ := Finset.mem_filter.mp hi
    have hgood' : δ ^ 2 / 2 * (A.card : ℝ) ^ 2 ≤ ((F i₀ ∩ F i).card : ℝ) := by
      simpa only [Finset.card_product, Nat.cast_mul, pow_two] using hgood
    obtain ⟨hXinter, hYinter⟩ := finite_large_product_intersections hA
      (hXY i₀ hi₀).1 (hXY i₀ hi₀).2.1 hgood'
    have hXinter' : (A.card : ℝ) / (131072 * K ^ 4) ≤ ((X i₀ ∩ X i).card : ℝ) := by
      simpa only [hconstant, inv_mul_eq_div] using hXinter
    have hYinter' : (A.card : ℝ) / (131072 * K ^ 4) ≤ ((Y i ∩ Y i₀).card : ℝ) := by
      simpa only [hconstant, inv_mul_eq_div, Finset.inter_comm] using hYinter
    have hh := finite_bsg_common_structure (X := X i₀) (Y := X i)
      (U := (Y i₀).image (φ i₀)) (V := (Y i).image (φ i)) (W := (Y i₀).image (φ i)) hAp hK
      (hXY i₀ hi₀).2.2.1
      (by simpa only [Finset.card_image_of_injective _ (φ i₀).injective] using (hXY i₀ hi₀).2.2.2.1)
      hXinter'
      (by simpa only [finite_add_equiv_inter_card] using hYinter')
      (hXY i₀ hi₀).2.2.2.2 (hXY i hiI).2.2.2.2
      (by rw [finite_add_equiv_sum_card, finite_add_equiv_sum_card])
    simpa only [Finset.card_image_of_injective _ (φ i₀).injective] using hh

def ringDilate {R : Type*} [Ring R] [DecidableEq R] (a : R) (A : Finset R) : Finset R :=
  A.image (fun x => a * x)

def ringUnitMulAddEquiv {R : Type*} [Ring R] (u : Rˣ) : R ≃+ R where
  toFun x := (u : R) * x
  invFun x := (u⁻¹ : Rˣ) * x
  left_inv x := by simp only [← mul_assoc, Units.inv_mul, one_mul]
  right_inv x := by simp only [← mul_assoc, Units.mul_inv, one_mul]
  map_add' x y := mul_add _ _ _

theorem ring_dilate_add {R : Type*} [Ring R] [DecidableEq R] (a : R) (A B : Finset R) :
    ringDilate a (A + B) = ringDilate a A + ringDilate a B := by
  exact Finset.image_add (AddMonoidHom.mulLeft a)

theorem ring_dilate_sub {R : Type*} [Ring R] [DecidableEq R] (a : R) (A B : Finset R) :
    ringDilate a (A - B) = ringDilate a A - ringDilate a B := by
  exact Finset.image_image₂_distrib (map_sub (AddMonoidHom.mulLeft a))

theorem ring_dilate_mul {R : Type*} [Ring R] [DecidableEq R] (a b : R) (A : Finset R) :
    ringDilate a (ringDilate b A) = ringDilate (a * b) A := by
  unfold ringDilate
  rw [Finset.image_image]
  apply Finset.image_congr
  intro x hx
  exact (mul_assoc a b x).symm

theorem ring_dilate_one {R : Type*} [Ring R] [DecidableEq R] (A : Finset R) :
    ringDilate 1 A = A := by simp [ringDilate]

theorem ring_dilate_unit_card {R : Type*} [Ring R] [DecidableEq R] (u : Rˣ) (A : Finset R) :
    (ringDilate (u : R) A).card = A.card :=
  Finset.card_image_of_injective A (ringUnitMulAddEquiv u).injective

theorem ring_unit_relative_sum_card {R : Type*} [Ring R] [DecidableEq R]
    (u v : Rˣ) (A : Finset R) :
    (A + ringDilate ((u⁻¹ * v : Rˣ) : R) A).card =
      (ringDilate (u : R) A + ringDilate (v : R) A).card := by
  have heq : ringDilate ((u⁻¹ : Rˣ) : R) (ringDilate (u : R) A + ringDilate (v : R) A) =
      A + ringDilate ((u⁻¹ * v : Rˣ) : R) A := by
    rw [ring_dilate_add, ring_dilate_mul, ring_dilate_mul, Units.inv_mul, ring_dilate_one]
    rfl
  rw [← heq, ring_dilate_unit_card]

noncomputable def ringSumStabilizer {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    (A : Finset R) (K : ℝ) : Finset R := by
  classical
  exact Finset.univ.filter (fun a => ((A + ringDilate a A).card : ℝ) ≤ K * (A.card : ℝ))

theorem mem_ring_sum_stabilizer {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    (A : Finset R) (K : ℝ) (a : R) :
    a ∈ ringSumStabilizer A K ↔ ((A + ringDilate a A).card : ℝ) ≤ K * (A.card : ℝ) := by
  classical
  simp only [ringSumStabilizer, Finset.mem_filter, Finset.mem_univ, true_and]

/-- A large family of unit dilates with high energy yields many normalized
unit multipliers stabilizing the additive size of one common large subset. -/
theorem finite_many_unit_dilates_stabilizer {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {T : Finset Rˣ} {K : ℝ} (hA : A.Nonempty) (hT : T.Nonempty) (hK : 0 < K)
    (hE : ∀ u ∈ T, (A.card : ℝ) ^ 3 ≤ K * (Finset.addEnergy A (ringDilate (u : R) A) : ℝ)) :
    ∃ B : Finset R, B ⊆ A ∧ B.Nonempty ∧ (A.card : ℝ) / (16 * K) ≤ (B.card : ℝ) ∧
      ∃ u₀ ∈ T, ∃ S : Finset R,
        S ⊆ T.image (fun u => ((u₀⁻¹ * u : Rˣ) : R)) ∧ S.Nonempty ∧
        (T.card : ℝ) / (131072 * K ^ 4) ≤ (S.card : ℝ) ∧
        (∀ x ∈ S, IsUnit x) ∧ S ⊆ ringSumStabilizer B ((2 : ℝ) ^ (82 : ℕ) * K ^ 30) := by
  classical
  obtain ⟨B, hBA, hB, hsize, u₀, hu₀, J, hJT, hJsize, hsmall⟩ :=
    finite_many_automorphisms_small_sumsets (fun u : Rˣ => ringUnitMulAddEquiv u) hA hT hK hE
  let S := J.image (fun u => ((u₀⁻¹ * u : Rˣ) : R))
  have hinj : Function.Injective (fun u : Rˣ => ((u₀⁻¹ * u : Rˣ) : R)) := by
    intro u v huv
    exact mul_left_cancel (Units.val_injective huv)
  have hScard : S.card = J.card := Finset.card_image_of_injective _ hinj
  have hTp : (0 : ℝ) < T.card := by exact_mod_cast hT.card_pos
  have hJp : (0 : ℝ) < J.card := (div_pos hTp (by positivity)).trans_le hJsize
  have hJ : J.Nonempty := Finset.card_pos.mp (by exact_mod_cast hJp)
  refine ⟨B, hBA, hB, hsize, u₀, hu₀, S, Finset.image_subset_image hJT, hJ.image _,
    by simpa only [hScard] using hJsize, ?_, ?_⟩
  · intro x hx
    obtain ⟨u, hu, rfl⟩ := Finset.mem_image.mp hx
    exact ⟨u₀⁻¹ * u, rfl⟩
  · intro x hx
    obtain ⟨u, hu, rfl⟩ := Finset.mem_image.mp hx
    rw [mem_ring_sum_stabilizer, ring_unit_relative_sum_card]
    exact hsmall u hu

theorem finite_signed_sum_card_bound {G : Type*} [AddCommGroup G] [DecidableEq G]
    {A : Finset G} {D : ℝ} (hA : A.Nonempty) (hD : 0 ≤ D)
    (hdouble : ((A + A).card : ℝ) ≤ D * (A.card : ℝ)) (m n : ℕ) :
    ((m • A - n • A).card : ℝ) ≤ D ^ (m + n) * (A.card : ℝ) := by
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  have hh := Finset.pluennecke_ruzsa_inequality_nsmul_sub_nsmul_add hA A m n
  have hhQ : ((m • A - n • A).card : ℚ) ≤
      (((A + A).card : ℚ) / (A.card : ℚ)) ^ (m + n) * (A.card : ℚ) := by
    exact_mod_cast (NNRat.coe_mono hh)
  have hhR := (Rat.cast_le (K := ℝ)).mpr hhQ
  push_cast at hhR
  have hratio : ((A + A).card : ℝ) / (A.card : ℝ) ≤ D := (div_le_iff₀ hAp).mpr hdouble
  exact hhR.trans (mul_le_mul_of_nonneg_right
    (pow_le_pow_left₀ (by positivity) hratio _) hAp.le)

theorem finite_three_two_hull_card {G : Type*} [AddCommGroup G] [DecidableEq G]
    {A : Finset G} {D : ℝ} (hA : A.Nonempty) (hD : 0 ≤ D)
    (hdouble : ((A + A).card : ℝ) ≤ D * (A.card : ℝ)) :
    (((A + (A - A)) + (A - A)).card : ℝ) ≤ D ^ (5 : ℕ) * (A.card : ℝ) := by
  have heq : (A + (A - A)) + (A - A) = (3 : ℕ) • A - (2 : ℕ) • A := by
    simp only [succ_nsmul, zero_nsmul, zero_add, sub_eq_add_neg, neg_add_rev,
      neg_zero, add_zero]
    ac_rfl
  rw [heq]
  exact finite_signed_sum_card_bound hA hD hdouble 3 2

theorem ring_sum_stabilizer_cover {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {K : ℝ} {x : R} (hA : A.Nonempty) (hx : x ∈ ringSumStabilizer A K) :
    ∃ F : Finset R, F ⊆ ringDilate x A ∧ (F.card : ℝ) ≤ K ∧ ringDilate x A ⊆ F + (A - A) := by
  exact Finset.ruzsa_covering_add hA (by
    rw [add_comm]
    exact (mem_ring_sum_stabilizer A K x).mp hx)

theorem ring_dilate_subset {R : Type*} [Ring R] [DecidableEq R] (x : R)
    {A B : Finset R} (hAB : A ⊆ B) : ringDilate x A ⊆ ringDilate x B :=
  Finset.image_subset_image hAB

theorem ring_dilate_scalar_add_subset {R : Type*} [Ring R] [DecidableEq R] (x y : R) (A : Finset R) :
    ringDilate (x + y) A ⊆ ringDilate x A + ringDilate y A := by
  intro z hz
  obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hz
  exact Finset.mem_add.mpr ⟨x * a, Finset.mem_image_of_mem _ ha,
    y * a, Finset.mem_image_of_mem _ ha, (add_mul x y a).symm⟩

theorem finite_three_sum_card_bound {G : Type*} [AddCommGroup G] [DecidableEq G]
    (A B C : Finset G) : (A + B + C).card ≤ A.card * B.card * C.card :=
  Finset.card_add_le.trans (Nat.mul_le_mul_right _ Finset.card_add_le)

theorem ring_sum_stabilizer_add {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {D K L : ℝ} {x y : R} (hA : A.Nonempty)
    (hD : 0 ≤ D) (hK : 0 ≤ K) (hL : 0 ≤ L)
    (hdouble : ((A + A).card : ℝ) ≤ D * (A.card : ℝ))
    (hx : x ∈ ringSumStabilizer A K) (hy : y ∈ ringSumStabilizer A L) :
    x + y ∈ ringSumStabilizer A (K * L * D ^ (5 : ℕ)) := by
  obtain ⟨F, hFx, hF, hcoverx⟩ := ring_sum_stabilizer_cover hA hx
  obtain ⟨G, hGy, hG, hcovery⟩ := ring_sum_stabilizer_cover hA hy
  let H := (A + (A - A)) + (A - A)
  have hsub : A + ringDilate (x + y) A ⊆ F + G + H := by
    calc
      _ ⊆ A + (ringDilate x A + ringDilate y A) :=
        Finset.add_subset_add_left (ring_dilate_scalar_add_subset x y A)
      _ ⊆ A + ((F + (A - A)) + (G + (A - A))) :=
        Finset.add_subset_add_left (Finset.add_subset_add hcoverx hcovery)
      _ = _ := by dsimp only [H]; ac_rfl
  rw [mem_ring_sum_stabilizer]
  calc
    _ ≤ ((F + G + H).card : ℝ) := by exact_mod_cast Finset.card_le_card hsub
    _ ≤ (F.card : ℝ) * (G.card : ℝ) * (H.card : ℝ) := by
      exact_mod_cast finite_three_sum_card_bound F G H
    _ ≤ K * L * (D ^ (5 : ℕ) * (A.card : ℝ)) := by
      gcongr
      exact finite_three_two_hull_card hA hD hdouble
    _ = _ := by ring

theorem ring_sum_stabilizer_mul {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {D K L : ℝ} {x y : R} (hA : A.Nonempty)
    (hD : 0 ≤ D) (hK : 0 ≤ K) (hL : 0 ≤ L)
    (hdouble : ((A + A).card : ℝ) ≤ D * (A.card : ℝ))
    (hx : x ∈ ringSumStabilizer A K) (hy : y ∈ ringSumStabilizer A L) :
    x * y ∈ ringSumStabilizer A (K ^ 2 * L * D ^ (5 : ℕ)) := by
  obtain ⟨F, hFx, hF, hcoverx⟩ := ring_sum_stabilizer_cover hA hx
  obtain ⟨G, hGy, hG, hcovery⟩ := ring_sum_stabilizer_cover hA hy
  let H := (A + (A - A)) + (A - A)
  have hsub : A + ringDilate (x * y) A ⊆ (ringDilate x G + (F - F)) + H := by
    calc
      _ = A + ringDilate x (ringDilate y A) := by rw [ring_dilate_mul]
      _ ⊆ A + ringDilate x (G + (A - A)) :=
        Finset.add_subset_add_left (ring_dilate_subset x hcovery)
      _ = A + (ringDilate x G + (ringDilate x A - ringDilate x A)) := by
        rw [ring_dilate_add, ring_dilate_sub]
      _ ⊆ A + (ringDilate x G + ((F + (A - A)) - (F + (A - A)))) :=
        Finset.add_subset_add_left (Finset.add_subset_add_left (Finset.sub_subset_sub hcoverx hcoverx))
      _ = _ := by
        dsimp only [H]
        simp only [sub_eq_add_neg, neg_add_rev, neg_neg]
        ac_rfl
  have hcardx : ((ringDilate x G).card : ℝ) ≤ G.card := by exact_mod_cast Finset.card_image_le
  have hcardF : ((F - F).card : ℝ) ≤ (F.card : ℝ) ^ 2 := by
    exact_mod_cast (Finset.card_sub_le : (F - F).card ≤ F.card * F.card).trans_eq (pow_two F.card).symm
  rw [mem_ring_sum_stabilizer]
  calc
    _ ≤ (((ringDilate x G + (F - F)) + H).card : ℝ) := by exact_mod_cast Finset.card_le_card hsub
    _ ≤ ((ringDilate x G).card : ℝ) * ((F - F).card : ℝ) * (H.card : ℝ) := by
      exact_mod_cast finite_three_sum_card_bound (ringDilate x G) (F - F) H
    _ ≤ L * K ^ 2 * (D ^ (5 : ℕ) * (A.card : ℝ)) := by
      gcongr
      · exact hcardx.trans hG
      · exact hcardF.trans (pow_le_pow_left₀ (Nat.cast_nonneg _) hF 2)
      · exact finite_three_two_hull_card hA hD hdouble
    _ = _ := by ring

theorem ring_dilate_neg {R : Type*} [Ring R] [DecidableEq R] (x : R) (A : Finset R) :
    ringDilate (-x) A = -(ringDilate x A) := by
  ext z
  simp only [ringDilate, Finset.mem_image, Finset.mem_neg, neg_mul, neg_eq_iff_eq_neg]
  aesop

theorem ring_sum_stabilizer_neg {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {D K : ℝ} {x : R} (hA : A.Nonempty) (hD : 0 ≤ D) (hK : 0 ≤ K)
    (hdouble : ((A + A).card : ℝ) ≤ D * (A.card : ℝ))
    (hx : x ∈ ringSumStabilizer A K) : -x ∈ ringSumStabilizer A (D * K) := by
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  have hh : ((A - ringDilate x A).card : ℝ) * (A.card : ℝ) ≤
      ((A + A).card : ℝ) * ((ringDilate x A + A).card : ℝ) := by
    exact_mod_cast Finset.ruzsa_triangle_inequality_sub_add_add A A (ringDilate x A)
  have hx' : ((ringDilate x A + A).card : ℝ) ≤ K * (A.card : ℝ) := by
    rw [add_comm]
    exact (mem_ring_sum_stabilizer A K x).mp hx
  rw [mem_ring_sum_stabilizer, ring_dilate_neg, ← sub_eq_add_neg]
  apply (mul_le_mul_iff_left₀ hAp).mp
  calc
    _ ≤ _ := hh
    _ ≤ (D * (A.card : ℝ)) * (K * (A.card : ℝ)) := by gcongr
    _ = _ := by ring

theorem ring_sum_stabilizer_mono {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    (A : Finset R) {K L : ℝ} (hKL : K ≤ L) : ringSumStabilizer A K ⊆ ringSumStabilizer A L := by
  intro x hx
  rw [mem_ring_sum_stabilizer] at hx ⊢
  exact hx.trans (mul_le_mul_of_nonneg_right hKL (Nat.cast_nonneg _))

theorem ring_sum_stabilizer_zero {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {K : ℝ} (hA : A.Nonempty) (hK : 1 ≤ K) : 0 ∈ ringSumStabilizer A K := by
  have hz : ringDilate (0 : R) A = {0} := by
    ext z
    simp only [ringDilate, Finset.mem_image, zero_mul, Finset.mem_singleton]
    constructor
    · rintro ⟨a, ha, hz⟩
      exact hz.symm
    · intro hz
      obtain ⟨a, ha⟩ := hA
      exact ⟨a, ha, hz.symm⟩
  rw [mem_ring_sum_stabilizer, hz]
  have heq : A + ({0} : Finset R) = A := by change A + 0 = A; exact add_zero A
  rw [heq]
  simpa only [one_mul] using mul_le_mul_of_nonneg_right hK (Nat.cast_nonneg A.card : (0 : ℝ) ≤ A.card)

theorem ring_sum_stabilizer_one {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {K : ℝ} (hdouble : ((A + A).card : ℝ) ≤ K * (A.card : ℝ)) :
    1 ∈ ringSumStabilizer A K := by
  rw [mem_ring_sum_stabilizer, ring_dilate_one]
  exact hdouble

theorem ring_sum_stabilizer_unit_doubling {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {K : ℝ} (hA : A.Nonempty) (hK : 0 ≤ K) (u : Rˣ)
    (hu : (u : R) ∈ ringSumStabilizer A K) :
    ((A + A).card : ℝ) ≤ K ^ 2 * (A.card : ℝ) := by
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  have hh : ((A + A).card : ℝ) * (A.card : ℝ) ≤
      ((A + ringDilate (u : R) A).card : ℝ) ^ 2 := by
    have hh' := Finset.ruzsa_triangle_inequality_add_add_add A (ringDilate (u : R) A) A
    rw [ring_dilate_unit_card, add_comm (ringDilate (u : R) A) A] at hh'
    exact_mod_cast hh'.trans_eq (pow_two (A + ringDilate (u : R) A).card).symm
  have hbound := (mem_ring_sum_stabilizer A K (u : R)).mp hu
  apply (mul_le_mul_iff_left₀ hAp).mp
  calc
    _ ≤ _ := hh
    _ ≤ (K * (A.card : ℝ)) ^ 2 := pow_le_pow_left₀ (Nat.cast_nonneg _) hbound 2
    _ = _ := by ring

theorem ring_sum_stabilizer_add_power {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {K : ℝ} {x y : R} (hA : A.Nonempty) (hK : 1 ≤ K)
    (hdouble : ((A + A).card : ℝ) ≤ K * (A.card : ℝ))
    (hx : x ∈ ringSumStabilizer A K) (hy : y ∈ ringSumStabilizer A K) :
    x + y ∈ ringSumStabilizer A (K ^ (8 : ℕ)) := by
  have hK0 : 0 ≤ K := (by norm_num : (0 : ℝ) ≤ 1).trans hK
  have hh := ring_sum_stabilizer_add hA hK0 hK0 hK0 hdouble hx hy
  apply ring_sum_stabilizer_mono A (show K * K * K ^ (5 : ℕ) ≤ K ^ (8 : ℕ) from ?_) hh
  calc
    _ = K ^ (7 : ℕ) := by ring
    _ ≤ _ := pow_le_pow_right₀ hK (by norm_num)

theorem ring_sum_stabilizer_mul_power {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {K : ℝ} {x y : R} (hA : A.Nonempty) (hK : 1 ≤ K)
    (hdouble : ((A + A).card : ℝ) ≤ K * (A.card : ℝ))
    (hx : x ∈ ringSumStabilizer A K) (hy : y ∈ ringSumStabilizer A K) :
    x * y ∈ ringSumStabilizer A (K ^ (8 : ℕ)) := by
  have hK0 : 0 ≤ K := (by norm_num : (0 : ℝ) ≤ 1).trans hK
  have hh := ring_sum_stabilizer_mul hA hK0 hK0 hK0 hdouble hx hy
  have heq : K ^ (2 : ℕ) * K * K ^ (5 : ℕ) = K ^ (8 : ℕ) := by ring
  rwa [heq] at hh

theorem ring_sum_stabilizer_neg_power {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A : Finset R} {K : ℝ} {x : R} (hA : A.Nonempty) (hK : 1 ≤ K)
    (hdouble : ((A + A).card : ℝ) ≤ K * (A.card : ℝ))
    (hx : x ∈ ringSumStabilizer A K) : -x ∈ ringSumStabilizer A (K ^ (8 : ℕ)) := by
  have hK0 : 0 ≤ K := (by norm_num : (0 : ℝ) ≤ 1).trans hK
  have hh := ring_sum_stabilizer_neg hA hK0 hK0 hdouble hx
  apply ring_sum_stabilizer_mono A (show K * K ≤ K ^ (8 : ℕ) from ?_) hh
  calc
    _ = K ^ (2 : ℕ) := by ring
    _ ≤ _ := pow_le_pow_right₀ hK (by norm_num)

/-- The sum-product closure used in the growth theorem remains a stabilizer,
with a fixed power loss in the parameter. This does not require units. -/
theorem ring_sum_stabilizer_quadratic_closure {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A S : Finset R} {K : ℝ} (hA : A.Nonempty) (hK : 1 ≤ K)
    (hdouble : ((A + A).card : ℝ) ≤ K * (A.card : ℝ)) (hS : S ⊆ ringSumStabilizer A K) :
    (insert 0 (S ∪ S * S) + insert 0 (S ∪ S * S)) ⊆ ringSumStabilizer A (K ^ (64 : ℕ)) := by
  have hKK : K ≤ K ^ (8 : ℕ) := by
    simpa only [pow_one] using pow_le_pow_right₀ hK (show 1 ≤ (8 : ℕ) by norm_num)
  have hF : insert 0 (S ∪ S * S) ⊆ ringSumStabilizer A (K ^ (8 : ℕ)) := by
    intro x hx
    rcases Finset.mem_insert.mp hx with rfl | hx
    · exact ring_sum_stabilizer_mono A hKK (ring_sum_stabilizer_zero hA hK)
    · rcases Finset.mem_union.mp hx with hx | hx
      · exact ring_sum_stabilizer_mono A hKK (hS hx)
      · obtain ⟨a, ha, b, hb, rfl⟩ := Finset.mem_mul.mp hx
        exact ring_sum_stabilizer_mul_power hA hK hdouble (hS ha) (hS hb)
  intro z hz
  obtain ⟨x, hx, y, hy, rfl⟩ := Finset.mem_add.mp hz
  have hdouble' : ((A + A).card : ℝ) ≤ K ^ (8 : ℕ) * (A.card : ℝ) :=
    hdouble.trans (mul_le_mul_of_nonneg_right hKK (Nat.cast_nonneg _))
  have hh := ring_sum_stabilizer_add_power hA (one_le_pow₀ hK) hdouble' (hF hx) (hF hy)
  simpa only [← pow_mul, show (8 : ℕ) * 8 = 64 from rfl] using hh


/- Fourier averaging and a density bound for all additive stabilizers. -/

theorem cyclic_set_indicator_norm {q : ℕ} [NeZero q] (A : Finset (ZMod q)) (x : ZMod q) :
    ‖cyclicSetIndicator A x‖ = if x ∈ A then (1 : ℝ) else 0 := by
  classical
  by_cases hx : x ∈ A <;> simp [cyclicSetIndicator, hx]

theorem cyclic_set_indicator_norm_sum {q : ℕ} [NeZero q] (A : Finset (ZMod q)) :
    (∑ x : ZMod q, ‖cyclicSetIndicator A x‖) = (A.card : ℝ) := by
  classical
  simp [cyclic_set_indicator_norm]

theorem cyclic_set_indicator_sq_norm_sum {q : ℕ} [NeZero q] (A : Finset (ZMod q)) :
    (∑ x : ZMod q, ‖cyclicSetIndicator A x‖ ^ 2) = (A.card : ℝ) := by
  classical
  simp [cyclic_set_indicator_norm, ite_pow]

theorem cyclic_set_indicator_pushforward {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (T : ZMod q → ZMod q) (z : ZMod q) :
    cyclicPushforward (cyclicSetIndicator A) T z = ((A.filter (fun x => T x = z)).card : ℂ) := by
  classical
  have heq (x : ZMod q) : (if T x = z then (if x ∈ A then (1 : ℂ) else 0) else 0) =
      if x ∈ A then (if T x = z then (1 : ℂ) else 0) else 0 := by
    by_cases hx : x ∈ A <;> by_cases hz : T x = z <;> simp [hx, hz]
  unfold cyclicPushforward cyclicSetIndicator
  simp_rw [heq]
  simp only [← Finset.sum_filter, Finset.filter_mem_eq_inter, Finset.univ_inter,
    Finset.sum_const, nsmul_eq_mul, mul_one]

theorem cyclic_set_pushforward_norm_sum {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (T : ZMod q → ZMod q) :
    (∑ z : ZMod q, ‖cyclicPushforward (cyclicSetIndicator A) T z‖) = (A.card : ℝ) := by
  simp_rw [cyclic_set_indicator_pushforward, Complex.norm_natCast]
  exact_mod_cast (Finset.card_eq_sum_card_fiberwise (f := T) (s := A)
    (t := Finset.univ) (fun _ _ => Finset.mem_univ _)).symm

theorem dft_cyclic_pushforward_mul {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (k x : ZMod q) :
    ZMod.dft (cyclicPushforward f (fun a => a * k)) x = ZMod.dft f (x * k) := by
  rw [dft_cyclicPushforward, ZMod.dft_apply]
  apply Finset.sum_congr rfl
  intro a ha
  simp only [smul_eq_mul]
  rw [show a * k * x = a * (x * k) by ring]

theorem uniform_mul_fourier_energy_eq_pushforward {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (k : ZMod q) :
    (∑ x : ZMod q, (1 / (q : ℝ)) * ‖ZMod.dft f (x * k)‖ ^ 2) =
      ∑ z : ZMod q, ‖cyclicPushforward f (fun a => a * k) z‖ ^ 2 := by
  have hh := dft_parseval (cyclicPushforward f (fun a => a * k))
  simp_rw [dft_cyclic_pushforward_mul] at hh
  rw [← Finset.mul_sum, hh]
  have hq : (q : ℝ) ≠ 0 := by exact_mod_cast NeZero.ne q
  field_simp

theorem uniform_set_fourier_energy_le_fibers {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (k : ZMod q) {M : ℝ}
    (hM : ∀ z : ZMod q, ((A.filter (fun a => a * k = z)).card : ℝ) ≤ M) :
    (∑ x : ZMod q, (1 / (q : ℝ)) * ‖ZMod.dft (cyclicSetIndicator A) (x * k)‖ ^ 2) ≤
      M * (A.card : ℝ) := by
  rw [uniform_mul_fourier_energy_eq_pushforward]
  calc
    _ ≤ ∑ z : ZMod q, M * ‖cyclicPushforward (cyclicSetIndicator A) (fun a => a * k) z‖ := by
      apply Finset.sum_le_sum
      intro z hz
      have hb : ‖cyclicPushforward (cyclicSetIndicator A) (fun a => a * k) z‖ ≤ M := by
        simpa only [cyclic_set_indicator_pushforward, Complex.norm_natCast] using hM z
      simpa only [pow_two] using mul_le_mul_of_nonneg_right hb (norm_nonneg _)
    _ = _ := by rw [← Finset.mul_sum, cyclic_set_pushforward_norm_sum]

theorem finite_fiber_card_le_of_kernel {α β κ : Type*} [DecidableEq α] [DecidableEq β] [DecidableEq κ]
    (A : Finset α) (f : α → β) (g : α → κ) {M : ℝ} (hM : 0 ≤ M)
    (hkernel : ∀ a b : α, f a = f b → g a = g b)
    (hbound : ∀ r : κ, ((A.filter (fun a => g a = r)).card : ℝ) ≤ M) :
    ∀ z : β, ((A.filter (fun a => f a = z)).card : ℝ) ≤ M := by
  classical
  intro z
  by_cases hF : (A.filter (fun a => f a = z)).Nonempty
  · obtain ⟨a₀, ha₀⟩ := hF
    have hsub : A.filter (fun a => f a = z) ⊆ A.filter (fun a => g a = g a₀) := by
      intro a ha
      obtain ⟨haA, haz⟩ := Finset.mem_filter.mp ha
      exact Finset.mem_filter.mpr ⟨haA, hkernel a a₀ (haz.trans (Finset.mem_filter.mp ha₀).2.symm)⟩
    exact (show ((A.filter (fun a => f a = z)).card : ℝ) ≤
      ((A.filter (fun a => g a = g a₀)).card : ℝ) by exact_mod_cast Finset.card_le_card hsub).trans (hbound _)
  · simpa only [Finset.not_nonempty_iff_eq_empty.mp hF, Finset.card_empty, Nat.cast_zero] using hM

theorem dyadic_mul_kernel_refines_coarse {J L : ℕ} (hL : L ≤ J) {k : ZMod (2 ^ J)}
    (hk : L ≤ dyadicConductorLevel k) (a b : ZMod (2 ^ J)) (hab : a * k = b * k) :
    (a.val : ZMod (2 ^ L)) = (b.val : ZMod (2 ^ L)) := by
  have hkill : (a - b) * k = 0 := by rw [sub_mul, hab, sub_self]
  have hd : addOrderOf k ∣ (a - b).val := by
    apply addOrderOf_dvd_iff_nsmul_eq_zero.mpr
    simpa only [nsmul_eq_mul, ZMod.natCast_zmod_val] using hkill
  rw [(dyadic_conductor_spec k).2] at hd
  have hdL : 2 ^ L ∣ (a - b).val := (pow_dvd_pow 2 hk).trans hd
  have hh := dyadic_sub_val_mod hL a.val b.val
  simp only [ZMod.natCast_zmod_val] at hh
  have hzero : ((a.val : ZMod (2 ^ L)) - (b.val : ZMod (2 ^ L))).val = 0 :=
    hh.symm.trans (Nat.mod_eq_zero_of_dvd hdL)
  apply sub_eq_zero.mp
  apply ZMod.val_injective (2 ^ L)
  simpa only [ZMod.val_zero] using hzero

theorem dyadic_uniform_set_fourier_energy_coarse {J L : ℕ} (hL : L ≤ J)
    (A : Finset (ZMod (2 ^ J))) {M : ℝ} (hM : 0 ≤ M)
    (hbound : ∀ r : ZMod (2 ^ L),
      ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤ M * (A.card : ℝ))
    {k : ZMod (2 ^ J)} (hk : L ≤ dyadicConductorLevel k) :
    (∑ x : ZMod (2 ^ J), (1 / ((2 ^ J : ℕ) : ℝ)) *
      ‖ZMod.dft (cyclicSetIndicator A) (x * k)‖ ^ 2) ≤ M * (A.card : ℝ) ^ 2 := by
  have hfiber := finite_fiber_card_le_of_kernel A (fun a => a * k)
    (fun a => (a.val : ZMod (2 ^ L))) (show 0 ≤ M * (A.card : ℝ) by positivity)
    (dyadic_mul_kernel_refines_coarse hL hk) hbound
  have hh := uniform_set_fourier_energy_le_fibers A k hfiber
  simpa only [mul_assoc, pow_two] using hh

theorem dyadic_low_conductor_card_le {J L : ℕ} (hL : L ≤ J) :
    (Finset.univ.filter (fun k : ZMod (2 ^ J) => dyadicConductorLevel k ≤ L)).card ≤ 2 ^ L := by
  classical
  have hsub : (Finset.univ.filter (fun k : ZMod (2 ^ J) => dyadicConductorLevel k ≤ L)) ⊆
      Finset.univ.filter (fun k : ZMod (2 ^ J) => k * ((2 ^ L : ℕ) : ZMod (2 ^ J)) = 0) := by
    intro k hk
    have hh := dyadic_conductor_power_nsmul_eq_zero (Finset.mem_filter.mp hk).2
    exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, by
      simpa only [nsmul_eq_mul, mul_comm] using hh⟩
  calc
    _ ≤ (Finset.univ.filter (fun k : ZMod (2 ^ J) => k * ((2 ^ L : ℕ) : ZMod (2 ^ J)) = 0)).card :=
      Finset.card_le_card hsub
    _ ≤ (2 ^ J).gcd (2 ^ L) := zmod_mul_zero_fiber_card_le (2 ^ L)
    _ = _ := Nat.gcd_eq_right (pow_dvd_pow 2 hL)

noncomputable def cyclicSetDilateCollision {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (x : ZMod q) : ℝ :=
  ∑ z : ZMod q, ‖cyclicConvolution (cyclicSetIndicator A)
    (cyclicPushforward (cyclicSetIndicator A) (fun a => a * x)) z‖ ^ 2

theorem cyclic_set_dilate_collision_nonneg {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (x : ZMod q) : 0 ≤ cyclicSetDilateCollision A x := by
  unfold cyclicSetDilateCollision
  positivity

theorem cyclic_set_dilate_collision_fourier {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (x : ZMod q) :
    (q : ℝ) * cyclicSetDilateCollision A x =
      ∑ k : ZMod q, ‖ZMod.dft (cyclicSetIndicator A) k‖ ^ 2 *
        ‖ZMod.dft (cyclicSetIndicator A) (k * x)‖ ^ 2 := by
  unfold cyclicSetDilateCollision
  rw [← dft_parseval]
  simp only [dft_cyclicConvolution, dft_cyclic_pushforward_mul, norm_mul, mul_pow]

theorem cyclic_set_dilate_collision_sum_fourier {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) :
    (q : ℝ) * (∑ x : ZMod q, cyclicSetDilateCollision A x) =
      ∑ k : ZMod q, ‖ZMod.dft (cyclicSetIndicator A) k‖ ^ 2 *
        (∑ x : ZMod q, ‖ZMod.dft (cyclicSetIndicator A) (x * k)‖ ^ 2) := by
  rw [Finset.mul_sum]
  simp_rw [cyclic_set_dilate_collision_fourier]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro k hk
  rw [Finset.mul_sum]
  apply Finset.sum_congr rfl
  intro x hx
  rw [mul_comm x k]

/-- Coarse residue control bounds the average additive collision of all dilates,
including multiplication by nonunits. -/
theorem dyadic_set_dilate_collision_sum_bound {J L : ℕ} (hL : L ≤ J)
    (A : Finset (ZMod (2 ^ J))) {M : ℝ} (hM : 0 ≤ M)
    (hbound : ∀ r : ZMod (2 ^ L),
      ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤ M * (A.card : ℝ)) :
    (∑ x : ZMod (2 ^ J), cyclicSetDilateCollision A x) ≤
      (2 : ℝ) ^ L * (A.card : ℝ) ^ 4 + (2 : ℝ) ^ J * M * (A.card : ℝ) ^ 3 := by
  classical
  let F := fun k : ZMod (2 ^ J) => ‖ZMod.dft (cyclicSetIndicator A) k‖ ^ 2
  let Q : ℝ := (2 : ℝ) ^ J
  let Z := Finset.univ.filter (fun k : ZMod (2 ^ J) => dyadicConductorLevel k ≤ L)
  have hQ : 0 < Q := by dsimp only [Q]; positivity
  have hF (k : ZMod (2 ^ J)) : 0 ≤ F k := sq_nonneg _
  have hFbound (k : ZMod (2 ^ J)) : F k ≤ (A.card : ℝ) ^ 2 := by
    have hh := norm_dft_le_sum_norm (cyclicSetIndicator A) k
    rw [cyclic_set_indicator_norm_sum] at hh
    exact pow_le_pow_left₀ (norm_nonneg _) hh 2
  have hsumF : (∑ k : ZMod (2 ^ J), F k) = Q * (A.card : ℝ) := by
    simpa only [F, Q, Nat.cast_pow, Nat.cast_ofNat, cyclic_set_indicator_sq_norm_sum] using
      dft_parseval (cyclicSetIndicator A)
  have hsum (k : ZMod (2 ^ J)) : (∑ x : ZMod (2 ^ J), F (x * k)) ≤ Q * (A.card : ℝ) ^ 2 := by
    calc
      _ ≤ ∑ _x : ZMod (2 ^ J), (A.card : ℝ) ^ 2 := Finset.sum_le_sum (fun x _ => hFbound _)
      _ = _ := by simp [Q]
  have hhigh (k : ZMod (2 ^ J)) (hk : k ∉ Z) :
      (∑ x : ZMod (2 ^ J), F (x * k)) ≤ Q * M * (A.card : ℝ) ^ 2 := by
    have hkL : L ≤ dyadicConductorLevel k := by
      have hh : ¬ dyadicConductorLevel k ≤ L := by
        intro hh
        exact hk (Finset.mem_filter.mpr ⟨Finset.mem_univ _, hh⟩)
      omega
    have hh := dyadic_uniform_set_fourier_energy_coarse hL A hM hbound hkL
    have heq : (∑ x : ZMod (2 ^ J), F (x * k)) =
        Q * (∑ x : ZMod (2 ^ J), (1 / ((2 ^ J : ℕ) : ℝ)) * F (x * k)) := by
      rw [← Finset.mul_sum]
      simp only [Nat.cast_pow, Nat.cast_ofNat]
      dsimp only [Q]
      field_simp
    calc
      _ = _ := heq
      _ ≤ Q * (M * (A.card : ℝ) ^ 2) := mul_le_mul_of_nonneg_left hh hQ.le
      _ = _ := by ring
  have hpoint (k : ZMod (2 ^ J)) : F k * (∑ x : ZMod (2 ^ J), F (x * k)) ≤
      (if k ∈ Z then Q * (A.card : ℝ) ^ 4 else 0) + Q * M * (A.card : ℝ) ^ 2 * F k := by
    by_cases hk : k ∈ Z
    · rw [if_pos hk]
      calc
        _ ≤ (A.card : ℝ) ^ 2 * (Q * (A.card : ℝ) ^ 2) :=
          mul_le_mul (hFbound k) (hsum k) (Finset.sum_nonneg (fun _ _ => hF _)) (by positivity)
        _ = Q * (A.card : ℝ) ^ 4 := by ring
        _ ≤ _ := le_add_of_nonneg_right (by positivity)
    · rw [if_neg hk, zero_add]
      calc
        _ ≤ F k * (Q * M * (A.card : ℝ) ^ 2) := mul_le_mul_of_nonneg_left (hhigh k hk) (hF k)
        _ = _ := by ring
  have hZ : (Z.card : ℝ) ≤ (2 : ℝ) ^ L := by exact_mod_cast dyadic_low_conductor_card_le hL
  apply (mul_le_mul_iff_right₀ hQ).mp
  calc
    _ = ∑ k : ZMod (2 ^ J), F k * (∑ x : ZMod (2 ^ J), F (x * k)) := by
      simpa only [Q, F, Nat.cast_pow, Nat.cast_ofNat] using cyclic_set_dilate_collision_sum_fourier A
    _ ≤ ∑ k : ZMod (2 ^ J), ((if k ∈ Z then Q * (A.card : ℝ) ^ 4 else 0) +
        Q * M * (A.card : ℝ) ^ 2 * F k) := Finset.sum_le_sum (fun k _ => hpoint k)
    _ = (Z.card : ℝ) * (Q * (A.card : ℝ) ^ 4) + Q * M * (A.card : ℝ) ^ 2 * (Q * (A.card : ℝ)) := by
      rw [Finset.sum_add_distrib, ← Finset.mul_sum, hsumF]
      rw [← Finset.sum_filter, Finset.filter_mem_eq_inter, Finset.univ_inter]
      simp
    _ ≤ (2 : ℝ) ^ L * (Q * (A.card : ℝ) ^ 4) + Q * M * (A.card : ℝ) ^ 2 * (Q * (A.card : ℝ)) := by
      gcongr
    _ = _ := by dsimp only [Q]; ring

theorem cyclic_convolution_set_indicator_left {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (g : ZMod q → ℂ) (z : ZMod q) :
    cyclicConvolution (cyclicSetIndicator A) g z = ∑ a ∈ A, g (z - a) := by
  classical
  simp only [cyclicConvolution, cyclicSetIndicator, ite_mul, one_mul, zero_mul,
    ← Finset.sum_filter, Finset.filter_mem_eq_inter, Finset.univ_inter]

theorem cyclic_set_dilate_convolution_card {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (x z : ZMod q) :
    cyclicConvolution (cyclicSetIndicator A)
      (cyclicPushforward (cyclicSetIndicator A) (fun a => a * x)) z =
      (((A ×ˢ A).filter (fun p => p.1 + p.2 * x = z)).card : ℂ) := by
  classical
  rw [cyclic_convolution_set_indicator_left]
  simp_rw [cyclic_set_indicator_pushforward]
  simp only [Finset.card_eq_sum_ones, Nat.cast_sum, Nat.cast_one,
    Finset.sum_filter, Finset.sum_product]
  apply Finset.sum_congr rfl
  intro a ha
  apply Finset.sum_congr rfl
  intro b hb
  have heq : b * x = z - a ↔ a + b * x = z := by
    constructor
    · intro h
      rw [h, add_sub_cancel]
    · intro h
      rw [← h, add_sub_cancel_left]
  simp only [heq, Nat.cast_ite, Nat.cast_one, Nat.cast_zero]

theorem finite_map_collision_lower {α β : Type*} [DecidableEq α] [DecidableEq β] [Fintype β]
    (A : Finset α) (f : α → β) :
    (A.card : ℝ) ^ 2 ≤ ((A.image f).card : ℝ) *
      ∑ y : β, ((A.filter (fun a => f a = y)).card : ℝ) ^ 2 := by
  have hsum : (∑ y ∈ A.image f, ((A.filter (fun a => f a = y)).card : ℝ)) = (A.card : ℝ) := by
    exact_mod_cast (Finset.card_eq_sum_card_image f A).symm
  have hh := Finset.sum_mul_sq_le_sq_mul_sq (A.image f) (fun _ => (1 : ℝ))
    (fun y => ((A.filter (fun a => f a = y)).card : ℝ))
  simp only [one_mul, one_pow, Finset.sum_const, nsmul_eq_mul, mul_one, hsum] at hh
  exact hh.trans (mul_le_mul_of_nonneg_left
    (Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) (fun _ _ _ => sq_nonneg _))
    (Nat.cast_nonneg _))

theorem ring_sum_dilate_product_image {R : Type*} [CommRing R] [DecidableEq R]
    (A : Finset R) (x : R) :
    (A ×ˢ A).image (fun p => p.1 + p.2 * x) = A + ringDilate x A := by
  ext z
  constructor
  · intro hz
    obtain ⟨⟨a, b⟩, hab, rfl⟩ := Finset.mem_image.mp hz
    obtain ⟨ha, hb⟩ := Finset.mem_product.mp hab
    exact Finset.mem_add.mpr ⟨a, ha, x * b, Finset.mem_image_of_mem _ hb, by rw [mul_comm x b]⟩
  · intro hz
    obtain ⟨a, ha, y, hy, rfl⟩ := Finset.mem_add.mp hz
    obtain ⟨b, hb, rfl⟩ := Finset.mem_image.mp hy
    exact Finset.mem_image.mpr ⟨(a, b), Finset.mem_product.mpr ⟨ha, hb⟩, by rw [mul_comm b x]⟩

theorem cyclic_set_dilate_sumset_collision {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (x : ZMod q) :
    (A.card : ℝ) ^ 4 ≤ ((A + ringDilate x A).card : ℝ) * cyclicSetDilateCollision A x := by
  have hh := finite_map_collision_lower (A ×ˢ A) (fun p => p.1 + p.2 * x)
  rw [ring_sum_dilate_product_image] at hh
  have heq : cyclicSetDilateCollision A x =
      ∑ z : ZMod q, (((A ×ˢ A).filter (fun p => p.1 + p.2 * x = z)).card : ℝ) ^ 2 := by
    simp only [cyclicSetDilateCollision, cyclic_set_dilate_convolution_card, Complex.norm_natCast]
  rw [heq]
  calc
    _ = ((A ×ˢ A).card : ℝ) ^ 2 := by rw [Finset.card_product, Nat.cast_mul]; ring
    _ ≤ _ := hh

theorem ring_sum_stabilizer_collision_lower {q : ℕ} [NeZero q]
    {A : Finset (ZMod q)} {K : ℝ} {x : ZMod q} (hA : A.Nonempty)
    (hx : x ∈ ringSumStabilizer A K) :
    (A.card : ℝ) ^ 3 ≤ K * cyclicSetDilateCollision A x := by
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  have hx' := (mem_ring_sum_stabilizer A K x).mp hx
  apply (mul_le_mul_iff_right₀ hAp).mp
  calc
    _ = (A.card : ℝ) ^ 4 := by ring
    _ ≤ _ := cyclic_set_dilate_sumset_collision A x
    _ ≤ (K * (A.card : ℝ)) * cyclicSetDilateCollision A x :=
      mul_le_mul_of_nonneg_right hx' (cyclic_set_dilate_collision_nonneg A x)
    _ = _ := by ring

/-- A single coarse fiber bound controls the size of the full stabilizer,
without restricting its multipliers to units. -/
theorem dyadic_sum_stabilizer_card_bound {J L : ℕ} (hL : L ≤ J)
    {A : Finset (ZMod (2 ^ J))} {M K : ℝ} (hA : A.Nonempty) (hM : 0 ≤ M) (hK : 0 ≤ K)
    (hbound : ∀ r : ZMod (2 ^ L),
      ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤ M * (A.card : ℝ)) :
    ((ringSumStabilizer A K).card : ℝ) ≤ K * ((2 : ℝ) ^ L * (A.card : ℝ) + (2 : ℝ) ^ J * M) := by
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  apply (mul_le_mul_iff_left₀ (show (0 : ℝ) < (A.card : ℝ) ^ 3 by positivity)).mp
  calc
    _ = ∑ _x ∈ ringSumStabilizer A K, (A.card : ℝ) ^ 3 := by simp
    _ ≤ ∑ x ∈ ringSumStabilizer A K, K * cyclicSetDilateCollision A x :=
      Finset.sum_le_sum (fun x hx => ring_sum_stabilizer_collision_lower hA hx)
    _ ≤ ∑ x : ZMod (2 ^ J), K * cyclicSetDilateCollision A x :=
      Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _)
        (fun x _ _ => mul_nonneg hK (cyclic_set_dilate_collision_nonneg A x))
    _ = K * ∑ x : ZMod (2 ^ J), cyclicSetDilateCollision A x := (Finset.mul_sum _ _ _).symm
    _ ≤ K * ((2 : ℝ) ^ L * (A.card : ℝ) ^ 4 + (2 : ℝ) ^ J * M * (A.card : ℝ) ^ 3) :=
      mul_le_mul_of_nonneg_left (dyadic_set_dilate_collision_sum_bound hL A hM hbound) hK
    _ = _ := by ring

/-- Nonconcentration and a density deficit force a power-saving upper bound
on every additive stabilizer, uniformly in its parameter. -/
theorem exists_dyadic_sum_stabilizer_density_bound {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ c ε : ℝ, 0 < c ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset (ZMod (2 ^ J)), A.Nonempty →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
          ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
            (2 : ℝ) ^ (-γ * (L : ℝ)) * (A.card : ℝ)) →
        ∀ K : ℝ, 0 ≤ K → ((ringSumStabilizer A K).card : ℝ) ≤
          K * (2 : ℝ) ^ ((1 - c) * (J : ℝ)) := by
  let c₀ := min (δ / 2) (γ * δ / 4)
  have hc₀ : 0 < c₀ := lt_min (by positivity) (by positivity)
  have hcδ : c₀ ≤ δ / 2 := min_le_left _ _
  have hcγ : c₀ ≤ γ * δ / 4 := min_le_right _ _
  obtain ⟨J₀, hJ₀⟩ := exists_nat_ge (max (8 / δ) (2 / c₀))
  refine ⟨c₀ / 2, δ / 8, by positivity, by positivity, by linarith, J₀, ?_⟩
  intro J hJ A hA hsize hmass K hK
  have hJr : (J₀ : ℝ) ≤ J := by exact_mod_cast hJ
  have hJ8 : 8 / δ ≤ (J : ℝ) := (le_max_left _ _).trans (hJ₀.trans hJr)
  have hJ2 : 2 / c₀ ≤ (J : ℝ) := (le_max_right _ _).trans (hJ₀.trans hJr)
  have hδJ : 8 ≤ δ * (J : ℝ) := by
    have hh := (div_le_iff₀ hδ).mp hJ8
    nlinarith
  have hcJ : 2 ≤ c₀ * (J : ℝ) := by
    have hh := (div_le_iff₀ hc₀).mp hJ2
    nlinarith
  let L := Nat.floor (δ * (J : ℝ) / 2)
  have hLupper : (L : ℝ) ≤ δ * (J : ℝ) / 2 := Nat.floor_le (by positivity)
  have hLlt : δ * (J : ℝ) / 2 < (L : ℝ) + 1 := Nat.lt_floor_add_one _
  have hLlower : δ * (J : ℝ) / 4 ≤ (L : ℝ) := by linarith
  have hεL : δ / 8 * (J : ℝ) < (L : ℝ) := by nlinarith
  have hLJ : L ≤ J := by
    have hh : (L : ℝ) ≤ (J : ℝ) := by nlinarith [show (0 : ℝ) ≤ J from Nat.cast_nonneg _]
    exact_mod_cast hh
  have hcard := dyadic_sum_stabilizer_card_bound hLJ hA
    (show (0 : ℝ) ≤ (2 : ℝ) ^ (-γ * (L : ℝ)) by positivity) hK (hmass L hLJ hεL)
  have hfirst : (2 : ℝ) ^ L * (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - c₀) * (J : ℝ)) := by
    calc
      _ ≤ (2 : ℝ) ^ L * (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) :=
        mul_le_mul_of_nonneg_left hsize (by positivity)
      _ = (2 : ℝ) ^ ((L : ℝ) + (1 - δ) * (J : ℝ)) := by
        rw [← Real.rpow_natCast, ← Real.rpow_add (by norm_num)]
      _ ≤ _ := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        have hh := mul_le_mul_of_nonneg_right hcδ (Nat.cast_nonneg J : (0 : ℝ) ≤ J)
        nlinarith
  have hsecond : (2 : ℝ) ^ J * (2 : ℝ) ^ (-γ * (L : ℝ)) ≤
      (2 : ℝ) ^ ((1 - c₀) * (J : ℝ)) := by
    calc
      _ = (2 : ℝ) ^ ((J : ℝ) - γ * (L : ℝ)) := by
        rw [← Real.rpow_natCast, ← Real.rpow_add (by norm_num)]
        congr 1
        ring
      _ ≤ _ := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        have hh := mul_le_mul_of_nonneg_right hcγ (Nat.cast_nonneg J : (0 : ℝ) ≤ J)
        have hl := mul_le_mul_of_nonneg_left hLlower hγ.le
        nlinarith
  have htwo : (2 : ℝ) ≤ (2 : ℝ) ^ ((c₀ / 2) * (J : ℝ)) := by
    calc
      _ = (2 : ℝ) ^ (1 : ℝ) := (Real.rpow_one 2).symm
      _ ≤ _ := Real.rpow_le_rpow_of_exponent_le (by norm_num) (by nlinarith)
  calc
    _ ≤ K * ((2 : ℝ) ^ L * (A.card : ℝ) + (2 : ℝ) ^ J * (2 : ℝ) ^ (-γ * (L : ℝ))) := hcard
    _ ≤ K * ((2 : ℝ) ^ ((1 - c₀) * (J : ℝ)) + (2 : ℝ) ^ ((1 - c₀) * (J : ℝ))) := by gcongr
    _ = K * (2 * (2 : ℝ) ^ ((1 - c₀) * (J : ℝ))) := by ring
    _ ≤ K * ((2 : ℝ) ^ ((c₀ / 2) * (J : ℝ)) * (2 : ℝ) ^ ((1 - c₀) * (J : ℝ))) := by gcongr
    _ = _ := by
      rw [← Real.rpow_add (by norm_num)]
      congr 2
      ring



/- Iterated stabilizer growth and energy saving for unit dilates. -/

theorem exists_dyadic_sum_product_double_growth_of_projection {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ σ ε : ℝ, 0 < σ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset ℕ,
        A.Nonempty → (∀ x ∈ A, x < 2 ^ J) →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ j : ℕ, j ≤ J → ε * (J : ℝ) < (j : ℝ) →
          (2 : ℝ) ^ (γ * (j : ℝ)) ≤ ((dyadicProjection A j).card : ℝ)) →
        (2 : ℝ) ^ (σ * (J : ℝ)) * (A.card : ℝ) ≤
          ((natResidueGenerators (natLinearQuadraticSet A) (2 ^ J) +
            natResidueGenerators (natLinearQuadraticSet A) (2 ^ J)).card : ℝ) := by
  obtain ⟨κ, ε, hκ, hε, hε4, K, J₀, hK, hgrowth⟩ :=
    exists_dyadic_signed_sum_product_growth hγ hδ hδ1
  let σ := κ / (4 * (K : ℝ) + 2)
  have hden : 0 < 4 * (K : ℝ) + 2 := by positivity
  have hσ : 0 < σ := div_pos hκ hden
  have hexp : σ * ((2 * K + 1 : ℕ) : ℝ) = κ / 2 := by
    dsimp [σ]
    push_cast
    field_simp
    ring
  refine ⟨σ, ε, hσ, hε, hε4, max J₀ 1, ?_⟩
  intro J hJ A hA hbound hsize hmass
  have hJ₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hJ1 : 1 ≤ J := (le_max_right _ _).trans hJ
  have hJp : (0 : ℝ) < J := by exact_mod_cast (show 0 < J by omega)
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast Finset.card_pos.mpr hA
  by_contra h
  have hupper := nat_signed_hull_bound_of_double_bound (natLinearQuadraticSet A) K
    (q := 2 ^ J) (by exact_mod_cast nat_linear_quadratic_generators_card_ge hbound)
    (show 0 ≤ (2 : ℝ) ^ (σ * (J : ℝ)) by positivity) (lt_of_not_ge h).le
  have hpowlt : ((2 : ℝ) ^ (σ * (J : ℝ))) ^ (2 * K + 1) < (2 : ℝ) ^ (κ * (J : ℝ)) := by
    rw [← Real.rpow_mul_natCast (by norm_num)]
    apply Real.rpow_lt_rpow_of_exponent_lt (by norm_num)
    have hEq : σ * (J : ℝ) * ((2 * K + 1 : ℕ) : ℝ) = κ / 2 * (J : ℝ) := by
      rw [mul_right_comm, hexp]
    rw [hEq]
    nlinarith [mul_pos hκ hJp]
  exact (not_lt_of_ge (hgrowth J hJ₀ A hA hbound hsize hmass))
    (hupper.trans_lt (mul_lt_mul_of_pos_right hpowlt hAp))

def ringQuadraticClosure {R : Type*} [Ring R] [DecidableEq R] (S : Finset R) : Finset R :=
  insert 0 (S ∪ S * S) + insert 0 (S ∪ S * S)

def ringQuadraticIterate {R : Type*} [Ring R] [DecidableEq R] (S : Finset R) : ℕ → Finset R
  | 0 => S
  | n + 1 => ringQuadraticClosure (ringQuadraticIterate S n)

def dyadicRingProjection {J : ℕ} (A : Finset (ZMod (2 ^ J))) (j : ℕ) : Finset (ZMod (2 ^ j)) :=
  A.image (fun x => (x.val : ZMod (2 ^ j)))

theorem ring_quadratic_closure_extensive {R : Type*} [Ring R] [DecidableEq R] (S : Finset R) :
    S ⊆ ringQuadraticClosure S := by
  intro x hx
  exact Finset.mem_add.mpr ⟨x, Finset.mem_insert_of_mem (Finset.mem_union_left _ hx),
    0, Finset.mem_insert_self _ _, add_zero x⟩

theorem ring_quadratic_iterate_extensive {R : Type*} [Ring R] [DecidableEq R]
    (S : Finset R) (n : ℕ) : S ⊆ ringQuadraticIterate S n := by
  induction n with
  | zero => exact Finset.Subset.refl _
  | succ n ih => exact ih.trans (ring_quadratic_closure_extensive _)

theorem ring_quadratic_iterate_stabilizer {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    {A S : Finset R} {K : ℝ} (hA : A.Nonempty) (hK : 1 ≤ K)
    (hdouble : ((A + A).card : ℝ) ≤ K * (A.card : ℝ))
    (hS : S ⊆ ringSumStabilizer A K) (n : ℕ) :
    ringQuadraticIterate S n ⊆ ringSumStabilizer A (K ^ (64 ^ n)) := by
  induction n with
  | zero => simpa only [ringQuadraticIterate, pow_zero, pow_one] using hS
  | succ n ih =>
    have hKK : K ≤ K ^ (64 ^ n) := by
      have hn : 1 ≤ (64 : ℕ) ^ n := Nat.succ_le_of_lt (pow_pos (by norm_num) n)
      simpa only [pow_one] using pow_le_pow_right₀ hK hn
    have hd : ((A + A).card : ℝ) ≤ K ^ (64 ^ n) * (A.card : ℝ) :=
      hdouble.trans (mul_le_mul_of_nonneg_right hKK (Nat.cast_nonneg _))
    have hh := ring_sum_stabilizer_quadratic_closure hA (one_le_pow₀ hK) hd ih
    have heq : (K ^ (64 ^ n)) ^ (64 : ℕ) = K ^ (64 ^ (n + 1)) := by
      rw [← pow_mul, ← pow_succ]
    rw [heq] at hh
    exact hh

theorem dyadic_ring_projection_mono {J : ℕ} {A B : Finset (ZMod (2 ^ J))}
    (hAB : A ⊆ B) (j : ℕ) : dyadicRingProjection A j ⊆ dyadicRingProjection B j :=
  Finset.image_subset_image hAB

theorem dyadic_ring_projection_card {J : ℕ} (A : Finset (ZMod (2 ^ J))) (j : ℕ) :
    (dyadicRingProjection A j).card = (dyadicProjection (A.image ZMod.val) j).card := by
  rw [← Finset.card_image_of_injective (dyadicRingProjection A j) (ZMod.val_injective _)]
  simp only [dyadicRingProjection, dyadicProjection, Finset.image_image, Function.comp_def,
    ZMod.val_natCast]

theorem zmod_cast_image_val {q : ℕ} [NeZero q] (A : Finset (ZMod q)) :
    (A.image ZMod.val).image (fun n : ℕ => (n : ZMod q)) = A := by
  simp [Finset.image_image]

/-- Sum-product growth in the native residue ring, under projection lower bounds.
These hypotheses pass to every superset, as needed for iteration. -/
theorem exists_dyadic_ring_quadratic_growth {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ σ ε : ℝ, 0 < σ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset (ZMod (2 ^ J)), A.Nonempty →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ j : ℕ, j ≤ J → ε * (J : ℝ) < (j : ℝ) →
          (2 : ℝ) ^ (γ * (j : ℝ)) ≤ ((dyadicRingProjection A j).card : ℝ)) →
        (2 : ℝ) ^ (σ * (J : ℝ)) * (A.card : ℝ) ≤ ((ringQuadraticClosure A).card : ℝ) := by
  obtain ⟨σ, ε, hσ, hε, hε4, J₀, hg⟩ :=
    exists_dyadic_sum_product_double_growth_of_projection hγ hδ hδ1
  refine ⟨σ, ε, hσ, hε, hε4, J₀, ?_⟩
  intro J hJ A hA hsize hproj
  have hcard : (A.image ZMod.val).card = A.card :=
    Finset.card_image_of_injective _ (ZMod.val_injective _)
  have hb : ∀ x ∈ A.image ZMod.val, x < 2 ^ J := by
    intro x hx
    obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hx
    exact ZMod.val_lt _
  have hh := hg J hJ (A.image ZMod.val) (hA.image _) hb
    (by simpa only [hcard] using hsize)
    (fun j hj hjε => by simpa only [← dyadic_ring_projection_card] using hproj j hj hjε)
  simpa only [hcard, nat_linear_quadratic_residue_generators, zmod_cast_image_val,
    ringQuadraticClosure] using hh

theorem dyadic_ring_quadratic_iterate_card_growth {J R : ℕ}
    {S : Finset (ZMod (2 ^ J))} {g B γ ε : ℝ} (hS : S.Nonempty) (hg : 0 ≤ g)
    (hproj : ∀ j : ℕ, j ≤ J → ε * (J : ℝ) < (j : ℝ) →
      (2 : ℝ) ^ (γ * (j : ℝ)) ≤ ((dyadicRingProjection S j).card : ℝ))
    (hgrowth : ∀ U : Finset (ZMod (2 ^ J)), U.Nonempty → (U.card : ℝ) ≤ B →
      (∀ j : ℕ, j ≤ J → ε * (J : ℝ) < (j : ℝ) →
        (2 : ℝ) ^ (γ * (j : ℝ)) ≤ ((dyadicRingProjection U j).card : ℝ)) →
      g * (U.card : ℝ) ≤ ((ringQuadraticClosure U).card : ℝ))
    (hsize : ∀ i : ℕ, i < R → ((ringQuadraticIterate S i).card : ℝ) ≤ B) :
    g ^ R * (S.card : ℝ) ≤ ((ringQuadraticIterate S R).card : ℝ) := by
  have hi : ∀ i : ℕ, i ≤ R → g ^ i * (S.card : ℝ) ≤ ((ringQuadraticIterate S i).card : ℝ) := by
    intro i
    induction i with
    | zero => intro _; simp [ringQuadraticIterate]
    | succ i ih =>
      intro hi
      have hsub := ring_quadratic_iterate_extensive S i
      calc
        _ = g * (g ^ i * (S.card : ℝ)) := by rw [pow_succ]; ring
        _ ≤ g * ((ringQuadraticIterate S i).card : ℝ) :=
          mul_le_mul_of_nonneg_left (ih (by omega)) hg
        _ ≤ _ := hgrowth _ (hS.mono hsub) (hsize i (by omega)) (fun j hj hεj =>
          (hproj j hj hεj).trans (by exact_mod_cast Finset.card_le_card (dyadic_ring_projection_mono hsub j)))
  exact hi R le_rfl

/-- A nonconcentrated set of moderate size cannot have a well-projecting
family of stabilizers at a sufficiently small power of the modulus. -/
theorem exists_dyadic_no_projecting_stabilizer {α β δ : ℝ}
    (hα : 0 < α) (hβ : 0 < β) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ η ε : ℝ, 0 < η ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A S : Finset (ZMod (2 ^ J)), A.Nonempty → S.Nonempty →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
          ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
            (2 : ℝ) ^ (-α * (L : ℝ)) * (A.card : ℝ)) →
        (∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) →
          (2 : ℝ) ^ (β * (L : ℝ)) ≤ ((dyadicRingProjection S L).card : ℝ)) →
        ((A + A).card : ℝ) ≤ (2 : ℝ) ^ (η * (J : ℝ)) * (A.card : ℝ) →
        ¬ S ⊆ ringSumStabilizer A ((2 : ℝ) ^ (η * (J : ℝ))) := by
  obtain ⟨c₀, ε₀, hc₀, hε₀, hε₀4, J₀, hstab⟩ :=
    exists_dyadic_sum_stabilizer_density_bound hα hδ hδ1
  let c := min c₀ 1
  have hc : 0 < c := lt_min hc₀ (by norm_num)
  have hcc₀ : c ≤ c₀ := min_le_left _ _
  have hc1 : c ≤ 1 := min_le_right _ _
  obtain ⟨σ, ε₁, hσ, hε₁, hε₁4, J₁, hgrowth⟩ :=
    exists_dyadic_ring_quadratic_growth hβ (show 0 < c / 2 by positivity) (by linarith)
  obtain ⟨R, hR⟩ := exists_nat_ge (2 / σ)
  have hσR : 2 ≤ σ * (R : ℝ) := by
    have hh := (div_le_iff₀ hσ).mp hR
    nlinarith
  let η := c / (2 * ((64 ^ R : ℕ) : ℝ))
  have hden : (0 : ℝ) < (64 ^ R : ℕ) := by positivity
  have hη : 0 < η := div_pos hc (mul_pos (by norm_num) hden)
  have hηR : η * ((64 ^ R : ℕ) : ℝ) = c / 2 := by
    dsimp [η]
    field_simp
  refine ⟨η, min ε₀ ε₁, hη, lt_min hε₀ hε₁,
    (min_le_left _ _).trans hε₀4, max (max J₀ J₁) 1, ?_⟩
  intro J hJ A S hA hS hsize hmass hproj hdouble hSstab
  have hJ₀ : J₀ ≤ J := (le_max_left _ _).trans ((le_max_left _ _).trans hJ)
  have hJ₁ : J₁ ≤ J := (le_max_right _ _).trans ((le_max_left _ _).trans hJ)
  have hJp : (0 : ℝ) < J := by exact_mod_cast (lt_of_lt_of_le (by norm_num : 0 < (1 : ℕ)) ((le_max_right _ _).trans hJ))
  have hJ0 := hJp.le
  have hm : ∀ L : ℕ, L ≤ J → ε₀ * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
      ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
        (2 : ℝ) ^ (-α * (L : ℝ)) * (A.card : ℝ) := by
    intro L hL hεL
    exact hmass L hL ((mul_le_mul_of_nonneg_right (min_le_left _ _) hJ0).trans_lt hεL)
  have hp : ∀ L : ℕ, L ≤ J → ε₁ * (J : ℝ) < (L : ℝ) →
      (2 : ℝ) ^ (β * (L : ℝ)) ≤ ((dyadicRingProjection S L).card : ℝ) := by
    intro L hL hεL
    exact hproj L hL ((mul_le_mul_of_nonneg_right (min_le_right _ _) hJ0).trans_lt hεL)
  let K := (2 : ℝ) ^ (η * (J : ℝ))
  have hK : 1 ≤ K := Real.one_le_rpow (by norm_num) (mul_nonneg hη.le hJ0)
  have hiter : ∀ i : ℕ, i ≤ R →
      ((ringQuadraticIterate S i).card : ℝ) ≤ (2 : ℝ) ^ ((1 - c / 2) * (J : ℝ)) := by
    intro i hi
    have hsub := ring_quadratic_iterate_stabilizer hA hK hdouble hSstab i
    have hexp : η * ((64 ^ i : ℕ) : ℝ) ≤ c / 2 := by
      rw [← hηR]
      apply mul_le_mul_of_nonneg_left _ hη.le
      exact_mod_cast Nat.pow_le_pow_right (by norm_num : 0 < (64 : ℕ)) hi
    calc
      _ ≤ ((ringSumStabilizer A (K ^ (64 ^ i))).card : ℝ) := by exact_mod_cast Finset.card_le_card hsub
      _ ≤ K ^ (64 ^ i) * (2 : ℝ) ^ ((1 - c₀) * (J : ℝ)) :=
        hstab J hJ₀ A hA hsize hm _ (by positivity)
      _ = (2 : ℝ) ^ ((η * ((64 ^ i : ℕ) : ℝ) + 1 - c₀) * (J : ℝ)) := by
        dsimp only [K]
        rw [← Real.rpow_mul_natCast (by norm_num), ← Real.rpow_add (by norm_num)]
        congr 1
        ring
      _ ≤ _ := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        apply mul_le_mul_of_nonneg_right _ hJ0
        linarith
  have hlower := dyadic_ring_quadratic_iterate_card_growth hS
    (show (0 : ℝ) ≤ (2 : ℝ) ^ (σ * (J : ℝ)) by positivity) hp
    (hgrowth J hJ₁) (fun i hi => hiter i hi.le)
  have hcard : ((ringQuadraticIterate S R).card : ℝ) ≤ (2 : ℝ) ^ J := by
    have hh : (ringQuadraticIterate S R).card ≤ 2 ^ J := by
      simpa only [ZMod.card] using (Finset.card_le_univ (s := ringQuadraticIterate S R))
    exact_mod_cast hh
  have hS1 : (1 : ℝ) ≤ S.card := by exact_mod_cast hS.card_pos
  have hupper : ((2 : ℝ) ^ (σ * (J : ℝ))) ^ R ≤ (2 : ℝ) ^ J := by
    calc
      _ = ((2 : ℝ) ^ (σ * (J : ℝ))) ^ R * 1 := (mul_one _).symm
      _ ≤ ((2 : ℝ) ^ (σ * (J : ℝ))) ^ R * (S.card : ℝ) :=
        mul_le_mul_of_nonneg_left hS1 (by positivity)
      _ ≤ _ := hlower.trans hcard
  have hlt : (2 : ℝ) ^ J < ((2 : ℝ) ^ (σ * (J : ℝ))) ^ R := by
    rw [← Real.rpow_natCast, ← Real.rpow_mul_natCast (by norm_num)]
    apply Real.rpow_lt_rpow_of_exponent_lt (by norm_num)
    have hh := mul_le_mul_of_nonneg_right hσR hJ0
    nlinarith
  exact (not_lt_of_ge hupper) hlt

theorem dyadic_ring_projection_growth_of_fiber_bound {J L : ℕ}
    {A : Finset (ZMod (2 ^ J))} {γ : ℝ} (hA : A.Nonempty)
    (hmass : ∀ r : ZMod (2 ^ L),
      ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
        (2 : ℝ) ^ (-γ * (L : ℝ)) * (A.card : ℝ)) :
    (2 : ℝ) ^ (γ * (L : ℝ)) ≤ ((dyadicRingProjection A L).card : ℝ) := by
  have hAp : (0 : ℝ) < A.card := by exact_mod_cast hA.card_pos
  have hh : (A.card : ℝ) ≤ ((dyadicRingProjection A L).card : ℝ) *
      ((2 : ℝ) ^ (-γ * (L : ℝ)) * (A.card : ℝ)) := by
    conv_lhs => rw [Finset.card_eq_sum_card_image (fun a => (a.val : ZMod (2 ^ L))) A, Nat.cast_sum]
    calc
      _ ≤ ∑ _r ∈ dyadicRingProjection A L,
          (2 : ℝ) ^ (-γ * (L : ℝ)) * (A.card : ℝ) :=
        Finset.sum_le_sum (fun r _ => hmass r)
      _ = _ := by simp
  have hbound : 1 ≤ ((dyadicRingProjection A L).card : ℝ) * (2 : ℝ) ^ (-γ * (L : ℝ)) := by
    apply (mul_le_mul_iff_left₀ hAp).mp
    simpa only [one_mul, mul_assoc] using hh
  have hinv : (2 : ℝ) ^ (-γ * (L : ℝ)) * (2 : ℝ) ^ (γ * (L : ℝ)) = 1 := by
    rw [← Real.rpow_add (by norm_num), show -γ * (L : ℝ) + γ * (L : ℝ) = 0 by ring,
      Real.rpow_zero]
  calc
    _ = 1 * (2 : ℝ) ^ (γ * (L : ℝ)) := (one_mul _).symm
    _ ≤ (((dyadicRingProjection A L).card : ℝ) * (2 : ℝ) ^ (-γ * (L : ℝ))) *
        (2 : ℝ) ^ (γ * (L : ℝ)) := mul_le_mul_of_nonneg_right hbound (by positivity)
    _ = _ := by rw [mul_assoc, hinv, mul_one]

theorem finite_fiber_bound_large_subset {X Y : Type*} [DecidableEq X] [DecidableEq Y]
    {A B : Finset X} (π : X → Y) {D M : ℝ} (hBA : B ⊆ A) (hM : 0 ≤ M)
    (hsize : (A.card : ℝ) ≤ D * (B.card : ℝ))
    (hbound : ∀ r : Y, ((A.filter (fun a => π a = r)).card : ℝ) ≤ M * (A.card : ℝ)) :
    ∀ r : Y, ((B.filter (fun a => π a = r)).card : ℝ) ≤ (D * M) * (B.card : ℝ) := by
  intro r
  calc
    _ ≤ ((A.filter (fun a => π a = r)).card : ℝ) := by
      exact_mod_cast Finset.card_le_card (Finset.filter_subset_filter _ hBA)
    _ ≤ M * (A.card : ℝ) := hbound r
    _ ≤ M * (D * (B.card : ℝ)) := mul_le_mul_of_nonneg_left hsize hM
    _ = _ := by ring

theorem ring_unit_dilate_fiber_card {R Q : Type*} [Ring R] [Ring Q]
    [DecidableEq R] [DecidableEq Q] (π : R →+* Q) (u : Rˣ) (A : Finset R) (r : Q) :
    ((ringDilate (u : R) A).filter (fun a => π a = r)).card =
      (A.filter (fun a => π a = π ((u⁻¹ : Rˣ) : R) * r)).card := by
  unfold ringDilate
  have hinj : Function.Injective (fun x : R => (u : R) * x) := (ringUnitMulAddEquiv u).injective
  rw [Finset.filter_image, Finset.card_image_of_injective _ hinj]
  congr 1
  apply Finset.filter_congr
  intro x hx
  rw [map_mul]
  exact (Units.eq_inv_mul_iff_mul_eq (Units.map π.toMonoidHom u)).symm

theorem dyadic_unit_dilate_fiber_bound {J L : ℕ} (hL : L ≤ J)
    (u : (ZMod (2 ^ J))ˣ) {A : Finset (ZMod (2 ^ J))} {M : ℝ}
    (hbound : ∀ r : ZMod (2 ^ L),
      ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤ M * (A.card : ℝ)) :
    ∀ r : ZMod (2 ^ L),
      (((ringDilate (u : ZMod (2 ^ J)) A).filter
        (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤ M * (A.card : ℝ) := by
  let π : ZMod (2 ^ J) →+* ZMod (2 ^ L) := ZMod.castHom (pow_dvd_pow 2 hL) _
  have hπ : ∀ x : ZMod (2 ^ J), π x = (x.val : ZMod (2 ^ L)) := by
    intro x
    exact ZMod.cast_eq_val _
  intro r
  have hh := ring_unit_dilate_fiber_card π u A r
  simp only [hπ] at hh
  rw [hh]
  exact hbound _

theorem unit_relative_image_eq_dilate {R : Type*} [Ring R] [DecidableEq R]
    (u : Rˣ) (T : Finset Rˣ) :
    T.image (fun v => ((u⁻¹ * v : Rˣ) : R)) =
      ringDilate ((u⁻¹ : Rˣ) : R) (T.image (fun v : Rˣ => (v : R))) := by
  simp only [ringDilate, Finset.image_image, Function.comp_def, Units.val_mul]

theorem exists_dyadic_fixed_power_absorption (a p : ℕ) {τ ξ : ℝ}
    (hgap : (p : ℝ) * τ < ξ) :
    ∃ J₀ : ℕ, ∀ J : ℕ, J₀ ≤ J →
      (2 : ℝ) ^ a * ((2 : ℝ) ^ (τ * (J : ℝ))) ^ p ≤ (2 : ℝ) ^ (ξ * (J : ℝ)) := by
  have hg : 0 < ξ - (p : ℝ) * τ := sub_pos.mpr hgap
  obtain ⟨J₀, hJ₀⟩ := exists_nat_ge ((a : ℝ) / (ξ - (p : ℝ) * τ))
  refine ⟨J₀, ?_⟩
  intro J hJ
  have hJr : (J₀ : ℝ) ≤ (J : ℝ) := by exact_mod_cast hJ
  have hh := (div_le_iff₀ hg).mp (hJ₀.trans hJr)
  calc
    _ = (2 : ℝ) ^ ((a : ℝ) + τ * (J : ℝ) * (p : ℝ)) := by
      rw [← Real.rpow_natCast, ← Real.rpow_mul_natCast (by norm_num),
        ← Real.rpow_add (by norm_num)]
    _ ≤ _ := Real.rpow_le_rpow_of_exponent_le (by norm_num) (by nlinarith)


theorem dyadic_unit_extraction_fiber_bounds {J : ℕ} {γ ε H : ℝ}
    (hγ : 0 < γ) {A B S : Finset (ZMod (2 ^ J))} {T : Finset (ZMod (2 ^ J))ˣ}
    (u₀ : (ZMod (2 ^ J))ˣ) (hBA : B ⊆ A)
    (hST : S ⊆ T.image (fun u : (ZMod (2 ^ J))ˣ => ((u₀⁻¹ * u : (ZMod (2 ^ J))ˣ) : ZMod (2 ^ J))))
    (hBlarge : (A.card : ℝ) ≤ H * (B.card : ℝ))
    (hSlarge : (T.card : ℝ) ≤ H * (S.card : ℝ))
    (hHcap : H ≤ (2 : ℝ) ^ ((γ * ε / 2) * (J : ℝ)))
    (hAmass : ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
      ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
        (2 : ℝ) ^ (-γ * (L : ℝ)) * (A.card : ℝ))
    (hTmass : ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
      (((T.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J)))).filter
        (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
          (2 : ℝ) ^ (-γ * (L : ℝ)) * (T.card : ℝ)) :
    (∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
      ((B.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
        (2 : ℝ) ^ (-(γ / 2) * (L : ℝ)) * (B.card : ℝ)) ∧
    (∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
      ((S.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
        (2 : ℝ) ^ (-(γ / 2) * (L : ℝ)) * (S.card : ℝ)) := by
  classical
  have hloss : ∀ L : ℕ, ε * (J : ℝ) < (L : ℝ) →
      H * (2 : ℝ) ^ (-γ * (L : ℝ)) ≤ (2 : ℝ) ^ (-(γ / 2) * (L : ℝ)) := by
    intro L hL
    calc
      _ ≤ (2 : ℝ) ^ ((γ * ε / 2) * (J : ℝ)) * (2 : ℝ) ^ (-γ * (L : ℝ)) :=
        mul_le_mul_of_nonneg_right hHcap (by positivity)
      _ = (2 : ℝ) ^ ((γ * ε / 2) * (J : ℝ) - γ * (L : ℝ)) := by
        rw [← Real.rpow_add (by norm_num)]; congr 1; ring
      _ ≤ _ := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        nlinarith only [mul_lt_mul_of_pos_left hL hγ]
  have hBmass : ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
      ((B.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
        (2 : ℝ) ^ (-(γ / 2) * (L : ℝ)) * (B.card : ℝ) := by
    intro L hL hεL r
    exact (finite_fiber_bound_large_subset (fun a : ZMod (2 ^ J) => (a.val : ZMod (2 ^ L))) hBA
      (show 0 ≤ (2 : ℝ) ^ (-γ * (L : ℝ)) by positivity) hBlarge (hAmass L hL hεL) r).trans
        (mul_le_mul_of_nonneg_right (hloss L hεL) (Nat.cast_nonneg _))
  let U := ringDilate ((u₀⁻¹ : (ZMod (2 ^ J))ˣ) : ZMod (2 ^ J))
    (T.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J))))
  have hTcard : (T.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J)))).card = T.card :=
    Finset.card_image_of_injective _ Units.val_injective
  have hUcard : U.card = T.card := by rw [ring_dilate_unit_card, hTcard]
  have hSU : S ⊆ U := by simpa only [unit_relative_image_eq_dilate] using hST
  have hSmass : ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
      ((S.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
        (2 : ℝ) ^ (-(γ / 2) * (L : ℝ)) * (S.card : ℝ) := by
    intro L hL hεL r
    have huMass : ∀ r : ZMod (2 ^ L),
        ((U.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
          (2 : ℝ) ^ (-γ * (L : ℝ)) * (U.card : ℝ) := by
      intro r
      have hh := dyadic_unit_dilate_fiber_bound hL u₀⁻¹
        (A := T.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J))))
        (M := (2 : ℝ) ^ (-γ * (L : ℝ)))
        (fun r => by simpa only [hTcard] using hTmass L hL hεL r) r
      simpa only [hTcard, hUcard] using hh
    exact (finite_fiber_bound_large_subset (fun a : ZMod (2 ^ J) => (a.val : ZMod (2 ^ L))) hSU
      (show 0 ≤ (2 : ℝ) ^ (-γ * (L : ℝ)) by positivity)
      (by simpa only [hUcard] using hSlarge) huMass r).trans
        (mul_le_mul_of_nonneg_right (hloss L hεL) (Nat.cast_nonneg _))
  exact ⟨hBmass, hSmass⟩

theorem dyadic_energy_parameter_square (K : ℝ) :
    ((2 : ℝ) ^ (82 : ℕ) * K ^ 30) ^ 2 = (2 : ℝ) ^ (164 : ℕ) * K ^ 60 := by
  ring

theorem dyadic_energy_parameter_lower (K : ℝ) (hK : 1 ≤ K) :
    16 * K ≤ (2 : ℝ) ^ (17 : ℕ) * K ^ 4 := by
  have hh : K ≤ K ^ (4 : ℕ) := by
    simpa only [pow_one] using pow_le_pow_right₀ hK (show 1 ≤ (4 : ℕ) by norm_num)
  norm_num only [Nat.reducePow]
  nlinarith only [hh, hK]

theorem exists_dyadic_unit_dilate_energy_saving {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ τ ε : ℝ, 0 < τ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset (ZMod (2 ^ J)), ∀ T : Finset (ZMod (2 ^ J))ˣ,
        A.Nonempty → T.Nonempty → (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
          ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
            (2 : ℝ) ^ (-γ * (L : ℝ)) * (A.card : ℝ)) →
        (∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
          (((T.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J)))).filter
            (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
              (2 : ℝ) ^ (-γ * (L : ℝ)) * (T.card : ℝ)) →
        ∃ u ∈ T, (2 : ℝ) ^ (τ * (J : ℝ)) *
          (Finset.addEnergy A (ringDilate (u : ZMod (2 ^ J)) A) : ℝ) < (A.card : ℝ) ^ 3 := by
  classical
  obtain ⟨η, ε, hη, hε, hε4, J₀, hobstruct⟩ :=
    exists_dyadic_no_projecting_stabilizer (show 0 < γ / 2 by positivity)
      (show 0 < γ / 2 by positivity) hδ hδ1
  let τ := min (η / 120) (γ * ε / 16)
  have hτ : 0 < τ := lt_min (by positivity) (by positivity)
  have hτη : τ ≤ η / 120 := min_le_left _ _
  have hτγε : τ ≤ γ * ε / 16 := min_le_right _ _
  obtain ⟨J₁, hJ₁⟩ := exists_dyadic_fixed_power_absorption 164 60
    (show (60 : ℝ) * τ < η by nlinarith only [hη, hτη])
  obtain ⟨J₂, hJ₂⟩ := exists_dyadic_fixed_power_absorption 17 4
    (show (4 : ℝ) * τ < γ * ε / 2 by nlinarith only [hτγε, mul_pos hγ hε])
  refine ⟨τ, ε, hτ, hε, hε4, max J₀ (max J₁ J₂), ?_⟩
  intro J hJ A T hA hT hsize hAmass hTmass
  have hj₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hj₁ : J₁ ≤ J := (le_max_left _ _).trans ((le_max_right _ _).trans hJ)
  have hj₂ : J₂ ≤ J := (le_max_right _ _).trans ((le_max_right _ _).trans hJ)
  let K := (2 : ℝ) ^ (τ * (J : ℝ))
  have hKp : 0 < K := by positivity
  have hK : 1 ≤ K := Real.one_le_rpow (by norm_num) (mul_nonneg hτ.le (Nat.cast_nonneg J))
  by_contra h
  push Not at h
  obtain ⟨B, hBA, hB, hBsize, u₀, hu₀, S, hST, hS, hSsize, hunit, hstab⟩ :=
    finite_many_unit_dilates_stabilizer hA hT hKp h
  let H := (2 : ℝ) ^ (17 : ℕ) * K ^ 4
  let D := (2 : ℝ) ^ (82 : ℕ) * K ^ 30
  have hD : 1 ≤ D := by
    exact one_le_mul_of_one_le_of_one_le (by norm_num) (one_le_pow₀ hK)
  have hDcap : D ^ 2 ≤ (2 : ℝ) ^ (η * (J : ℝ)) := by
    have heq : D ^ 2 = (2 : ℝ) ^ (164 : ℕ) * K ^ 60 := dyadic_energy_parameter_square K
    rw [heq]
    exact hJ₁ J hj₁
  have hHcap : H ≤ (2 : ℝ) ^ ((γ * ε / 2) * (J : ℝ)) := hJ₂ J hj₂
  have h16 : 16 * K ≤ H := dyadic_energy_parameter_lower K hK
  have hBlarge : (A.card : ℝ) ≤ H * (B.card : ℝ) := by
    have hh := (div_le_iff₀ (show 0 < 16 * K by positivity)).mp hBsize
    calc
      _ ≤ (16 * K) * (B.card : ℝ) := by simpa only [mul_comm] using hh
      _ ≤ _ := mul_le_mul_of_nonneg_right h16 (Nat.cast_nonneg _)
  have hSlarge : (T.card : ℝ) ≤ H * (S.card : ℝ) := by
    have hh := (div_le_iff₀ (show 0 < 131072 * K ^ 4 by positivity)).mp hSsize
    simpa only [H, show (2 : ℝ) ^ (17 : ℕ) = 131072 by norm_num, mul_comm] using hh
  obtain ⟨hBmass, hSmass⟩ := dyadic_unit_extraction_fiber_bounds hγ u₀ hBA hST
    hBlarge hSlarge hHcap hAmass hTmass
  have hBbound : (B.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) :=
    (show (B.card : ℝ) ≤ A.card by exact_mod_cast Finset.card_le_card hBA).trans hsize
  have hSproj : ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) →
      (2 : ℝ) ^ ((γ / 2) * (L : ℝ)) ≤ ((dyadicRingProjection S L).card : ℝ) :=
    fun L hL hεL => dyadic_ring_projection_growth_of_fiber_bound hS (hSmass L hL hεL)
  obtain ⟨x, hx⟩ := hS
  obtain ⟨u, hu⟩ := hunit x hx
  have hdouble : ((B + B).card : ℝ) ≤ (2 : ℝ) ^ (η * (J : ℝ)) * (B.card : ℝ) := by
    have hh := ring_sum_stabilizer_unit_doubling hB (show 0 ≤ D by positivity) u
      (by simpa only [hu] using hstab hx)
    exact hh.trans (mul_le_mul_of_nonneg_right hDcap (Nat.cast_nonneg _))
  have hSstab : S ⊆ ringSumStabilizer B ((2 : ℝ) ^ (η * (J : ℝ))) := by
    have hDD : D ≤ D ^ (2 : ℕ) := by
      simpa only [pow_one] using pow_le_pow_right₀ hD (show 1 ≤ (2 : ℕ) by norm_num)
    exact hstab.trans (ring_sum_stabilizer_mono B (hDD.trans hDcap))
  exact hobstruct J hj₀ B S hB ⟨x, hx⟩ hBbound hBmass hSproj hdouble hSstab


theorem finite_add_energy_upper {G : Type*} [AddCommGroup G] [Fintype G] [DecidableEq G]
    (A B : Finset G) : (Finset.addEnergy A B : ℝ) ≤ (A.card : ℝ) * (B.card : ℝ) ^ 2 := by
  rw [← finite_difference_energy_eq_addEnergy, ← finite_difference_energy_sum_real]
  calc
    _ ≤ ∑ x : G, (B.card : ℝ) * (finiteDifferenceCount A B x : ℝ) := by
      apply Finset.sum_le_sum
      intro x hx
      have hh : (finiteDifferenceCount A B x : ℝ) ≤ B.card := by
        exact_mod_cast finite_difference_count_le_right A B x
      simpa only [pow_two] using mul_le_mul_of_nonneg_right hh
        (Nat.cast_nonneg (finiteDifferenceCount A B x) : (0 : ℝ) ≤ finiteDifferenceCount A B x)
    _ = _ := by rw [← Finset.mul_sum, finite_difference_count_sum_real]; ring

theorem ring_unit_dilate_energy_upper {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    (A : Finset R) (u : Rˣ) :
    (Finset.addEnergy A (ringDilate (u : R) A) : ℝ) ≤ (A.card : ℝ) ^ 3 := by
  have hh := finite_add_energy_upper A (ringDilate (u : R) A)
  rw [ring_dilate_unit_card] at hh
  calc _ ≤ (A.card : ℝ) * (A.card : ℝ) ^ 2 := hh
       _ = _ := by ring

/-- A small value in every sufficiently large subset bounds the full average. -/
theorem finite_sum_bound_of_hereditary_small_value {X : Type*} [DecidableEq X]
    {T : Finset X} {f : X → ℝ} {ρ a M : ℝ}
    (hT : T.Nonempty) (hρ : 0 < ρ) (ha : 0 ≤ a) (hM : 0 ≤ M)
    (hupper : ∀ x ∈ T, f x ≤ M)
    (hsmall : ∀ U : Finset X, U ⊆ T → U.Nonempty →
      ρ * (T.card : ℝ) ≤ (U.card : ℝ) → ∃ x ∈ U, f x < a * M) :
    ∑ x ∈ T, f x ≤ (ρ + a) * (T.card : ℝ) * M := by
  classical
  let U := T.filter (fun x => a * M ≤ f x)
  have hU : (U.card : ℝ) < ρ * (T.card : ℝ) := by
    by_contra h
    have hh := le_of_not_gt h
    have hTp : (0 : ℝ) < T.card := by exact_mod_cast hT.card_pos
    have hUp : (0 : ℝ) < U.card := (mul_pos hρ hTp).trans_le hh
    obtain ⟨x, hx, hfx⟩ := hsmall U (Finset.filter_subset _ _)
      (Finset.card_pos.mp (by exact_mod_cast hUp)) hh
    exact (not_lt_of_ge (Finset.mem_filter.mp hx).2) hfx
  have hsplit : ∑ x ∈ T, f x =
      (∑ x ∈ T.filter (fun x => a * M ≤ f x), f x) +
      ∑ x ∈ T.filter (fun x => ¬ a * M ≤ f x), f x := by
    rw [Finset.sum_filter, Finset.sum_filter, ← Finset.sum_add_distrib]
    apply Finset.sum_congr rfl
    intro x hx
    split_ifs <;> simp_all
  rw [hsplit]
  calc
    _ ≤ (∑ _x ∈ U, M) + ∑ _x ∈ T.filter (fun x => ¬ a * M ≤ f x), a * M := by
      apply add_le_add
      · exact Finset.sum_le_sum (fun x hx => hupper x (Finset.mem_filter.mp hx).1)
      · exact Finset.sum_le_sum (fun x hx => (lt_of_not_ge (Finset.mem_filter.mp hx).2).le)
    _ = (U.card : ℝ) * M + ((T.filter (fun x => ¬ a * M ≤ f x)).card : ℝ) * (a * M) := by simp
    _ ≤ (ρ * (T.card : ℝ)) * M + (T.card : ℝ) * (a * M) := by
      apply add_le_add (mul_le_mul_of_nonneg_right hU.le hM)
      apply mul_le_mul_of_nonneg_right _ (mul_nonneg ha hM)
      exact_mod_cast Finset.card_filter_le T (fun x => ¬ a * M ≤ f x)
    _ = _ := by ring


/-- Uniform power-saving decay for the average mixed additive energy over a
nonconcentrated family of unit dilates. -/
theorem exists_dyadic_average_unit_energy_decay {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ τ ε : ℝ, 0 < τ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A : Finset (ZMod (2 ^ J)), ∀ T : Finset (ZMod (2 ^ J))ˣ,
        A.Nonempty → T.Nonempty → (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
          ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
            (2 : ℝ) ^ (-γ * (L : ℝ)) * (A.card : ℝ)) →
        (∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
          (((T.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J)))).filter
            (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
              (2 : ℝ) ^ (-γ * (L : ℝ)) * (T.card : ℝ)) →
        (∑ u ∈ T, (Finset.addEnergy A (ringDilate (u : ZMod (2 ^ J)) A) : ℝ)) ≤
          (2 : ℝ) ^ (-τ * (J : ℝ)) * (T.card : ℝ) * (A.card : ℝ) ^ 3 := by
  classical
  obtain ⟨κ, ε, hκ, hε, hε4, J₀, hpoint⟩ :=
    exists_dyadic_unit_dilate_energy_saving (show 0 < γ / 2 by positivity) hδ hδ1
  let ρ := min κ (γ * ε / 4)
  have hρ : 0 < ρ := lt_min hκ (by positivity)
  have hρκ : ρ ≤ κ := min_le_left _ _
  have hργε : ρ ≤ γ * ε / 4 := min_le_right _ _
  obtain ⟨J₁, hJ₁⟩ := exists_dyadic_fixed_power_absorption 1 0 (τ := 0)
    (ξ := ρ / 2) (by simpa using (show 0 < ρ / 2 by positivity))
  refine ⟨ρ / 2, ε, by positivity, hε, hε4, max J₀ J₁, ?_⟩
  intro J hJ A T hA hT hsize hAmass hTmass
  have hj₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hj₁ : J₁ ≤ J := (le_max_right _ _).trans hJ
  have hJ0 : (0 : ℝ) ≤ J := Nat.cast_nonneg _
  have hTcard : (T.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J)))).card = T.card :=
    Finset.card_image_of_injective _ Units.val_injective
  have hAmass' : ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
      ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
        (2 : ℝ) ^ (-(γ / 2) * (L : ℝ)) * (A.card : ℝ) := by
    intro L hL hεL r
    apply (hAmass L hL hεL r).trans
    apply mul_le_mul_of_nonneg_right _ (Nat.cast_nonneg _)
    apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
    nlinarith only [mul_nonneg hγ.le (Nat.cast_nonneg L : (0 : ℝ) ≤ L)]
  have hhereditary : ∀ U : Finset (ZMod (2 ^ J))ˣ, U ⊆ T → U.Nonempty →
      (2 : ℝ) ^ (-ρ * (J : ℝ)) * (T.card : ℝ) ≤ (U.card : ℝ) →
      ∃ u ∈ U, (Finset.addEnergy A (ringDilate (u : ZMod (2 ^ J)) A) : ℝ) <
        (2 : ℝ) ^ (-κ * (J : ℝ)) * (A.card : ℝ) ^ 3 := by
    intro U hUT hU hlarge
    have hUcard : (U.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J)))).card = U.card :=
      Finset.card_image_of_injective _ Units.val_injective
    have hinv : (2 : ℝ) ^ (ρ * (J : ℝ)) * (2 : ℝ) ^ (-ρ * (J : ℝ)) = 1 := by
      rw [← Real.rpow_add (by norm_num), show ρ * (J : ℝ) + -ρ * (J : ℝ) = 0 by ring,
        Real.rpow_zero]
    have hratio : (T.card : ℝ) ≤ (2 : ℝ) ^ (ρ * (J : ℝ)) * (U.card : ℝ) := by
      calc
        _ = (2 : ℝ) ^ (ρ * (J : ℝ)) * ((2 : ℝ) ^ (-ρ * (J : ℝ)) * (T.card : ℝ)) := by
          rw [← mul_assoc, hinv, one_mul]
        _ ≤ _ := mul_le_mul_of_nonneg_left hlarge (by positivity)
    have hUmass : ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
        (((U.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J)))).filter
          (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
            (2 : ℝ) ^ (-(γ / 2) * (L : ℝ)) * (U.card : ℝ) := by
      intro L hL hεL r
      have hh := finite_fiber_bound_large_subset (fun a : ZMod (2 ^ J) => (a.val : ZMod (2 ^ L)))
        (Finset.image_subset_image (f := fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J))) hUT)
        (show 0 ≤ (2 : ℝ) ^ (-γ * (L : ℝ)) by positivity)
        (D := (2 : ℝ) ^ (ρ * (J : ℝ)))
        (by simpa only [hTcard, hUcard] using hratio)
        (fun r => by simpa only [hTcard] using hTmass L hL hεL r) r
      simp only [hUcard] at hh
      apply hh.trans
      apply mul_le_mul_of_nonneg_right _ (Nat.cast_nonneg _)
      rw [← Real.rpow_add (by norm_num)]
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      have hρJ := mul_le_mul_of_nonneg_right hργε hJ0
      have hγL := mul_lt_mul_of_pos_left hεL hγ
      nlinarith only [hρJ, hγL, mul_nonneg hγ.le (Nat.cast_nonneg L : (0 : ℝ) ≤ L)]
    obtain ⟨u, hu, hE⟩ := hpoint J hj₀ A U hA hU hsize hAmass' hUmass
    refine ⟨u, hu, ?_⟩
    apply (mul_lt_mul_iff_of_pos_left
      (Real.rpow_pos_of_pos (by norm_num : (0 : ℝ) < 2) (κ * (J : ℝ)))).mp
    calc
      _ < (A.card : ℝ) ^ 3 := hE
      _ = _ := by
        rw [← mul_assoc, ← Real.rpow_add (by norm_num),
          show κ * (J : ℝ) + -κ * (J : ℝ) = 0 by ring, Real.rpow_zero, one_mul]
  have havg := finite_sum_bound_of_hereditary_small_value hT
    (show 0 < (2 : ℝ) ^ (-ρ * (J : ℝ)) by positivity)
    (show 0 ≤ (2 : ℝ) ^ (-κ * (J : ℝ)) by positivity)
    (show 0 ≤ (A.card : ℝ) ^ 3 by positivity)
    (fun u _ => ring_unit_dilate_energy_upper A u) hhereditary
  have htwo : (2 : ℝ) ≤ (2 : ℝ) ^ ((ρ / 2) * (J : ℝ)) := by
    simpa using hJ₁ J hj₁
  have hcoef : (2 : ℝ) ^ (-ρ * (J : ℝ)) + (2 : ℝ) ^ (-κ * (J : ℝ)) ≤
      (2 : ℝ) ^ (-(ρ / 2) * (J : ℝ)) := by
    have hpow : (2 : ℝ) ^ (-κ * (J : ℝ)) ≤ (2 : ℝ) ^ (-ρ * (J : ℝ)) := by
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      have hh := mul_le_mul_of_nonneg_right hρκ hJ0
      linarith only [hh]
    calc
      _ ≤ 2 * (2 : ℝ) ^ (-ρ * (J : ℝ)) := by linarith only [hpow]
      _ ≤ (2 : ℝ) ^ ((ρ / 2) * (J : ℝ)) * (2 : ℝ) ^ (-ρ * (J : ℝ)) :=
        mul_le_mul_of_nonneg_right htwo (by positivity)
      _ = _ := by rw [← Real.rpow_add (by norm_num)]; congr 1; ring
  exact havg.trans (mul_le_mul_of_nonneg_right
    (mul_le_mul_of_nonneg_right hcoef (Nat.cast_nonneg _)) (by positivity))


theorem finite_fiber_bound_union {X Y : Type*} [DecidableEq X] [DecidableEq Y]
    (π : X → Y) {A B : Finset X} {M : ℝ} (hM : 0 ≤ M)
    (hA : ∀ r : Y, ((A.filter (fun x => π x = r)).card : ℝ) ≤ M * (A.card : ℝ))
    (hB : ∀ r : Y, ((B.filter (fun x => π x = r)).card : ℝ) ≤ M * (B.card : ℝ)) :
    ∀ r : Y, (((A ∪ B).filter (fun x => π x = r)).card : ℝ) ≤
      (2 * M) * ((A ∪ B).card : ℝ) := by
  intro r
  have hAU : (A.card : ℝ) ≤ (A ∪ B).card := by
    exact_mod_cast Finset.card_le_card (Finset.subset_union_left : A ⊆ A ∪ B)
  have hBU : (B.card : ℝ) ≤ (A ∪ B).card := by
    exact_mod_cast Finset.card_le_card (Finset.subset_union_right : B ⊆ A ∪ B)
  calc
    _ ≤ ((A.filter (fun x => π x = r)).card : ℝ) + ((B.filter (fun x => π x = r)).card : ℝ) := by
      rw [Finset.filter_union]
      exact_mod_cast Finset.card_union_le _ _
    _ ≤ M * (A.card : ℝ) + M * (B.card : ℝ) := add_le_add (hA r) (hB r)
    _ ≤ M * ((A ∪ B).card : ℝ) + M * ((A ∪ B).card : ℝ) := by gcongr
    _ = _ := by ring

/-- Interpolate the union bound and the elementary mixed-energy bound. -/
theorem ordered_mixed_energy_square_bound {e a b t v r w : ℝ}
    (he : 0 ≤ e) (ha : 0 ≤ a) (hb : 0 ≤ b) (ht : 0 ≤ t) (hv : 0 ≤ v)
    (hr : 0 ≤ r) (hw : 0 ≤ w) (hab : a ≤ b)
    (hbalance : 64 * v ^ 2 * r ^ 3 ≤ w) (hinverse : 1 ≤ w * r)
    (hunion : e ≤ v * t * (a + b) ^ 3) (htrivial : e ≤ t * a ^ 2 * b) :
    e ^ 2 ≤ w * t ^ 2 * a ^ 3 * b ^ 3 := by
  by_cases hratio : b ≤ r * a
  · have he' : e ≤ v * t * (2 * b) ^ 3 := by
      apply hunion.trans
      gcongr
      linarith only [hab]
    have hb' : b ^ 3 ≤ r ^ 3 * a ^ 3 := by
      simpa only [mul_pow] using pow_le_pow_left₀ hb hratio 3
    calc
      _ ≤ (v * t * (2 * b) ^ 3) ^ 2 := pow_le_pow_left₀ he he' 2
      _ = (64 * v ^ 2 * t ^ 2 * b ^ 3) * b ^ 3 := by ring
      _ ≤ (64 * v ^ 2 * t ^ 2 * b ^ 3) * (r ^ 3 * a ^ 3) :=
        mul_le_mul_of_nonneg_left hb' (by positivity)
      _ = (64 * v ^ 2 * r ^ 3) * (t ^ 2 * a ^ 3 * b ^ 3) := by ring
      _ ≤ w * (t ^ 2 * a ^ 3 * b ^ 3) := mul_le_mul_of_nonneg_right hbalance (by positivity)
      _ = _ := by ring
  · have hratio' : r * a ≤ b := (lt_of_not_ge hratio).le
    have haw : a ≤ w * b := by
      calc
        _ = 1 * a := (one_mul _).symm
        _ ≤ (w * r) * a := mul_le_mul_of_nonneg_right hinverse ha
        _ = w * (r * a) := by ring
        _ ≤ _ := mul_le_mul_of_nonneg_left hratio' hw
    calc
      _ ≤ (t * a ^ 2 * b) ^ 2 := pow_le_pow_left₀ he htrivial 2
      _ = (t ^ 2 * a ^ 3 * b ^ 2) * a := by ring
      _ ≤ (t ^ 2 * a ^ 3 * b ^ 2) * (w * b) := mul_le_mul_of_nonneg_left haw (by positivity)
      _ = _ := by ring

theorem mixed_energy_square_bound {e a b t v r w : ℝ}
    (he : 0 ≤ e) (ha : 0 ≤ a) (hb : 0 ≤ b) (ht : 0 ≤ t) (hv : 0 ≤ v)
    (hr : 0 ≤ r) (hw : 0 ≤ w)
    (hbalance : 64 * v ^ 2 * r ^ 3 ≤ w) (hinverse : 1 ≤ w * r)
    (hunion : e ≤ v * t * (a + b) ^ 3)
    (hleft : e ≤ t * a ^ 2 * b) (hright : e ≤ t * a * b ^ 2) :
    e ^ 2 ≤ w * t ^ 2 * a ^ 3 * b ^ 3 := by
  rcases le_total a b with hab | hba
  · exact ordered_mixed_energy_square_bound he ha hb ht hv hr hw hab hbalance hinverse hunion hleft
  · have hh := ordered_mixed_energy_square_bound he hb ha ht hv hr hw hba hbalance hinverse
      (by simpa only [add_comm] using hunion)
      (by simpa only [mul_assoc, mul_comm, mul_left_comm] using hright)
    calc _ ≤ w * t ^ 2 * b ^ 3 * a ^ 3 := hh
         _ = _ := by ring

theorem ring_unit_mixed_energy_upper_left {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    (A B : Finset R) (u : Rˣ) :
    (Finset.addEnergy A (ringDilate (u : R) B) : ℝ) ≤ (A.card : ℝ) ^ 2 * (B.card : ℝ) := by
  rw [Finset.addEnergy_comm]
  have hh := finite_add_energy_upper (ringDilate (u : R) B) A
  rw [ring_dilate_unit_card] at hh
  simpa only [mul_comm] using hh

theorem ring_unit_mixed_energy_upper_right {R : Type*} [Ring R] [Fintype R] [DecidableEq R]
    (A B : Finset R) (u : Rˣ) :
    (Finset.addEnergy A (ringDilate (u : R) B) : ℝ) ≤ (A.card : ℝ) * (B.card : ℝ) ^ 2 := by
  have hh := finite_add_energy_upper A (ringDilate (u : R) B)
  simpa only [ring_dilate_unit_card] using hh

def DyadicRingSetNonconcentration {J : ℕ} (γ ε : ℝ) (A : Finset (ZMod (2 ^ J))) : Prop :=
  ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
    ((A.filter (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
      (2 : ℝ) ^ (-γ * (L : ℝ)) * (A.card : ℝ)

def DyadicUnitSetNonconcentration {J : ℕ} (γ ε : ℝ) (T : Finset (ZMod (2 ^ J))ˣ) : Prop :=
  ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
    (((T.image (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J)))).filter
      (fun a => (a.val : ZMod (2 ^ L)) = r)).card : ℝ) ≤
        (2 : ℝ) ^ (-γ * (L : ℝ)) * (T.card : ℝ)

/-- Average mixed energy of two distinct nonconcentrated sets, with a
cardinality-symmetric normalization suitable for weighted level sets. -/
theorem exists_dyadic_average_mixed_energy_decay {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ τ ε : ℝ, 0 < τ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ A B : Finset (ZMod (2 ^ J)), ∀ T : Finset (ZMod (2 ^ J))ˣ,
        A.Nonempty → B.Nonempty → T.Nonempty →
        (A.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        (B.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) →
        DyadicRingSetNonconcentration γ ε A → DyadicRingSetNonconcentration γ ε B →
        DyadicUnitSetNonconcentration γ ε T →
        (∑ u ∈ T, (Finset.addEnergy A (ringDilate (u : ZMod (2 ^ J)) B) : ℝ)) ^ 2 ≤
          (2 : ℝ) ^ (-τ * (J : ℝ)) * (T.card : ℝ) ^ 2 * (A.card : ℝ) ^ 3 * (B.card : ℝ) ^ 3 := by
  classical
  obtain ⟨κ, ε, hκ, hε, hε4, J₀, havg⟩ := exists_dyadic_average_unit_energy_decay
    (show 0 < γ / 2 by positivity) (show 0 < δ / 2 by positivity) (by linarith only [hδ1])
  obtain ⟨J₁, hJ₁⟩ := exists_dyadic_fixed_power_absorption 1 0 (τ := 0) (ξ := δ / 2)
    (by simpa using (show 0 < δ / 2 by positivity))
  obtain ⟨J₂, hJ₂⟩ := exists_dyadic_fixed_power_absorption 1 0 (τ := 0) (ξ := γ * ε / 2)
    (by simpa using (show 0 < γ * ε / 2 by positivity))
  obtain ⟨J₃, hJ₃⟩ := exists_dyadic_fixed_power_absorption 6 0 (τ := 0) (ξ := κ)
    (by simpa using hκ)
  refine ⟨κ / 4, ε, by positivity, hε, hε4, max J₀ (max J₁ (max J₂ J₃)), ?_⟩
  intro J hJ A B T hA hB hT hAsize hBsize hAmass hBmass hTmass
  have hj₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hj₁ : J₁ ≤ J := (le_max_left _ _).trans ((le_max_right _ _).trans hJ)
  have hj₂ : J₂ ≤ J := (le_max_left _ _).trans ((le_max_right _ _).trans ((le_max_right _ _).trans hJ))
  have hj₃ : J₃ ≤ J := (le_max_right _ _).trans ((le_max_right _ _).trans ((le_max_right _ _).trans hJ))
  have h2δ : (2 : ℝ) ≤ (2 : ℝ) ^ ((δ / 2) * (J : ℝ)) := by simpa using hJ₁ J hj₁
  have h2γ : (2 : ℝ) ≤ (2 : ℝ) ^ ((γ * ε / 2) * (J : ℝ)) := by simpa using hJ₂ J hj₂
  have h64 : (64 : ℝ) ≤ (2 : ℝ) ^ (κ * (J : ℝ)) := by
    have hh := hJ₃ J hj₃
    norm_num at hh
    exact hh
  let U := A ∪ B
  have hUcard : (U.card : ℝ) ≤ (A.card : ℝ) + (B.card : ℝ) := by
    exact_mod_cast Finset.card_union_le A B
  have hUsize : (U.card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ / 2) * (J : ℝ)) := by
    calc
      _ ≤ (A.card : ℝ) + (B.card : ℝ) := hUcard
      _ ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) + (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) := add_le_add hAsize hBsize
      _ = 2 * (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) := by ring
      _ ≤ (2 : ℝ) ^ ((δ / 2) * (J : ℝ)) * (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) := by gcongr
      _ = _ := by rw [← Real.rpow_add (by norm_num)]; congr 1; ring
  have hUmass : DyadicRingSetNonconcentration (γ / 2) ε U := by
    intro L hL hεL r
    have hh := finite_fiber_bound_union (fun a : ZMod (2 ^ J) => (a.val : ZMod (2 ^ L)))
      (show 0 ≤ (2 : ℝ) ^ (-γ * (L : ℝ)) by positivity) (hAmass L hL hεL) (hBmass L hL hεL) r
    apply hh.trans
    apply mul_le_mul_of_nonneg_right _ (Nat.cast_nonneg _)
    calc
      _ ≤ (2 : ℝ) ^ ((γ * ε / 2) * (J : ℝ)) * (2 : ℝ) ^ (-γ * (L : ℝ)) := by gcongr
      _ = (2 : ℝ) ^ ((γ * ε / 2) * (J : ℝ) - γ * (L : ℝ)) := by
        rw [← Real.rpow_add (by norm_num)]; congr 1; ring
      _ ≤ _ := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        nlinarith only [mul_lt_mul_of_pos_left hεL hγ]
  have hTmass' : DyadicUnitSetNonconcentration (γ / 2) ε T := by
    intro L hL hεL r
    apply (hTmass L hL hεL r).trans
    apply mul_le_mul_of_nonneg_right _ (Nat.cast_nonneg _)
    apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
    nlinarith only [mul_nonneg hγ.le (Nat.cast_nonneg L : (0 : ℝ) ≤ L)]
  have hUE := havg J hj₀ U T (hA.mono Finset.subset_union_left) hT hUsize hUmass hTmass'
  have hunion : (∑ u ∈ T, (Finset.addEnergy A (ringDilate (u : ZMod (2 ^ J)) B) : ℝ)) ≤
      (2 : ℝ) ^ (-κ * (J : ℝ)) * (T.card : ℝ) * ((A.card : ℝ) + (B.card : ℝ)) ^ 3 := by
    calc
      _ ≤ ∑ u ∈ T, (Finset.addEnergy U (ringDilate (u : ZMod (2 ^ J)) U) : ℝ) := by
        apply Finset.sum_le_sum
        intro u hu
        exact_mod_cast Finset.addEnergy_mono Finset.subset_union_left
          (ring_dilate_subset (u : ZMod (2 ^ J)) (Finset.subset_union_right : B ⊆ A ∪ B))
      _ ≤ (2 : ℝ) ^ (-κ * (J : ℝ)) * (T.card : ℝ) * (U.card : ℝ) ^ 3 := hUE
      _ ≤ _ := by gcongr
  have hleft : (∑ u ∈ T, (Finset.addEnergy A (ringDilate (u : ZMod (2 ^ J)) B) : ℝ)) ≤
      (T.card : ℝ) * (A.card : ℝ) ^ 2 * (B.card : ℝ) := by
    calc
      _ ≤ ∑ _u ∈ T, (A.card : ℝ) ^ 2 * (B.card : ℝ) :=
        Finset.sum_le_sum (fun u _ => ring_unit_mixed_energy_upper_left A B u)
      _ = _ := by simp; ring
  have hright : (∑ u ∈ T, (Finset.addEnergy A (ringDilate (u : ZMod (2 ^ J)) B) : ℝ)) ≤
      (T.card : ℝ) * (A.card : ℝ) * (B.card : ℝ) ^ 2 := by
    calc
      _ ≤ ∑ _u ∈ T, (A.card : ℝ) * (B.card : ℝ) ^ 2 :=
        Finset.sum_le_sum (fun u _ => ring_unit_mixed_energy_upper_right A B u)
      _ = _ := by simp; ring
  have hbalance : 64 * ((2 : ℝ) ^ (-κ * (J : ℝ))) ^ 2 *
      ((2 : ℝ) ^ ((κ / 4) * (J : ℝ))) ^ 3 ≤ (2 : ℝ) ^ (-(κ / 4) * (J : ℝ)) := by
    calc
      _ ≤ (2 : ℝ) ^ (κ * (J : ℝ)) * ((2 : ℝ) ^ (-κ * (J : ℝ))) ^ 2 *
          ((2 : ℝ) ^ ((κ / 4) * (J : ℝ))) ^ 3 := by gcongr
      _ = _ := by
        rw [← Real.rpow_mul_natCast (by norm_num), ← Real.rpow_mul_natCast (by norm_num),
          ← Real.rpow_add (by norm_num), ← Real.rpow_add (by norm_num)]
        congr 1
        norm_num
        ring
  have hinverse : 1 ≤ (2 : ℝ) ^ (-(κ / 4) * (J : ℝ)) * (2 : ℝ) ^ ((κ / 4) * (J : ℝ)) := by
    rw [← Real.rpow_add (by norm_num),
      show -(κ / 4) * (J : ℝ) + (κ / 4) * (J : ℝ) = 0 by ring, Real.rpow_zero]
  exact mixed_energy_square_bound (Finset.sum_nonneg (fun u _ => Nat.cast_nonneg _))
    (Nat.cast_nonneg _) (Nat.cast_nonneg _) (Nat.cast_nonneg _)
    (by positivity) (by positivity) (by positivity) hbalance hinverse hunion hleft hright


theorem norm_sum_sq_le_card_mul_sum_sq {X : Type*} (I : Finset X) (f : X → ℂ) :
    ‖∑ i ∈ I, f i‖ ^ 2 ≤ (I.card : ℝ) * ∑ i ∈ I, ‖f i‖ ^ 2 := by
  have hc := Finset.sum_mul_sq_le_sq_mul_sq I (fun _ => (1 : ℝ)) (fun i => ‖f i‖)
  simp only [one_mul, one_pow, Finset.sum_const, nsmul_eq_mul, mul_one] at hc
  exact (pow_le_pow_left₀ (norm_nonneg _) (norm_sum_le I f) 2).trans hc

noncomputable def cyclicUnitDilate {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (u : (ZMod q)ˣ) (x : ZMod q) : ℂ := f ((u⁻¹ : (ZMod q)ˣ) * x)

noncomputable def cyclicSetCombination {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (w : X → ℝ) (A : X → Finset (ZMod q)) (x : ZMod q) : ℂ :=
  ∑ i ∈ I, (w i : ℂ) * cyclicSetIndicator (A i) x

theorem mem_ring_unit_dilate {R : Type*} [Ring R] [DecidableEq R]
    (u : Rˣ) (A : Finset R) (x : R) :
    x ∈ ringDilate (u : R) A ↔ ((u⁻¹ : Rˣ) : R) * x ∈ A := by
  constructor
  · intro hx
    obtain ⟨a, ha, hax⟩ := Finset.mem_image.mp hx
    rw [← hax, ← mul_assoc, Units.inv_mul, one_mul]
    exact ha
  · intro hx
    apply Finset.mem_image.mpr
    exact ⟨((u⁻¹ : Rˣ) : R) * x, hx, by rw [← mul_assoc, Units.mul_inv, one_mul]⟩

theorem cyclic_unit_dilate_indicator {q : ℕ} [NeZero q]
    (A : Finset (ZMod q)) (u : (ZMod q)ˣ) :
    cyclicUnitDilate (cyclicSetIndicator A) u = cyclicSetIndicator (ringDilate (u : ZMod q) A) := by
  classical
  funext x
  simp only [cyclicUnitDilate, cyclicSetIndicator, mem_ring_unit_dilate]

theorem cyclic_unit_dilate_set_combination {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (w : X → ℝ) (A : X → Finset (ZMod q)) (u : (ZMod q)ˣ) :
    cyclicUnitDilate (cyclicSetCombination I w A) u =
      cyclicSetCombination I w (fun i => ringDilate (u : ZMod q) (A i)) := by
  funext x
  unfold cyclicSetCombination cyclicUnitDilate
  apply Finset.sum_congr rfl
  intro i hi
  congr 1
  exact congrFun (cyclic_unit_dilate_indicator (A i) u) x

theorem cyclic_convolution_scaled {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) (a b : ℂ) (x : ZMod q) :
    cyclicConvolution (fun y => a * f y) (fun y => b * g y) x = a * b * cyclicConvolution f g x := by
  unfold cyclicConvolution
  rw [Finset.mul_sum]
  apply Finset.sum_congr rfl
  intro y hy
  ring

theorem cyclic_convolution_sum_left {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (f : X → ZMod q → ℂ) (g : ZMod q → ℂ) (x : ZMod q) :
    cyclicConvolution (fun y => ∑ i ∈ I, f i y) g x = ∑ i ∈ I, cyclicConvolution (f i) g x := by
  simp only [cyclicConvolution, Finset.sum_mul]
  rw [Finset.sum_comm]

theorem cyclic_convolution_sum_right {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (f : ZMod q → ℂ) (g : X → ZMod q → ℂ) (x : ZMod q) :
    cyclicConvolution f (fun y => ∑ i ∈ I, g i y) x = ∑ i ∈ I, cyclicConvolution f (g i) x := by
  simp only [cyclicConvolution, Finset.mul_sum]
  rw [Finset.sum_comm]

theorem cyclic_convolution_set_combinations {X Y : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (K : Finset Y) (w : X → ℝ) (v : Y → ℝ)
    (A : X → Finset (ZMod q)) (B : Y → Finset (ZMod q)) (x : ZMod q) :
    cyclicConvolution (cyclicSetCombination I w A) (cyclicSetCombination K v B) x =
      ∑ i ∈ I, ∑ j ∈ K, (w i : ℂ) * (v j : ℂ) *
        cyclicConvolution (cyclicSetIndicator (A i)) (cyclicSetIndicator (B j)) x := by
  unfold cyclicSetCombination
  rw [cyclic_convolution_sum_left]
  apply Finset.sum_congr rfl
  intro i hi
  rw [cyclic_convolution_sum_right]
  apply Finset.sum_congr rfl
  intro j hj
  exact cyclic_convolution_scaled _ _ _ _ _

theorem finite_weighted_card_three_halves_bound {X : Type*}
    (I : Finset X) (w a : X → ℝ) (hw : ∀ i ∈ I, 0 ≤ w i) (ha : ∀ i ∈ I, 0 ≤ a i) :
    (∑ i ∈ I, w i ^ 2 * (a i * Real.sqrt (a i))) ^ 2 ≤
      (∑ i ∈ I, w i ^ 2 * a i) * (∑ i ∈ I, w i * a i) ^ 2 := by
  have hc := Finset.sum_mul_sq_le_sq_mul_sq I (fun i => w i * Real.sqrt (a i)) (fun i => w i * a i)
  have hfirst : (∑ i ∈ I, (w i * Real.sqrt (a i)) ^ 2) = ∑ i ∈ I, w i ^ 2 * a i := by
    apply Finset.sum_congr rfl
    intro i hi
    rw [mul_pow, Real.sq_sqrt (ha i hi)]
  have hprod : (∑ i ∈ I, (w i * Real.sqrt (a i)) * (w i * a i)) =
      ∑ i ∈ I, w i ^ 2 * (a i * Real.sqrt (a i)) := by
    apply Finset.sum_congr rfl
    intro i hi
    ring
  rw [hfirst, hprod] at hc
  apply hc.trans
  apply mul_le_mul_of_nonneg_left _ (Finset.sum_nonneg (fun i hi => mul_nonneg (sq_nonneg _) (ha i hi)))
  exact Finset.sum_sq_le_sq_sum_of_nonneg (fun i hi => mul_nonneg (hw i hi) (ha i hi))

theorem cyclic_set_combination_unit_energy {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (w : X → ℝ) (A : X → Finset (ZMod q)) (u : (ZMod q)ˣ)
    (hw : ∀ i ∈ I, 0 ≤ w i) :
    (∑ x : ZMod q, ‖cyclicConvolution (cyclicSetCombination I w A)
      (cyclicUnitDilate (cyclicSetCombination I w A) u) x‖ ^ 2) ≤
      (I.card : ℝ) ^ 2 * ∑ i ∈ I, ∑ j ∈ I, w i ^ 2 * w j ^ 2 *
        (Finset.addEnergy (A i) (ringDilate (u : ZMod q) (A j)) : ℝ) := by
  have hpoint : ∀ x : ZMod q,
      ‖cyclicConvolution (cyclicSetCombination I w A)
        (cyclicUnitDilate (cyclicSetCombination I w A) u) x‖ ^ 2 ≤
        (I.card : ℝ) ^ 2 * ∑ i ∈ I, ∑ j ∈ I, w i ^ 2 * w j ^ 2 *
          ‖cyclicConvolution (cyclicSetIndicator (A i))
            (cyclicSetIndicator (ringDilate (u : ZMod q) (A j))) x‖ ^ 2 := by
    intro x
    rw [cyclic_unit_dilate_set_combination, cyclic_convolution_set_combinations]
    have hh := norm_sum_sq_le_card_mul_sum_sq (I ×ˢ I) (fun p =>
      (w p.1 : ℂ) * (w p.2 : ℂ) * cyclicConvolution (cyclicSetIndicator (A p.1))
        (cyclicSetIndicator (ringDilate (u : ZMod q) (A p.2))) x)
    simp only [Finset.sum_product, Finset.card_product, Nat.cast_mul] at hh
    apply hh.trans_eq
    rw [pow_two]
    congr 1
    apply Finset.sum_congr rfl
    intro i hi
    apply Finset.sum_congr rfl
    intro j hj
    rw [norm_mul, norm_mul, Complex.norm_real, Complex.norm_real,
      Real.norm_eq_abs, Real.norm_eq_abs, abs_of_nonneg (hw i hi), abs_of_nonneg (hw j hj),
      mul_pow, mul_pow]
  calc
    _ ≤ ∑ x : ZMod q, (I.card : ℝ) ^ 2 * ∑ i ∈ I, ∑ j ∈ I, w i ^ 2 * w j ^ 2 *
        ‖cyclicConvolution (cyclicSetIndicator (A i))
          (cyclicSetIndicator (ringDilate (u : ZMod q) (A j))) x‖ ^ 2 :=
      Finset.sum_le_sum (fun x _ => hpoint x)
    _ = (I.card : ℝ) ^ 2 * ∑ i ∈ I, ∑ j ∈ I, w i ^ 2 * w j ^ 2 *
        ∑ x : ZMod q, ‖cyclicConvolution (cyclicSetIndicator (A i))
          (cyclicSetIndicator (ringDilate (u : ZMod q) (A j))) x‖ ^ 2 := by
      rw [← Finset.mul_sum, Finset.sum_comm]
      congr 1
      apply Finset.sum_congr rfl
      intro i hi
      rw [Finset.sum_comm]
      apply Finset.sum_congr rfl
      intro j hj
      rw [← Finset.mul_sum]
    _ = _ := by simp_rw [cyclic_set_convolution_energy]

theorem cyclic_set_combination_average_energy {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (w : X → ℝ) (A : X → Finset (ZMod q)) (T : Finset (ZMod q)ˣ)
    {C : ℝ} (hw : ∀ i ∈ I, 0 ≤ w i) (hC : 0 ≤ C)
    (hE : ∀ i ∈ I, ∀ j ∈ I,
      (∑ u ∈ T, (Finset.addEnergy (A i) (ringDilate (u : ZMod q) (A j)) : ℝ)) ≤
        C * ((A i).card : ℝ) * Real.sqrt ((A i).card : ℝ) *
          ((A j).card : ℝ) * Real.sqrt ((A j).card : ℝ)) :
    (∑ u ∈ T, ∑ x : ZMod q, ‖cyclicConvolution (cyclicSetCombination I w A)
      (cyclicUnitDilate (cyclicSetCombination I w A) u) x‖ ^ 2) ≤
      (I.card : ℝ) ^ 2 * C * (∑ i ∈ I, w i ^ 2 * ((A i).card : ℝ)) *
        (∑ i ∈ I, w i * ((A i).card : ℝ)) ^ 2 := by
  let a := fun i => ((A i).card : ℝ)
  have hfactor : (∑ i ∈ I, ∑ j ∈ I, w i ^ 2 * w j ^ 2 *
      (C * a i * Real.sqrt (a i) * a j * Real.sqrt (a j))) =
      C * (∑ i ∈ I, w i ^ 2 * (a i * Real.sqrt (a i))) ^ 2 := by
    rw [pow_two, Finset.sum_mul_sum, Finset.mul_sum]
    apply Finset.sum_congr rfl
    intro i hi
    rw [Finset.mul_sum]
    apply Finset.sum_congr rfl
    intro j hj
    ring
  calc
    _ ≤ ∑ u ∈ T, (I.card : ℝ) ^ 2 * ∑ i ∈ I, ∑ j ∈ I, w i ^ 2 * w j ^ 2 *
        (Finset.addEnergy (A i) (ringDilate (u : ZMod q) (A j)) : ℝ) :=
      Finset.sum_le_sum (fun u _ => cyclic_set_combination_unit_energy I w A u hw)
    _ = (I.card : ℝ) ^ 2 * ∑ i ∈ I, ∑ j ∈ I, w i ^ 2 * w j ^ 2 *
        ∑ u ∈ T, (Finset.addEnergy (A i) (ringDilate (u : ZMod q) (A j)) : ℝ) := by
      rw [← Finset.mul_sum, Finset.sum_comm]
      congr 1
      apply Finset.sum_congr rfl
      intro i hi
      rw [Finset.sum_comm]
      apply Finset.sum_congr rfl
      intro j hj
      rw [← Finset.mul_sum]
    _ ≤ (I.card : ℝ) ^ 2 * ∑ i ∈ I, ∑ j ∈ I, w i ^ 2 * w j ^ 2 *
        (C * a i * Real.sqrt (a i) * a j * Real.sqrt (a j)) := by
      apply mul_le_mul_of_nonneg_left _ (sq_nonneg _)
      apply Finset.sum_le_sum
      intro i hi
      apply Finset.sum_le_sum
      intro j hj
      exact mul_le_mul_of_nonneg_left (hE i hi j hj) (by positivity)
    _ = (I.card : ℝ) ^ 2 * C *
        (∑ i ∈ I, w i ^ 2 * (a i * Real.sqrt (a i))) ^ 2 := by rw [hfactor]; ring
    _ ≤ (I.card : ℝ) ^ 2 * C *
        ((∑ i ∈ I, w i ^ 2 * a i) * (∑ i ∈ I, w i * a i) ^ 2) :=
      mul_le_mul_of_nonneg_left (finite_weighted_card_three_halves_bound I w a hw
        (fun i _ => Nat.cast_nonneg _)) (mul_nonneg (sq_nonneg _) hC)
    _ = _ := by ring

theorem dyadic_mixed_energy_bound_of_sq {J : ℕ}
    {A B : Finset (ZMod (2 ^ J))} {T : Finset (ZMod (2 ^ J))ˣ} {τ : ℝ}
    (hE : (∑ u ∈ T, (Finset.addEnergy A (ringDilate (u : ZMod (2 ^ J)) B) : ℝ)) ^ 2 ≤
      (2 : ℝ) ^ (-τ * (J : ℝ)) * (T.card : ℝ) ^ 2 * (A.card : ℝ) ^ 3 * (B.card : ℝ) ^ 3) :
    (∑ u ∈ T, (Finset.addEnergy A (ringDilate (u : ZMod (2 ^ J)) B) : ℝ)) ≤
      ((2 : ℝ) ^ (-(τ / 2) * (J : ℝ)) * (T.card : ℝ)) *
        (A.card : ℝ) * Real.sqrt (A.card : ℝ) * (B.card : ℝ) * Real.sqrt (B.card : ℝ) := by
  have hscale : ((2 : ℝ) ^ (-(τ / 2) * (J : ℝ))) ^ 2 = (2 : ℝ) ^ (-τ * (J : ℝ)) := by
    rw [← Real.rpow_mul_natCast (by norm_num)]
    congr 1
    norm_num
    ring
  have hsquare : (((2 : ℝ) ^ (-(τ / 2) * (J : ℝ)) * (T.card : ℝ)) *
      (A.card : ℝ) * Real.sqrt (A.card : ℝ) * (B.card : ℝ) * Real.sqrt (B.card : ℝ)) ^ 2 =
      (2 : ℝ) ^ (-τ * (J : ℝ)) * (T.card : ℝ) ^ 2 * (A.card : ℝ) ^ 3 * (B.card : ℝ) ^ 3 := by
    simp only [mul_pow, Real.sq_sqrt (Nat.cast_nonneg _), hscale]
    ring
  have hnonneg : 0 ≤ ((2 : ℝ) ^ (-(τ / 2) * (J : ℝ)) * (T.card : ℝ)) *
      (A.card : ℝ) * Real.sqrt (A.card : ℝ) * (B.card : ℝ) * Real.sqrt (B.card : ℝ) := by positivity
  rw [← hsquare] at hE
  exact (sq_le_sq₀ (Finset.sum_nonneg (fun _ _ => Nat.cast_nonneg _)) hnonneg).mp hE

theorem cyclic_set_combination_norm {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (w : X → ℝ) (A : X → Finset (ZMod q))
    (hw : ∀ i ∈ I, 0 ≤ w i) (x : ZMod q) :
    ‖cyclicSetCombination I w A x‖ = ∑ i ∈ I, w i * ‖cyclicSetIndicator (A i) x‖ := by
  classical
  have heq : cyclicSetCombination I w A x =
      ((∑ i ∈ I, w i * ‖cyclicSetIndicator (A i) x‖ : ℝ) : ℂ) := by
    rw [Complex.ofReal_sum]
    apply Finset.sum_congr rfl
    intro i hi
    by_cases hx : x ∈ A i <;> simp [cyclicSetIndicator, hx]
  rw [heq, Complex.norm_of_nonneg (Finset.sum_nonneg (fun i hi => mul_nonneg (hw i hi) (norm_nonneg _)))]

theorem cyclic_set_combination_sum_norm {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (w : X → ℝ) (A : X → Finset (ZMod q))
    (hw : ∀ i ∈ I, 0 ≤ w i) :
    (∑ x : ZMod q, ‖cyclicSetCombination I w A x‖) = ∑ i ∈ I, w i * ((A i).card : ℝ) := by
  simp_rw [cyclic_set_combination_norm I w A hw]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro i hi
  rw [← Finset.mul_sum, cyclic_set_indicator_norm_sum]

theorem cyclic_set_combination_sq_norm_lower {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (w : X → ℝ) (A : X → Finset (ZMod q))
    (hw : ∀ i ∈ I, 0 ≤ w i) :
    (∑ i ∈ I, w i ^ 2 * ((A i).card : ℝ)) ≤ ∑ x : ZMod q, ‖cyclicSetCombination I w A x‖ ^ 2 := by
  calc
    _ = ∑ i ∈ I, w i ^ 2 * ∑ x : ZMod q, ‖cyclicSetIndicator (A i) x‖ ^ 2 := by
      simp_rw [cyclic_set_indicator_sq_norm_sum]
    _ = ∑ x : ZMod q, ∑ i ∈ I, (w i * ‖cyclicSetIndicator (A i) x‖) ^ 2 := by
      simp_rw [Finset.mul_sum, mul_pow]
      rw [Finset.sum_comm]
    _ ≤ ∑ x : ZMod q, (∑ i ∈ I, w i * ‖cyclicSetIndicator (A i) x‖) ^ 2 :=
      Finset.sum_le_sum (fun x _ => Finset.sum_sq_le_sq_sum_of_nonneg
        (fun i hi => mul_nonneg (hw i hi) (norm_nonneg _)))
    _ = _ := by simp_rw [cyclic_set_combination_norm I w A hw]

/-- Flattening for a bounded number of nonnegative set levels. The level
sets satisfy the same density and residue bounds, and their total mass is at most one. -/
theorem exists_dyadic_set_combination_flattening {X : Type*} {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ τ ε : ℝ, 0 < τ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ I : Finset X, ∀ w : X → ℝ,
      ∀ A : X → Finset (ZMod (2 ^ J)), ∀ T : Finset (ZMod (2 ^ J))ˣ,
        (∀ i ∈ I, 0 ≤ w i) → T.Nonempty →
        (I.card : ℝ) ≤ (2 : ℝ) ^ (τ * (J : ℝ)) →
        (∑ i ∈ I, w i * ((A i).card : ℝ)) ≤ 1 →
        (∀ i ∈ I, (A i).Nonempty ∧
          ((A i).card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ) * (J : ℝ)) ∧
          DyadicRingSetNonconcentration γ ε (A i)) →
        DyadicUnitSetNonconcentration γ ε T →
        (∑ u ∈ T, ∑ x : ZMod (2 ^ J), ‖cyclicConvolution (cyclicSetCombination I w A)
          (cyclicUnitDilate (cyclicSetCombination I w A) u) x‖ ^ 2) ≤
          (2 : ℝ) ^ (-τ * (J : ℝ)) * (T.card : ℝ) *
            ∑ x : ZMod (2 ^ J), ‖cyclicSetCombination I w A x‖ ^ 2 := by
  obtain ⟨κ, ε, hκ, hε, hε4, J₀, hmix⟩ := exists_dyadic_average_mixed_energy_decay hγ hδ hδ1
  refine ⟨κ / 6, ε, by positivity, hε, hε4, J₀, ?_⟩
  intro J hJ I w A T hw hT hI hmass hA hTmass
  have hE : ∀ i ∈ I, ∀ j ∈ I,
      (∑ u ∈ T, (Finset.addEnergy (A i) (ringDilate (u : ZMod (2 ^ J)) (A j)) : ℝ)) ≤
        ((2 : ℝ) ^ (-(κ / 2) * (J : ℝ)) * (T.card : ℝ)) *
          ((A i).card : ℝ) * Real.sqrt ((A i).card : ℝ) *
            ((A j).card : ℝ) * Real.sqrt ((A j).card : ℝ) := by
    intro i hi j hj
    exact dyadic_mixed_energy_bound_of_sq (hmix J hJ (A i) (A j) T (hA i hi).1
      (hA j hj).1 hT (hA i hi).2.1 (hA j hj).2.1 (hA i hi).2.2 (hA j hj).2.2 hTmass)
  have hh := cyclic_set_combination_average_energy I w A T hw (by positivity) hE
  have hmass0 : 0 ≤ ∑ i ∈ I, w i * ((A i).card : ℝ) :=
    Finset.sum_nonneg (fun i hi => mul_nonneg (hw i hi) (Nat.cast_nonneg _))
  have hmass2 : (∑ i ∈ I, w i * ((A i).card : ℝ)) ^ 2 ≤ 1 := by
    simpa only [one_pow] using pow_le_pow_left₀ hmass0 hmass 2
  have hI2 : (I.card : ℝ) ^ 2 ≤ ((2 : ℝ) ^ ((κ / 6) * (J : ℝ))) ^ 2 :=
    pow_le_pow_left₀ (Nat.cast_nonneg _) hI 2
  have hcoef : (I.card : ℝ) ^ 2 *
      ((2 : ℝ) ^ (-(κ / 2) * (J : ℝ)) * (T.card : ℝ)) ≤
        (2 : ℝ) ^ (-(κ / 6) * (J : ℝ)) * (T.card : ℝ) := by
    calc
      _ ≤ ((2 : ℝ) ^ ((κ / 6) * (J : ℝ))) ^ 2 *
          ((2 : ℝ) ^ (-(κ / 2) * (J : ℝ)) * (T.card : ℝ)) :=
        mul_le_mul_of_nonneg_right hI2 (by positivity)
      _ = _ := by
        rw [← Real.rpow_mul_natCast (by norm_num), ← mul_assoc, ← Real.rpow_add (by norm_num)]
        congr 2
        norm_num
        ring
  calc
    _ ≤ (I.card : ℝ) ^ 2 * ((2 : ℝ) ^ (-(κ / 2) * (J : ℝ)) * (T.card : ℝ)) *
        (∑ i ∈ I, w i ^ 2 * ((A i).card : ℝ)) * (∑ i ∈ I, w i * ((A i).card : ℝ)) ^ 2 := hh
    _ ≤ (I.card : ℝ) ^ 2 * ((2 : ℝ) ^ (-(κ / 2) * (J : ℝ)) * (T.card : ℝ)) *
        (∑ i ∈ I, w i ^ 2 * ((A i).card : ℝ)) * 1 :=
      mul_le_mul_of_nonneg_left hmass2 (by positivity)
    _ ≤ ((2 : ℝ) ^ (-(κ / 6) * (J : ℝ)) * (T.card : ℝ)) *
        (∑ i ∈ I, w i ^ 2 * ((A i).card : ℝ)) := by
      rw [mul_one]
      exact mul_le_mul_of_nonneg_right hcoef (by positivity)
    _ ≤ _ := mul_le_mul_of_nonneg_left (cyclic_set_combination_sq_norm_lower I w A hw) (by positivity)

theorem weighted_sum_sq_le_mass_mul {X : Type*} (I : Finset X) (w t : X → ℝ)
    (hw : ∀ i ∈ I, 0 ≤ w i) :
    (∑ i ∈ I, w i * t i) ^ 2 ≤ (∑ i ∈ I, w i) * ∑ i ∈ I, w i * t i ^ 2 := by
  have hprod : (∑ i ∈ I, Real.sqrt (w i) * (Real.sqrt (w i) * t i)) = ∑ i ∈ I, w i * t i := by
    apply Finset.sum_congr rfl
    intro i hi
    rw [← mul_assoc, Real.mul_self_sqrt (hw i hi)]
  have hfirst : (∑ i ∈ I, Real.sqrt (w i) ^ 2) = ∑ i ∈ I, w i :=
    Finset.sum_congr rfl (fun i hi => Real.sq_sqrt (hw i hi))
  have hsecond : (∑ i ∈ I, (Real.sqrt (w i) * t i) ^ 2) = ∑ i ∈ I, w i * t i ^ 2 := by
    apply Finset.sum_congr rfl
    intro i hi
    rw [mul_pow, Real.sq_sqrt (hw i hi)]
  have hh := Finset.sum_mul_sq_le_sq_mul_sq I (fun i => Real.sqrt (w i)) (fun i => Real.sqrt (w i) * t i)
  rwa [hprod, hfirst, hsecond] at hh

theorem cyclic_convolution_young_sq {q : ℕ} [NeZero q] (f g : ZMod q → ℂ) :
    (∑ x : ZMod q, ‖cyclicConvolution f g x‖ ^ 2) ≤
      (∑ x : ZMod q, ‖f x‖) ^ 2 * ∑ x : ZMod q, ‖g x‖ ^ 2 := by
  have hpoint : ∀ x : ZMod q, ‖cyclicConvolution f g x‖ ^ 2 ≤
      (∑ y : ZMod q, ‖f y‖) * ∑ y : ZMod q, ‖f y‖ * ‖g (x - y)‖ ^ 2 := by
    intro x
    have hh : ‖cyclicConvolution f g x‖ ≤ ∑ y : ZMod q, ‖f y‖ * ‖g (x - y)‖ := by
      simpa only [cyclicConvolution, norm_mul] using norm_sum_le Finset.univ (fun y => f y * g (x - y))
    exact (pow_le_pow_left₀ (norm_nonneg _) hh 2).trans
      (weighted_sum_sq_le_mass_mul Finset.univ (fun y => ‖f y‖) (fun y => ‖g (x - y)‖)
        (fun _ _ => norm_nonneg _))
  calc
    _ ≤ ∑ x : ZMod q, (∑ y : ZMod q, ‖f y‖) * ∑ y : ZMod q, ‖f y‖ * ‖g (x - y)‖ ^ 2 :=
      Finset.sum_le_sum (fun x _ => hpoint x)
    _ = (∑ y : ZMod q, ‖f y‖) * ∑ y : ZMod q, ‖f y‖ * ∑ x : ZMod q, ‖g x‖ ^ 2 := by
      rw [← Finset.mul_sum, Finset.sum_comm]
      congr 1
      apply Finset.sum_congr rfl
      intro y hy
      rw [← Finset.mul_sum]
      congr 1
      exact Fintype.sum_equiv (Equiv.subRight y) _ _ (fun _ => rfl)
    _ = _ := by rw [← Finset.sum_mul]; ring

theorem cyclic_convolution_comm {q : ℕ} [NeZero q] (f g : ZMod q → ℂ) :
    cyclicConvolution f g = cyclicConvolution g f := by
  funext x
  unfold cyclicConvolution
  apply Fintype.sum_equiv (Equiv.subLeft x)
  intro y
  simp only [Equiv.subLeft_apply, sub_sub_cancel]
  ring

theorem cyclic_convolution_young_sq_right {q : ℕ} [NeZero q] (f g : ZMod q → ℂ) :
    (∑ x : ZMod q, ‖cyclicConvolution f g x‖ ^ 2) ≤
      (∑ x : ZMod q, ‖g x‖) ^ 2 * ∑ x : ZMod q, ‖f x‖ ^ 2 := by
  rw [cyclic_convolution_comm]
  exact cyclic_convolution_young_sq g f

theorem cyclic_unit_dilate_sum_norm {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (u : (ZMod q)ˣ) :
    (∑ x : ZMod q, ‖cyclicUnitDilate f u x‖) = ∑ x : ZMod q, ‖f x‖ := by
  exact Fintype.sum_equiv (ringUnitMulAddEquiv u⁻¹).toEquiv _ _ (fun _ => rfl)

theorem cyclic_unit_dilate_sq_norm {q : ℕ} [NeZero q] (f : ZMod q → ℂ) (u : (ZMod q)ˣ) :
    (∑ x : ZMod q, ‖cyclicUnitDilate f u x‖ ^ 2) = ∑ x : ZMod q, ‖f x‖ ^ 2 := by
  exact Fintype.sum_equiv (ringUnitMulAddEquiv u⁻¹).toEquiv _ _ (fun _ => rfl)

theorem cyclic_convolution_norm_of_nonnegative {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) (hf : ∀ x, f x = (‖f x‖ : ℂ)) (hg : ∀ x, g x = (‖g x‖ : ℂ))
    (x : ZMod q) : ‖cyclicConvolution f g x‖ = ∑ y : ZMod q, ‖f y‖ * ‖g (x - y)‖ := by
  have heq : cyclicConvolution f g x = ((∑ y : ZMod q, ‖f y‖ * ‖g (x - y)‖ : ℝ) : ℂ) := by
    unfold cyclicConvolution
    rw [Complex.ofReal_sum]
    apply Finset.sum_congr rfl
    intro y hy
    rw [Complex.ofReal_mul, ← hf, ← hg]
  rw [heq, Complex.norm_of_nonneg (Finset.sum_nonneg (fun _ _ => mul_nonneg (norm_nonneg _) (norm_nonneg _)))]

theorem cyclic_set_combination_nonnegative {X : Type*} {q : ℕ} [NeZero q]
    (I : Finset X) (w : X → ℝ) (A : X → Finset (ZMod q)) (hw : ∀ i ∈ I, 0 ≤ w i)
    (x : ZMod q) : cyclicSetCombination I w A x = (‖cyclicSetCombination I w A x‖ : ℂ) := by
  classical
  rw [cyclic_set_combination_norm I w A hw, Complex.ofReal_sum]
  apply Finset.sum_congr rfl
  intro i hi
  by_cases hx : x ∈ A i <;> simp [cyclicSetIndicator, hx]

theorem cyclic_convolution_norm_dominated {q : ℕ} [NeZero q]
    (f g F G : ZMod q → ℂ) (hF : ∀ x, F x = (‖F x‖ : ℂ)) (hG : ∀ x, G x = (‖G x‖ : ℂ))
    (hf : ∀ x, ‖f x‖ ≤ ‖F x‖) (hg : ∀ x, ‖g x‖ ≤ ‖G x‖) (x : ZMod q) :
    ‖cyclicConvolution f g x‖ ≤ ‖cyclicConvolution F G x‖ := by
  rw [cyclic_convolution_norm_of_nonnegative F G hF hG]
  calc
    _ ≤ ∑ y : ZMod q, ‖f y‖ * ‖g (x - y)‖ := by
      simpa only [cyclicConvolution, norm_mul] using norm_sum_le Finset.univ (fun y => f y * g (x - y))
    _ ≤ _ := Finset.sum_le_sum (fun y _ => mul_le_mul (hf y) (hg _) (norm_nonneg _) (norm_nonneg _))


noncomputable def dyadicLevelWeight (n : ℕ) : ℝ := (1 / 2 : ℝ) ^ n

noncomputable def finiteDyadicLevel {X : Type*} [Fintype X] (p : X → ℝ) (n : ℕ) : Finset X := by
  classical
  exact Finset.univ.filter (fun x => dyadicLevelWeight n ≤ p x ∧ p x < 2 * dyadicLevelWeight n)

theorem dyadic_level_weight_pos (n : ℕ) : 0 < dyadicLevelWeight n := by
  unfold dyadicLevelWeight
  positivity

theorem dyadic_level_weight_zero : dyadicLevelWeight 0 = 1 := by simp [dyadicLevelWeight]

theorem dyadic_level_weight_succ (n : ℕ) : 2 * dyadicLevelWeight (n + 1) = dyadicLevelWeight n := by
  unfold dyadicLevelWeight
  rw [pow_succ]
  ring

theorem dyadic_level_weight_antitone {m n : ℕ} (hmn : m ≤ n) : dyadicLevelWeight n ≤ dyadicLevelWeight m := by
  exact pow_le_pow_of_le_one (by norm_num) (by norm_num) hmn

theorem dyadic_level_weight_rpow (n : ℕ) : dyadicLevelWeight n = (2 : ℝ) ^ (-(n : ℝ)) := by
  rw [Real.rpow_neg (by norm_num), Real.rpow_natCast, ← inv_pow]
  simp only [dyadicLevelWeight, one_div]

theorem mem_finite_dyadic_level {X : Type*} [Fintype X] (p : X → ℝ) (n : ℕ) (x : X) :
    x ∈ finiteDyadicLevel p n ↔ dyadicLevelWeight n ≤ p x ∧ p x < 2 * dyadicLevelWeight n := by
  classical
  simp only [finiteDyadicLevel, Finset.mem_filter, Finset.mem_univ, true_and]

theorem finite_dyadic_level_disjoint {X : Type*} [Fintype X] (p : X → ℝ) {m n : ℕ}
    (hmn : m ≠ n) : Disjoint (finiteDyadicLevel p m) (finiteDyadicLevel p n) := by
  classical
  rw [Finset.disjoint_left]
  intro x hxm hxn
  obtain ⟨hmlo, hmhi⟩ := (mem_finite_dyadic_level p m x).mp hxm
  obtain ⟨hnlo, hnhi⟩ := (mem_finite_dyadic_level p n x).mp hxn
  rcases lt_or_gt_of_ne hmn with hmn | hnm
  · have hh := mul_le_mul_of_nonneg_left (dyadic_level_weight_antitone (Nat.succ_le_of_lt hmn)) (by norm_num : (0 : ℝ) ≤ 2)
    rw [dyadic_level_weight_succ] at hh
    linarith only [hh, hmlo, hnhi]
  · have hh := mul_le_mul_of_nonneg_left (dyadic_level_weight_antitone (Nat.succ_le_of_lt hnm)) (by norm_num : (0 : ℝ) ≤ 2)
    rw [dyadic_level_weight_succ] at hh
    linarith only [hh, hnlo, hmhi]

theorem exists_finite_dyadic_level {X : Type*} [Fintype X] (p : X → ℝ) (N : ℕ) {x : X}
    (hxlo : dyadicLevelWeight N ≤ p x) (hxhi : p x ≤ 1) :
    ∃ n : ℕ, n ≤ N ∧ x ∈ finiteDyadicLevel p n := by
  induction N with
  | zero =>
    refine ⟨0, le_rfl, (mem_finite_dyadic_level p 0 x).mpr ⟨hxlo, ?_⟩⟩
    rw [dyadic_level_weight_zero]
    linarith only [hxhi]
  | succ N ih =>
    by_cases hh : dyadicLevelWeight N ≤ p x
    · obtain ⟨n, hn, hxn⟩ := ih hh
      exact ⟨n, hn.trans (Nat.le_succ _), hxn⟩
    · refine ⟨N + 1, le_rfl, (mem_finite_dyadic_level p (N + 1) x).mpr ⟨hxlo, ?_⟩⟩
      rw [dyadic_level_weight_succ]
      exact lt_of_not_ge hh

theorem finite_level_card_bound {X : Type*} [Fintype X] [DecidableEq X]
    (p : X → ℝ) {A : Finset X} {w M : ℝ} (hp : ∀ x, 0 ≤ p x)
    (hmass : ∑ x : X, p x ≤ M) (hlower : ∀ x ∈ A, w ≤ p x) :
    w * (A.card : ℝ) ≤ M := by
  calc
    _ = ∑ _x ∈ A, w := by simp [mul_comm]
    _ ≤ ∑ x ∈ A, p x := Finset.sum_le_sum hlower
    _ ≤ ∑ x : X, p x := Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _) (fun x _ _ => hp x)
    _ ≤ _ := hmass

theorem finite_level_fiber_bound {X Y : Type*} [Fintype X] [DecidableEq X] [DecidableEq Y]
    (p : X → ℝ) (π : X → Y) {A : Finset X} {w m M : ℝ}
    (hp : ∀ x, 0 ≤ p x) (hm : 0 < m)
    (hlower : ∀ x ∈ A, w ≤ p x) (hupper : ∀ x ∈ A, p x ≤ 2 * w)
    (hmass : m ≤ ∑ x ∈ A, p x)
    (hfiber : ∀ r : Y, (∑ x ∈ Finset.univ.filter (fun x => π x = r), p x) ≤ M) :
    ∀ r : Y, ((A.filter (fun x => π x = r)).card : ℝ) ≤ (2 * M / m) * (A.card : ℝ) := by
  intro r
  have hsize : m ≤ (2 * w) * (A.card : ℝ) := by
    apply hmass.trans
    calc
      _ ≤ ∑ _x ∈ A, 2 * w := Finset.sum_le_sum hupper
      _ = _ := by simp [mul_comm]
  have hcount : w * ((A.filter (fun x => π x = r)).card : ℝ) ≤ M := by
    calc
      _ = ∑ _x ∈ A.filter (fun x => π x = r), w := by simp [mul_comm]
      _ ≤ ∑ x ∈ A.filter (fun x => π x = r), p x :=
        Finset.sum_le_sum (fun x hx => hlower x (Finset.mem_filter.mp hx).1)
      _ ≤ ∑ x ∈ Finset.univ.filter (fun x => π x = r), p x :=
        Finset.sum_le_sum_of_subset_of_nonneg (Finset.filter_subset_filter _ (Finset.subset_univ _))
          (fun x _ _ => hp x)
      _ ≤ _ := hfiber r
  apply (mul_le_mul_iff_left₀ hm).mp
  calc
    _ ≤ ((2 * w) * (A.card : ℝ)) * ((A.filter (fun x => π x = r)).card : ℝ) := by
      simpa only [mul_comm] using mul_le_mul_of_nonneg_right hsize
        (Nat.cast_nonneg (A.filter (fun x => π x = r)).card : (0 : ℝ) ≤ (A.filter (fun x => π x = r)).card)
    _ = (2 * (A.card : ℝ)) * (w * ((A.filter (fun x => π x = r)).card : ℝ)) := by ring
    _ ≤ (2 * (A.card : ℝ)) * M := mul_le_mul_of_nonneg_left hcount (by positivity)
    _ = _ := by field_simp

theorem finite_dyadic_level_fiber_bound {X Y : Type*} [Fintype X] [DecidableEq X] [DecidableEq Y]
    (p : X → ℝ) (π : X → Y) (n : ℕ) {m M : ℝ}
    (hp : ∀ x, 0 ≤ p x) (hm : 0 < m) (hmass : m ≤ ∑ x ∈ finiteDyadicLevel p n, p x)
    (hfiber : ∀ r : Y, (∑ x ∈ Finset.univ.filter (fun x => π x = r), p x) ≤ M) :
    ∀ r : Y, (((finiteDyadicLevel p n).filter (fun x => π x = r)).card : ℝ) ≤
      (2 * M / m) * ((finiteDyadicLevel p n).card : ℝ) :=
  finite_level_fiber_bound p π hp hm
    (fun x hx => ((mem_finite_dyadic_level p n x).mp hx).1)
    (fun x hx => ((mem_finite_dyadic_level p n x).mp hx).2.le) hmass hfiber

noncomputable def finiteDyadicApprox {X : Type*} [Fintype X]
    (p : X → ℝ) (I : Finset ℕ) (x : X) : ℝ := by
  classical
  exact ∑ n ∈ I, if x ∈ finiteDyadicLevel p n then dyadicLevelWeight n else 0

theorem finite_dyadic_approx_eq_weight {X : Type*} [Fintype X]
    (p : X → ℝ) {I : Finset ℕ} {n : ℕ} {x : X}
    (hn : n ∈ I) (hx : x ∈ finiteDyadicLevel p n) : finiteDyadicApprox p I x = dyadicLevelWeight n := by
  classical
  unfold finiteDyadicApprox
  rw [Finset.sum_eq_single n]
  · simp only [hx, if_true]
  · intro k hk hkn
    have hnot : x ∉ finiteDyadicLevel p k := by
      intro hxk
      exact (Finset.disjoint_left.mp (finite_dyadic_level_disjoint p hkn)) hxk hx
    simp only [hnot, if_false]
  · exact fun h => (h hn).elim

theorem finite_dyadic_approx_nonneg {X : Type*} [Fintype X]
    (p : X → ℝ) (I : Finset ℕ) (x : X) : 0 ≤ finiteDyadicApprox p I x := by
  classical
  unfold finiteDyadicApprox
  apply Finset.sum_nonneg
  intro n hn
  split_ifs
  · exact (dyadic_level_weight_pos n).le
  · exact le_rfl

theorem finite_dyadic_approx_le {X : Type*} [Fintype X]
    (p : X → ℝ) (I : Finset ℕ) (hp : ∀ x, 0 ≤ p x) (x : X) : finiteDyadicApprox p I x ≤ p x := by
  classical
  by_cases hx : ∃ n ∈ I, x ∈ finiteDyadicLevel p n
  · obtain ⟨n, hn, hxn⟩ := hx
    rw [finite_dyadic_approx_eq_weight p hn hxn]
    exact ((mem_finite_dyadic_level p n x).mp hxn).1
  · have hzero : finiteDyadicApprox p I x = 0 := by
      apply Finset.sum_eq_zero
      intro n hn
      have hnot : x ∉ finiteDyadicLevel p n := fun hxn => hx ⟨n, hn, hxn⟩
      simp only [hnot, if_false]
    rw [hzero]
    exact hp x

theorem finite_dyadic_approx_dominates {X : Type*} [Fintype X] [DecidableEq X]
    (p : X → ℝ) (I : Finset ℕ) {x : X} (hx : x ∈ I.biUnion (finiteDyadicLevel p)) :
    p x ≤ 2 * finiteDyadicApprox p I x := by
  obtain ⟨n, hn, hxn⟩ := Finset.mem_biUnion.mp hx
  rw [finite_dyadic_approx_eq_weight p hn hxn]
  exact ((mem_finite_dyadic_level p n x).mp hxn).2.le

theorem finite_dyadic_approx_sum {X : Type*} [Fintype X]
    (p : X → ℝ) (I : Finset ℕ) :
    (∑ x : X, finiteDyadicApprox p I x) = ∑ n ∈ I, dyadicLevelWeight n * ((finiteDyadicLevel p n).card : ℝ) := by
  classical
  unfold finiteDyadicApprox
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro n hn
  simp [← Finset.sum_filter, mul_comm]

theorem finite_dyadic_union_mass {X : Type*} [Fintype X] [DecidableEq X]
    (p : X → ℝ) (I : Finset ℕ) :
    (∑ x ∈ I.biUnion (finiteDyadicLevel p), p x) = ∑ n ∈ I, ∑ x ∈ finiteDyadicLevel p n, p x := by
  apply Finset.sum_biUnion
  intro m hm n hn hmn
  exact finite_dyadic_level_disjoint p hmn

theorem cyclic_dyadic_combination_norm {q : ℕ} [NeZero q]
    (p : ZMod q → ℝ) (I : Finset ℕ) (x : ZMod q) :
    ‖cyclicSetCombination I dyadicLevelWeight (finiteDyadicLevel p) x‖ = finiteDyadicApprox p I x := by
  classical
  rw [cyclic_set_combination_norm _ _ _ (fun n _ => (dyadic_level_weight_pos n).le)]
  simp only [cyclic_set_indicator_norm, mul_ite, mul_one, mul_zero, finiteDyadicApprox]
  apply Finset.sum_congr rfl
  intro n hn
  split_ifs <;> rfl

/-- Retain high-weight levels with significant mass. The remaining points
split into a part of small total mass and a part of uniformly small weight. -/
theorem exists_finite_dyadic_level_decomposition {X : Type*} [Fintype X] [DecidableEq X]
    (p : X → ℝ) (N : ℕ) {v m : ℝ} (hp : ∀ x, 0 ≤ p x) (hp1 : ∀ x, p x ≤ 1)
    (hm : 0 < m) (hNv : dyadicLevelWeight N ≤ v) :
    ∃ I : Finset ℕ, ∃ G S : Finset X,
      I.card ≤ N + 1 ∧ G = I.biUnion (finiteDyadicLevel p) ∧ Disjoint G S ∧
      (∀ n ∈ I, (finiteDyadicLevel p n).Nonempty ∧ v < dyadicLevelWeight n ∧
        m ≤ ∑ x ∈ finiteDyadicLevel p n, p x) ∧
      (∑ x ∈ S, p x) ≤ (N + 1 : ℕ) * m ∧
      (∀ x : X, x ∉ G → x ∉ S → p x ≤ 2 * v) := by
  classical
  let I := (Finset.range (N + 1)).filter (fun n => v < dyadicLevelWeight n ∧ m ≤ ∑ x ∈ finiteDyadicLevel p n, p x)
  let K := (Finset.range (N + 1)).filter (fun n => v < dyadicLevelWeight n ∧ (∑ x ∈ finiteDyadicLevel p n, p x) < m)
  let G := I.biUnion (finiteDyadicLevel p)
  let S := K.biUnion (finiteDyadicLevel p)
  have hI : I.card ≤ N + 1 := (Finset.card_filter_le _ _).trans_eq (Finset.card_range _)
  have hK : K.card ≤ N + 1 := (Finset.card_filter_le _ _).trans_eq (Finset.card_range _)
  refine ⟨I, G, S, hI, rfl, ?_, ?_, ?_, ?_⟩
  · rw [Finset.disjoint_left]
    intro x hxG hxS
    obtain ⟨i, hi, hxi⟩ := Finset.mem_biUnion.mp hxG
    obtain ⟨k, hk, hxk⟩ := Finset.mem_biUnion.mp hxS
    have hik : i ≠ k := by
      intro heq
      subst k
      exact (not_lt_of_ge (Finset.mem_filter.mp hi).2.2) (Finset.mem_filter.mp hk).2.2
    exact (Finset.disjoint_left.mp (finite_dyadic_level_disjoint p hik)) hxi hxk
  · intro n hn
    have hgood := (Finset.mem_filter.mp hn).2
    refine ⟨?_, hgood⟩
    by_contra h
    have he : finiteDyadicLevel p n = ∅ := Finset.not_nonempty_iff_eq_empty.mp h
    simp only [he, Finset.sum_empty] at hgood
    exact (not_le_of_gt hm) hgood.2
  · rw [finite_dyadic_union_mass]
    calc
      _ ≤ ∑ _n ∈ K, m := Finset.sum_le_sum (fun n hn => (Finset.mem_filter.mp hn).2.2.le)
      _ = (K.card : ℝ) * m := by simp
      _ ≤ _ := mul_le_mul_of_nonneg_right (by exact_mod_cast hK) hm.le
  · intro x hxG hxS
    by_contra hx
    have hxv : 2 * v < p x := lt_of_not_ge hx
    have hv : 0 < v := (dyadic_level_weight_pos N).trans_le hNv
    have hxN : dyadicLevelWeight N ≤ p x := by linarith only [hNv, hxv, hv]
    obtain ⟨n, hn, hxn⟩ := exists_finite_dyadic_level p N hxN (hp1 x)
    have hnrange : n ∈ Finset.range (N + 1) := Finset.mem_range.mpr (by omega)
    have hnv : v < dyadicLevelWeight n := by
      have hh := ((mem_finite_dyadic_level p n x).mp hxn).2
      linarith only [hh, hxv]
    by_cases hmass : m ≤ ∑ x ∈ finiteDyadicLevel p n, p x
    · exact hxG (Finset.mem_biUnion.mpr ⟨n, Finset.mem_filter.mpr ⟨hnrange, hnv, hmass⟩, hxn⟩)
    · exact hxS (Finset.mem_biUnion.mpr ⟨n, Finset.mem_filter.mpr ⟨hnrange, hnv, lt_of_not_ge hmass⟩, hxn⟩)

theorem norm_five_sum_sq_le (a b c d e : ℂ) :
    ‖a + b + c + d + e‖ ^ 2 ≤ 5 * (‖a‖ ^ 2 + ‖b‖ ^ 2 + ‖c‖ ^ 2 + ‖d‖ ^ 2 + ‖e‖ ^ 2) := by
  have hh := norm_sum_sq_le_card_mul_sum_sq (Finset.univ : Finset (Fin 5)) ![a, b, c, d, e]
  simpa [Fin.sum_univ_succ, add_assoc] using hh

theorem cyclic_unit_convolution_decomposition {q : ℕ} [NeZero q]
    (f g l s : ZMod q → ℂ) (u : (ZMod q)ˣ)
    (hdecomp : ∀ x, f x = g x + l x + s x) (x : ZMod q) :
    cyclicConvolution f (cyclicUnitDilate f u) x =
      cyclicConvolution g (cyclicUnitDilate g u) x +
      cyclicConvolution l (cyclicUnitDilate f u) x +
      cyclicConvolution s (cyclicUnitDilate f u) x +
      cyclicConvolution g (cyclicUnitDilate l u) x +
      cyclicConvolution g (cyclicUnitDilate s u) x := by
  unfold cyclicConvolution cyclicUnitDilate
  rw [← Finset.sum_add_distrib, ← Finset.sum_add_distrib, ← Finset.sum_add_distrib,
    ← Finset.sum_add_distrib]
  apply Finset.sum_congr rfl
  intro y hy
  rw [hdecomp y, hdecomp (((u⁻¹ : (ZMod q)ˣ) : ZMod q) * (x - y))]
  ring

theorem cyclic_unit_convolution_error_bound {q : ℕ} [NeZero q]
    (f g l s : ZMod q → ℂ) (u : (ZMod q)ˣ) {v m : ℝ}
    (hdecomp : ∀ x, f x = g x + l x + s x)
    (hfmass : (∑ x : ZMod q, ‖f x‖) ≤ 1) (hgmass : (∑ x : ZMod q, ‖g x‖) ≤ 1)
    (hgener : (∑ x : ZMod q, ‖g x‖ ^ 2) ≤ ∑ x : ZMod q, ‖f x‖ ^ 2)
    (hlener : (∑ x : ZMod q, ‖l x‖ ^ 2) ≤ v)
    (hsmass : (∑ x : ZMod q, ‖s x‖) ≤ m) (hm : 0 ≤ m) :
    (∑ x : ZMod q, ‖cyclicConvolution f (cyclicUnitDilate f u) x‖ ^ 2) ≤
      5 * (∑ x : ZMod q, ‖cyclicConvolution g (cyclicUnitDilate g u) x‖ ^ 2) +
        10 * v + 10 * m ^ 2 * ∑ x : ZMod q, ‖f x‖ ^ 2 := by
  have hfmass2 : (∑ x : ZMod q, ‖f x‖) ^ 2 ≤ 1 := by
    simpa only [one_pow] using pow_le_pow_left₀ (Finset.sum_nonneg (fun _ _ => norm_nonneg _)) hfmass 2
  have hgmass2 : (∑ x : ZMod q, ‖g x‖) ^ 2 ≤ 1 := by
    simpa only [one_pow] using pow_le_pow_left₀ (Finset.sum_nonneg (fun _ _ => norm_nonneg _)) hgmass 2
  have hsmass2 : (∑ x : ZMod q, ‖s x‖) ^ 2 ≤ m ^ 2 :=
    pow_le_pow_left₀ (Finset.sum_nonneg (fun _ _ => norm_nonneg _)) hsmass 2
  have hlf : (∑ x : ZMod q, ‖cyclicConvolution l (cyclicUnitDilate f u) x‖ ^ 2) ≤ v := by
    calc
      _ ≤ (∑ x : ZMod q, ‖cyclicUnitDilate f u x‖) ^ 2 * ∑ x : ZMod q, ‖l x‖ ^ 2 :=
        cyclic_convolution_young_sq_right _ _
      _ = (∑ x : ZMod q, ‖f x‖) ^ 2 * ∑ x : ZMod q, ‖l x‖ ^ 2 := by rw [cyclic_unit_dilate_sum_norm]
      _ ≤ 1 * ∑ x : ZMod q, ‖l x‖ ^ 2 := mul_le_mul_of_nonneg_right hfmass2 (by positivity)
      _ ≤ _ := by simpa only [one_mul] using hlener
  have hsf : (∑ x : ZMod q, ‖cyclicConvolution s (cyclicUnitDilate f u) x‖ ^ 2) ≤
      m ^ 2 * ∑ x : ZMod q, ‖f x‖ ^ 2 := by
    calc
      _ ≤ (∑ x : ZMod q, ‖s x‖) ^ 2 * ∑ x : ZMod q, ‖cyclicUnitDilate f u x‖ ^ 2 :=
        cyclic_convolution_young_sq _ _
      _ = (∑ x : ZMod q, ‖s x‖) ^ 2 * ∑ x : ZMod q, ‖f x‖ ^ 2 := by rw [cyclic_unit_dilate_sq_norm]
      _ ≤ _ := mul_le_mul_of_nonneg_right hsmass2 (by positivity)
  have hgl : (∑ x : ZMod q, ‖cyclicConvolution g (cyclicUnitDilate l u) x‖ ^ 2) ≤ v := by
    calc
      _ ≤ (∑ x : ZMod q, ‖g x‖) ^ 2 * ∑ x : ZMod q, ‖cyclicUnitDilate l u x‖ ^ 2 :=
        cyclic_convolution_young_sq _ _
      _ = (∑ x : ZMod q, ‖g x‖) ^ 2 * ∑ x : ZMod q, ‖l x‖ ^ 2 := by rw [cyclic_unit_dilate_sq_norm]
      _ ≤ 1 * ∑ x : ZMod q, ‖l x‖ ^ 2 := mul_le_mul_of_nonneg_right hgmass2 (by positivity)
      _ ≤ _ := by simpa only [one_mul] using hlener
  have hgs : (∑ x : ZMod q, ‖cyclicConvolution g (cyclicUnitDilate s u) x‖ ^ 2) ≤
      m ^ 2 * ∑ x : ZMod q, ‖f x‖ ^ 2 := by
    calc
      _ ≤ (∑ x : ZMod q, ‖cyclicUnitDilate s u x‖) ^ 2 * ∑ x : ZMod q, ‖g x‖ ^ 2 :=
        cyclic_convolution_young_sq_right _ _
      _ = (∑ x : ZMod q, ‖s x‖) ^ 2 * ∑ x : ZMod q, ‖g x‖ ^ 2 := by rw [cyclic_unit_dilate_sum_norm]
      _ ≤ _ := mul_le_mul hsmass2 hgener (by positivity) (sq_nonneg _)
  calc
    _ ≤ ∑ x : ZMod q, 5 * (
        ‖cyclicConvolution g (cyclicUnitDilate g u) x‖ ^ 2 +
        ‖cyclicConvolution l (cyclicUnitDilate f u) x‖ ^ 2 +
        ‖cyclicConvolution s (cyclicUnitDilate f u) x‖ ^ 2 +
        ‖cyclicConvolution g (cyclicUnitDilate l u) x‖ ^ 2 +
        ‖cyclicConvolution g (cyclicUnitDilate s u) x‖ ^ 2) := by
      apply Finset.sum_le_sum
      intro x hx
      rw [cyclic_unit_convolution_decomposition f g l s u hdecomp]
      exact norm_five_sum_sq_le _ _ _ _ _
    _ = 5 * ((∑ x : ZMod q, ‖cyclicConvolution g (cyclicUnitDilate g u) x‖ ^ 2) +
        (∑ x : ZMod q, ‖cyclicConvolution l (cyclicUnitDilate f u) x‖ ^ 2) +
        (∑ x : ZMod q, ‖cyclicConvolution s (cyclicUnitDilate f u) x‖ ^ 2) +
        (∑ x : ZMod q, ‖cyclicConvolution g (cyclicUnitDilate l u) x‖ ^ 2) +
        ∑ x : ZMod q, ‖cyclicConvolution g (cyclicUnitDilate s u) x‖ ^ 2) := by
      rw [← Finset.mul_sum]
      simp only [Finset.sum_add_distrib]
    _ ≤ _ := by linarith only [hlf, hsf, hgl, hgs]

theorem cyclic_unit_energy_dominated {q : ℕ} [NeZero q]
    (f F : ZMod q → ℂ) (u : (ZMod q)ˣ) {c : ℝ} (hc : 0 ≤ c)
    (hF : ∀ x, F x = (‖F x‖ : ℂ)) (hf : ∀ x, ‖f x‖ ≤ c * ‖F x‖) :
    (∑ x : ZMod q, ‖cyclicConvolution f (cyclicUnitDilate f u) x‖ ^ 2) ≤
      c ^ 4 * ∑ x : ZMod q, ‖cyclicConvolution F (cyclicUnitDilate F u) x‖ ^ 2 := by
  have hpoint : ∀ x : ZMod q, ‖cyclicConvolution f (cyclicUnitDilate f u) x‖ ≤
      c ^ 2 * ‖cyclicConvolution F (cyclicUnitDilate F u) x‖ := by
    intro x
    rw [cyclic_convolution_norm_of_nonnegative F (cyclicUnitDilate F u) hF
      (fun y => hF (((u⁻¹ : (ZMod q)ˣ) : ZMod q) * y))]
    calc
      _ ≤ ∑ y : ZMod q, ‖f y‖ * ‖cyclicUnitDilate f u (x - y)‖ := by
        simpa only [cyclicConvolution, norm_mul] using
          norm_sum_le Finset.univ (fun y => f y * cyclicUnitDilate f u (x - y))
      _ ≤ ∑ y : ZMod q, (c * ‖F y‖) * (c * ‖cyclicUnitDilate F u (x - y)‖) :=
        Finset.sum_le_sum (fun y _ => mul_le_mul (hf y) (hf _) (norm_nonneg _) (by positivity))
      _ = _ := by
        rw [Finset.mul_sum]
        apply Finset.sum_congr rfl
        intro y hy
        ring
  calc
    _ ≤ ∑ x : ZMod q, (c ^ 2 * ‖cyclicConvolution F (cyclicUnitDilate F u) x‖) ^ 2 :=
      Finset.sum_le_sum (fun x _ => pow_le_pow_left₀ (norm_nonneg _) (hpoint x) 2)
    _ = _ := by simp only [mul_pow, ← pow_mul, show (2 : ℕ) * 2 = 4 from rfl, Finset.mul_sum]

/-- A fixed exponential bound absorbs the number of dyadic levels. -/
theorem exists_dyadic_linear_count_bound {η : ℝ} (hη : 0 < η) :
    ∃ J₀ : ℕ, ∀ J : ℕ, J₀ ≤ J → ((2 * J + 1 : ℕ) : ℝ) ≤ (2 : ℝ) ^ (η * (J : ℝ)) := by
  let b := (2 : ℝ) ^ (η / 2)
  have hb : 1 < b := Real.one_lt_rpow (by norm_num) (by positivity)
  let d := b - 1
  have hd : 0 < d := sub_pos.mpr hb
  obtain ⟨J₀, hJ₀⟩ := exists_nat_ge (2 / d ^ 2)
  refine ⟨J₀, ?_⟩
  intro J hJ
  have hJ0 : (0 : ℝ) ≤ J := Nat.cast_nonneg _
  have hJr : (J₀ : ℝ) ≤ (J : ℝ) := by exact_mod_cast hJ
  have hbound : 2 ≤ (J : ℝ) * d ^ 2 := (div_le_iff₀ (sq_pos_of_pos hd)).mp (hJ₀.trans hJr)
  have hquad : 2 * (J : ℝ) ≤ ((J : ℝ) * d) ^ 2 := by
    have hh := mul_le_mul_of_nonneg_left hbound hJ0
    nlinarith only [hh]
  have hbern : 1 + (J : ℝ) * d ≤ b ^ J := by
    have hh := one_add_mul_le_pow (show -2 ≤ d by linarith only [hd]) J
    simpa only [d, add_sub_cancel] using hh
  calc
    _ ≤ (1 + (J : ℝ) * d) ^ 2 := by
      push_cast
      nlinarith only [hquad, mul_nonneg hJ0 hd.le]
    _ ≤ (b ^ J) ^ 2 := pow_le_pow_left₀ (by positivity) hbern 2
    _ = _ := by
      dsimp only [b]
      rw [← Real.rpow_mul_natCast (by norm_num), ← Real.rpow_mul_natCast (by norm_num)]
      congr 1
      norm_num
      ring

noncomputable def finiteRealRestriction {X : Type*} [DecidableEq X]
    (p : X → ℝ) (A : Finset X) (x : X) : ℂ := if x ∈ A then (p x : ℂ) else 0

theorem finite_real_restriction_norm {X : Type*} [DecidableEq X]
    (p : X → ℝ) (A : Finset X) (hp : ∀ x, 0 ≤ p x) (x : X) :
    ‖finiteRealRestriction p A x‖ = if x ∈ A then p x else 0 := by
  by_cases hx : x ∈ A <;>
    simp [finiteRealRestriction, hx, Complex.norm_real, Real.norm_eq_abs, abs_of_nonneg (hp x)]

theorem finite_real_restriction_norm_le {X : Type*} [DecidableEq X]
    (p : X → ℝ) (A : Finset X) (hp : ∀ x, 0 ≤ p x) (x : X) :
    ‖finiteRealRestriction p A x‖ ≤ p x := by
  rw [finite_real_restriction_norm p A hp]
  split_ifs
  · exact le_rfl
  · exact hp x

theorem finite_real_restriction_mass {X : Type*} [Fintype X] [DecidableEq X]
    (p : X → ℝ) (A : Finset X) (hp : ∀ x, 0 ≤ p x) :
    (∑ x : X, ‖finiteRealRestriction p A x‖) = ∑ x ∈ A, p x := by
  simp only [finite_real_restriction_norm p A hp, ← Finset.sum_filter,
    Finset.filter_mem_eq_inter, Finset.univ_inter]

theorem finite_real_restriction_mass_le {X : Type*} [Fintype X] [DecidableEq X]
    (p : X → ℝ) (A : Finset X) (hp : ∀ x, 0 ≤ p x) :
    (∑ x : X, ‖finiteRealRestriction p A x‖) ≤ ∑ x : X, p x :=
  Finset.sum_le_sum (fun x _ => finite_real_restriction_norm_le p A hp x)

theorem finite_real_restriction_energy_le {X : Type*} [Fintype X] [DecidableEq X]
    (p : X → ℝ) (A : Finset X) (hp : ∀ x, 0 ≤ p x) :
    (∑ x : X, ‖finiteRealRestriction p A x‖ ^ 2) ≤ ∑ x : X, p x ^ 2 :=
  Finset.sum_le_sum (fun x _ => pow_le_pow_left₀ (norm_nonneg _) (finite_real_restriction_norm_le p A hp x) 2)

theorem finite_real_restriction_energy_of_peak {X : Type*} [Fintype X] [DecidableEq X]
    (p : X → ℝ) (A : Finset X) {M : ℝ} (hp : ∀ x, 0 ≤ p x) (hM : 0 ≤ M)
    (hmass : (∑ x : X, p x) ≤ 1) (hpeak : ∀ x ∈ A, p x ≤ M) :
    (∑ x : X, ‖finiteRealRestriction p A x‖ ^ 2) ≤ M := by
  have hh : ∀ x : X, ‖finiteRealRestriction p A x‖ ≤ M := by
    intro x
    rw [finite_real_restriction_norm p A hp]
    split_ifs with hx
    · exact hpeak x hx
    · exact hM
  calc
    _ ≤ ∑ x : X, M * ‖finiteRealRestriction p A x‖ := by
      apply Finset.sum_le_sum
      intro x hx
      simpa only [pow_two] using mul_le_mul_of_nonneg_right (hh x) (norm_nonneg _)
    _ = M * ∑ x : X, ‖finiteRealRestriction p A x‖ := (Finset.mul_sum _ _ _).symm
    _ ≤ M * 1 := mul_le_mul_of_nonneg_left ((finite_real_restriction_mass_le p A hp).trans hmass) hM
    _ = _ := mul_one _

theorem finite_real_restriction_three_parts {X : Type*} [Fintype X] [DecidableEq X]
    (p : X → ℝ) {G S : Finset X} (hGS : Disjoint G S) (x : X) :
    (p x : ℂ) = finiteRealRestriction p G x + finiteRealRestriction p ((G ∪ S)ᶜ) x +
      finiteRealRestriction p S x := by
  by_cases hxG : x ∈ G
  · have hxS : x ∉ S := fun hxS => (Finset.disjoint_left.mp hGS) hxG hxS
    simp [finiteRealRestriction, hxG, hxS]
  · by_cases hxS : x ∈ S <;> simp [finiteRealRestriction, hxG, hxS]


def DyadicProbabilityNonconcentration {J : ℕ} (γ ε : ℝ) (p : ZMod (2 ^ J) → ℝ) : Prop :=
  ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
    (∑ x ∈ Finset.univ.filter (fun x : ZMod (2 ^ J) => (x.val : ZMod (2 ^ L)) = r), p x) ≤
      (2 : ℝ) ^ (-γ * (L : ℝ))

/-- Averaged additive flattening for an arbitrary nonnegative law whose
squared norm remains above the density threshold. -/
theorem exists_dyadic_probability_flattening {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ τ ε : ℝ, 0 < τ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ p : ZMod (2 ^ J) → ℝ, ∀ T : Finset (ZMod (2 ^ J))ˣ,
        (∀ x, 0 ≤ p x) → (∑ x : ZMod (2 ^ J), p x) ≤ 1 →
        (2 : ℝ) ^ (-(1 - δ) * (J : ℝ)) ≤ (∑ x : ZMod (2 ^ J), p x ^ 2) →
        DyadicProbabilityNonconcentration γ ε p → T.Nonempty → DyadicUnitSetNonconcentration γ ε T →
        (∑ u ∈ T, ∑ x : ZMod (2 ^ J),
          ‖cyclicConvolution (fun y => (p y : ℂ)) (cyclicUnitDilate (fun y => (p y : ℂ)) u) x‖ ^ 2) ≤
          (2 : ℝ) ^ (-τ * (J : ℝ)) * (T.card : ℝ) * ∑ x : ZMod (2 ^ J), p x ^ 2 := by
  classical
  obtain ⟨a, ε, ha, hε, hε4, J₀, hflat⟩ := exists_dyadic_set_combination_flattening (X := ℕ)
    (show 0 < γ / 2 by positivity) (show 0 < δ / 2 by positivity) (by linarith only [hδ1])
  let η := γ * ε / 8
  have hη : 0 < η := by dsimp only [η]; positivity
  let b := min a (min (δ / 2) η)
  have hb : 0 < b := lt_min ha (lt_min (by positivity) hη)
  have hba : b ≤ a := min_le_left _ _
  have hbδ : b ≤ δ / 2 := (min_le_right _ _).trans (min_le_left _ _)
  have hbη : b ≤ η := (min_le_right _ _).trans (min_le_right _ _)
  obtain ⟨J₁, hJ₁⟩ := exists_dyadic_linear_count_bound ha
  obtain ⟨J₂, hJ₂⟩ := exists_dyadic_linear_count_bound (show 0 < η / 2 by positivity)
  obtain ⟨J₃, hJ₃⟩ := exists_dyadic_fixed_power_absorption 1 0 (τ := 0) (ξ := η) (by simpa using hη)
  obtain ⟨J₄, hJ₄⟩ := exists_dyadic_fixed_power_absorption 7 0 (τ := 0) (ξ := b / 2)
    (by simpa using (show 0 < b / 2 by positivity))
  refine ⟨b / 2, ε, by positivity, hε, hε4, max J₀ (max J₁ (max J₂ (max J₃ J₄))), ?_⟩
  intro J hJ p T hp hmass hnorm hspread hT hTspread
  have hj₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hj₁ : J₁ ≤ J := (le_max_left _ _).trans ((le_max_right _ _).trans hJ)
  have hj₂ : J₂ ≤ J := (le_max_left _ _).trans ((le_max_right _ _).trans ((le_max_right _ _).trans hJ))
  have hj₃ : J₃ ≤ J := (le_max_left _ _).trans ((le_max_right _ _).trans ((le_max_right _ _).trans ((le_max_right _ _).trans hJ)))
  have hj₄ : J₄ ≤ J := (le_max_right _ _).trans ((le_max_right _ _).trans ((le_max_right _ _).trans ((le_max_right _ _).trans hJ)))
  have hJ0 : (0 : ℝ) ≤ J := Nat.cast_nonneg _
  have hp1 : ∀ x, p x ≤ 1 := fun x =>
    (Finset.single_le_sum (fun y _ => hp y) (Finset.mem_univ x)).trans hmass
  let v := (2 : ℝ) ^ (-(1 - δ / 2) * (J : ℝ))
  let m := (2 : ℝ) ^ (-η * (J : ℝ))
  let z := (2 : ℝ) ^ (-(η / 2) * (J : ℝ))
  let H := ∑ x : ZMod (2 ^ J), p x ^ 2
  have hv : 0 < v := by positivity
  have hm : 0 < m := by positivity
  have hz : 0 ≤ z := by positivity
  have hH : 0 ≤ H := Finset.sum_nonneg (fun _ _ => sq_nonneg _)
  have hNv : dyadicLevelWeight (2 * J) ≤ v := by
    rw [dyadic_level_weight_rpow]
    apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
    push_cast
    nlinarith only [hJ0, mul_nonneg hδ.le hJ0]
  obtain ⟨I, G, S, hI, hG, hGS, hlevels, hS, hlow⟩ :=
    exists_finite_dyadic_level_decomposition p (2 * J) hp hp1 hm hNv
  let A := finiteDyadicLevel p
  let F := cyclicSetCombination I dyadicLevelWeight A
  let f := fun x => (p x : ℂ)
  let g := finiteRealRestriction p G
  let l := finiteRealRestriction p ((G ∪ S)ᶜ)
  let s := finiteRealRestriction p S
  have hfnorm : ∀ x, ‖f x‖ = p x := fun x => Complex.norm_of_nonneg (hp x)
  have hfmass : (∑ x : ZMod (2 ^ J), ‖f x‖) ≤ 1 := by simpa only [hfnorm] using hmass
  have hfenergy : (∑ x : ZMod (2 ^ J), ‖f x‖ ^ 2) = H := by simp only [hfnorm, H]
  have hIcap : (I.card : ℝ) ≤ (2 : ℝ) ^ (a * (J : ℝ)) :=
    (show (I.card : ℝ) ≤ ((2 * J + 1 : ℕ) : ℝ) by exact_mod_cast hI).trans (hJ₁ J hj₁)
  have hsmass : (∑ x : ZMod (2 ^ J), ‖s x‖) ≤ z := by
    rw [finite_real_restriction_mass p S hp]
    calc
      _ ≤ ((2 * J + 1 : ℕ) : ℝ) * m := hS
      _ ≤ (2 : ℝ) ^ ((η / 2) * (J : ℝ)) * (2 : ℝ) ^ (-η * (J : ℝ)) :=
        mul_le_mul_of_nonneg_right (hJ₂ J hj₂) hm.le
      _ = _ := by
        rw [← Real.rpow_add (by norm_num)]
        congr 1
        ring
  have h2η : (2 : ℝ) ≤ (2 : ℝ) ^ (η * (J : ℝ)) := by simpa using hJ₃ J hj₃
  have hloss : ∀ L : ℕ, ε * (J : ℝ) < (L : ℝ) →
      2 * (2 : ℝ) ^ (-γ * (L : ℝ)) / m ≤ (2 : ℝ) ^ (-(γ / 2) * (L : ℝ)) := by
    intro L hL
    apply (div_le_iff₀ hm).mpr
    calc
      _ ≤ (2 : ℝ) ^ (η * (J : ℝ)) * (2 : ℝ) ^ (-γ * (L : ℝ)) := by gcongr
      _ = (2 : ℝ) ^ (η * (J : ℝ) - γ * (L : ℝ)) := by
        rw [← Real.rpow_add (by norm_num)]; congr 1; ring
      _ ≤ (2 : ℝ) ^ (-(γ / 2) * (L : ℝ) - η * (J : ℝ)) := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        dsimp only [η]
        nlinarith only [mul_lt_mul_of_pos_left hL hγ, mul_nonneg hγ.le (Nat.cast_nonneg L : (0 : ℝ) ≤ L)]
      _ = _ := by
        dsimp only [m]
        rw [← Real.rpow_add (by norm_num)]
        congr 1
        ring
  have hA : ∀ n ∈ I, (A n).Nonempty ∧
      ((A n).card : ℝ) ≤ (2 : ℝ) ^ ((1 - δ / 2) * (J : ℝ)) ∧
      DyadicRingSetNonconcentration (γ / 2) ε (A n) := by
    intro n hn
    obtain ⟨hnonempty, hnweight, hnmass⟩ := hlevels n hn
    refine ⟨hnonempty, ?_, ?_⟩
    · have hcard := finite_level_card_bound p hp hmass
        (fun x hx => ((mem_finite_dyadic_level p n x).mp hx).1)
      have hvc : v * ((A n).card : ℝ) ≤ 1 :=
        (mul_le_mul_of_nonneg_right hnweight.le (Nat.cast_nonneg _)).trans hcard
      apply (mul_le_mul_iff_of_pos_left hv).mp
      calc
        _ ≤ 1 := hvc
        _ = _ := by
          dsimp only [v]
          rw [← Real.rpow_add (by norm_num),
            show -(1 - δ / 2) * (J : ℝ) + (1 - δ / 2) * (J : ℝ) = 0 by ring, Real.rpow_zero]
    · intro L hL hεL r
      have hh := finite_dyadic_level_fiber_bound p (fun x => (x.val : ZMod (2 ^ L))) n
        hp hm hnmass (hspread L hL hεL) r
      exact hh.trans (mul_le_mul_of_nonneg_right (hloss L hεL) (Nat.cast_nonneg _))
  have hTspread' : DyadicUnitSetNonconcentration (γ / 2) ε T := by
    intro L hL hεL r
    apply (hTspread L hL hεL r).trans
    apply mul_le_mul_of_nonneg_right _ (Nat.cast_nonneg _)
    apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
    nlinarith only [mul_nonneg hγ.le (Nat.cast_nonneg L : (0 : ℝ) ≤ L)]
  have hFmass : (∑ n ∈ I, dyadicLevelWeight n * ((A n).card : ℝ)) ≤ 1 := by
    rw [← finite_dyadic_approx_sum p I]
    exact (Finset.sum_le_sum (fun x _ => finite_dyadic_approx_le p I hp x)).trans hmass
  have hFenergy : (∑ x : ZMod (2 ^ J), ‖F x‖ ^ 2) ≤ H := by
    apply Finset.sum_le_sum
    intro x hx
    rw [cyclic_dyadic_combination_norm]
    exact pow_le_pow_left₀ (finite_dyadic_approx_nonneg p I x) (finite_dyadic_approx_le p I hp x) 2
  have hFflat := hflat J hj₀ I dyadicLevelWeight A T (fun n _ => (dyadic_level_weight_pos n).le)
    hT hIcap hFmass hA hTspread'
  have hFnonneg : ∀ x, F x = (‖F x‖ : ℂ) :=
    cyclic_set_combination_nonnegative I dyadicLevelWeight A (fun n _ => (dyadic_level_weight_pos n).le)
  have hgdom : ∀ x, ‖g x‖ ≤ 2 * ‖F x‖ := by
    intro x
    rw [finite_real_restriction_norm p G hp]
    by_cases hx : x ∈ G
    · rw [if_pos hx, cyclic_dyadic_combination_norm]
      exact finite_dyadic_approx_dominates p I (by rwa [← hG])
    · rw [if_neg hx]
      positivity
  have hgavg : (∑ u ∈ T, ∑ x : ZMod (2 ^ J), ‖cyclicConvolution g (cyclicUnitDilate g u) x‖ ^ 2) ≤
      16 * (2 : ℝ) ^ (-a * (J : ℝ)) * (T.card : ℝ) * H := by
    have hFbound : (∑ u ∈ T, ∑ x : ZMod (2 ^ J), ‖cyclicConvolution F (cyclicUnitDilate F u) x‖ ^ 2) ≤
        (2 : ℝ) ^ (-a * (J : ℝ)) * (T.card : ℝ) * H := by
      exact hFflat.trans (mul_le_mul_of_nonneg_left hFenergy
        (show 0 ≤ (2 : ℝ) ^ (-a * (J : ℝ)) * (T.card : ℝ) from mul_nonneg
          (Real.rpow_pos_of_pos (by norm_num) _).le (Nat.cast_nonneg _)))
    calc
      _ ≤ ∑ u ∈ T, (2 : ℝ) ^ (4 : ℕ) * ∑ x : ZMod (2 ^ J), ‖cyclicConvolution F (cyclicUnitDilate F u) x‖ ^ 2 :=
        Finset.sum_le_sum (fun u _ => cyclic_unit_energy_dominated g F u (by norm_num) hFnonneg hgdom)
      _ = 16 * ∑ u ∈ T, ∑ x : ZMod (2 ^ J), ‖cyclicConvolution F (cyclicUnitDilate F u) x‖ ^ 2 := by
        rw [← Finset.mul_sum, show (2 : ℝ) ^ (4 : ℕ) = 16 by norm_num]
      _ ≤ 16 * ((2 : ℝ) ^ (-a * (J : ℝ)) * (T.card : ℝ) * H) :=
        mul_le_mul_of_nonneg_left hFbound (by norm_num)
      _ = _ := by ring
  have hlener : (∑ x : ZMod (2 ^ J), ‖l x‖ ^ 2) ≤ 2 * v := by
    apply finite_real_restriction_energy_of_peak p _ hp (by positivity) hmass
    intro x hx
    have hh : x ∉ G ∧ x ∉ S := by simpa only [Finset.mem_compl, Finset.mem_union, not_or] using hx
    exact hlow x hh.1 hh.2
  have hzsq : z ^ 2 = (2 : ℝ) ^ (-η * (J : ℝ)) := by
    dsimp only [z]
    rw [← Real.rpow_mul_natCast (by norm_num)]
    congr 1
    norm_num
    ring
  have hvrel : v ≤ (2 : ℝ) ^ (-(δ / 2) * (J : ℝ)) * H := by
    calc
      _ = (2 : ℝ) ^ (-(δ / 2) * (J : ℝ)) * (2 : ℝ) ^ (-(1 - δ) * (J : ℝ)) := by
        dsimp only [v]
        rw [← Real.rpow_add (by norm_num)]
        congr 1
        ring
      _ ≤ _ := mul_le_mul_of_nonneg_left hnorm (by positivity)
  have herr : (∑ u ∈ T, ∑ x : ZMod (2 ^ J), ‖cyclicConvolution f (cyclicUnitDilate f u) x‖ ^ 2) ≤
      (80 * (2 : ℝ) ^ (-a * (J : ℝ)) + 20 * (2 : ℝ) ^ (-(δ / 2) * (J : ℝ)) +
        10 * (2 : ℝ) ^ (-η * (J : ℝ))) * (T.card : ℝ) * H := by
    have hu : ∀ u ∈ T, (∑ x : ZMod (2 ^ J), ‖cyclicConvolution f (cyclicUnitDilate f u) x‖ ^ 2) ≤
        5 * (∑ x : ZMod (2 ^ J), ‖cyclicConvolution g (cyclicUnitDilate g u) x‖ ^ 2) +
          20 * v + 10 * (2 : ℝ) ^ (-η * (J : ℝ)) * H := by
      intro u hu
      have hh := cyclic_unit_convolution_error_bound f g l s u
        (finite_real_restriction_three_parts p hGS) hfmass
        ((finite_real_restriction_mass_le p G hp).trans hmass)
        (by simpa only [hfenergy] using finite_real_restriction_energy_le p G hp)
        hlener hsmass hz
      simpa only [hfenergy, hzsq, show (10 : ℝ) * (2 * v) = 20 * v by ring] using hh
    calc
      _ ≤ ∑ u ∈ T, (5 * (∑ x : ZMod (2 ^ J), ‖cyclicConvolution g (cyclicUnitDilate g u) x‖ ^ 2) +
          20 * v + 10 * (2 : ℝ) ^ (-η * (J : ℝ)) * H) := Finset.sum_le_sum hu
      _ = 5 * (∑ u ∈ T, ∑ x : ZMod (2 ^ J), ‖cyclicConvolution g (cyclicUnitDilate g u) x‖ ^ 2) +
          (T.card : ℝ) * (20 * v + 10 * (2 : ℝ) ^ (-η * (J : ℝ)) * H) := by
        rw [Finset.sum_add_distrib, Finset.sum_add_distrib, ← Finset.mul_sum]
        simp only [Finset.sum_const, nsmul_eq_mul]
        ring
      _ ≤ 5 * (16 * (2 : ℝ) ^ (-a * (J : ℝ)) * (T.card : ℝ) * H) +
          (T.card : ℝ) * (20 * ((2 : ℝ) ^ (-(δ / 2) * (J : ℝ)) * H) +
            10 * (2 : ℝ) ^ (-η * (J : ℝ)) * H) := by
        apply add_le_add (mul_le_mul_of_nonneg_left hgavg (by norm_num : (0 : ℝ) ≤ 5))
        apply mul_le_mul_of_nonneg_left _ (Nat.cast_nonneg T.card : (0 : ℝ) ≤ T.card)
        exact add_le_add (mul_le_mul_of_nonneg_left hvrel (by norm_num : (0 : ℝ) ≤ 20)) le_rfl
      _ = _ := by ring
  have h110 : (110 : ℝ) ≤ (2 : ℝ) ^ ((b / 2) * (J : ℝ)) := by
    have hh := hJ₄ J hj₄
    norm_num at hh
    exact (by norm_num : (110 : ℝ) ≤ 128).trans hh
  have hcoef : 80 * (2 : ℝ) ^ (-a * (J : ℝ)) + 20 * (2 : ℝ) ^ (-(δ / 2) * (J : ℝ)) +
      10 * (2 : ℝ) ^ (-η * (J : ℝ)) ≤ (2 : ℝ) ^ (-(b / 2) * (J : ℝ)) := by
    have hpow : ∀ c : ℝ, b ≤ c → (2 : ℝ) ^ (-c * (J : ℝ)) ≤ (2 : ℝ) ^ (-b * (J : ℝ)) := by
      intro c hc
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      have hh := mul_le_mul_of_nonneg_right hc hJ0
      linarith only [hh]
    calc
      _ ≤ 110 * (2 : ℝ) ^ (-b * (J : ℝ)) := by
        linarith only [hpow a hba, hpow (δ / 2) hbδ, hpow η hbη]
      _ ≤ (2 : ℝ) ^ ((b / 2) * (J : ℝ)) * (2 : ℝ) ^ (-b * (J : ℝ)) :=
        mul_le_mul_of_nonneg_right h110 (by positivity)
      _ = _ := by rw [← Real.rpow_add (by norm_num)]; congr 1; ring
  exact herr.trans (mul_le_mul_of_nonneg_right
    (mul_le_mul_of_nonneg_right hcoef (Nat.cast_nonneg _)) hH)


theorem finite_dyadic_approx_weighted_sum {X : Type*} [Fintype X]
    (p : X → ℝ) (I : Finset ℕ) (b : X → ℝ) :
    (∑ x : X, finiteDyadicApprox p I x * b x) =
      ∑ n ∈ I, dyadicLevelWeight n * ∑ x ∈ finiteDyadicLevel p n, b x := by
  classical
  simp only [finiteDyadicApprox, Finset.sum_mul]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro n hn
  rw [Finset.mul_sum]
  simp only [ite_mul, zero_mul, ← Finset.sum_filter]
  simp

/-- Lift bounds on retained dyadic levels to an average under a nonnegative
law. The two discarded parts are controlled by mass and pointwise size. -/
theorem finite_dyadic_weighted_average {X : Type*} [Fintype X] [DecidableEq X]
    (p b : X → ℝ) (I : Finset ℕ) (G S : Finset X) {C D v H : ℝ}
    (hp : ∀ x, 0 ≤ p x) (hmass : (∑ x : X, p x) ≤ 1)
    (hb : ∀ x, 0 ≤ b x) (hbH : ∀ x, b x ≤ H) (hH : 0 ≤ H)
    (hC : 0 ≤ C) (hv : 0 ≤ v) (hG : G = I.biUnion (finiteDyadicLevel p))
    (hGS : Disjoint G S) (hS : (∑ x ∈ S, p x) ≤ D)
    (hlow : ∀ x, x ∉ G → x ∉ S → p x ≤ v)
    (hlevels : ∀ n ∈ I, (∑ x ∈ finiteDyadicLevel p n, b x) ≤
      C * ((finiteDyadicLevel p n).card : ℝ)) :
    (∑ x : X, p x * b x) ≤ 2 * C + (D + v * Fintype.card X) * H := by
  classical
  have happrox : (∑ x : X, finiteDyadicApprox p I x * b x) ≤ C := by
    rw [finite_dyadic_approx_weighted_sum]
    calc
      _ ≤ ∑ n ∈ I, dyadicLevelWeight n *
          (C * ((finiteDyadicLevel p n).card : ℝ)) :=
        Finset.sum_le_sum (fun n hn => mul_le_mul_of_nonneg_left (hlevels n hn)
          (dyadic_level_weight_pos n).le)
      _ = C * ∑ n ∈ I, dyadicLevelWeight n * ((finiteDyadicLevel p n).card : ℝ) := by
        rw [Finset.mul_sum]
        apply Finset.sum_congr rfl
        intro n hn
        ring
      _ ≤ C * 1 := by
        apply mul_le_mul_of_nonneg_left _ hC
        rw [← finite_dyadic_approx_sum]
        exact (Finset.sum_le_sum (fun x _ => finite_dyadic_approx_le p I hp x)).trans hmass
      _ = C := mul_one _
  have hgood : (∑ x ∈ G, p x * b x) ≤ 2 * C := by
    calc
      _ ≤ ∑ x ∈ G, 2 * (finiteDyadicApprox p I x * b x) := by
        apply Finset.sum_le_sum
        intro x hx
        have hh := mul_le_mul_of_nonneg_right
          (finite_dyadic_approx_dominates p I (by rwa [← hG])) (hb x)
        simpa only [mul_assoc] using hh
      _ = 2 * ∑ x ∈ G, finiteDyadicApprox p I x * b x := (Finset.mul_sum _ _ _).symm
      _ ≤ 2 * ∑ x : X, finiteDyadicApprox p I x * b x := by
        apply mul_le_mul_of_nonneg_left _ (by norm_num : (0 : ℝ) ≤ 2)
        exact Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _)
          (fun x _ _ => mul_nonneg (finite_dyadic_approx_nonneg p I x) (hb x))
      _ ≤ 2 * C := mul_le_mul_of_nonneg_left happrox (by norm_num)
  have hsmall : (∑ x ∈ S, p x * b x) ≤ D * H := by
    calc
      _ ≤ ∑ x ∈ S, p x * H := Finset.sum_le_sum (fun x _ =>
        mul_le_mul_of_nonneg_left (hbH x) (hp x))
      _ = (∑ x ∈ S, p x) * H := (Finset.sum_mul _ _ _).symm
      _ ≤ D * H := mul_le_mul_of_nonneg_right hS hH
  have htail : (∑ x ∈ (G ∪ S)ᶜ, p x * b x) ≤ v * Fintype.card X * H := by
    calc
      _ ≤ ∑ _x ∈ (G ∪ S)ᶜ, v * H := by
        apply Finset.sum_le_sum
        intro x hx
        have hnot : x ∉ G ∧ x ∉ S := by
          simpa only [Finset.mem_compl, Finset.mem_union, not_or] using hx
        exact mul_le_mul (hlow x hnot.1 hnot.2) (hbH x) (hb x) hv
      _ = (((G ∪ S)ᶜ).card : ℝ) * (v * H) := by simp
      _ ≤ (Fintype.card X : ℝ) * (v * H) := by
        apply mul_le_mul_of_nonneg_right _ (mul_nonneg hv hH)
        exact_mod_cast Finset.card_le_univ ((G ∪ S)ᶜ)
      _ = _ := by ring
  have hpartition : (∑ x : X, p x * b x) =
      (∑ x ∈ G, p x * b x) + (∑ x ∈ S, p x * b x) +
        ∑ x ∈ (G ∪ S)ᶜ, p x * b x := by
    rw [← Finset.sum_union hGS, Finset.sum_add_sum_compl]
  rw [hpartition]
  calc
    _ ≤ 2 * C + D * H + v * Fintype.card X * H := add_le_add (add_le_add hgood hsmall) htail
    _ = _ := by ring

theorem unit_image_fiber_card {R Q : Type*} [Monoid R] [DecidableEq R]
    (T : Finset Rˣ) (π : R → Q) (r : Q) [DecidableEq Q] :
    ((T.image (fun u : Rˣ => (u : R))).filter (fun a => π a = r)).card =
      (T.filter (fun u : Rˣ => π (u : R) = r)).card := by
  classical
  rw [Finset.filter_image, Finset.card_image_of_injective _ Units.val_injective]

def DyadicUnitProbabilityNonconcentration {J : ℕ} (γ ε : ℝ)
    (w : (ZMod (2 ^ J))ˣ → ℝ) : Prop :=
  ∀ L : ℕ, L ≤ J → ε * (J : ℝ) < (L : ℝ) → ∀ r : ZMod (2 ^ L),
    (∑ u ∈ Finset.univ.filter
      (fun u : (ZMod (2 ^ J))ˣ => (((u : ZMod (2 ^ J)).val : ZMod (2 ^ L))) = r), w u) ≤
        (2 : ℝ) ^ (-γ * (L : ℝ))

theorem cyclic_probability_unit_energy_bound {q : ℕ} [NeZero q]
    (p : ZMod q → ℝ) (hp : ∀ x, 0 ≤ p x) (hmass : (∑ x : ZMod q, p x) ≤ 1)
    (u : (ZMod q)ˣ) :
    (∑ x : ZMod q, ‖cyclicConvolution (fun y => (p y : ℂ))
      (cyclicUnitDilate (fun y => (p y : ℂ)) u) x‖ ^ 2) ≤ ∑ x : ZMod q, p x ^ 2 := by
  have hfnorm : ∀ x : ZMod q, ‖(p x : ℂ)‖ = p x := fun x => Complex.norm_of_nonneg (hp x)
  have hh := cyclic_convolution_young_sq (fun y => (p y : ℂ))
    (cyclicUnitDilate (fun y => (p y : ℂ)) u)
  rw [cyclic_unit_dilate_sq_norm] at hh
  simp only [hfnorm] at hh
  have hsq : (∑ x : ZMod q, p x) ^ 2 ≤ 1 := by
    simpa only [one_pow] using pow_le_pow_left₀ (Finset.sum_nonneg (fun x _ => hp x)) hmass 2
  exact hh.trans (by simpa only [one_mul] using
    mul_le_mul_of_nonneg_right hsq (Finset.sum_nonneg (fun _ _ => sq_nonneg _)))

/-- Additive flattening with both a nonuniform input law and a nonuniform
law on unit multipliers. All parameters are independent of the two laws. -/
theorem exists_dyadic_weighted_probability_flattening {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ τ ε : ℝ, 0 < τ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ p : ZMod (2 ^ J) → ℝ,
      ∀ w : (ZMod (2 ^ J))ˣ → ℝ,
        (∀ x, 0 ≤ p x) → (∑ x : ZMod (2 ^ J), p x) ≤ 1 →
        (2 : ℝ) ^ (-(1 - δ) * (J : ℝ)) ≤ (∑ x : ZMod (2 ^ J), p x ^ 2) →
        DyadicProbabilityNonconcentration γ ε p →
        (∀ u, 0 ≤ w u) → (∑ u : (ZMod (2 ^ J))ˣ, w u) ≤ 1 →
        DyadicUnitProbabilityNonconcentration γ ε w →
        (∑ u : (ZMod (2 ^ J))ˣ, w u * ∑ x : ZMod (2 ^ J),
          ‖cyclicConvolution (fun y => (p y : ℂ))
            (cyclicUnitDilate (fun y => (p y : ℂ)) u) x‖ ^ 2) ≤
          (2 : ℝ) ^ (-τ * (J : ℝ)) * ∑ x : ZMod (2 ^ J), p x ^ 2 := by
  classical
  obtain ⟨a, ε, ha, hε, hε4, J₀, hflat⟩ := exists_dyadic_probability_flattening
    (show 0 < γ / 2 by positivity) hδ hδ1
  let η := γ * ε / 8
  have hη : 0 < η := by dsimp only [η]; positivity
  let b := min a (min (η / 2) 1)
  have hb : 0 < b := lt_min ha (lt_min (by positivity) (by norm_num))
  have hba : b ≤ a := min_le_left _ _
  have hbη : b ≤ η / 2 := (min_le_right _ _).trans (min_le_left _ _)
  have hb1 : b ≤ 1 := (min_le_right _ _).trans (min_le_right _ _)
  obtain ⟨J₁, hJ₁⟩ := exists_dyadic_linear_count_bound (show 0 < η / 2 by positivity)
  obtain ⟨J₂, hJ₂⟩ := exists_dyadic_fixed_power_absorption 1 0
    (τ := 0) (ξ := η) (by simpa using hη)
  obtain ⟨J₃, hJ₃⟩ := exists_dyadic_fixed_power_absorption 3 0
    (τ := 0) (ξ := b / 2) (by simpa using (show 0 < b / 2 by positivity))
  refine ⟨b / 2, ε, by positivity, hε, hε4, max J₀ (max J₁ (max J₂ J₃)), ?_⟩
  intro J hJ p w hp hmass hnorm hspread hw hwmass hwspread
  have hj₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hj₁ : J₁ ≤ J := (le_max_left _ _).trans ((le_max_right _ _).trans hJ)
  have hj₂ : J₂ ≤ J := (le_max_left _ _).trans ((le_max_right _ _).trans ((le_max_right _ _).trans hJ))
  have hj₃ : J₃ ≤ J := (le_max_right _ _).trans ((le_max_right _ _).trans ((le_max_right _ _).trans hJ))
  have hJ0 : (0 : ℝ) ≤ J := Nat.cast_nonneg _
  have hw1 : ∀ u, w u ≤ 1 := fun u =>
    (Finset.single_le_sum (fun v _ => hw v) (Finset.mem_univ u)).trans hwmass
  let v := (2 : ℝ) ^ (-2 * (J : ℝ))
  let m := (2 : ℝ) ^ (-η * (J : ℝ))
  let H := ∑ x : ZMod (2 ^ J), p x ^ 2
  let E := fun u : (ZMod (2 ^ J))ˣ => ∑ x : ZMod (2 ^ J),
    ‖cyclicConvolution (fun y => (p y : ℂ)) (cyclicUnitDilate (fun y => (p y : ℂ)) u) x‖ ^ 2
  have hv : 0 < v := by positivity
  have hm : 0 < m := by positivity
  have hH : 0 ≤ H := Finset.sum_nonneg (fun _ _ => sq_nonneg _)
  have hNv : dyadicLevelWeight (2 * J) ≤ v := by
    rw [dyadic_level_weight_rpow]
    dsimp only [v]
    norm_num
  obtain ⟨I, G, S, hI, hG, hGS, hlevels, hS, hlow⟩ :=
    exists_finite_dyadic_level_decomposition w (2 * J) hw hw1 hm hNv
  have h2η : (2 : ℝ) ≤ (2 : ℝ) ^ (η * (J : ℝ)) := by simpa using hJ₂ J hj₂
  have hloss : ∀ L : ℕ, ε * (J : ℝ) < (L : ℝ) →
      2 * (2 : ℝ) ^ (-γ * (L : ℝ)) / m ≤ (2 : ℝ) ^ (-(γ / 2) * (L : ℝ)) := by
    intro L hL
    apply (div_le_iff₀ hm).mpr
    calc
      _ ≤ (2 : ℝ) ^ (η * (J : ℝ)) * (2 : ℝ) ^ (-γ * (L : ℝ)) := by gcongr
      _ = (2 : ℝ) ^ (η * (J : ℝ) - γ * (L : ℝ)) := by
        rw [← Real.rpow_add (by norm_num)]; congr 1; ring
      _ ≤ (2 : ℝ) ^ (-(γ / 2) * (L : ℝ) - η * (J : ℝ)) := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        dsimp only [η]
        nlinarith only [mul_lt_mul_of_pos_left hL hγ,
          mul_nonneg hγ.le (Nat.cast_nonneg L : (0 : ℝ) ≤ L)]
      _ = _ := by
        dsimp only [m]
        rw [← Real.rpow_add (by norm_num)]
        congr 1
        ring
  have hlevelspread : ∀ n ∈ I,
      DyadicUnitSetNonconcentration (γ / 2) ε (finiteDyadicLevel w n) := by
    intro n hn L hL hεL r
    rw [unit_image_fiber_card]
    have hh := finite_dyadic_level_fiber_bound w
      (fun u : (ZMod (2 ^ J))ˣ => (((u : ZMod (2 ^ J)).val : ZMod (2 ^ L)))) n
      hw hm (hlevels n hn).2.2 (hwspread L hL hεL) r
    exact hh.trans (mul_le_mul_of_nonneg_right (hloss L hεL) (Nat.cast_nonneg _))
  have hspread' : DyadicProbabilityNonconcentration (γ / 2) ε p := by
    intro L hL hεL r
    apply (hspread L hL hεL r).trans
    apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
    nlinarith only [mul_nonneg hγ.le (Nat.cast_nonneg L : (0 : ℝ) ≤ L)]
  have hsmall : (∑ u ∈ S, w u) ≤ (2 : ℝ) ^ (-(η / 2) * (J : ℝ)) := by
    calc
      _ ≤ ((2 * J + 1 : ℕ) : ℝ) * m := hS
      _ ≤ (2 : ℝ) ^ ((η / 2) * (J : ℝ)) * (2 : ℝ) ^ (-η * (J : ℝ)) :=
        mul_le_mul_of_nonneg_right (hJ₁ J hj₁) hm.le
      _ = _ := by rw [← Real.rpow_add (by norm_num)]; congr 1; ring
  have htail : 2 * v * (Fintype.card (ZMod (2 ^ J))ˣ : ℝ) ≤
      2 * (2 : ℝ) ^ (-(J : ℝ)) := by
    have hcard : Fintype.card (ZMod (2 ^ J))ˣ ≤ 2 ^ J := by
      calc
        _ ≤ Fintype.card (ZMod (2 ^ J)) :=
          Fintype.card_le_of_injective (fun u : (ZMod (2 ^ J))ˣ => (u : ZMod (2 ^ J))) Units.val_injective
        _ = _ := ZMod.card _
    calc
      _ ≤ 2 * v * ((2 ^ J : ℕ) : ℝ) :=
        mul_le_mul_of_nonneg_left (by exact_mod_cast hcard) (by positivity)
      _ = _ := by
        dsimp only [v]
        push_cast
        rw [← Real.rpow_natCast, mul_assoc, ← Real.rpow_add (by norm_num)]
        congr 2
        ring
  have hmain : (∑ u : (ZMod (2 ^ J))ˣ, w u * E u) ≤
      (2 * (2 : ℝ) ^ (-a * (J : ℝ)) + (2 : ℝ) ^ (-(η / 2) * (J : ℝ)) +
        2 * (2 : ℝ) ^ (-(J : ℝ))) * H := by
    have hh := finite_dyadic_weighted_average w E I G S hw hwmass
      (fun _ => Finset.sum_nonneg (fun _ _ => sq_nonneg _))
      (cyclic_probability_unit_energy_bound p hp hmass) hH
      (show 0 ≤ (2 : ℝ) ^ (-a * (J : ℝ)) * H by positivity)
      (show 0 ≤ 2 * v by positivity) hG hGS hsmall hlow (by
        intro n hn
        have hflatn := hflat J hj₀ p (finiteDyadicLevel w n) hp hmass hnorm hspread'
          (hlevels n hn).1 (hlevelspread n hn)
        simpa only [E, H, mul_assoc, mul_left_comm, mul_comm] using hflatn)
    calc
      _ ≤ 2 * ((2 : ℝ) ^ (-a * (J : ℝ)) * H) +
          ((2 : ℝ) ^ (-(η / 2) * (J : ℝ)) + 2 * v * Fintype.card (ZMod (2 ^ J))ˣ) * H := hh
      _ ≤ 2 * ((2 : ℝ) ^ (-a * (J : ℝ)) * H) +
          ((2 : ℝ) ^ (-(η / 2) * (J : ℝ)) + 2 * (2 : ℝ) ^ (-(J : ℝ))) * H := by
        exact add_le_add le_rfl (mul_le_mul_of_nonneg_right (add_le_add le_rfl htail) hH)
      _ = _ := by ring
  have h5 : (5 : ℝ) ≤ (2 : ℝ) ^ ((b / 2) * (J : ℝ)) := by
    have hh := hJ₃ J hj₃
    norm_num at hh
    exact (by norm_num : (5 : ℝ) ≤ 8).trans hh
  have hcoef : 2 * (2 : ℝ) ^ (-a * (J : ℝ)) + (2 : ℝ) ^ (-(η / 2) * (J : ℝ)) +
      2 * (2 : ℝ) ^ (-(J : ℝ)) ≤ (2 : ℝ) ^ (-(b / 2) * (J : ℝ)) := by
    have hpow : ∀ c : ℝ, b ≤ c → (2 : ℝ) ^ (-c * (J : ℝ)) ≤ (2 : ℝ) ^ (-b * (J : ℝ)) := by
      intro c hc
      apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
      have hh := mul_le_mul_of_nonneg_right hc hJ0
      linarith only [hh]
    have hpow1 : (2 : ℝ) ^ (-(J : ℝ)) ≤ (2 : ℝ) ^ (-b * (J : ℝ)) := by
      simpa using hpow 1 hb1
    calc
      _ ≤ 5 * (2 : ℝ) ^ (-b * (J : ℝ)) := by
        linarith only [hpow a hba, hpow (η / 2) hbη, hpow1]
      _ ≤ (2 : ℝ) ^ ((b / 2) * (J : ℝ)) * (2 : ℝ) ^ (-b * (J : ℝ)) :=
        mul_le_mul_of_nonneg_right h5 (by positivity)
      _ = _ := by rw [← Real.rpow_add (by norm_num)]; congr 1; ring
  exact hmain.trans (mul_le_mul_of_nonneg_right hcoef hH)



theorem finite_pushforward_equivariant {X Y : Type*} [Fintype X] [DecidableEq Y]
    (p : X → ℝ) (π : X → Y) (e : X ≃ X) (σ : Y ≃ Y)
    (hπ : ∀ x, π (e x) = σ (π x)) (r : Y) :
    finitePushforward (fun x => p (e x)) π r = finitePushforward p π (σ r) := by
  classical
  unfold finitePushforward
  simp only [Finset.sum_filter]
  apply Fintype.sum_equiv e
  intro x
  rw [hπ]
  simp only [Equiv.apply_eq_iff_eq]

theorem finite_pushforward_unit_dilate {R Q : Type*} [Ring R] [Ring Q]
    [Fintype R] [DecidableEq Q] (p : R → ℝ) (π : R →+* Q) (u : Rˣ) (r : Q) :
    finitePushforward (fun x => p ((u : R) * x)) π r =
      finitePushforward p π (π (u : R) * r) := by
  let v : Qˣ := Units.map π.toMonoidHom u
  exact finite_pushforward_equivariant p π (ringUnitMulAddEquiv u).toEquiv
    (ringUnitMulAddEquiv v).toEquiv (fun x => by simp [ringUnitMulAddEquiv, v]) r

theorem finite_pushforward_unit_translate {R Q : Type*} [Ring R] [Ring Q]
    [Fintype Rˣ] [DecidableEq Q] (w : Rˣ → ℝ) (π : R →+* Q) (u : Rˣ) (r : Q) :
    finitePushforward (fun v : Rˣ => w (u * v)) (fun v : Rˣ => π (v : R)) r =
      finitePushforward w (fun v : Rˣ => π (v : R)) (π (u : R) * r) := by
  let v : Qˣ := Units.map π.toMonoidHom u
  exact finite_pushforward_equivariant w (fun z : Rˣ => π (z : R)) (Equiv.mulLeft u)
    (ringUnitMulAddEquiv v).toEquiv (fun x => by simp [ringUnitMulAddEquiv, v]) r

theorem dyadic_probability_nonconcentration_unit_dilate {J : ℕ} {γ ε : ℝ}
    {p : ZMod (2 ^ J) → ℝ} (hp : DyadicProbabilityNonconcentration γ ε p)
    (u : (ZMod (2 ^ J))ˣ) :
    DyadicProbabilityNonconcentration γ ε (fun x => p ((u : ZMod (2 ^ J)) * x)) := by
  intro L hL hεL r
  let π : ZMod (2 ^ J) →+* ZMod (2 ^ L) := ZMod.castHom (pow_dvd_pow 2 hL) _
  have hπ : ∀ x : ZMod (2 ^ J), π x = (x.val : ZMod (2 ^ L)) := by
    intro x
    exact ZMod.cast_eq_val _
  change finitePushforward _ (fun x : ZMod (2 ^ J) => (x.val : ZMod (2 ^ L))) r ≤ _
  simp only [← hπ]
  rw [finite_pushforward_unit_dilate]
  simpa only [finitePushforward, hπ] using hp L hL hεL (π (u : ZMod (2 ^ J)) * r)

theorem dyadic_unit_probability_nonconcentration_translate {J : ℕ} {γ ε : ℝ}
    {w : (ZMod (2 ^ J))ˣ → ℝ} (hw : DyadicUnitProbabilityNonconcentration γ ε w)
    (u : (ZMod (2 ^ J))ˣ) :
    DyadicUnitProbabilityNonconcentration γ ε (fun v => w (u * v)) := by
  intro L hL hεL r
  let π : ZMod (2 ^ J) →+* ZMod (2 ^ L) := ZMod.castHom (pow_dvd_pow 2 hL) _
  have hπ : ∀ x : ZMod (2 ^ J), π x = (x.val : ZMod (2 ^ L)) := by
    intro x
    exact ZMod.cast_eq_val _
  change finitePushforward _ (fun v : (ZMod (2 ^ J))ˣ => ((v : ZMod (2 ^ J)).val : ZMod (2 ^ L))) r ≤ _
  simp only [← hπ]
  rw [finite_pushforward_unit_translate]
  simpa only [finitePushforward, hπ] using hw L hL hεL (π (u : ZMod (2 ^ J)) * r)

theorem finite_pushforward_linear_combination {X Y I : Type*} [Fintype X] [Fintype I]
    [DecidableEq Y] (w : I → ℝ) (F : I → X → ℝ) (π : X → Y) (r : Y) :
    finitePushforward (fun x => ∑ i : I, w i * F i x) π r =
      ∑ i : I, w i * finitePushforward (F i) π r := by
  unfold finitePushforward
  rw [Finset.sum_comm]
  simp only [Finset.mul_sum]

theorem cyclic_mixture_norm_of_nonnegative {I : Type*} [Fintype I] {q : ℕ} [NeZero q]
    (w : I → ℝ) (F : I → ZMod q → ℂ) (hw : ∀ i, 0 ≤ w i)
    (hF : ∀ i x, F i x = (‖F i x‖ : ℂ)) (x : ZMod q) :
    ‖cyclicMixture w F x‖ = ∑ i : I, w i * ‖F i x‖ := by
  have heq : cyclicMixture w F x = ((∑ i : I, w i * ‖F i x‖ : ℝ) : ℂ) := by
    unfold cyclicMixture
    rw [Complex.ofReal_sum]
    apply Finset.sum_congr rfl
    intro i hi
    rw [Complex.ofReal_mul]
    exact congrArg (fun z : ℂ => (w i : ℂ) * z) (hF i x)
  rw [heq]
  exact Complex.norm_of_nonneg (Finset.sum_nonneg (fun i _ => mul_nonneg (hw i) (norm_nonneg _)))

theorem dyadic_probability_nonconcentration_mixture {I : Type*} [Fintype I]
    {J : ℕ} {γ ε : ℝ} (w : I → ℝ) (F : I → ZMod (2 ^ J) → ℂ)
    (hw : ∀ i, 0 ≤ w i) (hmass : ∑ i : I, w i = 1)
    (hF : ∀ i x, F i x = (‖F i x‖ : ℂ))
    (hspread : ∀ i, DyadicProbabilityNonconcentration γ ε (fun x => ‖F i x‖)) :
    DyadicProbabilityNonconcentration γ ε (fun x => ‖cyclicMixture w F x‖) := by
  intro L hL hεL r
  simp only [cyclic_mixture_norm_of_nonnegative w F hw hF]
  change finitePushforward _ (fun x : ZMod (2 ^ J) => (x.val : ZMod (2 ^ L))) r ≤ _
  rw [finite_pushforward_linear_combination]
  calc
    _ ≤ ∑ i : I, w i * (2 : ℝ) ^ (-γ * (L : ℝ)) :=
      Finset.sum_le_sum (fun i _ => mul_le_mul_of_nonneg_left (hspread i L hL hεL r) (hw i))
    _ = _ := by rw [← Finset.sum_mul, hmass, one_mul]

theorem cyclic_convolution_norm_le_peak {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) {M : ℝ} (hpeak : ∀ x, ‖f x‖ ≤ M) (x : ZMod q) :
    ‖cyclicConvolution f g x‖ ≤ M * ∑ y : ZMod q, ‖g y‖ := by
  rw [cyclic_convolution_comm]
  calc
    _ ≤ ∑ y : ZMod q, ‖g y * f (x - y)‖ := norm_sum_le _ _
    _ ≤ ∑ y : ZMod q, M * ‖g y‖ := by
      apply Finset.sum_le_sum
      intro y hy
      rw [norm_mul, mul_comm]
      exact mul_le_mul_of_nonneg_right (hpeak (x - y)) (norm_nonneg _)
    _ = _ := (Finset.mul_sum _ _ _).symm

theorem cyclic_probability_convolution_fiber_bound {Q q : ℕ} [NeZero Q] [NeZero q]
    {f g : ZMod Q → ℂ} (hf : FiniteComplexProbability f) (hg : FiniteComplexProbability g)
    (π : ZMod Q →+ ZMod q) {M : ℝ}
    (hpeak : ∀ r : ZMod q, finitePushforward (fun x => ‖f x‖) π r ≤ M) (r : ZMod q) :
    finitePushforward (fun x => ‖cyclicConvolution f g x‖) π r ≤ M := by
  rw [← norm_cyclicPushforward_of_probability (cyclicConvolution_probability hf hg),
    cyclicPushforward_convolution]
  have hpeak' : ∀ x, ‖cyclicPushforward f π x‖ ≤ M := by
    intro x
    rw [norm_cyclicPushforward_of_probability hf]
    exact hpeak x
  have hh := cyclic_convolution_norm_le_peak (cyclicPushforward f π) (cyclicPushforward g π) hpeak' r
  simpa only [finite_complex_probability_sum_norm (cyclicPushforward_probability hg π), mul_one] using hh

theorem dyadic_probability_nonconcentration_convolution {J : ℕ} {γ ε : ℝ}
    {f g : ZMod (2 ^ J) → ℂ} (hf : FiniteComplexProbability f) (hg : FiniteComplexProbability g)
    (hspread : DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖)) :
    DyadicProbabilityNonconcentration γ ε (fun x => ‖cyclicConvolution f g x‖) := by
  intro L hL hεL r
  let π : ZMod (2 ^ J) →+* ZMod (2 ^ L) := ZMod.castHom (pow_dvd_pow 2 hL) _
  have hπ : ∀ x : ZMod (2 ^ J), π x = (x.val : ZMod (2 ^ L)) := by
    intro x
    exact ZMod.cast_eq_val _
  have hπadd : ∀ x : ZMod (2 ^ J), π.toAddMonoidHom x = (x.val : ZMod (2 ^ L)) := hπ
  have hh := cyclic_probability_convolution_fiber_bound hf hg π.toAddMonoidHom
    (M := (2 : ℝ) ^ (-γ * (L : ℝ))) (by
      intro r
      simpa only [finitePushforward, hπadd] using hspread L hL hεL r) r
  simpa only [finitePushforward, hπadd] using hh

theorem cyclic_unit_dilate_probability {q : ℕ} [NeZero q] {f : ZMod q → ℂ}
    (hf : FiniteComplexProbability f) (u : (ZMod q)ˣ) :
    FiniteComplexProbability (cyclicUnitDilate f u) := by
  refine ⟨fun x => hf.norm_cast _, ?_⟩
  calc
    _ = ∑ x : ZMod q, f x := Fintype.sum_equiv (ringUnitMulAddEquiv u⁻¹).toEquiv _ _ (fun _ => rfl)
    _ = 1 := hf.sum_eq_one

theorem dyadic_probability_nonconcentration_cyclic_unit_dilate {J : ℕ} {γ ε : ℝ}
    {f : ZMod (2 ^ J) → ℂ}
    (hf : DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖))
    (u : (ZMod (2 ^ J))ˣ) :
    DyadicProbabilityNonconcentration γ ε (fun x => ‖cyclicUnitDilate f u x‖) :=
  dyadic_probability_nonconcentration_unit_dilate hf u⁻¹

theorem cyclic_mixture_energy_le {I : Type*} [Fintype I] {q : ℕ} [NeZero q]
    (w : I → ℝ) (F : I → ZMod q → ℂ) (hw : ∀ i, 0 ≤ w i)
    (hmass : ∑ i : I, w i = 1) :
    (∑ x : ZMod q, ‖cyclicMixture w F x‖ ^ 2) ≤
      ∑ i : I, w i * ∑ x : ZMod q, ‖F i x‖ ^ 2 := by
  have hx : ∀ x : ZMod q, ‖cyclicMixture w F x‖ ^ 2 ≤ ∑ i : I, w i * ‖F i x‖ ^ 2 := by
    intro x
    have hnorm : ‖cyclicMixture w F x‖ ≤ ∑ i : I, w i * ‖F i x‖ := by
      calc
        _ ≤ ∑ i : I, ‖(w i : ℂ) * F i x‖ := norm_sum_le _ _
        _ = _ := by
          apply Finset.sum_congr rfl
          intro i hi
          rw [norm_mul, Complex.norm_of_nonneg (hw i)]
    exact (pow_le_pow_left₀ (norm_nonneg _) hnorm 2).trans
      (weighted_sum_sq_le Finset.univ w (fun i => ‖F i x‖) (fun i _ => hw i) hmass)
  calc
    _ ≤ ∑ x : ZMod q, ∑ i : I, w i * ‖F i x‖ ^ 2 := Finset.sum_le_sum (fun x _ => hx x)
    _ = _ := by rw [Finset.sum_comm]; simp only [Finset.mul_sum]

theorem cyclic_convolution_mixture_left {I : Type*} [Fintype I] {q : ℕ} [NeZero q]
    (w : I → ℝ) (F : I → ZMod q → ℂ) (g : ZMod q → ℂ) :
    cyclicConvolution (cyclicMixture w F) g = cyclicMixture w (fun i => cyclicConvolution (F i) g) := by
  funext x
  unfold cyclicConvolution cyclicMixture
  simp only [Finset.sum_mul, Finset.mul_sum]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro i hi
  apply Finset.sum_congr rfl
  intro y hy
  ring

theorem cyclic_convolution_mixture_right {I : Type*} [Fintype I] {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : I → ℝ) (G : I → ZMod q → ℂ) :
    cyclicConvolution f (cyclicMixture w G) = cyclicMixture w (fun i => cyclicConvolution f (G i)) := by
  rw [cyclic_convolution_comm, cyclic_convolution_mixture_left]
  congr 1
  funext i
  exact cyclic_convolution_comm _ _

theorem cyclic_convolution_mixture_energy_le {I K : Type*} [Fintype I] [Fintype K]
    {q : ℕ} [NeZero q] (w : I → ℝ) (v : K → ℝ)
    (F : I → ZMod q → ℂ) (G : K → ZMod q → ℂ)
    (hw : ∀ i, 0 ≤ w i) (hwmass : ∑ i : I, w i = 1)
    (hv : ∀ k, 0 ≤ v k) (hvmass : ∑ k : K, v k = 1) :
    (∑ x : ZMod q, ‖cyclicConvolution (cyclicMixture w F) (cyclicMixture v G) x‖ ^ 2) ≤
      ∑ i : I, w i * ∑ k : K, v k * ∑ x : ZMod q, ‖cyclicConvolution (F i) (G k) x‖ ^ 2 := by
  rw [cyclic_convolution_mixture_left]
  apply (cyclic_mixture_energy_le w _ hw hwmass).trans
  apply Finset.sum_le_sum
  intro i hi
  apply mul_le_mul_of_nonneg_left _ (hw i)
  rw [cyclic_convolution_mixture_right]
  exact cyclic_mixture_energy_le v _ hv hvmass

theorem cyclic_unit_dilate_mul {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (u v : (ZMod q)ˣ) :
    cyclicUnitDilate (cyclicUnitDilate f v) u = cyclicUnitDilate f (u * v) := by
  funext x
  simp only [cyclicUnitDilate, mul_inv_rev, Units.val_mul, mul_assoc]

theorem cyclic_unit_dilate_convolution {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) (u : (ZMod q)ˣ) :
    cyclicConvolution (cyclicUnitDilate f u) (cyclicUnitDilate g u) =
      cyclicUnitDilate (cyclicConvolution f g) u := by
  funext x
  unfold cyclicConvolution cyclicUnitDilate
  apply Fintype.sum_equiv (ringUnitMulAddEquiv u⁻¹).toEquiv
  intro y
  change f ((u⁻¹ : (ZMod q)ˣ) * y) * g ((u⁻¹ : (ZMod q)ˣ) * (x - y)) =
    f ((u⁻¹ : (ZMod q)ˣ) * y) * g ((u⁻¹ : (ZMod q)ˣ) * x - (u⁻¹ : (ZMod q)ˣ) * y)
  rw [mul_sub]

theorem cyclic_unit_pair_convolution_energy {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) (u v : (ZMod q)ˣ) :
    (∑ x : ZMod q, ‖cyclicConvolution (cyclicUnitDilate f u) (cyclicUnitDilate g v) x‖ ^ 2) =
      ∑ x : ZMod q, ‖cyclicConvolution f (cyclicUnitDilate g (u⁻¹ * v)) x‖ ^ 2 := by
  have hrel : cyclicUnitDilate (cyclicUnitDilate g (u⁻¹ * v)) u = cyclicUnitDilate g v := by
    rw [cyclic_unit_dilate_mul, mul_inv_cancel_left]
  rw [← hrel, cyclic_unit_dilate_convolution, cyclic_unit_dilate_sq_norm]

/-- One probability step: average unit dilations, then add two independent
samples from that averaged law. -/
noncomputable def cyclicUnitAveragingStep {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ) : ZMod q → ℂ :=
  cyclicConvolution (cyclicMixture w (cyclicUnitDilate f)) (cyclicMixture w (cyclicUnitDilate f))

theorem cyclic_unit_averaging_step_probability {q : ℕ} [NeZero q] {f : ZMod q → ℂ}
    (hf : FiniteComplexProbability f) (w : (ZMod q)ˣ → ℝ)
    (hw : ∀ u, 0 ≤ w u) (hmass : ∑ u : (ZMod q)ˣ, w u = 1) :
    FiniteComplexProbability (cyclicUnitAveragingStep f w) := by
  have hmix := cyclicMixture_probability w (cyclicUnitDilate f) hw hmass
    (cyclic_unit_dilate_probability hf)
  exact cyclicConvolution_probability hmix hmix

theorem dyadic_probability_nonconcentration_averaging_step {J : ℕ} {γ ε : ℝ}
    {f : ZMod (2 ^ J) → ℂ} (hf : FiniteComplexProbability f)
    (hspread : DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖))
    (w : (ZMod (2 ^ J))ˣ → ℝ) (hw : ∀ u, 0 ≤ w u) (hmass : ∑ u : (ZMod (2 ^ J))ˣ, w u = 1) :
    DyadicProbabilityNonconcentration γ ε (fun x => ‖cyclicUnitAveragingStep f w x‖) := by
  have hmix := cyclicMixture_probability w (cyclicUnitDilate f) hw hmass
    (cyclic_unit_dilate_probability hf)
  exact dyadic_probability_nonconcentration_convolution hmix hmix
    (dyadic_probability_nonconcentration_mixture w (cyclicUnitDilate f) hw hmass
      (fun u => (cyclic_unit_dilate_probability hf u).norm_cast)
      (dyadic_probability_nonconcentration_cyclic_unit_dilate hspread))

theorem cyclic_unit_averaging_step_energy_le {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ)
    (hw : ∀ u, 0 ≤ w u) (hmass : ∑ u : (ZMod q)ˣ, w u = 1) :
    (∑ x : ZMod q, ‖cyclicUnitAveragingStep f w x‖ ^ 2) ≤
      ∑ u : (ZMod q)ˣ, w u * ∑ v : (ZMod q)ˣ, w v *
        ∑ x : ZMod q, ‖cyclicConvolution f (cyclicUnitDilate f (u⁻¹ * v)) x‖ ^ 2 := by
  have hh := cyclic_convolution_mixture_energy_le w w (cyclicUnitDilate f) (cyclicUnitDilate f)
    hw hmass hw hmass
  simpa only [cyclicUnitAveragingStep, cyclic_unit_pair_convolution_energy] using hh

theorem cyclic_unit_averaging_step_energy_mono {q : ℕ} [NeZero q]
    {f : ZMod q → ℂ} (hf : FiniteComplexProbability f) (w : (ZMod q)ˣ → ℝ)
    (hw : ∀ u, 0 ≤ w u) (hmass : ∑ u : (ZMod q)ˣ, w u = 1) :
    (∑ x : ZMod q, ‖cyclicUnitAveragingStep f w x‖ ^ 2) ≤ ∑ x : ZMod q, ‖f x‖ ^ 2 := by
  let θ := cyclicMixture w (cyclicUnitDilate f)
  have hθ := cyclicMixture_probability w (cyclicUnitDilate f) hw hmass
    (cyclic_unit_dilate_probability hf)
  have hconv := cyclic_convolution_young_sq θ θ
  rw [finite_complex_probability_sum_norm hθ, one_pow, one_mul] at hconv
  have hmix := cyclic_mixture_energy_le w (cyclicUnitDilate f) hw hmass
  simp only [cyclic_unit_dilate_sq_norm, ← Finset.sum_mul, hmass, one_mul] at hmix
  exact hconv.trans hmix

theorem exists_dyadic_averaging_step_flattening {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ τ ε : ℝ, 0 < τ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ f : ZMod (2 ^ J) → ℂ,
      ∀ w : (ZMod (2 ^ J))ˣ → ℝ,
        FiniteComplexProbability f →
        (2 : ℝ) ^ (-(1 - δ) * (J : ℝ)) ≤ (∑ x : ZMod (2 ^ J), ‖f x‖ ^ 2) →
        DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖) →
        (∀ u, 0 ≤ w u) → (∑ u : (ZMod (2 ^ J))ˣ, w u) = 1 →
        DyadicUnitProbabilityNonconcentration γ ε w →
        (∑ x : ZMod (2 ^ J), ‖cyclicUnitAveragingStep f w x‖ ^ 2) ≤
          (2 : ℝ) ^ (-τ * (J : ℝ)) * ∑ x : ZMod (2 ^ J), ‖f x‖ ^ 2 := by
  classical
  obtain ⟨τ, ε, hτ, hε, hε4, J₀, hflat⟩ := exists_dyadic_weighted_probability_flattening hγ hδ hδ1
  refine ⟨τ, ε, hτ, hε, hε4, J₀, ?_⟩
  intro J hJ f w hf hnorm hspread hw hmass hwspread
  have hfreal : (fun x : ZMod (2 ^ J) => (‖f x‖ : ℂ)) = f := funext (fun x => (hf.norm_cast x).symm)
  have hu : ∀ u : (ZMod (2 ^ J))ˣ,
      (∑ v : (ZMod (2 ^ J))ˣ, w v * ∑ x : ZMod (2 ^ J),
        ‖cyclicConvolution f (cyclicUnitDilate f (u⁻¹ * v)) x‖ ^ 2) ≤
          (2 : ℝ) ^ (-τ * (J : ℝ)) * ∑ x : ZMod (2 ^ J), ‖f x‖ ^ 2 := by
    intro u
    have hmassu : (∑ v : (ZMod (2 ^ J))ˣ, w (u * v)) = 1 := by
      calc
        _ = ∑ v : (ZMod (2 ^ J))ˣ, w v := Fintype.sum_equiv (Equiv.mulLeft u) _ _ (fun _ => rfl)
        _ = 1 := hmass
    have hh := hflat J hJ (fun x => ‖f x‖) (fun v => w (u * v)) (fun x => norm_nonneg _)
      (finite_complex_probability_sum_norm hf).le hnorm hspread (fun v => hw (u * v)) hmassu.le
      (dyadic_unit_probability_nonconcentration_translate hwspread u)
    rw [hfreal] at hh
    have heq : (∑ v : (ZMod (2 ^ J))ˣ, w (u * v) * ∑ x : ZMod (2 ^ J),
        ‖cyclicConvolution f (cyclicUnitDilate f v) x‖ ^ 2) =
        ∑ v : (ZMod (2 ^ J))ˣ, w v * ∑ x : ZMod (2 ^ J),
          ‖cyclicConvolution f (cyclicUnitDilate f (u⁻¹ * v)) x‖ ^ 2 := by
      apply Fintype.sum_equiv (Equiv.mulLeft u)
      intro v
      change w (u * v) * (∑ x : ZMod (2 ^ J), ‖cyclicConvolution f (cyclicUnitDilate f v) x‖ ^ 2) =
        w (u * v) * ∑ x : ZMod (2 ^ J), ‖cyclicConvolution f (cyclicUnitDilate f (u⁻¹ * (u * v))) x‖ ^ 2
      rw [inv_mul_cancel_left]
    rwa [heq] at hh
  calc
    _ ≤ ∑ u : (ZMod (2 ^ J))ˣ, w u * ∑ v : (ZMod (2 ^ J))ˣ, w v *
        ∑ x : ZMod (2 ^ J), ‖cyclicConvolution f (cyclicUnitDilate f (u⁻¹ * v)) x‖ ^ 2 :=
      cyclic_unit_averaging_step_energy_le f w hw hmass
    _ ≤ ∑ u : (ZMod (2 ^ J))ˣ, w u *
        ((2 : ℝ) ^ (-τ * (J : ℝ)) * ∑ x : ZMod (2 ^ J), ‖f x‖ ^ 2) :=
      Finset.sum_le_sum (fun u _ => mul_le_mul_of_nonneg_left (hu u) (hw u))
    _ = _ := by rw [← Finset.sum_mul, hmass, one_mul]

theorem exists_dyadic_averaging_step_energy_bound {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ τ ε : ℝ, 0 < τ ∧ 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ f : ZMod (2 ^ J) → ℂ,
      ∀ w : (ZMod (2 ^ J))ˣ → ℝ,
        FiniteComplexProbability f →
        DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖) →
        (∀ u, 0 ≤ w u) → (∑ u : (ZMod (2 ^ J))ˣ, w u) = 1 →
        DyadicUnitProbabilityNonconcentration γ ε w →
        (∑ x : ZMod (2 ^ J), ‖cyclicUnitAveragingStep f w x‖ ^ 2) ≤
          max ((2 : ℝ) ^ (-(1 - δ) * (J : ℝ)))
            ((2 : ℝ) ^ (-τ * (J : ℝ)) * ∑ x : ZMod (2 ^ J), ‖f x‖ ^ 2) := by
  obtain ⟨τ, ε, hτ, hε, hε4, J₀, hflat⟩ := exists_dyadic_averaging_step_flattening hγ hδ hδ1
  refine ⟨τ, ε, hτ, hε, hε4, J₀, ?_⟩
  intro J hJ f w hf hspread hw hmass hwspread
  by_cases hnorm : (2 : ℝ) ^ (-(1 - δ) * (J : ℝ)) ≤ ∑ x : ZMod (2 ^ J), ‖f x‖ ^ 2
  · exact (hflat J hJ f w hf hnorm hspread hw hmass hwspread).trans (le_max_right _ _)
  · exact (cyclic_unit_averaging_step_energy_mono hf w hw hmass).trans
      ((lt_of_not_ge hnorm).le.trans (le_max_left _ _))

theorem finite_complex_probability_sq_norm_le_one {X : Type*} [Fintype X]
    {f : X → ℂ} (hf : FiniteComplexProbability f) : (∑ x : X, ‖f x‖ ^ 2) ≤ 1 := by
  have hh := Finset.sum_sq_le_sq_sum_of_nonneg (s := (Finset.univ : Finset X))
    (f := fun x => ‖f x‖) (fun _ _ => norm_nonneg _)
  simpa only [finite_complex_probability_sum_norm hf, one_pow] using hh

theorem finite_contractive_iteration {R : ℕ} (E : ℕ → ℝ) {M c : ℝ}
    (hM : 0 ≤ M) (hc : 0 ≤ c) (hc1 : c ≤ 1) (hbase : E 0 ≤ 1)
    (hstep : ∀ n < R, E (n + 1) ≤ max M (c * E n)) :
    ∀ n ≤ R, E n ≤ max M (c ^ n) := by
  intro n
  induction n with
  | zero =>
    intro hn
    exact hbase.trans (by simpa using le_max_right M (1 : ℝ))
  | succ n ih =>
    intro hn
    apply (hstep n (by omega)).trans
    apply max_le (le_max_left _ _)
    calc
      c * E n ≤ c * max M (c ^ n) := mul_le_mul_of_nonneg_left (ih (by omega)) hc
      _ = max (c * M) (c ^ (n + 1)) := by rw [mul_max_of_nonneg _ _ hc, pow_succ']
      _ ≤ max M (c ^ (n + 1)) := max_le_max
        (by simpa only [one_mul] using mul_le_mul_of_nonneg_right hc1 hM) le_rfl

noncomputable def cyclicUnitAveragingIter {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : ℕ → (ZMod q)ˣ → ℝ) : ℕ → ZMod q → ℂ
  | 0 => f
  | n + 1 => cyclicUnitAveragingStep (cyclicUnitAveragingIter f w n) (w n)

theorem cyclic_unit_averaging_iter_probability {q R : ℕ} [NeZero q]
    {f : ZMod q → ℂ} (hf : FiniteComplexProbability f) (w : ℕ → (ZMod q)ˣ → ℝ)
    (hw : ∀ n < R, ∀ u, 0 ≤ w n u) (hmass : ∀ n < R, ∑ u : (ZMod q)ˣ, w n u = 1) :
    ∀ n ≤ R, FiniteComplexProbability (cyclicUnitAveragingIter f w n) := by
  intro n
  induction n with
  | zero => intro hn; exact hf
  | succ n ih =>
    intro hn
    exact cyclic_unit_averaging_step_probability (ih (by omega)) (w n) (hw n (by omega)) (hmass n (by omega))

theorem dyadic_probability_nonconcentration_averaging_iter {J R : ℕ} {γ ε : ℝ}
    {f : ZMod (2 ^ J) → ℂ} (hf : FiniteComplexProbability f)
    (hspread : DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖))
    (w : ℕ → (ZMod (2 ^ J))ˣ → ℝ)
    (hw : ∀ n < R, ∀ u, 0 ≤ w n u) (hmass : ∀ n < R, ∑ u : (ZMod (2 ^ J))ˣ, w n u = 1) :
    ∀ n ≤ R, DyadicProbabilityNonconcentration γ ε (fun x => ‖cyclicUnitAveragingIter f w n x‖) := by
  intro n
  induction n with
  | zero => intro hn; exact hspread
  | succ n ih =>
    intro hn
    exact dyadic_probability_nonconcentration_averaging_step
      (cyclic_unit_averaging_iter_probability hf w hw hmass n (by omega)) (ih (by omega))
      (w n) (hw n (by omega)) (hmass n (by omega))

/-- A fixed number of independent unit-averaging steps reaches the density
threshold. The number of steps and residue cutoff are uniform in the modulus. -/
theorem exists_dyadic_probability_flattening_iteration {γ δ : ℝ}
    (hγ : 0 < γ) (hδ : 0 < δ) (hδ1 : δ ≤ 1) :
    ∃ ε : ℝ, 0 < ε ∧ ε ≤ 1 / 4 ∧ ∃ R : ℕ, 0 < R ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ f : ZMod (2 ^ J) → ℂ,
      ∀ w : ℕ → (ZMod (2 ^ J))ˣ → ℝ,
        FiniteComplexProbability f →
        DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖) →
        (∀ n < R, ∀ u, 0 ≤ w n u) →
        (∀ n < R, (∑ u : (ZMod (2 ^ J))ˣ, w n u) = 1) →
        (∀ n < R, DyadicUnitProbabilityNonconcentration γ ε (w n)) →
        (∑ x : ZMod (2 ^ J), ‖cyclicUnitAveragingIter f w R x‖ ^ 2) ≤
          (2 : ℝ) ^ (-(1 - δ) * (J : ℝ)) := by
  obtain ⟨τ, ε, hτ, hε, hε4, J₀, hstep⟩ := exists_dyadic_averaging_step_energy_bound hγ hδ hδ1
  obtain ⟨R, hR⟩ := exists_nat_gt (1 / τ)
  have hRτ : 1 ≤ (R : ℝ) * τ := ((div_lt_iff₀ hτ).mp hR).le
  have hR0 : 0 < R := by
    by_contra hn
    have heq : R = 0 := by omega
    subst R
    norm_num at hRτ
  refine ⟨ε, hε, hε4, R, hR0, J₀, ?_⟩
  intro J hJ f w hf hspread hw hmass hwspread
  let M := (2 : ℝ) ^ (-(1 - δ) * (J : ℝ))
  let c := (2 : ℝ) ^ (-τ * (J : ℝ))
  let E := fun n : ℕ => ∑ x : ZMod (2 ^ J), ‖cyclicUnitAveragingIter f w n x‖ ^ 2
  have hc : 0 ≤ c := by positivity
  have hc1 : c ≤ 1 := by
    calc
      _ ≤ (2 : ℝ) ^ (0 : ℝ) := by
        apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
        nlinarith only [mul_nonneg hτ.le (Nat.cast_nonneg J : (0 : ℝ) ≤ J)]
      _ = 1 := Real.rpow_zero _
  have hE : E R ≤ max M (c ^ R) := by
    apply finite_contractive_iteration E (by positivity) hc hc1 (finite_complex_probability_sq_norm_le_one hf)
      (fun n hn => hstep J hJ (cyclicUnitAveragingIter f w n) (w n)
        (cyclic_unit_averaging_iter_probability hf w hw hmass n hn.le)
        (dyadic_probability_nonconcentration_averaging_iter hf hspread w hw hmass n hn.le)
        (hw n hn) (hmass n hn) (hwspread n hn)) R le_rfl
  have hcR : c ^ R ≤ M := by
    dsimp only [c, M]
    rw [← Real.rpow_mul_natCast (by norm_num)]
    apply Real.rpow_le_rpow_of_exponent_le (by norm_num)
    have hJ0 : (0 : ℝ) ≤ J := Nat.cast_nonneg _
    have hRτJ := mul_le_mul_of_nonneg_right hRτ hJ0
    have hδJ := mul_nonneg hδ.le hJ0
    nlinarith only [hRτJ, hδJ]
  exact hE.trans (max_le le_rfl hcR)



theorem dft_cyclic_unit_dilate {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (u : (ZMod q)ˣ) (k : ZMod q) :
    ZMod.dft (cyclicUnitDilate f u) k = ZMod.dft f ((u : ZMod q) * k) := by
  simp only [ZMod.dft_apply, smul_eq_mul, cyclicUnitDilate]
  apply Fintype.sum_equiv (ringUnitMulAddEquiv u⁻¹).toEquiv
  intro x
  change ZMod.stdAddChar (-(x * k)) * f (((u⁻¹ : (ZMod q)ˣ) : ZMod q) * x) =
    ZMod.stdAddChar (-((((u⁻¹ : (ZMod q)ˣ) : ZMod q) * x) * ((u : ZMod q) * k))) *
      f (((u⁻¹ : (ZMod q)ˣ) : ZMod q) * x)
  have heq : (((u⁻¹ : (ZMod q)ˣ) : ZMod q) * x) * ((u : ZMod q) * k) = x * k := by
    calc
      _ = (((u⁻¹ : (ZMod q)ˣ) : ZMod q) * (u : ZMod q)) * (x * k) := by ring
      _ = _ := by rw [Units.inv_mul, one_mul]
  rw [heq]

theorem dft_cyclic_mixture {I : Type*} [Fintype I] {q : ℕ} [NeZero q]
    (w : I → ℝ) (F : I → ZMod q → ℂ) (k : ZMod q) :
    ZMod.dft (cyclicMixture w F) k = ∑ i : I, (w i : ℂ) * ZMod.dft (F i) k := by
  simp only [ZMod.dft_apply, smul_eq_mul, cyclicMixture, Finset.mul_sum]
  rw [Finset.sum_comm]
  apply Finset.sum_congr rfl
  intro i hi
  apply Finset.sum_congr rfl
  intro x hx
  ring

theorem norm_dft_cyclic_unit_mixture_le {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ) (hw : ∀ u, 0 ≤ w u) (k : ZMod q) :
    ‖ZMod.dft (cyclicMixture w (cyclicUnitDilate f)) k‖ ≤
      ∑ u : (ZMod q)ˣ, w u * ‖ZMod.dft f ((u : ZMod q) * k)‖ := by
  rw [dft_cyclic_mixture]
  calc
    _ ≤ ∑ u : (ZMod q)ˣ, ‖(w u : ℂ) * ZMod.dft (cyclicUnitDilate f u) k‖ := norm_sum_le _ _
    _ = _ := by
      apply Finset.sum_congr rfl
      intro u hu
      rw [norm_mul, Complex.norm_of_nonneg (hw u), dft_cyclic_unit_dilate]

theorem weighted_sum_two_power_le {I : Type*} [Fintype I]
    (w t : I → ℝ) (hw : ∀ i, 0 ≤ w i) (ht : ∀ i, 0 ≤ t i)
    (hmass : ∑ i : I, w i = 1) (n : ℕ) :
    (∑ i : I, w i * t i) ^ (2 ^ n) ≤ ∑ i : I, w i * t i ^ (2 ^ n) := by
  induction n with
  | zero => simp
  | succ n ih =>
    rw [pow_succ, pow_mul]
    calc
      _ ≤ (∑ i : I, w i * t i ^ (2 ^ n)) ^ 2 :=
        pow_le_pow_left₀ (pow_nonneg (Finset.sum_nonneg (fun i _ => mul_nonneg (hw i) (ht i))) _) ih 2
      _ ≤ ∑ i : I, w i * (t i ^ (2 ^ n)) ^ 2 :=
        weighted_sum_sq_le Finset.univ w (fun i => t i ^ (2 ^ n)) (fun i _ => hw i) hmass
      _ = _ := by simp only [pow_mul]

theorem norm_dft_unit_mixture_two_power_le {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ)
    (hw : ∀ u, 0 ≤ w u) (hmass : ∑ u : (ZMod q)ˣ, w u = 1)
    (n : ℕ) (k : ZMod q) :
    ‖ZMod.dft (cyclicMixture w (cyclicUnitDilate f)) k‖ ^ (2 ^ n) ≤
      ∑ u : (ZMod q)ˣ, w u * ‖ZMod.dft f ((u : ZMod q) * k)‖ ^ (2 ^ n) := by
  exact (pow_le_pow_left₀ (norm_nonneg _) (norm_dft_cyclic_unit_mixture_le f w hw k) _).trans
    (weighted_sum_two_power_le w (fun u => ‖ZMod.dft f ((u : ZMod q) * k)‖)
      hw (fun _ => norm_nonneg _) hmass n)

theorem dft_neg_of_real {q : ℕ} [NeZero q] (f : ZMod q → ℂ)
    (hf : ∀ x, f x = (‖f x‖ : ℂ)) (k : ZMod q) :
    ZMod.dft f (-k) = starRingEnd ℂ (ZMod.dft f k) := by
  have hconj : (fun x => starRingEnd ℂ (f x)) = f := by
    funext x
    rw [hf x]
    exact Complex.conj_ofReal _
  have hh := dft_conjugate f (-k)
  rwa [hconj, neg_neg] at hh

noncomputable def cyclicSymmetrize {q : ℕ} [NeZero q] (f : ZMod q → ℂ) : ZMod q → ℂ :=
  cyclicConvolution f (cyclicUnitDilate f (-1))

theorem dft_cyclic_symmetrize {q : ℕ} [NeZero q] (f : ZMod q → ℂ)
    (hf : ∀ x, f x = (‖f x‖ : ℂ)) (k : ZMod q) :
    ZMod.dft (cyclicSymmetrize f) k = (‖ZMod.dft f k‖ ^ 2 : ℝ) := by
  rw [cyclicSymmetrize, dft_cyclicConvolution, dft_cyclic_unit_dilate]
  simp only [Units.val_neg, Units.val_one, neg_one_mul]
  rw [dft_neg_of_real f hf]
  simpa only [Complex.ofReal_pow] using Complex.mul_conj' (ZMod.dft f k)

theorem cyclic_symmetrize_probability {q : ℕ} [NeZero q]
    {f : ZMod q → ℂ} (hf : FiniteComplexProbability f) :
    FiniteComplexProbability (cyclicSymmetrize f) :=
  cyclicConvolution_probability hf (cyclic_unit_dilate_probability hf (-1))

theorem dyadic_probability_nonconcentration_symmetrize {J : ℕ} {γ ε : ℝ}
    {f : ZMod (2 ^ J) → ℂ} (hf : FiniteComplexProbability f)
    (hspread : DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖)) :
    DyadicProbabilityNonconcentration γ ε (fun x => ‖cyclicSymmetrize f x‖) :=
  dyadic_probability_nonconcentration_convolution hf (cyclic_unit_dilate_probability hf (-1)) hspread

theorem dft_cyclic_symmetrize_nonnegative {q : ℕ} [NeZero q] (f : ZMod q → ℂ)
    (hf : ∀ x, f x = (‖f x‖ : ℂ)) (k : ZMod q) :
    ZMod.dft (cyclicSymmetrize f) k = (‖ZMod.dft (cyclicSymmetrize f) k‖ : ℂ) := by
  rw [dft_cyclic_symmetrize f hf, Complex.norm_of_nonneg (sq_nonneg _)]

theorem dft_unit_mixture_of_nonnegative_fourier {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ)
    (hf : ∀ k, ZMod.dft f k = (‖ZMod.dft f k‖ : ℂ)) (k : ZMod q) :
    ZMod.dft (cyclicMixture w (cyclicUnitDilate f)) k =
      ((∑ u : (ZMod q)ˣ, w u * ‖ZMod.dft f ((u : ZMod q) * k)‖ : ℝ) : ℂ) := by
  rw [dft_cyclic_mixture, Complex.ofReal_sum]
  apply Finset.sum_congr rfl
  intro u hu
  rw [dft_cyclic_unit_dilate, Complex.ofReal_mul]
  exact congrArg (fun z : ℂ => (w u : ℂ) * z) (hf ((u : ZMod q) * k))

theorem norm_dft_unit_mixture_of_nonnegative_fourier {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ) (hw : ∀ u, 0 ≤ w u)
    (hf : ∀ k, ZMod.dft f k = (‖ZMod.dft f k‖ : ℂ)) (k : ZMod q) :
    ‖ZMod.dft (cyclicMixture w (cyclicUnitDilate f)) k‖ =
      ∑ u : (ZMod q)ˣ, w u * ‖ZMod.dft f ((u : ZMod q) * k)‖ := by
  rw [dft_unit_mixture_of_nonnegative_fourier f w hf]
  exact Complex.norm_of_nonneg (Finset.sum_nonneg (fun u _ => mul_nonneg (hw u) (norm_nonneg _)))

theorem dft_unit_averaging_step_of_nonnegative_fourier {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ)
    (hf : ∀ k, ZMod.dft f k = (‖ZMod.dft f k‖ : ℂ)) (k : ZMod q) :
    ZMod.dft (cyclicUnitAveragingStep f w) k =
      (((∑ u : (ZMod q)ˣ, w u * ‖ZMod.dft f ((u : ZMod q) * k)‖) ^ 2 : ℝ) : ℂ) := by
  rw [cyclicUnitAveragingStep, dft_cyclicConvolution, dft_unit_mixture_of_nonnegative_fourier f w hf]
  push_cast
  ring

theorem norm_dft_unit_averaging_step_of_nonnegative_fourier {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ)
    (hf : ∀ k, ZMod.dft f k = (‖ZMod.dft f k‖ : ℂ)) (k : ZMod q) :
    ‖ZMod.dft (cyclicUnitAveragingStep f w) k‖ =
      (∑ u : (ZMod q)ˣ, w u * ‖ZMod.dft f ((u : ZMod q) * k)‖) ^ 2 := by
  rw [dft_unit_averaging_step_of_nonnegative_fourier f w hf, Complex.norm_of_nonneg (sq_nonneg _)]

theorem dft_unit_averaging_step_nonnegative {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ)
    (hf : ∀ k, ZMod.dft f k = (‖ZMod.dft f k‖ : ℂ)) (k : ZMod q) :
    ZMod.dft (cyclicUnitAveragingStep f w) k = (‖ZMod.dft (cyclicUnitAveragingStep f w) k‖ : ℂ) := by
  rw [dft_unit_averaging_step_of_nonnegative_fourier f w hf, Complex.norm_of_nonneg (sq_nonneg _)]

theorem dft_unit_averaging_iter_nonnegative {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : ℕ → (ZMod q)ˣ → ℝ)
    (hf : ∀ k, ZMod.dft f k = (‖ZMod.dft f k‖ : ℂ)) (n : ℕ) :
    ∀ k, ZMod.dft (cyclicUnitAveragingIter f w n) k =
      (‖ZMod.dft (cyclicUnitAveragingIter f w n) k‖ : ℂ) := by
  induction n with
  | zero => exact hf
  | succ n ih => exact dft_unit_averaging_step_nonnegative _ _ ih

noncomputable def cyclicUnitProductIter {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : ℕ → (ZMod q)ˣ → ℝ) : ℕ → ZMod q → ℂ
  | 0 => f
  | n + 1 => cyclicMixture (w n) (cyclicUnitDilate (cyclicUnitProductIter f w n))

theorem norm_dft_unit_product_dominated {q R : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : ℕ → (ZMod q)ˣ → ℝ)
    (hf : ∀ x, f x = (‖f x‖ : ℂ))
    (hw : ∀ n < R, ∀ u, 0 ≤ w n u) (hmass : ∀ n < R, ∑ u : (ZMod q)ˣ, w n u = 1) :
    ∀ n ≤ R, ∀ k : ZMod q,
      ‖ZMod.dft (cyclicUnitProductIter f w n) k‖ ^ (2 ^ (n + 1)) ≤
        ‖ZMod.dft (cyclicUnitAveragingIter (cyclicSymmetrize f) w n) k‖ := by
  intro n
  induction n with
  | zero =>
    intro hn k
    simp only [cyclicUnitProductIter, cyclicUnitAveragingIter, zero_add, pow_one,
      dft_cyclic_symmetrize f hf, Complex.norm_of_nonneg (sq_nonneg _)]
    exact le_rfl
  | succ n ih =>
    intro hn k
    let ν := cyclicUnitAveragingIter (cyclicSymmetrize f) w n
    have hν : ∀ k, ZMod.dft ν k = (‖ZMod.dft ν k‖ : ℂ) :=
      dft_unit_averaging_iter_nonnegative _ w (dft_cyclic_symmetrize_nonnegative f hf) n
    have hh : ‖ZMod.dft (cyclicUnitProductIter f w (n + 1)) k‖ ^ (2 ^ (n + 1)) ≤
        ∑ u : (ZMod q)ˣ, w n u * ‖ZMod.dft ν ((u : ZMod q) * k)‖ := by
      apply (norm_dft_unit_mixture_two_power_le (cyclicUnitProductIter f w n) (w n)
        (hw n (by omega)) (hmass n (by omega)) (n + 1) k).trans
      exact Finset.sum_le_sum (fun u _ => mul_le_mul_of_nonneg_left (ih (by omega) _) (hw n (by omega) u))
    change ‖ZMod.dft (cyclicUnitProductIter f w (n + 1)) k‖ ^ (2 ^ (n + 1 + 1)) ≤
      ‖ZMod.dft (cyclicUnitAveragingStep ν (w n)) k‖
    rw [norm_dft_unit_averaging_step_of_nonnegative_fourier ν (w n) hν, pow_succ, pow_mul]
    exact pow_le_pow_left₀ (pow_nonneg (norm_nonneg _) _) hh 2

theorem norm_dft_unit_product_final_power_le {q R : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : ℕ → (ZMod q)ˣ → ℝ)
    (hf : ∀ x, f x = (‖f x‖ : ℂ))
    (hw : ∀ n < R + 1, ∀ u, 0 ≤ w n u)
    (hmass : ∀ n < R + 1, ∑ u : (ZMod q)ˣ, w n u = 1) (k : ZMod q) :
    ‖ZMod.dft (cyclicUnitProductIter f w (R + 1)) k‖ ^ (2 ^ (R + 1)) ≤
      ‖ZMod.dft (cyclicMixture (w R)
        (cyclicUnitDilate (cyclicUnitAveragingIter (cyclicSymmetrize f) w R))) k‖ := by
  have hν := dft_unit_averaging_iter_nonnegative (cyclicSymmetrize f) w
    (dft_cyclic_symmetrize_nonnegative f hf) R
  rw [norm_dft_unit_mixture_of_nonnegative_fourier _ _ (hw R (by omega)) hν]
  apply (norm_dft_unit_mixture_two_power_le (cyclicUnitProductIter f w R) (w R)
    (hw R (by omega)) (hmass R (by omega)) (R + 1) k).trans
  apply Finset.sum_le_sum
  intro u hu
  apply mul_le_mul_of_nonneg_left _ (hw R (by omega) u)
  exact norm_dft_unit_product_dominated f w hf hw hmass R (by omega) _

theorem finite_sum_comp_le_of_injective {X Y : Type*} [Fintype X] [Fintype Y]
    (e : X → Y) (he : Function.Injective e) (F : Y → ℝ) (hF : ∀ y, 0 ≤ F y) :
    (∑ x : X, F (e x)) ≤ ∑ y : Y, F y := by
  classical
  calc
    _ = ∑ y ∈ (Finset.univ : Finset X).image e, F y := by
      symm
      exact Finset.sum_image (fun x _ y _ hxy => he hxy)
    _ ≤ _ := Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_univ _)
      (fun y _ _ => hF y)

theorem norm_dft_unit_mixture_sq_le {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (w : (ZMod q)ˣ → ℝ)
    (hw : ∀ u, 0 ≤ w u) (hmass : ∑ u : (ZMod q)ˣ, w u = 1)
    {M : ℝ} (hpeak : ∀ u, w u ≤ M) {k : ZMod q} (hk : IsUnit k) :
    ‖ZMod.dft (cyclicMixture w (cyclicUnitDilate f)) k‖ ^ 2 ≤
      (q : ℝ) * M * ∑ x : ZMod q, ‖f x‖ ^ 2 := by
  have hM : 0 ≤ M := (hw 1).trans (hpeak 1)
  have hwsq : (∑ u : (ZMod q)ˣ, w u ^ 2) ≤ M := by
    calc
      _ ≤ ∑ u : (ZMod q)ˣ, w u * M := Finset.sum_le_sum (fun u _ => by
        simpa only [pow_two] using mul_le_mul_of_nonneg_left (hpeak u) (hw u))
      _ = M := by rw [← Finset.sum_mul, hmass, one_mul]
  have hfsq : (∑ u : (ZMod q)ˣ, ‖ZMod.dft f ((u : ZMod q) * k)‖ ^ 2) ≤
      (q : ℝ) * ∑ x : ZMod q, ‖f x‖ ^ 2 := by
    obtain ⟨v, rfl⟩ := hk
    have hinj : Function.Injective (fun u : (ZMod q)ˣ => (u : ZMod q) * (v : ZMod q)) := by
      intro u z huz
      exact Units.val_injective (v.mulRight.injective huz)
    exact (finite_sum_comp_le_of_injective _ hinj (fun x => ‖ZMod.dft f x‖ ^ 2)
      (fun _ => sq_nonneg _)).trans_eq (dft_parseval f)
  calc
    _ ≤ (∑ u : (ZMod q)ˣ, w u * ‖ZMod.dft f ((u : ZMod q) * k)‖) ^ 2 :=
      pow_le_pow_left₀ (norm_nonneg _) (norm_dft_cyclic_unit_mixture_le f w hw k) 2
    _ ≤ (∑ u : (ZMod q)ˣ, w u ^ 2) *
        ∑ u : (ZMod q)ˣ, ‖ZMod.dft f ((u : ZMod q) * k)‖ ^ 2 :=
      Finset.sum_mul_sq_le_sq_mul_sq _ _ _
    _ ≤ M * ((q : ℝ) * ∑ x : ZMod q, ‖f x‖ ^ 2) :=
      mul_le_mul hwsq hfsq (Finset.sum_nonneg (fun _ _ => sq_nonneg _)) hM
    _ = _ := by ring

theorem dyadic_unit_probability_point_bound {J : ℕ} {γ ε : ℝ}
    {w : (ZMod (2 ^ J))ˣ → ℝ} (hw : ∀ u, 0 ≤ w u)
    (hspread : DyadicUnitProbabilityNonconcentration γ ε w)
    (hJ : 0 < J) (hε : ε < 1) (u : (ZMod (2 ^ J))ˣ) :
    w u ≤ (2 : ℝ) ^ (-γ * (J : ℝ)) := by
  have hεJ : ε * (J : ℝ) < (J : ℝ) := by
    simpa only [one_mul] using mul_lt_mul_of_pos_right hε (show (0 : ℝ) < J by exact_mod_cast hJ)
  apply (Finset.single_le_sum (fun v _ => hw v) (show u ∈ Finset.univ.filter
    (fun v : (ZMod (2 ^ J))ˣ => (((v : ZMod (2 ^ J)).val : ZMod (2 ^ J))) = (u : ZMod (2 ^ J))) by simp)).trans
  exact hspread J le_rfl hεJ (u : ZMod (2 ^ J))

/-- Power cancellation for an initial nonconcentrated law followed by a
fixed number of independent nonconcentrated unit inputs. -/
theorem exists_dyadic_unit_product_fourier_decay {γ : ℝ} (hγ : 0 < γ) :
    ∃ ε τ : ℝ, 0 < ε ∧ ε ≤ 1 / 4 ∧ 0 < τ ∧ ∃ r : ℕ, 0 < r ∧ ∃ J₀ : ℕ,
      ∀ J : ℕ, J₀ ≤ J → ∀ f : ZMod (2 ^ J) → ℂ,
      ∀ w : ℕ → (ZMod (2 ^ J))ˣ → ℝ,
        FiniteComplexProbability f →
        DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖) →
        (∀ n < r, ∀ u, 0 ≤ w n u) →
        (∀ n < r, (∑ u : (ZMod (2 ^ J))ˣ, w n u) = 1) →
        (∀ n < r, DyadicUnitProbabilityNonconcentration γ ε (w n)) →
        ∀ k : ZMod (2 ^ J), IsUnit k →
          ‖ZMod.dft (cyclicUnitProductIter f w r) k‖ ≤ (2 : ℝ) ^ (-τ * (J : ℝ)) := by
  let δ := min (γ / 2) (1 / 2)
  have hδ : 0 < δ := lt_min (by positivity) (by norm_num)
  have hδ1 : δ ≤ 1 := (min_le_right _ _).trans (by norm_num)
  have hκ : 0 < γ - δ := by
    have hh : δ ≤ γ / 2 := min_le_left _ _
    linarith only [hh, hγ]
  obtain ⟨ε, hε, hε4, R, hR, J₀, hflat⟩ := exists_dyadic_probability_flattening_iteration hγ hδ hδ1
  let N := 2 ^ (R + 2)
  have hN : 0 < N := by dsimp only [N]; positivity
  have hNR : (0 : ℝ) < N := by exact_mod_cast hN
  let τ := (γ - δ) / (N : ℝ)
  have hτ : 0 < τ := div_pos hκ hNR
  refine ⟨ε, τ, hε, hε4, hτ, R + 1, by omega, max J₀ 1, ?_⟩
  intro J hJ f w hf hspread hw hmass hwspread k hk
  have hJ₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hJpos : 0 < J := by have hh := (le_max_right J₀ 1).trans hJ; omega
  let ν := cyclicUnitAveragingIter (cyclicSymmetrize f) w R
  have henergy : (∑ x : ZMod (2 ^ J), ‖ν x‖ ^ 2) ≤ (2 : ℝ) ^ (-(1 - δ) * (J : ℝ)) :=
    hflat J hJ₀ (cyclicSymmetrize f) w (cyclic_symmetrize_probability hf)
      (dyadic_probability_nonconcentration_symmetrize hf hspread)
      (fun n hn => hw n (by omega)) (fun n hn => hmass n (by omega))
      (fun n hn => hwspread n (by omega))
  have hlast : ∀ u, w R u ≤ (2 : ℝ) ^ (-γ * (J : ℝ)) :=
    dyadic_unit_probability_point_bound (hw R (by omega)) (hwspread R (by omega))
      hJpos (by linarith only [hε4])
  have hbilinear : ‖ZMod.dft (cyclicMixture (w R) (cyclicUnitDilate ν)) k‖ ^ 2 ≤
      (2 : ℝ) ^ (-(γ - δ) * (J : ℝ)) := by
    calc
      _ ≤ ((2 ^ J : ℕ) : ℝ) * (2 : ℝ) ^ (-γ * (J : ℝ)) * ∑ x : ZMod (2 ^ J), ‖ν x‖ ^ 2 :=
        norm_dft_unit_mixture_sq_le ν (w R) (hw R (by omega)) (hmass R (by omega)) hlast hk
      _ ≤ ((2 ^ J : ℕ) : ℝ) * (2 : ℝ) ^ (-γ * (J : ℝ)) * (2 : ℝ) ^ (-(1 - δ) * (J : ℝ)) :=
        mul_le_mul_of_nonneg_left henergy (by positivity)
      _ = _ := by
        push_cast
        rw [← Real.rpow_natCast, ← Real.rpow_add (by norm_num), ← Real.rpow_add (by norm_num)]
        congr 1
        ring
  have hpower : ‖ZMod.dft (cyclicUnitProductIter f w (R + 1)) k‖ ^ N ≤
      (2 : ℝ) ^ (-(γ - δ) * (J : ℝ)) := by
    have hh := pow_le_pow_left₀ (pow_nonneg (norm_nonneg _) _)
      (norm_dft_unit_product_final_power_le f w hf.norm_cast hw hmass k) 2
    have he : N = 2 ^ (R + 1) * 2 := by dsimp only [N]; rw [show R + 2 = R + 1 + 1 by omega, pow_succ]
    rw [he, pow_mul]
    exact hh.trans hbilinear
  apply (pow_le_pow_iff_left₀ (norm_nonneg _) (by positivity) hN.ne').mp
  calc
    _ ≤ (2 : ℝ) ^ (-(γ - δ) * (J : ℝ)) := hpower
    _ = ((2 : ℝ) ^ (-τ * (J : ℝ))) ^ N := by
      rw [← Real.rpow_mul_natCast (by norm_num)]
      congr 1
      dsimp only [τ]
      field_simp



theorem finite_sum_units_eq {R M : Type*} [Monoid R] [Fintype R] [Fintype Rˣ]
    [AddCommMonoid M] (F : R → M) (hsupport : ∀ x, F x ≠ 0 → IsUnit x) :
    (∑ u : Rˣ, F (u : R)) = ∑ x : R, F x := by
  classical
  calc
    _ = ∑ x ∈ (Finset.univ : Finset Rˣ).image (fun u : Rˣ => (u : R)), F x := by
      symm
      exact Finset.sum_image (fun u _ v _ huv => Units.val_injective huv)
    _ = _ := by
      apply Finset.sum_subset (Finset.subset_univ _)
      intro x hx hxnot
      by_contra hzero
      obtain ⟨u, rfl⟩ := hsupport x hzero
      exact hxnot (Finset.mem_image.mpr ⟨u, Finset.mem_univ _, rfl⟩)

theorem finite_unit_fiber_mass_eq {R Q : Type*} [Monoid R] [Fintype R] [Fintype Rˣ]
    [DecidableEq Q] (p : R → ℝ) (π : R → Q)
    (hsupport : ∀ x, p x ≠ 0 → IsUnit x) (r : Q) :
    (∑ u ∈ Finset.univ.filter (fun u : Rˣ => π (u : R) = r), p (u : R)) =
      finitePushforward p π r := by
  simp only [finitePushforward, Finset.sum_filter]
  apply finite_sum_units_eq (fun x => if π x = r then p x else 0)
  intro x hx
  by_cases hxr : π x = r
  · exact hsupport x (by simpa only [if_pos hxr] using hx)
  · simp only [if_neg hxr, ne_eq, not_true_eq_false] at hx

theorem dyadic_unit_probability_nonconcentration_of_supported {J : ℕ} {γ ε : ℝ}
    {p : ZMod (2 ^ J) → ℝ} (hsupport : ∀ x, p x ≠ 0 → IsUnit x)
    (hspread : DyadicProbabilityNonconcentration γ ε p) :
    DyadicUnitProbabilityNonconcentration γ ε (fun u : (ZMod (2 ^ J))ˣ => p (u : ZMod (2 ^ J))) := by
  intro L hL hεL r
  have heq := finite_unit_fiber_mass_eq p (fun x : ZMod (2 ^ J) => (x.val : ZMod (2 ^ L))) hsupport r
  exact heq.trans_le (hspread L hL hεL r)

theorem cyclic_multiplicative_convolution_comm {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) : cyclicMultiplicativeConvolution f g = cyclicMultiplicativeConvolution g f := by
  classical
  funext x
  unfold cyclicMultiplicativeConvolution cyclicPushforward
  apply Fintype.sum_equiv (Equiv.prodComm (ZMod q) (ZMod q))
  intro p
  rcases p with ⟨a, b⟩
  simp [mul_comm]

theorem cyclic_product_pow_one {q : ℕ} [NeZero q] (f : ZMod q → ℂ) :
    cyclicProductPow f 1 = f := by
  apply ZMod.dft.injective
  funext k
  rw [cyclicProductPow, dft_cyclicMultiplicativeConvolution]
  simp [cyclicProductPow, ite_mul]

theorem cyclic_mixture_units_eq_mulconv {q : ℕ} [NeZero q]
    (f g : ZMod q → ℂ) (hg : ∀ x, g x = (‖g x‖ : ℂ))
    (hsupport : ∀ x, g x ≠ 0 → IsUnit x) :
    cyclicMixture (fun u : (ZMod q)ˣ => ‖g (u : ZMod q)‖) (cyclicUnitDilate f) =
      cyclicMultiplicativeConvolution f g := by
  apply ZMod.dft.injective
  funext k
  rw [dft_cyclic_mixture, dft_cyclicMultiplicativeConvolution]
  calc
    _ = ∑ u : (ZMod q)ˣ, g (u : ZMod q) * ZMod.dft f ((u : ZMod q) * k) := by
      apply Finset.sum_congr rfl
      intro u hu
      rw [dft_cyclic_unit_dilate, ← hg (u : ZMod q)]
    _ = _ := finite_sum_units_eq (fun x : ZMod q => g x * ZMod.dft f (x * k))
      (fun x hx => hsupport x (mul_ne_zero_iff.mp hx).1)

theorem cyclic_unit_product_iter_const {q : ℕ} [NeZero q]
    (f : ZMod q → ℂ) (hf : ∀ x, f x = (‖f x‖ : ℂ))
    (hsupport : ∀ x, f x ≠ 0 → IsUnit x) (r : ℕ) :
    cyclicUnitProductIter f (fun _ u => ‖f (u : ZMod q)‖) r = cyclicProductPow f (r + 1) := by
  induction r with
  | zero => exact (cyclic_product_pow_one f).symm
  | succ r ih =>
    rw [cyclicUnitProductIter, ih, cyclic_mixture_units_eq_mulconv _ f hf hsupport]
    exact cyclic_multiplicative_convolution_comm _ _

theorem cyclic_uniform_nat_set_complex_probability {q : ℕ} [NeZero q]
    {A : Finset ℕ} (hA : A.Nonempty) : FiniteComplexProbability (cyclicUniformNatSet (q := q) A) := by
  refine ⟨?_, ?_⟩
  · intro x
    rw [norm_cyclicUniformNatSet, cyclicUniformNatSet_eq_residue_mass]
  · simpa only [ZMod.dft_apply_zero] using dft_cyclicUniformNatSet_at_zero (q := q) hA

theorem dyadic_uniform_nat_set_probability_nonconcentration {J : ℕ} {γ ε : ℝ}
    (A : Finset ℕ) (hcutoff : 2 ≤ ε * (J : ℝ))
    (hspread : ∀ L : ℕ, 2 ≤ L → L ≤ J → ∀ x : ZMod (2 ^ L),
      ‖cyclicUniformNatSet A x‖ ≤ (2 : ℝ) ^ (-γ * (L : ℝ))) :
    DyadicProbabilityNonconcentration γ ε (fun x : ZMod (2 ^ J) => ‖cyclicUniformNatSet A x‖) := by
  intro L hL hεL r
  have hL2 : 2 ≤ L := by exact_mod_cast (hcutoff.trans_lt hεL).le
  let π : ZMod (2 ^ J) →+* ZMod (2 ^ L) := ZMod.castHom (pow_dvd_pow 2 hL) _
  have hπ : ∀ x : ZMod (2 ^ J), π x = (x.val : ZMod (2 ^ L)) := fun x => ZMod.cast_eq_val _
  have heq := congrFun (finite_pushforward_norm_cyclicUniformNatSet π A) r
  have hh := hspread L hL2 hL r
  rw [← heq] at hh
  simpa only [finitePushforward, hπ] using hh

theorem weighted_dyadic_mixing : WeightedDyadicMixing := by
  intro γ hγ hγhalf
  obtain ⟨ε, τ, hε, hε4, hτ, r, hr, J₀, hdecay⟩ := exists_dyadic_unit_product_fourier_decay hγ
  refine ⟨r + 1, τ, max J₀ ⌈2 / ε⌉₊, by omega, hτ, ?_⟩
  intro J hJ A hA hodd hspread a ha
  have hJ₀ : J₀ ≤ J := (le_max_left _ _).trans hJ
  have hJceil : ⌈2 / ε⌉₊ ≤ J := (le_max_right _ _).trans hJ
  have hcutoff : 2 ≤ ε * (J : ℝ) := by
    have hcast : (2 / ε : ℝ) ≤ J := (Nat.le_ceil _).trans (by exact_mod_cast hJceil)
    have hh := (div_le_iff₀ hε).mp hcast
    simpa only [mul_comm] using hh
  let f : ZMod (2 ^ J) → ℂ := cyclicUniformNatSet A
  let w : (ZMod (2 ^ J))ˣ → ℝ := fun u => ‖f (u : ZMod (2 ^ J))‖
  have hf : FiniteComplexProbability f := cyclic_uniform_nat_set_complex_probability hA
  have hsupport : ∀ x, ‖f x‖ ≠ 0 → IsUnit x := cyclicUniformNatSet_support_odd hodd J
  have hsupport' : ∀ x, f x ≠ 0 → IsUnit x := fun x hx => hsupport x (norm_ne_zero_iff.mpr hx)
  have hnonconcentration : DyadicProbabilityNonconcentration γ ε (fun x => ‖f x‖) :=
    dyadic_uniform_nat_set_probability_nonconcentration A hcutoff hspread
  have hw : ∀ u, 0 ≤ w u := fun _ => norm_nonneg _
  have hmass : ∑ u : (ZMod (2 ^ J))ˣ, w u = 1 := by
    rw [finite_sum_units_eq (fun x => ‖f x‖) hsupport]
    exact finite_complex_probability_sum_norm hf
  have hwspread : DyadicUnitProbabilityNonconcentration γ ε w :=
    dyadic_unit_probability_nonconcentration_of_supported hsupport hnonconcentration
  have hh := hdecay J hJ₀ f (fun _ => w) hf hnonconcentration (fun _ _ => hw)
    (fun _ _ => hmass) (fun _ _ => hwspread) (a : ZMod (2 ^ J)) (odd_natCast_isUnit_dyadic J ha)
  rw [cyclic_unit_product_iter_const f hf.norm_cast hsupport'] at hh
  exact hh

theorem target : fcTypeOfName% "Erdos18.erdos_18b" := by
  exact erdos18b_of_weighted_dyadic_mixing weighted_dyadic_mixing