import Mathlib

noncomputable section

namespace SoficGroups

section

open Filter Topology

universe u v w

abbrev UnitaryRepresentation (G : Type u) (H : Type v) [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] :=
  G →* (H ≃ₗᵢ[ℂ] H)

open scoped Pointwise commutatorElement symmDiff

structure KazhdanPair (G : Type u) [Group G] where
  generators : Finset G
  kazhdanConstant : ℝ
  positive : 0 < kazhdanConstant
  invariant :
    ∀ (H : Type v) [NormedAddCommGroup H] [InnerProductSpace ℂ H]
      [CompleteSpace H] (π : UnitaryRepresentation G H) (ξ : H),
      ‖ξ‖ = 1 →
      (∀ g ∈ generators, ‖π g ξ - ξ‖ < kazhdanConstant) →
      ∃ η : H, η ≠ 0 ∧ ∀ g : G, π g η = η

class HasPropertyT (G : Type u) [Group G] : Prop where
  exists_kazhdanPair : Nonempty (KazhdanPair.{u, v} G)

theorem hasPropertyT_of_mulEquiv {G : Type u} {G' : Type w}
    [Group G] [Group G'] (e : G ≃* G')
    [HasPropertyT.{u, v} G] : HasPropertyT.{w, v} G' := by
  classical
  obtain ⟨P⟩ := HasPropertyT.exists_kazhdanPair (G := G)
  refine ⟨⟨{
    generators := P.generators.image e
    kazhdanConstant := P.kazhdanConstant
    positive := P.positive
    invariant := ?_
  }⟩⟩
  intro H _ _ _ π ξ hξ hξ'
  obtain ⟨η, hη, hη'⟩ := P.invariant H (π.comp e.toMonoidHom) ξ hξ (by
    intro g hg
    exact hξ' (e g) (Finset.mem_image.mpr ⟨g, hg, rfl⟩))
  refine ⟨η, hη, ?_⟩
  intro g
  obtain ⟨g, rfl⟩ := e.surjective g
  exact hη' g

def normalizedHamming {Y : Type*} [Fintype Y] [DecidableEq Y]
    (p q : Equiv.Perm Y) : ℝ :=
  (hammingDist (fun y => p y) (fun y => q y) : ℝ) / Fintype.card Y

@[simp]
theorem normalizedHamming_self {Y : Type*} [Fintype Y] [DecidableEq Y]
    (p : Equiv.Perm Y) : normalizedHamming p p = 0 := by
  simp [normalizedHamming]

theorem normalizedHamming_comm {Y : Type*} [Fintype Y] [DecidableEq Y]
    (p q : Equiv.Perm Y) : normalizedHamming p q = normalizedHamming q p := by
  simp only [normalizedHamming, hammingDist_comm]

theorem normalizedHamming_nonneg {Y : Type*} [Fintype Y] [DecidableEq Y]
    (p q : Equiv.Perm Y) : 0 ≤ normalizedHamming p q := by
  unfold normalizedHamming
  positivity

theorem normalizedHamming_triangle {Y : Type*} [Fintype Y] [DecidableEq Y]
    (p q r : Equiv.Perm Y) :
    normalizedHamming p r ≤ normalizedHamming p q + normalizedHamming q r := by
  have h := hammingDist_triangle (fun y => p y) (fun y => q y) (fun y => r y)
  unfold normalizedHamming
  rw [← add_div]
  apply div_le_div_of_nonneg_right
  · exact_mod_cast h
  · positivity

theorem normalizedHamming_le_one {Y : Type*} [Fintype Y] [DecidableEq Y]
    (p q : Equiv.Perm Y) : normalizedHamming p q ≤ 1 := by
  have hcard :
      hammingDist (fun y => p y) (fun y => q y) ≤ Fintype.card Y :=
    hammingDist_le_card_fintype
  unfold normalizedHamming
  calc
    (hammingDist (fun y => p y) (fun y => q y) : ℝ) / Fintype.card Y ≤
        (Fintype.card Y : ℝ) / Fintype.card Y := by
      apply div_le_div_of_nonneg_right
      · exact_mod_cast hcard
      · positivity
    _ ≤ 1 := by
      by_cases h : Fintype.card Y = 0 <;> simp [h]

theorem normalizedHamming_mul_left {Y : Type*} [Fintype Y] [DecidableEq Y]
    (s p q : Equiv.Perm Y) :
    normalizedHamming (s * p) (s * q) = normalizedHamming p q := by
  have hdist :
      hammingDist (fun y => s (p y)) (fun y => s (q y)) =
        hammingDist (fun y => p y) (fun y => q y) :=
    hammingDist_comp (fun (_ : Y) (z : Y) => s z) (fun _ => s.injective)
  simp [normalizedHamming, Equiv.Perm.mul_apply, hdist]

theorem normalizedHamming_mul_right {Y : Type*} [Fintype Y] [DecidableEq Y]
    (s p q : Equiv.Perm Y) :
    normalizedHamming (p * s) (q * s) = normalizedHamming p q := by
  have hdist :
      hammingDist (fun y => (p * s) y) (fun y => (q * s) y) =
        hammingDist (fun y => p y) (fun y => q y) := by
    unfold hammingDist
    apply Finset.card_bij (fun y _ => s y)
    · intro y hy
      apply Finset.mem_filter.mpr
      refine ⟨Finset.mem_univ _, ?_⟩
      simpa only [Equiv.Perm.mul_apply] using (Finset.mem_filter.mp hy).2
    · intro y hy z hz h
      exact s.injective h
    · intro y hy
      refine ⟨s.symm y, ?_, by simp⟩
      apply Finset.mem_filter.mpr
      refine ⟨Finset.mem_univ _, ?_⟩
      simpa only [Equiv.Perm.mul_apply, Equiv.apply_symm_apply] using
        (Finset.mem_filter.mp hy).2
  unfold normalizedHamming
  exact congrArg
    (fun k : ℕ => (k : ℝ) / (Fintype.card Y : ℝ)) hdist

structure PermutationModel (G : Type*) [Group G] where
  size : ℕ
  size_pos : 0 < size
  action : G → Equiv.Perm (Fin size)
  map_one : action 1 = 1

structure GoodOn {G : Type*} [Group G]
    (M : PermutationModel G) (F : Finset G) (ε : ℝ) : Prop where
  multiplicative : ∀ g ∈ F, ∀ h ∈ F,
    normalizedHamming (M.action (g * h)) (M.action g * M.action h) < ε
  separated : ∀ g ∈ F, g ≠ 1 →
    1 - ε < normalizedHamming (M.action g) 1

theorem GoodOn.mono {G : Type*} [Group G] {M : PermutationModel G}
    {F F' : Finset G} {ε : ℝ} (h : GoodOn M F' ε) (hF : F ⊆ F') :
    GoodOn M F ε where
  multiplicative g hg k hk := h.multiplicative g (hF hg) k (hF hk)
  separated g hg hne := h.separated g (hF hg) hne

class Sofic (G : Type*) [Group G] : Prop where
  approximation : ∀ (F : Finset G) (ε : ℝ), 0 < ε → ε < 1 →
    ∃ M : PermutationModel G, GoodOn M F ε

theorem normalizedHamming_permCongr
    {X Y : Type*} [Fintype X] [DecidableEq X]
    [Fintype Y] [DecidableEq Y] (e : X ≃ Y) (p q : Equiv.Perm X) :
    normalizedHamming (e.permCongr p) (e.permCongr q) =
      normalizedHamming p q := by
  have hdist :
      hammingDist (fun y => e.permCongr p y) (fun y => e.permCongr q y) =
        hammingDist (fun x => p x) (fun x => q x) := by
    unfold hammingDist
    apply Finset.card_equiv e.symm
    intro y
    simp [Equiv.permCongr_apply, e.injective.eq_iff]
  unfold normalizedHamming
  rw [hdist, ← Fintype.card_congr e]

theorem hammingDist_prodCongr_refl_left
    {X Y : Type*} [Fintype X] [DecidableEq X]
    [Fintype Y] [DecidableEq Y] (p q : Equiv.Perm Y) :
    hammingDist
      (fun z : X × Y => ((Equiv.refl X).prodCongr p) z)
      (fun z : X × Y => ((Equiv.refl X).prodCongr q) z) =
      Fintype.card X * hammingDist (fun y => p y) (fun y => q y) := by
  classical
  change
    (Finset.univ.filter fun z : X × Y =>
      (z.1, p z.2) ≠ (z.1, q z.2)).card =
      Fintype.card X *
        (Finset.univ.filter fun y : Y => p y ≠ q y).card
  have hfilter :
      (Finset.univ.filter fun z : X × Y =>
        (z.1, p z.2) ≠ (z.1, q z.2)) =
        (Finset.univ : Finset X) ×ˢ
          (Finset.univ.filter fun y : Y => p y ≠ q y) := by
    ext z
    simp
  rw [hfilter, Finset.card_product]
  rfl

theorem normalizedHamming_prodCongr_refl_left
    {X Y : Type*} [Fintype X] [DecidableEq X]
    [Fintype Y] [DecidableEq Y] (hX : Fintype.card X ≠ 0)
    (p q : Equiv.Perm Y) :
    normalizedHamming
      ((Equiv.refl X).prodCongr p) ((Equiv.refl X).prodCongr q) =
      normalizedHamming p q := by
  unfold normalizedHamming
  rw [hammingDist_prodCongr_refl_left, Fintype.card_prod, Nat.cast_mul,
    Nat.cast_mul]
  exact mul_div_mul_left _ _ (by exact_mod_cast hX)

def amplifyModel {G : Type*} [Group G]
    (M : PermutationModel G) (k : ℕ) (hk : 0 < k) : PermutationModel G where
  size := k * M.size
  size_pos := Nat.mul_pos hk M.size_pos
  action g := finProdFinEquiv.permCongr
    ((Equiv.refl (Fin k)).prodCongr (M.action g))
  map_one := by
    ext x
    simp [M.map_one, Equiv.permCongr_apply, Equiv.prodCongr,
      Nat.mod_add_div]

theorem amplifyModel_normalizedHamming
    {G : Type*} [Group G] (M : PermutationModel G)
    (k : ℕ) (hk : 0 < k) (g h : G) :
    normalizedHamming ((amplifyModel M k hk).action g)
        ((amplifyModel M k hk).action h) =
      normalizedHamming (M.action g) (M.action h) := by
  change normalizedHamming
    (finProdFinEquiv.permCongr
      ((Equiv.refl (Fin k)).prodCongr (M.action g)))
    (finProdFinEquiv.permCongr
      ((Equiv.refl (Fin k)).prodCongr (M.action h))) = _
  rw [normalizedHamming_permCongr]
  apply normalizedHamming_prodCongr_refl_left
  simpa using hk.ne'

theorem amplifyModel_multiplicative_distance
    {G : Type*} [Group G] (M : PermutationModel G)
    (k : ℕ) (hk : 0 < k) (g h : G) :
    normalizedHamming
      ((amplifyModel M k hk).action (g * h))
      ((amplifyModel M k hk).action g *
        (amplifyModel M k hk).action h) =
    normalizedHamming (M.action (g * h))
      (M.action g * M.action h) := by
  have hprod (p q : Equiv.Perm (Fin M.size)) :
      ((Equiv.refl (Fin k)).prodCongr p) *
        ((Equiv.refl (Fin k)).prodCongr q) =
      (Equiv.refl (Fin k)).prodCongr (p * q) := by
    apply Equiv.ext
    intro z
    exact Prod.ext rfl rfl
  change
    normalizedHamming
      (finProdFinEquiv.permCongr
        ((Equiv.refl (Fin k)).prodCongr (M.action (g * h))))
      (finProdFinEquiv.permCongr
        ((Equiv.refl (Fin k)).prodCongr (M.action g)) *
        finProdFinEquiv.permCongr
        ((Equiv.refl (Fin k)).prodCongr (M.action h))) = _
  rw [← Equiv.permCongr_mul, normalizedHamming_permCongr, hprod]
  apply normalizedHamming_prodCongr_refl_left
  simpa using hk.ne'

theorem amplifyModel_separation_distance
    {G : Type*} [Group G] (M : PermutationModel G)
    (k : ℕ) (hk : 0 < k) (g : G) :
    normalizedHamming ((amplifyModel M k hk).action g) 1 =
      normalizedHamming (M.action g) 1 := by
  calc
    normalizedHamming ((amplifyModel M k hk).action g) 1 =
        normalizedHamming ((amplifyModel M k hk).action g)
          ((amplifyModel M k hk).action 1) := by
            rw [PermutationModel.map_one]
    _ = normalizedHamming (M.action g) (M.action 1) :=
      amplifyModel_normalizedHamming M k hk g 1
    _ = normalizedHamming (M.action g) 1 := by rw [M.map_one]

structure SoficApproximation (G : Type*) [Group G] where
  model : ℕ → PermutationModel G
  multiplicative : ∀ g h : G,
    Tendsto
      (fun n => normalizedHamming
        ((model n).action (g * h)) ((model n).action g * (model n).action h))
      atTop (𝓝 0)
  separated : ∀ g : G, g ≠ 1 →
    Tendsto
      (fun n => normalizedHamming ((model n).action g) 1)
      atTop (𝓝 1)

def pullbackPermutationModel {G H : Type*} [Group G] [Group H]
    (f : H →* G) (M : PermutationModel G) : PermutationModel H where
  size := M.size
  size_pos := M.size_pos
  action h := M.action (f h)
  map_one := by simpa using M.map_one

def pullbackSoficApproximation {G H : Type*} [Group G] [Group H]
    (f : H →* G) (hf : Function.Injective f)
    (A : SoficApproximation G) : SoficApproximation H where
  model n := pullbackPermutationModel f (A.model n)
  multiplicative g h := by
    convert A.multiplicative (f g) (f h) using 1
    funext n
    change
      normalizedHamming ((A.model n).action (f (g * h)))
        ((A.model n).action (f g) * (A.model n).action (f h)) =
      normalizedHamming ((A.model n).action (f g * f h))
        ((A.model n).action (f g) * (A.model n).action (f h))
    rw [map_mul]
  separated g hg := by
    have hfg : f g ≠ 1 := by
      intro he
      apply hg
      apply hf
      simpa using he
    convert A.separated (f g) hfg using 1
    funext n
    rfl

theorem nonempty_soficApproximation_of_sofic
    (G : Type*) [Group G] [Countable G] [Sofic G] :
    Nonempty (SoficApproximation G) := by
  classical
  let K : Set.FiniteExhaustion (Set.univ : Set G) :=
    Set.countable_univ.finiteExhaustion
  let F : ℕ → Finset G := fun n => (K.finite n).toFinset
  let ε : ℕ → ℝ := fun n => 1 / ((n : ℝ) + 2)
  have hε_pos (n : ℕ) : 0 < ε n := by
    dsimp [ε]
    positivity
  have hε_lt (n : ℕ) : ε n < 1 := by
    dsimp [ε]
    have hn : 0 ≤ (n : ℝ) := Nat.cast_nonneg n
    rw [div_lt_one (by linarith : (0 : ℝ) < n + 2)]
    linarith
  have hε_lim : Tendsto ε atTop (𝓝 0) := by
    simpa [ε, Function.comp_def, Nat.cast_add, Nat.cast_one, add_assoc,
      one_add_one_eq_two] using
      (tendsto_one_div_add_atTop_nhds_zero_nat (𝕜 := ℝ)).comp
        (tendsto_add_atTop_nat 1)
  have hmem (g : G) : ∀ᶠ n in atTop, g ∈ F n := by
    have hg : g ∈ ⋃ n, K n := by
      rw [K.iUnion_eq]
      exact Set.mem_univ g
    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hg
    filter_upwards [eventually_ge_atTop i] with n hn
    exact (K.finite n).mem_toFinset.mpr (K.mono hn hi)
  have hchoose (n : ℕ) : ∃ M : PermutationModel G, GoodOn M (F n) (ε n) :=
    Sofic.approximation (F n) (ε n) (hε_pos n) (hε_lt n)
  let M : ℕ → PermutationModel G := fun n => (hchoose n).choose
  have hgood (n : ℕ) : GoodOn (M n) (F n) (ε n) :=
    (hchoose n).choose_spec
  refine ⟨{
    model := M
    multiplicative := ?_
    separated := ?_
  }⟩
  · intro g h
    refine squeeze_zero' (Eventually.of_forall fun n =>
      normalizedHamming_nonneg _ _) ?_ hε_lim
    filter_upwards [hmem g, hmem h] with n hg hh
    exact (hgood n).multiplicative g hg h hh |>.le
  · intro g hg
    apply tendsto_of_tendsto_of_tendsto_of_le_of_le'
      (by simpa using (tendsto_const_nhds.sub hε_lim))
      tendsto_const_nhds
    · filter_upwards [hmem g] with n hn
      exact ((hgood n).separated g hn hg).le
    · exact Eventually.of_forall fun n =>
        normalizedHamming_le_one _ _

def amplifyApproximation {G : Type*} [Group G]
    (A : SoficApproximation G) : SoficApproximation G where
  model n := amplifyModel (A.model n) (n + 1) (Nat.zero_lt_succ n)
  multiplicative g h := by
    simpa only [amplifyModel_multiplicative_distance] using
      A.multiplicative g h
  separated g hg := by
    simpa only [amplifyModel_separation_distance] using
      A.separated g hg

theorem amplifyApproximation_size_tendsto
    {G : Type*} [Group G] (A : SoficApproximation G) :
    Tendsto (fun n => (amplifyApproximation A).model n |>.size)
      atTop atTop := by
  apply tendsto_atTop_mono (f := fun n : ℕ => n + 1)
    (g := fun n => (amplifyApproximation A).model n |>.size)
  · intro n
    change n + 1 ≤ (n + 1) * (A.model n).size
    exact Nat.le_mul_of_pos_right _ (A.model n).size_pos
  · exact tendsto_add_atTop_nat 1

theorem exists_soficApproximation_size_tendsto
    (G : Type*) [Group G] [Countable G] [Sofic G] :
    ∃ A : SoficApproximation G,
      Tendsto (fun n => (A.model n).size) atTop atTop := by
  obtain ⟨A⟩ := nonempty_soficApproximation_of_sofic G
  exact ⟨amplifyApproximation A, amplifyApproximation_size_tendsto A⟩

theorem sofic_of_injective {G H : Type*} [Group G] [Group H]
    [Sofic G] (f : H →* G) (hf : Function.Injective f) : Sofic H := by
  classical
  constructor
  intro F ε hε hε'
  obtain ⟨M, hM⟩ := Sofic.approximation (F.image f) ε hε hε'
  let N : PermutationModel H :=
    { size := M.size
      size_pos := M.size_pos
      action := fun g => M.action (f g)
      map_one := by simpa using M.map_one }
  refine ⟨N, ?_⟩
  constructor
  · intro g hg h hh
    simpa [N] using hM.multiplicative
      (f g) (Finset.mem_image_of_mem f hg)
      (f h) (Finset.mem_image_of_mem f hh)
  · intro g hg hne
    apply hM.separated (f g) (Finset.mem_image_of_mem f hg)
    intro he
    apply hne
    apply hf
    simpa using he

theorem exists_finite_obstruction {G : Type*} [Group G] (hG : ¬ Sofic G) :
    ∃ (F : Finset G) (ε : ℝ), 1 ∈ F ∧ 0 < ε ∧ ε < 1 ∧
      ∀ M : PermutationModel G, ¬ GoodOn M F ε := by
  classical
  have hex : ∃ (F : Finset G) (ε : ℝ), 0 < ε ∧ ε < 1 ∧
      ∀ M : PermutationModel G, ¬ GoodOn M F ε := by
    by_contra h
    apply hG
    constructor
    intro F ε hε hε'
    by_contra hmodel
    apply h
    exact ⟨F, ε, hε, hε', fun M hM => hmodel ⟨M, hM⟩⟩
  obtain ⟨F, ε, hε, hε', hF⟩ := hex
  refine ⟨insert 1 F, ε, Finset.mem_insert_self _ _, hε, hε', ?_⟩
  intro M hM
  exact hF M (hM.mono (Finset.subset_insert _ _))

noncomputable def multiplicationTable {G : Type*} [Group G]
    (F : Finset G) : Finset G := by
  classical
  exact F ∪ (F.product F).image (fun x : G × G => x.1 * x.2)

theorem mem_multiplicationTable_of_mem {G : Type*} [Group G]
    {F : Finset G} {g : G} (hg : g ∈ F) : g ∈ multiplicationTable F := by
  classical
  simp [multiplicationTable, hg]

theorem mul_mem_multiplicationTable {G : Type*} [Group G]
    {F : Finset G} {g h : G} (hg : g ∈ F) (hh : h ∈ F) :
    g * h ∈ multiplicationTable F := by
  classical
  change g * h ∈ F ∪ (F.product F).image (fun x : G × G => x.1 * x.2)
  apply Finset.mem_union_right
  exact Finset.mem_image.mpr
    ⟨(g, h), Finset.mem_product.mpr ⟨hg, hh⟩, rfl⟩

noncomputable def tableRelators {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) :
    Finset (FreeGroup ↥(multiplicationTable F)) := by
  classical
  let oneGenerator : ↥(multiplicationTable F) :=
    ⟨1, mem_multiplicationTable_of_mem h₁⟩
  let word (x : ↥F × ↥F) : FreeGroup ↥(multiplicationTable F) :=
    FreeGroup.of ⟨x.1.1, mem_multiplicationTable_of_mem x.1.2⟩ *
      FreeGroup.of ⟨x.2.1, mem_multiplicationTable_of_mem x.2.2⟩ *
      (FreeGroup.of
        ⟨x.1.1 * x.2.1, mul_mem_multiplicationTable x.1.2 x.2.2⟩)⁻¹
  exact {FreeGroup.of oneGenerator} ∪ (F.attach.product F.attach).image word

abbrev tableGroup {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) : Type _ :=
  PresentedGroup (tableRelators F h₁ : Set (FreeGroup ↥(multiplicationTable F)))

noncomputable def tableGenerator {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) (g : ↥(multiplicationTable F)) :
    tableGroup F h₁ :=
  PresentedGroup.of g

theorem tableGenerator_one {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) :
    tableGenerator F h₁ ⟨1, mem_multiplicationTable_of_mem h₁⟩ = 1 := by
  classical
  change PresentedGroup.mk _ (FreeGroup.of _) = 1
  apply PresentedGroup.one_of_mem
  change FreeGroup.of _ ∈ tableRelators F h₁
  simp [tableRelators]

theorem tableGenerator_mul {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) {g h : G} (hg : g ∈ F) (hh : h ∈ F) :
    tableGenerator F h₁ ⟨g, mem_multiplicationTable_of_mem hg⟩ *
      tableGenerator F h₁ ⟨h, mem_multiplicationTable_of_mem hh⟩ =
    tableGenerator F h₁ ⟨g * h, mul_mem_multiplicationTable hg hh⟩ := by
  classical
  have hrel :
      (FreeGroup.of ⟨g, mem_multiplicationTable_of_mem hg⟩ *
        FreeGroup.of ⟨h, mem_multiplicationTable_of_mem hh⟩) *
          (FreeGroup.of ⟨g * h, mul_mem_multiplicationTable hg hh⟩)⁻¹ ∈
        (tableRelators F h₁ : Set (FreeGroup ↥(multiplicationTable F))) := by
    change _ ∈ tableRelators F h₁
    rw [tableRelators]
    apply Finset.mem_union_right
    apply Finset.mem_image.mpr
    refine ⟨(⟨g, hg⟩, ⟨h, hh⟩), ?_, rfl⟩
    simp
  simpa only [tableGenerator, PresentedGroup.of, map_mul] using
    PresentedGroup.mk_eq_mk_of_mul_inv_mem hrel

noncomputable def tableEvaluation {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) : tableGroup F h₁ →* G := by
  classical
  apply PresentedGroup.toGroup (f := fun g : ↥(multiplicationTable F) => g.1)
  intro r hr
  change r ∈ tableRelators F h₁ at hr
  simp only [tableRelators, Finset.mem_union, Finset.mem_singleton,
    Finset.mem_image] at hr
  rcases hr with rfl | ⟨⟨g, h⟩, _, rfl⟩
  · simp
  · simp

@[simp]
theorem tableEvaluation_generator {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) (g : ↥(multiplicationTable F)) :
    tableEvaluation F h₁ (tableGenerator F h₁ g) = g.1 := by
  change PresentedGroup.toGroup _ (PresentedGroup.of g) = g.1
  exact PresentedGroup.toGroup.of _

theorem tableGenerator_ne_one {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) {g : G} (hg : g ∈ F) (hne : g ≠ 1) :
    tableGenerator F h₁ ⟨g, mem_multiplicationTable_of_mem hg⟩ ≠ 1 := by
  intro h
  apply hne
  simpa using congrArg (tableEvaluation F h₁) h

theorem tableGroup_finitelyPresented {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) :
    Group.IsFinitelyPresented (tableGroup F h₁) :=
  inferInstance

noncomputable def tableTestSet {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) : Finset (tableGroup F h₁) := by
  classical
  exact F.attach.image fun g =>
    tableGenerator F h₁ ⟨g.1, mem_multiplicationTable_of_mem g.2⟩

theorem tableGenerator_mem_tableTestSet {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) {g : G} (hg : g ∈ F) :
    tableGenerator F h₁ ⟨g, mem_multiplicationTable_of_mem hg⟩ ∈
      tableTestSet F h₁ := by
  classical
  change _ ∈ F.attach.image _
  exact Finset.mem_image.mpr ⟨⟨g, hg⟩, Finset.mem_attach _ _, rfl⟩

noncomputable def pullbackTableModel {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F)
    (M : PermutationModel (tableGroup F h₁)) : PermutationModel G := by
  classical
  refine
    { size := M.size
      size_pos := M.size_pos
      action := fun g => if hg : g ∈ multiplicationTable F then
        M.action (tableGenerator F h₁ ⟨g, hg⟩) else 1
      map_one := ?_ }
  simp [mem_multiplicationTable_of_mem h₁, tableGenerator_one F h₁,
    M.map_one]

theorem pullbackTableModel_action_of_mem {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F)
    (M : PermutationModel (tableGroup F h₁))
    {g : G} (hg : g ∈ multiplicationTable F) :
    (pullbackTableModel F h₁ M).action g =
      M.action (tableGenerator F h₁ ⟨g, hg⟩) := by
  classical
  simp only [pullbackTableModel, dif_pos hg]

theorem goodOn_pullbackTableModel {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) {ε : ℝ}
    (M : PermutationModel (tableGroup F h₁))
    (hM : GoodOn M (tableTestSet F h₁) ε) :
    GoodOn (pullbackTableModel F h₁ M) F ε := by
  constructor
  · intro g hg h hh
    have htest := hM.multiplicative
      (tableGenerator F h₁ ⟨g, mem_multiplicationTable_of_mem hg⟩)
      (tableGenerator_mem_tableTestSet F h₁ hg)
      (tableGenerator F h₁ ⟨h, mem_multiplicationTable_of_mem hh⟩)
      (tableGenerator_mem_tableTestSet F h₁ hh)
    change normalizedHamming
      ((pullbackTableModel F h₁ M).action (g * h))
      ((pullbackTableModel F h₁ M).action g *
        (pullbackTableModel F h₁ M).action h) < ε
    rw [pullbackTableModel_action_of_mem F h₁ M
      (mul_mem_multiplicationTable hg hh),
      pullbackTableModel_action_of_mem F h₁ M
        (mem_multiplicationTable_of_mem hg),
      pullbackTableModel_action_of_mem F h₁ M
        (mem_multiplicationTable_of_mem hh),
      ← tableGenerator_mul F h₁ hg hh]
    exact htest
  · intro g hg hne
    have htest := hM.separated
      (tableGenerator F h₁ ⟨g, mem_multiplicationTable_of_mem hg⟩)
      (tableGenerator_mem_tableTestSet F h₁ hg)
      (tableGenerator_ne_one F h₁ hg hne)
    change 1 - ε < normalizedHamming
      ((pullbackTableModel F h₁ M).action g) 1
    rw [pullbackTableModel_action_of_mem F h₁ M
      (mem_multiplicationTable_of_mem hg)]
    exact htest

theorem tableGroup_not_sofic_of_obstruction {G : Type*} [Group G]
    (F : Finset G) (h₁ : 1 ∈ F) (ε : ℝ)
    (hε : 0 < ε) (hε' : ε < 1)
    (hbad : ∀ M : PermutationModel G, ¬ GoodOn M F ε) :
    ¬ Sofic (tableGroup F h₁) := by
  intro hsofic
  obtain ⟨M, hM⟩ := hsofic.approximation (tableTestSet F h₁) ε hε hε'
  exact hbad (pullbackTableModel F h₁ M)
    (goodOn_pullbackTableModel F h₁ M hM)

theorem exists_nonsofic_finite_table {G : Type u} [Group G]
    (hG : ¬ Sofic G) :
    ∃ (F : Finset G) (h₁ : 1 ∈ F),
      Group.IsFinitelyPresented (tableGroup F h₁) ∧
        ¬ Sofic (tableGroup F h₁) := by
  obtain ⟨F, ε, h₁, hε, hε', hbad⟩ := exists_finite_obstruction hG
  exact ⟨F, h₁, tableGroup_finitelyPresented F h₁,
    tableGroup_not_sofic_of_obstruction F h₁ ε hε hε' hbad⟩

theorem exists_finitelyPresented_not_sofic_of_not_sofic
    {G : Type u} [Group G] (hG : ¬ Sofic G) :
    ∃ (H : Type u) (_ : Group H),
      Group.IsFinitelyPresented H ∧ ¬ Sofic H := by
  obtain ⟨F, h₁, hfp, hn⟩ := exists_nonsofic_finite_table hG
  exact ⟨tableGroup F h₁, inferInstance, hfp, hn⟩

structure LocalMultiplicativeOn {G : Type u} {H : Type v}
    [Group G] [Group H] (s : Finset G) (f : G → H) : Prop where
  map_one : f 1 = 1
  map_mul : ∀ x ∈ s, ∀ y ∈ s, f (x * y) = f x * f y

class LEF (G : Type u) [Group G] : Prop where
  approximate : ∀ s : Finset G, ∃ (n : ℕ) (f : G → Equiv.Perm (Fin n)),
    Set.InjOn f (s : Set G) ∧ LocalMultiplicativeOn s f

namespace LocalMultiplicativeOn

variable {G : Type u} {H : Type v} [Group G] [Group H]

theorem mono {s t : Finset G} {f : G → H}
    (h : LocalMultiplicativeOn t f) (hst : s ⊆ t) : LocalMultiplicativeOn s f where
  map_one := h.map_one
  map_mul x hx y hy := h.map_mul x (hst hx) y (hst hy)

theorem map_inv_of_mem {s : Finset G} {f : G → H}
    (h : LocalMultiplicativeOn s f) {x : G} (hx : x ∈ s) (hi : x⁻¹ ∈ s) :
    f x⁻¹ = (f x)⁻¹ := by
  have hm := h.map_mul x hx x⁻¹ hi
  rw [mul_inv_cancel, h.map_one] at hm
  exact eq_inv_of_mul_eq_one_right hm.symm

end LocalMultiplicativeOn

theorem exists_local_word_control {α : Type u} {G : Type v} [Group G]
    (φ : FreeGroup α →* G) (z : FreeGroup α) :
    ∃ s : Finset G, ∀ (H : Type w) [Group H] (f : G → H),
      LocalMultiplicativeOn s f →
        FreeGroup.lift (fun a => f (φ (FreeGroup.of a))) z = f (φ z) := by
  classical
  refine FreeGroup.induction_on z ?_ ?_ ?_ ?_
  · refine ⟨∅, ?_⟩
    intro H _ f hf
    simp [hf.map_one]
  · intro a
    refine ⟨∅, ?_⟩
    intro H _ f _
    simp
  · intro a _
    refine ⟨{φ (FreeGroup.of a), (φ (FreeGroup.of a))⁻¹}, ?_⟩
    intro H _ f hf
    simp only [map_inv, FreeGroup.lift_apply_of]
    exact (hf.map_inv_of_mem (by simp) (by simp)).symm
  · intro x y hx hy
    obtain ⟨sx, hx⟩ := hx
    obtain ⟨sy, hy⟩ := hy
    refine ⟨insert (φ x) (insert (φ y) (sx ∪ sy)), ?_⟩
    intro H _ f hf
    have hsx : sx ⊆ insert (φ x) (insert (φ y) (sx ∪ sy)) := by
      intro a ha
      simp [ha]
    have hsy : sy ⊆ insert (φ x) (insert (φ y) (sx ∪ sy)) := by
      intro a ha
      simp [ha]
    calc
      FreeGroup.lift (fun a => f (φ (FreeGroup.of a))) (x * y) =
          FreeGroup.lift (fun a => f (φ (FreeGroup.of a))) x *
            FreeGroup.lift (fun a => f (φ (FreeGroup.of a))) y := map_mul _ _ _
      _ = f (φ x) * f (φ y) :=
        congrArg₂ (· * ·) (hx H f (hf.mono hsx)) (hy H f (hf.mono hsy))
      _ = f (φ x * φ y) :=
        (hf.map_mul (φ x) (by simp) (φ y) (by simp)).symm
      _ = f (φ (x * y)) := by rw [map_mul]

def boundary {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (A : Finset V) : ℕ :=
  ∑ i : ι, (A.filter fun x => σ i x ∉ A).card

def agreementSet {V : Type*} [Fintype V] [DecidableEq V]
    (c c' : Equiv.Perm V) : Finset V :=
  Finset.univ.filter (fun x => c x = c' x)

def permutationCommutationDefect {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (c : Equiv.Perm V) : ℕ :=
  ∑ i : ι, (Finset.univ.filter fun x => c (σ i x) ≠ σ i (c x)).card

theorem agreementSet_card_add_hammingDist {V : Type*}
    [Fintype V] [DecidableEq V] (c c' : Equiv.Perm V) :
    (agreementSet c c').card +
      hammingDist (fun x => c x) (fun x => c' x) = Fintype.card V := by
  simpa [agreementSet, hammingDist] using
    (Finset.card_filter_add_card_filter_not
      (s := (Finset.univ : Finset V)) (fun x => c x = c' x))

theorem boundary_agreementSet_le_commutationDefect {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (c c' : Equiv.Perm V) :
    boundary σ (agreementSet c c') ≤
      permutationCommutationDefect σ c +
        permutationCommutationDefect σ c' := by
  classical
  unfold boundary permutationCommutationDefect
  rw [← Finset.sum_add_distrib]
  apply Finset.sum_le_sum
  intro i _
  let B : Finset V :=
    Finset.univ.filter fun x => c (σ i x) ≠ σ i (c x)
  let B' : Finset V :=
    Finset.univ.filter fun x => c' (σ i x) ≠ σ i (c' x)
  have hsub :
      (agreementSet c c').filter (fun x => σ i x ∉ agreementSet c c') ⊆
        B ∪ B' := by
    intro x hx
    have hx' := Finset.mem_filter.mp hx
    have hagree : c x = c' x :=
      (Finset.mem_filter.mp hx'.1).2
    have hdisagree : c (σ i x) ≠ c' (σ i x) := by
      intro heq
      exact hx'.2 (Finset.mem_filter.mpr ⟨Finset.mem_univ _, heq⟩)
    by_cases hc : c (σ i x) = σ i (c x)
    · apply Finset.mem_union_right
      apply Finset.mem_filter.mpr
      refine ⟨Finset.mem_univ _, ?_⟩
      intro hc'
      apply hdisagree
      calc
        c (σ i x) = σ i (c x) := hc
        _ = σ i (c' x) := congrArg (σ i) hagree
        _ = c' (σ i x) := hc'.symm
    · apply Finset.mem_union_left
      exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, hc⟩
  exact (Finset.card_le_card hsub).trans (Finset.card_union_le B B')

theorem hamming_dichotomy_of_expansion {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (h : ℝ)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
          ((Fintype.card V : ℝ) - A.card) ≤
        (boundary σ A : ℝ))
    (c c' : Equiv.Perm V) :
    h * (hammingDist (fun x => c x) (fun x => c' x) : ℝ) ≤
        (permutationCommutationDefect σ c +
          permutationCommutationDefect σ c' : ℕ) ∨
      h * ((Fintype.card V : ℝ) -
          hammingDist (fun x => c x) (fun x => c' x)) ≤
        (permutationCommutationDefect σ c +
          permutationCommutationDefect σ c' : ℕ) := by
  have hcard := agreementSet_card_add_hammingDist c c'
  have hcard' :
      ((agreementSet c c').card : ℝ) +
        (hammingDist (fun x => c x) (fun x => c' x) : ℝ) =
          Fintype.card V := by
    exact_mod_cast hcard
  have hboundary := boundary_agreementSet_le_commutationDefect σ c c'
  have hboundary' :
      (boundary σ (agreementSet c c') : ℝ) ≤
        (permutationCommutationDefect σ c +
          permutationCommutationDefect σ c' : ℕ) := by
    exact_mod_cast hboundary
  have hcut := (hexp (agreementSet c c')).trans hboundary'
  by_cases hhalf :
      ((agreementSet c c').card : ℝ) ≤
        (Fintype.card V : ℝ) - (agreementSet c c').card
  · right
    rw [min_eq_left hhalf] at hcut
    have hident :
        (Fintype.card V : ℝ) -
          hammingDist (fun x => c x) (fun x => c' x) =
            (agreementSet c c').card := by
      linarith [hcard']
    simpa [hident] using hcut
  · left
    rw [min_eq_right (le_of_not_ge hhalf)] at hcut
    have hident :
        (Fintype.card V : ℝ) - (agreementSet c c').card =
          hammingDist (fun x => c x) (fun x => c' x) := by
      linarith [hcard']
    simpa [hident] using hcut

def inducedBoundary {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B E : Finset V) : ℕ :=
  ∑ i : ι, (E.filter fun x => σ i x ∉ B ∧ σ i x ∉ E).card

theorem boundary_union_le {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B E : Finset V) :
    boundary σ (B ∪ E) ≤ boundary σ B + inducedBoundary σ B E := by
  classical
  unfold boundary inducedBoundary
  rw [← Finset.sum_add_distrib]
  refine Finset.sum_le_sum fun i _ => ?_
  apply le_trans (Finset.card_le_card ?_) (Finset.card_union_le _ _)
  intro x hx
  simp only [Finset.mem_filter, Finset.mem_union] at hx ⊢
  rcases hx with ⟨hxB | hxE, hout⟩
  · exact Or.inl ⟨hxB, fun h => hout (Or.inl h)⟩
  · exact Or.inr
      ⟨hxE, fun h => hout (Or.inl h), fun h => hout (Or.inr h)⟩

theorem boundary_le_induced_add_deleted {V ι : Type*}
    [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B E : Finset V) :
    boundary σ E ≤ inducedBoundary σ B E + Fintype.card ι * B.card := by
  classical
  unfold boundary inducedBoundary
  calc
    (∑ i : ι, (E.filter fun x => σ i x ∉ E).card)
        ≤ ∑ i : ι,
          ((E.filter fun x => σ i x ∉ B ∧ σ i x ∉ E).card + B.card) := by
            refine Finset.sum_le_sum fun i _ => ?_
            have hpre : (E.filter fun x => σ i x ∈ B).card ≤ B.card := by
              rw [← Finset.card_map (σ i).toEmbedding]
              apply Finset.card_le_card
              intro y hy
              obtain ⟨x, hx, rfl⟩ := Finset.mem_map.mp hy
              exact (Finset.mem_filter.mp hx).2
            have hsub :
                (E.filter fun x => σ i x ∉ E) ⊆
                  (E.filter fun x => σ i x ∉ B ∧ σ i x ∉ E) ∪
                    (E.filter fun x => σ i x ∈ B) := by
              intro x hx
              obtain ⟨hxE, hout⟩ := Finset.mem_filter.mp hx
              by_cases hB : σ i x ∈ B
              · exact Finset.mem_union_right _ (Finset.mem_filter.mpr ⟨hxE, hB⟩)
              · exact Finset.mem_union_left _
                  (Finset.mem_filter.mpr ⟨hxE, hB, hout⟩)
            exact (Finset.card_le_card hsub).trans
              ((Finset.card_union_le _ _).trans (Nat.add_le_add_left hpre _))
    _ = (∑ i : ι, (E.filter fun x => σ i x ∉ B ∧ σ i x ∉ E).card) +
        Fintype.card ι * B.card := by simp [Finset.sum_add_distrib]

theorem maximal_bad_cut_induced_lower {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B E : Finset V) (ell : ℝ)
    (hB : (boundary σ B : ℝ) ≤ ell * (B.card : ℝ))
    (hmax : ∀ A : Finset V,
      2 * A.card ≤ Fintype.card V →
      (boundary σ A : ℝ) < ell * (A.card : ℝ) → A.card ≤ B.card)
    (hdisj : Disjoint B E) (hne : E.Nonempty)
    (hhalf : 2 * (B ∪ E).card ≤ Fintype.card V) :
    ell * (E.card : ℝ) ≤ (inducedBoundary σ B E : ℝ) := by
  classical
  by_contra h
  have hE : (inducedBoundary σ B E : ℝ) < ell * (E.card : ℝ) :=
    lt_of_not_ge h
  have hcut : (boundary σ (B ∪ E) : ℝ) ≤
      (boundary σ B : ℝ) + (inducedBoundary σ B E : ℝ) := by
    exact_mod_cast boundary_union_le σ B E
  have hcard : ((B ∪ E).card : ℝ) = (B.card : ℝ) + (E.card : ℝ) := by
    exact_mod_cast Finset.card_union_of_disjoint hdisj
  have hbad : (boundary σ (B ∪ E) : ℝ) < ell * ((B ∪ E).card : ℝ) := by
    rw [hcard]
    nlinarith
  have hsize := hmax (B ∪ E) hhalf hbad
  have hepos : 0 < E.card := Finset.card_pos.mpr hne
  have hnat := Finset.card_union_of_disjoint hdisj
  omega

theorem bad_cut_card_bound {γ ell a : ℝ} {N b q : ℕ}
    (hgap : ell < γ)
    (hadd : γ * (b : ℝ) - a * (N : ℝ) ≤ (q : ℝ))
    (hbad : (q : ℝ) ≤ ell * (b : ℝ)) :
    (b : ℝ) ≤ a * (N : ℝ) / (γ - ell) := by
  apply (le_div_iff₀ (sub_pos.mpr hgap)).2
  nlinarith

theorem large_cut_lower {γ ell a d N b e q : ℝ}
    (hgap : ell < γ) (hd : 0 ≤ d) (hN : 0 ≤ N)
    (hdeleted : (γ - ell) * b ≤ a * N)
    (hsmall : 2 * a * (2 * (γ - ell) + d) ≤ (γ - ell) ^ 2)
    (hlarge : N / 2 - b < e)
    (hcut : γ * e - a * N - d * b ≤ q) :
    ell * e ≤ q := by
  have hδ : 0 < γ - ell := sub_pos.mpr hgap
  have hδd : 0 ≤ (γ - ell) + d := by linarith
  have hscaledDeleted := mul_le_mul_of_nonneg_left hdeleted hδd
  have hscaledSmall := mul_le_mul_of_nonneg_right hsmall hN
  have hscaledLarge := mul_lt_mul_of_pos_left hlarge hδ
  nlinarith

theorem prune_permutation_multigraph {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (γ ell a : ℝ) (B : Finset V)
    (hgap : ell < γ)
    (hadd : ∀ A : Finset V,
      γ * min (A.card : ℝ) ((Fintype.card V : ℝ) - (A.card : ℝ)) -
          a * (Fintype.card V : ℝ) ≤ (boundary σ A : ℝ))
    (hBhalf : 2 * B.card ≤ Fintype.card V)
    (hB : (boundary σ B : ℝ) ≤ ell * (B.card : ℝ))
    (hmax : ∀ A : Finset V,
      2 * A.card ≤ Fintype.card V →
      (boundary σ A : ℝ) < ell * (A.card : ℝ) → A.card ≤ B.card)
    (hsmall :
      2 * a * (2 * (γ - ell) + (Fintype.card ι : ℝ)) ≤ (γ - ell) ^ 2)
    (E : Finset V) (hdisj : Disjoint B E)
    (hEhalf : 2 * E.card ≤ Fintype.card V - B.card) :
    ell * (E.card : ℝ) ≤ (inducedBoundary σ B E : ℝ) := by
  classical
  rcases E.eq_empty_or_nonempty with rfl | hne
  · simp [inducedBoundary]
  by_cases hunion : 2 * (B ∪ E).card ≤ Fintype.card V
  · exact maximal_bad_cut_induced_lower σ B E ell hB hmax hdisj hne hunion
  have hBhalfReal :
      (B.card : ℝ) ≤ (Fintype.card V : ℝ) - (B.card : ℝ) := by
    have hcast : 2 * (B.card : ℝ) ≤ (Fintype.card V : ℝ) := by
      exact_mod_cast hBhalf
    linarith
  have haddB := hadd B
  rw [min_eq_left hBhalfReal] at haddB
  have hdeleted :
      (γ - ell) * (B.card : ℝ) ≤ a * (Fintype.card V : ℝ) := by
    linarith
  have hEhalfNat : 2 * E.card ≤ Fintype.card V :=
    hEhalf.trans (Nat.sub_le _ _)
  have hEhalfReal :
      (E.card : ℝ) ≤ (Fintype.card V : ℝ) - (E.card : ℝ) := by
    have hcast : 2 * (E.card : ℝ) ≤ (Fintype.card V : ℝ) := by
      exact_mod_cast hEhalfNat
    linarith
  have haddE := hadd E
  rw [min_eq_left hEhalfReal] at haddE
  have hremoval :
      (boundary σ E : ℝ) ≤ (inducedBoundary σ B E : ℝ) +
        (Fintype.card ι : ℝ) * (B.card : ℝ) := by
    exact_mod_cast boundary_le_induced_add_deleted σ B E
  have hcut :
      γ * (E.card : ℝ) - a * (Fintype.card V : ℝ) -
        (Fintype.card ι : ℝ) * (B.card : ℝ) ≤
        (inducedBoundary σ B E : ℝ) := by
    linarith
  have hcard := Finset.card_union_of_disjoint hdisj
  have hlargeNat : Fintype.card V < 2 * (B.card + E.card) := by
    simpa [hcard] using Nat.lt_of_not_ge hunion
  have hlargeCast :
      (Fintype.card V : ℝ) < 2 * ((B.card : ℝ) + (E.card : ℝ)) := by
    exact_mod_cast hlargeNat
  have hlarge :
      (Fintype.card V : ℝ) / 2 - (B.card : ℝ) < (E.card : ℝ) := by
    linarith
  exact large_cut_lower hgap (Nat.cast_nonneg _) (Nat.cast_nonneg _)
    hdeleted hsmall hlarge hcut

theorem exists_maximal_bad_cut {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (ell : ℝ) :
    ∃ B : Finset V,
      2 * B.card ≤ Fintype.card V ∧
      (boundary σ B : ℝ) ≤ ell * (B.card : ℝ) ∧
      ∀ A : Finset V,
        2 * A.card ≤ Fintype.card V →
        (boundary σ A : ℝ) < ell * (A.card : ℝ) → A.card ≤ B.card := by
  classical
  let candidates : Finset (Finset V) :=
    Finset.univ.powerset.filter fun A =>
      2 * A.card ≤ Fintype.card V ∧
        (boundary σ A : ℝ) < ell * (A.card : ℝ)
  by_cases hnonempty : candidates.Nonempty
  · obtain ⟨B, hBmem, hmax⟩ :=
      Finset.exists_max_image candidates Finset.card hnonempty
    have hprops :
        2 * B.card ≤ Fintype.card V ∧
          (boundary σ B : ℝ) < ell * (B.card : ℝ) := by
      have hmem : B ∈ Finset.univ.powerset.filter fun A =>
          2 * A.card ≤ Fintype.card V ∧
            (boundary σ A : ℝ) < ell * (A.card : ℝ) := by
        simpa only [candidates] using hBmem
      exact (Finset.mem_filter.mp hmem).2
    refine ⟨B, hprops.1, hprops.2.le, ?_⟩
    intro A hhalf hbad
    apply hmax A
    simp [candidates, hhalf, hbad]
  · refine ⟨∅, by simp, by simp [boundary], ?_⟩
    intro A hhalf hbad
    exfalso
    apply hnonempty
    refine ⟨A, ?_⟩
    simp [candidates, hhalf, hbad]

theorem exists_pruned_expander {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (γ ell a : ℝ)
    (hgap : ell < γ)
    (hadd : ∀ A : Finset V,
      γ * min (A.card : ℝ) ((Fintype.card V : ℝ) - (A.card : ℝ)) -
          a * (Fintype.card V : ℝ) ≤ (boundary σ A : ℝ))
    (hsmall :
      2 * a * (2 * (γ - ell) + (Fintype.card ι : ℝ)) ≤ (γ - ell) ^ 2) :
    ∃ B : Finset V,
      2 * B.card ≤ Fintype.card V ∧
      (B.card : ℝ) ≤ a * (Fintype.card V : ℝ) / (γ - ell) ∧
      ∀ E : Finset V, Disjoint B E →
        2 * E.card ≤ Fintype.card V - B.card →
        ell * (E.card : ℝ) ≤ (inducedBoundary σ B E : ℝ) := by
  classical
  obtain ⟨B, hhalf, hB, hmax⟩ := exists_maximal_bad_cut σ ell
  refine ⟨B, hhalf, ?_, ?_⟩
  · have hhalfReal :
        (B.card : ℝ) ≤ (Fintype.card V : ℝ) - (B.card : ℝ) := by
      have hcast : 2 * (B.card : ℝ) ≤ (Fintype.card V : ℝ) := by
        exact_mod_cast hhalf
      linarith
    have hlow := hadd B
    rw [min_eq_left hhalfReal] at hlow
    exact bad_cut_card_bound hgap hlow hB
  · intro E hdisj hEhalf
    exact prune_permutation_multigraph σ γ ell a B hgap hadd hhalf hB
      hmax hsmall E hdisj hEhalf

theorem disjoint_dominant_intersections_false {V : Type*} [DecidableEq V]
    (P Q D : Finset V) (hdisj : Disjoint P Q)
    (hP : D.card < 2 * (P ∩ D).card)
    (hQ : D.card < 2 * (Q ∩ D).card) : False := by
  have hparts : Disjoint (P ∩ D) (Q ∩ D) := by
    exact Finset.disjoint_of_subset_left (Finset.inter_subset_left)
      (Finset.disjoint_of_subset_right (Finset.inter_subset_left) hdisj)
  have hsub : (P ∩ D) ∪ (Q ∩ D) ⊆ D := by
    intro x hx
    rcases Finset.mem_union.mp hx with hx | hx
    · exact (Finset.mem_inter.mp hx).2
    · exact (Finset.mem_inter.mp hx).2
  have hcard := Finset.card_le_card hsub
  rw [Finset.card_union_of_disjoint hparts] at hcard
  omega

def matchedRetainedSupport {V : Type*} [DecidableEq V]
    (R : Finset (Finset V)) : Finset V :=
  R.biUnion id

def matchedCore {V : Type*} [DecidableEq V]
    (R : Finset (Finset V)) (D : Finset V → Finset V) : Finset V :=
  R.biUnion fun C => C ∩ D C

def partitionWordCrossing {V : Type*} [DecidableEq V]
    {U : Finset V} (P : Finpartition U) (w : Equiv.Perm V) : Finset V :=
  U.filter (fun x => w x ∉ P.part x)

def matchedWordPreimageBad {V : Type*} [DecidableEq V]
    (U : Finset V) (R : Finset (Finset V))
    (D : Finset V → Finset V) (w : Equiv.Perm V) : Finset V :=
  U.filter (fun x => w x ∈ U \ matchedCore R D)

theorem finpartition_dominant_matching_injOn
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (D : Finset V → Finset V)
    (hmajor : ∀ C ∈ R, (D C).card < 2 * (C ∩ D C).card) :
    Set.InjOn D (R : Set (Finset V)) := by
  intro C hC E hE heq
  have hCR : C ∈ R := hC
  have hER : E ∈ R := hE
  by_contra hne
  exact disjoint_dominant_intersections_false C E (D C)
    (P.disjoint (hR hCR) (hR hER) hne)
    (hmajor C hCR)
    (by simpa [heq] using hmajor E hER)

theorem matchedRetainedSupport_subset
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) :
    matchedRetainedSupport R ⊆ U := by
  intro x hx
  obtain ⟨C, hC, hxC⟩ := Finset.mem_biUnion.mp hx
  exact P.subset (hR hC) (by simpa using hxC)

theorem matchedCore_subset_retainedSupport
    {V : Type*} [DecidableEq V]
    (R : Finset (Finset V)) (D : Finset V → Finset V) :
    matchedCore R D ⊆ matchedRetainedSupport R := by
  intro x hx
  obtain ⟨C, hC, hxC⟩ := Finset.mem_biUnion.mp hx
  exact Finset.mem_biUnion.mpr
    ⟨C, hC, by simpa using (Finset.mem_inter.mp hxC).1⟩

theorem matchedCore_subset
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (D : Finset V → Finset V) :
    matchedCore R D ⊆ U :=
  (matchedCore_subset_retainedSupport R D).trans
    (matchedRetainedSupport_subset P R hR)

theorem matchedRetainedSupport_card
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) :
    (matchedRetainedSupport R).card = ∑ C ∈ R, C.card := by
  unfold matchedRetainedSupport
  apply Finset.card_biUnion
  intro C hC E hE hne
  exact P.disjoint (hR hC) (hR hE) hne

theorem matchedCore_card
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (D : Finset V → Finset V) :
    (matchedCore R D).card = ∑ C ∈ R, (C ∩ D C).card := by
  unfold matchedCore
  apply Finset.card_biUnion
  intro C hC E hE hne
  exact (P.disjoint (hR hC) (hR hE) hne).mono
    Finset.inter_subset_left Finset.inter_subset_left

theorem matchedCore_missing_card
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (D : Finset V → Finset V) :
    (U \ matchedCore R D).card =
      (U \ matchedRetainedSupport R).card +
        ∑ C ∈ R, (C \ D C).card := by
  have hcore := Finset.card_sdiff_add_card_eq_card
    (matchedCore_subset P R hR D)
  have hret := Finset.card_sdiff_add_card_eq_card
    (matchedRetainedSupport_subset P R hR)
  have hsplit :
      (∑ C ∈ R, (C \ D C).card) + (matchedCore R D).card =
        (matchedRetainedSupport R).card := by
    rw [matchedCore_card P R hR D, matchedRetainedSupport_card P R hR]
    rw [← Finset.sum_add_distrib]
    exact Finset.sum_congr rfl fun C _ =>
      Finset.card_sdiff_add_card_inter C (D C)
  omega

theorem matchedCore_missing_card_le_symmDiff
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (D : Finset V → Finset V) :
    (U \ matchedCore R D).card ≤
      (U \ matchedRetainedSupport R).card +
        ∑ C ∈ R, (C ∆ D C).card := by
  rw [matchedCore_missing_card P R hR D]
  exact Nat.add_le_add_left
    (Finset.sum_le_sum fun C _ =>
      Finset.card_le_card (Finset.symmDiff_subset_sdiff (s := C) (t := D C))) _

theorem matched_partition_part_eq_of_target_part_eq
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P Q : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (D : Finset V → Finset V)
    (hD : ∀ C ∈ R, D C ∈ Q.parts)
    (hinj : Set.InjOn D (R : Set (Finset V)))
    {x y : V} (hx : x ∈ matchedCore R D)
    (hy : y ∈ matchedCore R D)
    (hpart : Q.part x = Q.part y) :
    P.part x = P.part y := by
  obtain ⟨C, hC, hxC⟩ := Finset.mem_biUnion.mp hx
  obtain ⟨E, hE, hyE⟩ := Finset.mem_biUnion.mp hy
  have hxparts := Finset.mem_inter.mp hxC
  have hyparts := Finset.mem_inter.mp hyE
  have hQx : Q.part x = D C :=
    Q.part_eq_of_mem (hD C hC) hxparts.2
  have hQy : Q.part y = D E :=
    Q.part_eq_of_mem (hD E hE) hyparts.2
  have hCE : C = E := hinj hC hE (hQx.symm.trans (hpart.trans hQy))
  calc
    P.part x = C := P.part_eq_of_mem (hR hC) hxparts.1
    _ = E := hCE
    _ = P.part y := (P.part_eq_of_mem (hR hE) hyparts.1).symm

theorem matchedWordPreimageBad_card_le
    {V : Type*} [DecidableEq V]
    (U : Finset V) (R : Finset (Finset V))
    (D : Finset V → Finset V) (w : Equiv.Perm V) :
    (matchedWordPreimageBad U R D w).card ≤
      (U \ matchedCore R D).card := by
  apply Finset.card_le_card_of_injOn w
  · intro x hx
    exact (Finset.mem_filter.mp hx).2
  · intro x _ y _ hxy
    exact w.injective hxy

theorem partitionWordCrossing_subset_target_or_unmatched
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P Q : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (D : Finset V → Finset V)
    (hD : ∀ C ∈ R, D C ∈ Q.parts)
    (hinj : Set.InjOn D (R : Set (Finset V)))
    (w : Equiv.Perm V) :
    partitionWordCrossing P w ⊆
      partitionWordCrossing Q w ∪
        (U \ matchedCore R D) ∪ matchedWordPreimageBad U R D w := by
  intro x hx
  obtain ⟨hxU, hxP⟩ := Finset.mem_filter.mp hx
  by_cases hxcore : x ∈ matchedCore R D
  · by_cases hxQ : w x ∈ Q.part x
    · have hwU : w x ∈ U := Q.part_subset x hxQ
      by_cases hwcore : w x ∈ matchedCore R D
      · have hQpart : Q.part x = Q.part (w x) :=
          (Q.part_eq_of_mem (Q.part_mem.mpr hxU) hxQ).symm
        have hPpart := matched_partition_part_eq_of_target_part_eq
          P Q R hR D hD hinj hxcore hwcore hQpart
        exfalso
        apply hxP
        rw [hPpart]
        exact P.mem_part hwU
      · exact Finset.mem_union_right _
          (Finset.mem_filter.mpr
            ⟨hxU, Finset.mem_sdiff.mpr ⟨hwU, hwcore⟩⟩)
    · exact Finset.mem_union_left _
        (Finset.mem_union_left _ (Finset.mem_filter.mpr ⟨hxU, hxQ⟩))
  · exact Finset.mem_union_left _
      (Finset.mem_union_right _ (Finset.mem_sdiff.mpr ⟨hxU, hxcore⟩))

theorem partitionWordCrossing_card_le_target_add_unmatched
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P Q : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (D : Finset V → Finset V)
    (hD : ∀ C ∈ R, D C ∈ Q.parts)
    (hinj : Set.InjOn D (R : Set (Finset V)))
    (w : Equiv.Perm V) :
    (partitionWordCrossing P w).card ≤
      (partitionWordCrossing Q w).card +
        2 * (U \ matchedCore R D).card := by
  have hsub := Finset.card_le_card
    (partitionWordCrossing_subset_target_or_unmatched
      P Q R hR D hD hinj w)
  have hfirst := Finset.card_union_le
    (partitionWordCrossing Q w) (U \ matchedCore R D)
  have hsecond := Finset.card_union_le
    (partitionWordCrossing Q w ∪ (U \ matchedCore R D))
    (matchedWordPreimageBad U R D w)
  have hpre := matchedWordPreimageBad_card_le U R D w
  omega

theorem matchedCore_missing_density_tendsto_zero
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    (U : ∀ n, Finset (V n)) (P : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (D : ∀ n, Finset (V n) → Finset (V n))
    (hdiscard : Tendsto
      (fun n => (((U n \ matchedRetainedSupport (R n)).card : ℝ) /
        (U n).card)) atTop (𝓝 0))
    (hsymm : Tendsto
      (fun n =>
        ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) / (U n).card)
      atTop (𝓝 0)) :
    Tendsto
      (fun n => (((U n \ matchedCore (R n) (D n)).card : ℝ) /
        (U n).card)) atTop (𝓝 0) := by
  have hsum : Tendsto
      (fun n =>
        ((U n \ matchedRetainedSupport (R n)).card : ℝ) / (U n).card +
          ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) / (U n).card)
      atTop (𝓝 0) := by
    simpa only [zero_add] using hdiscard.add hsymm
  refine squeeze_zero (fun n => by positivity) ?_ hsum
  intro n
  have hcard :
      ((U n \ matchedCore (R n) (D n)).card : ℝ) ≤
        (U n \ matchedRetainedSupport (R n)).card +
          ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) := by
    exact_mod_cast matchedCore_missing_card_le_symmDiff
      (P n) (R n) (hR n) (D n)
  calc
    ((U n \ matchedCore (R n) (D n)).card : ℝ) / (U n).card ≤
        (((U n \ matchedRetainedSupport (R n)).card : ℝ) +
          ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ)) / (U n).card :=
      div_le_div_of_nonneg_right hcard (by positivity)
    _ = ((U n \ matchedRetainedSupport (R n)).card : ℝ) / (U n).card +
          ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) / (U n).card := by
      ring

theorem permutation_increment_sum_eq_zero
    {α : Type*} [Fintype α] (p : Equiv.Perm α) (f : α → ℝ) :
    ∑ x, (f (p x) - f x) = 0 := by
  rw [Finset.sum_sub_distrib, Equiv.sum_comp p f]
  exact sub_self _

theorem permutation_squared_increment_le_twice_decreasing
    {α : Type*} [Fintype α] (p : Equiv.Perm α) (f : α → ℝ)
    (hf_nonneg : ∀ x, 0 ≤ f x)
    (hf_le_one : ∀ x, f x ≤ 1) :
    ∑ x, (f (p x) - f x) ^ 2 ≤
      2 * ((Finset.univ.filter fun x => f (p x) < f x).card : ℝ) := by
  classical
  let d : α → ℝ := fun x => f (p x) - f x
  let B : Finset α := Finset.univ.filter fun x => d x < 0
  let C : Finset α := Finset.univ.filter fun x => ¬ d x < 0
  have hsum : ∑ x, d x = 0 :=
    permutation_increment_sum_eq_zero p f
  have hlower (x : α) : -1 ≤ d x := by
    dsimp [d]
    linarith [hf_nonneg (p x), hf_le_one x]
  have hupper (x : α) : d x ≤ 1 := by
    dsimp [d]
    linarith [hf_le_one (p x), hf_nonneg x]
  have hsplit : B.sum d + C.sum d = 0 := by
    calc
      B.sum d + C.sum d = ∑ x, d x := by
        simpa [B, C] using
          Finset.sum_filter_add_sum_filter_not Finset.univ
            (fun x : α => d x < 0) d
      _ = 0 := hsum
  have habs_bad : B.sum (fun x => |d x|) = -(B.sum d) := by
    rw [← Finset.sum_neg_distrib]
    apply Finset.sum_congr rfl
    intro x hx
    have hneg : d x < 0 := (Finset.mem_filter.mp hx).2
    exact abs_of_neg hneg
  have habs_good : C.sum (fun x => |d x|) = C.sum d := by
    apply Finset.sum_congr rfl
    intro x hx
    have hnonneg : 0 ≤ d x :=
      le_of_not_gt (Finset.mem_filter.mp hx).2
    exact abs_of_nonneg hnonneg
  have habs_split :
      B.sum (fun x => |d x|) + C.sum (fun x => |d x|) =
        ∑ x, |d x| := by
    simpa [B, C] using
      Finset.sum_filter_add_sum_filter_not Finset.univ
        (fun x : α => d x < 0) (fun x => |d x|)
  have habs_total : (∑ x, |d x|) = -2 * B.sum d := by
    rw [← habs_split, habs_bad, habs_good]
    linarith
  have hbad : -(B.sum d) ≤ (B.card : ℝ) := by
    calc
      -(B.sum d) = B.sum (fun x => -d x) := by
        simp
      _ ≤ B.sum (fun _ => (1 : ℝ)) := by
        apply Finset.sum_le_sum
        intro x _
        linarith [hlower x]
      _ = (B.card : ℝ) := by simp
  have hsquare : (∑ x, d x ^ 2) ≤ ∑ x, |d x| := by
    apply Finset.sum_le_sum
    intro x _
    by_cases h : 0 ≤ d x
    · rw [abs_of_nonneg h]
      nlinarith [hupper x]
    · have hneg : d x < 0 := lt_of_not_ge h
      rw [abs_of_neg hneg]
      nlinarith [hlower x]
  rw [habs_total] at hsquare
  have hfinal : (∑ x, d x ^ 2) ≤ 2 * (B.card : ℝ) := by
    linarith
  simpa [d, B, sub_neg] using hfinal

theorem exists_completion_of_internal_permutation {V : Type*}
    [Fintype V]
    (p : Equiv.Perm V) (Z : Finset V) :
    ∃ q : Equiv.Perm {x : V // x ∈ Z},
      ∀ (x : V) (hx : x ∈ Z) (_hp : p x ∈ Z),
        (q ⟨x, hx⟩ : V) = p x := by
  classical
  let A := {x : V // x ∈ Z ∧ p x ∈ Z}
  let f : A → {x : V // x ∈ Z} := fun x => ⟨x.1, x.2.1⟩
  let g : A → {x : V // x ∈ Z} := fun x => ⟨p x.1, x.2.2⟩
  have hf : Function.Injective f := by
    intro x y h
    apply Subtype.ext
    exact congrArg (fun z : {x : V // x ∈ Z} => (z : V)) h
  have hg : Function.Injective g := by
    intro x y h
    apply Subtype.ext
    exact p.injective
      (congrArg (fun z : {x : V // x ∈ Z} => (z : V)) h)
  obtain ⟨q, hq⟩ := Equiv.Perm.exists_extending_pair f g hf hg
  refine ⟨q, ?_⟩
  intro x hx hp
  have h := hq (⟨x, hx, hp⟩ : A)
  exact congrArg (fun z : {x : V // x ∈ Z} => (z : V)) h

def diagonalRadius (e : ℕ → ℕ → ℝ) (n : ℕ) : ℕ := by
  classical
  exact Nat.findGreatest
    (fun k => e n k < 1 / ((k : ℝ) + 1)) n

theorem diagonalRadius_tendsto_atTop (e : ℕ → ℕ → ℝ)
    (he : ∀ k, Tendsto (fun n => e n k) atTop (𝓝 0)) :
    Tendsto (diagonalRadius e) atTop atTop := by
  classical
  apply Filter.tendsto_atTop.2
  intro k
  have htol : (0 : ℝ) < 1 / ((k : ℝ) + 1) := by
    positivity
  have herr : ∀ᶠ n in atTop, e n k < 1 / ((k : ℝ) + 1) :=
    (he k).eventually (gt_mem_nhds htol)
  filter_upwards [eventually_ge_atTop k, herr] with n hn hn'
  exact Nat.le_findGreatest hn hn'

theorem diagonalRadius_eventually_error_lt (e : ℕ → ℕ → ℝ)
    (he : ∀ k, Tendsto (fun n => e n k) atTop (𝓝 0)) :
    ∀ᶠ n in atTop,
      e n (diagonalRadius e n) <
        1 / ((diagonalRadius e n : ℝ) + 1) := by
  classical
  have htol : (0 : ℝ) < 1 / ((0 : ℝ) + 1) := by
    norm_num
  have herr : ∀ᶠ n in atTop,
      e n 0 < 1 / ((0 : ℝ) + 1) :=
    (he 0).eventually (gt_mem_nhds htol)
  filter_upwards [herr] with n hn
  change
    (fun k : ℕ => e n k < 1 / ((k : ℝ) + 1))
      (Nat.findGreatest (fun k => e n k < 1 / ((k : ℝ) + 1)) n)
  exact Nat.findGreatest_spec
    (P := fun k => e n k < 1 / ((k : ℝ) + 1))
    (Nat.zero_le n) (by simpa using hn)

theorem diagonalRadius_error_tendsto_zero (e : ℕ → ℕ → ℝ)
    (hnonneg : ∀ n k, 0 ≤ e n k)
    (he : ∀ k, Tendsto (fun n => e n k) atTop (𝓝 0)) :
    Tendsto (fun n => e n (diagonalRadius e n)) atTop (𝓝 0) := by
  have hbound : ∀ᶠ n in atTop,
      e n (diagonalRadius e n) ≤
        1 / ((diagonalRadius e n : ℝ) + 1) :=
    (diagonalRadius_eventually_error_lt e he).mono fun _ h => h.le
  have hlimit : Tendsto
      (fun n => 1 / ((diagonalRadius e n : ℝ) + 1)) atTop (𝓝 0) := by
    simpa only [Function.comp_def] using
      (tendsto_one_div_add_atTop_nhds_zero_nat (𝕜 := ℝ)).comp
        (diagonalRadius_tendsto_atTop e he)
  exact squeeze_zero'
    (Eventually.of_forall fun n => hnonneg n (diagonalRadius e n))
    hbound hlimit

theorem exists_diverging_radius_with_vanishing_diagonal_error
    (e : ℕ → ℕ → ℝ) (hnonneg : ∀ n k, 0 ≤ e n k)
    (he : ∀ k, Tendsto (fun n => e n k) atTop (𝓝 0)) :
    ∃ r : ℕ → ℕ,
      Tendsto r atTop atTop ∧
        Tendsto (fun n => e n (r n)) atTop (𝓝 0) :=
  ⟨diagonalRadius e, diagonalRadius_tendsto_atTop e he,
    diagonalRadius_error_tendsto_zero e hnonneg he⟩

theorem finite_union_bad_density_tendsto_zero
    {α : ℕ → Type*} [∀ n, DecidableEq (α n)]
    {ι : Type*} (I : Finset ι)
    (V : ∀ n, Finset (α n)) (B : ∀ n, ι → Finset (α n))
    (hbad : ∀ i ∈ I, Tendsto
      (fun n => (((V n ∩ B n i).card : ℝ) / (V n).card))
      atTop (𝓝 0)) :
    Tendsto
      (fun n =>
        (((V n ∩ I.biUnion (B n)).card : ℝ) / (V n).card))
      atTop (𝓝 0) := by
  classical
  have hsum : Tendsto
      (fun n =>
        ∑ i ∈ I, (((V n ∩ B n i).card : ℝ) / (V n).card))
      atTop (𝓝 0) := by
    induction I using Finset.induction_on with
    | empty =>
        simp
    | @insert i I hi ih =>
        have hfirst := hbad i (Finset.mem_insert_self i I)
        have hrest := ih (fun j hj =>
          hbad j (Finset.mem_insert_of_mem hj))
        simpa [Finset.sum_insert, hi] using hfirst.add hrest
  refine squeeze_zero (fun n => by positivity) ?_ hsum
  intro n
  have hcard :
      ((V n ∩ I.biUnion (B n)).card : ℝ) ≤
        ∑ i ∈ I, ((V n ∩ B n i).card : ℝ) := by
    rw [Finset.inter_biUnion]
    exact_mod_cast
      (Finset.card_biUnion_le
        (s := I) (t := fun i => V n ∩ B n i))
  calc
    ((V n ∩ I.biUnion (B n)).card : ℝ) / (V n).card ≤
        (∑ i ∈ I, ((V n ∩ B n i).card : ℝ)) / (V n).card :=
      div_le_div_of_nonneg_right hcard (by positivity)
    _ = ∑ i ∈ I, (((V n ∩ B n i).card : ℝ) / (V n).card) :=
      Finset.sum_div _ _ _

theorem sum_card_inter_partition {α : Type*} [DecidableEq α]
    {U : Finset α} (P : Finpartition U) (B : Finset α) :
    ∑ C ∈ P.parts, (C ∩ B).card = (U ∩ B).card := by
  have hdis :
      (P.parts : Set (Finset α)).PairwiseDisjoint
        (fun C : Finset α => C ∩ B) := by
    intro C hC D hD hne
    exact (P.disjoint hC hD hne).mono
      Finset.inter_subset_left Finset.inter_subset_left
  have hunion :
      P.parts.biUnion (fun C => C ∩ B) = U ∩ B := by
    ext x
    simp [← P.biUnion_parts]
    aesop
  calc
    ∑ C ∈ P.parts, (C ∩ B).card =
        (P.parts.biUnion fun C => C ∩ B).card :=
      (Finset.card_biUnion hdis).symm
    _ = (U ∩ B).card := congrArg Finset.card hunion

theorem retained_bad_density_tendsto_zero
    {α : ℕ → Type*} [∀ n, DecidableEq (α n)]
    (V U B : ∀ n, Finset (α n))
    (hV : ∀ n, (V n).Nonempty) (hU : ∀ n, (U n).Nonempty)
    (hUV : ∀ n, U n ⊆ V n)
    (hcover : Tendsto
      (fun n => ((U n).card : ℝ) / (V n).card) atTop (𝓝 1))
    (hbad : Tendsto
      (fun n => (((V n ∩ B n).card : ℝ) / (V n).card))
      atTop (𝓝 0)) :
    Tendsto (fun n => (((U n ∩ B n).card : ℝ) / (U n).card))
      atTop (𝓝 0) := by
  have hhalf : ∀ᶠ n in atTop,
      (1 / 2 : ℝ) ≤ ((U n).card : ℝ) / (V n).card :=
    (hcover.eventually (lt_mem_nhds (by norm_num : (1 / 2 : ℝ) < 1))).mono
      fun _ h => h.le
  refine squeeze_zero' (Eventually.of_forall fun n => by positivity) ?_
    (by simpa using (tendsto_const_nhds.mul hbad :
      Tendsto
        (fun n => (2 : ℝ) *
          (((V n ∩ B n).card : ℝ) / (V n).card))
        atTop (𝓝 ((2 : ℝ) * 0))))
  filter_upwards [hhalf] with n hn
  have hv : (0 : ℝ) < (V n).card := by
    exact_mod_cast (hV n).card_pos
  have hu : (0 : ℝ) < (U n).card := by
    exact_mod_cast (hU n).card_pos
  have hmass : ((V n).card : ℝ) ≤ 2 * (U n).card := by
    have h := (le_div_iff₀ hv).1 hn
    linarith
  have hbadcard :
      ((U n ∩ B n).card : ℝ) ≤ (V n ∩ B n).card := by
    exact_mod_cast Finset.card_le_card
      (Finset.inter_subset_inter_right (hUV n) :
        U n ∩ B n ⊆ V n ∩ B n)
  calc
    ((U n ∩ B n).card : ℝ) / (U n).card ≤
        ((V n ∩ B n).card : ℝ) / (U n).card :=
      div_le_div_of_nonneg_right hbadcard hu.le
    _ ≤ 2 * (((V n ∩ B n).card : ℝ) / (V n).card) := by
      rw [← mul_div_assoc]
      apply (div_le_div_iff₀ hu hv).2
      simpa [mul_assoc, mul_comm, mul_left_comm] using
        (mul_le_mul_of_nonneg_left hmass
          (Nat.cast_nonneg (α := ℝ) (V n ∩ B n).card))

inductive LeavittGenerator where
  | s : Fin 2 → LeavittGenerator
  | t : Fin 2 → LeavittGenerator
  deriving Fintype

abbrev LeavittFree : Type := FreeAlgebra (ZMod 2) LeavittGenerator

instance leavittFreeCountable : Countable LeavittFree :=
  ((FreeAlgebra.equivMonoidAlgebraFreeMonoid
      (R := ZMod 2) (X := LeavittGenerator)).toEquiv.trans
    (MonoidAlgebra.coeffEquiv
      (R := ZMod 2) (M := FreeMonoid LeavittGenerator))).injective.countable

inductive LeavittRelation : LeavittFree → LeavittFree → Prop where
  | inverse (i j : Fin 2) :
      LeavittRelation
        (FreeAlgebra.ι (ZMod 2) (.t i) * FreeAlgebra.ι (ZMod 2) (.s j))
        (if i = j then 1 else 0)
  | partition :
      LeavittRelation
        (FreeAlgebra.ι (ZMod 2) (.s 0) * FreeAlgebra.ι (ZMod 2) (.t 0) +
          FreeAlgebra.ι (ZMod 2) (.s 1) * FreeAlgebra.ι (ZMod 2) (.t 1))
        1

abbrev BinaryLeavitt : Type := RingQuot LeavittRelation

instance binaryLeavittCountable : Countable BinaryLeavitt :=
  (RingQuot.mkAlgHom_surjective (ZMod 2) LeavittRelation).countable

def leavittQuotient : LeavittFree →ₐ[ZMod 2] BinaryLeavitt :=
  RingQuot.mkAlgHom (ZMod 2) LeavittRelation

instance binaryLeavittFiniteType : Algebra.FiniteType (ZMod 2) BinaryLeavitt :=
  Algebra.FiniteType.of_surjective leavittQuotient
    (RingQuot.mkAlgHom_surjective (ZMod 2) LeavittRelation)

def leavittS (i : Fin 2) : BinaryLeavitt :=
  leavittQuotient (FreeAlgebra.ι (ZMod 2) (.s i))

def leavittT (i : Fin 2) : BinaryLeavitt :=
  leavittQuotient (FreeAlgebra.ι (ZMod 2) (.t i))

theorem leavittT_mul_S (i j : Fin 2) :
    leavittT i * leavittS j = if i = j then 1 else 0 := by
  simpa [leavittT, leavittS, leavittQuotient] using
    RingQuot.mkAlgHom_rel (ZMod 2) (LeavittRelation.inverse i j)

theorem leavitt_partition :
    leavittS 0 * leavittT 0 + leavittS 1 * leavittT 1 = 1 := by
  simpa [leavittT, leavittS, leavittQuotient] using
    RingQuot.mkAlgHom_rel (ZMod 2) LeavittRelation.partition

abbrev leavittSequence : Type := ℕ → ZMod 2

def prefixOperator (i : Fin 2) : Module.End (ZMod 2) leavittSequence where
  toFun x n := if n % 2 = i.val then x (n / 2) else 0
  map_add' x y := by
    ext n
    simp only [Pi.add_apply]
    split_ifs <;> simp
  map_smul' a x := by
    ext n
    simp only [Pi.smul_apply, RingHom.id_apply]
    split_ifs <;> simp

def deletionOperator (i : Fin 2) : Module.End (ZMod 2) leavittSequence where
  toFun x n := x (2 * n + i.val)
  map_add' x y := by
    ext n
    rfl
  map_smul' a x := by
    ext n
    rfl

theorem deletion_mul_prefix (i j : Fin 2) :
    deletionOperator i * prefixOperator j = if i = j then 1 else 0 := by
  fin_cases i <;> fin_cases j <;> ext x n <;>
    simp [deletionOperator, prefixOperator, Module.End.mul_apply, Nat.add_mod]
  congr 1
  omega

theorem prefix_deletion_partition :
    prefixOperator 0 * deletionOperator 0 +
      prefixOperator 1 * deletionOperator 1 = 1 := by
  ext x n
  simp only [LinearMap.add_apply, Module.End.mul_apply, Module.End.one_apply]
  change
    (if n % 2 = 0 then x (2 * (n / 2)) else 0) +
      (if n % 2 = 1 then x (2 * (n / 2) + 1) else 0) = x n
  have h : n % 2 = 0 ∨ n % 2 = 1 := by omega
  rcases h with h | h <;> simp [h] <;> congr 1 <;> omega

def leavittGeneratorAction :
    LeavittGenerator → Module.End (ZMod 2) leavittSequence
  | .s i => prefixOperator i
  | .t i => deletionOperator i

def leavittFreeRepresentation :
    LeavittFree →ₐ[ZMod 2] Module.End (ZMod 2) leavittSequence :=
  FreeAlgebra.lift (ZMod 2) leavittGeneratorAction

theorem leavittFreeRepresentation_respects {x y : LeavittFree}
    (h : LeavittRelation x y) :
    leavittFreeRepresentation x = leavittFreeRepresentation y := by
  cases h with
  | inverse i j =>
      simp [leavittFreeRepresentation, leavittGeneratorAction,
        deletion_mul_prefix]
  | partition =>
      simpa [leavittFreeRepresentation, leavittGeneratorAction] using
        prefix_deletion_partition

def leavittRepresentation :
    BinaryLeavitt →ₐ[ZMod 2] Module.End (ZMod 2) leavittSequence :=
  RingQuot.liftAlgHom (ZMod 2)
    ⟨leavittFreeRepresentation, fun _ _ h => leavittFreeRepresentation_respects h⟩

@[simp] theorem leavittRepresentation_S (i : Fin 2) :
    leavittRepresentation (leavittS i) = prefixOperator i := by
  simp [leavittS, leavittQuotient, leavittRepresentation,
    leavittFreeRepresentation, leavittGeneratorAction]

@[simp] theorem leavittRepresentation_T (i : Fin 2) :
    leavittRepresentation (leavittT i) = deletionOperator i := by
  simp [leavittT, leavittQuotient, leavittRepresentation,
    leavittFreeRepresentation, leavittGeneratorAction]

instance binaryLeavittNontrivial : Nontrivial BinaryLeavitt :=
  leavittRepresentation.toRingHom.domain_nontrivial

theorem prefix_deletion_ne_one :
    prefixOperator 0 * deletionOperator 0 ≠ 1 := by
  intro h
  have h' := congrArg
    (fun f : Module.End (ZMod 2) leavittSequence => f (fun _ => 1) 1) h
  simp [prefixOperator, deletionOperator, Module.End.mul_apply] at h'

theorem leavittS_mul_T_ne_one : leavittS 0 * leavittT 0 ≠ 1 := by
  intro h
  apply prefix_deletion_ne_one
  simpa using congrArg leavittRepresentation h

instance binaryLeavittInfinite : Infinite BinaryLeavitt where
  not_finite h := by
    letI := h
    apply leavittS_mul_T_ne_one
    exact mul_eq_one_symm (by simpa using leavittT_mul_S 0 0)

def leavittWordS : List (Fin 2) → BinaryLeavitt
  | [] => 1
  | i :: a => leavittS i * leavittWordS a

def leavittWordT : List (Fin 2) → BinaryLeavitt
  | [] => 1
  | i :: a => leavittWordT a * leavittT i

theorem leavittWordT_mul_wordS_self (a : List (Fin 2)) :
    leavittWordT a * leavittWordS a = 1 := by
  induction a with
  | nil => simp [leavittWordT, leavittWordS]
  | cons i a ih =>
      calc
        leavittWordT (i :: a) * leavittWordS (i :: a) =
            leavittWordT a *
              ((leavittT i * leavittS i) * leavittWordS a) := by
                simp [leavittWordT, leavittWordS, mul_assoc]
        _ = 1 := by simp [leavittT_mul_S, ih]

theorem leavittWordT_mul_wordS_of_incomparable
    (a b : List (Fin 2)) (hab : ¬a <+: b) (hba : ¬b <+: a) :
    leavittWordT a * leavittWordS b = 0 := by
  induction a generalizing b with
  | nil => exact (hab (by simp)).elim
  | cons i a ih =>
      cases b with
      | nil => exact (hba (by simp)).elim
      | cons j b =>
          by_cases hij : i = j
          · subst j
            have hab' : ¬a <+: b := by
              intro hp
              apply hab
              simpa using hp
            have hba' : ¬b <+: a := by
              intro hp
              apply hba
              simpa using hp
            calc
              leavittWordT (i :: a) * leavittWordS (i :: b) =
                  leavittWordT a *
                    ((leavittT i * leavittS i) * leavittWordS b) := by
                      simp [leavittWordT, leavittWordS, mul_assoc]
              _ = leavittWordT a * leavittWordS b := by
                simp [leavittT_mul_S]
              _ = 0 := ih b hab' hba'
          · calc
              leavittWordT (i :: a) * leavittWordS (j :: b) =
                  leavittWordT a *
                    ((leavittT i * leavittS j) * leavittWordS b) := by
                      simp [leavittWordT, leavittWordS, mul_assoc]
              _ = 0 := by simp [leavittT_mul_S, hij]

theorem leavittWordS_append (a b : List (Fin 2)) :
    leavittWordS (a ++ b) = leavittWordS a * leavittWordS b := by
  induction a with
  | nil => simp [leavittWordS]
  | cons i a ih => simp [leavittWordS, ih, mul_assoc]

theorem leavittWordT_append (a b : List (Fin 2)) :
    leavittWordT (a ++ b) = leavittWordT b * leavittWordT a := by
  induction a with
  | nil => simp [leavittWordT]
  | cons i a ih => simp [leavittWordT, ih, mul_assoc]

def leavittCylinder (a : List (Fin 2)) : BinaryLeavitt :=
  leavittWordS a * leavittWordT a

theorem leavittCylinder_split (a : List (Fin 2)) :
    leavittCylinder a =
      leavittCylinder (a ++ [0]) + leavittCylinder (a ++ [1]) := by
  calc
    leavittCylinder a =
        leavittWordS a *
          (leavittS 0 * leavittT 0 + leavittS 1 * leavittT 1) *
          leavittWordT a := by
            rw [leavitt_partition]
            simp [leavittCylinder]
    _ = leavittCylinder (a ++ [0]) + leavittCylinder (a ++ [1]) := by
      simp [leavittCylinder, leavittWordS_append, leavittWordT_append,
        leavittWordS, leavittWordT, mul_add, add_mul, mul_assoc]

namespace MatrixCorner

variable {ι A : Type*} [Fintype ι] [Ring A]

def codeIdempotent (s t : ι → A) : A := ∑ i, s i * t i

def encode (s t : ι → A) (M : Matrix ι ι A) : A :=
  ∑ i, ∑ j, s i * M i j * t j

def decode (s t : ι → A) (x : A) : Matrix ι ι A :=
  fun i j => t i * x * s j

theorem decode_encode [DecidableEq ι] (s t : ι → A)
    (h : ∀ i j, t i * s j = if i = j then 1 else 0)
    (M : Matrix ι ι A) : decode s t (encode s t M) = M := by
  ext i j
  change t i * (∑ k, ∑ l, s k * M k l * t l) * s j = M i j
  calc
    t i * (∑ k, ∑ l, s k * M k l * t l) * s j =
        ∑ k, ∑ l, (t i * s k) * M k l * (t l * s j) := by
          simp [Finset.mul_sum, Finset.sum_mul, mul_assoc]
    _ = M i j := by simp [h]

theorem encode_decode (s t : ι → A) (x : A) :
    encode s t (decode s t x) =
      codeIdempotent s t * x * codeIdempotent s t := by
  change
    (∑ i, ∑ j, s i * (t i * x * s j) * t j) =
      (∑ i, s i * t i) * x * (∑ j, s j * t j)
  calc
    (∑ i, ∑ j, s i * (t i * x * s j) * t j) =
        ∑ i, ∑ j, (s i * t i) * x * (s j * t j) := by
          apply Finset.sum_congr rfl
          intro i _
          apply Finset.sum_congr rfl
          intro j _
          simp [mul_assoc]
    _ = (∑ i, s i * t i) * x * (∑ j, s j * t j) := by
      simp only [Finset.sum_mul, Finset.mul_sum]
      exact Finset.sum_comm

theorem codeIdempotent_isIdempotent [DecidableEq ι] (s t : ι → A)
    (h : ∀ i j, t i * s j = if i = j then 1 else 0) :
    IsIdempotentElem (codeIdempotent s t) := by
  change (∑ i, s i * t i) * (∑ i, s i * t i) = ∑ i, s i * t i
  calc
    (∑ i, s i * t i) * (∑ i, s i * t i) =
        ∑ i, ∑ j, s i * (t i * s j) * t j := by
          rw [Finset.sum_mul]
          apply Finset.sum_congr rfl
          intro i _
          rw [Finset.mul_sum]
          apply Finset.sum_congr rfl
          intro j _
          simp [mul_assoc]
    _ = ∑ i, s i * t i := by simp [h]

theorem encode_one [DecidableEq ι] (s t : ι → A) :
    encode s t (1 : Matrix ι ι A) = codeIdempotent s t := by
  simp [encode, codeIdempotent, Matrix.one_apply, mul_ite, ite_mul]

theorem encode_mul [DecidableEq ι] (s t : ι → A)
    (h : ∀ i j, t i * s j = if i = j then 1 else 0)
    (M N : Matrix ι ι A) :
    encode s t (M * N) = encode s t M * encode s t N := by
  symm
  calc
    encode s t M * encode s t N =
        ∑ i, ∑ j, ∑ k, ∑ l,
          s i * M i j * (t j * s k) * N k l * t l := by
            change
              (∑ i, ∑ j, s i * M i j * t j) *
                (∑ k, ∑ l, s k * N k l * t l) = _
            rw [Finset.sum_mul]
            apply Finset.sum_congr rfl
            intro i _
            rw [Finset.sum_mul]
            apply Finset.sum_congr rfl
            intro j _
            rw [Finset.mul_sum]
            apply Finset.sum_congr rfl
            intro k _
            rw [Finset.mul_sum]
            apply Finset.sum_congr rfl
            intro l _
            simp [mul_assoc]
    _ = ∑ i, ∑ j, ∑ l, s i * M i j * N j l * t l := by
      simp [h]
    _ = ∑ i, ∑ l, ∑ j, s i * M i j * N j l * t l := by
      apply Finset.sum_congr rfl
      intro i _
      exact Finset.sum_comm
    _ = encode s t (M * N) := by
      simp only [encode, Matrix.mul_apply]
      apply Finset.sum_congr rfl
      intro i _
      apply Finset.sum_congr rfl
      intro l _
      rw [Finset.mul_sum, Finset.sum_mul]
      apply Finset.sum_congr rfl
      intro j _
      simp [mul_assoc]

def ringEquiv [DecidableEq ι] (s t : ι → A)
    (h : ∀ i j, t i * s j = if i = j then 1 else 0) :
    Matrix ι ι A ≃+* (codeIdempotent_isIdempotent s t h).Corner where
  toFun M :=
    ⟨encode s t M, ⟨encode s t M, by
      change
        codeIdempotent s t * encode s t M * codeIdempotent s t =
          encode s t M
      rw [← encode_decode, decode_encode s t h]⟩⟩
  invFun x := decode s t x.1
  left_inv M := decode_encode s t h M
  right_inv x := Subtype.ext <| by
    change encode s t (decode s t x.1) = x.1
    rw [encode_decode]
    have hx :=
      (Subsemigroup.mem_corner_iff
        (codeIdempotent_isIdempotent s t h)).mp x.property
    rw [hx.1, hx.2]
  map_mul' M N := Subtype.ext (encode_mul s t h M N)
  map_add' M N := Subtype.ext <| by
    change encode s t (M + N) = encode s t M + encode s t N
    simp [encode, Matrix.add_apply, mul_add, add_mul, Finset.sum_add_distrib]

end MatrixCorner

structure BinaryPrefixCode (ι : Type*) where
  word : ι → List (Fin 2)
  prefix_free : ∀ ⦃i j⦄, i ≠ j → ¬word i <+: word j

theorem binaryPrefixCode_orthogonal {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι) (i j : ι) :
    leavittWordT (E.word i) * leavittWordS (E.word j) =
      if i = j then 1 else 0 := by
  by_cases hij : i = j
  · subst j
    simp [leavittWordT_mul_wordS_self]
  · simp only [hij, ↓reduceIte]
    exact leavittWordT_mul_wordS_of_incomparable _ _
      (E.prefix_free hij) (E.prefix_free (Ne.symm hij))

def binaryPrefixCornerEquiv {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι) :
    Matrix ι ι BinaryLeavitt ≃+*
      (MatrixCorner.codeIdempotent_isIdempotent
        (fun i => leavittWordS (E.word i))
        (fun i => leavittWordT (E.word i))
        (binaryPrefixCode_orthogonal E)).Corner :=
  MatrixCorner.ringEquiv
    (fun i => leavittWordS (E.word i))
    (fun i => leavittWordT (E.word i))
    (binaryPrefixCode_orthogonal E)

def prefixTable {ι : Type*} [Fintype ι]
    (source target : BinaryPrefixCode ι) : BinaryLeavitt :=
  ∑ i, leavittWordS (target.word i) * leavittWordT (source.word i)

theorem prefixTable_mul_reverse {ι : Type*} [Fintype ι] [DecidableEq ι]
    (source target : BinaryPrefixCode ι) :
    prefixTable source target * prefixTable target source =
      MatrixCorner.codeIdempotent
        (fun i => leavittWordS (target.word i))
        (fun i => leavittWordT (target.word i)) := by
  change
    (∑ i, leavittWordS (target.word i) * leavittWordT (source.word i)) *
        (∑ j, leavittWordS (source.word j) * leavittWordT (target.word j)) =
      ∑ i, leavittWordS (target.word i) * leavittWordT (target.word i)
  calc
    (∑ i, leavittWordS (target.word i) * leavittWordT (source.word i)) *
        (∑ j, leavittWordS (source.word j) * leavittWordT (target.word j)) =
        ∑ i, ∑ j,
          leavittWordS (target.word i) *
            (leavittWordT (source.word i) *
              leavittWordS (source.word j)) *
            leavittWordT (target.word j) := by
              rw [Finset.sum_mul]
              apply Finset.sum_congr rfl
              intro i _
              rw [Finset.mul_sum]
              apply Finset.sum_congr rfl
              intro j _
              simp [mul_assoc]
    _ = ∑ i, leavittWordS (target.word i) *
          leavittWordT (target.word i) := by
      simp [binaryPrefixCode_orthogonal]

def prefixTableUnit {ι : Type*} [Fintype ι] [DecidableEq ι]
    (source target : BinaryPrefixCode ι)
    (hsource : MatrixCorner.codeIdempotent
      (fun i => leavittWordS (source.word i))
      (fun i => leavittWordT (source.word i)) = 1)
    (htarget : MatrixCorner.codeIdempotent
      (fun i => leavittWordS (target.word i))
      (fun i => leavittWordT (target.word i)) = 1) : BinaryLeavittˣ where
  val := prefixTable source target
  inv := prefixTable target source
  val_inv := (prefixTable_mul_reverse source target).trans htarget
  inv_val := (prefixTable_mul_reverse target source).trans hsource

def alphaWord : Fin 3 → List (Fin 2)
  | 0 => [0, 0, 0]
  | 1 => [0, 0, 1]
  | _ => [0, 1]

def betaWord : Fin 3 → List (Fin 2)
  | 0 => [1, 0, 0, 0]
  | 1 => [1, 0, 0, 1]
  | _ => [1, 0, 1]

def nuWord : Fin 3 → List (Fin 2)
  | 0 => [1, 1, 0, 0]
  | 1 => [1, 1, 0, 1]
  | _ => [1, 1, 1]

def etaWord : Fin 3 → List (Fin 2)
  | 0 => [1, 0, 0]
  | 1 => [1, 0, 1]
  | _ => [1, 1]

def nineWord : Fin 9 → List (Fin 2)
  | 0 => alphaWord 0
  | 1 => betaWord 0
  | 2 => nuWord 0
  | 3 => alphaWord 1
  | 4 => betaWord 1
  | 5 => nuWord 1
  | 6 => alphaWord 2
  | 7 => betaWord 2
  | _ => nuWord 2

def uWord : Fin 9 → List (Fin 2)
  | 0 => alphaWord 0 ++ [0]
  | 1 => alphaWord 0 ++ [1]
  | 2 => etaWord 0
  | 3 => alphaWord 1 ++ [0]
  | 4 => alphaWord 1 ++ [1]
  | 5 => etaWord 1
  | 6 => alphaWord 2 ++ [0]
  | 7 => alphaWord 2 ++ [1]
  | _ => etaWord 2

def vWord : Fin 9 → List (Fin 2)
  | 0 => alphaWord 0 ++ [0]
  | 1 => etaWord 0
  | 2 => alphaWord 0 ++ [1]
  | 3 => alphaWord 1 ++ [0]
  | 4 => etaWord 1
  | 5 => alphaWord 1 ++ [1]
  | 6 => alphaWord 2 ++ [0]
  | 7 => etaWord 2
  | _ => alphaWord 2 ++ [1]

def alphaPrefixCode : BinaryPrefixCode (Fin 3) where
  word := alphaWord
  prefix_free := by decide

def ninePrefixCode : BinaryPrefixCode (Fin 9) where
  word := nineWord
  prefix_free := by decide

def uPrefixCode : BinaryPrefixCode (Fin 9) where
  word := uWord
  prefix_free := by decide

def vPrefixCode : BinaryPrefixCode (Fin 9) where
  word := vWord
  prefix_free := by decide

theorem alpha_cylinders :
    leavittCylinder (alphaWord 0) +
        leavittCylinder (alphaWord 1) +
        leavittCylinder (alphaWord 2) =
      leavittCylinder [0] := by
  have h₀₀ :
      leavittCylinder [0, 0, 0] + leavittCylinder [0, 0, 1] =
        leavittCylinder [0, 0] := by
    simpa using (leavittCylinder_split [0, 0]).symm
  have h₀ :
      leavittCylinder [0, 0] + leavittCylinder [0, 1] =
        leavittCylinder [0] := by
    simpa using (leavittCylinder_split [0]).symm
  change
    leavittCylinder [0, 0, 0] +
        leavittCylinder [0, 0, 1] +
        leavittCylinder [0, 1] = leavittCylinder [0]
  rw [h₀₀, h₀]

theorem beta_cylinders :
    leavittCylinder (betaWord 0) +
        leavittCylinder (betaWord 1) +
        leavittCylinder (betaWord 2) =
      leavittCylinder [1, 0] := by
  have h₁₀₀ :
      leavittCylinder [1, 0, 0, 0] + leavittCylinder [1, 0, 0, 1] =
        leavittCylinder [1, 0, 0] := by
    simpa using (leavittCylinder_split [1, 0, 0]).symm
  have h₁₀ :
      leavittCylinder [1, 0, 0] + leavittCylinder [1, 0, 1] =
        leavittCylinder [1, 0] := by
    simpa using (leavittCylinder_split [1, 0]).symm
  change
    leavittCylinder [1, 0, 0, 0] +
        leavittCylinder [1, 0, 0, 1] +
        leavittCylinder [1, 0, 1] = leavittCylinder [1, 0]
  rw [h₁₀₀, h₁₀]

theorem nu_cylinders :
    leavittCylinder (nuWord 0) +
        leavittCylinder (nuWord 1) +
        leavittCylinder (nuWord 2) =
      leavittCylinder [1, 1] := by
  have h₁₁₀ :
      leavittCylinder [1, 1, 0, 0] + leavittCylinder [1, 1, 0, 1] =
        leavittCylinder [1, 1, 0] := by
    simpa using (leavittCylinder_split [1, 1, 0]).symm
  have h₁₁ :
      leavittCylinder [1, 1, 0] + leavittCylinder [1, 1, 1] =
        leavittCylinder [1, 1] := by
    simpa using (leavittCylinder_split [1, 1]).symm
  change
    leavittCylinder [1, 1, 0, 0] +
        leavittCylinder [1, 1, 0, 1] +
        leavittCylinder [1, 1, 1] = leavittCylinder [1, 1]
  rw [h₁₁₀, h₁₁]

theorem eta_cylinders :
    leavittCylinder (etaWord 0) +
        leavittCylinder (etaWord 1) +
        leavittCylinder (etaWord 2) =
      leavittCylinder [1] := by
  have h₁₀ :
      leavittCylinder [1, 0, 0] + leavittCylinder [1, 0, 1] =
        leavittCylinder [1, 0] := by
    simpa using (leavittCylinder_split [1, 0]).symm
  have h₁ :
      leavittCylinder [1, 0] + leavittCylinder [1, 1] =
        leavittCylinder [1] := by
    simpa using (leavittCylinder_split [1]).symm
  change
    leavittCylinder [1, 0, 0] +
        leavittCylinder [1, 0, 1] +
        leavittCylinder [1, 1] = leavittCylinder [1]
  rw [h₁₀, h₁]

theorem ninePrefixCode_complete :
    MatrixCorner.codeIdempotent
      (fun i => leavittWordS (ninePrefixCode.word i))
      (fun i => leavittWordT (ninePrefixCode.word i)) = 1 := by
  change (∑ i : Fin 9, leavittCylinder (nineWord i)) = 1
  have h₁ :
      leavittCylinder [1, 0] + leavittCylinder [1, 1] =
        leavittCylinder [1] := by
    simpa using (leavittCylinder_split [1]).symm
  have hroot : leavittCylinder [0] + leavittCylinder [1] = 1 := by
    simpa [leavittCylinder, leavittWordS, leavittWordT] using
      leavitt_partition
  calc
    (∑ i : Fin 9, leavittCylinder (nineWord i)) =
        (leavittCylinder (alphaWord 0) +
          leavittCylinder (alphaWord 1) +
          leavittCylinder (alphaWord 2)) +
        (leavittCylinder (betaWord 0) +
          leavittCylinder (betaWord 1) +
          leavittCylinder (betaWord 2)) +
        (leavittCylinder (nuWord 0) +
          leavittCylinder (nuWord 1) +
          leavittCylinder (nuWord 2)) := by
          simp [Fin.sum_univ_succ, nineWord]
          ac_rfl
    _ = leavittCylinder [0] +
          leavittCylinder [1, 0] + leavittCylinder [1, 1] := by
      rw [alpha_cylinders, beta_cylinders, nu_cylinders]
    _ = leavittCylinder [0] + leavittCylinder [1] := by
      rw [add_assoc, h₁]
    _ = 1 := hroot

theorem uPrefixCode_complete :
    MatrixCorner.codeIdempotent
      (fun i => leavittWordS (uPrefixCode.word i))
      (fun i => leavittWordT (uPrefixCode.word i)) = 1 := by
  change (∑ i : Fin 9, leavittCylinder (uWord i)) = 1
  have h₀ :
      leavittCylinder (alphaWord 0 ++ [0]) +
          leavittCylinder (alphaWord 0 ++ [1]) =
        leavittCylinder (alphaWord 0) :=
    (leavittCylinder_split (alphaWord 0)).symm
  have h₁ :
      leavittCylinder (alphaWord 1 ++ [0]) +
          leavittCylinder (alphaWord 1 ++ [1]) =
        leavittCylinder (alphaWord 1) :=
    (leavittCylinder_split (alphaWord 1)).symm
  have h₂ :
      leavittCylinder (alphaWord 2 ++ [0]) +
          leavittCylinder (alphaWord 2 ++ [1]) =
        leavittCylinder (alphaWord 2) :=
    (leavittCylinder_split (alphaWord 2)).symm
  have hroot : leavittCylinder [0] + leavittCylinder [1] = 1 := by
    simpa [leavittCylinder, leavittWordS, leavittWordT] using
      leavitt_partition
  calc
    (∑ i : Fin 9, leavittCylinder (uWord i)) =
        ((leavittCylinder (alphaWord 0 ++ [0]) +
            leavittCylinder (alphaWord 0 ++ [1])) +
          (leavittCylinder (alphaWord 1 ++ [0]) +
            leavittCylinder (alphaWord 1 ++ [1])) +
          (leavittCylinder (alphaWord 2 ++ [0]) +
            leavittCylinder (alphaWord 2 ++ [1]))) +
        (leavittCylinder (etaWord 0) +
          leavittCylinder (etaWord 1) +
          leavittCylinder (etaWord 2)) := by
          simp [Fin.sum_univ_succ, uWord]
          ac_rfl
    _ = (leavittCylinder (alphaWord 0) +
          leavittCylinder (alphaWord 1) +
          leavittCylinder (alphaWord 2)) + leavittCylinder [1] := by
      rw [h₀, h₁, h₂, eta_cylinders]
    _ = leavittCylinder [0] + leavittCylinder [1] := by
      rw [alpha_cylinders]
    _ = 1 := hroot

theorem vPrefixCode_complete :
    MatrixCorner.codeIdempotent
      (fun i => leavittWordS (vPrefixCode.word i))
      (fun i => leavittWordT (vPrefixCode.word i)) = 1 := by
  change (∑ i : Fin 9, leavittCylinder (vWord i)) = 1
  calc
    (∑ i : Fin 9, leavittCylinder (vWord i)) =
        ∑ i : Fin 9, leavittCylinder (uWord i) := by
          simp [Fin.sum_univ_succ, vWord, uWord]
          ac_rfl
    _ = 1 := uPrefixCode_complete

def compressionU : BinaryLeavittˣ :=
  prefixTableUnit ninePrefixCode uPrefixCode
    ninePrefixCode_complete uPrefixCode_complete

def compressionV : BinaryLeavittˣ :=
  prefixTableUnit ninePrefixCode vPrefixCode
    ninePrefixCode_complete vPrefixCode_complete

instance binaryLeavittCharP : CharP BinaryLeavitt 2 :=
  CharP.of_ringHom_of_ne_zero
    (algebraMap (ZMod 2) BinaryLeavitt) 2 (by decide)

theorem matrixUnitTransport_root
    {A ι : Type*} [Ring A] [Fintype ι] [DecidableEq ι]
    (sSource tSource sTarget tTarget : ι → A)
    (hsource : ∀ i j, tSource i * sSource j = if i = j then 1 else 0)
    (i j : ι) (a : A) :
    (∑ k, sTarget k * tSource k) *
        (sSource i * a * tSource j) *
        (∑ k, sSource k * tTarget k) =
      sTarget i * a * tTarget j := by
  have hleft :
      (∑ k, sTarget k * tSource k) * sSource i = sTarget i := by
    calc
      (∑ k, sTarget k * tSource k) * sSource i =
          ∑ k, sTarget k * (tSource k * sSource i) := by
            simp only [Finset.sum_mul, mul_assoc]
      _ = sTarget i := by simp [hsource]
  have hright :
      tSource j * (∑ k, sSource k * tTarget k) = tTarget j := by
    calc
      tSource j * (∑ k, sSource k * tTarget k) =
          ∑ k, (tSource j * sSource k) * tTarget k := by
            simp only [Finset.mul_sum, mul_assoc]
      _ = tTarget j := by simp [hsource]
  calc
    (∑ k, sTarget k * tSource k) *
        (sSource i * a * tSource j) *
        (∑ k, sSource k * tTarget k) =
        ((∑ k, sTarget k * tSource k) * sSource i) * a *
          (tSource j * (∑ k, sSource k * tTarget k)) := by
            simp [mul_assoc]
    _ = sTarget i * a * tTarget j := by rw [hleft, hright]

theorem prefixTable_transport_root {ι : Type*}
    [Fintype ι] [DecidableEq ι]
    (source target : BinaryPrefixCode ι) (i j : ι)
    (a : BinaryLeavitt) :
    prefixTable source target *
        (leavittWordS (source.word i) * a *
          leavittWordT (source.word j)) *
        prefixTable target source =
      leavittWordS (target.word i) * a * leavittWordT (target.word j) := by
  exact matrixUnitTransport_root
    (fun k => leavittWordS (source.word k))
    (fun k => leavittWordT (source.word k))
    (fun k => leavittWordS (target.word k))
    (fun k => leavittWordT (target.word k))
    (binaryPrefixCode_orthogonal source) i j a

theorem compressionU_conjugate_root (i j : Fin 9) (a : BinaryLeavitt) :
    (compressionU : BinaryLeavitt) *
        (leavittWordS (nineWord i) * a * leavittWordT (nineWord j)) *
        (↑(compressionU⁻¹) : BinaryLeavitt) =
      leavittWordS (uWord i) * a * leavittWordT (uWord j) := by
  exact prefixTable_transport_root ninePrefixCode uPrefixCode i j a

theorem compressionV_conjugate_root (i j : Fin 9) (a : BinaryLeavitt) :
    (compressionV : BinaryLeavitt) *
        (leavittWordS (nineWord i) * a * leavittWordT (nineWord j)) *
        (↑(compressionV⁻¹) : BinaryLeavitt) =
      leavittWordS (vWord i) * a * leavittWordT (vWord j) := by
  exact prefixTable_transport_root ninePrefixCode vPrefixCode i j a

def alphaNineIndex (i : Fin 3) : Fin 9 :=
  ⟨3 * i.val, by omega⟩

@[simp]
theorem nineWord_alphaNineIndex (i : Fin 3) :
    nineWord (alphaNineIndex i) = alphaWord i := by
  fin_cases i <;> rfl

@[simp]
theorem uWord_alphaNineIndex (i : Fin 3) :
    uWord (alphaNineIndex i) = alphaWord i ++ [0] := by
  fin_cases i <;> rfl

@[simp]
theorem vWord_alphaNineIndex (i : Fin 3) :
    vWord (alphaNineIndex i) = alphaWord i ++ [0] := by
  fin_cases i <;> rfl

theorem compressionU_conjugate_alpha_root
    (i j : Fin 3) (a : BinaryLeavitt) :
    (compressionU : BinaryLeavitt) *
        (leavittWordS (alphaWord i) * a * leavittWordT (alphaWord j)) *
        (↑(compressionU⁻¹) : BinaryLeavitt) =
      leavittWordS (alphaWord i ++ [0]) * a *
        leavittWordT (alphaWord j ++ [0]) := by
  simpa only [nineWord_alphaNineIndex, uWord_alphaNineIndex] using
    compressionU_conjugate_root (alphaNineIndex i) (alphaNineIndex j) a

theorem compressionV_conjugate_alpha_root
    (i j : Fin 3) (a : BinaryLeavitt) :
    (compressionV : BinaryLeavitt) *
        (leavittWordS (alphaWord i) * a * leavittWordT (alphaWord j)) *
        (↑(compressionV⁻¹) : BinaryLeavitt) =
      leavittWordS (alphaWord i ++ [0]) * a *
        leavittWordT (alphaWord j ++ [0]) := by
  simpa only [nineWord_alphaNineIndex, vWord_alphaNineIndex] using
    compressionV_conjugate_root (alphaNineIndex i) (alphaNineIndex j) a

def alphaZeroPrefixCode : BinaryPrefixCode (Fin 3) where
  word i := alphaWord i ++ [0]
  prefix_free := by decide

def prefixElementaryUnit {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι) (i j : ι) (hij : i ≠ j)
    (a : BinaryLeavitt) : BinaryLeavittˣ := by
  let x := leavittWordS (E.word i) * a * leavittWordT (E.word j)
  have hzero : leavittWordT (E.word j) * leavittWordS (E.word i) = 0 := by
    simpa [hij.symm] using binaryPrefixCode_orthogonal E j i
  have hx : x * x = 0 := by
    dsimp [x]
    calc
      (leavittWordS (E.word i) * a * leavittWordT (E.word j)) *
          (leavittWordS (E.word i) * a * leavittWordT (E.word j)) =
        leavittWordS (E.word i) * a *
          (leavittWordT (E.word j) * leavittWordS (E.word i)) *
          a * leavittWordT (E.word j) := by
            simp [mul_assoc]
      _ = 0 := by rw [hzero]; simp
  exact
    { val := 1 + x
      inv := 1 - x
      val_inv := by noncomm_ring [hx]
      inv_val := by noncomm_ring [hx] }

def prefixElementaryGroup {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι) : Subgroup BinaryLeavittˣ :=
  Subgroup.closure
    {z | ∃ (i j : ι) (h : i ≠ j) (a : BinaryLeavitt),
      prefixElementaryUnit E i j h a = z}

theorem compressionU_conjugate_alpha_elementaryUnit
    (i j : Fin 3) (hij : i ≠ j) (a : BinaryLeavitt) :
    MulAut.conj compressionU
        (prefixElementaryUnit alphaPrefixCode i j hij a) =
      prefixElementaryUnit alphaZeroPrefixCode i j hij a := by
  apply Units.ext
  change
    (compressionU : BinaryLeavitt) *
        (1 + leavittWordS (alphaWord i) * a *
          leavittWordT (alphaWord j)) *
        (↑(compressionU⁻¹) : BinaryLeavitt) =
      1 + leavittWordS (alphaWord i ++ [0]) * a *
        leavittWordT (alphaWord j ++ [0])
  calc
    (compressionU : BinaryLeavitt) *
        (1 + leavittWordS (alphaWord i) * a *
          leavittWordT (alphaWord j)) *
        (↑(compressionU⁻¹) : BinaryLeavitt) =
      1 + (compressionU : BinaryLeavitt) *
        (leavittWordS (alphaWord i) * a *
          leavittWordT (alphaWord j)) *
        (↑(compressionU⁻¹) : BinaryLeavitt) := by
          simp [mul_add, add_mul]
    _ = 1 + leavittWordS (alphaWord i ++ [0]) * a *
          leavittWordT (alphaWord j ++ [0]) := by
      rw [compressionU_conjugate_alpha_root]

theorem compressionV_conjugate_alpha_elementaryUnit
    (i j : Fin 3) (hij : i ≠ j) (a : BinaryLeavitt) :
    MulAut.conj compressionV
        (prefixElementaryUnit alphaPrefixCode i j hij a) =
      prefixElementaryUnit alphaZeroPrefixCode i j hij a := by
  apply Units.ext
  change
    (compressionV : BinaryLeavitt) *
        (1 + leavittWordS (alphaWord i) * a *
          leavittWordT (alphaWord j)) *
        (↑(compressionV⁻¹) : BinaryLeavitt) =
      1 + leavittWordS (alphaWord i ++ [0]) * a *
        leavittWordT (alphaWord j ++ [0])
  calc
    (compressionV : BinaryLeavitt) *
        (1 + leavittWordS (alphaWord i) * a *
          leavittWordT (alphaWord j)) *
        (↑(compressionV⁻¹) : BinaryLeavitt) =
      1 + (compressionV : BinaryLeavitt) *
        (leavittWordS (alphaWord i) * a *
          leavittWordT (alphaWord j)) *
        (↑(compressionV⁻¹) : BinaryLeavitt) := by
          simp [mul_add, add_mul]
    _ = 1 + leavittWordS (alphaWord i ++ [0]) * a *
          leavittWordT (alphaWord j ++ [0]) := by
      rw [compressionV_conjugate_alpha_root]

theorem prefixElementaryGroup_map_conj
    {ι : Type*} [DecidableEq ι]
    (E E' : BinaryPrefixCode ι) (g : BinaryLeavittˣ)
    (hconj : ∀ (i j : ι) (hij : i ≠ j) (a : BinaryLeavitt),
      MulAut.conj g (prefixElementaryUnit E i j hij a) =
        prefixElementaryUnit E' i j hij a) :
    (prefixElementaryGroup E).map (MulAut.conj g).toMonoidHom =
      prefixElementaryGroup E' := by
  unfold prefixElementaryGroup
  rw [MonoidHom.map_closure]
  congr 1
  ext z
  constructor
  · rintro ⟨_, ⟨i, j, hij, a, rfl⟩, hz⟩
    exact ⟨i, j, hij, a, (hconj i j hij a).symm.trans hz⟩
  · rintro ⟨i, j, hij, a, rfl⟩
    exact ⟨prefixElementaryUnit E i j hij a,
      ⟨i, j, hij, a, rfl⟩, hconj i j hij a⟩

theorem compressionU_map_alphaPrefixElementaryGroup :
    (prefixElementaryGroup alphaPrefixCode).map
        (MulAut.conj compressionU).toMonoidHom =
      prefixElementaryGroup alphaZeroPrefixCode :=
  prefixElementaryGroup_map_conj alphaPrefixCode alphaZeroPrefixCode
    compressionU compressionU_conjugate_alpha_elementaryUnit

theorem compressionV_map_alphaPrefixElementaryGroup :
    (prefixElementaryGroup alphaPrefixCode).map
        (MulAut.conj compressionV).toMonoidHom =
      prefixElementaryGroup alphaZeroPrefixCode :=
  prefixElementaryGroup_map_conj alphaPrefixCode alphaZeroPrefixCode
    compressionV compressionV_conjugate_alpha_elementaryUnit

theorem alphaZero_prefixElementaryUnit_eq
    (i j : Fin 3) (hij : i ≠ j) (a : BinaryLeavitt) :
    prefixElementaryUnit alphaZeroPrefixCode i j hij a =
      prefixElementaryUnit alphaPrefixCode i j hij
        (leavittS 0 * a * leavittT 0) := by
  apply Units.ext
  change
    1 + leavittWordS (alphaWord i ++ [0]) * a *
      leavittWordT (alphaWord j ++ [0]) =
    1 + leavittWordS (alphaWord i) *
      (leavittS 0 * a * leavittT 0) * leavittWordT (alphaWord j)
  simp [leavittWordS_append, leavittWordT_append,
    leavittWordS, leavittWordT, mul_assoc]

theorem alphaZero_prefixElementaryGroup_le :
    prefixElementaryGroup alphaZeroPrefixCode ≤
      prefixElementaryGroup alphaPrefixCode := by
  rw [prefixElementaryGroup, Subgroup.closure_le]
  rintro _ ⟨i, j, hij, a, rfl⟩
  rw [alphaZero_prefixElementaryUnit_eq]
  exact Subgroup.subset_closure
    ⟨i, j, hij, leavittS 0 * a * leavittT 0, rfl⟩

section NoncommutativeElementaryGroup

variable {ι R : Type*} [Fintype ι] [DecidableEq ι] [Ring R]

theorem single_mul_self_eq_zero (i j : ι) (h : i ≠ j) (a : R) :
    Matrix.single i j a * Matrix.single i j a = 0 :=
  Matrix.single_mul_single_of_ne (c := a) i j i h.symm a

def elementaryUnit (i j : ι) (h : i ≠ j) (a : R) : (Matrix ι ι R)ˣ where
  val := 1 + Matrix.single i j a
  inv := 1 - Matrix.single i j a
  val_inv := by
    have hx := single_mul_self_eq_zero i j h a
    noncomm_ring [hx]
  inv_val := by
    have hx := single_mul_self_eq_zero i j h a
    noncomm_ring [hx]

@[simp] theorem elementaryUnit_zero (i j : ι) (h : i ≠ j) :
    elementaryUnit (R := R) i j h 0 = 1 := by
  apply Units.ext
  simp [elementaryUnit]

theorem elementaryUnit_mul (i j : ι) (h : i ≠ j) (a b : R) :
    elementaryUnit i j h a * elementaryUnit i j h b =
      elementaryUnit i j h (a + b) := by
  apply Units.ext
  change
    (1 + Matrix.single i j a) * (1 + Matrix.single i j b) =
      1 + Matrix.single i j (a + b)
  have hab : Matrix.single i j a * Matrix.single i j b = 0 :=
    Matrix.single_mul_single_of_ne (c := a) i j i h.symm b
  rw [Matrix.single_add]
  noncomm_ring [hab]

theorem elementaryUnit_injective (i j : ι) (h : i ≠ j) :
    Function.Injective (elementaryUnit (R := R) i j h) := by
  intro a b hab
  have he := congrArg (fun z : (Matrix ι ι R)ˣ => (z : Matrix ι ι R) i j) hab
  simpa [elementaryUnit, Matrix.one_apply, h] using he

def elementaryGroup (ι R : Type*) [Fintype ι] [DecidableEq ι] [Ring R] :
    Subgroup (Matrix ι ι R)ˣ :=
  Subgroup.closure
    {z | ∃ (i j : ι) (h : i ≠ j) (a : R), elementaryUnit i j h a = z}

theorem elementaryUnit_mem (i j : ι) (h : i ≠ j) (a : R) :
    elementaryUnit i j h a ∈ elementaryGroup ι R :=
  Subgroup.subset_closure ⟨i, j, h, a, rfl⟩

def elementaryRootHom (i j : ι) (h : i ≠ j) :
    Multiplicative R →* elementaryGroup ι R where
  toFun a := ⟨elementaryUnit i j h a.toAdd, elementaryUnit_mem i j h a.toAdd⟩
  map_one' := by
    apply Subtype.ext
    exact elementaryUnit_zero i j h
  map_mul' a b := by
    apply Subtype.ext
    exact (elementaryUnit_mul i j h a.toAdd b.toAdd).symm

theorem elementaryGroup_infinite [Infinite R] (i j : ι) (h : i ≠ j) :
    Infinite (elementaryGroup ι R) := by
  apply Infinite.of_injective
    (fun a : R => (⟨elementaryUnit i j h a, elementaryUnit_mem i j h a⟩ :
      elementaryGroup ι R))
  intro a b hab
  exact elementaryUnit_injective i j h (congrArg Subtype.val hab)

theorem cylinder_transposition_factorization [CharP R 2] (P Q : R)
    (hPP : P * P = 0) (hPQP : P * Q * P = P) :
    (1 + P) * (1 + Q) * (1 + P) =
      1 - P * Q - Q * P + P + Q := by
  simp only [CharTwo.sub_eq_add]
  have hthree : (3 : ℤ) • P = P := by
    rw [zsmul_eq_mul, CharTwo.intCast_eq_mod]
    norm_num
  noncomm_ring [hPP, hPQP]
  simp only [hthree]

theorem elementaryUnit_commutator (i j k : ι)
    (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k) (a b : R) :
    ⁅elementaryUnit i j hij a, elementaryUnit j k hjk b⁆ =
      elementaryUnit i k hik (a * b) := by
  apply Units.ext
  change
    (1 + Matrix.single i j a) * (1 + Matrix.single j k b) *
      (1 - Matrix.single i j a) * (1 - Matrix.single j k b) =
      1 + Matrix.single i k (a * b)
  have hxx := single_mul_self_eq_zero i j hij a
  have hyy := single_mul_self_eq_zero j k hjk b
  have hyx : Matrix.single j k b * Matrix.single i j a = 0 :=
    Matrix.single_mul_single_of_ne (c := b) j k i hik.symm a
  have hxy : Matrix.single i j a * Matrix.single j k b =
      Matrix.single i k (a * b) :=
    Matrix.single_mul_single_same (c := a) i j k b
  have hzx : Matrix.single i k (a * b) * Matrix.single i j a = 0 :=
    Matrix.single_mul_single_of_ne (c := a * b) i k i hik.symm a
  have hzy : Matrix.single i k (a * b) * Matrix.single j k b = 0 :=
    Matrix.single_mul_single_of_ne (c := a * b) i k j hjk.symm b
  have hzz := single_mul_self_eq_zero i k hik (a * b)
  noncomm_ring [hxx, hyy, hyx, hxy, hzx, hzy, hzz]

theorem elementaryUnit_mem_of_two_step
    (H : Subgroup (Matrix ι ι R)ˣ) (i j k : ι)
    (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k) (a : R)
    (hleft : elementaryUnit i j hij a ∈ H)
    (hright : elementaryUnit j k hjk 1 ∈ H) :
    elementaryUnit i k hik a ∈ H := by
  have hc : ⁅elementaryUnit i j hij a, elementaryUnit j k hjk 1⁆ ∈ H := by
    rw [commutatorElement_def]
    exact H.mul_mem (H.mul_mem (H.mul_mem hleft hright) (H.inv_mem hleft))
      (H.inv_mem hright)
  rw [elementaryUnit_commutator i j k hij hjk hik a 1] at hc
  simpa using hc

end NoncommutativeElementaryGroup

section FiniteGeneration

variable {R : Type*} [Ring R]

noncomputable def finiteElementaryGenerators [DecidableEq R]
    (n : ℕ) (s : Finset R) : Finset (Matrix (Fin n) (Fin n) R)ˣ :=
  Finset.univ.biUnion (fun i : Fin n =>
    Finset.univ.biUnion (fun j : Fin n =>
      if h : i ≠ j then (insert 1 s).image (elementaryUnit i j h) else ∅))

theorem mem_finiteElementaryGenerators [DecidableEq R] (n : ℕ) (s : Finset R)
    (z : (Matrix (Fin n) (Fin n) R)ˣ) :
    z ∈ finiteElementaryGenerators n s ↔
      ∃ (i j : Fin n) (h : i ≠ j) (a : R),
        a ∈ insert 1 s ∧ elementaryUnit i j h a = z := by
  constructor
  · intro hz
    unfold finiteElementaryGenerators at hz
    obtain ⟨i, _, hi⟩ := Finset.mem_biUnion.mp hz
    obtain ⟨j, _, hj⟩ := Finset.mem_biUnion.mp hi
    by_cases h : i ≠ j
    · rw [dif_pos h] at hj
      obtain ⟨a, ha, rfl⟩ := Finset.mem_image.mp hj
      exact ⟨i, j, h, a, ha, rfl⟩
    · rw [dif_neg h] at hj
      simp at hj
  · rintro ⟨i, j, h, a, ha, rfl⟩
    unfold finiteElementaryGenerators
    apply Finset.mem_biUnion.mpr
    refine ⟨i, Finset.mem_univ i, ?_⟩
    apply Finset.mem_biUnion.mpr
    refine ⟨j, Finset.mem_univ j, ?_⟩
    rw [dif_pos h]
    exact Finset.mem_image.mpr ⟨a, ha, rfl⟩

variable [Algebra (ZMod 2) R]

def elementaryCoefficientSubalgebra (n : ℕ) (hn : 2 < n)
    (H : Subgroup (Matrix (Fin n) (Fin n) R)ˣ)
    (hunit : ∀ (i j : Fin n) (h : i ≠ j), elementaryUnit i j h (1 : R) ∈ H) :
    Subalgebra (ZMod 2) R where
  carrier :=
    {a | ∀ (i j : Fin n) (h : i ≠ j), elementaryUnit i j h a ∈ H}
  add_mem' := by
    intro a b ha hb i j hij
    rw [← elementaryUnit_mul]
    exact H.mul_mem (ha i j hij) (hb i j hij)
  mul_mem' := by
    intro a b ha hb i j hij
    obtain ⟨k, hki, hkj⟩ := Fin.exists_ne_and_ne_of_two_lt i j hn
    have hik : i ≠ k := hki.symm
    have hleft := ha i k hik
    have hright := hb k j hkj
    have hc : ⁅elementaryUnit i k hik a, elementaryUnit k j hkj b⁆ ∈ H := by
      rw [commutatorElement_def]
      exact H.mul_mem
        (H.mul_mem (H.mul_mem hleft hright) (H.inv_mem hleft))
        (H.inv_mem hright)
    rw [elementaryUnit_commutator i k j hik hkj hij a b] at hc
    exact hc
  algebraMap_mem' := by
    intro z
    have hz : z = 0 ∨ z = 1 := by
      fin_cases z
      · exact Or.inl rfl
      · exact Or.inr rfl
    rcases hz with rfl | rfl
    · intro i j hij
      simpa only [map_zero, elementaryUnit_zero] using H.one_mem
    · intro i j hij
      simpa only [map_one] using hunit i j hij

theorem elementaryGroup_finitelyGenerated
    [Algebra.FiniteType (ZMod 2) R]
    (n : ℕ) (hn : 2 < n) :
    Group.FG (elementaryGroup (Fin n) R) := by
  classical
  obtain ⟨s, hs⟩ := Algebra.FiniteType.out (R := ZMod 2) (A := R)
  let t : Finset (Matrix (Fin n) (Fin n) R)ˣ :=
    finiteElementaryGenerators n s
  let H : Subgroup (Matrix (Fin n) (Fin n) R)ˣ :=
    Subgroup.closure (t : Set (Matrix (Fin n) (Fin n) R)ˣ)
  have hunit : ∀ (i j : Fin n) (h : i ≠ j),
      elementaryUnit i j h (1 : R) ∈ H := by
    intro i j hij
    apply Subgroup.subset_closure
    change elementaryUnit i j hij (1 : R) ∈ finiteElementaryGenerators n s
    exact (mem_finiteElementaryGenerators n s _).mpr
      ⟨i, j, hij, 1, Finset.mem_insert_self 1 s, rfl⟩
  let C : Subalgebra (ZMod 2) R :=
    elementaryCoefficientSubalgebra n hn H hunit
  have hgen : (s : Set R) ⊆ (C : Set R) := by
    intro a ha i j hij
    apply Subgroup.subset_closure
    change elementaryUnit i j hij a ∈ finiteElementaryGenerators n s
    exact (mem_finiteElementaryGenerators n s _).mpr
      ⟨i, j, hij, a, Finset.mem_insert_of_mem ha, rfl⟩
  have hC : C = ⊤ := by
    apply top_unique
    rw [← hs]
    exact Algebra.adjoin_le hgen
  have heq : H = elementaryGroup (Fin n) R := by
    apply le_antisymm
    · change Subgroup.closure (t : Set (Matrix (Fin n) (Fin n) R)ˣ) ≤ _
      rw [Subgroup.closure_le]
      intro z hz
      change z ∈ finiteElementaryGenerators n s at hz
      obtain ⟨i, j, hij, a, _, rfl⟩ :=
        (mem_finiteElementaryGenerators n s z).mp hz
      exact elementaryUnit_mem i j hij a
    · rw [elementaryGroup, Subgroup.closure_le]
      rintro _ ⟨i, j, hij, a, rfl⟩
      have ha : a ∈ C := by simp [hC]
      exact ha i j hij
  apply (Group.fg_iff_subgroup_fg (elementaryGroup (Fin n) R)).mpr
  exact ⟨t, heq⟩

theorem elementaryGroup_three_finitelyGenerated
    [Algebra.FiniteType (ZMod 2) R] :
    Group.FG (elementaryGroup (Fin 3) R) :=
  elementaryGroup_finitelyGenerated 3 (by decide)

end FiniteGeneration

abbrev binaryLeavittElementaryGroup (n : ℕ) : Type :=
  elementaryGroup (Fin n) BinaryLeavitt

def completePrefixMatrixEquiv {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (hcomplete : MatrixCorner.codeIdempotent
      (fun i => leavittWordS (E.word i))
      (fun i => leavittWordT (E.word i)) = 1) :
    Matrix ι ι BinaryLeavitt ≃+* BinaryLeavitt where
  toFun := MatrixCorner.encode
    (fun i => leavittWordS (E.word i))
    (fun i => leavittWordT (E.word i))
  invFun := MatrixCorner.decode
    (fun i => leavittWordS (E.word i))
    (fun i => leavittWordT (E.word i))
  left_inv := MatrixCorner.decode_encode _ _ (binaryPrefixCode_orthogonal E)
  right_inv x := by
    rw [MatrixCorner.encode_decode, hcomplete]
    simp
  map_mul' := MatrixCorner.encode_mul _ _ (binaryPrefixCode_orthogonal E)
  map_add' M N := by
    simp [MatrixCorner.encode, Matrix.add_apply, mul_add, add_mul,
      Finset.sum_add_distrib]

def completePrefixUnitEquiv {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (hcomplete : MatrixCorner.codeIdempotent
      (fun i => leavittWordS (E.word i))
      (fun i => leavittWordT (E.word i)) = 1) :
    (Matrix ι ι BinaryLeavitt)ˣ ≃* BinaryLeavittˣ :=
  Units.mapEquiv (completePrefixMatrixEquiv E hcomplete).toMulEquiv

theorem completePrefixUnitEquiv_elementaryUnit
    {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (hcomplete : MatrixCorner.codeIdempotent
      (fun i => leavittWordS (E.word i))
      (fun i => leavittWordT (E.word i)) = 1)
    (i j : ι) (hij : i ≠ j) (a : BinaryLeavitt) :
    completePrefixUnitEquiv E hcomplete (elementaryUnit i j hij a) =
      prefixElementaryUnit E i j hij a := by
  apply Units.ext
  change
    MatrixCorner.encode
      (fun k => leavittWordS (E.word k))
      (fun k => leavittWordT (E.word k))
      (1 + Matrix.single i j a) =
        1 + leavittWordS (E.word i) * a * leavittWordT (E.word j)
  have h₁ :
      MatrixCorner.encode
        (fun k => leavittWordS (E.word k))
        (fun k => leavittWordT (E.word k))
        (1 : Matrix ι ι BinaryLeavitt) = 1 := by
    rw [MatrixCorner.encode_one, hcomplete]
  calc
    MatrixCorner.encode
        (fun k => leavittWordS (E.word k))
        (fun k => leavittWordT (E.word k))
        (1 + Matrix.single i j a) =
      MatrixCorner.encode
        (fun k => leavittWordS (E.word k))
        (fun k => leavittWordT (E.word k))
        (1 : Matrix ι ι BinaryLeavitt) +
      MatrixCorner.encode
        (fun k => leavittWordS (E.word k))
        (fun k => leavittWordT (E.word k))
        (Matrix.single i j a) := by
          simp [MatrixCorner.encode, Matrix.add_apply, mul_add, add_mul,
            Finset.sum_add_distrib]
    _ = 1 + leavittWordS (E.word i) * a * leavittWordT (E.word j) := by
      rw [h₁]
      simp [MatrixCorner.encode, Matrix.single_apply, mul_ite, ite_mul, ite_and]

theorem completePrefixElementaryGroup_map
    {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (hcomplete : MatrixCorner.codeIdempotent
      (fun i => leavittWordS (E.word i))
      (fun i => leavittWordT (E.word i)) = 1) :
    (elementaryGroup ι BinaryLeavitt).map
        (completePrefixUnitEquiv E hcomplete).toMonoidHom =
      prefixElementaryGroup E := by
  unfold elementaryGroup prefixElementaryGroup
  rw [MonoidHom.map_closure]
  congr 1
  ext z
  constructor
  · rintro ⟨_, ⟨i, j, hij, a, rfl⟩, hz⟩
    exact ⟨i, j, hij, a,
      (completePrefixUnitEquiv_elementaryUnit E hcomplete i j hij a).symm.trans hz⟩
  · rintro ⟨i, j, hij, a, rfl⟩
    exact ⟨elementaryUnit i j hij a, ⟨i, j, hij, a, rfl⟩,
      completePrefixUnitEquiv_elementaryUnit E hcomplete i j hij a⟩

def ninePrefixElementaryGroupEquiv :
    binaryLeavittElementaryGroup 9 ≃* prefixElementaryGroup ninePrefixCode :=
  ((completePrefixUnitEquiv ninePrefixCode ninePrefixCode_complete).subgroupMap
      (elementaryGroup (Fin 9) BinaryLeavitt)).trans
    (MulEquiv.subgroupCongr
      (completePrefixElementaryGroup_map ninePrefixCode ninePrefixCode_complete))

def idempotentCornerUnitExtension {A : Type*} [Ring A]
    {e : A} (he : IsIdempotentElem e) : he.Cornerˣ →* Aˣ where
  toFun u :=
    { val := u.val.val + (1 - e)
      inv := u.inv.val + (1 - e)
      val_inv := by
        have hu := (Subsemigroup.mem_corner_iff he).mp u.val.property
        have hv := (Subsemigroup.mem_corner_iff he).mp u.inv.property
        have huv : u.val.val * u.inv.val = e := by
          have h := congrArg (fun z : he.Corner => z.val) u.val_inv
          exact h
        noncomm_ring [he.eq, hu.1, hu.2, hv.1, hv.2, huv]
      inv_val := by
        have hu := (Subsemigroup.mem_corner_iff he).mp u.val.property
        have hv := (Subsemigroup.mem_corner_iff he).mp u.inv.property
        have hvu : u.inv.val * u.val.val = e := by
          have h := congrArg (fun z : he.Corner => z.val) u.inv_val
          exact h
        noncomm_ring [he.eq, hu.1, hu.2, hv.1, hv.2, hvu] }
  map_one' := by
    apply Units.ext
    change e + (1 - e) = 1
    noncomm_ring
  map_mul' u v := by
    apply Units.ext
    have hu := (Subsemigroup.mem_corner_iff he).mp u.val.property
    have hv := (Subsemigroup.mem_corner_iff he).mp v.val.property
    change
      u.val.val * v.val.val + (1 - e) =
        (u.val.val + (1 - e)) * (v.val.val + (1 - e))
    noncomm_ring [he.eq, hu.1, hu.2, hv.1, hv.2]

theorem idempotentCornerUnitExtension_injective
    {A : Type*} [Ring A] {e : A} (he : IsIdempotentElem e) :
    Function.Injective (idempotentCornerUnitExtension he) := by
  intro u v huv
  apply Units.ext
  apply Subtype.ext
  have h := congrArg (fun z : Aˣ => (z : A)) huv
  change u.val.val + (1 - e) = v.val.val + (1 - e) at h
  exact add_right_cancel h

def prefixCornerUnitHom {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι) :
    (Matrix ι ι BinaryLeavitt)ˣ →* BinaryLeavittˣ :=
  (idempotentCornerUnitExtension
    (MatrixCorner.codeIdempotent_isIdempotent
      (fun i => leavittWordS (E.word i))
      (fun i => leavittWordT (E.word i))
      (binaryPrefixCode_orthogonal E))).comp
    (Units.mapEquiv (binaryPrefixCornerEquiv E).toMulEquiv).toMonoidHom

theorem prefixCornerUnitHom_injective
    {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι) :
    Function.Injective (prefixCornerUnitHom E) := by
  exact (idempotentCornerUnitExtension_injective
    (MatrixCorner.codeIdempotent_isIdempotent
      (fun i => leavittWordS (E.word i))
      (fun i => leavittWordT (E.word i))
      (binaryPrefixCode_orthogonal E))).comp
    (Units.mapEquiv (binaryPrefixCornerEquiv E).toMulEquiv).injective

theorem prefixCornerUnitHom_elementaryUnit
    {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (i j : ι) (hij : i ≠ j) (a : BinaryLeavitt) :
    prefixCornerUnitHom E (elementaryUnit i j hij a) =
      prefixElementaryUnit E i j hij a := by
  apply Units.ext
  change
    MatrixCorner.encode
      (fun k => leavittWordS (E.word k))
      (fun k => leavittWordT (E.word k))
      (1 + Matrix.single i j a) +
      (1 - MatrixCorner.codeIdempotent
        (fun k => leavittWordS (E.word k))
        (fun k => leavittWordT (E.word k))) =
      1 + leavittWordS (E.word i) * a * leavittWordT (E.word j)
  have henc :
      MatrixCorner.encode
        (fun k => leavittWordS (E.word k))
        (fun k => leavittWordT (E.word k))
        (1 + Matrix.single i j a) =
      MatrixCorner.codeIdempotent
        (fun k => leavittWordS (E.word k))
        (fun k => leavittWordT (E.word k)) +
        leavittWordS (E.word i) * a * leavittWordT (E.word j) := by
    calc
      MatrixCorner.encode
          (fun k => leavittWordS (E.word k))
          (fun k => leavittWordT (E.word k))
          (1 + Matrix.single i j a) =
        MatrixCorner.encode
          (fun k => leavittWordS (E.word k))
          (fun k => leavittWordT (E.word k))
          (1 : Matrix ι ι BinaryLeavitt) +
        MatrixCorner.encode
          (fun k => leavittWordS (E.word k))
          (fun k => leavittWordT (E.word k))
          (Matrix.single i j a) := by
            simp [MatrixCorner.encode, Matrix.add_apply, mul_add, add_mul,
              Finset.sum_add_distrib]
      _ = MatrixCorner.codeIdempotent
          (fun k => leavittWordS (E.word k))
          (fun k => leavittWordT (E.word k)) +
          leavittWordS (E.word i) * a * leavittWordT (E.word j) := by
            rw [MatrixCorner.encode_one]
            simp [MatrixCorner.encode, Matrix.single_apply,
              mul_ite, ite_mul, ite_and]
  rw [henc]
  noncomm_ring

theorem prefixCornerElementaryGroup_map
    {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι) :
    (elementaryGroup ι BinaryLeavitt).map (prefixCornerUnitHom E) =
      prefixElementaryGroup E := by
  unfold elementaryGroup prefixElementaryGroup
  rw [MonoidHom.map_closure]
  congr 1
  ext z
  constructor
  · rintro ⟨_, ⟨i, j, hij, a, rfl⟩, hz⟩
    exact ⟨i, j, hij, a,
      (prefixCornerUnitHom_elementaryUnit E i j hij a).symm.trans hz⟩
  · rintro ⟨i, j, hij, a, rfl⟩
    exact ⟨elementaryUnit i j hij a, ⟨i, j, hij, a, rfl⟩,
      prefixCornerUnitHom_elementaryUnit E i j hij a⟩

def alphaPrefixElementaryGroupEquiv :
    binaryLeavittElementaryGroup 3 ≃* prefixElementaryGroup alphaPrefixCode :=
  ((elementaryGroup (Fin 3) BinaryLeavitt).equivMapOfInjective
      (prefixCornerUnitHom alphaPrefixCode)
      (prefixCornerUnitHom_injective alphaPrefixCode)).trans
    (MulEquiv.subgroupCongr
      (prefixCornerElementaryGroup_map alphaPrefixCode))

namespace SourceGeneration

open scoped commutatorElement

def sourceGeneratedGroup : Subgroup BinaryLeavittˣ :=
  Subgroup.closure
    ((prefixElementaryGroup alphaPrefixCode : Set BinaryLeavittˣ) ∪
      {compressionU, compressionV})

theorem alphaRoot_mem_sourceGenerated
    (i j : Fin 3) (hij : i ≠ j) (a : BinaryLeavitt) :
    prefixElementaryUnit alphaPrefixCode i j hij a ∈ sourceGeneratedGroup := by
  apply Subgroup.subset_closure
  apply Set.mem_union_left
  exact Subgroup.subset_closure ⟨i, j, hij, a, rfl⟩

theorem compressionU_mem_sourceGenerated :
    compressionU ∈ sourceGeneratedGroup := by
  apply Subgroup.subset_closure
  apply Set.mem_union_right
  simp

theorem compressionV_mem_sourceGenerated :
    compressionV ∈ sourceGeneratedGroup := by
  apply Subgroup.subset_closure
  apply Set.mem_union_right
  simp

theorem prefixTable_mul_wordS {ι : Type*} [Fintype ι] [DecidableEq ι]
    (source target : BinaryPrefixCode ι) (i : ι) :
    prefixTable source target * leavittWordS (source.word i) =
      leavittWordS (target.word i) := by
  calc
    prefixTable source target * leavittWordS (source.word i) =
        ∑ j, leavittWordS (target.word j) *
          (leavittWordT (source.word j) * leavittWordS (source.word i)) := by
            simp [prefixTable, Finset.sum_mul, mul_assoc]
    _ = leavittWordS (target.word i) := by
      simp [binaryPrefixCode_orthogonal]

theorem wordT_mul_prefixTable {ι : Type*} [Fintype ι] [DecidableEq ι]
    (source target : BinaryPrefixCode ι) (i : ι) :
    leavittWordT (target.word i) * prefixTable source target =
      leavittWordT (source.word i) := by
  calc
    leavittWordT (target.word i) * prefixTable source target =
        ∑ j, (leavittWordT (target.word i) *
          leavittWordS (target.word j)) * leavittWordT (source.word j) := by
            simp [prefixTable, Finset.mul_sum, mul_assoc]
    _ = leavittWordT (source.word i) := by
      simp [binaryPrefixCode_orthogonal]

theorem leavittWordS_split (a : List (Fin 2)) :
    leavittWordS a =
      leavittWordS (a ++ [0]) * leavittT 0 +
        leavittWordS (a ++ [1]) * leavittT 1 := by
  calc
    leavittWordS a = leavittWordS a *
        (leavittS 0 * leavittT 0 + leavittS 1 * leavittT 1) := by
          rw [leavitt_partition]
          simp
    _ = leavittWordS (a ++ [0]) * leavittT 0 +
        leavittWordS (a ++ [1]) * leavittT 1 := by
          simp [leavittWordS_append, leavittWordS, mul_add, mul_assoc]

theorem leavittWordT_split (a : List (Fin 2)) :
    leavittWordT a =
      leavittS 0 * leavittWordT (a ++ [0]) +
        leavittS 1 * leavittWordT (a ++ [1]) := by
  calc
    leavittWordT a =
        (leavittS 0 * leavittT 0 + leavittS 1 * leavittT 1) *
          leavittWordT a := by
            rw [leavitt_partition]
            simp
    _ = leavittS 0 * leavittWordT (a ++ [0]) +
        leavittS 1 * leavittWordT (a ++ [1]) := by
          simp [leavittWordT_append, leavittWordT, add_mul, mul_assoc]

def betaNineIndex (i : Fin 3) : Fin 9 :=
  ⟨3 * i.val + 1, by omega⟩

def nuNineIndex (i : Fin 3) : Fin 9 :=
  ⟨3 * i.val + 2, by omega⟩

@[simp] theorem nineWord_betaNineIndex (i : Fin 3) :
    nineWord (betaNineIndex i) = betaWord i := by
  fin_cases i <;> rfl

@[simp] theorem nineWord_nuNineIndex (i : Fin 3) :
    nineWord (nuNineIndex i) = nuWord i := by
  fin_cases i <;> rfl

@[simp] theorem uWord_betaNineIndex (i : Fin 3) :
    uWord (betaNineIndex i) = alphaWord i ++ [1] := by
  fin_cases i <;> rfl

@[simp] theorem vWord_nuNineIndex (i : Fin 3) :
    vWord (nuNineIndex i) = alphaWord i ++ [1] := by
  fin_cases i <;> rfl

theorem compressionU_inv_mul_alphaWordS (i : Fin 3) :
    (↑(compressionU⁻¹) : BinaryLeavitt) * leavittWordS (alphaWord i) =
      leavittWordS (alphaWord i) * leavittT 0 +
        leavittWordS (betaWord i) * leavittT 1 := by
  calc
    (↑(compressionU⁻¹) : BinaryLeavitt) * leavittWordS (alphaWord i) =
        (↑(compressionU⁻¹) : BinaryLeavitt) *
          (leavittWordS (alphaWord i ++ [0]) * leavittT 0 +
            leavittWordS (alphaWord i ++ [1]) * leavittT 1) :=
      congrArg ((↑(compressionU⁻¹) : BinaryLeavitt) * ·)
        (leavittWordS_split (alphaWord i))
    _ = (prefixTable uPrefixCode ninePrefixCode *
          leavittWordS (alphaWord i ++ [0])) * leavittT 0 +
        (prefixTable uPrefixCode ninePrefixCode *
          leavittWordS (alphaWord i ++ [1])) * leavittT 1 := by
            change
              prefixTable uPrefixCode ninePrefixCode *
                  (leavittWordS (alphaWord i ++ [0]) * leavittT 0 +
                    leavittWordS (alphaWord i ++ [1]) * leavittT 1) = _
            simp [mul_add, mul_assoc]
    _ = leavittWordS (alphaWord i) * leavittT 0 +
        leavittWordS (betaWord i) * leavittT 1 := by
          simpa only [ninePrefixCode, uPrefixCode, nineWord_alphaNineIndex,
            nineWord_betaNineIndex, uWord_alphaNineIndex, uWord_betaNineIndex]
            using congrArg₂ (· + ·)
              (congrArg (· * leavittT 0)
                (prefixTable_mul_wordS uPrefixCode ninePrefixCode
                  (alphaNineIndex i)))
              (congrArg (· * leavittT 1)
                (prefixTable_mul_wordS uPrefixCode ninePrefixCode
                  (betaNineIndex i)))

theorem alphaWordT_mul_compressionU (i : Fin 3) :
    leavittWordT (alphaWord i) * (compressionU : BinaryLeavitt) =
      leavittS 0 * leavittWordT (alphaWord i) +
        leavittS 1 * leavittWordT (betaWord i) := by
  calc
    leavittWordT (alphaWord i) * (compressionU : BinaryLeavitt) =
        (leavittS 0 * leavittWordT (alphaWord i ++ [0]) +
          leavittS 1 * leavittWordT (alphaWord i ++ [1])) *
          (compressionU : BinaryLeavitt) :=
      congrArg (· * (compressionU : BinaryLeavitt))
        (leavittWordT_split (alphaWord i))
    _ = leavittS 0 * (leavittWordT (alphaWord i ++ [0]) *
          prefixTable ninePrefixCode uPrefixCode) +
        leavittS 1 * (leavittWordT (alphaWord i ++ [1]) *
          prefixTable ninePrefixCode uPrefixCode) := by
            change
              (leavittS 0 * leavittWordT (alphaWord i ++ [0]) +
                leavittS 1 * leavittWordT (alphaWord i ++ [1])) *
                prefixTable ninePrefixCode uPrefixCode = _
            simp [add_mul, mul_assoc]
    _ = leavittS 0 * leavittWordT (alphaWord i) +
        leavittS 1 * leavittWordT (betaWord i) := by
          simpa only [ninePrefixCode, uPrefixCode, nineWord_alphaNineIndex,
            nineWord_betaNineIndex, uWord_alphaNineIndex, uWord_betaNineIndex]
            using congrArg₂ (· + ·)
              (congrArg (leavittS 0 * ·)
                (wordT_mul_prefixTable ninePrefixCode uPrefixCode
                  (alphaNineIndex i)))
              (congrArg (leavittS 1 * ·)
                (wordT_mul_prefixTable ninePrefixCode uPrefixCode
                  (betaNineIndex i)))

def alphaBetaNineIndex (p : Fin 2) (i : Fin 3) : Fin 9 :=
  ⟨3 * i.val + p.val, by omega⟩

theorem alphaBetaNineIndex_ne {i j : Fin 3} (hij : i ≠ j)
    (p q : Fin 2) : alphaBetaNineIndex p i ≠ alphaBetaNineIndex q j := by
  intro h
  apply hij
  apply Fin.ext
  have hv := congrArg Fin.val h
  change 3 * i.val + p.val = 3 * j.val + q.val at hv
  omega

@[simp] theorem nineWord_alphaBetaNineIndex (p : Fin 2) (i : Fin 3) :
    nineWord (alphaBetaNineIndex p i) =
      if p = 0 then alphaWord i else betaWord i := by
  fin_cases p <;> fin_cases i <;> rfl

theorem binaryBlockSandwich
    (x₀ x₁ y₀ y₁ a : BinaryLeavitt) (p q : Fin 2) :
    (x₀ * leavittT 0 + x₁ * leavittT 1) *
        (leavittS p * a * leavittT q) *
        (leavittS 0 * y₀ + leavittS 1 * y₁) =
      (if p = 0 then x₀ else x₁) * a *
        (if q = 0 then y₀ else y₁) := by
  have hact (r s : Fin 2) (x : BinaryLeavitt) :
      leavittT r * (leavittS s * x) = if r = s then x else 0 := by
    rw [← mul_assoc, leavittT_mul_S]
    split <;> simp
  fin_cases p <;> fin_cases q <;>
    simp [add_mul, mul_add, mul_assoc, hact]

theorem alphaBetaRoot_mem_sourceGenerated
    (i j : Fin 3) (hij : i ≠ j) (p q : Fin 2) (a : BinaryLeavitt) :
    prefixElementaryUnit ninePrefixCode
      (alphaBetaNineIndex p i) (alphaBetaNineIndex q j)
      (alphaBetaNineIndex_ne hij p q) a ∈ sourceGeneratedGroup := by
  have hα := alphaRoot_mem_sourceGenerated i j hij
    (leavittS p * a * leavittT q)
  have hU := compressionU_mem_sourceGenerated
  have hconj :
      compressionU⁻¹ *
        prefixElementaryUnit alphaPrefixCode i j hij
          (leavittS p * a * leavittT q) * compressionU ∈
        sourceGeneratedGroup :=
    sourceGeneratedGroup.mul_mem
      (sourceGeneratedGroup.mul_mem (sourceGeneratedGroup.inv_mem hU) hα) hU
  have heq :
      compressionU⁻¹ *
        prefixElementaryUnit alphaPrefixCode i j hij
          (leavittS p * a * leavittT q) * compressionU =
        prefixElementaryUnit ninePrefixCode
          (alphaBetaNineIndex p i) (alphaBetaNineIndex q j)
          (alphaBetaNineIndex_ne hij p q) a := by
    apply Units.ext
    change
      (↑(compressionU⁻¹) : BinaryLeavitt) *
          (1 + leavittWordS (alphaWord i) *
            (leavittS p * a * leavittT q) *
            leavittWordT (alphaWord j)) *
          (compressionU : BinaryLeavitt) =
        1 + leavittWordS (nineWord (alphaBetaNineIndex p i)) * a *
          leavittWordT (nineWord (alphaBetaNineIndex q j))
    calc
      (↑(compressionU⁻¹) : BinaryLeavitt) *
          (1 + leavittWordS (alphaWord i) *
            (leavittS p * a * leavittT q) *
            leavittWordT (alphaWord j)) *
          (compressionU : BinaryLeavitt) =
        1 + ((↑(compressionU⁻¹) : BinaryLeavitt) *
            leavittWordS (alphaWord i)) *
          (leavittS p * a * leavittT q) *
          (leavittWordT (alphaWord j) * (compressionU : BinaryLeavitt)) := by
            simp [mul_add, add_mul, mul_assoc]
      _ = 1 +
          (leavittWordS (alphaWord i) * leavittT 0 +
            leavittWordS (betaWord i) * leavittT 1) *
          (leavittS p * a * leavittT q) *
          (leavittS 0 * leavittWordT (alphaWord j) +
            leavittS 1 * leavittWordT (betaWord j)) := by
              rw [compressionU_inv_mul_alphaWordS,
                alphaWordT_mul_compressionU]
      _ = 1 + leavittWordS (nineWord (alphaBetaNineIndex p i)) * a *
          leavittWordT (nineWord (alphaBetaNineIndex q j)) := by
            rw [binaryBlockSandwich]
            simp only [nineWord_alphaBetaNineIndex]
            split_ifs <;> rfl
  exact heq ▸ hconj

def prefixElementaryEntry {ι : Type*} (E : BinaryPrefixCode ι)
    (i j : ι) (a : BinaryLeavitt) : BinaryLeavitt :=
  leavittWordS (E.word i) * a * leavittWordT (E.word j)

theorem prefixElementaryEntry_mul {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι) (i j k l : ι)
    (a b : BinaryLeavitt) :
    prefixElementaryEntry E i j a * prefixElementaryEntry E k l b =
      if j = k then prefixElementaryEntry E i l (a * b) else 0 := by
  calc
    prefixElementaryEntry E i j a * prefixElementaryEntry E k l b =
        leavittWordS (E.word i) * a *
          (leavittWordT (E.word j) * leavittWordS (E.word k)) *
          b * leavittWordT (E.word l) := by
            simp [prefixElementaryEntry, mul_assoc]
    _ = if j = k then prefixElementaryEntry E i l (a * b) else 0 := by
      rw [binaryPrefixCode_orthogonal E j k]
      split <;> simp [prefixElementaryEntry, mul_assoc]

theorem prefixElementaryUnit_commutator {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι) (i j k : ι)
    (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (a b : BinaryLeavitt) :
    ⁅prefixElementaryUnit E i j hij a,
      prefixElementaryUnit E j k hjk b⁆ =
      prefixElementaryUnit E i k hik (a * b) := by
  let x := prefixElementaryEntry E i j a
  let y := prefixElementaryEntry E j k b
  let z := prefixElementaryEntry E i k (a * b)
  have hxx : x * x = 0 := by
    change prefixElementaryEntry E i j a *
      prefixElementaryEntry E i j a = 0
    rw [prefixElementaryEntry_mul, if_neg hij.symm]
  have hyy : y * y = 0 := by
    change prefixElementaryEntry E j k b *
      prefixElementaryEntry E j k b = 0
    rw [prefixElementaryEntry_mul, if_neg hjk.symm]
  have hyx : y * x = 0 := by
    change prefixElementaryEntry E j k b *
      prefixElementaryEntry E i j a = 0
    rw [prefixElementaryEntry_mul, if_neg hik.symm]
  have hxy : x * y = z := by
    change prefixElementaryEntry E i j a *
      prefixElementaryEntry E j k b =
      prefixElementaryEntry E i k (a * b)
    rw [prefixElementaryEntry_mul, if_pos rfl]
  have hzx : z * x = 0 := by
    change prefixElementaryEntry E i k (a * b) *
      prefixElementaryEntry E i j a = 0
    rw [prefixElementaryEntry_mul, if_neg hik.symm]
  have hzy : z * y = 0 := by
    change prefixElementaryEntry E i k (a * b) *
      prefixElementaryEntry E j k b = 0
    rw [prefixElementaryEntry_mul, if_neg hjk.symm]
  have hzz : z * z = 0 := by
    change prefixElementaryEntry E i k (a * b) *
      prefixElementaryEntry E i k (a * b) = 0
    rw [prefixElementaryEntry_mul, if_neg hik.symm]
  have hxz : x * z = 0 := by
    change prefixElementaryEntry E i j a *
      prefixElementaryEntry E i k (a * b) = 0
    rw [prefixElementaryEntry_mul, if_neg hij.symm]
  have hyz : y * z = 0 := by
    change prefixElementaryEntry E j k b *
      prefixElementaryEntry E i k (a * b) = 0
    rw [prefixElementaryEntry_mul, if_neg hik.symm]
  apply Units.ext
  change (1 + x) * (1 + y) * (1 - x) * (1 - y) = 1 + z
  noncomm_ring [hxx, hyy, hyx, hxy, hzx, hzy, hzz, hxz, hyz]

theorem prefixElementaryUnit_mem_of_two_step
    {ι : Type*} [DecidableEq ι] (E : BinaryPrefixCode ι)
    (H : Subgroup BinaryLeavittˣ) (i j k : ι)
    (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k) (a : BinaryLeavitt)
    (hleft : prefixElementaryUnit E i j hij a ∈ H)
    (hright : prefixElementaryUnit E j k hjk 1 ∈ H) :
    prefixElementaryUnit E i k hik a ∈ H := by
  have hc :
      ⁅prefixElementaryUnit E i j hij a,
        prefixElementaryUnit E j k hjk 1⁆ ∈ H := by
    rw [commutatorElement_def]
    exact H.mul_mem
      (H.mul_mem (H.mul_mem hleft hright) (H.inv_mem hleft))
      (H.inv_mem hright)
  rw [prefixElementaryUnit_commutator E i j k hij hjk hik a 1] at hc
  simpa using hc

theorem prefixElementaryGroup_le_of_hub
    {ι : Type*} [DecidableEq ι] (E : BinaryPrefixCode ι)
    (H : Subgroup BinaryLeavittˣ) (k : ι)
    (hto : ∀ (i : ι) (h : i ≠ k) (a : BinaryLeavitt),
      prefixElementaryUnit E i k h a ∈ H)
    (hfrom : ∀ (j : ι) (h : k ≠ j) (a : BinaryLeavitt),
      prefixElementaryUnit E k j h a ∈ H) :
    prefixElementaryGroup E ≤ H := by
  rw [prefixElementaryGroup, Subgroup.closure_le]
  rintro _ ⟨i, j, hij, a, rfl⟩
  by_cases hi : i = k
  · subst k
    exact hfrom j hij a
  by_cases hj : j = k
  · subst k
    exact hto i hij a
  exact prefixElementaryUnit_mem_of_two_step E H i k j
    hi (Ne.symm hj) hij a (hto i hi a) (hfrom j (Ne.symm hj) 1)

theorem compressionV_inv_mul_alphaWordS (i : Fin 3) :
    (↑(compressionV⁻¹) : BinaryLeavitt) * leavittWordS (alphaWord i) =
      leavittWordS (alphaWord i) * leavittT 0 +
        leavittWordS (nuWord i) * leavittT 1 := by
  calc
    (↑(compressionV⁻¹) : BinaryLeavitt) * leavittWordS (alphaWord i) =
        (↑(compressionV⁻¹) : BinaryLeavitt) *
          (leavittWordS (alphaWord i ++ [0]) * leavittT 0 +
            leavittWordS (alphaWord i ++ [1]) * leavittT 1) :=
      congrArg ((↑(compressionV⁻¹) : BinaryLeavitt) * ·)
        (leavittWordS_split (alphaWord i))
    _ = (prefixTable vPrefixCode ninePrefixCode *
          leavittWordS (alphaWord i ++ [0])) * leavittT 0 +
        (prefixTable vPrefixCode ninePrefixCode *
          leavittWordS (alphaWord i ++ [1])) * leavittT 1 := by
            change
              prefixTable vPrefixCode ninePrefixCode *
                  (leavittWordS (alphaWord i ++ [0]) * leavittT 0 +
                    leavittWordS (alphaWord i ++ [1]) * leavittT 1) = _
            simp [mul_add, mul_assoc]
    _ = leavittWordS (alphaWord i) * leavittT 0 +
        leavittWordS (nuWord i) * leavittT 1 := by
          simpa only [ninePrefixCode, vPrefixCode, nineWord_alphaNineIndex,
            nineWord_nuNineIndex, vWord_alphaNineIndex, vWord_nuNineIndex]
            using congrArg₂ (· + ·)
              (congrArg (· * leavittT 0)
                (prefixTable_mul_wordS vPrefixCode ninePrefixCode
                  (alphaNineIndex i)))
              (congrArg (· * leavittT 1)
                (prefixTable_mul_wordS vPrefixCode ninePrefixCode
                  (nuNineIndex i)))

theorem alphaWordT_mul_compressionV (i : Fin 3) :
    leavittWordT (alphaWord i) * (compressionV : BinaryLeavitt) =
      leavittS 0 * leavittWordT (alphaWord i) +
        leavittS 1 * leavittWordT (nuWord i) := by
  calc
    leavittWordT (alphaWord i) * (compressionV : BinaryLeavitt) =
        (leavittS 0 * leavittWordT (alphaWord i ++ [0]) +
          leavittS 1 * leavittWordT (alphaWord i ++ [1])) *
          (compressionV : BinaryLeavitt) :=
      congrArg (· * (compressionV : BinaryLeavitt))
        (leavittWordT_split (alphaWord i))
    _ = leavittS 0 * (leavittWordT (alphaWord i ++ [0]) *
          prefixTable ninePrefixCode vPrefixCode) +
        leavittS 1 * (leavittWordT (alphaWord i ++ [1]) *
          prefixTable ninePrefixCode vPrefixCode) := by
            change
              (leavittS 0 * leavittWordT (alphaWord i ++ [0]) +
                leavittS 1 * leavittWordT (alphaWord i ++ [1])) *
                prefixTable ninePrefixCode vPrefixCode = _
            simp [add_mul, mul_assoc]
    _ = leavittS 0 * leavittWordT (alphaWord i) +
        leavittS 1 * leavittWordT (nuWord i) := by
          simpa only [ninePrefixCode, vPrefixCode, nineWord_alphaNineIndex,
            nineWord_nuNineIndex, vWord_alphaNineIndex, vWord_nuNineIndex]
            using congrArg₂ (· + ·)
              (congrArg (leavittS 0 * ·)
                (wordT_mul_prefixTable ninePrefixCode vPrefixCode
                  (alphaNineIndex i)))
              (congrArg (leavittS 1 * ·)
                (wordT_mul_prefixTable ninePrefixCode vPrefixCode
                  (nuNineIndex i)))

def alphaNuNineIndex (p : Fin 2) (i : Fin 3) : Fin 9 :=
  ⟨3 * i.val + 2 * p.val, by omega⟩

theorem alphaNuNineIndex_ne {i j : Fin 3} (hij : i ≠ j)
    (p q : Fin 2) : alphaNuNineIndex p i ≠ alphaNuNineIndex q j := by
  intro h
  apply hij
  apply Fin.ext
  have hv := congrArg Fin.val h
  change 3 * i.val + 2 * p.val = 3 * j.val + 2 * q.val at hv
  omega

@[simp] theorem nineWord_alphaNuNineIndex (p : Fin 2) (i : Fin 3) :
    nineWord (alphaNuNineIndex p i) =
      if p = 0 then alphaWord i else nuWord i := by
  fin_cases p <;> fin_cases i <;> rfl

theorem alphaNuRoot_mem_sourceGenerated
    (i j : Fin 3) (hij : i ≠ j) (p q : Fin 2) (a : BinaryLeavitt) :
    prefixElementaryUnit ninePrefixCode
      (alphaNuNineIndex p i) (alphaNuNineIndex q j)
      (alphaNuNineIndex_ne hij p q) a ∈ sourceGeneratedGroup := by
  have hα := alphaRoot_mem_sourceGenerated i j hij
    (leavittS p * a * leavittT q)
  have hV := compressionV_mem_sourceGenerated
  have hconj :
      compressionV⁻¹ *
        prefixElementaryUnit alphaPrefixCode i j hij
          (leavittS p * a * leavittT q) * compressionV ∈
        sourceGeneratedGroup :=
    sourceGeneratedGroup.mul_mem
      (sourceGeneratedGroup.mul_mem (sourceGeneratedGroup.inv_mem hV) hα) hV
  have heq :
      compressionV⁻¹ *
        prefixElementaryUnit alphaPrefixCode i j hij
          (leavittS p * a * leavittT q) * compressionV =
        prefixElementaryUnit ninePrefixCode
          (alphaNuNineIndex p i) (alphaNuNineIndex q j)
          (alphaNuNineIndex_ne hij p q) a := by
    apply Units.ext
    change
      (↑(compressionV⁻¹) : BinaryLeavitt) *
          (1 + leavittWordS (alphaWord i) *
            (leavittS p * a * leavittT q) *
            leavittWordT (alphaWord j)) *
          (compressionV : BinaryLeavitt) =
        1 + leavittWordS (nineWord (alphaNuNineIndex p i)) * a *
          leavittWordT (nineWord (alphaNuNineIndex q j))
    calc
      (↑(compressionV⁻¹) : BinaryLeavitt) *
          (1 + leavittWordS (alphaWord i) *
            (leavittS p * a * leavittT q) *
            leavittWordT (alphaWord j)) *
          (compressionV : BinaryLeavitt) =
        1 + ((↑(compressionV⁻¹) : BinaryLeavitt) *
            leavittWordS (alphaWord i)) *
          (leavittS p * a * leavittT q) *
          (leavittWordT (alphaWord j) * (compressionV : BinaryLeavitt)) := by
            simp [mul_add, add_mul, mul_assoc]
      _ = 1 +
          (leavittWordS (alphaWord i) * leavittT 0 +
            leavittWordS (nuWord i) * leavittT 1) *
          (leavittS p * a * leavittT q) *
          (leavittS 0 * leavittWordT (alphaWord j) +
            leavittS 1 * leavittWordT (nuWord j)) := by
              rw [compressionV_inv_mul_alphaWordS,
                alphaWordT_mul_compressionV]
      _ = 1 + leavittWordS (nineWord (alphaNuNineIndex p i)) * a *
          leavittWordT (nineWord (alphaNuNineIndex q j)) := by
            rw [binaryBlockSandwich]
            simp only [nineWord_alphaNuNineIndex]
            split_ifs <;> rfl
  exact heq ▸ hconj

theorem nineRoot_to_alphaHub_mem_sourceGenerated
    (i : Fin 9) (hi : i ≠ 0) (a : BinaryLeavitt) :
    prefixElementaryUnit ninePrefixCode i 0 hi a ∈ sourceGeneratedGroup := by
  fin_cases i
  · exact (hi rfl).elim
  · exact prefixElementaryUnit_mem_of_two_step
      ninePrefixCode sourceGeneratedGroup 1 3 0
      (by decide) (by decide) hi a
      (by
        simpa [alphaBetaNineIndex] using
          alphaBetaRoot_mem_sourceGenerated
            (0 : Fin 3) (1 : Fin 3) (by decide)
            (1 : Fin 2) (0 : Fin 2) a)
      (by
        simpa [alphaBetaNineIndex] using
          alphaBetaRoot_mem_sourceGenerated
            (1 : Fin 3) (0 : Fin 3) (by decide)
            (0 : Fin 2) (0 : Fin 2) (1 : BinaryLeavitt))
  · exact prefixElementaryUnit_mem_of_two_step
      ninePrefixCode sourceGeneratedGroup 2 3 0
      (by decide) (by decide) hi a
      (by
        simpa [alphaNuNineIndex] using
          alphaNuRoot_mem_sourceGenerated
            (0 : Fin 3) (1 : Fin 3) (by decide)
            (1 : Fin 2) (0 : Fin 2) a)
      (by
        simpa [alphaBetaNineIndex] using
          alphaBetaRoot_mem_sourceGenerated
            (1 : Fin 3) (0 : Fin 3) (by decide)
            (0 : Fin 2) (0 : Fin 2) (1 : BinaryLeavitt))
  · simpa [alphaBetaNineIndex] using
      alphaBetaRoot_mem_sourceGenerated
        (1 : Fin 3) (0 : Fin 3) (by decide)
        (0 : Fin 2) (0 : Fin 2) a
  · simpa [alphaBetaNineIndex] using
      alphaBetaRoot_mem_sourceGenerated
        (1 : Fin 3) (0 : Fin 3) (by decide)
        (1 : Fin 2) (0 : Fin 2) a
  · simpa [alphaNuNineIndex] using
      alphaNuRoot_mem_sourceGenerated
        (1 : Fin 3) (0 : Fin 3) (by decide)
        (1 : Fin 2) (0 : Fin 2) a
  · simpa [alphaBetaNineIndex] using
      alphaBetaRoot_mem_sourceGenerated
        (2 : Fin 3) (0 : Fin 3) (by decide)
        (0 : Fin 2) (0 : Fin 2) a
  · simpa [alphaBetaNineIndex] using
      alphaBetaRoot_mem_sourceGenerated
        (2 : Fin 3) (0 : Fin 3) (by decide)
        (1 : Fin 2) (0 : Fin 2) a
  · simpa [alphaNuNineIndex] using
      alphaNuRoot_mem_sourceGenerated
        (2 : Fin 3) (0 : Fin 3) (by decide)
        (1 : Fin 2) (0 : Fin 2) a

theorem nineRoot_from_alphaHub_mem_sourceGenerated
    (i : Fin 9) (hi : (0 : Fin 9) ≠ i) (a : BinaryLeavitt) :
    prefixElementaryUnit ninePrefixCode 0 i hi a ∈ sourceGeneratedGroup := by
  fin_cases i
  · exact (hi rfl).elim
  · exact prefixElementaryUnit_mem_of_two_step
      ninePrefixCode sourceGeneratedGroup 0 3 1
      (by decide) (by decide) hi a
      (by
        simpa [alphaBetaNineIndex] using
          alphaBetaRoot_mem_sourceGenerated
            (0 : Fin 3) (1 : Fin 3) (by decide)
            (0 : Fin 2) (0 : Fin 2) a)
      (by
        simpa [alphaBetaNineIndex] using
          alphaBetaRoot_mem_sourceGenerated
            (1 : Fin 3) (0 : Fin 3) (by decide)
            (0 : Fin 2) (1 : Fin 2) (1 : BinaryLeavitt))
  · exact prefixElementaryUnit_mem_of_two_step
      ninePrefixCode sourceGeneratedGroup 0 3 2
      (by decide) (by decide) hi a
      (by
        simpa [alphaBetaNineIndex] using
          alphaBetaRoot_mem_sourceGenerated
            (0 : Fin 3) (1 : Fin 3) (by decide)
            (0 : Fin 2) (0 : Fin 2) a)
      (by
        simpa [alphaNuNineIndex] using
          alphaNuRoot_mem_sourceGenerated
            (1 : Fin 3) (0 : Fin 3) (by decide)
            (0 : Fin 2) (1 : Fin 2) (1 : BinaryLeavitt))
  · simpa [alphaBetaNineIndex] using
      alphaBetaRoot_mem_sourceGenerated
        (0 : Fin 3) (1 : Fin 3) (by decide)
        (0 : Fin 2) (0 : Fin 2) a
  · simpa [alphaBetaNineIndex] using
      alphaBetaRoot_mem_sourceGenerated
        (0 : Fin 3) (1 : Fin 3) (by decide)
        (0 : Fin 2) (1 : Fin 2) a
  · simpa [alphaNuNineIndex] using
      alphaNuRoot_mem_sourceGenerated
        (0 : Fin 3) (1 : Fin 3) (by decide)
        (0 : Fin 2) (1 : Fin 2) a
  · simpa [alphaBetaNineIndex] using
      alphaBetaRoot_mem_sourceGenerated
        (0 : Fin 3) (2 : Fin 3) (by decide)
        (0 : Fin 2) (0 : Fin 2) a
  · simpa [alphaBetaNineIndex] using
      alphaBetaRoot_mem_sourceGenerated
        (0 : Fin 3) (2 : Fin 3) (by decide)
        (0 : Fin 2) (1 : Fin 2) a
  · simpa [alphaNuNineIndex] using
      alphaNuRoot_mem_sourceGenerated
        (0 : Fin 3) (2 : Fin 3) (by decide)
        (0 : Fin 2) (1 : Fin 2) a

theorem ninePrefixElementaryGroup_le_sourceGenerated :
    prefixElementaryGroup ninePrefixCode ≤ sourceGeneratedGroup :=
  prefixElementaryGroup_le_of_hub ninePrefixCode sourceGeneratedGroup
    (0 : Fin 9) nineRoot_to_alphaHub_mem_sourceGenerated
    nineRoot_from_alphaHub_mem_sourceGenerated

theorem alphaNineIndex_ne {i j : Fin 3} (hij : i ≠ j) :
    alphaNineIndex i ≠ alphaNineIndex j := by
  intro h
  apply hij
  apply Fin.ext
  have hv := congrArg Fin.val h
  change 3 * i.val = 3 * j.val at hv
  omega

theorem alphaPrefixElementaryUnit_eq_nine
    (i j : Fin 3) (hij : i ≠ j) (a : BinaryLeavitt) :
    prefixElementaryUnit alphaPrefixCode i j hij a =
      prefixElementaryUnit ninePrefixCode
        (alphaNineIndex i) (alphaNineIndex j)
        (alphaNineIndex_ne hij) a := by
  apply Units.ext
  change
    1 + leavittWordS (alphaWord i) * a * leavittWordT (alphaWord j) =
      1 + leavittWordS (nineWord (alphaNineIndex i)) * a *
        leavittWordT (nineWord (alphaNineIndex j))
  rw [nineWord_alphaNineIndex, nineWord_alphaNineIndex]

theorem alphaPrefixElementaryGroup_le_nine :
    prefixElementaryGroup alphaPrefixCode ≤
      prefixElementaryGroup ninePrefixCode := by
  rw [prefixElementaryGroup, Subgroup.closure_le]
  rintro _ ⟨i, j, hij, a, rfl⟩
  rw [alphaPrefixElementaryUnit_eq_nine]
  exact Subgroup.subset_closure
    ⟨alphaNineIndex i, alphaNineIndex j, alphaNineIndex_ne hij, a, rfl⟩

theorem sourceGeneratedGroup_le_nine_of_compressions
    (hu : compressionU ∈ prefixElementaryGroup ninePrefixCode)
    (hv : compressionV ∈ prefixElementaryGroup ninePrefixCode) :
    sourceGeneratedGroup ≤ prefixElementaryGroup ninePrefixCode := by
  rw [sourceGeneratedGroup, Subgroup.closure_le]
  intro z hz
  rcases hz with hz | hz
  · exact alphaPrefixElementaryGroup_le_nine hz
  · simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hz
    rcases hz with rfl | rfl
    · exact hu
    · exact hv

theorem sourceGeneratedGroup_eq_nine_of_compressions
    (hu : compressionU ∈ prefixElementaryGroup ninePrefixCode)
    (hv : compressionV ∈ prefixElementaryGroup ninePrefixCode) :
    sourceGeneratedGroup = prefixElementaryGroup ninePrefixCode :=
  le_antisymm (sourceGeneratedGroup_le_nine_of_compressions hu hv)
    ninePrefixElementaryGroup_le_sourceGenerated

end SourceGeneration

theorem binaryLeavittMatrixUnitSubgroup_countable (n : ℕ)
    (H : Subgroup (Matrix (Fin n) (Fin n) BinaryLeavitt)ˣ) : Countable H := by
  letI : Countable (Matrix (Fin n) (Fin n) BinaryLeavitt) :=
    Countable.of_equiv (Fin n → Fin n → BinaryLeavitt)
      (Matrix.of : (Fin n → Fin n → BinaryLeavitt) ≃
        Matrix (Fin n) (Fin n) BinaryLeavitt)
  have h : Function.Injective
      (fun x : H => (x.val.val : Matrix (Fin n) (Fin n) BinaryLeavitt)) := by
    intro x y hxy
    apply Subtype.ext
    exact Units.ext hxy
  exact h.countable

instance binaryLeavittElementaryGroupCountable (n : ℕ) :
    Countable (binaryLeavittElementaryGroup n) :=
  binaryLeavittMatrixUnitSubgroup_countable n
    (elementaryGroup (Fin n) BinaryLeavitt)

theorem binaryLeavittEL3_finitelyGenerated :
    Group.FG (binaryLeavittElementaryGroup 3) :=
  elementaryGroup_three_finitelyGenerated

theorem binaryLeavittEL3_infinite :
    Infinite (binaryLeavittElementaryGroup 3) :=
  elementaryGroup_infinite (R := BinaryLeavitt)
    (0 : Fin 3) (1 : Fin 3) (by decide)

theorem alphaPrefixElementaryGroup_finitelyGenerated :
    Group.FG (prefixElementaryGroup alphaPrefixCode) := by
  letI : Group.FG (binaryLeavittElementaryGroup 3) :=
    binaryLeavittEL3_finitelyGenerated
  exact Group.fg_of_surjective
    (f := alphaPrefixElementaryGroupEquiv.toMonoidHom)
    alphaPrefixElementaryGroupEquiv.surjective

theorem ninePrefixElementaryGroup_countable :
    Countable (prefixElementaryGroup ninePrefixCode) :=
  ninePrefixElementaryGroupEquiv.symm.injective.countable

noncomputable def midrankFirstMoment (a : ℝ) : List ℝ → ℝ
  | [] => 0
  | p :: ps => p * (a + p / 2) + midrankFirstMoment (a + p) ps

noncomputable def midrankSecondMoment (a : ℝ) : List ℝ → ℝ
  | [] => 0
  | p :: ps => p * (a + p / 2) ^ 2 + midrankSecondMoment (a + p) ps

theorem midrankFirstMoment_eq (a : ℝ) (ps : List ℝ) :
    midrankFirstMoment a ps = ((a + ps.sum) ^ 2 - a ^ 2) / 2 := by
  induction ps generalizing a with
  | nil => simp [midrankFirstMoment]
  | cons p ps ih =>
      simp only [midrankFirstMoment, List.sum_cons]
      rw [ih (a + p)]
      ring

theorem midrankSecondMoment_eq (a : ℝ) (ps : List ℝ) :
    midrankSecondMoment a ps =
      ((a + ps.sum) ^ 3 - a ^ 3) / 3 -
        (ps.map fun p => p ^ 3).sum / 12 := by
  induction ps generalizing a with
  | nil => simp [midrankSecondMoment]
  | cons p ps ih =>
      simp only [midrankSecondMoment, List.sum_cons, List.map_cons]
      rw [ih (a + p)]
      ring

noncomputable def midrankVariance (ps : List ℝ) : ℝ :=
  midrankSecondMoment 0 ps - (midrankFirstMoment 0 ps) ^ 2

theorem midrankVariance_eq (ps : List ℝ) (hsum : ps.sum = 1) :
    midrankVariance ps = (1 - (ps.map fun p => p ^ 3).sum) / 12 := by
  unfold midrankVariance
  rw [midrankSecondMoment_eq, midrankFirstMoment_eq, hsum]
  ring

theorem cubeSum_le_dominant_mul_sum (ps : List ℝ) (m : ℝ)
    (hpos : ∀ p ∈ ps, 0 ≤ p)
    (hone : ∀ p ∈ ps, p ≤ 1)
    (hdom : ∀ p ∈ ps, p ≤ m) :
    (ps.map fun p => p ^ 3).sum ≤ m * ps.sum := by
  induction ps with
  | nil => simp
  | cons p ps ih =>
      have hp : 0 ≤ p := hpos p (by simp)
      have hpone : p ≤ 1 := hone p (by simp)
      have hpm : p ≤ m := hdom p (by simp)
      have hsq : p * p ≤ m := calc
        p * p ≤ p * 1 := mul_le_mul_of_nonneg_left hpone hp
        _ = p := by ring
        _ ≤ m := hpm
      have hcube : p ^ 3 ≤ m * p := calc
        p ^ 3 = (p * p) * p := by ring
        _ ≤ m * p := mul_le_mul_of_nonneg_right hsq hp
      have htailpos : ∀ q ∈ ps, 0 ≤ q := by
        intro q hq
        exact hpos q (by simp [hq])
      have htailone : ∀ q ∈ ps, q ≤ 1 := by
        intro q hq
        exact hone q (by simp [hq])
      have htaildom : ∀ q ∈ ps, q ≤ m := by
        intro q hq
        exact hdom q (by simp [hq])
      have htail := ih htailpos htailone htaildom
      simpa [mul_add] using add_le_add hcube htail

theorem cube_sum_le_dominant_mass (ps : List ℝ) (m : ℝ)
    (hsum : ps.sum = 1)
    (hpos : ∀ p ∈ ps, 0 ≤ p)
    (hdom : ∀ p ∈ ps, p ≤ m) :
    (ps.map fun p => p ^ 3).sum ≤ m := by
  have hone : ∀ p ∈ ps, p ≤ (1 : ℝ) := by
    intro p hp
    have hsub : List.Sublist [p] ps := List.singleton_sublist.mpr hp
    have hle : ([p] : List ℝ).sum ≤ ps.sum :=
      hsub.sum_le_sum hpos
    simpa [hsum] using hle
  have h := cubeSum_le_dominant_mul_sum ps m hpos hone hdom
  simpa [hsum] using h

theorem midrankVariance_controls_dominant_mass
    (ps : List ℝ) (m : ℝ)
    (hsum : ps.sum = 1)
    (hpos : ∀ p ∈ ps, 0 ≤ p)
    (hdom : ∀ p ∈ ps, p ≤ m) :
    (1 - m) / 12 ≤ midrankVariance ps := by
  rw [midrankVariance_eq ps hsum]
  have hcube := cube_sum_le_dominant_mass ps m hsum hpos hdom
  linarith

theorem weighted_midrank_dominant_mass_le {ι : Type*}
    (I : Finset ι) (weight : ι → ℝ)
    (q : ι → List ℝ) (m : ι → ℝ)
    (hweight : ∀ i ∈ I, 0 ≤ weight i)
    (hsum : ∀ i ∈ I, (q i).sum = 1)
    (hpositive : ∀ i ∈ I, ∀ x ∈ q i, 0 ≤ x)
    (hdominant : ∀ i ∈ I, ∀ x ∈ q i, x ≤ m i) :
    (∑ i ∈ I, weight i * (1 - m i)) ≤
      12 * ∑ i ∈ I, weight i * midrankVariance (q i) := by
  calc
    (∑ i ∈ I, weight i * (1 - m i)) ≤
        ∑ i ∈ I, 12 * (weight i * midrankVariance (q i)) := by
      apply Finset.sum_le_sum
      intro i hi
      have hvar := midrankVariance_controls_dominant_mass
        (q i) (m i) (hsum i hi) (hpositive i hi) (hdominant i hi)
      have hpoint : 1 - m i ≤ 12 * midrankVariance (q i) := by
        linarith
      calc
        weight i * (1 - m i) ≤
            weight i * (12 * midrankVariance (q i)) :=
          mul_le_mul_of_nonneg_left hpoint (hweight i hi)
        _ = 12 * (weight i * midrankVariance (q i)) := by ring
    _ = 12 * ∑ i ∈ I, weight i * midrankVariance (q i) := by
      rw [Finset.mul_sum]

def componentRankMass {V : Type*}
    (C : Finset V) (b : V → ℤ) (j : ℤ) : ℝ :=
  ((C.filter fun x => b x = j).card : ℝ) / (C.card : ℝ)

def componentVertexMidrank {V : Type*}
    (C : Finset V) (b : V → ℤ) (x : V) : ℝ :=
  (((C.filter fun z => b z < b x).card : ℝ) +
      ((C.filter fun z => b z = b x).card : ℝ) / 2) /
    (C.card : ℝ)

theorem componentVertexMidrank_eq_sum_componentRankMass
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (x : V) :
    componentVertexMidrank C b x =
      (∑ j ∈ (C.image b).filter (fun j => j < b x),
        componentRankMass C b j) + componentRankMass C b (b x) / 2 := by
  classical
  let J : Finset ℤ := (C.image b).filter fun j => j < b x
  have hfilter :
      C.filter (fun z => b z ∈ J) =
        C.filter (fun z => b z < b x) := by
    ext z
    simp only [Finset.mem_filter]
    dsimp [J]
    simp only [Finset.mem_filter, Finset.mem_image]
    aesop
  have hcard :
      (∑ j ∈ J, (C.filter fun z => b z = j).card) =
        (C.filter fun z => b z < b x).card := by
    calc
      (∑ j ∈ J, (C.filter fun z => b z = j).card) =
          (C.filter fun z => b z ∈ J).card :=
        Finset.sum_card_fiberwise_eq_card_filter C J b
      _ = (C.filter fun z => b z < b x).card :=
        congrArg Finset.card hfilter
  have hcard' :
      (∑ j ∈ J, ((C.filter fun z => b z = j).card : ℝ)) =
        ((C.filter fun z => b z < b x).card : ℝ) := by
    exact_mod_cast hcard
  simp only [componentVertexMidrank, componentRankMass, ← Finset.sum_div]
  rw [show
    (∑ j ∈ (C.image b).filter (fun j => j < b x),
      ((C.filter fun z => b z = j).card : ℝ)) =
        ((C.filter fun z => b z < b x).card : ℝ) from by
      simpa only [J] using hcard']
  ring

theorem componentRankMass_nonneg {V : Type*}
    (C : Finset V) (b : V → ℤ) (j : ℤ) :
    0 ≤ componentRankMass C b j := by
  unfold componentRankMass
  positivity

theorem sum_componentRankMass {V : Type*}
    (C : Finset V) (b : V → ℤ) (hC : C.Nonempty) :
    (∑ j ∈ C.image b, componentRankMass C b j) = 1 := by
  have hcard :
      (∑ j ∈ C.image b, ((C.filter fun x => b x = j).card : ℝ)) =
        (C.card : ℝ) := by
    exact_mod_cast (Finset.card_eq_sum_card_image b C).symm
  have hne : (C.card : ℝ) ≠ 0 := by
    exact_mod_cast (Finset.card_ne_zero.mpr hC)
  simp only [componentRankMass, ← Finset.sum_div]
  rw [hcard, div_self hne]

theorem componentVertexMidrank_nonneg {V : Type*}
    (C : Finset V) (b : V → ℤ) (x : V) :
    0 ≤ componentVertexMidrank C b x := by
  unfold componentVertexMidrank
  positivity

theorem component_lower_equal_disjoint
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (x : V) :
    Disjoint (C.filter fun z => b z < b x)
      (C.filter fun z => b z = b x) := by
  apply Finset.disjoint_left.mpr
  intro z hzlow hzeq
  have hlow := (Finset.mem_filter.mp hzlow).2
  have heq := (Finset.mem_filter.mp hzeq).2
  omega

theorem componentVertexMidrank_le_one {V : Type*}
    (C : Finset V) (b : V → ℤ) (x : V) :
    componentVertexMidrank C b x ≤ 1 := by
  classical
  rcases C.eq_empty_or_nonempty with rfl | hC
  · simp [componentVertexMidrank]
  · have hc : 0 < (C.card : ℝ) := by
      exact_mod_cast Finset.card_pos.mpr hC
    have hdisj := component_lower_equal_disjoint C b x
    have hsub :
        (C.filter fun z => b z < b x) ∪
          (C.filter fun z => b z = b x) ⊆ C := by
      intro z hz
      rcases Finset.mem_union.mp hz with hz | hz
      · exact (Finset.mem_filter.mp hz).1
      · exact (Finset.mem_filter.mp hz).1
    have hcard := Finset.card_le_card hsub
    rw [Finset.card_union_of_disjoint hdisj] at hcard
    have hcard' :
        ((C.filter fun z => b z < b x).card : ℝ) +
          ((C.filter fun z => b z = b x).card : ℝ) ≤
            (C.card : ℝ) := by
      exact_mod_cast hcard
    unfold componentVertexMidrank
    apply (div_le_one hc).2
    have heq : 0 ≤ ((C.filter fun z => b z = b x).card : ℝ) := by
      positivity
    linarith

theorem componentVertexMidrank_mono {V : Type*}
    (C : Finset V) (b : V → ℤ) {x y : V}
    (hxy : b x ≤ b y) :
    componentVertexMidrank C b x ≤ componentVertexMidrank C b y := by
  classical
  rcases C.eq_empty_or_nonempty with rfl | hC
  · simp [componentVertexMidrank]
  · have hc : 0 < (C.card : ℝ) := by
      exact_mod_cast Finset.card_pos.mpr hC
    rcases hxy.eq_or_lt with heq | hlt
    · unfold componentVertexMidrank
      simp [heq]
    · have hdisj := component_lower_equal_disjoint C b x
      have hsub :
          (C.filter fun z => b z < b x) ∪
            (C.filter fun z => b z = b x) ⊆
              C.filter fun z => b z < b y := by
        intro z hz
        rcases Finset.mem_union.mp hz with hz | hz
        · obtain ⟨hzC, hzx⟩ := Finset.mem_filter.mp hz
          exact Finset.mem_filter.mpr ⟨hzC, lt_trans hzx hlt⟩
        · obtain ⟨hzC, hzx⟩ := Finset.mem_filter.mp hz
          exact Finset.mem_filter.mpr ⟨hzC, hzx.symm ▸ hlt⟩
      have hcard := Finset.card_le_card hsub
      rw [Finset.card_union_of_disjoint hdisj] at hcard
      have hcard' :
          ((C.filter fun z => b z < b x).card : ℝ) +
            ((C.filter fun z => b z = b x).card : ℝ) ≤
              ((C.filter fun z => b z < b y).card : ℝ) := by
        exact_mod_cast hcard
      have hex : 0 ≤ ((C.filter fun z => b z = b x).card : ℝ) := by
        positivity
      have hey : 0 ≤ ((C.filter fun z => b z = b y).card : ℝ) := by
        positivity
      unfold componentVertexMidrank
      apply (div_le_div_iff_of_pos_right hc).2
      linarith

def componentRankMassList {V : Type*}
    (C : Finset V) (b : V → ℤ) : List ℝ :=
  ((C.image b).sort (· ≤ ·)).map (componentRankMass C b)

theorem sum_map_sort_eq {α : Type*}
    [LinearOrder α]
    (s : Finset α) (f : α → ℝ) :
    ((s.sort (· ≤ ·)).map f).sum = ∑ a ∈ s, f a := by
  change
    ((s.sort (· ≤ ·)).map f).sum =
      (s.val.map f).sum
  have h := congrArg
    (fun t : Multiset α => (t.map f).sum)
    (s.sort_eq (· ≤ ·))
  simpa only [Multiset.map_coe, Multiset.sum_coe] using h

theorem componentRankMassList_sum {V : Type*}
    (C : Finset V) (b : V → ℤ) (hC : C.Nonempty) :
    (componentRankMassList C b).sum = 1 := by
  unfold componentRankMassList
  rw [sum_map_sort_eq]
  exact sum_componentRankMass C b hC

theorem componentRankMassList_nonneg {V : Type*}
    (C : Finset V) (b : V → ℤ) :
    ∀ p ∈ componentRankMassList C b, 0 ≤ p := by
  intro p hp
  unfold componentRankMassList at hp
  obtain ⟨j, hj, rfl⟩ := List.mem_map.mp hp
  exact componentRankMass_nonneg C b j

theorem componentRankMassList_le_max {V : Type*}
    (C : Finset V) (b : V → ℤ) (j : ℤ)
    (hmax : ∀ k ∈ C.image b,
      componentRankMass C b k ≤ componentRankMass C b j) :
    ∀ p ∈ componentRankMassList C b,
      p ≤ componentRankMass C b j := by
  intro p hp
  unfold componentRankMassList at hp
  obtain ⟨k, hk, rfl⟩ := List.mem_map.mp hp
  exact hmax k (((C.image b).mem_sort (· ≤ ·)).mp hk)

theorem exists_maximal_componentRankMass
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (hC : C.Nonempty) :
    ∃ j ∈ C.image b,
      ∀ k ∈ C.image b,
        componentRankMass C b k ≤ componentRankMass C b j := by
  have himage : (C.image b).Nonempty := hC.image b
  obtain ⟨j, hj, hmax⟩ :=
    Finset.exists_max_image (C.image b) (componentRankMass C b) himage
  exact ⟨j, hj, hmax⟩

theorem component_omitted_rank_card_eq
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (j : ℤ)
    (hC : C.Nonempty) :
    ((C.card - (C.filter fun x => b x = j).card : ℕ) : ℝ) =
      (C.card : ℝ) * (1 - componentRankMass C b j) := by
  have hsub : (C.filter fun x => b x = j).card ≤ C.card :=
    Finset.card_le_card (Finset.filter_subset _ _)
  have hne : (C.card : ℝ) ≠ 0 := by
    exact_mod_cast Finset.card_ne_zero.mpr hC
  rw [Nat.cast_sub hsub]
  unfold componentRankMass
  field_simp [hne]

theorem actual_weighted_midrank_dominant_mass_le
    {V ι : Type*}
    (I : Finset ι) (C : ι → Finset V) (b : V → ℤ) (j : ι → ℤ)
    (hC : ∀ i ∈ I, (C i).Nonempty)
    (hmax : ∀ i ∈ I, ∀ k ∈ (C i).image b,
      componentRankMass (C i) b k ≤ componentRankMass (C i) b (j i)) :
    (∑ i ∈ I,
      (((C i).card - ((C i).filter fun x => b x = j i).card : ℕ) : ℝ)) ≤
      12 * ∑ i ∈ I,
        ((C i).card : ℝ) *
          midrankVariance (componentRankMassList (C i) b) := by
  calc
    (∑ i ∈ I,
        (((C i).card - ((C i).filter fun x => b x = j i).card : ℕ) : ℝ)) =
      ∑ i ∈ I,
        ((C i).card : ℝ) *
          (1 - componentRankMass (C i) b (j i)) := by
            apply Finset.sum_congr rfl
            intro i hi
            exact component_omitted_rank_card_eq (C i) b (j i) (hC i hi)
    _ ≤ 12 * ∑ i ∈ I,
        ((C i).card : ℝ) *
          midrankVariance (componentRankMassList (C i) b) := by
      apply weighted_midrank_dominant_mass_le
        I (fun i => ((C i).card : ℝ))
        (fun i => componentRankMassList (C i) b)
        (fun i => componentRankMass (C i) b (j i))
      · intro i hi
        positivity
      · intro i hi
        exact componentRankMassList_sum (C i) b (hC i hi)
      · intro i hi
        exact componentRankMassList_nonneg (C i) b
      · intro i hi
        exact componentRankMassList_le_max (C i) b (j i) (hmax i hi)

theorem exists_maximum_overlap_component
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (C : Finset V)
    (hC : C.Nonempty) (hCU : C ⊆ U) :
    ∃ D ∈ Q.parts,
      ∀ E ∈ Q.parts, (C ∩ E).card ≤ (C ∩ D).card := by
  classical
  have hU : U.Nonempty := hC.mono hCU
  exact Finset.exists_max_image Q.parts
    (fun D : Finset V => (C ∩ D).card)
    (Q.parts_nonempty hU.ne_empty)

theorem sum_card_component_inter_partition
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (C : Finset V) (hCU : C ⊆ U) :
    ∑ D ∈ Q.parts, (C ∩ D).card = C.card := by
  have h := sum_card_inter_partition Q C
  simpa [Finset.inter_comm, Finset.inter_eq_right.mpr hCU] using h

noncomputable def maximumOverlapPart
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (C : Finset V) : Finset V := by
  classical
  exact if h : C.Nonempty ∧ C ⊆ U then
    (exists_maximum_overlap_component Q C h.1 h.2).choose else ∅

theorem maximumOverlapPart_mem
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (C : Finset V)
    (hC : C.Nonempty) (hCU : C ⊆ U) :
    maximumOverlapPart Q C ∈ Q.parts := by
  classical
  have h : C.Nonempty ∧ C ⊆ U := ⟨hC, hCU⟩
  simpa only [maximumOverlapPart, dif_pos h] using
    (exists_maximum_overlap_component Q C hC hCU).choose_spec.1

theorem maximumOverlapPart_maximal
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (C : Finset V)
    (hC : C.Nonempty) (hCU : C ⊆ U) :
    ∀ E ∈ Q.parts,
      (C ∩ E).card ≤ (C ∩ maximumOverlapPart Q C).card := by
  classical
  have h : C.Nonempty ∧ C ⊆ U := ⟨hC, hCU⟩
  simpa only [maximumOverlapPart, dif_pos h] using
    (exists_maximum_overlap_component Q C hC hCU).choose_spec.2

namespace PrefixCompressionU

open scoped BigOperators

def sourceCrossRoot (i j : Fin 9) (h : i ≠ j)
    (a b : List (Fin 2)) : BinaryLeavittˣ :=
  prefixElementaryUnit ninePrefixCode i j h
    (leavittWordS a * leavittWordT b)

theorem sourceCrossRoot_mem (i j : Fin 9) (h : i ≠ j)
    (a b : List (Fin 2)) :
    sourceCrossRoot i j h a b ∈ prefixElementaryGroup ninePrefixCode :=
  Subgroup.subset_closure ⟨i, j, h,
    leavittWordS a * leavittWordT b, rfl⟩

@[simp] theorem sourceCrossRoot_val (i j : Fin 9) (h : i ≠ j)
    (a b : List (Fin 2)) :
    (↑(sourceCrossRoot i j h a b) : BinaryLeavitt) =
      1 + leavittWordS (nineWord i ++ a) *
        leavittWordT (nineWord j ++ b) := by
  change
    1 + leavittWordS (nineWord i) *
      (leavittWordS a * leavittWordT b) * leavittWordT (nineWord j) = _
  rw [leavittWordS_append, leavittWordT_append]
  noncomm_ring

def sourceCrossSwap (i j : Fin 9) (h : i ≠ j)
    (a b : List (Fin 2)) : BinaryLeavittˣ :=
  sourceCrossRoot i j h a b *
    sourceCrossRoot j i h.symm b a *
    sourceCrossRoot i j h a b

theorem sourceCrossSwap_mem (i j : Fin 9) (h : i ≠ j)
    (a b : List (Fin 2)) :
    sourceCrossSwap i j h a b ∈ prefixElementaryGroup ninePrefixCode := by
  exact (prefixElementaryGroup ninePrefixCode).mul_mem
    ((prefixElementaryGroup ninePrefixCode).mul_mem
      (sourceCrossRoot_mem i j h a b)
      (sourceCrossRoot_mem j i h.symm b a))
    (sourceCrossRoot_mem i j h a b)

theorem sourceRefinementOrthogonal (i j : Fin 9) (h : i ≠ j)
    (a b : List (Fin 2)) :
    leavittWordT (nineWord i ++ a) *
      leavittWordS (nineWord j ++ b) = 0 := by
  have hz : leavittWordT (nineWord i) * leavittWordS (nineWord j) = 0 := by
    simpa [ninePrefixCode, h] using
      binaryPrefixCode_orthogonal ninePrefixCode i j
  rw [leavittWordT_append, leavittWordS_append]
  calc
    (leavittWordT a * leavittWordT (nineWord i)) *
        (leavittWordS (nineWord j) * leavittWordS b) =
      leavittWordT a *
        (leavittWordT (nineWord i) * leavittWordS (nineWord j)) *
        leavittWordS b := by noncomm_ring
    _ = 0 := by rw [hz]; simp

theorem sourceCrossSwap_val (i j : Fin 9) (h : i ≠ j)
    (a b : List (Fin 2)) :
    (↑(sourceCrossSwap i j h a b) : BinaryLeavitt) =
      1 - leavittWordS (nineWord i ++ a) *
          leavittWordT (nineWord i ++ a) -
        leavittWordS (nineWord j ++ b) *
          leavittWordT (nineWord j ++ b) +
        leavittWordS (nineWord i ++ a) *
          leavittWordT (nineWord j ++ b) +
        leavittWordS (nineWord j ++ b) *
          leavittWordT (nineWord i ++ a) := by
  let A : List (Fin 2) := nineWord i ++ a
  let B : List (Fin 2) := nineWord j ++ b
  let P : BinaryLeavitt := leavittWordS A * leavittWordT B
  let Q : BinaryLeavitt := leavittWordS B * leavittWordT A
  have hba : leavittWordT B * leavittWordS A = 0 :=
    sourceRefinementOrthogonal j i h.symm b a
  have hPP : P * P = 0 := by
    change
      (leavittWordS A * leavittWordT B) *
        (leavittWordS A * leavittWordT B) = 0
    calc
      (leavittWordS A * leavittWordT B) *
          (leavittWordS A * leavittWordT B) =
        leavittWordS A *
          (leavittWordT B * leavittWordS A) * leavittWordT B := by
            noncomm_ring
      _ = 0 := by rw [hba]; simp
  have hPQ : P * Q = leavittWordS A * leavittWordT A := by
    change
      (leavittWordS A * leavittWordT B) *
        (leavittWordS B * leavittWordT A) =
        leavittWordS A * leavittWordT A
    calc
      (leavittWordS A * leavittWordT B) *
          (leavittWordS B * leavittWordT A) =
        leavittWordS A *
          (leavittWordT B * leavittWordS B) * leavittWordT A := by
            noncomm_ring
      _ = leavittWordS A * leavittWordT A := by
        rw [leavittWordT_mul_wordS_self]
        simp
  have hQP : Q * P = leavittWordS B * leavittWordT B := by
    change
      (leavittWordS B * leavittWordT A) *
        (leavittWordS A * leavittWordT B) =
        leavittWordS B * leavittWordT B
    calc
      (leavittWordS B * leavittWordT A) *
          (leavittWordS A * leavittWordT B) =
        leavittWordS B *
          (leavittWordT A * leavittWordS A) * leavittWordT B := by
            noncomm_ring
      _ = leavittWordS B * leavittWordT B := by
        rw [leavittWordT_mul_wordS_self]
        simp
  have hPQP : P * Q * P = P := by
    rw [hPQ]
    change
      (leavittWordS A * leavittWordT A) *
        (leavittWordS A * leavittWordT B) =
        leavittWordS A * leavittWordT B
    calc
      (leavittWordS A * leavittWordT A) *
          (leavittWordS A * leavittWordT B) =
        leavittWordS A *
          (leavittWordT A * leavittWordS A) * leavittWordT B := by
            noncomm_ring
      _ = leavittWordS A * leavittWordT B := by
        rw [leavittWordT_mul_wordS_self]
        simp
  change
    (↑(sourceCrossSwap i j h a b) : BinaryLeavitt) =
      1 - leavittWordS A * leavittWordT A -
        leavittWordS B * leavittWordT B + P + Q
  calc
    (↑(sourceCrossSwap i j h a b) : BinaryLeavitt) =
        (1 + P) * (1 + Q) * (1 + P) := by
          simp only [sourceCrossSwap, Units.val_mul, sourceCrossRoot_val]
          rfl
    _ = 1 - P * Q - Q * P + P + Q :=
      cylinder_transposition_factorization P Q hPP hPQP
    _ = 1 - leavittWordS A * leavittWordT A -
        leavittWordS B * leavittWordT B + P + Q := by rw [hPQ, hQP]

def refinedSourceWord : Fin 19 → List (Fin 2)
  | 0 => [0, 0, 0, 0]
  | 1 => [0, 0, 0, 1]
  | 2 => [1, 0, 0, 0, 0]
  | 3 => [1, 0, 0, 0, 1]
  | 4 => [1, 1, 0, 0, 0]
  | 5 => [1, 1, 0, 0, 1]
  | 6 => [0, 0, 1]
  | 7 => [1, 0, 0, 1, 0]
  | 8 => [1, 0, 0, 1, 1]
  | 9 => [1, 1, 0, 1]
  | 10 => [0, 1, 0, 0]
  | 11 => [0, 1, 0, 1]
  | 12 => [0, 1, 1]
  | 13 => [1, 0, 1, 0, 0]
  | 14 => [1, 0, 1, 0, 1]
  | 15 => [1, 0, 1, 1]
  | 16 => [1, 1, 1, 0, 0]
  | 17 => [1, 1, 1, 0, 1]
  | _ => [1, 1, 1, 1]

def refinedSourcePrefixCode : BinaryPrefixCode (Fin 19) where
  word := refinedSourceWord
  prefix_free := by decide

theorem refinedSourcePrefixCode_complete :
    MatrixCorner.codeIdempotent
      (fun i => leavittWordS (refinedSourcePrefixCode.word i))
      (fun i => leavittWordT (refinedSourcePrefixCode.word i)) = 1 := by
  have h000 :
      leavittCylinder [0, 0, 0, 0] +
          leavittCylinder [0, 0, 0, 1] =
        leavittCylinder [0, 0, 0] := by
    simpa using (leavittCylinder_split [0, 0, 0]).symm
  have h1000 :
      leavittCylinder [1, 0, 0, 0, 0] +
          leavittCylinder [1, 0, 0, 0, 1] =
        leavittCylinder [1, 0, 0, 0] := by
    simpa using (leavittCylinder_split [1, 0, 0, 0]).symm
  have h1100 :
      leavittCylinder [1, 1, 0, 0, 0] +
          leavittCylinder [1, 1, 0, 0, 1] =
        leavittCylinder [1, 1, 0, 0] := by
    simpa using (leavittCylinder_split [1, 1, 0, 0]).symm
  have h1001 :
      leavittCylinder [1, 0, 0, 1, 0] +
          leavittCylinder [1, 0, 0, 1, 1] =
        leavittCylinder [1, 0, 0, 1] := by
    simpa using (leavittCylinder_split [1, 0, 0, 1]).symm
  have h010 :
      leavittCylinder [0, 1, 0, 0] +
          leavittCylinder [0, 1, 0, 1] =
        leavittCylinder [0, 1, 0] := by
    simpa using (leavittCylinder_split [0, 1, 0]).symm
  have h01 :
      leavittCylinder [0, 1, 0] +
          leavittCylinder [0, 1, 1] =
        leavittCylinder [0, 1] := by
    simpa using (leavittCylinder_split [0, 1]).symm
  have h1010 :
      leavittCylinder [1, 0, 1, 0, 0] +
          leavittCylinder [1, 0, 1, 0, 1] =
        leavittCylinder [1, 0, 1, 0] := by
    simpa using (leavittCylinder_split [1, 0, 1, 0]).symm
  have h101 :
      leavittCylinder [1, 0, 1, 0] +
          leavittCylinder [1, 0, 1, 1] =
        leavittCylinder [1, 0, 1] := by
    simpa using (leavittCylinder_split [1, 0, 1]).symm
  have h1110 :
      leavittCylinder [1, 1, 1, 0, 0] +
          leavittCylinder [1, 1, 1, 0, 1] =
        leavittCylinder [1, 1, 1, 0] := by
    simpa using (leavittCylinder_split [1, 1, 1, 0]).symm
  have h111 :
      leavittCylinder [1, 1, 1, 0] +
          leavittCylinder [1, 1, 1, 1] =
        leavittCylinder [1, 1, 1] := by
    simpa using (leavittCylinder_split [1, 1, 1]).symm
  change (∑ i : Fin 19, leavittCylinder (refinedSourceWord i)) = 1
  calc
    (∑ i : Fin 19, leavittCylinder (refinedSourceWord i)) =
        (leavittCylinder [0, 0, 0, 0] +
          leavittCylinder [0, 0, 0, 1]) +
        (leavittCylinder [1, 0, 0, 0, 0] +
          leavittCylinder [1, 0, 0, 0, 1]) +
        (leavittCylinder [1, 1, 0, 0, 0] +
          leavittCylinder [1, 1, 0, 0, 1]) +
        leavittCylinder [0, 0, 1] +
        (leavittCylinder [1, 0, 0, 1, 0] +
          leavittCylinder [1, 0, 0, 1, 1]) +
        leavittCylinder [1, 1, 0, 1] +
        ((leavittCylinder [0, 1, 0, 0] +
            leavittCylinder [0, 1, 0, 1]) +
          leavittCylinder [0, 1, 1]) +
        ((leavittCylinder [1, 0, 1, 0, 0] +
            leavittCylinder [1, 0, 1, 0, 1]) +
          leavittCylinder [1, 0, 1, 1]) +
        ((leavittCylinder [1, 1, 1, 0, 0] +
            leavittCylinder [1, 1, 1, 0, 1]) +
          leavittCylinder [1, 1, 1, 1]) := by
            simp [Fin.sum_univ_succ, refinedSourceWord]
            ac_rfl
    _ = leavittCylinder [0, 0, 0] +
          leavittCylinder [1, 0, 0, 0] +
          leavittCylinder [1, 1, 0, 0] +
          leavittCylinder [0, 0, 1] +
          leavittCylinder [1, 0, 0, 1] +
          leavittCylinder [1, 1, 0, 1] +
          leavittCylinder [0, 1] +
          leavittCylinder [1, 0, 1] +
          leavittCylinder [1, 1, 1] := by
            rw [h000, h1000, h1100, h1001, h010, h01,
              h1010, h101, h1110, h111]
    _ = ∑ i : Fin 9, leavittCylinder (nineWord i) := by
      simp [Fin.sum_univ_succ, nineWord, alphaWord, betaWord, nuWord]
      ac_rfl
    _ = 1 := ninePrefixCode_complete

theorem completePrefixWord_ext {ι : Type*} [Fintype ι]
    (E : BinaryPrefixCode ι)
    (hcomplete : MatrixCorner.codeIdempotent
      (fun i => leavittWordS (E.word i))
      (fun i => leavittWordT (E.word i)) = 1)
    (x y : BinaryLeavitt)
    (haction : ∀ i : ι,
      x * leavittWordS (E.word i) =
        y * leavittWordS (E.word i)) :
    x = y := by
  calc
    x = x * 1 := (mul_one x).symm
    _ = x * MatrixCorner.codeIdempotent
        (fun i => leavittWordS (E.word i))
        (fun i => leavittWordT (E.word i)) := by rw [hcomplete]
    _ = ∑ i : ι,
        (x * leavittWordS (E.word i)) *
          leavittWordT (E.word i) := by
      rw [MatrixCorner.codeIdempotent, Finset.mul_sum]
      apply Finset.sum_congr rfl
      intro i _
      exact (mul_assoc x _ _).symm
    _ = ∑ i : ι,
        (y * leavittWordS (E.word i)) *
          leavittWordT (E.word i) := by
      apply Finset.sum_congr rfl
      intro i _
      rw [haction i]
    _ = y * MatrixCorner.codeIdempotent
        (fun i => leavittWordS (E.word i))
        (fun i => leavittWordT (E.word i)) := by
      rw [MatrixCorner.codeIdempotent, Finset.mul_sum]
      apply Finset.sum_congr rfl
      intro i _
      exact mul_assoc y _ _
    _ = y := by rw [hcomplete, mul_one]

theorem prefixTable_mul_sourceWord {ι : Type*}
    [Fintype ι] [DecidableEq ι]
    (source target : BinaryPrefixCode ι) (i : ι) :
    prefixTable source target * leavittWordS (source.word i) =
      leavittWordS (target.word i) := by
  classical
  simp [prefixTable, Finset.sum_mul, mul_assoc,
    binaryPrefixCode_orthogonal]

theorem compressionU_mul_nine_refinement
    (i : Fin 9) (r : List (Fin 2)) :
    (compressionU : BinaryLeavitt) *
        leavittWordS (nineWord i ++ r) =
      leavittWordS (uWord i ++ r) := by
  rw [leavittWordS_append, leavittWordS_append]
  change
    prefixTable ninePrefixCode uPrefixCode *
        (leavittWordS (ninePrefixCode.word i) * leavittWordS r) =
      leavittWordS (uPrefixCode.word i) * leavittWordS r
  rw [← mul_assoc, prefixTable_mul_sourceWord]

def refinedSourceParent : Fin 19 → Fin 9
  | 0 => 0
  | 1 => 0
  | 2 => 1
  | 3 => 1
  | 4 => 2
  | 5 => 2
  | 6 => 3
  | 7 => 4
  | 8 => 4
  | 9 => 5
  | 10 => 6
  | 11 => 6
  | 12 => 6
  | 13 => 7
  | 14 => 7
  | 15 => 7
  | 16 => 8
  | 17 => 8
  | _ => 8

def refinedSourceSuffix : Fin 19 → List (Fin 2)
  | 0 => [0]
  | 1 => [1]
  | 2 => [0]
  | 3 => [1]
  | 4 => [0]
  | 5 => [1]
  | 6 => []
  | 7 => [0]
  | 8 => [1]
  | 9 => []
  | 10 => [0, 0]
  | 11 => [0, 1]
  | 12 => [1]
  | 13 => [0, 0]
  | 14 => [0, 1]
  | 15 => [1]
  | 16 => [0, 0]
  | 17 => [0, 1]
  | _ => [1]

def refinedTargetWord (i : Fin 19) : List (Fin 2) :=
  uWord (refinedSourceParent i) ++ refinedSourceSuffix i

theorem refinedSourceWord_eq_parent_append (i : Fin 19) :
    refinedSourceWord i =
      nineWord (refinedSourceParent i) ++ refinedSourceSuffix i := by
  fin_cases i <;> decide

theorem compressionU_mul_refinedSourceWord (i : Fin 19) :
    (compressionU : BinaryLeavitt) *
        leavittWordS (refinedSourceWord i) =
      leavittWordS (refinedTargetWord i) := by
  rw [refinedSourceWord_eq_parent_append]
  exact compressionU_mul_nine_refinement
    (refinedSourceParent i) (refinedSourceSuffix i)

def binaryWordCancellation (a b : List (Fin 2)) : BinaryLeavitt :=
  match a, b with
  | [], b => leavittWordS b
  | a, [] => leavittWordT a
  | i :: a, j :: b =>
      if i = j then binaryWordCancellation a b else 0

theorem leavittWordT_mul_wordS_cancel (a b : List (Fin 2)) :
    leavittWordT a * leavittWordS b =
      binaryWordCancellation a b := by
  induction a generalizing b with
  | nil => simp [binaryWordCancellation, leavittWordT]
  | cons i a ih =>
      cases b with
      | nil => simp [binaryWordCancellation, leavittWordS]
      | cons j b =>
          by_cases hij : i = j
          · subst j
            change
              (leavittWordT a * leavittT i) *
                  (leavittS i * leavittWordS b) =
                if i = i then binaryWordCancellation a b else 0
            rw [if_pos rfl]
            calc
              (leavittWordT a * leavittT i) *
                  (leavittS i * leavittWordS b) =
                leavittWordT a *
                  ((leavittT i * leavittS i) * leavittWordS b) := by
                    noncomm_ring
              _ = binaryWordCancellation a b := by
                rw [leavittT_mul_S]
                simpa using ih b
          · change
              (leavittWordT a * leavittT i) *
                  (leavittS j * leavittWordS b) =
                if i = j then binaryWordCancellation a b else 0
            rw [if_neg hij]
            calc
              (leavittWordT a * leavittT i) *
                  (leavittS j * leavittWordS b) =
                leavittWordT a *
                  ((leavittT i * leavittS j) * leavittWordS b) := by
                    noncomm_ring
              _ = 0 := by rw [leavittT_mul_S]; simp [hij]

theorem leavittWordS_mul_wordS (a b : List (Fin 2)) :
    leavittWordS a * leavittWordS b = leavittWordS (a ++ b) :=
  (leavittWordS_append a b).symm

theorem sourceCrossSwap_mul_leavittWordS
    (i j : Fin 9) (h : i ≠ j)
    (a b x : List (Fin 2)) :
    (↑(sourceCrossSwap i j h a b) : BinaryLeavitt) * leavittWordS x =
      leavittWordS x -
        leavittWordS (nineWord i ++ a) *
          binaryWordCancellation (nineWord i ++ a) x -
        leavittWordS (nineWord j ++ b) *
          binaryWordCancellation (nineWord j ++ b) x +
        leavittWordS (nineWord i ++ a) *
          binaryWordCancellation (nineWord j ++ b) x +
        leavittWordS (nineWord j ++ b) *
          binaryWordCancellation (nineWord i ++ a) x := by
  rw [sourceCrossSwap_val]
  simp only [sub_mul, add_mul, one_mul, mul_assoc,
    leavittWordT_mul_wordS_cancel]

def sourceUChronologicalSwaps : List BinaryLeavittˣ :=
  [sourceCrossSwap 0 1 (by decide) [0] [],
   sourceCrossSwap 0 4 (by decide) [1] [],
   sourceCrossSwap 3 7 (by decide) [] [],
   sourceCrossSwap 6 2 (by decide) [0, 0] [],
   sourceCrossSwap 6 5 (by decide) [0, 1] [],
   sourceCrossSwap 6 8 (by decide) [1] [],
   sourceCrossSwap 3 6 (by decide) [] [0],
   sourceCrossSwap 1 0 (by decide) [] [0, 0],
   sourceCrossSwap 4 0 (by decide) [] [0, 1],
   sourceCrossSwap 1 0 (by decide) [] [1, 0],
   sourceCrossSwap 4 0 (by decide) [] [1, 1],
   sourceCrossSwap 3 1 (by decide) [0, 0] [],
   sourceCrossSwap 3 4 (by decide) [0, 1] [],
   sourceCrossSwap 7 3 (by decide) [] [0],
   sourceCrossSwap 7 3 (by decide) [] [1],
   sourceCrossSwap 2 6 (by decide) [] [0, 0, 0],
   sourceCrossSwap 5 6 (by decide) [] [0, 0, 1],
   sourceCrossSwap 8 6 (by decide) [] [0, 1],
   sourceCrossSwap 2 6 (by decide) [] [1, 0, 0],
   sourceCrossSwap 5 6 (by decide) [] [1, 0, 1],
   sourceCrossSwap 8 6 (by decide) [] [1, 1]]

def elementaryCompressionU : BinaryLeavittˣ :=
  sourceUChronologicalSwaps.reverse.prod

theorem elementaryCompressionU_mem :
    elementaryCompressionU ∈ prefixElementaryGroup ninePrefixCode := by
  apply (prefixElementaryGroup ninePrefixCode).list_prod_mem
  intro x hx
  simp only [List.mem_reverse, sourceUChronologicalSwaps,
    List.mem_cons, List.not_mem_nil, or_false] at hx
  rcases hx with h | h | h | h | h | h | h | h | h | h | h |
    h | h | h | h | h | h | h | h | h | h <;>
    subst x <;> exact sourceCrossSwap_mem _ _ _ _ _

theorem elementaryCompressionU_mul_refinedSourceWord (i : Fin 19) :
    (elementaryCompressionU : BinaryLeavitt) *
        leavittWordS (refinedSourceWord i) =
      leavittWordS (refinedTargetWord i) := by
  fin_cases i <;>
    simp [elementaryCompressionU, sourceUChronologicalSwaps,
      sourceCrossSwap_mul_leavittWordS,
      refinedSourceWord, refinedTargetWord,
      refinedSourceParent, refinedSourceSuffix,
      nineWord, uWord, alphaWord, betaWord, nuWord, etaWord,
      binaryWordCancellation, leavittWordS_mul_wordS,
      List.prod_cons, mul_assoc]

theorem elementaryCompressionU_eq_compressionU :
    elementaryCompressionU = compressionU := by
  apply Units.ext
  apply completePrefixWord_ext refinedSourcePrefixCode
    refinedSourcePrefixCode_complete
  intro i
  change
    (elementaryCompressionU : BinaryLeavitt) *
        leavittWordS (refinedSourceWord i) =
      (compressionU : BinaryLeavitt) *
        leavittWordS (refinedSourceWord i)
  rw [elementaryCompressionU_mul_refinedSourceWord,
    compressionU_mul_refinedSourceWord]

theorem compressionU_mem_ninePrefixElementaryGroup :
    compressionU ∈ prefixElementaryGroup ninePrefixCode := by
  rw [← elementaryCompressionU_eq_compressionU]
  exact elementaryCompressionU_mem

end PrefixCompressionU

theorem compressionU_mem_ninePrefixElementaryGroup :
    compressionU ∈ prefixElementaryGroup ninePrefixCode :=
  PrefixCompressionU.compressionU_mem_ninePrefixElementaryGroup

namespace PrefixCompression

open scoped BigOperators

theorem prefixTable_compose {ι : Type*} [Fintype ι] [DecidableEq ι]
    (source middle target : BinaryPrefixCode ι) :
    prefixTable middle target * prefixTable source middle =
      prefixTable source target := by
  change
    (∑ i, leavittWordS (target.word i) *
      leavittWordT (middle.word i)) *
      (∑ j, leavittWordS (middle.word j) *
        leavittWordT (source.word j)) =
      ∑ i, leavittWordS (target.word i) *
        leavittWordT (source.word i)
  calc
    (∑ i, leavittWordS (target.word i) *
        leavittWordT (middle.word i)) *
        (∑ j, leavittWordS (middle.word j) *
          leavittWordT (source.word j)) =
      ∑ i, ∑ j,
        leavittWordS (target.word i) *
          (leavittWordT (middle.word i) *
            leavittWordS (middle.word j)) *
          leavittWordT (source.word j) := by
            rw [Finset.sum_mul]
            apply Finset.sum_congr rfl
            intro i _
            rw [Finset.mul_sum]
            apply Finset.sum_congr rfl
            intro j _
            simp [mul_assoc]
    _ = ∑ i, leavittWordS (target.word i) *
          leavittWordT (source.word i) := by
      simp [binaryPrefixCode_orthogonal]

def compressionTransition : BinaryLeavittˣ :=
  prefixTableUnit uPrefixCode vPrefixCode
    uPrefixCode_complete vPrefixCode_complete

theorem compressionV_eq_transition_mul :
    compressionV = compressionTransition * compressionU := by
  apply Units.ext
  change
    prefixTable ninePrefixCode vPrefixCode =
      prefixTable uPrefixCode vPrefixCode *
        prefixTable ninePrefixCode uPrefixCode
  exact (prefixTable_compose ninePrefixCode uPrefixCode vPrefixCode).symm

def nineCrossRoot (i j : Fin 9) (hij : i ≠ j)
    (a b : List (Fin 2)) : BinaryLeavittˣ :=
  prefixElementaryUnit ninePrefixCode i j hij
    (leavittWordS a * leavittWordT b)

theorem nineCrossRoot_mem (i j : Fin 9) (hij : i ≠ j)
    (a b : List (Fin 2)) :
    nineCrossRoot i j hij a b ∈ prefixElementaryGroup ninePrefixCode := by
  exact Subgroup.subset_closure
    ⟨i, j, hij, leavittWordS a * leavittWordT b, rfl⟩

def nineCrossSwap (i j : Fin 9) (hij : i ≠ j)
    (a b : List (Fin 2)) : BinaryLeavittˣ :=
  nineCrossRoot i j hij a b *
    nineCrossRoot j i hij.symm b a *
    nineCrossRoot i j hij a b

theorem nineCrossSwap_mem (i j : Fin 9) (hij : i ≠ j)
    (a b : List (Fin 2)) :
    nineCrossSwap i j hij a b ∈ prefixElementaryGroup ninePrefixCode := by
  exact (prefixElementaryGroup ninePrefixCode).mul_mem
    ((prefixElementaryGroup ninePrefixCode).mul_mem
      (nineCrossRoot_mem i j hij a b)
      (nineCrossRoot_mem j i hij.symm b a))
    (nineCrossRoot_mem i j hij a b)

def compressionTransitionCrossSwaps : List BinaryLeavittˣ :=
  [nineCrossSwap 0 1 (by decide) [1, 0] [],
   nineCrossSwap 0 4 (by decide) [1, 1] [],
   nineCrossSwap 3 7 (by decide) [1] [],
   nineCrossSwap 6 2 (by decide) [1, 0, 0] [],
   nineCrossSwap 6 5 (by decide) [1, 0, 1] [],
   nineCrossSwap 6 8 (by decide) [1, 1] []]

theorem compressionTransitionCrossSwaps_prod_mem :
    compressionTransitionCrossSwaps.prod ∈
      prefixElementaryGroup ninePrefixCode := by
  apply (prefixElementaryGroup ninePrefixCode).list_prod_mem
  intro x hx
  simp only [compressionTransitionCrossSwaps, List.mem_cons,
    List.not_mem_nil, or_false] at hx
  rcases hx with h | h | h | h | h | h <;>
    subst x <;> exact nineCrossSwap_mem _ _ _ _ _

def transpositionValue {A : Type*} [Ring A]
    (sa ta sb tb : A) : A :=
  1 - sa * ta - sb * tb + sa * tb + sb * ta

theorem transpositionValue_refine {A : Type*} [Ring A]
    (sa ta sb tb p₀ q₀ p₁ q₁ : A)
    (haa : ta * sa = 1) (hbb : tb * sb = 1)
    (hab : ta * sb = 0) (hba : tb * sa = 0)
    (h₀₀ : q₀ * p₀ = 1) (h₁₁ : q₁ * p₁ = 1)
    (h₀₁ : q₀ * p₁ = 0) (h₁₀ : q₁ * p₀ = 0)
    (hpartition : p₀ * q₀ + p₁ * q₁ = 1) :
    transpositionValue (sa * p₀) (q₀ * ta) (sb * p₀) (q₀ * tb) *
        transpositionValue (sa * p₁) (q₁ * ta) (sb * p₁) (q₁ * tb) =
      transpositionValue sa ta sb tb := by
  have haa' (x : A) : ta * (sa * x) = x := by
    rw [← mul_assoc, haa, one_mul]
  have hbb' (x : A) : tb * (sb * x) = x := by
    rw [← mul_assoc, hbb, one_mul]
  have hab' (x : A) : ta * (sb * x) = 0 := by
    rw [← mul_assoc, hab, zero_mul]
  have hba' (x : A) : tb * (sa * x) = 0 := by
    rw [← mul_assoc, hba, zero_mul]
  have h₀₀' (x : A) : q₀ * (p₀ * x) = x := by
    rw [← mul_assoc, h₀₀, one_mul]
  have h₁₁' (x : A) : q₁ * (p₁ * x) = x := by
    rw [← mul_assoc, h₁₁, one_mul]
  have h₀₁' (x : A) : q₀ * (p₁ * x) = 0 := by
    rw [← mul_assoc, h₀₁, zero_mul]
  have h₁₀' (x : A) : q₁ * (p₀ * x) = 0 := by
    rw [← mul_assoc, h₁₀, zero_mul]
  have hpartition' (x : A) :
      p₀ * (q₀ * x) + p₁ * (q₁ * x) = x := by
    rw [← mul_assoc, ← mul_assoc, ← add_mul, hpartition, one_mul]
  have hpartition_left (z x : A) :
      z * (p₀ * (q₀ * x)) + z * (p₁ * (q₁ * x)) = z * x := by
    rw [← mul_add, hpartition']
  unfold transpositionValue
  calc
    _ = 1 -
          (sa * (p₀ * (q₀ * ta)) + sa * (p₁ * (q₁ * ta))) -
          (sb * (p₀ * (q₀ * tb)) + sb * (p₁ * (q₁ * tb))) +
          (sa * (p₀ * (q₀ * tb)) + sa * (p₁ * (q₁ * tb))) +
          (sb * (p₀ * (q₀ * ta)) + sb * (p₁ * (q₁ * ta))) := by
            noncomm_ring [haa, hbb, hab, hba, h₀₀, h₁₁, h₀₁, h₁₀,
              haa', hbb', hab', hba', h₀₀', h₁₁', h₀₁', h₁₀']
    _ = _ := by
      rw [hpartition_left sa ta, hpartition_left sb tb,
        hpartition_left sa tb, hpartition_left sb ta]

theorem nineRefinement_orthogonal
    (i j : Fin 9) (hij : i ≠ j) (a b : List (Fin 2)) :
    leavittWordT (nineWord i ++ a) *
      leavittWordS (nineWord j ++ b) = 0 := by
  have hzero :
      leavittWordT (nineWord i) * leavittWordS (nineWord j) = 0 := by
    simpa [ninePrefixCode, hij] using
      binaryPrefixCode_orthogonal ninePrefixCode i j
  rw [leavittWordT_append, leavittWordS_append]
  calc
    (leavittWordT a * leavittWordT (nineWord i)) *
        (leavittWordS (nineWord j) * leavittWordS b) =
      leavittWordT a *
        (leavittWordT (nineWord i) * leavittWordS (nineWord j)) *
        leavittWordS b := by noncomm_ring
    _ = 0 := by rw [hzero]; simp

theorem nineCrossSwap_val (i j : Fin 9) (hij : i ≠ j)
    (a b : List (Fin 2)) :
    (↑(nineCrossSwap i j hij a b) : BinaryLeavitt) =
      transpositionValue
        (leavittWordS (nineWord i ++ a))
        (leavittWordT (nineWord i ++ a))
        (leavittWordS (nineWord j ++ b))
        (leavittWordT (nineWord j ++ b)) := by
  let A : List (Fin 2) := nineWord i ++ a
  let B : List (Fin 2) := nineWord j ++ b
  let P : BinaryLeavitt := leavittWordS A * leavittWordT B
  let Q : BinaryLeavitt := leavittWordS B * leavittWordT A
  have hBA : leavittWordT B * leavittWordS A = 0 :=
    nineRefinement_orthogonal j i hij.symm b a
  have hPP : P * P = 0 := by
    change
      (leavittWordS A * leavittWordT B) *
        (leavittWordS A * leavittWordT B) = 0
    calc
      (leavittWordS A * leavittWordT B) *
          (leavittWordS A * leavittWordT B) =
        leavittWordS A *
          (leavittWordT B * leavittWordS A) *
          leavittWordT B := by noncomm_ring
      _ = 0 := by rw [hBA]; simp
  have hPQP : P * Q * P = P := by
    change
      (leavittWordS A * leavittWordT B) *
        (leavittWordS B * leavittWordT A) *
        (leavittWordS A * leavittWordT B) =
        leavittWordS A * leavittWordT B
    calc
      (leavittWordS A * leavittWordT B) *
          (leavittWordS B * leavittWordT A) *
          (leavittWordS A * leavittWordT B) =
        leavittWordS A *
          (leavittWordT B * leavittWordS B) *
          (leavittWordT A * leavittWordS A) *
          leavittWordT B := by noncomm_ring
      _ = leavittWordS A * leavittWordT B := by
        rw [leavittWordT_mul_wordS_self,
          leavittWordT_mul_wordS_self]
        simp
  have hPQ : P * Q = leavittWordS A * leavittWordT A := by
    dsimp [P, Q]
    calc
      (leavittWordS A * leavittWordT B) *
          (leavittWordS B * leavittWordT A) =
        leavittWordS A *
          (leavittWordT B * leavittWordS B) *
          leavittWordT A := by noncomm_ring
      _ = _ := by rw [leavittWordT_mul_wordS_self]; simp
  have hQP : Q * P = leavittWordS B * leavittWordT B := by
    dsimp [P, Q]
    calc
      (leavittWordS B * leavittWordT A) *
          (leavittWordS A * leavittWordT B) =
        leavittWordS B *
          (leavittWordT A * leavittWordS A) *
          leavittWordT B := by noncomm_ring
      _ = _ := by rw [leavittWordT_mul_wordS_self]; simp
  change
    (1 + leavittWordS (nineWord i) *
      (leavittWordS a * leavittWordT b) * leavittWordT (nineWord j)) *
      (1 + leavittWordS (nineWord j) *
        (leavittWordS b * leavittWordT a) * leavittWordT (nineWord i)) *
      (1 + leavittWordS (nineWord i) *
        (leavittWordS a * leavittWordT b) * leavittWordT (nineWord j)) = _
  have hleft :
      leavittWordS (nineWord i) *
          (leavittWordS a * leavittWordT b) * leavittWordT (nineWord j) =
        P := by
    dsimp [P, A, B]
    rw [leavittWordS_append, leavittWordT_append]
    noncomm_ring
  have hright :
      leavittWordS (nineWord j) *
          (leavittWordS b * leavittWordT a) * leavittWordT (nineWord i) =
        Q := by
    dsimp [Q, A, B]
    rw [leavittWordS_append, leavittWordT_append]
    noncomm_ring
  rw [hleft, hright,
    SoficGroups.cylinder_transposition_factorization P Q hPP hPQP,
    hPQ, hQP]
  rfl

def wordSwapValue (a b : List (Fin 2)) : BinaryLeavitt :=
  transpositionValue (leavittWordS a) (leavittWordT a)
    (leavittWordS b) (leavittWordT b)

theorem wordSwapValue_refine (a b : List (Fin 2))
    (hab : leavittWordT a * leavittWordS b = 0)
    (hba : leavittWordT b * leavittWordS a = 0) :
    wordSwapValue (a ++ [0]) (b ++ [0]) *
        wordSwapValue (a ++ [1]) (b ++ [1]) =
      wordSwapValue a b := by
  unfold wordSwapValue
  simpa only [leavittWordS_append, leavittWordT_append,
    leavittWordS, leavittWordT, mul_one, one_mul] using
    transpositionValue_refine
      (leavittWordS a) (leavittWordT a)
      (leavittWordS b) (leavittWordT b)
      (leavittS 0) (leavittT 0)
      (leavittS 1) (leavittT 1)
      (leavittWordT_mul_wordS_self a)
      (leavittWordT_mul_wordS_self b)
      hab hba
      (by simpa using leavittT_mul_S 0 0)
      (by simpa using leavittT_mul_S 1 1)
      (by simpa using leavittT_mul_S 0 1)
      (by simpa using leavittT_mul_S 1 0)
      leavitt_partition

theorem compressionTransitionCrossSwaps_prod_val :
    (↑compressionTransitionCrossSwaps.prod : BinaryLeavitt) =
      wordSwapValue (uWord 1) (uWord 2) *
        wordSwapValue (uWord 4) (uWord 5) *
        wordSwapValue (uWord 7) (uWord 8) := by
  have h₀ :
      wordSwapValue [0, 0, 0, 1, 0] [1, 0, 0, 0] *
        wordSwapValue [0, 0, 0, 1, 1] [1, 0, 0, 1] =
        wordSwapValue [0, 0, 0, 1] [1, 0, 0] := by
    simpa using wordSwapValue_refine
      [0, 0, 0, 1] [1, 0, 0]
      (leavittWordT_mul_wordS_of_incomparable _ _ (by decide) (by decide))
      (leavittWordT_mul_wordS_of_incomparable _ _ (by decide) (by decide))
  have h₂₀ :
      wordSwapValue [0, 1, 1, 0, 0] [1, 1, 0, 0] *
        wordSwapValue [0, 1, 1, 0, 1] [1, 1, 0, 1] =
        wordSwapValue [0, 1, 1, 0] [1, 1, 0] := by
    simpa using wordSwapValue_refine
      [0, 1, 1, 0] [1, 1, 0]
      (leavittWordT_mul_wordS_of_incomparable _ _ (by decide) (by decide))
      (leavittWordT_mul_wordS_of_incomparable _ _ (by decide) (by decide))
  have h₂ :
      wordSwapValue [0, 1, 1, 0] [1, 1, 0] *
        wordSwapValue [0, 1, 1, 1] [1, 1, 1] =
        wordSwapValue [0, 1, 1] [1, 1] := by
    simpa using wordSwapValue_refine
      [0, 1, 1] [1, 1]
      (leavittWordT_mul_wordS_of_incomparable _ _ (by decide) (by decide))
      (leavittWordT_mul_wordS_of_incomparable _ _ (by decide) (by decide))
  simp only [compressionTransitionCrossSwaps, List.prod_cons, List.prod_nil,
    Units.val_mul, nineCrossSwap_val, mul_one]
  change
    wordSwapValue [0, 0, 0, 1, 0] [1, 0, 0, 0] *
      (wordSwapValue [0, 0, 0, 1, 1] [1, 0, 0, 1] *
      (wordSwapValue [0, 0, 1, 1] [1, 0, 1] *
      (wordSwapValue [0, 1, 1, 0, 0] [1, 1, 0, 0] *
      (wordSwapValue [0, 1, 1, 0, 1] [1, 1, 0, 1] *
       wordSwapValue [0, 1, 1, 1] [1, 1, 1])))) =
    wordSwapValue [0, 0, 0, 1] [1, 0, 0] *
      wordSwapValue [0, 0, 1, 1] [1, 0, 1] *
      wordSwapValue [0, 1, 1] [1, 1]
  calc
    _ =
      (wordSwapValue [0, 0, 0, 1, 0] [1, 0, 0, 0] *
        wordSwapValue [0, 0, 0, 1, 1] [1, 0, 0, 1]) *
      wordSwapValue [0, 0, 1, 1] [1, 0, 1] *
      ((wordSwapValue [0, 1, 1, 0, 0] [1, 1, 0, 0] *
        wordSwapValue [0, 1, 1, 0, 1] [1, 1, 0, 1]) *
        wordSwapValue [0, 1, 1, 1] [1, 1, 1]) := by
          noncomm_ring
    _ = _ := by rw [h₀, h₂₀, h₂]

theorem transpositionValue_mul_codeWord {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι) (i j : ι) (hij : i ≠ j) (k : ι) :
    transpositionValue
        (leavittWordS (E.word i)) (leavittWordT (E.word i))
        (leavittWordS (E.word j)) (leavittWordT (E.word j)) *
        leavittWordS (E.word k) =
      if k = i then leavittWordS (E.word j)
      else if k = j then leavittWordS (E.word i)
      else leavittWordS (E.word k) := by
  by_cases hki : k = i
  · subst k
    simp [transpositionValue, sub_mul, add_mul, mul_assoc,
      binaryPrefixCode_orthogonal, hij.symm]
  · by_cases hkj : k = j
    · subst k
      simp [transpositionValue, sub_mul, add_mul, mul_assoc,
        binaryPrefixCode_orthogonal, hij, hij.symm]
    · simp [transpositionValue, sub_mul, add_mul, mul_assoc,
        binaryPrefixCode_orthogonal,
        hki, Ne.symm hki, hkj, Ne.symm hkj]

theorem uSwap12_mul (k : Fin 9) :
    wordSwapValue (uWord 1) (uWord 2) * leavittWordS (uWord k) =
      if k = 1 then leavittWordS (uWord 2)
      else if k = 2 then leavittWordS (uWord 1)
      else leavittWordS (uWord k) :=
  transpositionValue_mul_codeWord uPrefixCode 1 2 (by decide) k

theorem uSwap45_mul (k : Fin 9) :
    wordSwapValue (uWord 4) (uWord 5) * leavittWordS (uWord k) =
      if k = 4 then leavittWordS (uWord 5)
      else if k = 5 then leavittWordS (uWord 4)
      else leavittWordS (uWord k) :=
  transpositionValue_mul_codeWord uPrefixCode 4 5 (by decide) k

theorem uSwap78_mul (k : Fin 9) :
    wordSwapValue (uWord 7) (uWord 8) * leavittWordS (uWord k) =
      if k = 7 then leavittWordS (uWord 8)
      else if k = 8 then leavittWordS (uWord 7)
      else leavittWordS (uWord k) :=
  transpositionValue_mul_codeWord uPrefixCode 7 8 (by decide) k

theorem compressionTransitionParentSwaps_mul_word (k : Fin 9) :
    (wordSwapValue (uWord 1) (uWord 2) *
      wordSwapValue (uWord 4) (uWord 5) *
      wordSwapValue (uWord 7) (uWord 8)) *
        leavittWordS (uWord k) = leavittWordS (vWord k) := by
  fin_cases k <;>
    simp [mul_assoc, uSwap12_mul, uSwap45_mul, uSwap78_mul] <;>
    rfl

theorem compressionTransitionParentSwaps_eq_table :
    wordSwapValue (uWord 1) (uWord 2) *
        wordSwapValue (uWord 4) (uWord 5) *
        wordSwapValue (uWord 7) (uWord 8) =
      prefixTable uPrefixCode vPrefixCode := by
  let x : BinaryLeavitt :=
    wordSwapValue (uWord 1) (uWord 2) *
      wordSwapValue (uWord 4) (uWord 5) *
      wordSwapValue (uWord 7) (uWord 8)
  change x = prefixTable uPrefixCode vPrefixCode
  calc
    x = x * 1 := (mul_one x).symm
    _ = x * MatrixCorner.codeIdempotent
          (fun i => leavittWordS (uPrefixCode.word i))
          (fun i => leavittWordT (uPrefixCode.word i)) := by
            rw [uPrefixCode_complete]
    _ = ∑ i : Fin 9,
          (x * leavittWordS (uWord i)) * leavittWordT (uWord i) := by
            simp [MatrixCorner.codeIdempotent, Finset.mul_sum, mul_assoc,
              uPrefixCode]
    _ = ∑ i : Fin 9,
          leavittWordS (vWord i) * leavittWordT (uWord i) := by
            apply Finset.sum_congr rfl
            intro i _
            rw [show x * leavittWordS (uWord i) =
              leavittWordS (vWord i) from
              compressionTransitionParentSwaps_mul_word i]
    _ = prefixTable uPrefixCode vPrefixCode := rfl

theorem compressionTransitionCrossSwaps_prod_eq :
    compressionTransitionCrossSwaps.prod = compressionTransition := by
  apply Units.ext
  exact compressionTransitionCrossSwaps_prod_val.trans
    compressionTransitionParentSwaps_eq_table

theorem compressionTransition_mem :
    compressionTransition ∈ prefixElementaryGroup ninePrefixCode := by
  rw [← compressionTransitionCrossSwaps_prod_eq]
  exact compressionTransitionCrossSwaps_prod_mem

theorem compressionV_mem_of_compressionU
    (hU : compressionU ∈ prefixElementaryGroup ninePrefixCode) :
    compressionV ∈ prefixElementaryGroup ninePrefixCode := by
  rw [compressionV_eq_transition_mul]
  exact (prefixElementaryGroup ninePrefixCode).mul_mem
    compressionTransition_mem hU

end PrefixCompression

theorem compressionV_mem_ninePrefixElementaryGroup :
    compressionV ∈ prefixElementaryGroup ninePrefixCode :=
  PrefixCompression.compressionV_mem_of_compressionU
    compressionU_mem_ninePrefixElementaryGroup

theorem sourceGeneratedGroup_eq_nine :
    SourceGeneration.sourceGeneratedGroup =
      prefixElementaryGroup ninePrefixCode :=
  SourceGeneration.sourceGeneratedGroup_eq_nine_of_compressions
    compressionU_mem_ninePrefixElementaryGroup
    compressionV_mem_ninePrefixElementaryGroup

theorem shifted_floor_drop_subset_two_intervals
    (u v H : ℝ) (hH : 0 < H) (k : ℤ) (hk : k = ⌊u / H⌋) :
    {r : ℝ | r ∈ Set.Ico 0 H ∧ ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋} ⊆
      Set.Ico ((k : ℝ) * H - u) ((k : ℝ) * H - v) ∪
        Set.Ico (((k + 1 : ℤ) : ℝ) * H - u)
          (((k + 1 : ℤ) : ℝ) * H - v) := by
  intro r hr
  rcases hr with ⟨⟨hr0, hrH⟩, hdrop⟩
  let j : ℤ := ⌊(u + r) / H⌋
  have hlow : k ≤ j := by
    rw [hk]
    apply Int.floor_mono
    apply (div_le_div_iff_of_pos_right hH).2
    linarith
  have hhigh : j < k + 2 := by
    apply Int.floor_lt.mpr
    have hu : u / H < (k : ℝ) + 1 := by
      rw [hk]
      exact Int.lt_floor_add_one (u / H)
    have hr' : r / H < 1 := (div_lt_one hH).mpr hrH
    calc
      (u + r) / H = u / H + r / H := by ring
      _ < ((k : ℝ) + 1) + 1 := add_lt_add hu hr'
      _ = ((k + 2 : ℤ) : ℝ) := by push_cast; ring
  have hcases : j = k ∨ j = k + 1 := by omega
  have hv : (v + r) / H < (j : ℝ) := by
    apply Int.floor_lt.mp
    exact hdrop
  have hu : (j : ℝ) ≤ (u + r) / H := Int.floor_le _
  have hv' : v + r < (j : ℝ) * H := (div_lt_iff₀ hH).mp hv
  have hu' : (j : ℝ) * H ≤ u + r := (le_div_iff₀ hH).mp hu
  rcases hcases with hcase | hcase
  · left
    rw [hcase] at hv' hu'
    exact ⟨by linarith, by linarith⟩
  · right
    rw [hcase] at hv' hu'
    exact ⟨by linarith, by linarith⟩

theorem measurableSet_shifted_floor_drop (u v H : ℝ) :
    MeasurableSet
      {r : ℝ | ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋} := by
  have hv : Measurable (fun r : ℝ => ⌊(v + r) / H⌋) := by
    fun_prop
  have hu : Measurable (fun r : ℝ => ⌊(u + r) / H⌋) := by
    fun_prop
  exact measurableSet_lt hv hu

theorem exists_common_offset_below_average
    (H : ℝ) (hH : 0 < H) (f : ℝ → ℝ)
    (hf : MeasureTheory.IntegrableOn f (Set.Ico 0 H)
      MeasureTheory.volume) :
    ∃ r ∈ Set.Ico 0 H,
      f r ≤ MeasureTheory.average
        (MeasureTheory.volume.restrict (Set.Ico 0 H)) f := by
  have hvolume : MeasureTheory.volume (Set.Ico (0 : ℝ) H) =
      ENNReal.ofReal H := by
    rw [Real.volume_Ico, sub_zero]
  have hnezero : MeasureTheory.volume (Set.Ico (0 : ℝ) H) ≠ 0 := by
    rw [hvolume]
    exact ENNReal.ofReal_ne_zero_iff.mpr hH
  have hnetop : MeasureTheory.volume (Set.Ico (0 : ℝ) H) ≠ ⊤ := by
    rw [hvolume]
    exact ENNReal.ofReal_ne_top
  exact MeasureTheory.exists_le_setAverage hnezero hnetop hf

noncomputable def rankDropCount {ι : Type*} [Fintype ι]
    (u v : ι → ℝ) (H r : ℝ) : ℝ :=
  Finset.univ.sum (fun i : ι =>
    if ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋ then (1 : ℝ) else 0)

theorem measurable_rankDropCount {ι : Type*} [Fintype ι]
    (u v : ι → ℝ) (H : ℝ) :
    Measurable (fun r : ℝ => rankDropCount u v H r) := by
  classical
  unfold rankDropCount
  apply Finset.measurable_sum
  intro i hi
  exact Measurable.ite
    (measurableSet_shifted_floor_drop (u i) (v i) H)
    measurable_const measurable_const

theorem rankDropCount_nonneg_and_le {ι : Type*} [Fintype ι]
    (u v : ι → ℝ) (H r : ℝ) :
    0 ≤ rankDropCount u v H r ∧
      rankDropCount u v H r ≤ (Fintype.card ι : ℝ) := by
  classical
  constructor
  · unfold rankDropCount
    exact Finset.sum_nonneg (fun i hi => by split_ifs <;> norm_num)
  · unfold rankDropCount
    calc
      (∑ i : ι, if ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋
        then (1 : ℝ) else 0) ≤ ∑ _i : ι, (1 : ℝ) := by
          apply Finset.sum_le_sum
          intro i hi
          split_ifs <;> norm_num
      _ = (Fintype.card ι : ℝ) := by simp

theorem integrableOn_rankDropCount {ι : Type*} [Fintype ι]
    (u v : ι → ℝ) (H : ℝ) :
    MeasureTheory.IntegrableOn (fun r : ℝ => rankDropCount u v H r)
      (Set.Ico 0 H) MeasureTheory.volume := by
  have hfinite : MeasureTheory.volume (Set.Ico (0 : ℝ) H) < ⊤ := by
    rw [Real.volume_Ico]
    exact ENNReal.ofReal_lt_top
  refine ⟨(measurable_rankDropCount u v H).aestronglyMeasurable, ?_⟩
  apply MeasureTheory.HasFiniteIntegral.restrict_of_bounded
    (Fintype.card ι : ℝ) hfinite
  filter_upwards [] with r
  rw [Real.norm_eq_abs, abs_of_nonneg
    (rankDropCount_nonneg_and_le u v H r).1]
  exact (rankDropCount_nonneg_and_le u v H r).2

theorem integrable_rankDropIndicator
    (u v H : ℝ) :
    MeasureTheory.Integrable
      (fun r : ℝ =>
        if ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋ then (1 : ℝ) else 0)
      (MeasureTheory.volume.restrict (Set.Ico 0 H)) := by
  have hfinite : MeasureTheory.volume (Set.Ico (0 : ℝ) H) < ⊤ := by
    rw [Real.volume_Ico]
    exact ENNReal.ofReal_lt_top
  have hmeas : Measurable
      (fun r : ℝ =>
        if ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋ then (1 : ℝ) else 0) :=
    Measurable.ite (measurableSet_shifted_floor_drop u v H)
      measurable_const measurable_const
  refine ⟨hmeas.aestronglyMeasurable, ?_⟩
  apply MeasureTheory.HasFiniteIntegral.restrict_of_bounded
    (1 : ℝ) hfinite
  filter_upwards [] with r
  split_ifs <;> norm_num

theorem exists_common_rank_offset {ι : Type*} [Fintype ι]
    (u v : ι → ℝ) (H : ℝ) (hH : 0 < H) :
    ∃ r ∈ Set.Ico 0 H,
      rankDropCount u v H r ≤
        MeasureTheory.average
          (MeasureTheory.volume.restrict (Set.Ico 0 H))
          (fun t : ℝ => rankDropCount u v H t) := by
  exact exists_common_offset_below_average H hH
    (fun t : ℝ => rankDropCount u v H t)
    (integrableOn_rankDropCount u v H)

theorem rankDropCount_integral_eq {ι : Type*} [Fintype ι]
    (u v : ι → ℝ) (H : ℝ) :
    (∫ r, rankDropCount u v H r
      ∂(MeasureTheory.volume.restrict (Set.Ico 0 H))) =
      ∑ i : ι, (MeasureTheory.volume.restrict (Set.Ico 0 H)).real
        {r : ℝ | ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋} := by
  classical
  unfold rankDropCount
  rw [MeasureTheory.integral_finsetSum Finset.univ
    (fun i hi => integrable_rankDropIndicator (u i) (v i) H)]
  apply Finset.sum_congr rfl
  intro i hi
  have hindicator :
      (fun r : ℝ =>
        if ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋
          then (1 : ℝ) else 0) =
        {r : ℝ | ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋}.indicator
          (fun _ : ℝ => (1 : ℝ)) := by
    funext r
    simp [Set.indicator]
  rw [hindicator]
  exact MeasureTheory.integral_indicator_one
    (measurableSet_shifted_floor_drop (u i) (v i) H)

theorem rankDropCount_average_eq {ι : Type*} [Fintype ι]
    (u v : ι → ℝ) (H : ℝ) (hH : 0 < H) :
    MeasureTheory.average
        (MeasureTheory.volume.restrict (Set.Ico 0 H))
        (fun r : ℝ => rankDropCount u v H r) =
      H⁻¹ * ∑ i : ι,
        (MeasureTheory.volume.restrict (Set.Ico 0 H)).real
          {r : ℝ | ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋} := by
  rw [MeasureTheory.average_eq,
    MeasureTheory.measureReal_restrict_apply_univ,
    Real.volume_real_Ico_of_le hH.le, sub_zero,
    rankDropCount_integral_eq]
  exact smul_eq_mul _ _

theorem rankDropCount_clamp_eq {ι : Type*} [Fintype ι]
    (u v : ι → ℝ) (H r : ℝ) (hH : 0 < H) :
    rankDropCount u v H r =
      rankDropCount u (fun i => min (v i) (u i)) H r := by
  classical
  unfold rankDropCount
  apply Finset.sum_congr rfl
  intro i hi
  change
    (if ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋
      then (1 : ℝ) else 0) =
      if ⌊(min (v i) (u i) + r) / H⌋ < ⌊(u i + r) / H⌋
        then (1 : ℝ) else 0
  by_cases hle : v i ≤ u i
  · rw [min_eq_left hle]
  · have hreverse : u i ≤ v i := le_of_not_ge hle
    have hfloor :
        ¬ ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋ := by
      apply not_lt_of_ge
      apply Int.floor_mono
      apply (div_le_div_iff_of_pos_right hH).2
      linarith
    simp [min_eq_right hreverse, hfloor]

theorem shifted_floor_drop_volume_bound_sharp
    (u v H : ℝ) (hH : 0 < H) (hvu : v ≤ u) :
    MeasureTheory.volume
        {r : ℝ | r ∈ Set.Ico 0 H ∧
          ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋} ≤
      ENNReal.ofReal (u - v) := by
  let k : ℤ := ⌊u / H⌋
  let c : ℝ := (((k + 1 : ℤ) : ℝ) * H - u)
  let d : ℝ := u - v
  have hd : 0 ≤ d := sub_nonneg.mpr hvu
  have hklo : (k : ℝ) ≤ u / H := by
    dsimp [k]
    exact Int.floor_le _
  have hkhi : u / H < (k : ℝ) + 1 := by
    dsimp [k]
    exact Int.lt_floor_add_one _
  have hklo' : (k : ℝ) * H ≤ u := (le_div_iff₀ hH).mp hklo
  have hkhi' : u < ((k : ℝ) + 1) * H := (div_lt_iff₀ hH).mp hkhi
  have hc0 : 0 ≤ c := by
    dsimp [c]
    push_cast
    linarith
  have hcH : c ≤ H := by
    dsimp [c]
    push_cast
    linarith
  let A : Set ℝ := Set.Ico 0 (max 0 (c - H + d))
  let B : Set ℝ := Set.Ico c (min H (c + d))
  have hsubset :
      {r : ℝ | r ∈ Set.Ico 0 H ∧
        ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋} ⊆ A ∪ B := by
    intro r hr
    have htwo := shifted_floor_drop_subset_two_intervals u v H hH k rfl hr
    rcases htwo with hleft | hright
    · left
      change r ∈ Set.Ico 0 (max 0 (c - H + d))
      refine ⟨hr.1.1, ?_⟩
      apply lt_of_lt_of_le (b := c - H + d)
      · have hupper := hleft.2
        dsimp [c, d]
        push_cast
        linarith
      · exact le_max_right _ _
    · right
      change r ∈ Set.Ico c (min H (c + d))
      refine ⟨?_, lt_min hr.1.2 ?_⟩
      · have hlower := hright.1
        dsimp [c]
        exact hlower
      · have hupper := hright.2
        dsimp [c, d]
        push_cast at hupper ⊢
        linarith
  have hA : MeasureTheory.volume A =
      ENNReal.ofReal (max 0 (c - H + d)) := by
    dsimp [A]
    rw [Real.volume_Ico, sub_zero]
  have hB : MeasureTheory.volume B =
      ENNReal.ofReal (min H (c + d) - c) := by
    dsimp [B]
    rw [Real.volume_Ico]
  have hA0 : 0 ≤ max 0 (c - H + d) := le_max_left _ _
  have hB0 : 0 ≤ min H (c + d) - c := by
    apply sub_nonneg.mpr
    exact le_min hcH (by linarith)
  have hlength : max 0 (c - H + d) + (min H (c + d) - c) = d := by
    by_cases hshort : d ≤ H - c
    · rw [max_eq_left (by linarith), min_eq_right (by linarith)]
      ring
    · have hlong : H - c < d := lt_of_not_ge hshort
      rw [max_eq_right (by linarith), min_eq_left (by linarith)]
      ring
  calc
    MeasureTheory.volume
        {r : ℝ | r ∈ Set.Ico 0 H ∧
          ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋} ≤
        MeasureTheory.volume (A ∪ B) :=
      MeasureTheory.measure_mono hsubset
    _ ≤ MeasureTheory.volume A + MeasureTheory.volume B :=
      MeasureTheory.measure_union_le A B
    _ = ENNReal.ofReal (max 0 (c - H + d)) +
        ENNReal.ofReal (min H (c + d) - c) := by rw [hA, hB]
    _ = ENNReal.ofReal d := by
      rw [← ENNReal.ofReal_add hA0 hB0, hlength]
    _ = ENNReal.ofReal (u - v) := by rfl

theorem rankDrop_measureReal_bound_sharp
    (u v H : ℝ) (hH : 0 < H) (hvu : v ≤ u) :
    (MeasureTheory.volume.restrict (Set.Ico 0 H)).real
      {r : ℝ | ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋} ≤
      u - v := by
  rw [MeasureTheory.measureReal_restrict_apply
    (measurableSet_shifted_floor_drop u v H)]
  have heq :
      {r : ℝ | ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋} ∩ Set.Ico 0 H =
        {r : ℝ | r ∈ Set.Ico 0 H ∧
          ⌊(v + r) / H⌋ < ⌊(u + r) / H⌋} := by
    ext r
    simp [and_comm]
  rw [heq, MeasureTheory.measureReal_def]
  have hbound := shifted_floor_drop_volume_bound_sharp u v H hH hvu
  have hreal := ENNReal.toReal_mono ENNReal.ofReal_ne_top hbound
  rwa [ENNReal.toReal_ofReal (sub_nonneg.mpr hvu)] at hreal

theorem exists_common_rank_offset_bound_sharp {ι : Type*} [Fintype ι]
    (u v : ι → ℝ) (H : ℝ) (hH : 0 < H)
    (hvu : ∀ i : ι, v i ≤ u i) :
    ∃ r ∈ Set.Ico 0 H,
      rankDropCount u v H r ≤
        (1 / H) * ∑ i : ι, (u i - v i) := by
  classical
  obtain ⟨r, hr, hmean⟩ := exists_common_rank_offset u v H hH
  refine ⟨r, hr, hmean.trans ?_⟩
  rw [rankDropCount_average_eq u v H hH]
  have hsum :
      (∑ i : ι, (MeasureTheory.volume.restrict (Set.Ico 0 H)).real
          {r : ℝ | ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋}) ≤
        ∑ i : ι, (u i - v i) := by
    exact Finset.sum_le_sum (fun i hi =>
      rankDrop_measureReal_bound_sharp (u i) (v i) H hH (hvu i))
  calc
    H⁻¹ *
        (∑ i : ι, (MeasureTheory.volume.restrict (Set.Ico 0 H)).real
          {r : ℝ | ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋}) ≤
      H⁻¹ * ∑ i : ι, (u i - v i) :=
        mul_le_mul_of_nonneg_left hsum (inv_nonneg.mpr hH.le)
    _ = (1 / H) * ∑ i : ι, (u i - v i) := by
      rw [one_div]

theorem exists_common_rank_offset_one_sided_sharp
    {ι : Type*} [Fintype ι]
    (u v delta : ι → ℝ) (H : ℝ) (hH : 0 < H)
    (hdelta : ∀ i : ι, 0 ≤ delta i)
    (hone : ∀ i : ι, u i - delta i ≤ v i) :
    ∃ r ∈ Set.Ico 0 H,
      rankDropCount u v H r ≤
        (1 / H) * ∑ i : ι, delta i := by
  classical
  obtain ⟨r, hr, hbound⟩ :=
    exists_common_rank_offset_bound_sharp
      u (fun i => min (v i) (u i))
      H hH (fun i => min_le_right (v i) (u i))
  refine ⟨r, hr, ?_⟩
  have hsum :
      (∑ i : ι, (u i - min (v i) (u i))) ≤
        ∑ i : ι, delta i := by
    apply Finset.sum_le_sum
    intro i hi
    by_cases hle : v i ≤ u i
    · rw [min_eq_left hle]
      linarith [hone i]
    · rw [min_eq_right (le_of_not_ge hle), sub_self]
      exact hdelta i
  calc
    rankDropCount u v H r =
      rankDropCount u (fun i => min (v i) (u i)) H r :=
        rankDropCount_clamp_eq u v H r hH
    _ ≤ (1 / H) * ∑ i : ι, (u i - min (v i) (u i)) := hbound
    _ ≤ (1 / H) * ∑ i : ι, delta i :=
      mul_le_mul_of_nonneg_left hsum (by positivity)

theorem log_one_sided_of_multiplicative
    (x y eta : ℝ) (hx : 0 < x)
    (heta0 : 0 ≤ eta) (heta1 : eta < 1)
    (hcomparison : (1 - eta) * x ≤ y) :
    Real.log x - |Real.log (1 - eta)| ≤ Real.log y := by
  have hfactor : 0 < 1 - eta := by linarith
  have hy : 0 < y :=
    lt_of_lt_of_le (mul_pos hfactor hx) hcomparison
  have hlog : Real.log ((1 - eta) * x) ≤ Real.log y :=
    (Real.log_le_log_iff (mul_pos hfactor hx) hy).2 hcomparison
  rw [Real.log_mul hfactor.ne' hx.ne'] at hlog
  have hnonpos : Real.log (1 - eta) ≤ 0 :=
    Real.log_nonpos hfactor.le (by linarith)
  rw [abs_of_nonpos hnonpos]
  linarith

theorem exists_common_log_rank_offset {ι : Type*} [Fintype ι]
    (x y : ι → ℝ) (eta H : ℝ)
    (hx : ∀ i : ι, 0 < x i)
    (heta0 : 0 ≤ eta) (heta1 : eta < 1) (hH : 0 < H)
    (hcomparison : ∀ i : ι, (1 - eta) * x i ≤ y i) :
    ∃ r ∈ Set.Ico 0 H,
      rankDropCount (fun i => Real.log (x i))
          (fun i => Real.log (y i)) H r ≤
        (Fintype.card ι : ℝ) * |Real.log (1 - eta)| / H := by
  classical
  obtain ⟨r, hr, hbound⟩ :=
    exists_common_rank_offset_one_sided_sharp
      (fun i => Real.log (x i))
      (fun i => Real.log (y i))
      (fun _ : ι => |Real.log (1 - eta)|)
      H hH
      (fun _ => abs_nonneg _)
      (fun i => log_one_sided_of_multiplicative
        (x i) (y i) eta (hx i) heta0 heta1 (hcomparison i))
  refine ⟨r, hr, hbound.trans_eq ?_⟩
  simp
  ring

theorem abs_log_one_sub_le_two_mul
    (eta : ℝ) (heta0 : 0 ≤ eta) (hetaHalf : eta ≤ (1 : ℝ) / 2) :
    |Real.log (1 - eta)| ≤ 2 * eta := by
  have hfactor : 0 < 1 - eta := by linarith
  have hlog : Real.log (1 - eta) ≤ 0 :=
    Real.log_nonpos hfactor.le (by linarith)
  rw [abs_of_nonpos hlog]
  have hlower := Real.one_sub_inv_le_log_of_pos hfactor
  have hratio : eta / (1 - eta) ≤ 2 * eta := by
    apply (div_le_iff₀ hfactor).2
    nlinarith [mul_nonneg heta0 (by linarith : 0 ≤ 1 - 2 * eta)]
  have hidentity : (1 - eta)⁻¹ - 1 = eta / (1 - eta) := by
    field_simp
    ring
  linarith

theorem abs_log_one_sub_div_tendsto_zero
    (eta H : ℕ → ℝ)
    (heta0 : ∀ n, 0 ≤ eta n)
    (hH : ∀ n, 0 < H n)
    (heta : Filter.Tendsto eta Filter.atTop (nhds 0))
    (hratio : Filter.Tendsto
      (fun n => eta n / H n) Filter.atTop (nhds 0)) :
    Filter.Tendsto
      (fun n => |Real.log (1 - eta n)| / H n)
      Filter.atTop (nhds 0) := by
  have hsmall : ∀ᶠ n in Filter.atTop,
      eta n < (1 : ℝ) / 2 :=
    heta.eventually (gt_mem_nhds (by norm_num))
  have hupper : ∀ᶠ n in Filter.atTop,
      |Real.log (1 - eta n)| / H n ≤
        2 * (eta n / H n) := by
    filter_upwards [hsmall] with n hn
    calc
      |Real.log (1 - eta n)| / H n ≤
          (2 * eta n) / H n :=
        (div_le_div_iff_of_pos_right (hH n)).2
          (abs_log_one_sub_le_two_mul
            (eta n) (heta0 n) hn.le)
      _ = 2 * (eta n / H n) := by ring
  have hlimit : Filter.Tendsto
      (fun n => 2 * (eta n / H n)) Filter.atTop (nhds 0) := by
    simpa using Filter.Tendsto.const_mul (2 : ℝ) hratio
  exact squeeze_zero'
    (Filter.Eventually.of_forall fun n =>
      div_nonneg (abs_nonneg _) (hH n).le)
    hupper hlimit

namespace CheegerPoincare

open scoped BigOperators

noncomputable def positiveSupport {V : Type*} [Fintype V]
    (f : V → ℝ) : Finset V := by
  classical
  exact Finset.univ.filter fun x => 0 < f x

@[simp] theorem mem_positiveSupport {V : Type*} [Fintype V]
    (f : V → ℝ) (x : V) :
    x ∈ positiveSupport f ↔ 0 < f x := by
  classical
  simp [positiveSupport]

noncomputable def finiteMean {V : Type*} [Fintype V] (f : V → ℝ) : ℝ :=
  (∑ x : V, f x) / (Fintype.card V : ℝ)

theorem sum_sub_finiteMean_eq_zero {V : Type*} [Fintype V] [Nonempty V]
    (f : V → ℝ) :
    (∑ x : V, (f x - finiteMean f)) = 0 := by
  have hcard : (Fintype.card V : ℝ) ≠ 0 := by
    exact_mod_cast Fintype.card_ne_zero
  simp only [Finset.sum_sub_distrib, Finset.sum_const,
    Finset.card_univ, nsmul_eq_mul, finiteMean]
  field_simp
  ring

theorem sum_sq_sub_finiteMean_le {V : Type*} [Fintype V] [Nonempty V]
    (f : V → ℝ) (c : ℝ) :
    (∑ x : V, (f x - finiteMean f) ^ 2) ≤
      ∑ x : V, (f x - c) ^ 2 := by
  have hpoint (x : V) :
      (f x - c) ^ 2 =
        (f x - finiteMean f) ^ 2 +
          2 * (finiteMean f - c) * (f x - finiteMean f) +
          (finiteMean f - c) ^ 2 := by
    ring
  have hidentity :
      (∑ x : V, (f x - c) ^ 2) =
        (∑ x : V, (f x - finiteMean f) ^ 2) +
          (Fintype.card V : ℝ) * (finiteMean f - c) ^ 2 := by
    calc
      (∑ x : V, (f x - c) ^ 2) =
          ∑ x : V,
            ((f x - finiteMean f) ^ 2 +
              2 * (finiteMean f - c) * (f x - finiteMean f) +
              (finiteMean f - c) ^ 2) :=
            Finset.sum_congr rfl (fun x _ => hpoint x)
      _ = (∑ x : V, (f x - finiteMean f) ^ 2) +
          2 * (finiteMean f - c) *
            (∑ x : V, (f x - finiteMean f)) +
          (Fintype.card V : ℝ) * (finiteMean f - c) ^ 2 := by
            simp only [Finset.sum_add_distrib, ← Finset.mul_sum,
              Finset.sum_const, Finset.card_univ, nsmul_eq_mul]
      _ = (∑ x : V, (f x - finiteMean f) ^ 2) +
          (Fintype.card V : ℝ) * (finiteMean f - c) ^ 2 := by
            rw [sum_sub_finiteMean_eq_zero]
            ring
  rw [hidentity]
  exact le_add_of_nonneg_right
    (mul_nonneg (Nat.cast_nonneg _) (sq_nonneg _))

noncomputable def lowerLevel {V : Type*} [Fintype V]
    (f : V → ℝ) (a : ℝ) : Finset V := by
  classical
  exact Finset.univ.filter fun x => f x < a

noncomputable def upperLevel {V : Type*} [Fintype V]
    (f : V → ℝ) (a : ℝ) : Finset V := by
  classical
  exact Finset.univ.filter fun x => a < f x

@[simp] theorem mem_lowerLevel {V : Type*} [Fintype V]
    (f : V → ℝ) (a : ℝ) (x : V) :
    x ∈ lowerLevel f a ↔ f x < a := by
  classical
  simp [lowerLevel]

@[simp] theorem mem_upperLevel {V : Type*} [Fintype V]
    (f : V → ℝ) (a : ℝ) (x : V) :
    x ∈ upperLevel f a ↔ a < f x := by
  classical
  simp [upperLevel]

theorem exists_finite_real_median {V : Type*} [Fintype V] [Nonempty V]
    (f : V → ℝ) :
    ∃ m : ℝ,
      2 * (lowerLevel f m).card ≤ Fintype.card V ∧
      2 * (upperLevel f m).card ≤ Fintype.card V := by
  classical
  let values : Finset ℝ := Finset.univ.image f
  have hvalues : values.Nonempty := by
    obtain ⟨x⟩ := ‹Nonempty V›
    refine ⟨f x, ?_⟩
    exact Finset.mem_image.mpr ⟨x, Finset.mem_univ x, rfl⟩
  let a : ℝ := values.min' hvalues
  have ha_values : a ∈ values := Finset.min'_mem values hvalues
  have ha_lower : lowerLevel f a = ∅ := by
    apply Finset.eq_empty_iff_forall_notMem.mpr
    intro x hx
    have hx_lt : f x < a := (mem_lowerLevel f a x).mp hx
    have hx_values : f x ∈ values :=
      Finset.mem_image.mpr ⟨x, Finset.mem_univ x, rfl⟩
    exact (not_lt_of_ge (Finset.min'_le values (f x) hx_values)) hx_lt
  let candidates : Finset ℝ :=
    values.filter fun c => 2 * (lowerLevel f c).card ≤ Fintype.card V
  have hcandidates : candidates.Nonempty := by
    refine ⟨a, ?_⟩
    apply Finset.mem_filter.mpr
    refine ⟨ha_values, ?_⟩
    simp [ha_lower]
  let m : ℝ := candidates.max' hcandidates
  have hm_candidates : m ∈ candidates :=
    Finset.max'_mem candidates hcandidates
  have hm_lower : 2 * (lowerLevel f m).card ≤ Fintype.card V :=
    (Finset.mem_filter.mp hm_candidates).2
  refine ⟨m, hm_lower, ?_⟩
  by_contra hu
  have hu_large : Fintype.card V < 2 * (upperLevel f m).card :=
    Nat.lt_of_not_ge hu
  have hu_nonempty : (upperLevel f m).Nonempty := by
    apply Finset.card_pos.mp
    omega
  let upperValues : Finset ℝ := (upperLevel f m).image f
  have hupperValues : upperValues.Nonempty :=
    Finset.image_nonempty.mpr hu_nonempty
  let b : ℝ := upperValues.min' hupperValues
  have hb_upperValues : b ∈ upperValues :=
    Finset.min'_mem upperValues hupperValues
  obtain ⟨z, hz_upper, hz_b⟩ := Finset.mem_image.mp hb_upperValues
  have hmb : m < b := by
    rw [← hz_b]
    exact (mem_upperLevel f m z).mp hz_upper
  have hdisjoint : Disjoint (lowerLevel f b) (upperLevel f m) := by
    apply Finset.disjoint_left.mpr
    intro x hx_lower hx_upper
    have hx_lt : f x < b := (mem_lowerLevel f b x).mp hx_lower
    have hx_image : f x ∈ upperValues :=
      Finset.mem_image.mpr ⟨x, hx_upper, rfl⟩
    have hb_le : b ≤ f x :=
      Finset.min'_le upperValues (f x) hx_image
    exact (not_lt_of_ge hb_le) hx_lt
  have hcard :
      (lowerLevel f b).card + (upperLevel f m).card ≤ Fintype.card V := by
    calc
      (lowerLevel f b).card + (upperLevel f m).card =
          ((lowerLevel f b) ∪ (upperLevel f m)).card :=
        (Finset.card_union_of_disjoint hdisjoint).symm
      _ ≤ (Finset.univ : Finset V).card :=
        Finset.card_le_card (Finset.subset_univ _)
      _ = Fintype.card V := Finset.card_univ
  have hb_lower : 2 * (lowerLevel f b).card ≤ Fintype.card V := by
    omega
  have hb_values : b ∈ values := by
    rw [← hz_b]
    exact Finset.mem_image.mpr ⟨z, Finset.mem_univ z, rfl⟩
  have hb_candidates : b ∈ candidates :=
    Finset.mem_filter.mpr ⟨hb_values, hb_lower⟩
  have hb_le_m : b ≤ m :=
    Finset.le_max' candidates b hb_candidates
  exact (not_le_of_gt hmb) hb_le_m

theorem positive_max_iff (a : ℝ) : 0 < max a 0 ↔ 0 < a := by
  by_cases ha : 0 < a
  · rw [max_eq_left ha.le]
  · rw [max_eq_right (le_of_not_gt ha)]
    simp [ha]

theorem positiveSupport_max_sub {V : Type*} [Fintype V]
    (f : V → ℝ) (m : ℝ) :
    positiveSupport (fun x => max (f x - m) 0) = upperLevel f m := by
  classical
  ext x
  simp only [mem_positiveSupport, mem_upperLevel,
    positive_max_iff, sub_pos]

theorem positiveSupport_max_sub_reverse {V : Type*} [Fintype V]
    (f : V → ℝ) (m : ℝ) :
    positiveSupport (fun x => max (m - f x) 0) = lowerLevel f m := by
  classical
  ext x
  simp only [mem_positiveSupport, mem_lowerLevel,
    positive_max_iff, sub_pos]

def finiteVariance {V : Type*} [Fintype V] (f : V → ℝ) : ℝ :=
  (∑ x : V, (f x - finiteMean f) ^ 2) / (Fintype.card V : ℝ)

theorem finiteVariance_nonneg {V : Type*} [Fintype V]
    (f : V → ℝ) : 0 ≤ finiteVariance f := by
  unfold finiteVariance
  exact div_nonneg
    (Finset.sum_nonneg (fun _ _ => sq_nonneg _))
    (Nat.cast_nonneg _)

theorem card_mul_finiteVariance {V : Type*} [Fintype V] [Nonempty V]
    (f : V → ℝ) :
    (Fintype.card V : ℝ) * finiteVariance f =
      ∑ x : V, (f x - finiteMean f) ^ 2 := by
  have hc : (Fintype.card V : ℝ) ≠ 0 := by
    exact_mod_cast Fintype.card_ne_zero
  unfold finiteVariance
  field_simp

end CheegerPoincare

namespace ThompsonPrefixLocal

open scoped BigOperators

theorem idempotentCornerUnitExtensions_commute
    {A : Type*} [Ring A] {e f : A}
    (he : IsIdempotentElem e) (hf : IsIdempotentElem f)
    (hef : e * f = 0) (hfe : f * e = 0)
    (u : he.Cornerˣ) (v : hf.Cornerˣ) :
    Commute
      (idempotentCornerUnitExtension he u)
      (idempotentCornerUnitExtension hf v) := by
  apply Units.ext
  have hu := (Subsemigroup.mem_corner_iff he).mp u.val.property
  have hv := (Subsemigroup.mem_corner_iff hf).mp v.val.property
  have huv : u.val.val * v.val.val = 0 := by
    calc
      u.val.val * v.val.val =
          (u.val.val * e) * (f * v.val.val) := by rw [hu.2, hv.1]
      _ = u.val.val * (e * f) * v.val.val := by noncomm_ring
      _ = 0 := by rw [hef]; simp
  have hvu : v.val.val * u.val.val = 0 := by
    calc
      v.val.val * u.val.val =
          (v.val.val * f) * (e * u.val.val) := by rw [hv.2, hu.1]
      _ = v.val.val * (f * e) * u.val.val := by noncomm_ring
      _ = 0 := by rw [hfe]; simp
  have hev : e * v.val.val = 0 := by
    calc
      e * v.val.val = e * (f * v.val.val) := by rw [hv.1]
      _ = (e * f) * v.val.val := by rw [mul_assoc]
      _ = 0 := by rw [hef]; simp
  have hve : v.val.val * e = 0 := by
    calc
      v.val.val * e = (v.val.val * f) * e := by rw [hv.2]
      _ = v.val.val * (f * e) := by rw [mul_assoc]
      _ = 0 := by rw [hfe]; simp
  have huf : u.val.val * f = 0 := by
    calc
      u.val.val * f = (u.val.val * e) * f := by rw [hu.2]
      _ = u.val.val * (e * f) := by rw [mul_assoc]
      _ = 0 := by rw [hef]; simp
  have hfu : f * u.val.val = 0 := by
    calc
      f * u.val.val = f * (e * u.val.val) := by rw [hu.1]
      _ = (f * e) * u.val.val := by rw [mul_assoc]
      _ = 0 := by rw [hfe]; simp
  change
    (u.val.val + (1 - e)) * (v.val.val + (1 - f)) =
      (v.val.val + (1 - f)) * (u.val.val + (1 - e))
  noncomm_ring [he.eq, hf.eq, hu.1, hu.2, hv.1, hv.2,
    hef, hfe, huv, hvu, hev, hve, huf, hfu]

theorem idempotentCornerUnitExtensions_eq_one
    {A : Type*} [Ring A] {e f : A}
    (he : IsIdempotentElem e) (hf : IsIdempotentElem f)
    (hef : e * f = 0)
    (u : he.Cornerˣ) (v : hf.Cornerˣ)
    (h : idempotentCornerUnitExtension he u =
      idempotentCornerUnitExtension hf v) :
    idempotentCornerUnitExtension he u = 1 := by
  have hu := (Subsemigroup.mem_corner_iff he).mp u.val.property
  have hv := (Subsemigroup.mem_corner_iff hf).mp v.val.property
  have hev : e * v.val.val = 0 := by
    calc
      e * v.val.val = e * (f * v.val.val) := by rw [hv.1]
      _ = (e * f) * v.val.val := by rw [mul_assoc]
      _ = 0 := by rw [hef, zero_mul]
  have hval := congrArg (fun z : Aˣ => (z : A)) h
  change u.val.val + (1 - e) = v.val.val + (1 - f) at hval
  have hleft := congrArg (fun z : A => e * z) hval
  have hue : u.val.val = e := by
    simpa [mul_add, mul_sub, hu.1, he.eq, hev, hef] using hleft
  apply Units.ext
  change u.val.val + (1 - e) = 1
  rw [hue]
  noncomm_ring

def idempotentCornerGroup {A : Type*} [Ring A]
    {e : A} (he : IsIdempotentElem e) : Subgroup Aˣ :=
  (idempotentCornerUnitExtension he).range

theorem idempotentCornerGroup_le_centralizer
    {A : Type*} [Ring A] {e f : A}
    (he : IsIdempotentElem e) (hf : IsIdempotentElem f)
    (hef : e * f = 0) (hfe : f * e = 0) :
    idempotentCornerGroup hf ≤
      Subgroup.centralizer (idempotentCornerGroup he : Set Aˣ) := by
  intro z hz
  obtain ⟨v, rfl⟩ := hz
  apply Subgroup.mem_centralizer_iff.mpr
  intro x hx
  obtain ⟨u, rfl⟩ := hx
  exact (idempotentCornerUnitExtensions_commute he hf hef hfe u v).eq

theorem idempotentCornerGroup_inf_eq_bot
    {A : Type*} [Ring A] {e f : A}
    (he : IsIdempotentElem e) (hf : IsIdempotentElem f)
    (hef : e * f = 0) :
    idempotentCornerGroup he ⊓ idempotentCornerGroup hf = ⊥ := by
  apply le_antisymm
  · intro z hz
    obtain ⟨⟨u, hu⟩, ⟨v, hv⟩⟩ := hz
    have huv : idempotentCornerUnitExtension he u =
        idempotentCornerUnitExtension hf v := hu.trans hv.symm
    have hone := idempotentCornerUnitExtensions_eq_one he hf hef u v huv
    have hz : z = 1 := hu.symm.trans hone
    simp [hz]
  · exact bot_le

theorem leavittCylinder_isIdempotent (a : List (Fin 2)) :
    IsIdempotentElem (leavittCylinder a) := by
  change
    (leavittWordS a * leavittWordT a) *
        (leavittWordS a * leavittWordT a) =
      leavittWordS a * leavittWordT a
  calc
    (leavittWordS a * leavittWordT a) *
        (leavittWordS a * leavittWordT a) =
      leavittWordS a *
        (leavittWordT a * leavittWordS a) * leavittWordT a := by
          noncomm_ring
    _ = leavittWordS a * leavittWordT a := by
      rw [leavittWordT_mul_wordS_self]
      simp

theorem leavittCylinder_mul_eq_zero_of_incomparable
    (a b : List (Fin 2)) (hab : ¬ a <+: b) (hba : ¬ b <+: a) :
    leavittCylinder a * leavittCylinder b = 0 := by
  change
    (leavittWordS a * leavittWordT a) *
      (leavittWordS b * leavittWordT b) = 0
  calc
    (leavittWordS a * leavittWordT a) *
        (leavittWordS b * leavittWordT b) =
      leavittWordS a *
        (leavittWordT a * leavittWordS b) * leavittWordT b := by
          noncomm_ring
    _ = 0 := by
      rw [leavittWordT_mul_wordS_of_incomparable a b hab hba]
      simp

def cylinderCornerGroup (a : List (Fin 2)) : Subgroup BinaryLeavittˣ :=
  idempotentCornerGroup (leavittCylinder_isIdempotent a)

def prefixCodeIdempotent {ι : Type*} [Fintype ι]
    (E : BinaryPrefixCode ι) : BinaryLeavitt :=
  MatrixCorner.codeIdempotent
    (fun i => leavittWordS (E.word i))
    (fun i => leavittWordT (E.word i))

def prefixCodeCornerGroup {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι) : Subgroup BinaryLeavittˣ :=
  idempotentCornerGroup
    (MatrixCorner.codeIdempotent_isIdempotent
      (fun i => leavittWordS (E.word i))
      (fun i => leavittWordT (E.word i))
      (binaryPrefixCode_orthogonal E))

theorem prefixElementaryGroup_le_corner
    {ι : Type*} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι) :
    prefixElementaryGroup E ≤ prefixCodeCornerGroup E := by
  rw [← prefixCornerElementaryGroup_map E]
  rintro _ ⟨u, _, rfl⟩
  exact ⟨(Units.mapEquiv (binaryPrefixCornerEquiv E).toMulEquiv) u, rfl⟩

def sourceLocalWord : List (Fin 2) := [0, 0, 0, 1]

theorem alphaZeroWord_incomparable_local (i : Fin 3) :
    ¬ alphaZeroPrefixCode.word i <+: sourceLocalWord := by
  fin_cases i <;> decide

theorem localWord_incomparable_alphaZero (i : Fin 3) :
    ¬ sourceLocalWord <+: alphaZeroPrefixCode.word i := by
  fin_cases i <;> decide

theorem alphaZeroCode_mul_localCylinder :
    prefixCodeIdempotent alphaZeroPrefixCode *
        leavittCylinder sourceLocalWord = 0 := by
  change
    (∑ i : Fin 3, leavittCylinder (alphaZeroPrefixCode.word i)) *
        leavittCylinder sourceLocalWord = 0
  rw [Finset.sum_mul]
  apply Finset.sum_eq_zero
  intro i hi
  exact leavittCylinder_mul_eq_zero_of_incomparable
    (alphaZeroPrefixCode.word i) sourceLocalWord
    (alphaZeroWord_incomparable_local i)
    (localWord_incomparable_alphaZero i)

theorem localCylinder_mul_alphaZeroCode :
    leavittCylinder sourceLocalWord *
        prefixCodeIdempotent alphaZeroPrefixCode = 0 := by
  change
    leavittCylinder sourceLocalWord *
        (∑ i : Fin 3, leavittCylinder (alphaZeroPrefixCode.word i)) = 0
  rw [Finset.mul_sum]
  apply Finset.sum_eq_zero
  intro i hi
  exact leavittCylinder_mul_eq_zero_of_incomparable
    sourceLocalWord (alphaZeroPrefixCode.word i)
    (localWord_incomparable_alphaZero i)
    (alphaZeroWord_incomparable_local i)

theorem localCylinderCorner_le_centralizer_alphaZero :
    cylinderCornerGroup sourceLocalWord ≤
      Subgroup.centralizer
        (prefixElementaryGroup alphaZeroPrefixCode : Set BinaryLeavittˣ) := by
  let he := MatrixCorner.codeIdempotent_isIdempotent
    (fun i => leavittWordS (alphaZeroPrefixCode.word i))
    (fun i => leavittWordT (alphaZeroPrefixCode.word i))
    (binaryPrefixCode_orthogonal alphaZeroPrefixCode)
  let hf := leavittCylinder_isIdempotent sourceLocalWord
  have hef : prefixCodeIdempotent alphaZeroPrefixCode *
      leavittCylinder sourceLocalWord = 0 :=
    alphaZeroCode_mul_localCylinder
  have hfe : leavittCylinder sourceLocalWord *
      prefixCodeIdempotent alphaZeroPrefixCode = 0 :=
    localCylinder_mul_alphaZeroCode
  intro z hz
  apply Subgroup.mem_centralizer_iff.mpr
  intro x hx
  have hx' := prefixElementaryGroup_le_corner alphaZeroPrefixCode hx
  have hz' : z ∈ idempotentCornerGroup hf := hz
  have hc := idempotentCornerGroup_le_centralizer he hf hef hfe hz'
  exact Subgroup.mem_centralizer_iff.mp hc x hx'

theorem alphaZero_inf_localCylinderCorner_eq_bot :
    prefixElementaryGroup alphaZeroPrefixCode ⊓
        cylinderCornerGroup sourceLocalWord = ⊥ := by
  let he := MatrixCorner.codeIdempotent_isIdempotent
    (fun i => leavittWordS (alphaZeroPrefixCode.word i))
    (fun i => leavittWordT (alphaZeroPrefixCode.word i))
    (binaryPrefixCode_orthogonal alphaZeroPrefixCode)
  let hf := leavittCylinder_isIdempotent sourceLocalWord
  have hzero := idempotentCornerGroup_inf_eq_bot he hf
    alphaZeroCode_mul_localCylinder
  apply le_antisymm
  · intro z hz
    have hx := prefixElementaryGroup_le_corner alphaZeroPrefixCode hz.1
    have hz' : z ∈ idempotentCornerGroup he ⊓ idempotentCornerGroup hf :=
      ⟨hx, hz.2⟩
    rw [hzero] at hz'
    exact hz'
  · exact bot_le

end ThompsonPrefixLocal

theorem target_majority_of_small_symmDiff
    {V : Type*} [DecidableEq V] (C D : Finset V)
    (hsmall : 2 * (C ∆ D).card < C.card) :
    D.card < 2 * (C ∩ D).card := by
  have hC := Finset.card_sdiff_add_card_inter C D
  have hD := Finset.card_sdiff_add_card_inter D C
  have hleft : (C \ D).card ≤ (C ∆ D).card :=
    Finset.card_le_card (Finset.symmDiff_subset_sdiff (s := C) (t := D))
  have hright : (D \ C).card ≤ (C ∆ D).card :=
    Finset.card_le_card (Finset.symmDiff_subset_sdiff' (s := C) (t := D))
  rw [Finset.inter_comm D C] at hD
  omega

def matchedRetainedFinpartition
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) : Finpartition (matchedRetainedSupport R) :=
  P.ofSubset hR (Finset.sup_eq_biUnion R id)

theorem matchedRetainedSupport_nonempty
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (hRne : R.Nonempty) :
    (matchedRetainedSupport R).Nonempty := by
  obtain ⟨C, hC⟩ := hRne
  obtain ⟨x, hx⟩ := P.nonempty_of_mem_parts (hR hC)
  refine ⟨x, ?_⟩
  exact Finset.mem_biUnion.mpr ⟨C, hC, by simpa using hx⟩

theorem partitionWordCrossing_indexed_sum_card_le_target_add_unmatched
    {V ι : Type*} [DecidableEq V] {U : Finset V}
    (P Q : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (D : Finset V → Finset V)
    (hD : ∀ C ∈ R, D C ∈ Q.parts)
    (hinj : Set.InjOn D (R : Set (Finset V)))
    (I : Finset ι) (w : ι → Equiv.Perm V) :
    (∑ i ∈ I, (partitionWordCrossing P (w i)).card) ≤
      (∑ i ∈ I, (partitionWordCrossing Q (w i)).card) +
        2 * I.card * (U \ matchedCore R D).card := by
  calc
    (∑ i ∈ I, (partitionWordCrossing P (w i)).card) ≤
        ∑ i ∈ I,
          ((partitionWordCrossing Q (w i)).card +
            2 * (U \ matchedCore R D).card) :=
      Finset.sum_le_sum fun i _ =>
        partitionWordCrossing_card_le_target_add_unmatched
          P Q R hR D hD hinj (w i)
    _ = (∑ i ∈ I, (partitionWordCrossing Q (w i)).card) +
          2 * I.card * (U \ matchedCore R D).card := by
      simp [Finset.sum_add_distrib, mul_comm, mul_assoc]

theorem matchedRetainedSupport_cover_density_tendsto_one
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    (U : ∀ n, Finset (V n)) (hU : ∀ n, (U n).Nonempty)
    (P : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (hdiscard : Tendsto
      (fun n => (((U n \ matchedRetainedSupport (R n)).card : ℝ) /
        (U n).card)) atTop (𝓝 0)) :
    Tendsto
      (fun n => ((matchedRetainedSupport (R n)).card : ℝ) / (U n).card)
      atTop (𝓝 1) := by
  have hform (n : ℕ) :
      ((matchedRetainedSupport (R n)).card : ℝ) / (U n).card =
        1 - (((U n \ matchedRetainedSupport (R n)).card : ℝ) /
          (U n).card) := by
    have hcard := Finset.card_sdiff_add_card_eq_card
      (matchedRetainedSupport_subset (P n) (R n) (hR n))
    have hreal :
        ((U n \ matchedRetainedSupport (R n)).card : ℝ) +
          (matchedRetainedSupport (R n)).card = (U n).card := by
      exact_mod_cast hcard
    have hden : ((U n).card : ℝ) ≠ 0 := by
      exact_mod_cast (hU n).card_pos.ne'
    field_simp
    linarith
  have hlimit : Tendsto
      (fun n =>
        (1 : ℝ) - (((U n \ matchedRetainedSupport (R n)).card : ℝ) /
          (U n).card)) atTop (𝓝 1) := by
    simpa only [sub_zero] using
      (tendsto_const_nhds.sub hdiscard :
        Tendsto
          (fun n =>
            (1 : ℝ) - (((U n \ matchedRetainedSupport (R n)).card : ℝ) /
              (U n).card))
          atTop (𝓝 ((1 : ℝ) - 0)))
  convert hlimit using 1
  funext n
  exact hform n

theorem exists_matched_slow_diagonal_word_errors
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)] {ι : Type*}
    (U : ∀ n, Finset (V n))
    (P Q : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (D : ∀ n, Finset (V n) → Finset (V n))
    (hD : ∀ n C, C ∈ R n → D n C ∈ (Q n).parts)
    (hmajor : ∀ n C, C ∈ R n →
      (D n C).card < 2 * (C ∩ D n C).card)
    (hdiscard : Tendsto
      (fun n => (((U n \ matchedRetainedSupport (R n)).card : ℝ) /
        (U n).card)) atTop (𝓝 0))
    (hsymm : Tendsto
      (fun n =>
        ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) / (U n).card)
      atTop (𝓝 0))
    (I : ℕ → Finset ι)
    (w : ∀ n, ι → Equiv.Perm (V n))
    (hword : ∀ k, Tendsto
      (fun n =>
        ((∑ i ∈ I k,
          (partitionWordCrossing (Q n) (w n i)).card : ℕ) : ℝ) /
          (U n).card)
      atTop (𝓝 0))
    (B : ∀ n, ℕ → Finset (V n))
    (hbad : ∀ k, Tendsto
      (fun n => (((U n ∩ B n k).card : ℝ) / (U n).card))
      atTop (𝓝 0)) :
    ∃ r : ℕ → ℕ,
      Tendsto r atTop atTop ∧
        Tendsto
          (fun n =>
            (((∑ i ∈ I (r n),
                (partitionWordCrossing (P n) (w n i)).card : ℕ) : ℝ) +
              (U n ∩ B n (r n)).card) / (U n).card)
          atTop (𝓝 0) := by
  have hmissing := matchedCore_missing_density_tendsto_zero
    U P R hR D hdiscard hsymm
  have hsource (k : ℕ) : Tendsto
      (fun n =>
        ((∑ i ∈ I k,
          (partitionWordCrossing (P n) (w n i)).card : ℕ) : ℝ) /
          (U n).card)
      atTop (𝓝 0) := by
    have hscaled : Tendsto
        (fun n =>
          ((2 * (I k).card : ℕ) : ℝ) *
            (((U n \ matchedCore (R n) (D n)).card : ℝ) /
              (U n).card))
        atTop (𝓝 0) := by
      simpa only [mul_zero] using
        (tendsto_const_nhds.mul hmissing :
          Tendsto
            (fun n =>
              ((2 * (I k).card : ℕ) : ℝ) *
                (((U n \ matchedCore (R n) (D n)).card : ℝ) /
                  (U n).card))
            atTop (𝓝 (((2 * (I k).card : ℕ) : ℝ) * 0)))
    have hupper : Tendsto
        (fun n =>
          ((∑ i ∈ I k,
            (partitionWordCrossing (Q n) (w n i)).card : ℕ) : ℝ) /
            (U n).card +
            ((2 * (I k).card : ℕ) : ℝ) *
              (((U n \ matchedCore (R n) (D n)).card : ℝ) /
                (U n).card))
        atTop (𝓝 0) := by
      simpa only [add_zero] using (hword k).add hscaled
    refine squeeze_zero (fun n => by positivity) ?_ hupper
    intro n
    have hcard :
        ((∑ i ∈ I k,
          (partitionWordCrossing (P n) (w n i)).card : ℕ) : ℝ) ≤
          ((∑ i ∈ I k,
            (partitionWordCrossing (Q n) (w n i)).card : ℕ) : ℝ) +
            ((2 * (I k).card : ℕ) : ℝ) *
              ((U n \ matchedCore (R n) (D n)).card : ℝ) := by
      exact_mod_cast
        partitionWordCrossing_indexed_sum_card_le_target_add_unmatched
          (P n) (Q n) (R n) (hR n) (D n) (hD n)
          (finpartition_dominant_matching_injOn
            (P n) (R n) (hR n) (D n) (hmajor n))
          (I k) (w n)
    calc
      ((∑ i ∈ I k,
        (partitionWordCrossing (P n) (w n i)).card : ℕ) : ℝ) /
          (U n).card ≤
        (((∑ i ∈ I k,
          (partitionWordCrossing (Q n) (w n i)).card : ℕ) : ℝ) +
          ((2 * (I k).card : ℕ) : ℝ) *
            ((U n \ matchedCore (R n) (D n)).card : ℝ)) /
              (U n).card :=
        div_le_div_of_nonneg_right hcard (by positivity)
      _ = ((∑ i ∈ I k,
            (partitionWordCrossing (Q n) (w n i)).card : ℕ) : ℝ) /
            (U n).card +
            ((2 * (I k).card : ℕ) : ℝ) *
              (((U n \ matchedCore (R n) (D n)).card : ℝ) /
                (U n).card) := by
        ring
  let e : ℕ → ℕ → ℝ := fun n k =>
    (((∑ i ∈ I k,
        (partitionWordCrossing (P n) (w n i)).card : ℕ) : ℝ) +
      (U n ∩ B n k).card) / (U n).card
  have he_nonneg (n k : ℕ) : 0 ≤ e n k := by
    dsimp [e]
    positivity
  have he (k : ℕ) : Tendsto (fun n => e n k) atTop (𝓝 0) := by
    have hsum : Tendsto
        (fun n =>
          ((∑ i ∈ I k,
            (partitionWordCrossing (P n) (w n i)).card : ℕ) : ℝ) /
              (U n).card +
            ((U n ∩ B n k).card : ℝ) / (U n).card)
        atTop (𝓝 0) := by
      simpa only [add_zero] using (hsource k).add (hbad k)
    convert hsum using 1
    funext n
    dsimp [e]
    ring
  obtain ⟨r, hr, her⟩ :=
    exists_diverging_radius_with_vanishing_diagonal_error e he_nonneg he
  exact ⟨r, hr, her⟩

def matchedRadiusBad {V ι : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (I : Finset ι) (w : ι → Equiv.Perm V)
    (B : Finset V) : Finset V :=
  B ∪ I.biUnion fun i => partitionWordCrossing P (w i)

theorem matchedRadiusBad_card_le
    {V ι : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (I : Finset ι) (w : ι → Equiv.Perm V)
    (B : Finset V) :
    (U ∩ matchedRadiusBad P I w B).card ≤
      (U ∩ B).card +
        ∑ i ∈ I, (partitionWordCrossing P (w i)).card := by
  have hsubset : U ∩ matchedRadiusBad P I w B ⊆
      (U ∩ B) ∪ I.biUnion (fun i => partitionWordCrossing P (w i)) := by
    intro x hx
    obtain ⟨hxU, hx⟩ := Finset.mem_inter.mp hx
    rcases Finset.mem_union.mp hx with hxB | hxW
    · exact Finset.mem_union_left _ (Finset.mem_inter.mpr ⟨hxU, hxB⟩)
    · exact Finset.mem_union_right _ hxW
  have hfirst := Finset.card_le_card hsubset
  have hsecond := Finset.card_union_le
    (U ∩ B) (I.biUnion fun i => partitionWordCrossing P (w i))
  have hthird := Finset.card_biUnion_le
    (s := I) (t := fun i => partitionWordCrossing P (w i))
  omega

theorem matched_exists_le_weighted_average {ι : Type*}
    (s : Finset ι) (hs : s.Nonempty) (weight bad : ι → ℝ)
    (hweight : ∀ i ∈ s, 0 < weight i) :
    ∃ i ∈ s,
      bad i / weight i ≤ (∑ j ∈ s, bad j) / (∑ j ∈ s, weight j) := by
  have hsum : 0 < ∑ j ∈ s, weight j := Finset.sum_pos hweight hs
  have havg :
      ∑ i ∈ s, bad i ≤
        ∑ i ∈ s,
          ((∑ j ∈ s, bad j) / (∑ j ∈ s, weight j)) * weight i := by
    rw [← Finset.mul_sum, div_mul_cancel₀ _ hsum.ne']
  obtain ⟨i, hi, hbound⟩ := Finset.exists_le_of_sum_le hs havg
  exact ⟨i, hi, (div_le_iff₀ (hweight i hi)).2 hbound⟩

theorem matched_sum_card_inter_partition
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (B : Finset V) :
    ∑ C ∈ P.parts, (C ∩ B).card = (U ∩ B).card := by
  have hdis :
      (P.parts : Set (Finset V)).PairwiseDisjoint
        (fun C : Finset V => C ∩ B) := by
    intro C hC D hD hne
    exact (P.disjoint hC hD hne).mono
      Finset.inter_subset_left Finset.inter_subset_left
  have hunion : P.parts.biUnion (fun C => C ∩ B) = U ∩ B := by
    ext x
    simp [← P.biUnion_parts]
    aesop
  calc
    ∑ C ∈ P.parts, (C ∩ B).card =
        (P.parts.biUnion fun C => C ∩ B).card :=
      (Finset.card_biUnion hdis).symm
    _ = (U ∩ B).card := congrArg Finset.card hunion

theorem matchedRetained_bad_density_tendsto_zero
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    (U : ∀ n, Finset (V n)) (hU : ∀ n, (U n).Nonempty)
    (P : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (hRne : ∀ n, (R n).Nonempty)
    (hdiscard : Tendsto
      (fun n => (((U n \ matchedRetainedSupport (R n)).card : ℝ) /
        (U n).card)) atTop (𝓝 0))
    (B : ∀ n, Finset (V n))
    (hbad : Tendsto
      (fun n => (((U n ∩ B n).card : ℝ) / (U n).card))
      atTop (𝓝 0)) :
    Tendsto
      (fun n =>
        (((matchedRetainedSupport (R n) ∩ B n).card : ℝ) /
          (matchedRetainedSupport (R n)).card))
      atTop (𝓝 0) := by
  have hcover := matchedRetainedSupport_cover_density_tendsto_one
    U hU P R hR hdiscard
  have hhalf : ∀ᶠ n in atTop,
      (1 / 2 : ℝ) ≤
        ((matchedRetainedSupport (R n)).card : ℝ) / (U n).card :=
    (hcover.eventually (lt_mem_nhds (by norm_num : (1 / 2 : ℝ) < 1))).mono
      fun _ h => h.le
  have htwice : Tendsto
      (fun n =>
        (2 : ℝ) * (((U n ∩ B n).card : ℝ) / (U n).card))
      atTop (𝓝 0) := by
    simpa only [mul_zero] using
      (tendsto_const_nhds.mul hbad :
        Tendsto
          (fun n =>
            (2 : ℝ) * (((U n ∩ B n).card : ℝ) / (U n).card))
          atTop (𝓝 ((2 : ℝ) * 0)))
  refine squeeze_zero'
    (Eventually.of_forall fun n => by positivity) ?_ htwice
  filter_upwards [hhalf] with n hn
  have hucard : (0 : ℝ) < (U n).card := by
    exact_mod_cast (hU n).card_pos
  have hrcard : (0 : ℝ) < (matchedRetainedSupport (R n)).card := by
    exact_mod_cast
      (matchedRetainedSupport_nonempty (P n) (R n) (hR n) (hRne n)).card_pos
  have hmass :
      ((U n).card : ℝ) ≤ 2 * (matchedRetainedSupport (R n)).card := by
    have h := (le_div_iff₀ hucard).1 hn
    linarith
  have hbadcard :
      ((matchedRetainedSupport (R n) ∩ B n).card : ℝ) ≤
        (U n ∩ B n).card := by
    exact_mod_cast Finset.card_le_card
      (Finset.inter_subset_inter_right
        (matchedRetainedSupport_subset (P n) (R n) (hR n)))
  calc
    ((matchedRetainedSupport (R n) ∩ B n).card : ℝ) /
        (matchedRetainedSupport (R n)).card ≤
      ((U n ∩ B n).card : ℝ) / (matchedRetainedSupport (R n)).card :=
        div_le_div_of_nonneg_right hbadcard hrcard.le
    _ ≤ 2 * (((U n ∩ B n).card : ℝ) / (U n).card) := by
      rw [← mul_div_assoc]
      apply (div_le_div_iff₀ hrcard hucard).2
      simpa [mul_assoc, mul_comm, mul_left_comm] using
        (mul_le_mul_of_nonneg_left hmass
          (Nat.cast_nonneg (α := ℝ) (U n ∩ B n).card))

theorem matched_eventually_exists_good_vertex
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    (C B : ∀ n, Finset (V n)) (hC : ∀ n, (C n).Nonempty)
    (hbad : Tendsto
      (fun n => (((C n ∩ B n).card : ℝ) / (C n).card))
      atTop (𝓝 0)) :
    ∀ᶠ n in atTop, ∃ x ∈ C n, x ∉ B n := by
  filter_upwards [hbad.eventually (gt_mem_nhds zero_lt_one)] with n hn
  by_contra h
  push Not at h
  have heq : C n ∩ B n = C n := Finset.inter_eq_left.2 h
  have hc : ((C n).card : ℝ) ≠ 0 := by
    exact_mod_cast (hC n).card_pos.ne'
  rw [heq, div_self hc] at hn
  exact (lt_irrefl (1 : ℝ)) hn

namespace ComponentMidrankVariance

open scoped BigOperators

def lowerRankWeight (s : Finset ℤ) (w : ℤ → ℝ) (j : ℤ) : ℝ :=
  (s.filter (fun i => i < j)).sum w

theorem sum_weighted_ordered_midpoints_sq (s : Finset ℤ) (w : ℤ → ℝ) :
    (∑ j ∈ s, w j * (lowerRankWeight s w j + w j / 2) ^ 2) =
      (∑ j ∈ s, w j) ^ 3 / 3 -
        (∑ j ∈ s, w j ^ 3) / 12 := by
  classical
  induction s using Finset.induction_on_max with
  | empty => simp [lowerRankWeight]
  | @insert a s hmax ih =>
      have ha : a ∉ s := by
        intro ha
        exact (lt_irrefl a) (hmax a ha)
      have hfiltera :
          (insert a s).filter (fun i : ℤ => i < a) = s := by
        ext i
        simp only [Finset.mem_filter, Finset.mem_insert]
        constructor
        · rintro ⟨hi | hi, hia⟩
          · subst i
            exact (lt_irrefl _ hia).elim
          · exact hi
        · intro hi
          exact ⟨Or.inr hi, hmax i hi⟩
      have hprefixa :
          lowerRankWeight (insert a s) w a = ∑ i ∈ s, w i := by
        unfold lowerRankWeight
        rw [hfiltera]
      have hprefix (j : ℤ) (hj : j ∈ s) :
          lowerRankWeight (insert a s) w j = lowerRankWeight s w j := by
        unfold lowerRankWeight
        have hnot : ¬ a < j := not_lt_of_ge (le_of_lt (hmax j hj))
        rw [Finset.filter_insert, if_neg hnot]
      calc
        (∑ j ∈ insert a s,
            w j * (lowerRankWeight (insert a s) w j + w j / 2) ^ 2) =
          w a * ((∑ i ∈ s, w i) + w a / 2) ^ 2 +
            ∑ j ∈ s, w j * (lowerRankWeight s w j + w j / 2) ^ 2 := by
              rw [Finset.sum_insert ha, hprefixa]
              congr 1
              apply Finset.sum_congr rfl
              intro j hj
              rw [hprefix j hj]
        _ = w a * ((∑ i ∈ s, w i) + w a / 2) ^ 2 +
            ((∑ j ∈ s, w j) ^ 3 / 3 -
              (∑ j ∈ s, w j ^ 3) / 12) := by rw [ih]
        _ = (∑ j ∈ insert a s, w j) ^ 3 / 3 -
            (∑ j ∈ insert a s, w j ^ 3) / 12 := by
              rw [Finset.sum_insert ha, Finset.sum_insert ha]
              ring

theorem twice_lower_rank_pairs_add_equal_rank_pairs
    {V : Type*} (C : Finset V) (b : V → ℤ) :
    2 * (∑ x ∈ C, ((C.filter fun z => b z < b x).card : ℝ)) +
        (∑ x ∈ C, ((C.filter fun z => b z = b x).card : ℝ)) =
      (C.card : ℝ) ^ 2 := by
  classical
  let L : V → V → ℝ := fun x z => if b z < b x then 1 else 0
  let E : V → V → ℝ := fun x z => if b z = b x then 1 else 0
  have htri (x z : V) : L x z + L z x + E x z = 1 := by
    dsimp [L, E]
    split_ifs <;> norm_num <;> omega
  have hswap :
      (∑ x ∈ C, ∑ z ∈ C, L z x) =
        ∑ x ∈ C, ∑ z ∈ C, L x z := by
    rw [Finset.sum_comm]
  have hlower (x : V) :
      ((C.filter fun z => b z < b x).card : ℝ) =
        ∑ z ∈ C, L x z := by
    change ((C.filter fun z => b z < b x).card : ℝ) =
      ∑ z ∈ C, if b z < b x then 1 else 0
    exact (Finset.sum_boole (fun z : V => b z < b x) C).symm
  have hequal (x : V) :
      ((C.filter fun z => b z = b x).card : ℝ) =
        ∑ z ∈ C, E x z := by
    change ((C.filter fun z => b z = b x).card : ℝ) =
      ∑ z ∈ C, if b z = b x then 1 else 0
    exact (Finset.sum_boole (fun z : V => b z = b x) C).symm
  simp_rw [hlower, hequal]
  calc
    2 * (∑ x ∈ C, ∑ z ∈ C, L x z) +
        (∑ x ∈ C, ∑ z ∈ C, E x z) =
      ∑ x ∈ C, ∑ z ∈ C, (L x z + L z x + E x z) := by
        simp_rw [Finset.sum_add_distrib]
        rw [hswap]
        ring
    _ = ∑ x ∈ C, ∑ _z ∈ C, (1 : ℝ) := by
      apply Finset.sum_congr rfl
      intro x _
      apply Finset.sum_congr rfl
      intro z _
      exact htri x z
    _ = (C.card : ℝ) ^ 2 := by
      simp [pow_two]

theorem sum_componentVertexMidrank
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (hC : C.Nonempty) :
    (∑ x ∈ C, SoficGroups.componentVertexMidrank C b x) =
      (C.card : ℝ) / 2 := by
  have hcard : (C.card : ℝ) ≠ 0 := by
    exact_mod_cast Finset.card_ne_zero.mpr hC
  have hpairs := twice_lower_rank_pairs_add_equal_rank_pairs C b
  unfold SoficGroups.componentVertexMidrank
  rw [← Finset.sum_div]
  have hnum :
      (∑ x ∈ C,
        (((C.filter fun z => b z < b x).card : ℝ) +
          ((C.filter fun z => b z = b x).card : ℝ) / 2)) =
        (C.card : ℝ) ^ 2 / 2 := by
    rw [Finset.sum_add_distrib, ← Finset.sum_div]
    linarith
  rw [hnum]
  field_simp

theorem componentVertexMidrank_eq_ordered_midpoint
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (x : V) :
    SoficGroups.componentVertexMidrank C b x =
      lowerRankWeight (C.image b) (SoficGroups.componentRankMass C b) (b x) +
        SoficGroups.componentRankMass C b (b x) / 2 := by
  simpa only [lowerRankWeight] using
    SoficGroups.componentVertexMidrank_eq_sum_componentRankMass C b x

theorem sum_componentVertexMidrank_sq_eq
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (hC : C.Nonempty) :
    (∑ x ∈ C, SoficGroups.componentVertexMidrank C b x ^ 2) =
      (C.card : ℝ) *
        ((1 : ℝ) / 3 -
          (∑ j ∈ C.image b, SoficGroups.componentRankMass C b j ^ 3) / 12) := by
  classical
  have hcard : (C.card : ℝ) ≠ 0 := by
    exact_mod_cast Finset.card_ne_zero.mpr hC
  have hfiber := Finset.sum_fiberwise_of_maps_to
    (s := C) (t := C.image b) (g := b)
    (fun x hx => Finset.mem_image.mpr ⟨x, hx, rfl⟩)
    (fun x => SoficGroups.componentVertexMidrank C b x ^ 2)
  calc
    (∑ x ∈ C, SoficGroups.componentVertexMidrank C b x ^ 2) =
        ∑ j ∈ C.image b,
          ∑ x ∈ C.filter (fun x => b x = j),
            SoficGroups.componentVertexMidrank C b x ^ 2 := hfiber.symm
    _ = ∑ j ∈ C.image b,
          ((C.filter fun x => b x = j).card : ℝ) *
            (lowerRankWeight (C.image b) (SoficGroups.componentRankMass C b) j +
              SoficGroups.componentRankMass C b j / 2) ^ 2 := by
          apply Finset.sum_congr rfl
          intro j _
          calc
            (∑ x ∈ C.filter (fun x => b x = j),
                SoficGroups.componentVertexMidrank C b x ^ 2) =
              ∑ _x ∈ C.filter (fun x => b x = j),
                (lowerRankWeight (C.image b) (SoficGroups.componentRankMass C b) j +
                  SoficGroups.componentRankMass C b j / 2) ^ 2 := by
                    apply Finset.sum_congr rfl
                    intro x hx
                    have hbx : b x = j := (Finset.mem_filter.mp hx).2
                    rw [componentVertexMidrank_eq_ordered_midpoint C b x, hbx]
            _ = ((C.filter fun x => b x = j).card : ℝ) *
                (lowerRankWeight (C.image b) (SoficGroups.componentRankMass C b) j +
                  SoficGroups.componentRankMass C b j / 2) ^ 2 := by
                    simp
    _ = (C.card : ℝ) *
          (∑ j ∈ C.image b,
            SoficGroups.componentRankMass C b j *
              (lowerRankWeight (C.image b) (SoficGroups.componentRankMass C b) j +
                SoficGroups.componentRankMass C b j / 2) ^ 2) := by
          rw [Finset.mul_sum]
          apply Finset.sum_congr rfl
          intro j _
          have hweight :
              ((C.filter fun x => b x = j).card : ℝ) =
                (C.card : ℝ) * SoficGroups.componentRankMass C b j := by
            unfold SoficGroups.componentRankMass
            field_simp
          rw [hweight]
          ring
    _ = (C.card : ℝ) *
          (((∑ j ∈ C.image b, SoficGroups.componentRankMass C b j) ^ 3 / 3) -
            (∑ j ∈ C.image b, SoficGroups.componentRankMass C b j ^ 3) / 12) := by
          rw [sum_weighted_ordered_midpoints_sq]
    _ = (C.card : ℝ) *
          ((1 : ℝ) / 3 -
            (∑ j ∈ C.image b, SoficGroups.componentRankMass C b j ^ 3) / 12) := by
          rw [SoficGroups.sum_componentRankMass C b hC]
          norm_num

theorem componentRankMassList_cube_sum
    {V : Type*}
    (C : Finset V) (b : V → ℤ) :
    ((SoficGroups.componentRankMassList C b).map fun p => p ^ 3).sum =
      ∑ j ∈ C.image b, SoficGroups.componentRankMass C b j ^ 3 := by
  unfold SoficGroups.componentRankMassList
  simp only [List.map_map]
  exact SoficGroups.sum_map_sort_eq (C.image b)
    (fun j => SoficGroups.componentRankMass C b j ^ 3)

theorem componentVertexMidrank_variance_eq
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (hC : C.Nonempty) :
    (∑ x ∈ C,
      (SoficGroups.componentVertexMidrank C b x - (1 / 2 : ℝ)) ^ 2) =
      (C.card : ℝ) *
        SoficGroups.midrankVariance (SoficGroups.componentRankMassList C b) := by
  have hcenter :
      (∑ x ∈ C,
        (SoficGroups.componentVertexMidrank C b x - (1 / 2 : ℝ)) ^ 2) =
        (∑ x ∈ C, SoficGroups.componentVertexMidrank C b x ^ 2) -
          (∑ x ∈ C, SoficGroups.componentVertexMidrank C b x) +
          (C.card : ℝ) / 4 := by
    calc
      (∑ x ∈ C,
        (SoficGroups.componentVertexMidrank C b x - (1 / 2 : ℝ)) ^ 2) =
          ∑ x ∈ C,
            (SoficGroups.componentVertexMidrank C b x ^ 2 -
              SoficGroups.componentVertexMidrank C b x + (1 / 4 : ℝ)) := by
                apply Finset.sum_congr rfl
                intro x _
                ring
      _ = (∑ x ∈ C, SoficGroups.componentVertexMidrank C b x ^ 2) -
          (∑ x ∈ C, SoficGroups.componentVertexMidrank C b x) +
          (C.card : ℝ) / 4 := by
            rw [Finset.sum_add_distrib, Finset.sum_sub_distrib]
            simp [div_eq_mul_inv]
  calc
    (∑ x ∈ C,
      (SoficGroups.componentVertexMidrank C b x - (1 / 2 : ℝ)) ^ 2) =
        (C.card : ℝ) *
            ((1 : ℝ) / 3 -
              (∑ j ∈ C.image b,
                SoficGroups.componentRankMass C b j ^ 3) / 12) -
          (C.card : ℝ) / 2 + (C.card : ℝ) / 4 := by
            rw [hcenter, sum_componentVertexMidrank_sq_eq C b hC,
              sum_componentVertexMidrank C b hC]
    _ = (C.card : ℝ) *
        SoficGroups.midrankVariance (SoficGroups.componentRankMassList C b) := by
          rw [SoficGroups.midrankVariance_eq
            (SoficGroups.componentRankMassList C b)
            (SoficGroups.componentRankMassList_sum C b hC),
            componentRankMassList_cube_sum C b]
          ring

theorem componentVertexMidrank_finiteMean_eq_half
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (hC : C.Nonempty) :
    SoficGroups.CheegerPoincare.finiteMean
      (fun x : {x // x ∈ C} =>
        SoficGroups.componentVertexMidrank C b x) =
      (1 / 2 : ℝ) := by
  have hc : (C.card : ℝ) ≠ 0 := by
    exact_mod_cast Finset.card_ne_zero.mpr hC
  unfold SoficGroups.CheegerPoincare.finiteMean
  rw [← Finset.sum_subtype C (fun _ => Iff.rfl)
    (SoficGroups.componentVertexMidrank C b),
    Fintype.card_coe,
    SoficGroups.ComponentMidrankVariance.sum_componentVertexMidrank C b hC]
  field_simp

theorem componentVertexMidrank_finiteVariance_eq
    {V : Type*}
    (C : Finset V) (b : V → ℤ) (hC : C.Nonempty) :
    SoficGroups.CheegerPoincare.finiteVariance
      (fun x : {x // x ∈ C} =>
        SoficGroups.componentVertexMidrank C b x) =
      SoficGroups.midrankVariance (SoficGroups.componentRankMassList C b) := by
  have hc : (C.card : ℝ) ≠ 0 := by
    exact_mod_cast Finset.card_ne_zero.mpr hC
  unfold SoficGroups.CheegerPoincare.finiteVariance
  rw [componentVertexMidrank_finiteMean_eq_half C b hC,
    ← Finset.sum_subtype C (fun _ => Iff.rfl)
      (fun x =>
        (SoficGroups.componentVertexMidrank C b x - (1 / 2 : ℝ)) ^ 2),
    Fintype.card_coe,
    SoficGroups.ComponentMidrankVariance.componentVertexMidrank_variance_eq
      C b hC]
  field_simp

end ComponentMidrankVariance

noncomputable def insufficientOverlapComponents
    {V : Type u} [DecidableEq V] {U : Finset V}
    (P Q : Finpartition U) (eta : ℝ) : Finset (Finset V) := by
  classical
  exact P.parts.filter fun C =>
    ((C ∩ maximumOverlapPart Q C).card : ℝ) <
      (1 - eta) * (C.card : ℝ)

theorem insufficientOverlapComponents_subset
    {V : Type u} [DecidableEq V] {U : Finset V}
    (P Q : Finpartition U) (eta : ℝ) :
    insufficientOverlapComponents P Q eta ⊆ P.parts := by
  classical
  exact Finset.filter_subset _ _

theorem insufficientOverlapComponents_mass_le_loss
    {V : Type u} [DecidableEq V] {U : Finset V}
    (P Q : Finpartition U) (eta : ℝ) :
    eta * (∑ C ∈ insufficientOverlapComponents P Q eta,
        (C.card : ℝ)) ≤
      ∑ C ∈ P.parts,
        ((C.card : ℝ) - ((C ∩ maximumOverlapPart Q C).card : ℝ)) := by
  classical
  calc
    eta * (∑ C ∈ insufficientOverlapComponents P Q eta,
        (C.card : ℝ)) =
      ∑ C ∈ insufficientOverlapComponents P Q eta,
        eta * (C.card : ℝ) := by
          rw [Finset.mul_sum]
    _ ≤ ∑ C ∈ insufficientOverlapComponents P Q eta,
        ((C.card : ℝ) - ((C ∩ maximumOverlapPart Q C).card : ℝ)) := by
          apply Finset.sum_le_sum
          intro C hC
          have hbad :=
            (Finset.mem_filter.mp
              (show C ∈ P.parts.filter (fun C =>
                ((C ∩ maximumOverlapPart Q C).card : ℝ) <
                  (1 - eta) * (C.card : ℝ)) from hC)).2
          linarith
    _ ≤ ∑ C ∈ P.parts,
        ((C.card : ℝ) - ((C ∩ maximumOverlapPart Q C).card : ℝ)) := by
          apply Finset.sum_le_sum_of_subset_of_nonneg
            (insufficientOverlapComponents_subset P Q eta)
          intro C _ _
          exact sub_nonneg.mpr (by
            exact_mod_cast Finset.card_le_card
              (Finset.inter_subset_left :
                C ∩ maximumOverlapPart Q C ⊆ C))

noncomputable def finsetPermutationOrderIso
    {V : Type u} (T : Equiv.Perm V) : Finset V ≃o Finset V where
  toEquiv := T.finsetCongr
  map_rel_iff' := by
    intro A B
    exact Finset.map_subset_map

noncomputable def transportedFinpartition
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (T : Equiv.Perm V) :
    Finpartition (U.map T.toEmbedding) :=
  Q.map (finsetPermutationOrderIso T)

@[simp]
theorem transportedFinpartition_parts
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (T : Equiv.Perm V) :
    (transportedFinpartition Q T).parts =
      Q.parts.image (fun C : Finset V => C.map T.toEmbedding) := by
  classical
  change Q.parts.map (finsetPermutationOrderIso T).toEmbedding =
    Q.parts.image (fun C : Finset V => C.map T.toEmbedding)
  exact Finset.map_eq_image (finsetPermutationOrderIso T).toEmbedding Q.parts

noncomputable def transportedUnivFinpartition
    {V : Type u} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) : Finpartition (Finset.univ : Finset V) :=
  (transportedFinpartition Q T).copy (Finset.map_univ_equiv T)

@[simp]
theorem transportedUnivFinpartition_parts
    {V : Type u} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) :
    (transportedUnivFinpartition Q T).parts =
      Q.parts.image (fun C : Finset V => C.map T.toEmbedding) := by
  exact transportedFinpartition_parts Q T

noncomputable def partitionComponentSize
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (x : V) : ℕ :=
  (Q.part x).card

theorem partitionComponentSize_eq_card_of_mem
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (C : Finset V) (hC : C ∈ Q.parts)
    (x : V) (hx : x ∈ C) :
    partitionComponentSize Q x = C.card := by
  unfold partitionComponentSize
  rw [Q.part_eq_of_mem hC hx]

theorem partitionComponentSize_transport_lower_of_overlap
    {V : Type u} [DecidableEq V] {U : Finset V}
    (Q : Finpartition U) (T : Equiv.Perm V)
    (C D : Finset V) (hC : C ∈ Q.parts) (hD : D ∈ Q.parts)
    (eta : ℝ)
    (hoverlap :
      (1 - eta) * (C.card : ℝ) ≤
        (((C.map T.toEmbedding) ∩ D).card : ℝ))
    (x : V) (hx : x ∈ C) (hTx : T x ∈ D) :
    (1 - eta) * (partitionComponentSize Q x : ℝ) ≤
      (partitionComponentSize Q (T x) : ℝ) := by
  rw [partitionComponentSize_eq_card_of_mem Q C hC x hx,
    partitionComponentSize_eq_card_of_mem Q D hD (T x) hTx]
  calc
    (1 - eta) * (C.card : ℝ) ≤
      (((C.map T.toEmbedding) ∩ D).card : ℝ) := hoverlap
    _ ≤ (D.card : ℝ) := by
      exact_mod_cast Finset.card_le_card
        (Finset.inter_subset_right : (C.map T.toEmbedding) ∩ D ⊆ D)

theorem maximumOverlapPart_overlap_of_not_mem_insufficient
    {V : Type u} [DecidableEq V] {U : Finset V}
    (P Q : Finpartition U) (eta : ℝ) (C : Finset V)
    (hC : C ∈ P.parts)
    (hretained : C ∉ insufficientOverlapComponents P Q eta) :
    (1 - eta) * (C.card : ℝ) ≤
      ((C ∩ maximumOverlapPart Q C).card : ℝ) := by
  classical
  apply le_of_not_gt
  intro hbad
  apply hretained
  change C ∈ P.parts.filter (fun C =>
    ((C ∩ maximumOverlapPart Q C).card : ℝ) <
      (1 - eta) * (C.card : ℝ))
  exact Finset.mem_filter.mpr ⟨hC, hbad⟩

theorem partitionComponentSize_transport_lower_of_retained
    {V : Type u} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (C : Finset V) (hC : C ∈ Q.parts)
    (eta : ℝ)
    (hretained : C.map T.toEmbedding ∉
      insufficientOverlapComponents
        (transportedUnivFinpartition Q T) Q eta)
    (x : V) (hx : x ∈ C)
    (hTx : T x ∈ maximumOverlapPart Q (C.map T.toEmbedding)) :
    (1 - eta) * (partitionComponentSize Q x : ℝ) ≤
      (partitionComponentSize Q (T x) : ℝ) := by
  have htransport : C.map T.toEmbedding ∈
      (transportedUnivFinpartition Q T).parts := by
    rw [transportedUnivFinpartition_parts]
    exact Finset.mem_image_of_mem
      (fun C : Finset V => C.map T.toEmbedding) hC
  have hsize := maximumOverlapPart_overlap_of_not_mem_insufficient
    (transportedUnivFinpartition Q T) Q eta
    (C.map T.toEmbedding) htransport hretained
  have hsize' :
      (1 - eta) * (C.card : ℝ) ≤
        (((C.map T.toEmbedding) ∩
          maximumOverlapPart Q (C.map T.toEmbedding)).card : ℝ) := by
    simpa using hsize
  have htarget := maximumOverlapPart_mem Q
    (C.map T.toEmbedding)
    ((Finset.map_nonempty).2 (Q.nonempty_of_mem_parts hC))
    (Finset.subset_univ _)
  exact partitionComponentSize_transport_lower_of_overlap Q T C
    (maximumOverlapPart Q (C.map T.toEmbedding)) hC htarget
    eta hsize' x hx hTx

namespace ThompsonPrefixInsertion

open scoped BigOperators

def singletonPrefixCode (a : List (Fin 2)) : BinaryPrefixCode (Fin 1) where
  word _ := a
  prefix_free := by
    intro i j hij
    exact (hij (Subsingleton.elim i j)).elim

theorem singletonPrefixCode_codeIdempotent (a : List (Fin 2)) :
    MatrixCorner.codeIdempotent
        (fun i => leavittWordS ((singletonPrefixCode a).word i))
        (fun i => leavittWordT ((singletonPrefixCode a).word i)) =
      leavittCylinder a := by
  simp [MatrixCorner.codeIdempotent, singletonPrefixCode, leavittCylinder]

def prefixInsertionHom (a : List (Fin 2)) :
    BinaryLeavittˣ →* BinaryLeavittˣ :=
  (prefixCornerUnitHom (singletonPrefixCode a)).comp
    (Units.mapEquiv
      (Matrix.uniqueRingEquiv (m := Fin 1)
        (A := BinaryLeavitt)).symm.toMulEquiv).toMonoidHom

theorem prefixInsertionHom_injective (a : List (Fin 2)) :
    Function.Injective (prefixInsertionHom a) :=
  (prefixCornerUnitHom_injective (singletonPrefixCode a)).comp
    (Units.mapEquiv
      (Matrix.uniqueRingEquiv (m := Fin 1)
        (A := BinaryLeavitt)).symm.toMulEquiv).injective

theorem leavittCylinder_isIdempotent (a : List (Fin 2)) :
    IsIdempotentElem (leavittCylinder a) := by
  change
    (leavittWordS a * leavittWordT a) *
        (leavittWordS a * leavittWordT a) =
      leavittWordS a * leavittWordT a
  calc
    (leavittWordS a * leavittWordT a) *
        (leavittWordS a * leavittWordT a) =
      leavittWordS a *
        (leavittWordT a * leavittWordS a) * leavittWordT a := by
          noncomm_ring
    _ = leavittWordS a * leavittWordT a := by
      rw [leavittWordT_mul_wordS_self]
      simp

def cylinderCornerGroup (a : List (Fin 2)) : Subgroup BinaryLeavittˣ :=
  (idempotentCornerUnitExtension (leavittCylinder_isIdempotent a)).range

theorem cylinderCornerGroup_eq_source (a : List (Fin 2)) :
    cylinderCornerGroup a = ThompsonPrefixLocal.cylinderCornerGroup a := by
  rfl

theorem prefixInsertionHom_mem_cylinderCorner
    (a : List (Fin 2)) (u : BinaryLeavittˣ) :
    prefixInsertionHom a u ∈ cylinderCornerGroup a := by
  unfold cylinderCornerGroup
  let he := MatrixCorner.codeIdempotent_isIdempotent
    (fun i => leavittWordS ((singletonPrefixCode a).word i))
    (fun i => leavittWordT ((singletonPrefixCode a).word i))
    (binaryPrefixCode_orthogonal (singletonPrefixCode a))
  have hidem :
      (⟨MatrixCorner.codeIdempotent
        (fun i => leavittWordS ((singletonPrefixCode a).word i))
        (fun i => leavittWordT ((singletonPrefixCode a).word i)), he⟩ :
          {e : BinaryLeavitt // IsIdempotentElem e}) =
        ⟨leavittCylinder a, leavittCylinder_isIdempotent a⟩ :=
    Subtype.ext (singletonPrefixCode_codeIdempotent a)
  have hcorner := congrArg
    (fun p : {e : BinaryLeavitt // IsIdempotentElem e} =>
      (idempotentCornerUnitExtension p.property).range)
    hidem
  rw [← hcorner]
  refine ⟨(Units.mapEquiv
      (binaryPrefixCornerEquiv (singletonPrefixCode a)).toMulEquiv)
    ((Units.mapEquiv
      (Matrix.uniqueRingEquiv (m := Fin 1)
        (A := BinaryLeavitt)).symm.toMulEquiv) u), ?_⟩
  rfl

theorem prefixInsertionHom_val (a : List (Fin 2)) (u : BinaryLeavittˣ) :
    (↑(prefixInsertionHom a u) : BinaryLeavitt) =
      leavittWordS a * (u : BinaryLeavitt) * leavittWordT a +
        (1 - leavittCylinder a) := by
  change
    MatrixCorner.encode
        (fun i => leavittWordS ((singletonPrefixCode a).word i))
        (fun i => leavittWordT ((singletonPrefixCode a).word i))
        ((Matrix.uniqueRingEquiv (m := Fin 1)
          (A := BinaryLeavitt)).symm (u : BinaryLeavitt)) +
      (1 - MatrixCorner.codeIdempotent
        (fun i => leavittWordS ((singletonPrefixCode a).word i))
        (fun i => leavittWordT ((singletonPrefixCode a).word i))) = _
  simp [MatrixCorner.encode, MatrixCorner.codeIdempotent,
    singletonPrefixCode, leavittCylinder]

theorem transpositionValue_mul_self {A : Type*} [Ring A]
    (sa ta sb tb : A)
    (haa : ta * sa = 1) (hbb : tb * sb = 1)
    (hab : ta * sb = 0) (hba : tb * sa = 0) :
    PrefixCompression.transpositionValue sa ta sb tb *
      PrefixCompression.transpositionValue sa ta sb tb = 1 := by
  have haa' (x : A) : ta * (sa * x) = x := by
    rw [← mul_assoc, haa, one_mul]
  have hbb' (x : A) : tb * (sb * x) = x := by
    rw [← mul_assoc, hbb, one_mul]
  have hab' (x : A) : ta * (sb * x) = 0 := by
    rw [← mul_assoc, hab, zero_mul]
  have hba' (x : A) : tb * (sa * x) = 0 := by
    rw [← mul_assoc, hba, zero_mul]
  unfold PrefixCompression.transpositionValue
  noncomm_ring [haa, hbb, hab, hba, haa', hbb', hab', hba']

def cylinderSwap (a b : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a) : BinaryLeavittˣ where
  val := PrefixCompression.wordSwapValue a b
  inv := PrefixCompression.wordSwapValue a b
  val_inv := transpositionValue_mul_self
    (leavittWordS a) (leavittWordT a)
    (leavittWordS b) (leavittWordT b)
    (leavittWordT_mul_wordS_self a)
    (leavittWordT_mul_wordS_self b)
    (leavittWordT_mul_wordS_of_incomparable a b hab hba)
    (leavittWordT_mul_wordS_of_incomparable b a hba hab)
  inv_val := transpositionValue_mul_self
    (leavittWordS a) (leavittWordT a)
    (leavittWordS b) (leavittWordT b)
    (leavittWordT_mul_wordS_self a)
    (leavittWordT_mul_wordS_self b)
    (leavittWordT_mul_wordS_of_incomparable a b hab hba)
    (leavittWordT_mul_wordS_of_incomparable b a hba hab)

theorem append_not_prefix_append (a b x y : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a) :
    ¬ a ++ x <+: b ++ y := by
  intro h
  have ha : a <+: b ++ y := (List.prefix_append a x).trans h
  by_cases hle : a.length ≤ b.length
  · exact hab ((List.isPrefix_append_of_length hle).mp ha)
  · apply hba
    rw [List.prefix_iff_eq_take]
    have hea := List.prefix_iff_eq_take.mp ha
    rw [hea, List.take_take, Nat.min_eq_left (Nat.le_of_not_ge hle)]
    simp

theorem prepend_not_prefix_prepend (l a b : List (Fin 2))
    (hab : ¬ a <+: b) :
    ¬ l ++ a <+: l ++ b := by
  intro h
  apply hab
  simpa using h

theorem prefixInsertionHom_cylinderSwap
    (l a b : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a) :
    prefixInsertionHom l (cylinderSwap a b hab hba) =
      cylinderSwap (l ++ a) (l ++ b)
        (prepend_not_prefix_prepend l a b hab)
        (prepend_not_prefix_prepend l b a hba) := by
  apply Units.ext
  rw [prefixInsertionHom_val]
  change
    leavittWordS l *
        (1 - leavittWordS a * leavittWordT a -
          leavittWordS b * leavittWordT b +
          leavittWordS a * leavittWordT b +
          leavittWordS b * leavittWordT a) * leavittWordT l +
        (1 - leavittWordS l * leavittWordT l) =
      1 - leavittWordS (l ++ a) * leavittWordT (l ++ a) -
        leavittWordS (l ++ b) * leavittWordT (l ++ b) +
        leavittWordS (l ++ a) * leavittWordT (l ++ b) +
        leavittWordS (l ++ b) * leavittWordT (l ++ a)
  rw [leavittWordS_append, leavittWordT_append,
    leavittWordS_append, leavittWordT_append]
  simp only [CharTwo.sub_eq_add]
  noncomm_ring
  simp [CharTwo.two_eq_zero]

theorem transpositionValue_braid {A : Type*} [Ring A]
    (sa ta sb tb sc tc : A)
    (haa : ta * sa = 1) (hbb : tb * sb = 1) (hcc : tc * sc = 1)
    (hab : ta * sb = 0) (hba : tb * sa = 0)
    (hac : ta * sc = 0) (hca : tc * sa = 0)
    (hbc : tb * sc = 0) (hcb : tc * sb = 0) :
    PrefixCompression.transpositionValue sa ta sc tc *
        PrefixCompression.transpositionValue sb tb sc tc *
        PrefixCompression.transpositionValue sa ta sc tc =
      PrefixCompression.transpositionValue sa ta sb tb := by
  have haa' (x : A) : ta * (sa * x) = x := by
    rw [← mul_assoc, haa, one_mul]
  have hbb' (x : A) : tb * (sb * x) = x := by
    rw [← mul_assoc, hbb, one_mul]
  have hcc' (x : A) : tc * (sc * x) = x := by
    rw [← mul_assoc, hcc, one_mul]
  have hab' (x : A) : ta * (sb * x) = 0 := by
    rw [← mul_assoc, hab, zero_mul]
  have hba' (x : A) : tb * (sa * x) = 0 := by
    rw [← mul_assoc, hba, zero_mul]
  have hac' (x : A) : ta * (sc * x) = 0 := by
    rw [← mul_assoc, hac, zero_mul]
  have hca' (x : A) : tc * (sa * x) = 0 := by
    rw [← mul_assoc, hca, zero_mul]
  have hbc' (x : A) : tb * (sc * x) = 0 := by
    rw [← mul_assoc, hbc, zero_mul]
  have hcb' (x : A) : tc * (sb * x) = 0 := by
    rw [← mul_assoc, hcb, zero_mul]
  unfold PrefixCompression.transpositionValue
  noncomm_ring [haa, hbb, hcc, hab, hba, hac, hca, hbc, hcb,
    haa', hbb', hcc', hab', hba', hac', hca', hbc', hcb']

def prefixCrossRoot {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (i j : ι) (hij : i ≠ j) (a b : List (Fin 2)) : BinaryLeavittˣ :=
  prefixElementaryUnit E i j hij
    (leavittWordS a * leavittWordT b)

theorem prefixCrossRoot_mem {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (i j : ι) (hij : i ≠ j) (a b : List (Fin 2)) :
    prefixCrossRoot E i j hij a b ∈ prefixElementaryGroup E :=
  Subgroup.subset_closure
    ⟨i, j, hij, leavittWordS a * leavittWordT b, rfl⟩

def prefixCrossSwap {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (i j : ι) (hij : i ≠ j) (a b : List (Fin 2)) : BinaryLeavittˣ :=
  prefixCrossRoot E i j hij a b *
    prefixCrossRoot E j i hij.symm b a *
    prefixCrossRoot E i j hij a b

theorem prefixCrossSwap_mem {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (i j : ι) (hij : i ≠ j) (a b : List (Fin 2)) :
    prefixCrossSwap E i j hij a b ∈ prefixElementaryGroup E :=
  (prefixElementaryGroup E).mul_mem
    ((prefixElementaryGroup E).mul_mem
      (prefixCrossRoot_mem E i j hij a b)
      (prefixCrossRoot_mem E j i hij.symm b a))
    (prefixCrossRoot_mem E i j hij a b)

theorem prefixCrossSwap_val {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (i j : ι) (hij : i ≠ j) (a b : List (Fin 2)) :
    (↑(prefixCrossSwap E i j hij a b) : BinaryLeavitt) =
      PrefixCompression.wordSwapValue
        (E.word i ++ a) (E.word j ++ b) := by
  let A : List (Fin 2) := E.word i ++ a
  let B : List (Fin 2) := E.word j ++ b
  let P : BinaryLeavitt := leavittWordS A * leavittWordT B
  let Q : BinaryLeavitt := leavittWordS B * leavittWordT A
  have hBA : leavittWordT B * leavittWordS A = 0 := by
    apply leavittWordT_mul_wordS_of_incomparable B A
    · exact append_not_prefix_append (E.word j) (E.word i)
        b a (E.prefix_free hij.symm) (E.prefix_free hij)
    · exact append_not_prefix_append (E.word i) (E.word j)
        a b (E.prefix_free hij) (E.prefix_free hij.symm)
  have hPP : P * P = 0 := by
    change
      (leavittWordS A * leavittWordT B) *
        (leavittWordS A * leavittWordT B) = 0
    calc
      (leavittWordS A * leavittWordT B) *
          (leavittWordS A * leavittWordT B) =
        leavittWordS A *
          (leavittWordT B * leavittWordS A) *
          leavittWordT B := by noncomm_ring
      _ = 0 := by rw [hBA]; simp
  have hPQP : P * Q * P = P := by
    change
      (leavittWordS A * leavittWordT B) *
        (leavittWordS B * leavittWordT A) *
        (leavittWordS A * leavittWordT B) =
        leavittWordS A * leavittWordT B
    calc
      (leavittWordS A * leavittWordT B) *
          (leavittWordS B * leavittWordT A) *
          (leavittWordS A * leavittWordT B) =
        leavittWordS A *
          (leavittWordT B * leavittWordS B) *
          (leavittWordT A * leavittWordS A) *
          leavittWordT B := by noncomm_ring
      _ = leavittWordS A * leavittWordT B := by
        rw [leavittWordT_mul_wordS_self,
          leavittWordT_mul_wordS_self]
        simp
  have hPQ : P * Q = leavittWordS A * leavittWordT A := by
    dsimp [P, Q]
    calc
      (leavittWordS A * leavittWordT B) *
          (leavittWordS B * leavittWordT A) =
        leavittWordS A *
          (leavittWordT B * leavittWordS B) *
          leavittWordT A := by noncomm_ring
      _ = _ := by rw [leavittWordT_mul_wordS_self]; simp
  have hQP : Q * P = leavittWordS B * leavittWordT B := by
    dsimp [P, Q]
    calc
      (leavittWordS B * leavittWordT A) *
          (leavittWordS A * leavittWordT B) =
        leavittWordS B *
          (leavittWordT A * leavittWordS A) *
          leavittWordT B := by noncomm_ring
      _ = _ := by rw [leavittWordT_mul_wordS_self]; simp
  change
    (1 + leavittWordS (E.word i) *
      (leavittWordS a * leavittWordT b) * leavittWordT (E.word j)) *
      (1 + leavittWordS (E.word j) *
        (leavittWordS b * leavittWordT a) * leavittWordT (E.word i)) *
      (1 + leavittWordS (E.word i) *
        (leavittWordS a * leavittWordT b) * leavittWordT (E.word j)) = _
  have hleft :
      leavittWordS (E.word i) *
          (leavittWordS a * leavittWordT b) * leavittWordT (E.word j) =
        P := by
    dsimp [P, A, B]
    rw [leavittWordS_append, leavittWordT_append]
    noncomm_ring
  have hright :
      leavittWordS (E.word j) *
          (leavittWordS b * leavittWordT a) * leavittWordT (E.word i) =
        Q := by
    dsimp [Q, A, B]
    rw [leavittWordS_append, leavittWordT_append]
    noncomm_ring
  rw [hleft, hright,
    cylinder_transposition_factorization P Q hPP hPQP,
    hPQ, hQP]
  rfl

theorem samePrefixCylinderSwap_mem {ι : Type*} [DecidableEq ι]
    (E : BinaryPrefixCode ι)
    (i j : ι) (hij : i ≠ j)
    (a b c : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a) :
    cylinderSwap (E.word i ++ a) (E.word i ++ b)
        (prepend_not_prefix_prepend (E.word i) a b hab)
        (prepend_not_prefix_prepend (E.word i) b a hba) ∈
      prefixElementaryGroup E := by
  let x := prefixCrossSwap E i j hij a c
  let y := prefixCrossSwap E i j hij b c
  have hx : x ∈ prefixElementaryGroup E :=
    prefixCrossSwap_mem E i j hij a c
  have hy : y ∈ prefixElementaryGroup E :=
    prefixCrossSwap_mem E i j hij b c
  have hfactor : x * y * x =
      cylinderSwap (E.word i ++ a) (E.word i ++ b)
        (prepend_not_prefix_prepend (E.word i) a b hab)
        (prepend_not_prefix_prepend (E.word i) b a hba) := by
    apply Units.ext
    change
      (↑(prefixCrossSwap E i j hij a c) : BinaryLeavitt) *
          (↑(prefixCrossSwap E i j hij b c) : BinaryLeavitt) *
          (↑(prefixCrossSwap E i j hij a c) : BinaryLeavitt) =
        PrefixCompression.wordSwapValue (E.word i ++ a) (E.word i ++ b)
    rw [prefixCrossSwap_val, prefixCrossSwap_val]
    exact transpositionValue_braid
      (leavittWordS (E.word i ++ a))
      (leavittWordT (E.word i ++ a))
      (leavittWordS (E.word i ++ b))
      (leavittWordT (E.word i ++ b))
      (leavittWordS (E.word j ++ c))
      (leavittWordT (E.word j ++ c))
      (leavittWordT_mul_wordS_self (E.word i ++ a))
      (leavittWordT_mul_wordS_self (E.word i ++ b))
      (leavittWordT_mul_wordS_self (E.word j ++ c))
      (leavittWordT_mul_wordS_of_incomparable
        (E.word i ++ a) (E.word i ++ b)
        (prepend_not_prefix_prepend (E.word i) a b hab)
        (prepend_not_prefix_prepend (E.word i) b a hba))
      (leavittWordT_mul_wordS_of_incomparable
        (E.word i ++ b) (E.word i ++ a)
        (prepend_not_prefix_prepend (E.word i) b a hba)
        (prepend_not_prefix_prepend (E.word i) a b hab))
      (leavittWordT_mul_wordS_of_incomparable
        (E.word i ++ a) (E.word j ++ c)
        (append_not_prefix_append (E.word i) (E.word j) a c
          (E.prefix_free hij) (E.prefix_free hij.symm))
        (append_not_prefix_append (E.word j) (E.word i) c a
          (E.prefix_free hij.symm) (E.prefix_free hij)))
      (leavittWordT_mul_wordS_of_incomparable
        (E.word j ++ c) (E.word i ++ a)
        (append_not_prefix_append (E.word j) (E.word i) c a
          (E.prefix_free hij.symm) (E.prefix_free hij))
        (append_not_prefix_append (E.word i) (E.word j) a c
          (E.prefix_free hij) (E.prefix_free hij.symm)))
      (leavittWordT_mul_wordS_of_incomparable
        (E.word i ++ b) (E.word j ++ c)
        (append_not_prefix_append (E.word i) (E.word j) b c
          (E.prefix_free hij) (E.prefix_free hij.symm))
        (append_not_prefix_append (E.word j) (E.word i) c b
          (E.prefix_free hij.symm) (E.prefix_free hij)))
      (leavittWordT_mul_wordS_of_incomparable
        (E.word j ++ c) (E.word i ++ b)
        (append_not_prefix_append (E.word j) (E.word i) c b
          (E.prefix_free hij.symm) (E.prefix_free hij))
        (append_not_prefix_append (E.word i) (E.word j) b c
          (E.prefix_free hij) (E.prefix_free hij.symm)))
  rw [← hfactor]
  exact (prefixElementaryGroup E).mul_mem
    ((prefixElementaryGroup E).mul_mem hx hy) hx

theorem sourceLocal_cylinderSwap_mem_alpha
    (a b : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a) :
    prefixInsertionHom [0, 0, 0, 1] (cylinderSwap a b hab hba) ∈
      prefixElementaryGroup alphaPrefixCode := by
  rw [prefixInsertionHom_cylinderSwap]
  have h := samePrefixCylinderSwap_mem alphaPrefixCode
    (0 : Fin 3) (1 : Fin 3) (by decide)
    ([1] ++ a) ([1] ++ b) []
    (prepend_not_prefix_prepend [1] a b hab)
    (prepend_not_prefix_prepend [1] b a hba)
  simpa [alphaPrefixCode, alphaWord, List.append_assoc] using h

def binaryPrefixTranspositionGroup : Subgroup BinaryLeavittˣ :=
  Subgroup.closure
    {z | ∃ (a b : List (Fin 2))
      (hab : ¬ a <+: b) (hba : ¬ b <+: a),
      cylinderSwap a b hab hba = z}

def localPrefixTranspositionGroup
    (l : List (Fin 2)) : Subgroup BinaryLeavittˣ :=
  binaryPrefixTranspositionGroup.map (prefixInsertionHom l)

theorem localPrefixTranspositionGroup_le_cylinderCorner
    (l : List (Fin 2)) :
    localPrefixTranspositionGroup l ≤ cylinderCornerGroup l := by
  rintro _ ⟨u, _, rfl⟩
  exact prefixInsertionHom_mem_cylinderCorner l u

theorem localPrefixTranspositionGroup_le_sourceCylinderCorner
    (l : List (Fin 2)) :
    localPrefixTranspositionGroup l ≤
      ThompsonPrefixLocal.cylinderCornerGroup l := by
  rw [← cylinderCornerGroup_eq_source]
  exact localPrefixTranspositionGroup_le_cylinderCorner l

theorem sourceLocalPrefixTranspositionGroup_le_alpha :
    localPrefixTranspositionGroup [0, 0, 0, 1] ≤
      prefixElementaryGroup alphaPrefixCode := by
  apply (Subgroup.map_le_iff_le_comap).2
  apply (Subgroup.closure_le _).2
  rintro _ ⟨a, b, hab, hba, rfl⟩
  exact sourceLocal_cylinderSwap_mem_alpha a b hab hba

theorem sourceLocalPrefixTranspositionGroup_le_alpha_sourceWord :
    localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord ≤
      prefixElementaryGroup alphaPrefixCode := by
  exact sourceLocalPrefixTranspositionGroup_le_alpha

theorem sourceLocalPrefixTranspositionGroup_le_nine :
    localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord ≤
      prefixElementaryGroup ninePrefixCode :=
  sourceLocalPrefixTranspositionGroup_le_alpha_sourceWord.trans
    SourceGeneration.alphaPrefixElementaryGroup_le_nine

theorem sourceLocalPrefixTranspositionGroup_le_centralizer_alphaZero :
    localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord ≤
      Subgroup.centralizer
        (prefixElementaryGroup alphaZeroPrefixCode : Set BinaryLeavittˣ) :=
  (localPrefixTranspositionGroup_le_sourceCylinderCorner
    ThompsonPrefixLocal.sourceLocalWord).trans
    ThompsonPrefixLocal.localCylinderCorner_le_centralizer_alphaZero

theorem alphaZero_inf_sourceLocalPrefixTranspositionGroup_eq_bot :
    prefixElementaryGroup alphaZeroPrefixCode ⊓
        localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord = ⊥ := by
  apply le_antisymm
  · calc
      prefixElementaryGroup alphaZeroPrefixCode ⊓
          localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord ≤
        prefixElementaryGroup alphaZeroPrefixCode ⊓
          ThompsonPrefixLocal.cylinderCornerGroup
            ThompsonPrefixLocal.sourceLocalWord :=
          inf_le_inf_left _
            (localPrefixTranspositionGroup_le_sourceCylinderCorner
              ThompsonPrefixLocal.sourceLocalWord)
      _ = ⊥ := ThompsonPrefixLocal.alphaZero_inf_localCylinderCorner_eq_bot
  · exact bot_le

def sourceCompressedLocalProductHom :
    (prefixElementaryGroup alphaZeroPrefixCode ×
      localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord) →*
        BinaryLeavittˣ where
  toFun x := (x.1 : BinaryLeavittˣ) * (x.2 : BinaryLeavittˣ)
  map_one' := by simp
  map_mul' p q := by
    have hcomm :
        (q.1 : BinaryLeavittˣ) * (p.2 : BinaryLeavittˣ) =
          (p.2 : BinaryLeavittˣ) * (q.1 : BinaryLeavittˣ) :=
      Subgroup.mem_centralizer_iff.mp
        (sourceLocalPrefixTranspositionGroup_le_centralizer_alphaZero
          p.2.property)
        (q.1 : BinaryLeavittˣ) q.1.property
    change
      ((p.1 : BinaryLeavittˣ) * (q.1 : BinaryLeavittˣ)) *
          ((p.2 : BinaryLeavittˣ) * (q.2 : BinaryLeavittˣ)) =
        ((p.1 : BinaryLeavittˣ) * (p.2 : BinaryLeavittˣ)) *
          ((q.1 : BinaryLeavittˣ) * (q.2 : BinaryLeavittˣ))
    calc
      ((p.1 : BinaryLeavittˣ) * (q.1 : BinaryLeavittˣ)) *
          ((p.2 : BinaryLeavittˣ) * (q.2 : BinaryLeavittˣ)) =
        (p.1 : BinaryLeavittˣ) *
          (((q.1 : BinaryLeavittˣ) * (p.2 : BinaryLeavittˣ)) *
            (q.2 : BinaryLeavittˣ)) := by simp [mul_assoc]
      _ = (p.1 : BinaryLeavittˣ) *
          (((p.2 : BinaryLeavittˣ) * (q.1 : BinaryLeavittˣ)) *
            (q.2 : BinaryLeavittˣ)) := by rw [hcomm]
      _ = ((p.1 : BinaryLeavittˣ) * (p.2 : BinaryLeavittˣ)) *
          ((q.1 : BinaryLeavittˣ) * (q.2 : BinaryLeavittˣ)) := by
            simp [mul_assoc]

theorem sourceCompressedLocalProductHom_injective :
    Function.Injective sourceCompressedLocalProductHom := by
  apply (injective_iff_map_eq_one sourceCompressedLocalProductHom).2
  rintro ⟨k, j⟩ hone
  change (k : BinaryLeavittˣ) * (j : BinaryLeavittˣ) = 1 at hone
  have hkinv : (k : BinaryLeavittˣ) = (j : BinaryLeavittˣ)⁻¹ :=
    eq_inv_of_mul_eq_one_left hone
  have hkJ :
      (k : BinaryLeavittˣ) ∈
        localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord := by
    rw [hkinv]
    exact (localPrefixTranspositionGroup
      ThompsonPrefixLocal.sourceLocalWord).inv_mem j.property
  have hkbot :
      (k : BinaryLeavittˣ) ∈
        prefixElementaryGroup alphaZeroPrefixCode ⊓
          localPrefixTranspositionGroup
            ThompsonPrefixLocal.sourceLocalWord :=
    ⟨k.property, hkJ⟩
  rw [alphaZero_inf_sourceLocalPrefixTranspositionGroup_eq_bot] at hkbot
  have hkone : (k : BinaryLeavittˣ) = 1 := by
    simpa using hkbot
  have hjone : (j : BinaryLeavittˣ) = 1 := by
    simpa [hkone] using hone
  apply Prod.ext
  · exact Subtype.ext hkone
  · exact Subtype.ext hjone

theorem sourceCompressedLocalProductHom_range_le_nine :
    sourceCompressedLocalProductHom.range ≤
      prefixElementaryGroup ninePrefixCode := by
  rintro _ ⟨⟨k, j⟩, rfl⟩
  exact (prefixElementaryGroup ninePrefixCode).mul_mem
    (SourceGeneration.alphaPrefixElementaryGroup_le_nine
      (alphaZero_prefixElementaryGroup_le k.property))
    (sourceLocalPrefixTranspositionGroup_le_nine j.property)

def sourceCompressedLocalProductEmbedding :
    (prefixElementaryGroup alphaZeroPrefixCode ×
      localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord) →*
        prefixElementaryGroup ninePrefixCode :=
  sourceCompressedLocalProductHom.codRestrict
    (prefixElementaryGroup ninePrefixCode)
    (fun x => sourceCompressedLocalProductHom_range_le_nine ⟨x, rfl⟩)

theorem sourceCompressedLocalProductEmbedding_injective :
    Function.Injective sourceCompressedLocalProductEmbedding := by
  intro x y hxy
  apply sourceCompressedLocalProductHom_injective
  exact congrArg Subtype.val hxy

end ThompsonPrefixInsertion

namespace MidrankPermutationEnergy

def partitionVertexMidrank {V : Type*} [DecidableEq V]
    {U : Finset V} (P : Finpartition U) (b : V → ℤ) (x : V) : ℝ :=
  componentVertexMidrank (P.part x) b x

def rankDecreasingVertices {V : Type*}
    (U : Finset V) (b : V → ℤ) (p : Equiv.Perm V) : Finset V :=
  U.filter (fun x => b (p x) < b x)

def offsetFloorRank {V : Type*} (u : V → ℝ) (H r : ℝ) : V → ℤ :=
  fun x => ⌊(u x + r) / H⌋

theorem rankDropCount_eq_sum_rankDecreasingVertices
    {V ι : Type*} [Fintype V] [Fintype ι]
    (u : V → ℝ) (p : ι → Equiv.Perm V) (H r : ℝ) :
    SoficGroups.rankDropCount
      (fun e : ι × V => u e.2)
      (fun e : ι × V => u (p e.1 e.2)) H r =
        ∑ i : ι,
          ((rankDecreasingVertices Finset.univ
            (offsetFloorRank u H r) (p i)).card : ℝ) := by
  classical
  unfold SoficGroups.rankDropCount
  rw [← Finset.univ_product_univ, Finset.sum_product]
  apply Finset.sum_congr rfl
  intro i hi
  unfold rankDecreasingVertices offsetFloorRank
  exact Finset.sum_boole
    (fun x : V =>
      ⌊(u (p i x) + r) / H⌋ < ⌊(u x + r) / H⌋)
    Finset.univ

def midpointDecreasingVertices {V : Type*} [DecidableEq V]
    {U : Finset V} (P : Finpartition U) (b : V → ℤ)
    (p : Equiv.Perm V) : Finset V :=
  U.filter (fun x => partitionVertexMidrank P b (p x) <
    partitionVertexMidrank P b x)

theorem midpointDecreasing_subset_crossing_union_rankDecreasing
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (b : V → ℤ) (p : Equiv.Perm V) :
    midpointDecreasingVertices P b p ⊆
      partitionWordCrossing P p ∪ rankDecreasingVertices U b p := by
  intro x hx
  have hxmem := (Finset.mem_filter.mp hx).1
  have hxdec := (Finset.mem_filter.mp hx).2
  by_cases hcross : p x ∈ P.part x
  · apply Finset.mem_union.mpr
    right
    apply Finset.mem_filter.mpr
    refine ⟨hxmem, ?_⟩
    by_contra hnot
    have hrank : b x ≤ b (p x) := le_of_not_gt hnot
    have hpart : P.part x ∈ P.parts := P.part_mem.mpr hxmem
    have hsame : P.part (p x) = P.part x :=
      P.part_eq_of_mem hpart hcross
    have hmono := componentVertexMidrank_mono (P.part x) b hrank
    unfold partitionVertexMidrank at hxdec
    rw [hsame] at hxdec
    exact (not_lt_of_ge hmono) hxdec
  · apply Finset.mem_union.mpr
    left
    exact Finset.mem_filter.mpr ⟨hxmem, hcross⟩

theorem partitionVertexMidrank_permutation_energy_le
    {V : Type*} [Fintype V] [DecidableEq V]
    (P : Finpartition (Finset.univ : Finset V))
    (b : V → ℤ) (p : Equiv.Perm V) :
    (∑ x : V,
      (partitionVertexMidrank P b (p x) -
        partitionVertexMidrank P b x) ^ 2) ≤
      2 * ((partitionWordCrossing P p).card : ℝ) +
        2 * ((rankDecreasingVertices Finset.univ b p).card : ℝ) := by
  have hbase := SoficGroups.permutation_squared_increment_le_twice_decreasing
    p (partitionVertexMidrank P b)
    (fun x => componentVertexMidrank_nonneg (P.part x) b x)
    (fun x => componentVertexMidrank_le_one (P.part x) b x)
  have hsubset :
      (Finset.univ.filter fun x =>
        partitionVertexMidrank P b (p x) < partitionVertexMidrank P b x) ⊆
        partitionWordCrossing P p ∪
          rankDecreasingVertices Finset.univ b p := by
    exact midpointDecreasing_subset_crossing_union_rankDecreasing P b p
  have hcard :
      (Finset.univ.filter fun x =>
        partitionVertexMidrank P b (p x) <
          partitionVertexMidrank P b x).card ≤
        (partitionWordCrossing P p).card +
          (rankDecreasingVertices Finset.univ b p).card :=
    (Finset.card_le_card hsubset).trans
      (Finset.card_union_le _ _)
  have hcast :
      ((Finset.univ.filter fun x =>
        partitionVertexMidrank P b (p x) <
          partitionVertexMidrank P b x).card : ℝ) ≤
        ((partitionWordCrossing P p).card : ℝ) +
          ((rankDecreasingVertices Finset.univ b p).card : ℝ) := by
    exact_mod_cast hcard
  nlinarith

theorem sum_partitionVertexMidrank_permutation_energy_le
    {V ι : Type*} [Fintype V] [DecidableEq V]
    (I : Finset ι)
    (P : Finpartition (Finset.univ : Finset V))
    (b : V → ℤ) (p : ι → Equiv.Perm V) :
    (∑ i ∈ I, ∑ x : V,
      (partitionVertexMidrank P b (p i x) -
        partitionVertexMidrank P b x) ^ 2) ≤
      2 * (∑ i ∈ I, ((partitionWordCrossing P (p i)).card : ℝ)) +
        2 * (∑ i ∈ I,
          ((rankDecreasingVertices Finset.univ b (p i)).card : ℝ)) := by
  calc
    (∑ i ∈ I, ∑ x : V,
        (partitionVertexMidrank P b (p i x) -
          partitionVertexMidrank P b x) ^ 2) ≤
      ∑ i ∈ I,
        (2 * ((partitionWordCrossing P (p i)).card : ℝ) +
          2 * ((rankDecreasingVertices Finset.univ b (p i)).card : ℝ)) := by
            apply Finset.sum_le_sum
            intro i hi
            exact partitionVertexMidrank_permutation_energy_le P b (p i)
    _ = 2 * (∑ i ∈ I, ((partitionWordCrossing P (p i)).card : ℝ)) +
          2 * (∑ i ∈ I,
            ((rankDecreasingVertices Finset.univ b (p i)).card : ℝ)) := by
            rw [Finset.sum_add_distrib, ← Finset.mul_sum, ← Finset.mul_sum]

theorem partitionVertexMidrank_permutation_energy_tendsto_zero
    (V ι : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    [∀ n, Fintype (ι n)]
    (P : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (b : (n : ℕ) → V n → ℤ)
    (p : (n : ℕ) → ι n → Equiv.Perm (V n))
    (N : ℕ → ℝ)
    (hN : ∀ n, 0 < N n)
    (hcross : Tendsto
      (fun n =>
        (∑ i : ι n, ((partitionWordCrossing (P n) (p n i)).card : ℝ)) /
          N n)
      atTop (nhds 0))
    (hrank : Tendsto
      (fun n =>
        (∑ i : ι n,
          ((rankDecreasingVertices Finset.univ (b n) (p n i)).card : ℝ)) /
            N n)
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        (∑ i : ι n, ∑ x : V n,
          (partitionVertexMidrank (P n) (b n) (p n i x) -
            partitionVertexMidrank (P n) (b n) x) ^ 2) / N n)
      atTop (nhds 0) := by
  have hnonnegative : ∀ n,
      0 ≤ (∑ i : ι n, ∑ x : V n,
          (partitionVertexMidrank (P n) (b n) (p n i x) -
            partitionVertexMidrank (P n) (b n) x) ^ 2) / N n := by
    intro n
    apply div_nonneg _ (hN n).le
    apply Finset.sum_nonneg
    intro i hi
    exact Finset.sum_nonneg fun x hx => sq_nonneg _
  have hupper : ∀ n,
      (∑ i : ι n, ∑ x : V n,
          (partitionVertexMidrank (P n) (b n) (p n i x) -
            partitionVertexMidrank (P n) (b n) x) ^ 2) / N n ≤
        2 * ((∑ i : ι n,
          ((partitionWordCrossing (P n) (p n i)).card : ℝ)) / N n) +
        2 * ((∑ i : ι n,
          ((rankDecreasingVertices Finset.univ (b n) (p n i)).card : ℝ)) /
            N n) := by
    intro n
    have hfinite := sum_partitionVertexMidrank_permutation_energy_le
      (Finset.univ : Finset (ι n)) (P n) (b n) (p n)
    have hdiv := (div_le_div_iff_of_pos_right (hN n)).2 hfinite
    calc
      (∑ i : ι n, ∑ x : V n,
          (partitionVertexMidrank (P n) (b n) (p n i x) -
            partitionVertexMidrank (P n) (b n) x) ^ 2) / N n ≤
        (2 * (∑ i : ι n,
          ((partitionWordCrossing (P n) (p n i)).card : ℝ)) +
         2 * (∑ i : ι n,
          ((rankDecreasingVertices Finset.univ (b n) (p n i)).card : ℝ))) /
            N n := hdiv
      _ = 2 * ((∑ i : ι n,
          ((partitionWordCrossing (P n) (p n i)).card : ℝ)) / N n) +
        2 * ((∑ i : ι n,
          ((rankDecreasingVertices Finset.univ (b n) (p n i)).card : ℝ)) /
            N n) := by ring
  have hlimit : Tendsto
      (fun n =>
        2 * ((∑ i : ι n,
          ((partitionWordCrossing (P n) (p n i)).card : ℝ)) / N n) +
        2 * ((∑ i : ι n,
          ((rankDecreasingVertices Finset.univ (b n) (p n i)).card : ℝ)) /
            N n))
      atTop (nhds 0) := by
    simpa using
      (Filter.Tendsto.const_mul (2 : ℝ) hcross).add
        (Filter.Tendsto.const_mul (2 : ℝ) hrank)
  exact squeeze_zero'
    (Filter.Eventually.of_forall hnonnegative)
    (Filter.Eventually.of_forall hupper)
    hlimit

end MidrankPermutationEnergy

namespace RankArcCharging

open scoped BigOperators

def selectedRankSupport
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (b : V → ℤ) (j : Finset V → ℤ) : Finset V :=
  P.parts.biUnion (fun C => C.filter (fun x => b x = j C))

def rankChangingArc
    {V : Type*}
    (U : Finset V) (b : V → ℤ) (w : Equiv.Perm V) : Finset V :=
  U.filter (fun x => b (w x) ≠ b x)

def rankSupportPreimageBad
    {V : Type*} [DecidableEq V]
    (U S : Finset V) (w : Equiv.Perm V) : Finset V :=
  U.filter (fun x => w x ∈ U \ S)

theorem selectedRankSupport_subset
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (b : V → ℤ) (j : Finset V → ℤ) :
    selectedRankSupport P b j ⊆ U := by
  intro x hx
  obtain ⟨C, hC, hxC⟩ := Finset.mem_biUnion.mp hx
  exact P.subset hC (Finset.mem_filter.mp hxC).1

theorem selectedRankSupport_card
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (b : V → ℤ) (j : Finset V → ℤ) :
    (selectedRankSupport P b j).card =
      ∑ C ∈ P.parts, (C.filter fun x => b x = j C).card := by
  unfold selectedRankSupport
  apply Finset.card_biUnion
  intro C hC D hD hne
  exact (P.disjoint hC hD hne).mono
    (Finset.filter_subset _ _) (Finset.filter_subset _ _)

theorem card_sdiff_selectedRankSupport
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (b : V → ℤ) (j : Finset V → ℤ) :
    (U \ selectedRankSupport P b j).card =
      ∑ C ∈ P.parts,
        (C.card - (C.filter fun x => b x = j C).card) := by
  rw [Finset.card_sdiff_of_subset (selectedRankSupport_subset P b j),
    selectedRankSupport_card]
  rw [Finset.sum_tsub_distrib]
  · rw [P.sum_card_parts]
  · intro C hC
    exact Finset.card_le_card (Finset.filter_subset _ _)

theorem selectedRankSupport_rank_eq
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (b : V → ℤ) (j : Finset V → ℤ)
    {x : V} (hx : x ∈ selectedRankSupport P b j) :
    b x = j (P.part x) := by
  obtain ⟨C, hC, hxC⟩ := Finset.mem_biUnion.mp hx
  obtain ⟨hxmem, hxrank⟩ := Finset.mem_filter.mp hxC
  have hpart : P.part x = C := P.part_eq_of_mem hC hxmem
  simpa [hpart] using hxrank

theorem rankSupportPreimageBad_card_le
    {V : Type*} [DecidableEq V]
    (U S : Finset V) (w : Equiv.Perm V) :
    (rankSupportPreimageBad U S w).card ≤ (U \ S).card := by
  apply Finset.card_le_card_of_injOn w
  · intro x hx
    exact (Finset.mem_filter.mp hx).2
  · intro x hx y hy hxy
    exact w.injective hxy

theorem rankChangingArc_subset_crossing_or_unselected
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (b : V → ℤ) (j : Finset V → ℤ)
    (w : Equiv.Perm V) :
    rankChangingArc U b w ⊆
      partitionWordCrossing P w ∪
        (U \ selectedRankSupport P b j) ∪
          rankSupportPreimageBad U (selectedRankSupport P b j) w := by
  intro x hx
  obtain ⟨hxU, hxchange⟩ := Finset.mem_filter.mp hx
  by_cases hxselected : x ∈ selectedRankSupport P b j
  · by_cases hcross : w x ∈ P.part x
    · by_cases hwselected : w x ∈ selectedRankSupport P b j
      · exfalso
        apply hxchange
        have hpart : P.part (w x) = P.part x :=
          P.part_eq_of_mem (P.part_mem.mpr hxU) hcross
        rw [selectedRankSupport_rank_eq P b j hwselected,
          selectedRankSupport_rank_eq P b j hxselected, hpart]
      · have hwU : w x ∈ U := P.part_subset x hcross
        exact Finset.mem_union_right _
          (Finset.mem_filter.mpr
            ⟨hxU, Finset.mem_sdiff.mpr ⟨hwU, hwselected⟩⟩)
    · exact Finset.mem_union_left _
        (Finset.mem_union_left _
          (Finset.mem_filter.mpr ⟨hxU, hcross⟩))
  · exact Finset.mem_union_left _
      (Finset.mem_union_right _
        (Finset.mem_sdiff.mpr ⟨hxU, hxselected⟩))

theorem rankChangingArc_card_le_crossing_add_unselected
    {V : Type*} [DecidableEq V] {U : Finset V}
    (P : Finpartition U) (b : V → ℤ) (j : Finset V → ℤ)
    (w : Equiv.Perm V) :
    (rankChangingArc U b w).card ≤
      (partitionWordCrossing P w).card +
        2 * (U \ selectedRankSupport P b j).card := by
  have hsubset := Finset.card_le_card
    (rankChangingArc_subset_crossing_or_unselected P b j w)
  have hfirst := Finset.card_union_le
    (partitionWordCrossing P w) (U \ selectedRankSupport P b j)
  have hsecond := Finset.card_union_le
    (partitionWordCrossing P w ∪ (U \ selectedRankSupport P b j))
    (rankSupportPreimageBad U (selectedRankSupport P b j) w)
  have hpre := rankSupportPreimageBad_card_le
    U (selectedRankSupport P b j) w
  omega

theorem rankChangingArc_density_tendsto_zero
    (V : ℕ → Type*) [∀ n, DecidableEq (V n)]
    (U : ∀ n, Finset (V n))
    (P : ∀ n, Finpartition (U n))
    (b : ∀ n, V n → ℤ)
    (j : ∀ n, Finset (V n) → ℤ)
    (w : ∀ n, Equiv.Perm (V n))
    (N : ℕ → ℝ) (hN : ∀ n, 0 < N n)
    (hcross : Filter.Tendsto
      (fun n => ((partitionWordCrossing (P n) (w n)).card : ℝ) / N n)
      Filter.atTop (nhds 0))
    (homit : Filter.Tendsto
      (fun n =>
        (((U n \ selectedRankSupport (P n) (b n) (j n)).card : ℝ) /
          N n))
      Filter.atTop (nhds 0)) :
    Filter.Tendsto
      (fun n => ((rankChangingArc (U n) (b n) (w n)).card : ℝ) / N n)
      Filter.atTop (nhds 0) := by
  have hnonnegative : ∀ n,
      0 ≤ ((rankChangingArc (U n) (b n) (w n)).card : ℝ) / N n := by
    intro n
    exact div_nonneg (Nat.cast_nonneg _) (hN n).le
  have hupper : ∀ n,
      ((rankChangingArc (U n) (b n) (w n)).card : ℝ) / N n ≤
        ((partitionWordCrossing (P n) (w n)).card : ℝ) / N n +
          2 * (((U n \ selectedRankSupport (P n) (b n) (j n)).card : ℝ) /
            N n) := by
    intro n
    have hnat := rankChangingArc_card_le_crossing_add_unselected
      (P n) (b n) (j n) (w n)
    have hreal :
        ((rankChangingArc (U n) (b n) (w n)).card : ℝ) ≤
          ((partitionWordCrossing (P n) (w n)).card : ℝ) +
            2 * ((U n \ selectedRankSupport (P n) (b n) (j n)).card : ℝ) := by
      exact_mod_cast hnat
    calc
      ((rankChangingArc (U n) (b n) (w n)).card : ℝ) / N n ≤
          (((partitionWordCrossing (P n) (w n)).card : ℝ) +
            2 * ((U n \ selectedRankSupport (P n) (b n) (j n)).card : ℝ)) /
              N n :=
        div_le_div_of_nonneg_right hreal (hN n).le
      _ = ((partitionWordCrossing (P n) (w n)).card : ℝ) / N n +
          2 * (((U n \ selectedRankSupport (P n) (b n) (j n)).card : ℝ) /
            N n) := by
        ring
  have hlimit : Filter.Tendsto
      (fun n =>
        ((partitionWordCrossing (P n) (w n)).card : ℝ) / N n +
          2 * (((U n \ selectedRankSupport (P n) (b n) (j n)).card : ℝ) /
            N n))
      Filter.atTop (nhds 0) := by
    simpa using hcross.add (Filter.Tendsto.const_mul (2 : ℝ) homit)
  exact squeeze_zero'
    (Filter.Eventually.of_forall hnonnegative)
    (Filter.Eventually.of_forall hupper)
    hlimit

end RankArcCharging

def permutationDistance {V : Type*} [Fintype V] [DecidableEq V]
    (p q : Equiv.Perm V) : ℕ :=
  hammingDist (fun x => p x) (fun x => q x)

@[simp]
theorem permutationDistance_self {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) : permutationDistance p p = 0 := by
  simp [permutationDistance]

theorem permutationDistance_comm {V : Type*} [Fintype V] [DecidableEq V]
    (p q : Equiv.Perm V) : permutationDistance p q = permutationDistance q p := by
  exact hammingDist_comm _ _

theorem permutationDistance_triangle {V : Type*}
    [Fintype V] [DecidableEq V] (p q r : Equiv.Perm V) :
    permutationDistance p r ≤ permutationDistance p q + permutationDistance q r :=
  hammingDist_triangle _ _ _

theorem permutationDistance_mul_left {V : Type*}
    [Fintype V] [DecidableEq V] (s p q : Equiv.Perm V) :
    permutationDistance (s * p) (s * q) = permutationDistance p q := by
  have h := hammingDist_comp (fun (_ : V) (x : V) => s x)
    (x := fun x => p x) (y := fun x => q x) (fun _ => s.injective)
  simpa [permutationDistance, Equiv.Perm.mul_apply] using h

theorem permutationDistance_mul_right {V : Type*}
    [Fintype V] [DecidableEq V] (s p q : Equiv.Perm V) :
    permutationDistance (p * s) (q * s) = permutationDistance p q := by
  unfold permutationDistance hammingDist
  apply Finset.card_bij (fun x _ => s x)
  · intro x hx
    apply Finset.mem_filter.mpr
    refine ⟨Finset.mem_univ _, ?_⟩
    simpa only [Equiv.Perm.mul_apply] using (Finset.mem_filter.mp hx).2
  · intro x hx y hy h
    exact s.injective h
  · intro y hy
    refine ⟨s.symm y, ?_, by simp⟩
    apply Finset.mem_filter.mpr
    refine ⟨Finset.mem_univ _, ?_⟩
    simpa only [Equiv.Perm.mul_apply, Equiv.apply_symm_apply] using
      (Finset.mem_filter.mp hy).2

theorem permutationDistance_mul_le {V : Type*}
    [Fintype V] [DecidableEq V] (p p' q q' : Equiv.Perm V) :
    permutationDistance (p * q) (p' * q') ≤
      permutationDistance p p' + permutationDistance q q' := by
  calc
    permutationDistance (p * q) (p' * q') ≤
        permutationDistance (p * q) (p' * q) +
          permutationDistance (p' * q) (p' * q') :=
      permutationDistance_triangle _ _ _
    _ = permutationDistance p p' + permutationDistance q q' := by
      rw [permutationDistance_mul_right, permutationDistance_mul_left]

theorem permutationDistance_inv {V : Type*}
    [Fintype V] [DecidableEq V] (p q : Equiv.Perm V) :
    permutationDistance p⁻¹ q⁻¹ = permutationDistance p q := by
  calc
    permutationDistance p⁻¹ q⁻¹ =
        permutationDistance (q * p⁻¹) (q * q⁻¹) :=
      (permutationDistance_mul_left q p⁻¹ q⁻¹).symm
    _ = permutationDistance (q * p⁻¹) 1 := by simp
    _ = permutationDistance ((q * p⁻¹) * p) (1 * p) :=
      (permutationDistance_mul_right p (q * p⁻¹) 1).symm
    _ = permutationDistance q p := by simp
    _ = permutationDistance p q := permutationDistance_comm q p

@[simp]
theorem permutationCommutationDefect_one {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) :
    permutationCommutationDefect σ 1 = 0 := by
  simp [permutationCommutationDefect]

theorem permutationCommutationDefect_inv {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (c : Equiv.Perm V) :
    permutationCommutationDefect σ c⁻¹ = permutationCommutationDefect σ c := by
  classical
  unfold permutationCommutationDefect
  apply Finset.sum_congr rfl
  intro i _
  apply Finset.card_bij (fun x _ => c⁻¹ x)
  · intro x hx
    have hbad := (Finset.mem_filter.mp hx).2
    apply Finset.mem_filter.mpr
    refine ⟨Finset.mem_univ _, ?_⟩
    intro heq
    apply hbad
    apply c.injective
    simpa using heq.symm
  · intro x hx y hy heq
    exact (c⁻¹).injective heq
  · intro y hy
    have hbad := (Finset.mem_filter.mp hy).2
    refine ⟨c y, ?_, by simp⟩
    apply Finset.mem_filter.mpr
    refine ⟨Finset.mem_univ _, ?_⟩
    intro heq
    apply hbad
    have heq' := congrArg c heq
    simpa using heq'.symm

theorem permutationCommutationDefect_mul_le {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (p q : Equiv.Perm V) :
    permutationCommutationDefect σ (p * q) ≤
      permutationCommutationDefect σ p + permutationCommutationDefect σ q := by
  classical
  unfold permutationCommutationDefect
  rw [← Finset.sum_add_distrib]
  apply Finset.sum_le_sum
  intro i _
  let Bp : Finset V :=
    Finset.univ.filter fun x => p (σ i x) ≠ σ i (p x)
  let Bq : Finset V :=
    Finset.univ.filter fun x => q (σ i x) ≠ σ i (q x)
  let C : Finset V :=
    Finset.univ.filter fun x => q x ∈ Bp
  have hC : C.card = Bp.card := by
    apply Finset.card_bij (fun x _ => q x)
    · intro x hx
      exact (Finset.mem_filter.mp hx).2
    · intro x hx y hy hxy
      exact q.injective hxy
    · intro y hy
      refine ⟨q.symm y, ?_, by simp⟩
      exact Finset.mem_filter.mpr
        ⟨Finset.mem_univ _, by simpa using hy⟩
  have hsub :
      (Finset.univ.filter fun x =>
        (p * q) (σ i x) ≠ σ i ((p * q) x)) ⊆ Bq ∪ C := by
    intro x hx
    have hbad := (Finset.mem_filter.mp hx).2
    by_cases hq : q (σ i x) = σ i (q x)
    · apply Finset.mem_union_right
      apply Finset.mem_filter.mpr
      refine ⟨Finset.mem_univ _, ?_⟩
      apply Finset.mem_filter.mpr
      refine ⟨Finset.mem_univ _, ?_⟩
      intro hp
      apply hbad
      simpa [Equiv.Perm.mul_apply, hq] using hp
    · apply Finset.mem_union_left
      exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, hq⟩
  calc
    (Finset.univ.filter fun x =>
      (p * q) (σ i x) ≠ σ i ((p * q) x)).card ≤
        (Bq ∪ C).card := Finset.card_le_card hsub
    _ ≤ Bq.card + C.card := Finset.card_union_le Bq C
    _ = Bp.card + Bq.card := by rw [hC, Nat.add_comm]

structure AlmostCentralizerElement {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ) where
  permutation : Equiv.Perm V
  defect_le : permutationCommutationDefect σ permutation ≤ tolerance

@[ext (iff := false)]
theorem AlmostCentralizerElement.ext {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (p q : AlmostCentralizerElement σ tolerance)
    (h : p.permutation = q.permutation) : p = q := by
  cases p with
  | mk p hp =>
    cases q with
    | mk q hq =>
      cases h
      rfl

instance almostCentralizerElementFinite {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ) :
    Finite (AlmostCentralizerElement σ tolerance) :=
  Finite.of_injective (fun p => p.permutation)
    (fun p q hpq => AlmostCentralizerElement.ext p q hpq)

structure AlmostCentralizerGap {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ) : Prop where
  dichotomy : ∀ p q : AlmostCentralizerElement σ tolerance,
    5 * permutationDistance p.permutation q.permutation ≤ Fintype.card V ∨
      4 * Fintype.card V <
        5 * permutationDistance p.permutation q.permutation

theorem almostCentralizerGap_of_expansion {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ) (h : ℝ)
    (hpositive : 0 < h)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
          ((Fintype.card V : ℝ) - A.card) ≤ (boundary σ A : ℝ))
    (hsmall : (10 : ℝ) * tolerance < h * Fintype.card V) :
    AlmostCentralizerGap σ tolerance := by
  constructor
  intro p q
  have hdef :
      ((permutationCommutationDefect σ p.permutation +
        permutationCommutationDefect σ q.permutation : ℕ) : ℝ) ≤
          2 * (tolerance : ℝ) := by
    have hnat : permutationCommutationDefect σ p.permutation +
        permutationCommutationDefect σ q.permutation ≤ 2 * tolerance := by
      have hp := p.defect_le
      have hq := q.defect_le
      omega
    exact_mod_cast hnat
  rcases hamming_dichotomy_of_expansion σ h hexp p.permutation q.permutation with
    hnear | hfar
  · left
    by_contra hnot
    have hlarge : Fintype.card V <
        5 * permutationDistance p.permutation q.permutation :=
      Nat.lt_of_not_ge hnot
    have hlarge' : (Fintype.card V : ℝ) <
        5 * (permutationDistance p.permutation q.permutation : ℝ) := by
      exact_mod_cast hlarge
    have hpos : 0 < h *
        (5 * (permutationDistance p.permutation q.permutation : ℝ) -
          Fintype.card V) :=
      mul_pos hpositive (sub_pos.mpr hlarge')
    change h * (permutationDistance p.permutation q.permutation : ℝ) ≤ _
      at hnear
    nlinarith
  · right
    by_contra hnot
    have hlarge :
        5 * permutationDistance p.permutation q.permutation ≤
          4 * Fintype.card V := Nat.le_of_not_gt hnot
    have hlarge' :
        5 * (permutationDistance p.permutation q.permutation : ℝ) ≤
          4 * (Fintype.card V : ℝ) := by
      exact_mod_cast hlarge
    have hpos : 0 ≤ h *
        (4 * (Fintype.card V : ℝ) -
          5 * (permutationDistance p.permutation q.permutation : ℝ)) :=
      mul_nonneg hpositive.le (sub_nonneg.mpr hlarge')
    change h * ((Fintype.card V : ℝ) -
      permutationDistance p.permutation q.permutation) ≤ _ at hfar
    nlinarith

def almostCentralizerSetoid {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ)
    (hgap : AlmostCentralizerGap σ tolerance) :
    Setoid (AlmostCentralizerElement σ tolerance) where
  r p q := 5 * permutationDistance p.permutation q.permutation ≤ Fintype.card V
  iseqv := by
    refine ⟨?_, ?_, ?_⟩
    · intro p
      simp
    · intro p q hpq
      simpa [permutationDistance_comm q.permutation p.permutation] using hpq
    · intro p q r hpq hqr
      rcases hgap.dichotomy p r with hclose | hfar
      · exact hclose
      · have htri := permutationDistance_triangle
          p.permutation q.permutation r.permutation
        omega

abbrev AlmostCentralizerClusters {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ)
    (hgap : AlmostCentralizerGap σ tolerance) :=
  Quotient (almostCentralizerSetoid σ tolerance hgap)

def almostCentralizerCluster {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (hgap : AlmostCentralizerGap σ tolerance)
    (p : AlmostCentralizerElement σ tolerance) :
    AlmostCentralizerClusters σ tolerance hgap :=
  Quotient.mk (almostCentralizerSetoid σ tolerance hgap) p

theorem almostCentralizerCluster_eq_iff {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (hgap : AlmostCentralizerGap σ tolerance)
    (p q : AlmostCentralizerElement σ tolerance) :
    almostCentralizerCluster hgap p = almostCentralizerCluster hgap q ↔
      5 * permutationDistance p.permutation q.permutation ≤ Fintype.card V := by
  exact Quotient.eq

structure AlmostCentralizerRepair {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ) where
  correct : Equiv.Perm V → Equiv.Perm V
  corrected_defect : ∀ p q : AlmostCentralizerElement σ tolerance,
    permutationCommutationDefect σ
      (correct (p.permutation * q.permutation)) ≤ tolerance
  corrected_distance : ∀ p q : AlmostCentralizerElement σ tolerance,
    5 * permutationDistance
      (correct (p.permutation * q.permutation))
      (p.permutation * q.permutation) ≤ Fintype.card V

structure HasAlmostCentralizerImprovement {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ) : Prop where
  improve : ∀ p : Equiv.Perm V,
    permutationCommutationDefect σ p ≤ 2 * tolerance →
      ∃ q : Equiv.Perm V,
        permutationCommutationDefect σ q ≤ tolerance ∧
          5 * permutationDistance q p ≤ Fintype.card V

def almostCentralizerRepairOfImprovement {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (h : HasAlmostCentralizerImprovement σ tolerance) :
    AlmostCentralizerRepair σ tolerance := by
  classical
  let correction : Equiv.Perm V → Equiv.Perm V := fun p =>
    if hp : permutationCommutationDefect σ p ≤ 2 * tolerance then
      (h.improve p hp).choose
    else p
  refine ⟨correction, ?_, ?_⟩
  · intro p q
    have hprod := permutationCommutationDefect_mul_le σ
      p.permutation q.permutation
    have hp := p.defect_le
    have hq := q.defect_le
    have hgood : permutationCommutationDefect σ
        (p.permutation * q.permutation) ≤ 2 * tolerance := by
      omega
    change permutationCommutationDefect σ
      (correction (p.permutation * q.permutation)) ≤ tolerance
    simpa [correction, hgood] using
      (h.improve (p.permutation * q.permutation) hgood).choose_spec.1
  · intro p q
    have hprod := permutationCommutationDefect_mul_le σ
      p.permutation q.permutation
    have hp := p.defect_le
    have hq := q.defect_le
    have hgood : permutationCommutationDefect σ
        (p.permutation * q.permutation) ≤ 2 * tolerance := by
      omega
    change 5 * permutationDistance
      (correction (p.permutation * q.permutation))
      (p.permutation * q.permutation) ≤ Fintype.card V
    simpa [correction, hgood] using
      (h.improve (p.permutation * q.permutation) hgood).choose_spec.2

def correctedAlmostCentralizerProduct {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (R : AlmostCentralizerRepair σ tolerance)
    (p q : AlmostCentralizerElement σ tolerance) :
    AlmostCentralizerElement σ tolerance :=
  ⟨R.correct (p.permutation * q.permutation), R.corrected_defect p q⟩

theorem correctedAlmostCentralizerProduct_congr {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (hgap : AlmostCentralizerGap σ tolerance)
    (R : AlmostCentralizerRepair σ tolerance)
    {p p' q q' : AlmostCentralizerElement σ tolerance}
    (hp : 5 * permutationDistance p.permutation p'.permutation ≤
      Fintype.card V)
    (hq : 5 * permutationDistance q.permutation q'.permutation ≤
      Fintype.card V) :
    5 * permutationDistance
      (correctedAlmostCentralizerProduct R p q).permutation
      (correctedAlmostCentralizerProduct R p' q').permutation ≤
        Fintype.card V := by
  let a := correctedAlmostCentralizerProduct R p q
  let b := correctedAlmostCentralizerProduct R p' q'
  have ha := R.corrected_distance p q
  have hb := R.corrected_distance p' q'
  have hmul := permutationDistance_mul_le
    p.permutation p'.permutation q.permutation q'.permutation
  have htri₁ := permutationDistance_triangle a.permutation
    (p.permutation * q.permutation) b.permutation
  have htri₂ := permutationDistance_triangle
    (p.permutation * q.permutation)
    (p'.permutation * q'.permutation) b.permutation
  have hsym :
      permutationDistance (p'.permutation * q'.permutation) b.permutation =
        permutationDistance b.permutation
          (p'.permutation * q'.permutation) :=
    permutationDistance_comm _ _
  change 5 * permutationDistance a.permutation b.permutation ≤
    Fintype.card V
  rcases hgap.dichotomy a b with hclose | hfar
  · exact hclose
  · change 4 * Fintype.card V <
      5 * permutationDistance a.permutation b.permutation at hfar
    change 5 * permutationDistance a.permutation
      (p.permutation * q.permutation) ≤ Fintype.card V at ha
    change 5 * permutationDistance b.permutation
      (p'.permutation * q'.permutation) ≤ Fintype.card V at hb
    omega

def almostCentralizerClusterMul {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (hgap : AlmostCentralizerGap σ tolerance)
    (R : AlmostCentralizerRepair σ tolerance) :
    AlmostCentralizerClusters σ tolerance hgap →
      AlmostCentralizerClusters σ tolerance hgap →
        AlmostCentralizerClusters σ tolerance hgap :=
  Quotient.map₂ (correctedAlmostCentralizerProduct R)
    (fun _ _ hp _ _ hq =>
      correctedAlmostCentralizerProduct_congr hgap R hp hq)

def almostCentralizerOne {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ) :
    AlmostCentralizerElement σ tolerance :=
  ⟨1, by simp⟩

def almostCentralizerInverse {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (p : AlmostCentralizerElement σ tolerance) :
    AlmostCentralizerElement σ tolerance :=
  ⟨p.permutation⁻¹, by
    rw [permutationCommutationDefect_inv]
    exact p.defect_le⟩

def almostCentralizerClusterInv {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (hgap : AlmostCentralizerGap σ tolerance) :
    AlmostCentralizerClusters σ tolerance hgap →
      AlmostCentralizerClusters σ tolerance hgap :=
  Quotient.map almostCentralizerInverse (by
    intro p q hpq
    change 5 * permutationDistance p.permutation⁻¹ q.permutation⁻¹ ≤
      Fintype.card V
    rwa [permutationDistance_inv])

theorem correctedAlmostCentralizerProduct_assoc {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (hgap : AlmostCentralizerGap σ tolerance)
    (R : AlmostCentralizerRepair σ tolerance)
    (p q r : AlmostCentralizerElement σ tolerance) :
    5 * permutationDistance
      (correctedAlmostCentralizerProduct R
        (correctedAlmostCentralizerProduct R p q) r).permutation
      (correctedAlmostCentralizerProduct R p
        (correctedAlmostCentralizerProduct R q r)).permutation ≤
        Fintype.card V := by
  let a := correctedAlmostCentralizerProduct R p q
  let b := correctedAlmostCentralizerProduct R q r
  let l := correctedAlmostCentralizerProduct R a r
  let t := correctedAlmostCentralizerProduct R p b
  have hl := R.corrected_distance a r
  have ht := R.corrected_distance p b
  have ha := R.corrected_distance p q
  have hb := R.corrected_distance q r
  have ha' :
      5 * permutationDistance
        (a.permutation * r.permutation)
        ((p.permutation * q.permutation) * r.permutation) ≤
          Fintype.card V := by
    rw [permutationDistance_mul_right]
    exact ha
  have hb' :
      5 * permutationDistance
        ((p.permutation * q.permutation) * r.permutation)
        (p.permutation * b.permutation) ≤ Fintype.card V := by
    rw [mul_assoc, permutationDistance_mul_left,
      permutationDistance_comm]
    exact hb
  have ht' :
      5 * permutationDistance
        (p.permutation * b.permutation) t.permutation ≤
          Fintype.card V := by
    rw [permutationDistance_comm]
    exact ht
  have htri₁ := permutationDistance_triangle l.permutation
    (a.permutation * r.permutation) t.permutation
  have htri₂ := permutationDistance_triangle
    (a.permutation * r.permutation)
    ((p.permutation * q.permutation) * r.permutation) t.permutation
  have htri₃ := permutationDistance_triangle
    ((p.permutation * q.permutation) * r.permutation)
    (p.permutation * b.permutation) t.permutation
  change 5 * permutationDistance l.permutation t.permutation ≤
    Fintype.card V
  rcases hgap.dichotomy l t with hclose | hfar
  · exact hclose
  · change 4 * Fintype.card V <
      5 * permutationDistance l.permutation t.permutation at hfar
    change 5 * permutationDistance l.permutation
      (a.permutation * r.permutation) ≤ Fintype.card V at hl
    omega

@[instance_reducible]
def almostCentralizerClusterGroup {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    {σ : ι → Equiv.Perm V} {tolerance : ℕ}
    (hgap : AlmostCentralizerGap σ tolerance)
    (R : AlmostCentralizerRepair σ tolerance) :
    Group (AlmostCentralizerClusters σ tolerance hgap) := by
  letI : One (AlmostCentralizerClusters σ tolerance hgap) :=
    ⟨almostCentralizerCluster hgap (almostCentralizerOne σ tolerance)⟩
  letI : Mul (AlmostCentralizerClusters σ tolerance hgap) :=
    ⟨almostCentralizerClusterMul hgap R⟩
  letI : Inv (AlmostCentralizerClusters σ tolerance hgap) :=
    ⟨almostCentralizerClusterInv hgap⟩
  apply Group.ofLeftAxioms
  · intro x y z
    induction x, y, z using Quotient.inductionOn₃ with
    | _ p q r =>
      apply Quotient.sound
      exact correctedAlmostCentralizerProduct_assoc hgap R p q r
  · intro x
    induction x using Quotient.inductionOn with
    | _ p =>
      apply Quotient.sound
      change 5 * permutationDistance
        (R.correct (1 * p.permutation)) p.permutation ≤ Fintype.card V
      simpa [almostCentralizerOne] using
        R.corrected_distance (almostCentralizerOne σ tolerance) p
  · intro x
    induction x using Quotient.inductionOn with
    | _ p =>
      apply Quotient.sound
      change 5 * permutationDistance
        (R.correct (p.permutation⁻¹ * p.permutation)) 1 ≤ Fintype.card V
      simpa [almostCentralizerInverse] using
        R.corrected_distance (almostCentralizerInverse p) p

structure ExpandingCentralizerFiniteModel (G : Type*) [Group G]
    (F : Finset G) where
  vertices : Type
  [verticesFintype : Fintype vertices]
  [verticesDecidableEq : DecidableEq vertices]
  generatorIndex : Type
  [generatorFintype : Fintype generatorIndex]
  generators : generatorIndex → Equiv.Perm vertices
  tolerance : ℕ
  cheeger : ℝ
  cheeger_positive : 0 < cheeger
  expansion : ∀ A : Finset vertices,
    cheeger * min (A.card : ℝ)
        ((Fintype.card vertices : ℝ) - A.card) ≤
      (boundary generators A : ℝ)
  small : (10 : ℝ) * tolerance < cheeger * Fintype.card vertices
  repair : AlmostCentralizerRepair generators tolerance
  approximation : G → AlmostCentralizerElement generators tolerance
  map_one : (approximation 1).permutation = 1
  multiplicative : ∀ x ∈ F, ∀ y ∈ F,
    5 * permutationDistance (approximation (x * y)).permutation
      ((approximation x).permutation * (approximation y).permutation) ≤
        Fintype.card vertices
  separated : ∀ x ∈ F, ∀ y ∈ F, x ≠ y →
    Fintype.card vertices <
      5 * permutationDistance
        (approximation x).permutation (approximation y).permutation

instance expandingCentralizerFiniteModelVerticesFintype
    {G : Type*} [Group G] {F : Finset G}
    (M : ExpandingCentralizerFiniteModel G F) : Fintype M.vertices :=
  M.verticesFintype

instance expandingCentralizerFiniteModelVerticesDecidableEq
    {G : Type*} [Group G] {F : Finset G}
    (M : ExpandingCentralizerFiniteModel G F) : DecidableEq M.vertices :=
  M.verticesDecidableEq

instance expandingCentralizerFiniteModelGeneratorFintype
    {G : Type*} [Group G] {F : Finset G}
    (M : ExpandingCentralizerFiniteModel G F) : Fintype M.generatorIndex :=
  M.generatorFintype

def expandingCentralizerFiniteModelOfImprovement
    {G : Type*} [Group G] (F : Finset G)
    {V ι : Type} [Fintype V] [DecidableEq V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ) (h : ℝ)
    (hpositive : 0 < h)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤ (boundary σ A : ℝ))
    (hsmall : (10 : ℝ) * tolerance < h * Fintype.card V)
    (himprove : HasAlmostCentralizerImprovement σ tolerance)
    (f : G → AlmostCentralizerElement σ tolerance)
    (hone : (f 1).permutation = 1)
    (hmul : ∀ x ∈ F, ∀ y ∈ F,
      5 * permutationDistance (f (x * y)).permutation
        ((f x).permutation * (f y).permutation) ≤ Fintype.card V)
    (hsep : ∀ x ∈ F, ∀ y ∈ F, x ≠ y →
      Fintype.card V < 5 * permutationDistance
        (f x).permutation (f y).permutation) :
    ExpandingCentralizerFiniteModel G F where
  vertices := V
  verticesFintype := inferInstance
  verticesDecidableEq := inferInstance
  generatorIndex := ι
  generatorFintype := inferInstance
  generators := σ
  tolerance := tolerance
  cheeger := h
  cheeger_positive := hpositive
  expansion := hexp
  small := hsmall
  repair := almostCentralizerRepairOfImprovement himprove
  approximation := f
  map_one := hone
  multiplicative := hmul
  separated := hsep

theorem exists_finite_group_embedding_of_expanding_centralizer
    {G : Type*} [Group G] (F : Finset G)
    (M : ExpandingCentralizerFiniteModel G F) :
    ∃ (H : Type) (_ : Group H) (_ : Finite H) (f : G → H),
      Set.InjOn f (F : Set G) ∧ f 1 = 1 ∧
        ∀ x ∈ F, ∀ y ∈ F, f (x * y) = f x * f y := by
  let hgap : AlmostCentralizerGap M.generators M.tolerance :=
    almostCentralizerGap_of_expansion M.generators M.tolerance M.cheeger
      M.cheeger_positive M.expansion M.small
  let H := AlmostCentralizerClusters M.generators M.tolerance hgap
  letI : Group H := almostCentralizerClusterGroup hgap M.repair
  letI : Finite H := inferInstance
  let f : G → H := fun x => almostCentralizerCluster hgap (M.approximation x)
  refine ⟨H, inferInstance, inferInstance, f, ?_, ?_, ?_⟩
  · intro x hx y hy hxy
    by_contra hne
    have hclose :
        5 * permutationDistance
          (M.approximation x).permutation
          (M.approximation y).permutation ≤ Fintype.card M.vertices :=
      (almostCentralizerCluster_eq_iff hgap
        (M.approximation x) (M.approximation y)).mp hxy
    have hfar := M.separated x hx y hy hne
    omega
  · change almostCentralizerCluster hgap (M.approximation 1) =
      almostCentralizerCluster hgap
        (almostCentralizerOne M.generators M.tolerance)
    apply Quotient.sound
    change 5 * permutationDistance (M.approximation 1).permutation 1 ≤
      Fintype.card M.vertices
    simp [M.map_one]
  · intro x hx y hy
    change almostCentralizerCluster hgap (M.approximation (x * y)) =
      almostCentralizerCluster hgap
        (correctedAlmostCentralizerProduct M.repair
          (M.approximation x) (M.approximation y))
    apply Quotient.sound
    let a := M.approximation (x * y)
    let b := correctedAlmostCentralizerProduct M.repair
      (M.approximation x) (M.approximation y)
    change 5 * permutationDistance a.permutation b.permutation ≤
      Fintype.card M.vertices
    rcases hgap.dichotomy a b with hclose | hfar
    · exact hclose
    · have hmul := M.multiplicative x hx y hy
      have hrepair := M.repair.corrected_distance
        (M.approximation x) (M.approximation y)
      have htri := permutationDistance_triangle a.permutation
        ((M.approximation x).permutation *
          (M.approximation y).permutation) b.permutation
      have hsym :
          permutationDistance
            ((M.approximation x).permutation *
              (M.approximation y).permutation) b.permutation =
            permutationDistance b.permutation
              ((M.approximation x).permutation *
                (M.approximation y).permutation) :=
        permutationDistance_comm _ _
      change 4 * Fintype.card M.vertices <
        5 * permutationDistance a.permutation b.permutation at hfar
      change 5 * permutationDistance a.permutation
        ((M.approximation x).permutation *
          (M.approximation y).permutation) ≤ Fintype.card M.vertices at hmul
      change 5 * permutationDistance b.permutation
        ((M.approximation x).permutation *
          (M.approximation y).permutation) ≤
            Fintype.card M.vertices at hrepair
      omega

theorem exists_permutation_embedding_of_expanding_centralizer
    {G : Type*} [Group G] (F : Finset G)
    (M : ExpandingCentralizerFiniteModel G F) :
    ∃ (n : ℕ) (f : G → Equiv.Perm (Fin n)),
      Set.InjOn f (F : Set G) ∧ f 1 = 1 ∧
        ∀ x ∈ F, ∀ y ∈ F, f (x * y) = f x * f y := by
  obtain ⟨H, hgroup, hfinite, f, hinj, hone, hmul⟩ :=
    exists_finite_group_embedding_of_expanding_centralizer F M
  letI : Group H := hgroup
  letI : Finite H := hfinite
  letI : Fintype H := Fintype.ofFinite H
  let e : H ≃ Fin (Fintype.card H) := Fintype.equivFin H
  let ρ : H →* Equiv.Perm (Fin (Fintype.card H)) :=
    e.permCongrHom.toMonoidHom.comp (MulAction.toPermHom H H)
  have hρ : Function.Injective ρ :=
    e.permCongrHom.injective.comp MulAction.toPerm_injective
  refine ⟨Fintype.card H, fun x => ρ (f x), ?_, ?_, ?_⟩
  · intro x hx y hy hxy
    exact hinj hx hy (hρ hxy)
  · simp [hone]
  · intro x hx y hy
    change ρ (f (x * y)) = ρ (f x) * ρ (f y)
    rw [hmul x hx y hy, map_mul]

theorem lef_of_expanding_centralizer_models {G : Type*} [Group G]
    (hmodels : ∀ F : Finset G,
      Nonempty (ExpandingCentralizerFiniteModel G F)) : LEF G := by
  constructor
  intro F
  obtain ⟨M⟩ := hmodels F
  obtain ⟨n, f, hinj, hone, hmul⟩ :=
    exists_permutation_embedding_of_expanding_centralizer F M
  exact ⟨n, f, hinj, ⟨hone, hmul⟩⟩

theorem exists_positive_antitone_slow_vanishing_threshold
    (e : ℕ → ℝ) (he_nonneg : ∀ n, 0 ≤ e n)
    (he : Tendsto e atTop (nhds 0)) :
    ∃ eta : ℕ → ℝ,
      (∀ n, 0 < eta n) ∧ Antitone eta ∧
      Tendsto eta atTop (nhds 0) ∧
      Tendsto (fun n => e n / eta n) atTop (nhds 0) := by
  have hrange : BddAbove (Set.range e) := he.bddAbove_range
  have htail_bdd (n : ℕ) : BddAbove (e '' Set.Ici n) := by
    apply hrange.mono
    rintro y ⟨k, hk, rfl⟩
    exact ⟨k, rfl⟩
  have htail_ne (n : ℕ) : (e '' Set.Ici n).Nonempty := by
    refine ⟨e n, ?_⟩
    exact ⟨n, Set.mem_Ici.mpr (le_refl n), rfl⟩
  let d : ℕ → ℝ := fun n => sSup (e '' Set.Ici n)
  have hd_dom (n : ℕ) : e n ≤ d n := by
    dsimp [d]
    apply le_csSup (htail_bdd n)
    exact ⟨n, Set.mem_Ici.mpr (le_refl n), rfl⟩
  have hd_nonneg (n : ℕ) : 0 ≤ d n :=
    (he_nonneg n).trans (hd_dom n)
  have hd_antitone : Antitone d := by
    intro a b hab
    change sSup (e '' Set.Ici b) ≤ sSup (e '' Set.Ici a)
    apply csSup_le_csSup (htail_bdd a) (htail_ne b)
    rintro y ⟨k, hk, rfl⟩
    exact ⟨k, Set.mem_Ici.mpr (hab.trans (Set.mem_Ici.mp hk)), rfl⟩
  have hd_zero : Tendsto d atTop (nhds 0) := by
    apply tendsto_order.2
    constructor
    · intro a ha
      exact Eventually.of_forall fun n => lt_of_lt_of_le ha (hd_nonneg n)
    · intro a ha
      have hev : ∀ᶠ k in atTop, e k < a / 2 :=
        he.eventually (gt_mem_nhds (half_pos ha))
      obtain ⟨N, hN⟩ := eventually_atTop.mp hev
      filter_upwards [eventually_ge_atTop N] with n hn
      have hle : d n ≤ a / 2 := by
        dsimp [d]
        apply csSup_le (htail_ne n)
        rintro y ⟨k, hk, rfl⟩
        exact (hN k (hn.trans (Set.mem_Ici.mp hk))).le
      exact hle.trans_lt (half_lt_self ha)
  let q : ℕ → ℝ := fun n => 1 / ((n : ℝ) + 1)
  have hq_pos (n : ℕ) : 0 < q n := by
    dsimp [q]
    positivity
  have hq_antitone : Antitone q := by
    intro a b hab
    dsimp [q]
    apply one_div_le_one_div_of_le (by positivity)
    have hab_real : (a : ℝ) ≤ b := by
      exact_mod_cast hab
    exact add_le_add hab_real (le_refl 1)
  have hq_zero : Tendsto q atTop (nhds 0) := by
    dsimp [q]
    exact tendsto_one_div_add_atTop_nhds_zero_nat
  let eta : ℕ → ℝ := fun n => Real.sqrt (d n + q n)
  have heta_pos (n : ℕ) : 0 < eta n := by
    dsimp [eta]
    apply Real.sqrt_pos.2
    exact lt_of_lt_of_le (hq_pos n) (le_add_of_nonneg_left (hd_nonneg n))
  have heta_antitone : Antitone eta := by
    intro a b hab
    dsimp [eta]
    exact Real.sqrt_le_sqrt (add_le_add (hd_antitone hab) (hq_antitone hab))
  have hsum_zero : Tendsto (fun n => d n + q n) atTop (nhds 0) := by
    simpa using hd_zero.add hq_zero
  have heta_zero : Tendsto eta atTop (nhds 0) := by
    simpa only [eta, Function.comp_def, Real.sqrt_zero] using
      (Real.continuous_sqrt.tendsto (0 : ℝ)).comp hsum_zero
  have hratio_bound (n : ℕ) : e n / eta n ≤ eta n := by
    apply (div_le_iff₀ (heta_pos n)).2
    calc
      e n ≤ d n := hd_dom n
      _ ≤ d n + q n := le_add_of_nonneg_right (hq_pos n).le
      _ = eta n * eta n := by
        dsimp [eta]
        nlinarith [Real.sq_sqrt (add_nonneg (hd_nonneg n) (hq_pos n).le)]
  refine ⟨eta, heta_pos, heta_antitone, heta_zero, ?_⟩
  exact squeeze_zero (fun n => div_nonneg (he_nonneg n) (heta_pos n).le)
    hratio_bound heta_zero

theorem exists_positive_antitone_slow_overlap_scales
    (e : ℕ → ℝ) (he_nonneg : ∀ n, 0 ≤ e n)
    (he : Tendsto e atTop (nhds 0)) :
    ∃ eta H : ℕ → ℝ,
      (∀ n, 0 < eta n) ∧ Antitone eta ∧
      Tendsto eta atTop (nhds 0) ∧
      (∀ n, 0 < H n) ∧ Antitone H ∧
      Tendsto H atTop (nhds 0) ∧
      Tendsto (fun n => e n / eta n) atTop (nhds 0) ∧
      Tendsto (fun n => eta n / H n) atTop (nhds 0) := by
  obtain ⟨eta, heta_pos, heta_antitone, heta_zero, herror_zero⟩ :=
    exists_positive_antitone_slow_vanishing_threshold e he_nonneg he
  let H : ℕ → ℝ := fun n => Real.sqrt (eta n)
  have hH_pos (n : ℕ) : 0 < H n := by
    exact Real.sqrt_pos.2 (heta_pos n)
  have hH_antitone : Antitone H := by
    intro a b hab
    exact Real.sqrt_le_sqrt (heta_antitone hab)
  have hH_zero : Tendsto H atTop (nhds 0) := by
    simpa only [H, Function.comp_def, Real.sqrt_zero] using
      (Real.continuous_sqrt.tendsto (0 : ℝ)).comp heta_zero
  have hquot (n : ℕ) : eta n / H n = H n := by
    dsimp [H]
    apply (div_eq_iff (Real.sqrt_pos.2 (heta_pos n)).ne').2
    nlinarith [Real.sq_sqrt (heta_pos n).le]
  have hquot_zero : Tendsto (fun n => eta n / H n) atTop (nhds 0) := by
    have hfun : (fun n => eta n / H n) = H := funext hquot
    rw [hfun]
    exact hH_zero
  exact ⟨eta, H, heta_pos, heta_antitone, heta_zero,
    hH_pos, hH_antitone, hH_zero, herror_zero, hquot_zero⟩

namespace ExceptionalRankOffset

open Filter Topology
open scoped BigOperators

theorem rankDropCount_goodSubtype_eq
    {ι : Type*}
    (G : Finset ι) (u v : ι → ℝ) (H r : ℝ) :
    SoficGroups.rankDropCount
        (fun i : {i // i ∈ G} => u i.1)
        (fun i : {i // i ∈ G} => v i.1) H r =
      ∑ i ∈ G,
        if ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋ then (1 : ℝ) else 0 := by
  classical
  unfold SoficGroups.rankDropCount
  rw [Finset.univ_eq_attach]
  change
    (∑ i ∈ G.attach,
      if ⌊(v i.1 + r) / H⌋ < ⌊(u i.1 + r) / H⌋ then (1 : ℝ) else 0) =
      ∑ i ∈ G,
        if ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋ then (1 : ℝ) else 0
  exact Finset.sum_attach G
    (fun i : ι =>
      if ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋ then (1 : ℝ) else 0)

theorem rankDropCount_le_goodSubtype_add_exceptions
    {ι : Type*} [Fintype ι] [DecidableEq ι]
    (G : Finset ι) (u v : ι → ℝ) (H r : ℝ) :
    SoficGroups.rankDropCount u v H r ≤
      SoficGroups.rankDropCount
          (fun i : {i // i ∈ G} => u i.1)
          (fun i : {i // i ∈ G} => v i.1) H r +
        (((Finset.univ : Finset ι) \ G).card : ℝ) := by
  classical
  let d : ι → ℝ := fun i =>
    if ⌊(v i + r) / H⌋ < ⌊(u i + r) / H⌋ then 1 else 0
  have hgood :
      SoficGroups.rankDropCount
        (fun i : {i // i ∈ G} => u i.1)
        (fun i : {i // i ∈ G} => v i.1) H r =
        ∑ i ∈ G, d i := by
    exact rankDropCount_goodSubtype_eq G u v H r
  have hfull : SoficGroups.rankDropCount u v H r = ∑ i : ι, d i := by
    rfl
  have hsplit :
      (∑ i ∈ (Finset.univ : Finset ι) \ G, d i) +
        (∑ i ∈ G, d i) = ∑ i : ι, d i :=
    Finset.sum_sdiff (Finset.subset_univ G)
  have hbad :
      (∑ i ∈ (Finset.univ : Finset ι) \ G, d i) ≤
        (((Finset.univ : Finset ι) \ G).card : ℝ) := by
    calc
      (∑ i ∈ (Finset.univ : Finset ι) \ G, d i) ≤
        ∑ _i ∈ (Finset.univ : Finset ι) \ G, (1 : ℝ) := by
          apply Finset.sum_le_sum
          intro i hi
          dsimp [d]
          split_ifs <;> norm_num
      _ = (((Finset.univ : Finset ι) \ G).card : ℝ) := by simp
  rw [hfull, hgood]
  linarith

theorem exists_common_log_rank_offset_except
    {ι : Type*} [Fintype ι] [DecidableEq ι]
    (G : Finset ι) (x y : ι → ℝ) (eta H : ℝ)
    (hx : ∀ i ∈ G, 0 < x i)
    (heta0 : 0 ≤ eta) (heta1 : eta < 1) (hH : 0 < H)
    (hcomparison : ∀ i ∈ G, (1 - eta) * x i ≤ y i) :
    ∃ r ∈ Set.Ico 0 H,
      SoficGroups.rankDropCount
          (fun i => Real.log (x i))
          (fun i => Real.log (y i)) H r ≤
        (G.card : ℝ) * |Real.log (1 - eta)| / H +
          (((Finset.univ : Finset ι) \ G).card : ℝ) := by
  obtain ⟨r, hr, hbound⟩ := SoficGroups.exists_common_log_rank_offset
    (fun i : {i // i ∈ G} => x i.1)
    (fun i : {i // i ∈ G} => y i.1)
    eta H
    (fun i => hx i.1 i.2)
    heta0 heta1 hH
    (fun i => hcomparison i.1 i.2)
  have hbound' :
      SoficGroups.rankDropCount
        (fun i : {i // i ∈ G} => Real.log (x i.1))
        (fun i : {i // i ∈ G} => Real.log (y i.1)) H r ≤
          (G.card : ℝ) * |Real.log (1 - eta)| / H := by
    simpa only [Fintype.card_coe] using hbound
  refine ⟨r, hr, ?_⟩
  calc
    SoficGroups.rankDropCount
        (fun i => Real.log (x i))
        (fun i => Real.log (y i)) H r ≤
      SoficGroups.rankDropCount
          (fun i : {i // i ∈ G} => Real.log (x i.1))
          (fun i : {i // i ∈ G} => Real.log (y i.1)) H r +
        (((Finset.univ : Finset ι) \ G).card : ℝ) :=
        rankDropCount_le_goodSubtype_add_exceptions G
          (fun i => Real.log (x i)) (fun i => Real.log (y i)) H r
    _ ≤ (G.card : ℝ) * |Real.log (1 - eta)| / H +
        (((Finset.univ : Finset ι) \ G).card : ℝ) :=
        add_le_add hbound' (le_refl _)

theorem exists_common_log_rank_offsets_tendsto_zero_except
    (ι : ℕ → Type*)
    [∀ n, Fintype (ι n)] [∀ n, DecidableEq (ι n)]
    (G : (n : ℕ) → Finset (ι n))
    (x y : (n : ℕ) → ι n → ℝ)
    (eta H N : ℕ → ℝ) (C : ℝ)
    (hx : ∀ n i, i ∈ G n → 0 < x n i)
    (heta0 : ∀ n, 0 ≤ eta n)
    (heta1 : ∀ n, eta n < 1)
    (hH : ∀ n, 0 < H n)
    (hN : ∀ n, 0 < N n)
    (hcard : ∀ n, ((G n).card : ℝ) ≤ C * N n)
    (hcomparison : ∀ n i, i ∈ G n →
      (1 - eta n) * x n i ≤ y n i)
    (heta : Tendsto eta atTop (nhds 0))
    (hratio : Tendsto (fun n => eta n / H n) atTop (nhds 0))
    (hexceptions : Tendsto
      (fun n =>
        (((Finset.univ : Finset (ι n)) \ G n).card : ℝ) / N n)
      atTop (nhds 0)) :
    ∃ r : ℕ → ℝ,
      (∀ n, r n ∈ Set.Ico 0 (H n)) ∧
        Tendsto
          (fun n =>
            SoficGroups.rankDropCount
              (fun i => Real.log (x n i))
              (fun i => Real.log (y n i)) (H n) (r n) / N n)
          atTop (nhds 0) := by
  have hwitness : ∀ n, ∃ r ∈ Set.Ico 0 (H n),
      SoficGroups.rankDropCount
          (fun i => Real.log (x n i))
          (fun i => Real.log (y n i)) (H n) r ≤
        ((G n).card : ℝ) * |Real.log (1 - eta n)| / H n +
          (((Finset.univ : Finset (ι n)) \ G n).card : ℝ) := by
    intro n
    exact exists_common_log_rank_offset_except
      (G n) (x n) (y n) (eta n) (H n)
      (hx n) (heta0 n) (heta1 n) (hH n) (hcomparison n)
  choose r hr hbound using hwitness
  refine ⟨r, hr, ?_⟩
  have hlog := SoficGroups.abs_log_one_sub_div_tendsto_zero
    eta H heta0 hH heta hratio
  have hscaled : Tendsto
      (fun n => C * (|Real.log (1 - eta n)| / H n))
      atTop (nhds 0) := by
    simpa using Filter.Tendsto.const_mul C hlog
  have hlimit : Tendsto
      (fun n =>
        C * (|Real.log (1 - eta n)| / H n) +
          (((Finset.univ : Finset (ι n)) \ G n).card : ℝ) / N n)
      atTop (nhds 0) := by
    simpa only [add_zero] using hscaled.add hexceptions
  have hnonnegative : ∀ n,
      0 ≤ SoficGroups.rankDropCount
        (fun i => Real.log (x n i))
        (fun i => Real.log (y n i)) (H n) (r n) / N n := by
    intro n
    exact div_nonneg
      (SoficGroups.rankDropCount_nonneg_and_le
        (fun i => Real.log (x n i))
        (fun i => Real.log (y n i)) (H n) (r n)).1
      (hN n).le
  have hupper : ∀ n,
      SoficGroups.rankDropCount
          (fun i => Real.log (x n i))
          (fun i => Real.log (y n i)) (H n) (r n) / N n ≤
        C * (|Real.log (1 - eta n)| / H n) +
          (((Finset.univ : Finset (ι n)) \ G n).card : ℝ) / N n := by
    intro n
    calc
      SoficGroups.rankDropCount
          (fun i => Real.log (x n i))
          (fun i => Real.log (y n i)) (H n) (r n) / N n ≤
        (((G n).card : ℝ) * |Real.log (1 - eta n)| / H n +
          (((Finset.univ : Finset (ι n)) \ G n).card : ℝ)) / N n :=
          (div_le_div_iff_of_pos_right (hN n)).2 (hbound n)
      _ = (((G n).card : ℝ) / N n) *
            (|Real.log (1 - eta n)| / H n) +
          (((Finset.univ : Finset (ι n)) \ G n).card : ℝ) / N n := by
            ring
      _ ≤ C * (|Real.log (1 - eta n)| / H n) +
          (((Finset.univ : Finset (ι n)) \ G n).card : ℝ) / N n := by
            apply add_le_add
            · apply mul_le_mul_of_nonneg_right
                ((div_le_iff₀ (hN n)).2 (hcard n))
              exact div_nonneg (abs_nonneg _) (hH n).le
            · exact le_refl _
  exact squeeze_zero'
    (Filter.Eventually.of_forall hnonnegative)
    (Filter.Eventually.of_forall hupper)
    hlimit

end ExceptionalRankOffset

namespace ThompsonPrefixInsertion

theorem cylinderSwap_mul_wordS_right
    (a b : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a) :
    (↑(cylinderSwap a b hab hba) : BinaryLeavitt) *
        leavittWordS b = leavittWordS a := by
  change
    PrefixCompression.transpositionValue
        (leavittWordS a) (leavittWordT a)
        (leavittWordS b) (leavittWordT b) *
      leavittWordS b = leavittWordS a
  simp [PrefixCompression.transpositionValue, sub_mul, add_mul, mul_assoc,
    leavittWordT_mul_wordS_self,
    leavittWordT_mul_wordS_of_incomparable a b hab hba]

end ThompsonPrefixInsertion

universe u₁ u₂ u₃

section ElementaryRingQuotient

variable {ι : Type u₁} {R : Type u₂} {S : Type u₃}
  [Fintype ι] [DecidableEq ι]
  [Ring R] [Ring S]

def elementaryMatrixUnitMap (f : R →+* S) :
    (Matrix ι ι R)ˣ →* (Matrix ι ι S)ˣ :=
  Units.map f.mapMatrix.toMonoidHom

theorem elementaryMatrixUnitMap_elementaryUnit
    (f : R →+* S) (i j : ι) (hij : i ≠ j) (a : R) :
    elementaryMatrixUnitMap f (elementaryUnit i j hij a) =
      elementaryUnit i j hij (f a) := by
  apply Units.ext
  change f.mapMatrix (1 + Matrix.single i j a) =
    1 + Matrix.single i j (f a)
  rw [map_add, map_one]
  congr 1
  ext k l
  change f (if i = k ∧ j = l then a else 0) =
    if i = k ∧ j = l then f a else 0
  split_ifs <;> simp

theorem elementaryGroup_map_le (f : R →+* S) :
    (elementaryGroup ι R).map (elementaryMatrixUnitMap f) ≤
      elementaryGroup ι S := by
  rw [Subgroup.map_le_iff_le_comap, elementaryGroup, Subgroup.closure_le]
  rintro _ ⟨i, j, hij, a, rfl⟩
  change elementaryMatrixUnitMap f (elementaryUnit i j hij a) ∈
    elementaryGroup ι S
  rw [elementaryMatrixUnitMap_elementaryUnit]
  exact elementaryUnit_mem i j hij (f a)

theorem elementaryGroup_map_eq_of_surjective
    (f : R →+* S) (hf : Function.Surjective f) :
    (elementaryGroup ι R).map (elementaryMatrixUnitMap f) =
      elementaryGroup ι S := by
  apply le_antisymm (elementaryGroup_map_le f)
  rw [elementaryGroup, Subgroup.closure_le]
  rintro _ ⟨i, j, hij, b, rfl⟩
  obtain ⟨a, rfl⟩ := hf b
  refine ⟨elementaryUnit i j hij a,
    elementaryUnit_mem i j hij a, ?_⟩
  exact elementaryMatrixUnitMap_elementaryUnit f i j hij a

end ElementaryRingQuotient

def binaryPrefixElementaryGroupEquiv
    {ι : Type u} [Fintype ι] [DecidableEq ι]
    (E : BinaryPrefixCode ι) :
    elementaryGroup ι BinaryLeavitt ≃* prefixElementaryGroup E :=
  ((elementaryGroup ι BinaryLeavitt).equivMapOfInjective
      (prefixCornerUnitHom E) (prefixCornerUnitHom_injective E)).trans
    (MulEquiv.subgroupCongr (prefixCornerElementaryGroup_map E))

namespace CompressionCriterion

open Filter Topology

theorem normalizedHamming_distinct_tendsto
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    {g h : G} (hne : g ≠ h) :
    Tendsto
      (fun n => SoficGroups.normalizedHamming
        ((A.model n).action g) ((A.model n).action h))
      atTop (𝓝 1) := by
  have hdifference : g * h⁻¹ ≠ 1 := by
    intro he
    apply hne
    have := congrArg (fun x : G => x * h) he
    simpa using this
  have hseparation := A.separated (g * h⁻¹) hdifference
  have hmultiplication := A.multiplicative (g * h⁻¹) h
  have hlower (n : ℕ) :
      SoficGroups.normalizedHamming
        ((A.model n).action (g * h⁻¹)) 1 -
          SoficGroups.normalizedHamming
            ((A.model n).action ((g * h⁻¹) * h))
            ((A.model n).action (g * h⁻¹) *
              (A.model n).action h) ≤
        SoficGroups.normalizedHamming
          ((A.model n).action g) ((A.model n).action h) := by
    have htriangle := SoficGroups.normalizedHamming_triangle
      ((A.model n).action (g * h⁻¹) * (A.model n).action h)
      ((A.model n).action g)
      ((A.model n).action h)
    have hright := SoficGroups.normalizedHamming_mul_right
      ((A.model n).action h) ((A.model n).action (g * h⁻¹)) 1
    have hsym := SoficGroups.normalizedHamming_comm
      ((A.model n).action g)
      ((A.model n).action (g * h⁻¹) * (A.model n).action h)
    have hword : (g * h⁻¹) * h = g := by simp
    rw [hword] at *
    simp only [one_mul] at hright
    linarith
  apply tendsto_of_tendsto_of_tendsto_of_le_of_le
    (show Tendsto
      (fun n => SoficGroups.normalizedHamming
        ((A.model n).action (g * h⁻¹)) 1 -
          SoficGroups.normalizedHamming
            ((A.model n).action ((g * h⁻¹) * h))
            ((A.model n).action (g * h⁻¹) * (A.model n).action h))
      atTop (𝓝 1) by
        simpa using hseparation.sub hmultiplication)
    tendsto_const_nhds
  · exact hlower
  · intro n
    exact SoficGroups.normalizedHamming_le_one _ _

def productTrackedTable {J : Type*} [Group J]
    (F : Finset J) : Finset J := by
  classical
  exact SoficGroups.multiplicationTable (insert 1 F)

theorem one_mem_productTrackedTable {J : Type*} [Group J]
    (F : Finset J) : 1 ∈ productTrackedTable F := by
  classical
  exact SoficGroups.mem_multiplicationTable_of_mem
    (Finset.mem_insert_self 1 F)

theorem mem_productTrackedTable {J : Type*} [Group J]
    {F : Finset J} {j : J} (hj : j ∈ F) :
    j ∈ productTrackedTable F := by
  classical
  exact SoficGroups.mem_multiplicationTable_of_mem
    (Finset.mem_insert_of_mem hj)

theorem mul_mem_productTrackedTable {J : Type*} [Group J]
    {F : Finset J} {x y : J} (hx : x ∈ F) (hy : y ∈ F) :
    x * y ∈ productTrackedTable F := by
  classical
  exact SoficGroups.mul_mem_multiplicationTable
    (Finset.mem_insert_of_mem hx) (Finset.mem_insert_of_mem hy)

end CompressionCriterion

def permutationGraph {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) : Finset (V × V) :=
  Finset.univ.image fun x => (x, p x)

theorem mem_permutationGraph {V : Type*}
    [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (x y : V) :
    (x, y) ∈ permutationGraph p ↔ y = p x := by
  simp [permutationGraph, eq_comm]

theorem boundary_permutationGraph_eq_commutationDefect
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (p : Equiv.Perm V) :
    boundary (fun i => (σ i).prodCongr (σ i)) (permutationGraph p) =
      permutationCommutationDefect σ p := by
  classical
  unfold boundary permutationCommutationDefect
  apply Finset.sum_congr rfl
  intro i _
  apply Finset.card_bij (fun z _ => z.1)
  · intro z hz
    obtain ⟨hzgraph, hzbad⟩ := Finset.mem_filter.mp hz
    have hzsecond : z.2 = p z.1 :=
      (mem_permutationGraph p z.1 z.2).mp hzgraph
    apply Finset.mem_filter.mpr
    refine ⟨Finset.mem_univ _, ?_⟩
    intro hcommute
    apply hzbad
    apply (mem_permutationGraph p (σ i z.1) (σ i z.2)).mpr
    simpa [hzsecond] using hcommute.symm
  · intro z hz w hw hfirst
    obtain ⟨hzgraph, _⟩ := Finset.mem_filter.mp hz
    obtain ⟨hwgraph, _⟩ := Finset.mem_filter.mp hw
    have hzsecond := (mem_permutationGraph p z.1 z.2).mp hzgraph
    have hwsecond := (mem_permutationGraph p w.1 w.2).mp hwgraph
    apply Prod.ext hfirst
    simpa [hzsecond, hwsecond] using congrArg p hfirst
  · intro x hx
    obtain ⟨_, hbad⟩ := Finset.mem_filter.mp hx
    refine ⟨(x, p x), ?_, rfl⟩
    apply Finset.mem_filter.mpr
    refine ⟨(mem_permutationGraph p x (p x)).mpr rfl, ?_⟩
    intro hgraph
    have hcommute :=
      (mem_permutationGraph p (σ i x) (σ i (p x))).mp hgraph
    exact hbad hcommute.symm

theorem kazhdan_generator_displacement
    {G : Type u} {H : Type v} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] [CompleteSpace H]
    (P : KazhdanPair.{u, v} G)
    (π : UnitaryRepresentation G H)
    (hfixed : ∀ η : H, (∀ g : G, π g η = η) → η = 0)
    (ξ : H) (hξ : ξ ≠ 0) :
    ∃ g ∈ P.generators,
      P.kazhdanConstant * ‖ξ‖ ≤ ‖π g ξ - ξ‖ := by
  classical
  by_contra h
  push Not at h
  have hnorm : 0 < ‖ξ‖ := norm_pos_iff.mpr hξ
  let z : ℂ := (‖ξ‖ : ℂ)⁻¹
  let ζ : H := z • ξ
  have hζ : ‖ζ‖ = 1 := by
    dsimp [ζ, z]
    rw [norm_smul, norm_inv, Complex.norm_real, Real.norm_eq_abs,
      abs_of_pos hnorm]
    exact inv_mul_cancel₀ (ne_of_gt hnorm)
  have hζsmall : ∀ g ∈ P.generators,
      ‖π g ζ - ζ‖ < P.kazhdanConstant := by
    intro g hg
    have hscale :
        ‖π g ζ - ζ‖ = ‖ξ‖⁻¹ * ‖π g ξ - ξ‖ := by
      dsimp [ζ, z]
      rw [map_smul, ← smul_sub, norm_smul, norm_inv, Complex.norm_real,
        Real.norm_eq_abs, abs_of_pos hnorm]
    rw [hscale]
    calc
      ‖ξ‖⁻¹ * ‖π g ξ - ξ‖ <
          ‖ξ‖⁻¹ * (P.kazhdanConstant * ‖ξ‖) :=
        mul_lt_mul_of_pos_left (h g hg) (inv_pos.mpr hnorm)
      _ = P.kazhdanConstant := by
        field_simp
  obtain ⟨η, hη, hηfixed⟩ := P.invariant H π ζ hζ hζsmall
  exact hη (hfixed η hηfixed)

namespace ThompsonPrefixInsertion

open scoped commutatorElement

structure PrefixWordAction (g : BinaryLeavittˣ)
    (a b : List (Fin 2)) : Prop where
  prefixing : (↑g : BinaryLeavitt) * leavittWordS a = leavittWordS b
  deletion :
    leavittWordT a * (↑(g⁻¹) : BinaryLeavitt) = leavittWordT b

theorem prefixWordAction_append
    {g : BinaryLeavittˣ} {a b : List (Fin 2)}
    (h : PrefixWordAction g a b) (r : List (Fin 2)) :
    PrefixWordAction g (a ++ r) (b ++ r) := by
  constructor
  · rw [leavittWordS_append, leavittWordS_append, ← mul_assoc, h.prefixing]
  · rw [leavittWordT_append, leavittWordT_append, mul_assoc, h.deletion]

theorem prefixWordAction_mul
    {g h : BinaryLeavittˣ} {a b c : List (Fin 2)}
    (hg : PrefixWordAction g b c)
    (hh : PrefixWordAction h a b) :
    PrefixWordAction (g * h) a c := by
  constructor
  · change
      ((g : BinaryLeavitt) * (h : BinaryLeavitt)) *
        leavittWordS a = leavittWordS c
    rw [mul_assoc, hh.prefixing, hg.prefixing]
  · change
      leavittWordT a *
        ((↑(h⁻¹) : BinaryLeavitt) *
          (↑(g⁻¹) : BinaryLeavitt)) = leavittWordT c
    rw [← mul_assoc, hh.deletion, hg.deletion]

theorem cylinderSwap_prefixWordAction_left
    (a b : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a) :
    PrefixWordAction (cylinderSwap a b hab hba) a b := by
  constructor
  · change
      PrefixCompression.transpositionValue
          (leavittWordS a) (leavittWordT a)
          (leavittWordS b) (leavittWordT b) *
        leavittWordS a = leavittWordS b
    simp [PrefixCompression.transpositionValue,
      sub_mul, add_mul, mul_assoc,
      leavittWordT_mul_wordS_self,
      leavittWordT_mul_wordS_of_incomparable b a hba hab]
  · change
      leavittWordT a *
        PrefixCompression.transpositionValue
          (leavittWordS a) (leavittWordT a)
          (leavittWordS b) (leavittWordT b) = leavittWordT b
    have haa : leavittWordT a * leavittWordS a = 1 :=
      leavittWordT_mul_wordS_self a
    have hab' : leavittWordT a * leavittWordS b = 0 :=
      leavittWordT_mul_wordS_of_incomparable a b hab hba
    have haa' (z : BinaryLeavitt) :
        leavittWordT a * (leavittWordS a * z) = z := by
      rw [← mul_assoc, haa, one_mul]
    have hab'' (z : BinaryLeavitt) :
        leavittWordT a * (leavittWordS b * z) = 0 := by
      rw [← mul_assoc, hab', zero_mul]
    unfold PrefixCompression.transpositionValue
    noncomm_ring [haa, hab', haa', hab'']

theorem cylinderSwap_prefixWordAction_right
    (a b : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a) :
    PrefixWordAction (cylinderSwap a b hab hba) b a := by
  constructor
  · exact cylinderSwap_mul_wordS_right a b hab hba
  · change
      leavittWordT b *
        PrefixCompression.transpositionValue
          (leavittWordS a) (leavittWordT a)
          (leavittWordS b) (leavittWordT b) = leavittWordT a
    have hbb : leavittWordT b * leavittWordS b = 1 :=
      leavittWordT_mul_wordS_self b
    have hba' : leavittWordT b * leavittWordS a = 0 :=
      leavittWordT_mul_wordS_of_incomparable b a hba hab
    have hbb' (z : BinaryLeavitt) :
        leavittWordT b * (leavittWordS b * z) = z := by
      rw [← mul_assoc, hbb, one_mul]
    have hba'' (z : BinaryLeavitt) :
        leavittWordT b * (leavittWordS a * z) = 0 := by
      rw [← mul_assoc, hba', zero_mul]
    unfold PrefixCompression.transpositionValue
    noncomm_ring [hbb, hba', hbb', hba'']

theorem cylinderSwap_prefixWordAction_fixed
    (a b w : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a)
    (haw : ¬ a <+: w) (hwa : ¬ w <+: a)
    (hbw : ¬ b <+: w) (hwb : ¬ w <+: b) :
    PrefixWordAction (cylinderSwap a b hab hba) w w := by
  constructor
  · change
      PrefixCompression.transpositionValue
          (leavittWordS a) (leavittWordT a)
          (leavittWordS b) (leavittWordT b) *
        leavittWordS w = leavittWordS w
    simp [PrefixCompression.transpositionValue,
      sub_mul, add_mul, mul_assoc,
      leavittWordT_mul_wordS_of_incomparable a w haw hwa,
      leavittWordT_mul_wordS_of_incomparable b w hbw hwb]
  · change
      leavittWordT w *
        PrefixCompression.transpositionValue
          (leavittWordS a) (leavittWordT a)
          (leavittWordS b) (leavittWordT b) = leavittWordT w
    have hwa' : leavittWordT w * leavittWordS a = 0 :=
      leavittWordT_mul_wordS_of_incomparable w a hwa haw
    have hwb' : leavittWordT w * leavittWordS b = 0 :=
      leavittWordT_mul_wordS_of_incomparable w b hwb hbw
    have hwa'' (z : BinaryLeavitt) :
        leavittWordT w * (leavittWordS a * z) = 0 := by
      rw [← mul_assoc, hwa', zero_mul]
    have hwb'' (z : BinaryLeavitt) :
        leavittWordT w * (leavittWordS b * z) = 0 := by
      rw [← mul_assoc, hwb', zero_mul]
    unfold PrefixCompression.transpositionValue
    noncomm_ring [hwa', hwb', hwa'', hwb'']

theorem prefixInsertionHom_conjugate_of_prefixWordAction
    (g : BinaryLeavittˣ) (a b : List (Fin 2))
    (h : PrefixWordAction g a b) (u : BinaryLeavittˣ) :
    g * prefixInsertionHom a u * g⁻¹ = prefixInsertionHom b u := by
  apply Units.ext
  change
    (g : BinaryLeavitt) *
        (↑(prefixInsertionHom a u) : BinaryLeavitt) *
          (↑(g⁻¹) : BinaryLeavitt) =
      (↑(prefixInsertionHom b u) : BinaryLeavitt)
  rw [prefixInsertionHom_val, prefixInsertionHom_val]
  change
    (g : BinaryLeavitt) *
        (leavittWordS a * (u : BinaryLeavitt) * leavittWordT a +
          (1 - leavittWordS a * leavittWordT a)) *
          (↑(g⁻¹) : BinaryLeavitt) =
      leavittWordS b * (u : BinaryLeavitt) * leavittWordT b +
        (1 - leavittWordS b * leavittWordT b)
  have hunit :
      (g : BinaryLeavitt) * (↑(g⁻¹) : BinaryLeavitt) = 1 :=
    g.val_inv
  calc
    (g : BinaryLeavitt) *
        (leavittWordS a * (u : BinaryLeavitt) * leavittWordT a +
          (1 - leavittWordS a * leavittWordT a)) *
          (↑(g⁻¹) : BinaryLeavitt) =
        ((g : BinaryLeavitt) * leavittWordS a) *
            (u : BinaryLeavitt) *
            (leavittWordT a * (↑(g⁻¹) : BinaryLeavitt)) +
          ((g : BinaryLeavitt) * (↑(g⁻¹) : BinaryLeavitt) -
            ((g : BinaryLeavitt) * leavittWordS a) *
              (leavittWordT a * (↑(g⁻¹) : BinaryLeavitt))) := by
          simp only [CharTwo.sub_eq_add]
          noncomm_ring
    _ = leavittWordS b * (u : BinaryLeavitt) * leavittWordT b +
          (1 - leavittWordS b * leavittWordT b) := by
          rw [h.prefixing, h.deletion, hunit]

theorem prefixInsertionHom_mem_binaryPrefixTranspositionGroup
    (a : List (Fin 2)) (u : BinaryLeavittˣ)
    (hu : u ∈ binaryPrefixTranspositionGroup) :
    prefixInsertionHom a u ∈ binaryPrefixTranspositionGroup := by
  have hle :
      binaryPrefixTranspositionGroup ≤
        binaryPrefixTranspositionGroup.comap (prefixInsertionHom a) := by
    change Subgroup.closure _ ≤ _
    apply (Subgroup.closure_le _).2
    rintro _ ⟨x, y, hxy, hyx, rfl⟩
    change prefixInsertionHom a (cylinderSwap x y hxy hyx) ∈
      binaryPrefixTranspositionGroup
    rw [prefixInsertionHom_cylinderSwap]
    exact Subgroup.subset_closure
      ⟨a ++ x, a ++ y,
        prepend_not_prefix_prepend a x y hxy,
        prepend_not_prefix_prepend a y x hyx, rfl⟩
  exact hle hu

end ThompsonPrefixInsertion

namespace LeavittElementaryMorita

open scoped BigOperators commutatorElement

section ElementaryBlockFlattening

variable {ι κ R : Type*} [Fintype ι] [DecidableEq ι]
  [Fintype κ] [DecidableEq κ] [Ring R]

def elementaryBlockMatrixEquiv :
    Matrix ι ι (Matrix κ κ R) ≃+*
      Matrix (ι × κ) (ι × κ) R :=
  Matrix.compRingEquiv ι κ R

def elementaryBlockUnitEquiv :
    (Matrix ι ι (Matrix κ κ R))ˣ ≃*
      (Matrix (ι × κ) (ι × κ) R)ˣ :=
  Units.mapEquiv (elementaryBlockMatrixEquiv (ι := ι)
    (κ := κ) (R := R)).toMulEquiv

theorem elementaryBlockUnitEquiv_elementaryUnit_single
    (i j : ι) (hij : i ≠ j) (k l : κ) (a : R) :
    elementaryBlockUnitEquiv (ι := ι) (κ := κ) (R := R)
        (elementaryUnit i j hij (Matrix.single k l a)) =
      elementaryUnit (i, k) (j, l)
        (fun h => hij (congrArg Prod.fst h)) a := by
  apply Units.ext
  change
    elementaryBlockMatrixEquiv (ι := ι) (κ := κ) (R := R)
        (1 + Matrix.single i j (Matrix.single k l a)) =
      1 + Matrix.single (i, k) (j, l) a
  rw [map_add, map_one]
  congr 1
  exact Matrix.comp_single_single i j k l a

theorem elementaryBlockUnitEquiv_elementaryUnit_mem
    (i j : ι) (hij : i ≠ j) (A : Matrix κ κ R) :
    elementaryBlockUnitEquiv (ι := ι) (κ := κ) (R := R)
        (elementaryUnit i j hij A) ∈
      elementaryGroup (ι × κ) R := by
  induction A using Matrix.induction_on' with
  | h_zero =>
      simp [elementaryUnit_zero]
  | h_add A B hA hB =>
      rw [← elementaryUnit_mul, map_mul]
      exact (elementaryGroup (ι × κ) R).mul_mem hA hB
  | h_std_basis k l a =>
      rw [elementaryBlockUnitEquiv_elementaryUnit_single i j hij k l a]
      exact elementaryUnit_mem (i, k) (j, l)
        (fun h => hij (congrArg Prod.fst h)) a

theorem elementaryBlockGroup_map [Nontrivial ι] :
    (elementaryGroup ι (Matrix κ κ R)).map
        (elementaryBlockUnitEquiv
          (ι := ι) (κ := κ) (R := R)).toMonoidHom =
      elementaryGroup (ι × κ) R := by
  let B : Subgroup (Matrix (ι × κ) (ι × κ) R)ˣ :=
    (elementaryGroup ι (Matrix κ κ R)).map
      (elementaryBlockUnitEquiv
        (ι := ι) (κ := κ) (R := R)).toMonoidHom
  have hcross (i j : ι) (hij : i ≠ j) (k l : κ) (a : R) :
      elementaryUnit (i, k) (j, l)
          (fun h => hij (congrArg Prod.fst h)) a ∈ B := by
    refine ⟨elementaryUnit i j hij (Matrix.single k l a),
      elementaryUnit_mem i j hij (Matrix.single k l a), ?_⟩
    exact elementaryBlockUnitEquiv_elementaryUnit_single
      i j hij k l a
  change B = elementaryGroup (ι × κ) R
  apply le_antisymm
  · change
      (elementaryGroup ι (Matrix κ κ R)).map
          (elementaryBlockUnitEquiv
            (ι := ι) (κ := κ) (R := R)).toMonoidHom ≤
        elementaryGroup (ι × κ) R
    rw [elementaryGroup, MonoidHom.map_closure,
      Subgroup.closure_le]
    rintro _ ⟨_, ⟨i, j, hij, A, rfl⟩, rfl⟩
    change
      elementaryBlockUnitEquiv (ι := ι) (κ := κ) (R := R)
          (elementaryUnit i j hij A) ∈
        elementaryGroup (ι × κ) R
    exact elementaryBlockUnitEquiv_elementaryUnit_mem
      i j hij A
  · rw [elementaryGroup, Subgroup.closure_le]
    rintro _ ⟨⟨i, k⟩, ⟨j, l⟩, hne, a, rfl⟩
    by_cases hij : i = j
    · subst j
      obtain ⟨j, hji⟩ := exists_ne i
      exact elementaryUnit_mem_of_two_step B
        (i, k) (j, k) (i, l)
        (fun h => hji (congrArg Prod.fst h).symm)
        (fun h => hji (congrArg Prod.fst h))
        hne a
        (hcross i j hji.symm k k a)
        (hcross j i hji k l 1)
    · exact hcross i j hij k l a

def elementaryBlockGroupEquiv [Nontrivial ι] :
    elementaryGroup ι (Matrix κ κ R) ≃*
      elementaryGroup (ι × κ) R :=
  ((elementaryBlockUnitEquiv
      (ι := ι) (κ := κ) (R := R)).subgroupMap
    (elementaryGroup ι (Matrix κ κ R))).trans
    (MulEquiv.subgroupCongr
      (elementaryBlockGroup_map (ι := ι) (κ := κ) (R := R)))

end ElementaryBlockFlattening

section ElementaryReindexing

variable {ι κ R : Type*} [Fintype ι] [DecidableEq ι]
  [Fintype κ] [DecidableEq κ] [Ring R]

def elementaryReindexUnitEquiv (e : ι ≃ κ) :
    (Matrix ι ι R)ˣ ≃* (Matrix κ κ R)ˣ :=
  Units.mapEquiv (Matrix.reindexRingEquiv R e).toMulEquiv

theorem elementaryReindexUnitEquiv_elementaryUnit
    (e : ι ≃ κ) (i j : ι) (hij : i ≠ j) (a : R) :
    elementaryReindexUnitEquiv (R := R) e
        (elementaryUnit i j hij a) =
      elementaryUnit (e i) (e j) (e.injective.ne hij) a := by
  apply Units.ext
  change
    (Matrix.reindexRingEquiv R e)
        (1 + Matrix.single i j a) =
      1 + Matrix.single (e i) (e j) a
  rw [map_add, map_one]
  congr 1
  change
    Matrix.reindex e e (Matrix.single i j a) =
      Matrix.single (e i) (e j) a
  simpa only [Matrix.reindex_apply, Equiv.symm_symm] using
    (Matrix.submatrix_single_equiv e.symm e.symm i j a)

theorem elementaryReindexGroup_map (e : ι ≃ κ) :
    (elementaryGroup ι R).map
        (elementaryReindexUnitEquiv (R := R) e).toMonoidHom =
      elementaryGroup κ R := by
  apply le_antisymm
  · rw [elementaryGroup, MonoidHom.map_closure,
      Subgroup.closure_le]
    rintro _ ⟨_, ⟨i, j, hij, a, rfl⟩, rfl⟩
    change
      elementaryReindexUnitEquiv (R := R) e
          (elementaryUnit i j hij a) ∈ elementaryGroup κ R
    rw [elementaryReindexUnitEquiv_elementaryUnit]
    exact elementaryUnit_mem (e i) (e j) (e.injective.ne hij) a
  · rw [elementaryGroup, Subgroup.closure_le]
    rintro _ ⟨k, l, hkl, a, rfl⟩
    have hij : e.symm k ≠ e.symm l := e.symm.injective.ne hkl
    refine ⟨elementaryUnit (e.symm k) (e.symm l) hij a,
      elementaryUnit_mem (e.symm k) (e.symm l) hij a, ?_⟩
    simpa using elementaryReindexUnitEquiv_elementaryUnit
      e (e.symm k) (e.symm l) hij a

def elementaryReindexGroupEquiv (e : ι ≃ κ) :
    elementaryGroup ι R ≃* elementaryGroup κ R :=
  ((elementaryReindexUnitEquiv (R := R) e).subgroupMap
    (elementaryGroup ι R)).trans
    (MulEquiv.subgroupCongr (elementaryReindexGroup_map e))

end ElementaryReindexing

section ElementaryCoefficientEquivalence

variable {ι R S : Type*} [Fintype ι] [DecidableEq ι]
  [Ring R] [Ring S]

def elementaryCoefficientGroupEquiv (f : R ≃+* S) :
    elementaryGroup ι R ≃* elementaryGroup ι S :=
  ((Units.mapEquiv f.mapMatrix.toMulEquiv).subgroupMap
    (elementaryGroup ι R)).trans
    (MulEquiv.subgroupCongr (by
      change
        (elementaryGroup ι R).map
          (elementaryMatrixUnitMap f.toRingHom) =
            elementaryGroup ι S
      exact elementaryGroup_map_eq_of_surjective
        f.toRingHom f.surjective))

end ElementaryCoefficientEquivalence

def ternaryLeavittWord : Fin 3 → List (Fin 2)
  | 0 => [0, 0]
  | 1 => [0, 1]
  | _ => [1]

def ternaryLeavittPrefixCode : BinaryPrefixCode (Fin 3) where
  word := ternaryLeavittWord
  prefix_free := by decide

theorem ternaryLeavittPrefixCode_complete :
    MatrixCorner.codeIdempotent
        (fun i => leavittWordS (ternaryLeavittPrefixCode.word i))
        (fun i => leavittWordT (ternaryLeavittPrefixCode.word i)) =
      1 := by
  have hzero :
      leavittCylinder [0, 0] + leavittCylinder [0, 1] =
        leavittCylinder [0] := by
    simpa using (leavittCylinder_split [0]).symm
  have hroot :
      leavittCylinder [0] + leavittCylinder [1] = 1 := by
    simpa [leavittCylinder, leavittWordS, leavittWordT] using
      (leavittCylinder_split ([] : List (Fin 2))).symm
  have hsum :
      leavittCylinder [0, 0] + leavittCylinder [0, 1] +
          leavittCylinder [1] = 1 := by
    rw [hzero]
    exact hroot
  simpa [MatrixCorner.codeIdempotent, ternaryLeavittPrefixCode,
    ternaryLeavittWord, leavittCylinder, Fin.sum_univ_succ,
    add_assoc] using hsum

def binaryLeavittMatrixThreeEquiv :
    BinaryLeavitt ≃+* Matrix (Fin 3) (Fin 3) BinaryLeavitt :=
  (completePrefixMatrixEquiv ternaryLeavittPrefixCode
    ternaryLeavittPrefixCode_complete).symm

def binaryLeavittElementaryThreeEquivNine :
    binaryLeavittElementaryGroup 3 ≃*
      binaryLeavittElementaryGroup 9 :=
  (elementaryCoefficientGroupEquiv
    (ι := Fin 3) binaryLeavittMatrixThreeEquiv).trans
    ((elementaryBlockGroupEquiv
      (ι := Fin 3) (κ := Fin 3) (R := BinaryLeavitt)).trans
      (elementaryReindexGroupEquiv
        (R := BinaryLeavitt) (finProdFinEquiv :
          Fin 3 × Fin 3 ≃ Fin 9)))

theorem binaryLeavittElementaryThree_hasPropertyT_of_nine
    [HasPropertyT.{0, v} (binaryLeavittElementaryGroup 9)] :
    HasPropertyT.{0, v} (binaryLeavittElementaryGroup 3) :=
  hasPropertyT_of_mulEquiv binaryLeavittElementaryThreeEquivNine.symm

theorem alphaPrefixElementaryGroup_hasPropertyT_of_nine
    [HasPropertyT.{0, v} (binaryLeavittElementaryGroup 9)] :
    HasPropertyT.{0, v} (prefixElementaryGroup alphaPrefixCode) := by
  letI : HasPropertyT.{0, v} (binaryLeavittElementaryGroup 3) :=
    binaryLeavittElementaryThree_hasPropertyT_of_nine
  exact hasPropertyT_of_mulEquiv alphaPrefixElementaryGroupEquiv

theorem alphaZeroPrefixElementaryGroup_hasPropertyT_of_nine
    [HasPropertyT.{0, v} (binaryLeavittElementaryGroup 9)] :
    HasPropertyT.{0, v} (prefixElementaryGroup alphaZeroPrefixCode) := by
  letI : HasPropertyT.{0, v} (binaryLeavittElementaryGroup 3) :=
    binaryLeavittElementaryThree_hasPropertyT_of_nine
  exact hasPropertyT_of_mulEquiv
    (binaryPrefixElementaryGroupEquiv alphaZeroPrefixCode)

end LeavittElementaryMorita

namespace ThompsonFiniteGeneration

open ThompsonPrefixInsertion

theorem cylinderSwap_prefixWordAction_of_cases
    {a b w v : List (Fin 2)}
    (hab : ¬ a <+: b) (hba : ¬ b <+: a)
    (hcase :
      (a <+: w ∧ v = b ++ w.drop a.length) ∨
      (b <+: w ∧ v = a ++ w.drop b.length) ∨
      (v = w ∧ ¬ a <+: w ∧ ¬ w <+: a ∧
        ¬ b <+: w ∧ ¬ w <+: b)) :
    PrefixWordAction (cylinderSwap a b hab hba) w v := by
  rcases hcase with h | h | h
  · obtain ⟨haw, rfl⟩ := h
    simpa only [(List.prefix_append_drop haw).symm] using
      prefixWordAction_append
        (cylinderSwap_prefixWordAction_left a b hab hba)
        (w.drop a.length)
  · obtain ⟨hbw, rfl⟩ := h
    simpa only [(List.prefix_append_drop hbw).symm] using
      prefixWordAction_append
        (cylinderSwap_prefixWordAction_right a b hab hba)
        (w.drop b.length)
  · obtain ⟨hv, haw, hwa, hbw, hwb⟩ := h
    subst v
    exact cylinderSwap_prefixWordAction_fixed
      a b w hab hba haw hwa hbw hwb

end ThompsonFiniteGeneration

end

section

open Filter Topology

section ThreeProjectionSumOfSquares

variable {H : Type*} [NormedAddCommGroup H] [InnerProductSpace ℂ H]

theorem three_pair_sum_norm_sq (a b c : H) :
    ‖a + b‖ ^ 2 + ‖b + c‖ ^ 2 + ‖c + a‖ ^ 2 =
      ‖a + b + c‖ ^ 2 + (‖a‖ ^ 2 + ‖b‖ ^ 2 + ‖c‖ ^ 2) := by
  have hca :
      RCLike.re (inner ℂ c a) = RCLike.re (inner ℂ a c) := by
    exact @inner_re_symm ℂ H _ _ _ c a
  simp only [@norm_add_sq ℂ H, inner_add_left, map_add]
  nlinarith

omit [InnerProductSpace ℂ H] in

theorem norm_add_three_sq_le_three_mul (a b c : H) :
    ‖a + b + c‖ ^ 2 ≤ 3 * (‖a‖ ^ 2 + ‖b‖ ^ 2 + ‖c‖ ^ 2) := by
  have htriangle : ‖a + b + c‖ ≤ ‖a‖ + ‖b‖ + ‖c‖ := by
    calc
      ‖a + b + c‖ ≤ ‖a + b‖ + ‖c‖ := norm_add_le (a + b) c
      _ ≤ ‖a‖ + ‖b‖ + ‖c‖ := by gcongr; exact norm_add_le a b
  have hsquare :
      ‖a + b + c‖ ^ 2 ≤ (‖a‖ + ‖b‖ + ‖c‖) ^ 2 :=
    (sq_le_sq₀ (norm_nonneg _) (by positivity)).mpr htriangle
  nlinarith [sq_nonneg (‖a‖ - ‖b‖),
    sq_nonneg (‖b‖ - ‖c‖), sq_nonneg (‖c‖ - ‖a‖)]

theorem three_pairwise_residual_spectral_gap
    (a b c : H) (ε : ℝ)
    (hab : (1 - ε) * (‖a‖ ^ 2 + ‖b‖ ^ 2) ≤ ‖a + b‖ ^ 2)
    (hbc : (1 - ε) * (‖b‖ ^ 2 + ‖c‖ ^ 2) ≤ ‖b + c‖ ^ 2)
    (hca : (1 - ε) * (‖c‖ ^ 2 + ‖a‖ ^ 2) ≤ ‖c + a‖ ^ 2) :
    (1 - 2 * ε) * (‖a‖ ^ 2 + ‖b‖ ^ 2 + ‖c‖ ^ 2) ≤
      ‖a + b + c‖ ^ 2 := by
  nlinarith [three_pair_sum_norm_sq a b c]

end ThreeProjectionSumOfSquares

section TwoOrthogonalSectors

variable {H : Type*} [NormedAddCommGroup H] [InnerProductSpace ℂ H]

theorem inner_sq_le_of_orthogonal_two_sector
    (a₀ a₁ b₀ b₁ : H)
    (ha : inner ℂ a₀ a₁ = 0)
    (hb : inner ℂ b₀ b₁ = 0)
    (hcross₀ : inner ℂ a₀ b₁ = 0)
    (hcross₁ : inner ℂ a₁ b₀ = 0)
    (h₀ : 8 * ‖inner ℂ a₀ b₀‖ ^ 2 ≤ ‖a₀‖ ^ 2 * ‖b₀‖ ^ 2)
    (h₁ : 8 * ‖inner ℂ a₁ b₁‖ ^ 2 ≤ ‖a₁‖ ^ 2 * ‖b₁‖ ^ 2) :
    8 * ‖inner ℂ (a₀ + a₁) (b₀ + b₁)‖ ^ 2 ≤
      ‖a₀ + a₁‖ ^ 2 * ‖b₀ + b₁‖ ^ 2 := by
  have hproduct :
      (8 * ‖inner ℂ a₀ b₀‖ * ‖inner ℂ a₁ b₁‖) ^ 2 ≤
        (‖a₀‖ * ‖a₁‖ * ‖b₀‖ * ‖b₁‖) ^ 2 := by
    calc
      (8 * ‖inner ℂ a₀ b₀‖ * ‖inner ℂ a₁ b₁‖) ^ 2 =
          (8 * ‖inner ℂ a₀ b₀‖ ^ 2) *
            (8 * ‖inner ℂ a₁ b₁‖ ^ 2) := by ring
      _ ≤ (‖a₀‖ ^ 2 * ‖b₀‖ ^ 2) *
          (‖a₁‖ ^ 2 * ‖b₁‖ ^ 2) :=
        mul_le_mul h₀ h₁ (by positivity) (by positivity)
      _ = (‖a₀‖ * ‖a₁‖ * ‖b₀‖ * ‖b₁‖) ^ 2 := by ring
  have hcross :
      8 * ‖inner ℂ a₀ b₀‖ * ‖inner ℂ a₁ b₁‖ ≤
        ‖a₀‖ * ‖a₁‖ * ‖b₀‖ * ‖b₁‖ :=
    (sq_le_sq₀ (by positivity) (by positivity)).mp hproduct
  have hscalar :
      8 * (‖inner ℂ a₀ b₀‖ + ‖inner ℂ a₁ b₁‖) ^ 2 ≤
        (‖a₀‖ ^ 2 + ‖a₁‖ ^ 2) *
          (‖b₀‖ ^ 2 + ‖b₁‖ ^ 2) := by
    nlinarith [sq_nonneg (‖a₀‖ * ‖b₁‖ - ‖a₁‖ * ‖b₀‖)]
  have hinner :
      inner ℂ (a₀ + a₁) (b₀ + b₁) =
        inner ℂ a₀ b₀ + inner ℂ a₁ b₁ := by
    simp [hcross₀, hcross₁]
  have hnorm :
      ‖inner ℂ (a₀ + a₁) (b₀ + b₁)‖ ≤
        ‖inner ℂ a₀ b₀‖ + ‖inner ℂ a₁ b₁‖ := by
    rw [hinner]
    exact norm_add_le _ _
  have hnormsq :
      ‖inner ℂ (a₀ + a₁) (b₀ + b₁)‖ ^ 2 ≤
        (‖inner ℂ a₀ b₀‖ + ‖inner ℂ a₁ b₁‖) ^ 2 :=
    (sq_le_sq₀ (norm_nonneg _) (by positivity)).mpr hnorm
  have ha' : ‖a₀ + a₁‖ ^ 2 = ‖a₀‖ ^ 2 + ‖a₁‖ ^ 2 := by
    rw [norm_add_sq (𝕜 := ℂ), ha]
    simp
  have hb' : ‖b₀ + b₁‖ ^ 2 = ‖b₀‖ ^ 2 + ‖b₁‖ ^ 2 := by
    rw [norm_add_sq (𝕜 := ℂ), hb]
    simp
  rw [ha', hb']
  nlinarith

theorem inner_sq_le_of_finite_orthogonal_sector_splitting
    {ι : Type*} [Fintype ι]
    (F : ι → Submodule ℂ H)
    [∀ i, (F i).HasOrthogonalProjection]
    (U V : Submodule ℂ H)
    (hU : ∀ (i : ι) ⦃x : H⦄, x ∈ U →
      (F i).starProjection x ∈ U)
    (hV : ∀ (i : ι) ⦃x : H⦄, x ∈ V →
      (F i).starProjection x ∈ V)
    (hF : ∀ (i j : ι) ⦃x : H⦄, x ∈ F j →
      (F i).starProjection x ∈ F j)
    (hsector : ∀ (i : ι) (a b : H),
      a ∈ U → b ∈ V → a ∈ (F i)ᗮ → b ∈ (F i)ᗮ →
        8 * ‖inner ℂ a b‖ ^ 2 ≤ ‖a‖ ^ 2 * ‖b‖ ^ 2)
    (hterminal : ∀ (a b : H), a ∈ U → b ∈ V →
      (∀ i, a ∈ F i) → (∀ i, b ∈ F i) → inner ℂ a b = 0)
    (a b : H) (ha : a ∈ U) (hb : b ∈ V) :
    8 * ‖inner ℂ a b‖ ^ 2 ≤ ‖a‖ ^ 2 * ‖b‖ ^ 2 := by
  classical
  have hind : ∀ (s : Finset ι) (x y : H),
      x ∈ U → y ∈ V →
      (∀ j, j ∉ s → x ∈ F j) →
      (∀ j, j ∉ s → y ∈ F j) →
      8 * ‖inner ℂ x y‖ ^ 2 ≤ ‖x‖ ^ 2 * ‖y‖ ^ 2 := by
    intro s
    induction s using Finset.induction_on with
    | empty =>
        intro x y hx hy hxF hyF
        have hzero : inner ℂ x y = 0 :=
          hterminal x y hx hy
            (fun j => hxF j (by simp))
            (fun j => hyF j (by simp))
        simpa [hzero] using
          mul_nonneg (sq_nonneg ‖x‖) (sq_nonneg ‖y‖)
    | @insert i s hi ih =>
        intro x y hx hy hxF hyF
        let x₀ : H := (F i).starProjection x
        let x₁ : H := (F i)ᗮ.starProjection x
        let y₀ : H := (F i).starProjection y
        let y₁ : H := (F i)ᗮ.starProjection y
        have hx₀ : x₀ ∈ U := hU i hx
        have hy₀ : y₀ ∈ V := hV i hy
        have hx₁ : x₁ ∈ U := by
          dsimp [x₁]
          rw [Submodule.starProjection_orthogonal_val]
          exact U.sub_mem hx (hU i hx)
        have hy₁ : y₁ ∈ V := by
          dsimp [y₁]
          rw [Submodule.starProjection_orthogonal_val]
          exact V.sub_mem hy (hV i hy)
        have hx₀i : x₀ ∈ F i :=
          Submodule.starProjection_apply_mem (F i) x
        have hy₀i : y₀ ∈ F i :=
          Submodule.starProjection_apply_mem (F i) y
        have hx₁i : x₁ ∈ (F i)ᗮ :=
          Submodule.starProjection_apply_mem (F i)ᗮ x
        have hy₁i : y₁ ∈ (F i)ᗮ :=
          Submodule.starProjection_apply_mem (F i)ᗮ y
        have hx₀F : ∀ j, j ∉ s → x₀ ∈ F j := by
          intro j hj
          by_cases hji : j = i
          · subst j
            exact hx₀i
          · apply hF i j
            apply hxF j
            simp [hji, hj]
        have hy₀F : ∀ j, j ∉ s → y₀ ∈ F j := by
          intro j hj
          by_cases hji : j = i
          · subst j
            exact hy₀i
          · apply hF i j
            apply hyF j
            simp [hji, hj]
        have h₀ :
            8 * ‖inner ℂ x₀ y₀‖ ^ 2 ≤
              ‖x₀‖ ^ 2 * ‖y₀‖ ^ 2 :=
          ih x₀ y₀ hx₀ hy₀ hx₀F hy₀F
        have h₁ :
            8 * ‖inner ℂ x₁ y₁‖ ^ 2 ≤
              ‖x₁‖ ^ 2 * ‖y₁‖ ^ 2 :=
          hsector i x₁ y₁ hx₁ hy₁ hx₁i hy₁i
        have hsumx : x₀ + x₁ = x :=
          (F i).starProjection_add_starProjection_orthogonal x
        have hsumy : y₀ + y₁ = y :=
          (F i).starProjection_add_starProjection_orthogonal y
        have htwo := inner_sq_le_of_orthogonal_two_sector
          x₀ x₁ y₀ y₁
          (Submodule.inner_right_of_mem_orthogonal hx₀i hx₁i)
          (Submodule.inner_right_of_mem_orthogonal hy₀i hy₁i)
          (Submodule.inner_right_of_mem_orthogonal hx₀i hy₁i)
          (Submodule.inner_left_of_mem_orthogonal hy₀i hx₁i)
          h₀ h₁
        rwa [hsumx, hsumy] at htwo
  apply hind Finset.univ a b ha hb
  · intro j hj
    exact (hj (Finset.mem_univ j)).elim
  · intro j hj
    exact (hj (Finset.mem_univ j)).elim

end TwoOrthogonalSectors

section ThreeOrthogonalProjections

variable {H : Type*} [NormedAddCommGroup H]
  [InnerProductSpace ℂ H]

theorem ejStarProjection_re_inner (W : Submodule ℂ H)
    [W.HasOrthogonalProjection] (x : H) :
    RCLike.re (inner ℂ (W.starProjection x) x) =
      ‖W.starProjection x‖ ^ 2 := by
  have hidem : W.starProjection (W.starProjection x) =
      W.starProjection x :=
    Submodule.starProjection_eq_self_iff.mpr
      (Submodule.starProjection_apply_mem W x)
  have hinner :
      inner ℂ (W.starProjection x) x =
        inner ℂ (W.starProjection x) (W.starProjection x) := by
    calc
      inner ℂ (W.starProjection x) x =
          inner ℂ x (W.starProjection x) :=
        Submodule.inner_starProjection_left_eq_right W x x
      _ = inner ℂ x (W.starProjection (W.starProjection x)) :=
        congrArg (inner ℂ x) hidem.symm
      _ = inner ℂ (W.starProjection x) (W.starProjection x) :=
        (Submodule.inner_starProjection_left_eq_right W x
          (W.starProjection x)).symm
  rw [hinner]
  exact (norm_sq_eq_re_inner _).symm

def ejResidualProjection (V : Submodule ℂ H)
    [V.HasOrthogonalProjection] : H →L[ℂ] H :=
  Vᗮ.starProjection

@[simp]
theorem ejResidualProjection_apply (V : Submodule ℂ H)
    [V.HasOrthogonalProjection] (x : H) :
    ejResidualProjection V x = x - V.starProjection x :=
  Submodule.starProjection_orthogonal_val x

theorem ejResidualProjection_idempotent (V : Submodule ℂ H)
    [V.HasOrthogonalProjection] (x : H) :
    ejResidualProjection V (ejResidualProjection V x) =
      ejResidualProjection V x := by
  change Vᗮ.starProjection (Vᗮ.starProjection x) = Vᗮ.starProjection x
  exact Submodule.starProjection_eq_self_iff.mpr
    (Submodule.starProjection_apply_mem Vᗮ x)

theorem ejResidualProjection_inner (V : Submodule ℂ H)
    [V.HasOrthogonalProjection] (x y : H) :
    inner ℂ (ejResidualProjection V x) y =
      inner ℂ x (ejResidualProjection V y) :=
  Submodule.inner_starProjection_left_eq_right Vᗮ x y

theorem ejResidualProjection_re_inner (V : Submodule ℂ H)
    [V.HasOrthogonalProjection] (x : H) :
    RCLike.re (inner ℂ (ejResidualProjection V x) x) =
      ‖ejResidualProjection V x‖ ^ 2 := by
  have hinner :
      inner ℂ (ejResidualProjection V x) x =
        inner ℂ (ejResidualProjection V x)
          (ejResidualProjection V x) := by
    calc
      inner ℂ (ejResidualProjection V x) x =
          inner ℂ x (ejResidualProjection V x) :=
        ejResidualProjection_inner V x x
      _ = inner ℂ x
          (ejResidualProjection V (ejResidualProjection V x)) :=
        congrArg (inner ℂ x)
          (ejResidualProjection_idempotent V x).symm
      _ = inner ℂ (ejResidualProjection V x)
          (ejResidualProjection V x) :=
        (ejResidualProjection_inner V x
          (ejResidualProjection V x)).symm
  rw [hinner]
  exact (norm_sq_eq_re_inner _).symm

variable (V : Fin 3 → Submodule ℂ H)
  [∀ i, (V i).HasOrthogonalProjection]

def ejThreeResidualMap : H →L[ℂ] H :=
  ejResidualProjection (V 0) + ejResidualProjection (V 1) +
    ejResidualProjection (V 2)

def ejThreeResidualEnergy (x : H) : ℝ :=
  ‖ejResidualProjection (V 0) x‖ ^ 2 +
    ‖ejResidualProjection (V 1) x‖ ^ 2 +
    ‖ejResidualProjection (V 2) x‖ ^ 2

def ejThreeProjectionAverage : H →L[ℂ] H :=
  ContinuousLinearMap.id ℂ H -
    (3 : ℂ)⁻¹ • ejThreeResidualMap V

@[simp]
theorem ejThreeResidualMap_apply (x : H) :
    ejThreeResidualMap V x =
      ejResidualProjection (V 0) x +
        ejResidualProjection (V 1) x +
        ejResidualProjection (V 2) x := by
  rfl

@[simp]
theorem ejThreeProjectionAverage_apply (x : H) :
    ejThreeProjectionAverage V x =
      x - (3 : ℂ)⁻¹ • ejThreeResidualMap V x := by
  rfl

theorem ejThreeResidualEnergy_nonneg (x : H) :
    0 ≤ ejThreeResidualEnergy V x := by
  unfold ejThreeResidualEnergy
  positivity

theorem ejThreeResidualEnergy_eq_re_inner (x : H) :
    ejThreeResidualEnergy V x =
      RCLike.re (inner ℂ (ejThreeResidualMap V x) x) := by
  simp only [ejThreeResidualEnergy, ejThreeResidualMap_apply,
    inner_add_left, map_add]
  rw [ejResidualProjection_re_inner (V 0) x,
    ejResidualProjection_re_inner (V 1) x,
    ejResidualProjection_re_inner (V 2) x]

theorem ejThreeResidualMap_norm_sq_le (x : H) :
    ‖ejThreeResidualMap V x‖ ^ 2 ≤
      3 * ejThreeResidualEnergy V x := by
  simpa [ejThreeResidualMap_apply, ejThreeResidualEnergy] using
    norm_add_three_sq_le_three_mul
      (ejResidualProjection (V 0) x)
      (ejResidualProjection (V 1) x)
      (ejResidualProjection (V 2) x)

theorem ejResidualProjection_norm_le (i : Fin 3) (x : H) :
    ‖ejResidualProjection (V i) x‖ ≤ ‖x‖ :=
  (V i)ᗮ.norm_starProjection_apply_le x

theorem ejThreeResidualEnergy_le_three_norm_sq (x : H) :
    ejThreeResidualEnergy V x ≤ 3 * ‖x‖ ^ 2 := by
  have h0 : ‖ejResidualProjection (V 0) x‖ ^ 2 ≤ ‖x‖ ^ 2 :=
    (sq_le_sq₀ (norm_nonneg _) (norm_nonneg _)).mpr
      (ejResidualProjection_norm_le V 0 x)
  have h1 : ‖ejResidualProjection (V 1) x‖ ^ 2 ≤ ‖x‖ ^ 2 :=
    (sq_le_sq₀ (norm_nonneg _) (norm_nonneg _)).mpr
      (ejResidualProjection_norm_le V 1 x)
  have h2 : ‖ejResidualProjection (V 2) x‖ ^ 2 ≤ ‖x‖ ^ 2 :=
    (sq_le_sq₀ (norm_nonneg _) (norm_nonneg _)).mpr
      (ejResidualProjection_norm_le V 2 x)
  unfold ejThreeResidualEnergy
  linarith

theorem ejResidualProjection_cross_inner (W : Submodule ℂ H)
    [W.HasOrthogonalProjection] (x z : H) :
    inner ℂ (ejResidualProjection W x) (ejResidualProjection W z) =
      inner ℂ (ejResidualProjection W x) z := by
  calc
    inner ℂ (ejResidualProjection W x) (ejResidualProjection W z) =
        inner ℂ (ejResidualProjection W
          (ejResidualProjection W x)) z :=
      (ejResidualProjection_inner W (ejResidualProjection W x) z).symm
    _ = inner ℂ (ejResidualProjection W x) z := by
      rw [ejResidualProjection_idempotent W x]

theorem ejThreeResidual_cross_re_inner (x : H) :
    RCLike.re (inner ℂ (ejResidualProjection (V 0) x)
        (ejResidualProjection (V 0) (ejThreeResidualMap V x))) +
      RCLike.re (inner ℂ (ejResidualProjection (V 1) x)
        (ejResidualProjection (V 1) (ejThreeResidualMap V x))) +
      RCLike.re (inner ℂ (ejResidualProjection (V 2) x)
        (ejResidualProjection (V 2) (ejThreeResidualMap V x))) =
      ‖ejThreeResidualMap V x‖ ^ 2 := by
  calc
    _ = RCLike.re (inner ℂ (ejResidualProjection (V 0) x)
          (ejThreeResidualMap V x)) +
        RCLike.re (inner ℂ (ejResidualProjection (V 1) x)
          (ejThreeResidualMap V x)) +
        RCLike.re (inner ℂ (ejResidualProjection (V 2) x)
          (ejThreeResidualMap V x)) := by
      rw [ejResidualProjection_cross_inner (V 0),
        ejResidualProjection_cross_inner (V 1),
        ejResidualProjection_cross_inner (V 2)]
    _ = RCLike.re (inner ℂ
        (ejResidualProjection (V 0) x +
          ejResidualProjection (V 1) x +
          ejResidualProjection (V 2) x)
        (ejThreeResidualMap V x)) := by
      simp only [inner_add_left, map_add]
    _ = ‖ejThreeResidualMap V x‖ ^ 2 := by
      rw [← ejThreeResidualMap_apply V x]
      exact (norm_sq_eq_re_inner _).symm

theorem norm_sub_one_third_smul_sq (a b : H) :
    ‖a - (3 : ℂ)⁻¹ • b‖ ^ 2 =
      ‖a‖ ^ 2 - (2 / 3 : ℝ) * RCLike.re (inner ℂ a b) +
        (1 / 9 : ℝ) * ‖b‖ ^ 2 := by
  rw [norm_sub_sq (𝕜 := ℂ), inner_smul_right, norm_smul]
  norm_num [Complex.mul_re]
  ring

theorem ejResidualProjection_average_norm_sq
    (W : Submodule ℂ H) [W.HasOrthogonalProjection]
    (x z : H) :
    ‖ejResidualProjection W (x - (3 : ℂ)⁻¹ • z)‖ ^ 2 =
      ‖ejResidualProjection W x‖ ^ 2 -
        (2 / 3 : ℝ) * RCLike.re
          (inner ℂ (ejResidualProjection W x)
            (ejResidualProjection W z)) +
        (1 / 9 : ℝ) * ‖ejResidualProjection W z‖ ^ 2 := by
  rw [map_sub, map_smul]
  exact norm_sub_one_third_smul_sq
    (ejResidualProjection W x) (ejResidualProjection W z)

theorem ejThreeResidualEnergy_average (x : H) :
    ejThreeResidualEnergy V (ejThreeProjectionAverage V x) =
      ejThreeResidualEnergy V x -
        (2 / 3 : ℝ) * ‖ejThreeResidualMap V x‖ ^ 2 +
        (1 / 9 : ℝ) *
          ejThreeResidualEnergy V (ejThreeResidualMap V x) := by
  unfold ejThreeResidualEnergy
  rw [ejThreeProjectionAverage_apply,
    ejResidualProjection_average_norm_sq (V 0),
    ejResidualProjection_average_norm_sq (V 1),
    ejResidualProjection_average_norm_sq (V 2)]
  have hcross := ejThreeResidual_cross_re_inner V x
  nlinarith

theorem ejThreeResidualMap_spectral_gap (x : H) (ε : ℝ)
    (h01 : (1 - ε) *
      (‖ejResidualProjection (V 0) x‖ ^ 2 +
        ‖ejResidualProjection (V 1) x‖ ^ 2) ≤
      ‖ejResidualProjection (V 0) x +
        ejResidualProjection (V 1) x‖ ^ 2)
    (h12 : (1 - ε) *
      (‖ejResidualProjection (V 1) x‖ ^ 2 +
        ‖ejResidualProjection (V 2) x‖ ^ 2) ≤
      ‖ejResidualProjection (V 1) x +
        ejResidualProjection (V 2) x‖ ^ 2)
    (h20 : (1 - ε) *
      (‖ejResidualProjection (V 2) x‖ ^ 2 +
        ‖ejResidualProjection (V 0) x‖ ^ 2) ≤
      ‖ejResidualProjection (V 2) x +
        ejResidualProjection (V 0) x‖ ^ 2) :
    (1 - 2 * ε) * ejThreeResidualEnergy V x ≤
      ‖ejThreeResidualMap V x‖ ^ 2 := by
  exact three_pairwise_residual_spectral_gap
    (ejResidualProjection (V 0) x)
    (ejResidualProjection (V 1) x)
    (ejResidualProjection (V 2) x)
    ε h01 h12 h20

theorem ejThreeResidualEnergy_average_le
    (x : H) (δ : ℝ)
    (hgap : δ * ejThreeResidualEnergy V x ≤
      ‖ejThreeResidualMap V x‖ ^ 2) :
    ejThreeResidualEnergy V (ejThreeProjectionAverage V x) ≤
      (1 - δ / 3) * ejThreeResidualEnergy V x := by
  rw [ejThreeResidualEnergy_average]
  have hupper := ejThreeResidualEnergy_le_three_norm_sq V
    (ejThreeResidualMap V x)
  nlinarith

theorem ejStarProjection_mem_inf_orthogonal
    (U V : Submodule ℂ H) [U.HasOrthogonalProjection]
    (w : H) (hw : w ∈ (U ⊓ V)ᗮ) :
    U.starProjection w ∈ (U ⊓ V)ᗮ := by
  intro q hq
  calc
    inner ℂ q (U.starProjection w) =
        inner ℂ (U.starProjection q) w :=
      (Submodule.inner_starProjection_left_eq_right U q w).symm
    _ = inner ℂ q w := by
      rw [Submodule.starProjection_eq_self_iff.mpr hq.1]
    _ = 0 := hw q hq

theorem ejTwoProjection_norm_sq_sum_le_of_angle
    (U V : Submodule ℂ H)
    [U.HasOrthogonalProjection] [V.HasOrthogonalProjection]
    (c : ℝ) (hc : 0 ≤ c)
    (hangle : ∀ (u v : H),
      u ∈ U → u ∈ (U ⊓ V)ᗮ →
      v ∈ V → v ∈ (U ⊓ V)ᗮ →
        ‖inner ℂ u v‖ ≤ c * ‖u‖ * ‖v‖)
    (w : H) (hw : w ∈ (U ⊓ V)ᗮ) :
    ‖U.starProjection w‖ ^ 2 + ‖V.starProjection w‖ ^ 2 ≤
      (1 + c) * ‖w‖ ^ 2 := by
  let u : H := U.starProjection w
  let v : H := V.starProjection w
  have hu : u ∈ U := Submodule.starProjection_apply_mem U w
  have hv : v ∈ V := Submodule.starProjection_apply_mem V w
  have huorth : u ∈ (U ⊓ V)ᗮ :=
    ejStarProjection_mem_inf_orthogonal U V w hw
  have hvorth : v ∈ (U ⊓ V)ᗮ := by
    have h := ejStarProjection_mem_inf_orthogonal V U w (by
      simpa [inf_comm] using hw)
    simpa [inf_comm] using h
  have hre : RCLike.re (inner ℂ u v) ≤ c * ‖u‖ * ‖v‖ :=
    (RCLike.re_le_norm (inner ℂ u v)).trans
      (hangle u v hu huorth hv hvorth)
  have hsum :
      ‖u + v‖ ^ 2 ≤
        (1 + c) * (‖u‖ ^ 2 + ‖v‖ ^ 2) := by
    rw [norm_add_sq (𝕜 := ℂ)]
    nlinarith [mul_nonneg hc (sq_nonneg (‖u‖ - ‖v‖))]
  have huinner :
      (inner ℂ (U.starProjection w) w).re =
        ‖U.starProjection w‖ ^ 2 := by
    change RCLike.re (inner ℂ (U.starProjection w) w) = _
    exact ejStarProjection_re_inner U w
  have hvinner :
      (inner ℂ (V.starProjection w) w).re =
        ‖V.starProjection w‖ ^ 2 := by
    change RCLike.re (inner ℂ (V.starProjection w) w) = _
    exact ejStarProjection_re_inner V w
  have hlinear :
      ‖u‖ ^ 2 + ‖v‖ ^ 2 ≤ ‖u + v‖ * ‖w‖ := by
    calc
      ‖u‖ ^ 2 + ‖v‖ ^ 2 =
          RCLike.re (inner ℂ (u + v) w) := by
        dsimp [u, v]
        simp only [inner_add_left, Complex.add_re]
        rw [huinner, hvinner]
      _ ≤ ‖inner ℂ (u + v) w‖ :=
        RCLike.re_le_norm _
      _ ≤ ‖u + v‖ * ‖w‖ :=
        norm_inner_le_norm _ _
  have hsq :
      (‖u‖ ^ 2 + ‖v‖ ^ 2) ^ 2 ≤
        (‖u + v‖ * ‖w‖) ^ 2 :=
    (sq_le_sq₀ (by positivity) (by positivity)).mpr hlinear
  have hcancel :
      (‖u‖ ^ 2 + ‖v‖ ^ 2) *
          (‖u‖ ^ 2 + ‖v‖ ^ 2) ≤
        ((1 + c) * ‖w‖ ^ 2) *
          (‖u‖ ^ 2 + ‖v‖ ^ 2) := by
    calc
      _ = (‖u‖ ^ 2 + ‖v‖ ^ 2) ^ 2 := by ring
      _ ≤ (‖u + v‖ * ‖w‖) ^ 2 := hsq
      _ = ‖u + v‖ ^ 2 * ‖w‖ ^ 2 := by ring
      _ ≤ ((1 + c) * (‖u‖ ^ 2 + ‖v‖ ^ 2)) *
          ‖w‖ ^ 2 :=
        mul_le_mul_of_nonneg_right hsum (sq_nonneg ‖w‖)
      _ = ((1 + c) * ‖w‖ ^ 2) *
          (‖u‖ ^ 2 + ‖v‖ ^ 2) := by ring
  change ‖u‖ ^ 2 + ‖v‖ ^ 2 ≤ (1 + c) * ‖w‖ ^ 2
  by_cases hz : ‖u‖ ^ 2 + ‖v‖ ^ 2 = 0
  · rw [hz]
    positivity
  · have hpos : 0 < ‖u‖ ^ 2 + ‖v‖ ^ 2 :=
      lt_of_le_of_ne (by positivity) (Ne.symm hz)
    apply (mul_le_mul_iff_right₀ hpos).mp
    calc
      _ ≤ ((1 + c) * ‖w‖ ^ 2) *
          (‖u‖ ^ 2 + ‖v‖ ^ 2) := hcancel
      _ = (‖u‖ ^ 2 + ‖v‖ ^ 2) *
          ((1 + c) * ‖w‖ ^ 2) := by ring

theorem ejTwoResidualEnergy_ge_of_angle
    (U V : Submodule ℂ H)
    [U.HasOrthogonalProjection] [V.HasOrthogonalProjection]
    (c : ℝ) (hc : 0 ≤ c)
    (hangle : ∀ (u v : H),
      u ∈ U → u ∈ (U ⊓ V)ᗮ →
      v ∈ V → v ∈ (U ⊓ V)ᗮ →
        ‖inner ℂ u v‖ ≤ c * ‖u‖ * ‖v‖)
    (w : H) (hw : w ∈ (U ⊓ V)ᗮ) :
    (1 - c) * ‖w‖ ^ 2 ≤
      ‖ejResidualProjection U w‖ ^ 2 +
        ‖ejResidualProjection V w‖ ^ 2 := by
  have hU := U.norm_sq_eq_add_norm_sq_starProjection w
  have hV := V.norm_sq_eq_add_norm_sq_starProjection w
  change ‖w‖ ^ 2 =
    ‖U.starProjection w‖ ^ 2 +
      ‖ejResidualProjection U w‖ ^ 2 at hU
  change ‖w‖ ^ 2 =
    ‖V.starProjection w‖ ^ 2 +
      ‖ejResidualProjection V w‖ ^ 2 at hV
  have hsum :=
    ejTwoProjection_norm_sq_sum_le_of_angle U V c hc hangle w hw
  nlinarith

theorem ejTwoResidual_sum_re_inner
    (U V : Submodule ℂ H)
    [U.HasOrthogonalProjection] [V.HasOrthogonalProjection]
    (w : H) :
    RCLike.re (inner ℂ
      (ejResidualProjection U w + ejResidualProjection V w) w) =
        ‖ejResidualProjection U w‖ ^ 2 +
          ‖ejResidualProjection V w‖ ^ 2 := by
  have hU :
      (inner ℂ (ejResidualProjection U w) w).re =
        ‖ejResidualProjection U w‖ ^ 2 := by
    change RCLike.re (inner ℂ (ejResidualProjection U w) w) = _
    exact ejResidualProjection_re_inner U w
  have hV :
      (inner ℂ (ejResidualProjection V w) w).re =
        ‖ejResidualProjection V w‖ ^ 2 := by
    change RCLike.re (inner ℂ (ejResidualProjection V w) w) = _
    exact ejResidualProjection_re_inner V w
  change
    (inner ℂ
      (ejResidualProjection U w + ejResidualProjection V w) w).re = _
  simp only [inner_add_left, Complex.add_re]
  rw [hU, hV]

theorem ejTwoResidual_spectral_gap_of_angle
    (U V : Submodule ℂ H)
    [U.HasOrthogonalProjection] [V.HasOrthogonalProjection]
    [(U ⊓ V).HasOrthogonalProjection]
    (c : ℝ) (hc : 0 ≤ c) (hc' : c ≤ 1)
    (hangle : ∀ (u v : H),
      u ∈ U → u ∈ (U ⊓ V)ᗮ →
      v ∈ V → v ∈ (U ⊓ V)ᗮ →
        ‖inner ℂ u v‖ ≤ c * ‖u‖ * ‖v‖)
    (x : H) :
    (1 - c) *
        (‖ejResidualProjection U x‖ ^ 2 +
          ‖ejResidualProjection V x‖ ^ 2) ≤
      ‖ejResidualProjection U x +
        ejResidualProjection V x‖ ^ 2 := by
  let q : H := (U ⊓ V).starProjection x
  let w : H := x - q
  have hw : w ∈ (U ⊓ V)ᗮ :=
    Submodule.sub_starProjection_mem_orthogonal x
  have hq : q ∈ U ⊓ V :=
    Submodule.starProjection_apply_mem (U ⊓ V) x
  have hqU : ejResidualProjection U q = 0 := by
    rw [ejResidualProjection_apply,
      Submodule.starProjection_eq_self_iff.mpr hq.1, sub_self]
  have hqV : ejResidualProjection V q = 0 := by
    rw [ejResidualProjection_apply,
      Submodule.starProjection_eq_self_iff.mpr hq.2, sub_self]
  have hwU : ejResidualProjection U w =
      ejResidualProjection U x := by
    dsimp [w]
    rw [map_sub, hqU, sub_zero]
  have hwV : ejResidualProjection V w =
      ejResidualProjection V x := by
    dsimp [w]
    rw [map_sub, hqV, sub_zero]
  let e : ℝ :=
    ‖ejResidualProjection U w‖ ^ 2 +
      ‖ejResidualProjection V w‖ ^ 2
  let z : H :=
    ejResidualProjection U w + ejResidualProjection V w
  have he : 0 ≤ e := by
    dsimp [e]
    positivity
  have hcoercive : (1 - c) * ‖w‖ ^ 2 ≤ e :=
    ejTwoResidualEnergy_ge_of_angle U V c hc hangle w hw
  have hlinear : e ≤ ‖z‖ * ‖w‖ := by
    calc
      e = RCLike.re (inner ℂ z w) :=
        (ejTwoResidual_sum_re_inner U V w).symm
      _ ≤ ‖inner ℂ z w‖ := RCLike.re_le_norm _
      _ ≤ ‖z‖ * ‖w‖ := norm_inner_le_norm _ _
  have hsq : e ^ 2 ≤ (‖z‖ * ‖w‖) ^ 2 :=
    (sq_le_sq₀ he (by positivity)).mpr hlinear
  have hgap : (1 - c) * e ≤ ‖z‖ ^ 2 := by
    by_cases hz : e = 0
    · rw [hz, mul_zero]
      positivity
    · have hepos : 0 < e := lt_of_le_of_ne he (Ne.symm hz)
      apply (mul_le_mul_iff_right₀ hepos).mp
      calc
        e * ((1 - c) * e) = (1 - c) * e ^ 2 := by ring
        _ ≤ (1 - c) * (‖z‖ * ‖w‖) ^ 2 :=
          mul_le_mul_of_nonneg_left hsq (sub_nonneg.mpr hc')
        _ = ‖z‖ ^ 2 * ((1 - c) * ‖w‖ ^ 2) := by ring
        _ ≤ ‖z‖ ^ 2 * e :=
          mul_le_mul_of_nonneg_left hcoercive (sq_nonneg ‖z‖)
        _ = e * ‖z‖ ^ 2 := by ring
  change (1 - c) * e ≤ ‖z‖ ^ 2 at hgap
  dsimp [e, z] at hgap
  rw [hwU, hwV] at hgap
  exact hgap

theorem ejThreeProjectionAverage_dist_sq (x : H) :
    dist x (ejThreeProjectionAverage V x) ^ 2 =
      (1 / 9 : ℝ) * ‖ejThreeResidualMap V x‖ ^ 2 := by
  rw [dist_eq_norm, ejThreeProjectionAverage_apply]
  have hsub :
      x - (x - (3 : ℂ)⁻¹ • ejThreeResidualMap V x) =
        (3 : ℂ)⁻¹ • ejThreeResidualMap V x := by
    abel
  rw [hsub, norm_smul, norm_inv]
  norm_num
  ring

theorem ejThreeProjectionAverage_dist_sq_le (x : H) :
    dist x (ejThreeProjectionAverage V x) ^ 2 ≤
      ejThreeResidualEnergy V x / 3 := by
  rw [ejThreeProjectionAverage_dist_sq]
  have h := ejThreeResidualMap_norm_sq_le V x
  nlinarith

theorem ejThreeResidualEnergy_iterate_le
    (δ : ℝ) (hδ : δ ≤ 3)
    (hgap : ∀ x : H,
      δ * ejThreeResidualEnergy V x ≤ ‖ejThreeResidualMap V x‖ ^ 2)
    (x : H) (n : ℕ) :
    ejThreeResidualEnergy V
        (((ejThreeProjectionAverage V : H → H)^[n]) x) ≤
      (1 - δ / 3) ^ n * ejThreeResidualEnergy V x := by
  have hnonneg : 0 ≤ 1 - δ / 3 := by linarith
  induction n with
  | zero => simp
  | succ n ih =>
      rw [Function.iterate_succ_apply']
      calc
        ejThreeResidualEnergy V
            (ejThreeProjectionAverage V
              (((ejThreeProjectionAverage V : H → H)^[n]) x)) ≤
          (1 - δ / 3) * ejThreeResidualEnergy V
            (((ejThreeProjectionAverage V : H → H)^[n]) x) :=
          ejThreeResidualEnergy_average_le V _ δ (hgap _)
        _ ≤ (1 - δ / 3) *
            ((1 - δ / 3) ^ n * ejThreeResidualEnergy V x) :=
          mul_le_mul_of_nonneg_left ih hnonneg
        _ = (1 - δ / 3) ^ n.succ *
            ejThreeResidualEnergy V x := by
          rw [pow_succ]
          ring

theorem ejThreeProjectionAverage_iterate_dist_le_geometric
    (δ : ℝ) (hδ : δ ≤ 3)
    (hgap : ∀ x : H,
      δ * ejThreeResidualEnergy V x ≤ ‖ejThreeResidualMap V x‖ ^ 2)
    (x : H) (n : ℕ) :
    dist (((ejThreeProjectionAverage V : H → H)^[n]) x)
        (((ejThreeProjectionAverage V : H → H)^[n + 1]) x) ≤
      Real.sqrt (ejThreeResidualEnergy V x / 3) *
        (1 - δ / 6) ^ n := by
  let q : ℝ := 1 - δ / 3
  let r : ℝ := 1 - δ / 6
  have hq : 0 ≤ q := by
    dsimp [q]
    linarith
  have hr : 0 ≤ r := by
    dsimp [r]
    linarith
  have hqr : q ≤ r ^ 2 := by
    dsimp [q, r]
    nlinarith [sq_nonneg δ]
  let y : H := ((ejThreeProjectionAverage V : H → H)^[n]) x
  have hiter :
      ejThreeResidualEnergy V y ≤
        q ^ n * ejThreeResidualEnergy V x :=
    ejThreeResidualEnergy_iterate_le V δ hδ hgap x n
  have hpow : q ^ n ≤ (r ^ 2) ^ n :=
    pow_le_pow_left₀ hq hqr n
  have henergy :
      ejThreeResidualEnergy V y ≤
        r ^ (2 * n) * ejThreeResidualEnergy V x := by
    calc
      ejThreeResidualEnergy V y ≤
          q ^ n * ejThreeResidualEnergy V x := hiter
      _ ≤ (r ^ 2) ^ n * ejThreeResidualEnergy V x :=
        mul_le_mul_of_nonneg_right hpow
          (ejThreeResidualEnergy_nonneg V x)
      _ = r ^ (2 * n) * ejThreeResidualEnergy V x := by
        rw [pow_mul]
  have hstep := ejThreeProjectionAverage_dist_sq_le V y
  have hsqrt :
      (Real.sqrt (ejThreeResidualEnergy V x / 3)) ^ 2 =
        ejThreeResidualEnergy V x / 3 :=
    Real.sq_sqrt
      (div_nonneg (ejThreeResidualEnergy_nonneg V x) (by norm_num))
  have hsquared :
      dist y (ejThreeProjectionAverage V y) ^ 2 ≤
        (Real.sqrt (ejThreeResidualEnergy V x / 3) * r ^ n) ^ 2 := by
    rw [mul_pow, hsqrt]
    have hpower : (r ^ n) ^ 2 = r ^ (2 * n) := by
      rw [← pow_mul]
      congr 1
      omega
    rw [hpower]
    nlinarith
  have hdist :
      dist y (ejThreeProjectionAverage V y) ≤
        Real.sqrt (ejThreeResidualEnergy V x / 3) * r ^ n :=
    (sq_le_sq₀ (dist_nonneg) (by positivity)).mp hsquared
  change dist y
    (((ejThreeProjectionAverage V : H → H)^[n + 1]) x) ≤
      Real.sqrt (ejThreeResidualEnergy V x / 3) * r ^ n
  rw [Function.iterate_succ_apply']
  exact hdist

theorem ejThreeResidual_spectral_gap_of_pair_angles
    [∀ i j : Fin 3, (V i ⊓ V j).HasOrthogonalProjection]
    (c : ℝ) (hc : 0 ≤ c) (hc' : c ≤ 1)
    (hangle : ∀ (i j : Fin 3) (u v : H),
      u ∈ V i → u ∈ (V i ⊓ V j)ᗮ →
      v ∈ V j → v ∈ (V i ⊓ V j)ᗮ →
        ‖inner ℂ u v‖ ≤ c * ‖u‖ * ‖v‖)
    (x : H) :
    (1 - 2 * c) * ejThreeResidualEnergy V x ≤
      ‖ejThreeResidualMap V x‖ ^ 2 := by
  apply ejThreeResidualMap_spectral_gap V x c
  · exact ejTwoResidual_spectral_gap_of_angle
      (V 0) (V 1) c hc hc' (hangle 0 1) x
  · exact ejTwoResidual_spectral_gap_of_angle
      (V 1) (V 2) c hc hc' (hangle 1 2) x
  · exact ejTwoResidual_spectral_gap_of_angle
      (V 2) (V 0) c hc hc' (hangle 2 0) x

theorem ejThreeProjectionAverage_iterate_dist_le_of_pair_angles
    [∀ i j : Fin 3, (V i ⊓ V j).HasOrthogonalProjection]
    (c : ℝ) (hc : 0 ≤ c) (hchalf : c < (1 / 2 : ℝ))
    (hangle : ∀ (i j : Fin 3) (u v : H),
      u ∈ V i → u ∈ (V i ⊓ V j)ᗮ →
      v ∈ V j → v ∈ (V i ⊓ V j)ᗮ →
        ‖inner ℂ u v‖ ≤ c * ‖u‖ * ‖v‖)
    (x : H) (n : ℕ) :
    dist (((ejThreeProjectionAverage V : H → H)^[n]) x)
        (((ejThreeProjectionAverage V : H → H)^[n + 1]) x) ≤
      Real.sqrt (ejThreeResidualEnergy V x / 3) *
        (1 - (1 - 2 * c) / 6) ^ n := by
  have hc' : c ≤ 1 := by linarith
  apply ejThreeProjectionAverage_iterate_dist_le_geometric V
    (1 - 2 * c) (by linarith)
  intro y
  exact ejThreeResidual_spectral_gap_of_pair_angles
    V c hc hc' hangle y

theorem ejThreeResidualEnergy_sqrt_div_three_le
    (x : H) (T : ℝ) (hT : 0 ≤ T)
    (hbound : ∀ i : Fin 3,
      ‖ejResidualProjection (V i) x‖ ≤ T) :
    Real.sqrt (ejThreeResidualEnergy V x / 3) ≤ T := by
  have h₀ : ‖ejResidualProjection (V 0) x‖ ^ 2 ≤ T ^ 2 :=
    (sq_le_sq₀ (norm_nonneg _) hT).mpr (hbound 0)
  have h₁ : ‖ejResidualProjection (V 1) x‖ ^ 2 ≤ T ^ 2 :=
    (sq_le_sq₀ (norm_nonneg _) hT).mpr (hbound 1)
  have h₂ : ‖ejResidualProjection (V 2) x‖ ^ 2 ≤ T ^ 2 :=
    (sq_le_sq₀ (norm_nonneg _) hT).mpr (hbound 2)
  apply Real.sqrt_le_iff.mpr
  refine ⟨hT, ?_⟩
  unfold ejThreeResidualEnergy
  nlinarith

theorem ejThreeProjectionAverage_fixed_iff_residualMap_eq_zero (x : H) :
    ejThreeProjectionAverage V x = x ↔
      ejThreeResidualMap V x = 0 := by
  constructor
  · intro h
    rw [ejThreeProjectionAverage_apply] at h
    have hz : (3 : ℂ)⁻¹ • ejThreeResidualMap V x = 0 :=
      sub_eq_self.mp h
    exact (smul_eq_zero.mp hz).resolve_left (by norm_num)
  · intro h
    simp [ejThreeProjectionAverage_apply, h]

theorem ejThreeResidualEnergy_eq_zero_iff (x : H) :
    ejThreeResidualEnergy V x = 0 ↔
      ∀ i : Fin 3, ejResidualProjection (V i) x = 0 := by
  constructor
  · intro h i
    have h₀ : 0 ≤ ‖ejResidualProjection (V 0) x‖ ^ 2 :=
      sq_nonneg _
    have h₁ : 0 ≤ ‖ejResidualProjection (V 1) x‖ ^ 2 :=
      sq_nonneg _
    have h₂ : 0 ≤ ‖ejResidualProjection (V 2) x‖ ^ 2 :=
      sq_nonneg _
    unfold ejThreeResidualEnergy at h
    fin_cases i
    · change ejResidualProjection (V 0) x = 0
      apply norm_eq_zero.mp
      nlinarith [norm_nonneg (ejResidualProjection (V 0) x)]
    · change ejResidualProjection (V 1) x = 0
      apply norm_eq_zero.mp
      nlinarith [norm_nonneg (ejResidualProjection (V 1) x)]
    · change ejResidualProjection (V 2) x = 0
      apply norm_eq_zero.mp
      nlinarith [norm_nonneg (ejResidualProjection (V 2) x)]
  · intro h
    unfold ejThreeResidualEnergy
    simp [h 0, h 1, h 2]

theorem ejThreeProjectionAverage_fixed_mem
    (x : H) (hx : ejThreeProjectionAverage V x = x)
    (i : Fin 3) : x ∈ V i := by
  have hD : ejThreeResidualMap V x = 0 :=
    (ejThreeProjectionAverage_fixed_iff_residualMap_eq_zero V x).mp hx
  have hE : ejThreeResidualEnergy V x = 0 := by
    rw [ejThreeResidualEnergy_eq_re_inner V x, hD]
    simp
  have hres : ejResidualProjection (V i) x = 0 :=
    (ejThreeResidualEnergy_eq_zero_iff V x).mp hE i
  rw [ejResidualProjection_apply, sub_eq_zero] at hres
  exact Submodule.starProjection_eq_self_iff.mp hres.symm

end ThreeOrthogonalProjections

section ThreeFiniteUnitaryFixedSpaces

universe u₂ v₂

def ejUnitaryFixedSubmodule
    {G : Type u₂} {H : Type v₂} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) :
    Submodule ℂ H where
  carrier := {x : H | ∀ k : K, π (k : G) x = x}
  zero_mem' k := by simp
  add_mem' hx hy k := by
    simp [map_add, hx k, hy k]
  smul_mem' c x hx k := by
    simp [map_smul, hx k]

@[simp]
theorem mem_ejUnitaryFixedSubmodule
    {G : Type u₂} {H : Type v₂} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) (x : H) :
    x ∈ ejUnitaryFixedSubmodule π K ↔
      ∀ k : K, π (k : G) x = x :=
  Iff.rfl

theorem ejUnitaryFixedSubmodule_isClosed
    {G : Type u₂} {H : Type v₂} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) :
    IsClosed (ejUnitaryFixedSubmodule π K : Set H) := by
  have hset :
      (ejUnitaryFixedSubmodule π K : Set H) =
        ⋂ k : K, {x : H | π (k : G) x = x} := by
    ext x
    simp
  rw [hset]
  exact isClosed_iInter fun k =>
    isClosed_eq (π (k : G)).continuous continuous_id

theorem ejUnitaryFixedSubmodule_inf_isClosed
    {G : Type u₂} {H : Type v₂} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (K J : Subgroup G) :
    IsClosed
      ((ejUnitaryFixedSubmodule π K ⊓
        ejUnitaryFixedSubmodule π J : Submodule ℂ H) : Set H) := by
  change IsClosed
    ((ejUnitaryFixedSubmodule π K : Set H) ∩
      (ejUnitaryFixedSubmodule π J : Set H))
  exact (ejUnitaryFixedSubmodule_isClosed π K).inter
    (ejUnitaryFixedSubmodule_isClosed π J)

instance ejUnitaryFixedSubmodule_completeSpace
    {G : Type u₂} {H : Type v₂} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] [CompleteSpace H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) :
    CompleteSpace (ejUnitaryFixedSubmodule π K) :=
  (ejUnitaryFixedSubmodule_isClosed π K).isComplete.completeSpace_coe

instance ejUnitaryFixedSubmodule_inf_completeSpace
    {G : Type u₂} {H : Type v₂} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] [CompleteSpace H]
    (π : UnitaryRepresentation G H) (K J : Subgroup G) :
    CompleteSpace
      (↑(ejUnitaryFixedSubmodule π K ⊓
        ejUnitaryFixedSubmodule π J : Submodule ℂ H) : Type v₂) :=
  (ejUnitaryFixedSubmodule_inf_isClosed π K J).isComplete.completeSpace_coe

end ThreeFiniteUnitaryFixedSpaces

end

namespace ErshovJaikinFiniteSpectral

open Filter Topology

universe u v

section FiniteUnitaryAveraging

variable {G : Type u} {H : Type v} [Group G]
  [NormedAddCommGroup H] [InnerProductSpace ℂ H]

def finiteUnitarySubgroupAverage
    (π : SoficGroups.UnitaryRepresentation G H)
    (K : Subgroup G) [Fintype K] (x : H) : H :=
  (Fintype.card K : ℂ)⁻¹ • ∑ k : K, π (k : G) x

theorem finiteUnitarySubgroupAverage_fixed
    (π : SoficGroups.UnitaryRepresentation G H)
    (K : Subgroup G) [Fintype K] (x : H) (g : K) :
    π (g : G) (finiteUnitarySubgroupAverage π K x) =
      finiteUnitarySubgroupAverage π K x := by
  classical
  unfold finiteUnitarySubgroupAverage
  rw [map_smul, map_sum]
  congr 1
  calc
    (∑ k : K, π (g : G) (π (k : G) x)) =
        ∑ k : K, π ((g * k : K) : G) x := by
          apply Finset.sum_congr rfl
          intro k _
          simp [map_mul]
    _ = ∑ k : K, π (k : G) x :=
      Function.Bijective.sum_comp (Group.mulLeft_bijective g)
        (fun k : K => π (k : G) x)

theorem finiteUnitarySubgroupAverage_sub
    (π : SoficGroups.UnitaryRepresentation G H)
    (K : Subgroup G) [Fintype K] (x : H) :
    finiteUnitarySubgroupAverage π K x - x =
      (Fintype.card K : ℂ)⁻¹ •
        ∑ k : K, (π (k : G) x - x) := by
  classical
  have hcard : (Fintype.card K : ℂ) ≠ 0 := by
    exact_mod_cast Fintype.card_ne_zero
  unfold finiteUnitarySubgroupAverage
  rw [Finset.sum_sub_distrib, smul_sub]
  have hconst :
      (Fintype.card K : ℂ)⁻¹ • (∑ _k : K, x) = x := by
    simp [← Nat.cast_smul_eq_nsmul ℂ, smul_smul, hcard]
  rw [hconst]

theorem norm_finiteUnitarySubgroupAverage_sub_le
    (π : SoficGroups.UnitaryRepresentation G H)
    (K : Subgroup G) [Fintype K] (x : H) :
    ‖finiteUnitarySubgroupAverage π K x - x‖ ≤
      (Fintype.card K : ℝ)⁻¹ *
        ∑ k : K, ‖π (k : G) x - x‖ := by
  classical
  rw [finiteUnitarySubgroupAverage_sub, norm_smul, norm_inv,
    Complex.norm_natCast]
  exact mul_le_mul_of_nonneg_left
    (norm_sum_le Finset.univ (fun k : K => π (k : G) x - x))
    (by positivity)

theorem norm_sub_starProjection_le_finiteUnitarySubgroupAverage
    (π : SoficGroups.UnitaryRepresentation G H)
    (K : Subgroup G) [Fintype K]
    (U : Submodule ℂ H) [U.HasOrthogonalProjection]
    (x : H) (hmem : finiteUnitarySubgroupAverage π K x ∈ U) :
    ‖x - U.starProjection x‖ ≤
      ‖finiteUnitarySubgroupAverage π K x - x‖ := by
  rw [Submodule.starProjection_minimal]
  have hbound : BddBelow
      (Set.range fun z : U => ‖x - (z : H)‖) :=
    ⟨0, Set.forall_mem_range.mpr fun _ => norm_nonneg _⟩
  calc
    (⨅ z : U, ‖x - (z : H)‖) ≤
        ‖x - (⟨finiteUnitarySubgroupAverage π K x, hmem⟩ : U)‖ :=
      ciInf_le hbound _
    _ = ‖finiteUnitarySubgroupAverage π K x - x‖ :=
      norm_sub_rev _ _

end FiniteUnitaryAveraging

theorem hasPropertyT_of_geometric_finite_averaging
    {G : Type u} [Group G] (S : Finset G) (q : ℝ)
    (hq1 : q < 1)
    (haverage :
      ∀ (H : Type v) [NormedAddCommGroup H] [InnerProductSpace ℂ H]
        [CompleteSpace H] (π : SoficGroups.UnitaryRepresentation G H),
        ∃ A : H →L[ℂ] H,
          (∀ (x : H) (n : ℕ),
            dist ((A : H → H)^[n] x)
                ((A : H → H)^[n + 1] x) ≤
              (∑ g ∈ S, ‖π g x - x‖) * q ^ n) ∧
          (∀ x : H, A x = x → ∀ g : G, π g x = x)) :
    SoficGroups.HasPropertyT.{u, v} G := by
  classical
  let δ : ℝ := (1 - q) / (2 * (S.card + 1))
  have hδ : 0 < δ := by
    dsimp [δ]
    apply div_pos (sub_pos.mpr hq1)
    positivity
  refine ⟨⟨{
    generators := S
    kazhdanConstant := δ
    positive := hδ
    invariant := ?_
  }⟩⟩
  intro H _ _ _ π ξ hξ hsmall
  obtain ⟨A, hstep, hfixed⟩ := haverage H π
  let C : ℝ := ∑ g ∈ S, ‖π g ξ - ξ‖
  let f : ℕ → H := fun n => ((A : H → H)^[n]) ξ
  have hgeometric : ∀ n : ℕ,
      dist (f n) (f (n + 1)) ≤ C * q ^ n := by
    intro n
    exact hstep ξ n
  have hcauchy : CauchySeq f :=
    cauchySeq_of_le_geometric q C hq1 hgeometric
  obtain ⟨η, hηlim⟩ := cauchySeq_tendsto_of_complete hcauchy
  have hηfixed : A η = η :=
    isFixedPt_of_tendsto_iterate hηlim A.continuous.continuousAt
  have hdist : dist ξ η ≤ C / (1 - q) := by
    simpa [f] using
      (dist_le_of_le_geometric_of_tendsto₀ q C hq1 hgeometric hηlim)
  have hsum : C ≤ S.card * δ := by
    dsimp [C]
    calc
      (∑ g ∈ S, ‖π g ξ - ξ‖) ≤ ∑ _g ∈ S, δ := by
        exact Finset.sum_le_sum fun g hg => (hsmall g hg).le
      _ = S.card * δ := by simp
  have hhalf : C < (1 - q) / 2 := by
    calc
      C ≤ S.card * δ := hsum
      _ < (1 - q) / 2 := by
        dsimp [δ]
        have hpos : 0 < (1 - q) := sub_pos.mpr hq1
        have hc : (S.card : ℝ) < (S.card : ℝ) + 1 := by linarith
        have hcpos : 0 < (S.card : ℝ) + 1 := by positivity
        rw [show (2 * (↑S.card + 1) : ℝ) =
          2 * ((S.card : ℝ) + 1) by norm_cast]
        calc
          (S.card : ℝ) *
              ((1 - q) / (2 * ((S.card : ℝ) + 1))) =
            ((1 - q) / 2) *
              ((S.card : ℝ) / ((S.card : ℝ) + 1)) := by
                field_simp
          _ < ((1 - q) / 2) * 1 := by
            apply mul_lt_mul_of_pos_left
              (div_lt_one hcpos |>.mpr hc)
            positivity
          _ = (1 - q) / 2 := mul_one _
  have hηne : η ≠ 0 := by
    intro hzero
    subst η
    have hone : dist ξ (0 : H) = 1 := by simpa using hξ
    rw [hone] at hdist
    have hden : 0 < 1 - q := sub_pos.mpr hq1
    have hlt : C / (1 - q) < 1 / 2 :=
      (div_lt_iff₀ hden).mpr (by nlinarith [hhalf])
    linarith
  exact ⟨η, hηne, hfixed η hηfixed⟩

def threeFiniteSubgroupGenerators
    {G : Type u} [Group G] (K : Fin 3 → Subgroup G)
    [∀ i, Fintype (K i)] : Finset G := by
  classical
  exact Finset.univ.biUnion fun i : Fin 3 =>
    Finset.univ.image fun g : K i => (g : G)

theorem mem_threeFiniteSubgroupGenerators
    {G : Type u} [Group G] (K : Fin 3 → Subgroup G)
    [∀ i, Fintype (K i)] (g : G) :
    g ∈ threeFiniteSubgroupGenerators K ↔ ∃ i : Fin 3, g ∈ K i := by
  classical
  simp [threeFiniteSubgroupGenerators]

def unitaryVectorStabilizer
    {G : Type u} {H : Type v} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : SoficGroups.UnitaryRepresentation G H)
    (x : H) : Subgroup G where
  carrier := {g : G | π g x = x}
  one_mem' := by simp
  mul_mem' := by
    intro g h hg hh
    change π g x = x at hg
    change π h x = x at hh
    change π (g * h) x = x
    simpa [map_mul, hh] using hg
  inv_mem' := by
    intro g hg
    change π g x = x at hg
    change π g⁻¹ x = x
    have h := congrArg (fun z : H => π g⁻¹ z) hg
    simpa [← map_mul] using h.symm

theorem hasPropertyT_of_three_finite_subgroups_geometric
    {G : Type u} [Group G]
    (K : Fin 3 → Subgroup G) [∀ i, Fintype (K i)]
    (hgen : (⨆ i : Fin 3, K i) = ⊤)
    (q : ℝ) (hq : q < 1)
    (haverage :
      ∀ (H : Type v) [NormedAddCommGroup H] [InnerProductSpace ℂ H]
        [CompleteSpace H] (π : SoficGroups.UnitaryRepresentation G H),
        ∃ A : H →L[ℂ] H,
          (∀ (x : H) (n : ℕ),
            dist ((A : H → H)^[n] x)
                ((A : H → H)^[n + 1] x) ≤
              (∑ g ∈ threeFiniteSubgroupGenerators K,
                ‖π g x - x‖) * q ^ n) ∧
          (∀ x : H, A x = x →
            ∀ (i : Fin 3) (g : K i), π (g : G) x = x)) :
    SoficGroups.HasPropertyT.{u, v} G := by
  apply hasPropertyT_of_geometric_finite_averaging
    (threeFiniteSubgroupGenerators K) q hq
  intro H _ _ _ π
  obtain ⟨A, hstep, hfixed⟩ := haverage H π
  refine ⟨A, hstep, ?_⟩
  intro x hx g
  have hK : ∀ i : Fin 3,
      K i ≤ unitaryVectorStabilizer π x := by
    intro i k hk
    exact hfixed x hx i ⟨k, hk⟩
  have htop : (⊤ : Subgroup G) ≤ unitaryVectorStabilizer π x := by
    rw [← hgen]
    exact iSup_le hK
  exact htop (show g ∈ (⊤ : Subgroup G) from Subgroup.mem_top g)

theorem inv_sqrt_eight_pos : 0 < (Real.sqrt (8 : ℝ))⁻¹ := by
  positivity

theorem inv_sqrt_eight_lt_one_half :
    (Real.sqrt (8 : ℝ))⁻¹ < (1 / 2 : ℝ) := by
  have hsqrt : 2 < Real.sqrt (8 : ℝ) := by
    have hsq := Real.sq_sqrt (show (0 : ℝ) ≤ 8 by norm_num)
    have hnonneg := Real.sqrt_nonneg (8 : ℝ)
    nlinarith
  simpa [one_div] using
    (one_div_lt_one_div_of_lt (show (0 : ℝ) < 2 by norm_num) hsqrt)

theorem norm_inner_le_inv_sqrt_eight_of_sq
    {H : Type v} [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (a b : H)
    (h : 8 * ‖inner ℂ a b‖ ^ 2 ≤ ‖a‖ ^ 2 * ‖b‖ ^ 2) :
    ‖inner ℂ a b‖ ≤
      (Real.sqrt (8 : ℝ))⁻¹ * ‖a‖ * ‖b‖ := by
  have hsqrt : 0 < Real.sqrt (8 : ℝ) := by positivity
  have hsquare : Real.sqrt (8 : ℝ) ^ 2 = 8 :=
    Real.sq_sqrt (by norm_num)
  have hsq :
      ‖inner ℂ a b‖ ^ 2 ≤
        ((Real.sqrt (8 : ℝ))⁻¹ * ‖a‖ * ‖b‖) ^ 2 := by
    calc
      ‖inner ℂ a b‖ ^ 2 ≤
          (‖a‖ ^ 2 * ‖b‖ ^ 2) / 8 := by
            apply (le_div_iff₀ (show (0 : ℝ) < 8 by norm_num)).mpr
            nlinarith
      _ = ((Real.sqrt (8 : ℝ))⁻¹ * ‖a‖ * ‖b‖) ^ 2 := by
        field_simp
        nlinarith
  exact (sq_le_sq₀ (norm_nonneg _) (by positivity)).mp hsq

theorem hasPropertyT_of_three_finite_subgroups_friedrichs_angle
    {G : Type u} [Group G]
    (K : Fin 3 → Subgroup G) [∀ i, Fintype (K i)]
    (hgen : (⨆ i : Fin 3, K i) = ⊤)
    (c : ℝ) (hc : 0 ≤ c) (hchalf : c < (1 / 2 : ℝ))
    (hangle :
      ∀ (H : Type v) [NormedAddCommGroup H]
        [InnerProductSpace ℂ H] [CompleteSpace H]
        (π : SoficGroups.UnitaryRepresentation G H)
        (i j : Fin 3), i ≠ j →
        ∀ (a b : H),
          a ∈ SoficGroups.ejUnitaryFixedSubmodule π (K i) →
          a ∈ (SoficGroups.ejUnitaryFixedSubmodule π (K i) ⊓
            SoficGroups.ejUnitaryFixedSubmodule π (K j))ᗮ →
          b ∈ SoficGroups.ejUnitaryFixedSubmodule π (K j) →
          b ∈ (SoficGroups.ejUnitaryFixedSubmodule π (K i) ⊓
            SoficGroups.ejUnitaryFixedSubmodule π (K j))ᗮ →
            ‖inner ℂ a b‖ ≤ c * ‖a‖ * ‖b‖) :
    SoficGroups.HasPropertyT.{u, v} G := by
  classical
  let q : ℝ := 1 - (1 - 2 * c) / 6
  have hq : q < 1 := by
    dsimp [q]
    linarith
  have hqnonneg : 0 ≤ q := by
    dsimp [q]
    linarith
  apply hasPropertyT_of_three_finite_subgroups_geometric K hgen q hq
  intro H _ _ _ π
  let V : Fin 3 → Submodule ℂ H :=
    fun i => SoficGroups.ejUnitaryFixedSubmodule π (K i)
  letI : ∀ i : Fin 3, (V i).HasOrthogonalProjection := fun i => by
    dsimp [V]
    infer_instance
  letI : ∀ i j : Fin 3,
      (V i ⊓ V j).HasOrthogonalProjection := fun i j => by
    dsimp [V]
    infer_instance
  refine ⟨SoficGroups.ejThreeProjectionAverage V, ?_, ?_⟩
  · intro x n
    let T : ℝ := ∑ g ∈ threeFiniteSubgroupGenerators K,
      ‖π g x - x‖
    have hT : 0 ≤ T := by
      dsimp [T]
      positivity
    have hpoint (i : Fin 3) (k : K i) :
        ‖π (k : G) x - x‖ ≤ T := by
      dsimp [T]
      exact Finset.single_le_sum
        (s := threeFiniteSubgroupGenerators K)
        (f := fun g : G => ‖π g x - x‖)
        (fun g _ => norm_nonneg _)
        ((mem_threeFiniteSubgroupGenerators K (k : G)).mpr
          ⟨i, k.property⟩)
    have havgbound (i : Fin 3) :
        ‖finiteUnitarySubgroupAverage π (K i) x - x‖ ≤ T := by
      calc
        ‖finiteUnitarySubgroupAverage π (K i) x - x‖ ≤
            (Fintype.card (K i) : ℝ)⁻¹ *
              ∑ k : K i, ‖π (k : G) x - x‖ :=
          norm_finiteUnitarySubgroupAverage_sub_le π (K i) x
        _ ≤ (Fintype.card (K i) : ℝ)⁻¹ *
              ∑ _k : K i, T := by
          apply mul_le_mul_of_nonneg_left
          · exact Finset.sum_le_sum fun k _ => hpoint i k
          · positivity
        _ = T := by
          have hcard : (Fintype.card (K i) : ℝ) ≠ 0 := by
            exact_mod_cast Fintype.card_ne_zero
          simp [hcard]
    have hres (i : Fin 3) :
        ‖SoficGroups.ejResidualProjection (V i) x‖ ≤ T := by
      rw [SoficGroups.ejResidualProjection_apply]
      apply le_trans
        (norm_sub_starProjection_le_finiteUnitarySubgroupAverage
          π (K i) (V i) x ?_)
        (havgbound i)
      exact (SoficGroups.mem_ejUnitaryFixedSubmodule π (K i) _).mpr
        (finiteUnitarySubgroupAverage_fixed π (K i) x)
    have hfullangle : ∀ (i j : Fin 3) (a b : H),
        a ∈ V i → a ∈ (V i ⊓ V j)ᗮ →
        b ∈ V j → b ∈ (V i ⊓ V j)ᗮ →
          ‖inner ℂ a b‖ ≤ c * ‖a‖ * ‖b‖ := by
      intro i j a b ha haorth hb hborth
      by_cases hij : i = j
      · subst j
        have hazero : a = 0 :=
          inner_self_eq_zero.mp (haorth a ⟨ha, ha⟩)
        simp [hazero]
      · exact hangle H π i j hij a b ha haorth hb hborth
    calc
      dist (((SoficGroups.ejThreeProjectionAverage V : H → H)^[n]) x)
          (((SoficGroups.ejThreeProjectionAverage V : H → H)^[n + 1]) x)
          ≤ Real.sqrt (SoficGroups.ejThreeResidualEnergy V x / 3) *
              (1 - (1 - 2 * c) / 6) ^ n :=
        SoficGroups.ejThreeProjectionAverage_iterate_dist_le_of_pair_angles
          V c hc hchalf hfullangle x n
      _ ≤ T * q ^ n := by
        change Real.sqrt (SoficGroups.ejThreeResidualEnergy V x / 3) *
          q ^ n ≤ T * q ^ n
        exact mul_le_mul_of_nonneg_right
          (SoficGroups.ejThreeResidualEnergy_sqrt_div_three_le
            V x T hT hres)
          (pow_nonneg hqnonneg n)
      _ = (∑ g ∈ threeFiniteSubgroupGenerators K,
            ‖π g x - x‖) * q ^ n := by
        rfl
  · intro x hx i k
    have hxmem : x ∈ V i :=
      SoficGroups.ejThreeProjectionAverage_fixed_mem V x hx i
    exact (SoficGroups.mem_ejUnitaryFixedSubmodule π (K i) x).mp
      hxmem k

end ErshovJaikinFiniteSpectral

section

open scoped BigOperators commutatorElement

abbrev finiteBlockGaloisField : Type := GaloisField 2 3

def finiteBlockGaloisBasis :
    Module.Basis (Fin 3) (ZMod 2) finiteBlockGaloisField :=
  Module.finBasisOfFinrankEq (ZMod 2) finiteBlockGaloisField
    (GaloisField.finrank 2 (by decide))

def finiteBlockGaloisMatrix :
    finiteBlockGaloisField →ₐ[ZMod 2]
      Matrix (Fin 3) (Fin 3) (ZMod 2) :=
  Algebra.leftMulMatrix finiteBlockGaloisBasis

theorem finiteBlockGaloisField_natCard :
    Nat.card finiteBlockGaloisField = 8 := by
  simpa using (GaloisField.card 2 3 (by decide))

def finiteBlockGaloisMatrixOver (R : Type*) [Ring R]
    [Algebra (ZMod 2) R] :
    finiteBlockGaloisField →+* Matrix (Fin 3) (Fin 3) R :=
  (RingHom.mapMatrix (algebraMap (ZMod 2) R)).comp
    finiteBlockGaloisMatrix.toRingHom

section ActualBlockRoots

variable {R : Type*} [Ring R] [Algebra (ZMod 2) R]

theorem finiteBlockCoefficientMatrix_mul_binary_mem
    (W : Submodule (ZMod 2) R)
    (A : Matrix (Fin 3) (Fin 3) R)
    (hA : ∀ i j, A i j ∈ W)
    (B : Matrix (Fin 3) (Fin 3) (ZMod 2)) :
    ∀ i j,
      (A * RingHom.mapMatrix (algebraMap (ZMod 2) R) B) i j ∈ W := by
  intro i j
  rw [Matrix.mul_apply]
  apply Submodule.sum_mem
  intro k _
  rw [RingHom.mapMatrix_apply, Matrix.map_apply]
  rw [← Algebra.commutes, ← Algebra.smul_def]
  exact W.smul_mem (B k j) (hA i k)

theorem finiteBlockCoefficientMatrix_binary_mul_mem
    (W : Submodule (ZMod 2) R)
    (A : Matrix (Fin 3) (Fin 3) R)
    (hA : ∀ i j, A i j ∈ W)
    (B : Matrix (Fin 3) (Fin 3) (ZMod 2)) :
    ∀ i j,
      (RingHom.mapMatrix (algebraMap (ZMod 2) R) B * A) i j ∈ W := by
  intro i j
  rw [Matrix.mul_apply]
  apply Submodule.sum_mem
  intro k _
  rw [RingHom.mapMatrix_apply, Matrix.map_apply, ← Algebra.smul_def]
  exact W.smul_mem (B i k) (hA k j)

theorem finiteBlockCoefficientMatrix_mul_galois_mem
    (W : Submodule (ZMod 2) R)
    (A : Matrix (Fin 3) (Fin 3) R)
    (hA : ∀ i j, A i j ∈ W)
    (t : finiteBlockGaloisField) :
    ∀ i j, (A * finiteBlockGaloisMatrixOver R t) i j ∈ W := by
  change ∀ i j,
    (A * RingHom.mapMatrix (algebraMap (ZMod 2) R)
      (finiteBlockGaloisMatrix t)) i j ∈ W
  exact finiteBlockCoefficientMatrix_mul_binary_mem W A hA
    (finiteBlockGaloisMatrix t)

theorem finiteBlockCoefficientMatrix_galois_mul_mem
    (W : Submodule (ZMod 2) R)
    (A : Matrix (Fin 3) (Fin 3) R)
    (hA : ∀ i j, A i j ∈ W)
    (t : finiteBlockGaloisField) :
    ∀ i j, (finiteBlockGaloisMatrixOver R t * A) i j ∈ W := by
  change ∀ i j,
    (RingHom.mapMatrix (algebraMap (ZMod 2) R)
      (finiteBlockGaloisMatrix t) * A) i j ∈ W
  exact finiteBlockCoefficientMatrix_binary_mul_mem W A hA
    (finiteBlockGaloisMatrix t)

def finiteBlockCoefficientMatrixHom
    (W : Submodule (ZMod 2) R) :
    Matrix (Fin 3) (Fin 3) W →+
      Matrix (Fin 3) (Fin 3) R :=
  W.subtype.toAddMonoidHom.mapMatrix

def finiteOuterBlockRootHom
    (W : Submodule (ZMod 2) R) (i j : Fin 3) (hij : i ≠ j) :
    Multiplicative (Matrix (Fin 3) (Fin 3) W) →*
      elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R) :=
  (elementaryRootHom (R := Matrix (Fin 3) (Fin 3) R) i j hij).comp
    (finiteBlockCoefficientMatrixHom W).toMultiplicative

def finiteOuterBlockRootSubgroup
    (W : Submodule (ZMod 2) R) (i j : Fin 3) (hij : i ≠ j) :
    Subgroup (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) :=
  (finiteOuterBlockRootHom W i j hij).range

theorem finite_finiteOuterBlockRootSubgroup
    (W : Submodule (ZMod 2) R) [Finite W]
    (i j : Fin 3) (hij : i ≠ j) :
    Finite (finiteOuterBlockRootSubgroup W i j hij) := by
  let f : Multiplicative (Matrix (Fin 3) (Fin 3) W) →
      finiteOuterBlockRootSubgroup W i j hij :=
    fun x => ⟨finiteOuterBlockRootHom W i j hij x, ⟨x, rfl⟩⟩
  apply Finite.of_surjective f
  intro x
  obtain ⟨a, ha⟩ := x.property
  exact ⟨a, Subtype.ext ha⟩

omit [Algebra (ZMod 2) R] in

theorem finiteOuterElementaryRoot_commutator
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (A B : Matrix (Fin 3) (Fin 3) R) :
    ⁅elementaryRootHom i j hij (Multiplicative.ofAdd A),
      elementaryRootHom j k hjk (Multiplicative.ofAdd B)⁆ =
      elementaryRootHom i k hik (Multiplicative.ofAdd (A * B)) := by
  apply Subtype.ext
  exact elementaryUnit_commutator i j k hij hjk hik A B

omit [Algebra (ZMod 2) R] in

theorem finiteOuterElementaryRoot_conjugate_by_successor
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (A B : Matrix (Fin 3) (Fin 3) R) :
    let x := elementaryRootHom i j hij (Multiplicative.ofAdd A)
    let y := elementaryRootHom j k hjk (Multiplicative.ofAdd B)
    let z := elementaryRootHom i k hik (Multiplicative.ofAdd (A * B))
    y * x * y⁻¹ = z⁻¹ * x := by
  dsimp
  rw [← finiteOuterElementaryRoot_commutator i j k hij hjk hik A B]
  simp only [commutatorElement_def]
  group

omit [Algebra (ZMod 2) R] in

theorem finiteOuterElementaryUnit_commute_of_nonadjacent
    (i j k l : Fin 3) (hij : i ≠ j) (hkl : k ≠ l)
    (hjk : j ≠ k) (hli : l ≠ i)
    (A B : Matrix (Fin 3) (Fin 3) R) :
    Commute (elementaryUnit i j hij A) (elementaryUnit k l hkl B) := by
  apply Units.ext
  change
    (1 + Matrix.single i j A) * (1 + Matrix.single k l B) =
      (1 + Matrix.single k l B) * (1 + Matrix.single i j A)
  have hAB : Matrix.single i j A * Matrix.single k l B = 0 :=
    Matrix.single_mul_single_of_ne (c := A) i j k hjk B
  have hBA : Matrix.single k l B * Matrix.single i j A = 0 :=
    Matrix.single_mul_single_of_ne (c := B) k l i hli A
  noncomm_ring [hAB, hBA]

omit [Algebra (ZMod 2) R] in

theorem finiteOuterElementaryRoot_commute_of_nonadjacent
    (i j k l : Fin 3) (hij : i ≠ j) (hkl : k ≠ l)
    (hjk : j ≠ k) (hli : l ≠ i)
    (A B : Matrix (Fin 3) (Fin 3) R) :
    Commute
      (elementaryRootHom i j hij (Multiplicative.ofAdd A))
      (elementaryRootHom k l hkl (Multiplicative.ofAdd B)) := by
  apply Subtype.ext
  exact (finiteOuterElementaryUnit_commute_of_nonadjacent
    i j k l hij hkl hjk hli A B).eq

omit [Algebra (ZMod 2) R] in

theorem finiteOuterElementaryRoot_commute_same
    (i j : Fin 3) (hij : i ≠ j)
    (A B : Matrix (Fin 3) (Fin 3) R) :
    Commute
      (elementaryRootHom i j hij (Multiplicative.ofAdd A))
      (elementaryRootHom i j hij (Multiplicative.ofAdd B)) := by
  change
    elementaryRootHom i j hij (Multiplicative.ofAdd A) *
      elementaryRootHom i j hij (Multiplicative.ofAdd B) =
    elementaryRootHom i j hij (Multiplicative.ofAdd B) *
      elementaryRootHom i j hij (Multiplicative.ofAdd A)
  calc
    _ = elementaryRootHom i j hij
        (Multiplicative.ofAdd A * Multiplicative.ofAdd B) :=
      (map_mul (elementaryRootHom i j hij)
        (Multiplicative.ofAdd A) (Multiplicative.ofAdd B)).symm
    _ = elementaryRootHom i j hij
        (Multiplicative.ofAdd B * Multiplicative.ofAdd A) := by
      rw [mul_comm]
    _ = _ := map_mul (elementaryRootHom i j hij)
      (Multiplicative.ofAdd B) (Multiplicative.ofAdd A)

def finiteBlockCoefficientMatrixRightMul
    (W : Submodule (ZMod 2) R)
    (B : Matrix (Fin 3) (Fin 3) W) :
    Matrix (Fin 3) (Fin 3) W →+
      Matrix (Fin 3) (Fin 3) R where
  toFun A :=
    finiteBlockCoefficientMatrixHom W A *
      finiteBlockCoefficientMatrixHom W B
  map_zero' := by simp
  map_add' A C := by simp [add_mul]

def finiteOuterBlockProductCentralRootHom
    (W : Submodule (ZMod 2) R)
    (i k : Fin 3) (hik : i ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W) :
    Multiplicative (Matrix (Fin 3) (Fin 3) W) →*
      elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R) :=
  (elementaryRootHom
    (R := Matrix (Fin 3) (Fin 3) R) i k hik).comp
      (finiteBlockCoefficientMatrixRightMul W B).toMultiplicative

def finiteOuterBlockProductCentralRootSubgroup
    (W : Submodule (ZMod 2) R)
    (i k : Fin 3) (hik : i ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W) :
    Subgroup (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) :=
  (finiteOuterBlockProductCentralRootHom W i k hik B).range

theorem finiteOuterBlockRoot_commutator_mem_productCentral
    (W : Submodule (ZMod 2) R)
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (A B : Matrix (Fin 3) (Fin 3) W) :
    ⁅finiteOuterBlockRootHom W i j hij (Multiplicative.ofAdd A),
      finiteOuterBlockRootHom W j k hjk (Multiplicative.ofAdd B)⁆ ∈
      finiteOuterBlockProductCentralRootSubgroup W i k hik B := by
  refine ⟨Multiplicative.ofAdd A, ?_⟩
  change
    elementaryRootHom i k hik
      (Multiplicative.ofAdd
        (finiteBlockCoefficientMatrixHom W A *
          finiteBlockCoefficientMatrixHom W B)) =
      ⁅elementaryRootHom i j hij
        (Multiplicative.ofAdd (finiteBlockCoefficientMatrixHom W A)),
       elementaryRootHom j k hjk
        (Multiplicative.ofAdd (finiteBlockCoefficientMatrixHom W B))⁆
  exact (finiteOuterElementaryRoot_commutator i j k hij hjk hik
    (finiteBlockCoefficientMatrixHom W A)
    (finiteBlockCoefficientMatrixHom W B)).symm

theorem finiteOuterBlockRoot_commutator_exists_productCentral
    (W : Submodule (ZMod 2) R)
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (x y : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))
    (hx : x ∈ finiteOuterBlockRootSubgroup W i j hij)
    (hy : y ∈ finiteOuterBlockRootSubgroup W j k hjk) :
    ∃ B : Matrix (Fin 3) (Fin 3) W,
      ⁅x, y⁆ ∈ finiteOuterBlockProductCentralRootSubgroup W i k hik B := by
  obtain ⟨A, rfl⟩ := hx
  obtain ⟨B, rfl⟩ := hy
  exact ⟨B.toAdd,
    finiteOuterBlockRoot_commutator_mem_productCentral
      W i j k hij hjk hik A.toAdd B.toAdd⟩

theorem finiteOuterBlockProductCentralRoot_commute_left
    (W : Submodule (ZMod 2) R)
    (i j k : Fin 3) (hij : i ≠ j) (hik : i ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W)
    (x z : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))
    (hx : x ∈ finiteOuterBlockRootSubgroup W i j hij)
    (hz : z ∈ finiteOuterBlockProductCentralRootSubgroup W i k hik B) :
    Commute x z := by
  obtain ⟨A, rfl⟩ := hx
  obtain ⟨C, rfl⟩ := hz
  exact finiteOuterElementaryRoot_commute_of_nonadjacent
    i j i k hij hik hij.symm hik.symm
    (finiteBlockCoefficientMatrixHom W A.toAdd)
    (finiteBlockCoefficientMatrixRightMul W B C.toAdd)

theorem finiteOuterBlockProductCentralRoot_commute_right
    (W : Submodule (ZMod 2) R)
    (i j k : Fin 3) (hjk : j ≠ k) (hik : i ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W)
    (y z : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))
    (hy : y ∈ finiteOuterBlockRootSubgroup W j k hjk)
    (hz : z ∈ finiteOuterBlockProductCentralRootSubgroup W i k hik B) :
    Commute y z := by
  obtain ⟨A, rfl⟩ := hy
  obtain ⟨C, rfl⟩ := hz
  exact finiteOuterElementaryRoot_commute_of_nonadjacent
    j k i k hjk hik hik.symm hjk.symm
    (finiteBlockCoefficientMatrixHom W A.toAdd)
    (finiteBlockCoefficientMatrixRightMul W B C.toAdd)

theorem finiteOuterBlockProductCentralRoot_pair_le_centralizer
    (W : Submodule (ZMod 2) R)
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W) :
    finiteOuterBlockRootSubgroup W i j hij ⊔
      finiteOuterBlockRootSubgroup W j k hjk ≤
      Subgroup.centralizer
        (finiteOuterBlockProductCentralRootSubgroup W i k hik B :
          Set (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))) := by
  apply sup_le
  · intro x hx
    rw [Subgroup.mem_centralizer_iff]
    intro z hz
    exact (finiteOuterBlockProductCentralRoot_commute_left
      W i j k hij hik B x z hx hz).symm.eq
  · intro y hy
    rw [Subgroup.mem_centralizer_iff]
    intro z hz
    exact (finiteOuterBlockProductCentralRoot_commute_right
      W i j k hjk hik B y z hy hz).symm.eq

theorem finiteOuterBlockProductCentralRoots_commute
    (W : Submodule (ZMod 2) R)
    (i k : Fin 3) (hik : i ≠ k)
    (B C : Matrix (Fin 3) (Fin 3) W)
    (z w : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))
    (hz : z ∈ finiteOuterBlockProductCentralRootSubgroup W i k hik B)
    (hw : w ∈ finiteOuterBlockProductCentralRootSubgroup W i k hik C) :
    Commute z w := by
  obtain ⟨A, rfl⟩ := hz
  obtain ⟨D, rfl⟩ := hw
  exact finiteOuterElementaryRoot_commute_same i k hik
    (finiteBlockCoefficientMatrixRightMul W B A.toAdd)
    (finiteBlockCoefficientMatrixRightMul W C D.toAdd)

def finiteBlockGaloisLeftProductCoefficientMatrix
    (W : Submodule (ZMod 2) R)
    (B : Matrix (Fin 3) (Fin 3) W)
    (t : finiteBlockGaloisField) :
    Matrix (Fin 3) (Fin 3) W :=
  fun p q =>
    ⟨(finiteBlockGaloisMatrixOver R t *
        finiteBlockCoefficientMatrixHom W B) p q,
      finiteBlockCoefficientMatrix_galois_mul_mem W
        (finiteBlockCoefficientMatrixHom W B)
        (fun i j => (B i j).property) t p q⟩

theorem finiteBlockCoefficientMatrixHom_galoisLeftProduct
    (W : Submodule (ZMod 2) R)
    (B : Matrix (Fin 3) (Fin 3) W)
    (t : finiteBlockGaloisField) :
    finiteBlockCoefficientMatrixHom W
      (finiteBlockGaloisLeftProductCoefficientMatrix W B t) =
      finiteBlockGaloisMatrixOver R t *
        finiteBlockCoefficientMatrixHom W B := by
  ext p q
  rfl

def finiteOuterBlockGaloisConjugatorWithCoefficient
    (W : Submodule (ZMod 2) R)
    (j k : Fin 3) (hjk : j ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W)
    (t : finiteBlockGaloisField) :
    elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R) :=
  elementaryRootHom j k hjk
    (Multiplicative.ofAdd
      (finiteBlockGaloisMatrixOver R t *
        finiteBlockCoefficientMatrixHom W B))

theorem finiteOuterBlockGaloisConjugatorWithCoefficient_mem
    (W : Submodule (ZMod 2) R)
    (j k : Fin 3) (hjk : j ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W)
    (t : finiteBlockGaloisField) :
    finiteOuterBlockGaloisConjugatorWithCoefficient W j k hjk B t ∈
      finiteOuterBlockRootSubgroup W j k hjk := by
  refine ⟨Multiplicative.ofAdd
    (finiteBlockGaloisLeftProductCoefficientMatrix W B t), ?_⟩
  change
    elementaryRootHom j k hjk
      (Multiplicative.ofAdd
        (finiteBlockCoefficientMatrixHom W
          (finiteBlockGaloisLeftProductCoefficientMatrix W B t))) =
      elementaryRootHom j k hjk
        (Multiplicative.ofAdd
          (finiteBlockGaloisMatrixOver R t *
            finiteBlockCoefficientMatrixHom W B))
  rw [finiteBlockCoefficientMatrixHom_galoisLeftProduct]

def finiteOuterBlockGaloisConjugateRootWithCoefficient
    (W : Submodule (ZMod 2) R)
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W)
    (t : finiteBlockGaloisField) :
    Subgroup (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) :=
  (finiteOuterBlockRootSubgroup W i j hij).map
    (MulAut.conj
      (finiteOuterBlockGaloisConjugatorWithCoefficient
        W j k hjk B t)).toMonoidHom

omit [Algebra (ZMod 2) R] in

theorem finiteOuterElementaryRootConjugates_commute
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (A C P Q : Matrix (Fin 3) (Fin 3) R) :
    Commute
      (MulAut.conj
        (elementaryRootHom j k hjk (Multiplicative.ofAdd P))
        (elementaryRootHom i j hij (Multiplicative.ofAdd A)))
      (MulAut.conj
        (elementaryRootHom j k hjk (Multiplicative.ofAdd Q))
        (elementaryRootHom i j hij (Multiplicative.ofAdd C))) := by
  rw [MulAut.conj_apply, MulAut.conj_apply,
    finiteOuterElementaryRoot_conjugate_by_successor
      i j k hij hjk hik A P,
    finiteOuterElementaryRoot_conjugate_by_successor
      i j k hij hjk hik C Q]
  have hzz := finiteOuterElementaryRoot_commute_same
    i k hik (A * P) (C * Q)
  have hzx := finiteOuterElementaryRoot_commute_of_nonadjacent
    i k i j hik hij hik.symm hij.symm (A * P) C
  have hxz := finiteOuterElementaryRoot_commute_of_nonadjacent
    i j i k hij hik hij.symm hik.symm A (C * Q)
  have hxx := finiteOuterElementaryRoot_commute_same i j hij A C
  exact (hzz.inv_inv.mul_right hzx.inv_left).mul_left
    (hxz.inv_right.mul_right hxx)

theorem finiteOuterBlockGaloisConjugateRootsWithCoefficient_commute
    (W : Submodule (ZMod 2) R)
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W)
    (s t : finiteBlockGaloisField)
    (x y : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))
    (hx : x ∈ finiteOuterBlockGaloisConjugateRootWithCoefficient
      W i j k hij hjk B s)
    (hy : y ∈ finiteOuterBlockGaloisConjugateRootWithCoefficient
      W i j k hij hjk B t) :
    Commute x y := by
  obtain ⟨_, ⟨A, rfl⟩, rfl⟩ := hx
  obtain ⟨_, ⟨C, rfl⟩, rfl⟩ := hy
  exact finiteOuterElementaryRootConjugates_commute
    i j k hij hjk hik
    (finiteBlockCoefficientMatrixHom W A.toAdd)
    (finiteBlockCoefficientMatrixHom W C.toAdd)
    (finiteBlockGaloisMatrixOver R s *
      finiteBlockCoefficientMatrixHom W B)
    (finiteBlockGaloisMatrixOver R t *
      finiteBlockCoefficientMatrixHom W B)

def finiteBlockGaloisRightInverseCoefficientMatrix
    (W : Submodule (ZMod 2) R)
    (A : Matrix (Fin 3) (Fin 3) W)
    (s t : finiteBlockGaloisField) :
    Matrix (Fin 3) (Fin 3) W :=
  fun p q =>
    ⟨(finiteBlockCoefficientMatrixHom W A *
        finiteBlockGaloisMatrixOver R (t - s)⁻¹) p q,
      finiteBlockCoefficientMatrix_mul_galois_mem W
        (finiteBlockCoefficientMatrixHom W A)
        (fun i j => (A i j).property) (t - s)⁻¹ p q⟩

theorem finiteBlockCoefficientMatrixHom_galoisRightInverse
    (W : Submodule (ZMod 2) R)
    (A : Matrix (Fin 3) (Fin 3) W)
    (s t : finiteBlockGaloisField) :
    finiteBlockCoefficientMatrixHom W
      (finiteBlockGaloisRightInverseCoefficientMatrix W A s t) =
      finiteBlockCoefficientMatrixHom W A *
        finiteBlockGaloisMatrixOver R (t - s)⁻¹ := by
  ext p q
  rfl

theorem finiteBlockGalois_right_inverse_difference
    (s t : finiteBlockGaloisField) (hst : s ≠ t)
    (C : Matrix (Fin 3) (Fin 3) R) :
    (C * finiteBlockGaloisMatrixOver R (t - s)⁻¹) *
        finiteBlockGaloisMatrixOver R t -
      (C * finiteBlockGaloisMatrixOver R (t - s)⁻¹) *
        finiteBlockGaloisMatrixOver R s = C := by
  rw [← mul_sub, ← map_sub, mul_assoc, ← map_mul,
    inv_mul_cancel₀ (sub_ne_zero.mpr hst.symm), map_one, mul_one]

theorem finiteOuterBlockProductCentralRoot_le_galoisConjugates
    (W : Submodule (ZMod 2) R)
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W)
    (s t : finiteBlockGaloisField) (hst : s ≠ t) :
    finiteOuterBlockProductCentralRootSubgroup W i k hik B ≤
      finiteOuterBlockGaloisConjugateRootWithCoefficient
          W i j k hij hjk B s ⊔
        finiteOuterBlockGaloisConjugateRootWithCoefficient
          W i j k hij hjk B t := by
  intro z hz
  obtain ⟨A, rfl⟩ := hz
  let D : Matrix (Fin 3) (Fin 3) W :=
    finiteBlockGaloisRightInverseCoefficientMatrix W A.toAdd s t
  let x : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R) :=
    finiteOuterBlockRootHom W i j hij (Multiplicative.ofAdd D)
  let ys : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R) :=
    finiteOuterBlockGaloisConjugatorWithCoefficient W j k hjk B s
  let yt : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R) :=
    finiteOuterBlockGaloisConjugatorWithCoefficient W j k hjk B t
  let J : Subgroup (elementaryGroup (Fin 3)
      (Matrix (Fin 3) (Fin 3) R)) :=
    finiteOuterBlockGaloisConjugateRootWithCoefficient
        W i j k hij hjk B s ⊔
      finiteOuterBlockGaloisConjugateRootWithCoefficient
        W i j k hij hjk B t
  have hx : x ∈ finiteOuterBlockRootSubgroup W i j hij :=
    ⟨Multiplicative.ofAdd D, rfl⟩
  have hs : MulAut.conj ys x ∈
      finiteOuterBlockGaloisConjugateRootWithCoefficient
        W i j k hij hjk B s :=
    ⟨x, hx, rfl⟩
  have ht : MulAut.conj yt x ∈
      finiteOuterBlockGaloisConjugateRootWithCoefficient
        W i j k hij hjk B t :=
    ⟨x, hx, rfl⟩
  have hprod : MulAut.conj ys x * (MulAut.conj yt x)⁻¹ ∈ J :=
    J.mul_mem (Subgroup.mem_sup_left hs)
      (J.inv_mem (Subgroup.mem_sup_right ht))
  let C₀ : Matrix (Fin 3) (Fin 3) R :=
    finiteBlockCoefficientMatrixHom W A.toAdd
  let B₀ : Matrix (Fin 3) (Fin 3) R :=
    finiteBlockCoefficientMatrixHom W B
  let D₀ : Matrix (Fin 3) (Fin 3) R :=
    finiteBlockCoefficientMatrixHom W D
  let P : Matrix (Fin 3) (Fin 3) R :=
    finiteBlockGaloisMatrixOver R s * B₀
  let Q : Matrix (Fin 3) (Fin 3) R :=
    finiteBlockGaloisMatrixOver R t * B₀
  have hD : D₀ = C₀ * finiteBlockGaloisMatrixOver R (t - s)⁻¹ :=
    finiteBlockCoefficientMatrixHom_galoisRightInverse W A.toAdd s t
  have hdiff : - (D₀ * P) + D₀ * Q = C₀ * B₀ := by
    calc
      - (D₀ * P) + D₀ * Q =
          (D₀ * finiteBlockGaloisMatrixOver R t -
            D₀ * finiteBlockGaloisMatrixOver R s) * B₀ := by
        dsimp [P, Q]
        noncomm_ring
      _ = C₀ * B₀ := by
        rw [hD, finiteBlockGalois_right_inverse_difference s t hst C₀]
  have hroot :
      (elementaryRootHom i k hik (Multiplicative.ofAdd (D₀ * P)))⁻¹ *
        elementaryRootHom i k hik (Multiplicative.ofAdd (D₀ * Q)) =
      finiteOuterBlockProductCentralRootHom W i k hik B A := by
    calc
      _ = elementaryRootHom i k hik
          ((Multiplicative.ofAdd (D₀ * P))⁻¹ *
            Multiplicative.ofAdd (D₀ * Q)) := by
        simp only [map_mul, map_inv]
      _ = elementaryRootHom i k hik
          (Multiplicative.ofAdd (C₀ * B₀)) := by
        congr 1
      _ = finiteOuterBlockProductCentralRootHom W i k hik B A := by
        rfl
  change
    MulAut.conj
        (elementaryRootHom j k hjk (Multiplicative.ofAdd P))
        (elementaryRootHom i j hij (Multiplicative.ofAdd D₀)) *
      (MulAut.conj
        (elementaryRootHom j k hjk (Multiplicative.ofAdd Q))
        (elementaryRootHom i j hij (Multiplicative.ofAdd D₀)))⁻¹ ∈ J
    at hprod
  simp only [MulAut.conj_apply] at hprod
  rw [finiteOuterElementaryRoot_conjugate_by_successor
        i j k hij hjk hik D₀ P,
      finiteOuterElementaryRoot_conjugate_by_successor
        i j k hij hjk hik D₀ Q] at hprod
  have hcancel :
      ((elementaryRootHom i k hik (Multiplicative.ofAdd (D₀ * P)))⁻¹ *
        elementaryRootHom i j hij (Multiplicative.ofAdd D₀)) *
        ((elementaryRootHom i k hik (Multiplicative.ofAdd (D₀ * Q)))⁻¹ *
          elementaryRootHom i j hij (Multiplicative.ofAdd D₀))⁻¹ =
      (elementaryRootHom i k hik (Multiplicative.ofAdd (D₀ * P)))⁻¹ *
        elementaryRootHom i k hik (Multiplicative.ofAdd (D₀ * Q)) := by
    group
  rw [hcancel, hroot] at hprod
  exact hprod

end ActualBlockRoots

universe u₁ v₁

def UnitaryRepresentation.toRepresentation
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) : Representation ℂ G H where
  toFun g := (π g).toLinearEquiv.toLinearMap
  map_one' := by
    ext x
    simp
  map_mul' g h := by
    ext x
    simp [map_mul, Module.End.mul_apply]

def unitaryFixedSubmodule
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) : Submodule ℂ H :=
  Representation.invariants (π.toRepresentation.comp K.subtype)

@[simp] theorem mem_unitaryFixedSubmodule
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) (x : H) :
    x ∈ unitaryFixedSubmodule π K ↔ ∀ g : K, π (g : G) x = x :=
  Iff.rfl

def unitaryVectorStabilizer
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (x : H) : Subgroup G where
  carrier := {g : G | π g x = x}
  one_mem' := by simp
  mul_mem' := by
    intro g h hg hh
    change π g x = x at hg
    change π h x = x at hh
    change π (g * h) x = x
    simpa [map_mul, hh] using hg
  inv_mem' := by
    intro g hg
    change π g x = x at hg
    change π g⁻¹ x = x
    have heq := congrArg (fun y : H => π g⁻¹ y) hg
    simpa [← map_mul] using heq.symm

theorem unitaryFixedSubmodule_sup
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (K J : Subgroup G) :
    unitaryFixedSubmodule π (K ⊔ J) =
      unitaryFixedSubmodule π K ⊓ unitaryFixedSubmodule π J := by
  ext x
  constructor
  · intro hx
    refine ⟨?_, ?_⟩
    · change x ∈ unitaryFixedSubmodule π K
      rw [mem_unitaryFixedSubmodule]
      intro k
      exact (mem_unitaryFixedSubmodule π (K ⊔ J) x).mp hx
        ⟨k, Subgroup.mem_sup_left k.property⟩
    · change x ∈ unitaryFixedSubmodule π J
      rw [mem_unitaryFixedSubmodule]
      intro j
      exact (mem_unitaryFixedSubmodule π (K ⊔ J) x).mp hx
        ⟨j, Subgroup.mem_sup_right j.property⟩
  · rintro ⟨hxK, hxJ⟩
    have hK : K ≤ unitaryVectorStabilizer π x := by
      intro k hk
      exact (mem_unitaryFixedSubmodule π K x).mp hxK ⟨k, hk⟩
    have hJ : J ≤ unitaryVectorStabilizer π x := by
      intro j hj
      exact (mem_unitaryFixedSubmodule π J x).mp hxJ ⟨j, hj⟩
    rw [mem_unitaryFixedSubmodule]
    intro g
    exact (sup_le hK hJ) g.property

theorem unitaryFixedSubmodule_isClosed
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) :
    IsClosed (unitaryFixedSubmodule π K : Set H) := by
  have hset :
      (unitaryFixedSubmodule π K : Set H) =
        ⋂ g : K, {x : H | π (g : G) x = x} := by
    ext x
    simp
  rw [hset]
  exact isClosed_iInter fun g =>
    isClosed_eq (π (g : G)).continuous continuous_id

instance unitaryFixedSubmodule_completeSpace
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] [CompleteSpace H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) :
    CompleteSpace (unitaryFixedSubmodule π K) :=
  (unitaryFixedSubmodule_isClosed π K).isComplete.completeSpace_coe

theorem unitaryFixedSubmodule_map_of_centralizes
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) (g : G)
    (hg : ∀ k : K, Commute g (k : G)) :
    (unitaryFixedSubmodule π K).map (π g).toLinearEquiv.toLinearMap =
      unitaryFixedSubmodule π K := by
  ext z
  constructor
  · rintro ⟨x, hx, rfl⟩
    rw [mem_unitaryFixedSubmodule]
    intro k
    have hk := (mem_unitaryFixedSubmodule π K x).mp hx k
    calc
      π (k : G) (π g x) = π ((k : G) * g) x := by simp [map_mul]
      _ = π (g * (k : G)) x := by rw [(hg k).eq]
      _ = π g (π (k : G) x) := by simp [map_mul]
      _ = π g x := by rw [hk]
  · intro hz
    refine ⟨π g⁻¹ z, ?_, ?_⟩
    · change π g⁻¹ z ∈ unitaryFixedSubmodule π K
      rw [mem_unitaryFixedSubmodule]
      intro k
      have hk := (mem_unitaryFixedSubmodule π K z).mp hz k
      calc
        π (k : G) (π g⁻¹ z) = π ((k : G) * g⁻¹) z := by simp [map_mul]
        _ = π (g⁻¹ * (k : G)) z := by rw [(hg k).inv_left.eq]
        _ = π g⁻¹ (π (k : G) z) := by simp [map_mul]
        _ = π g⁻¹ z := by rw [hk]
    · simp

theorem unitaryFixedSubmodule_starProjection_commute
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] [CompleteSpace H]
    (π : UnitaryRepresentation G H) (K : Subgroup G) (g : G)
    (hg : ∀ k : K, Commute g (k : G)) (x : H) :
    (unitaryFixedSubmodule π K).starProjection (π g x) =
      π g ((unitaryFixedSubmodule π K).starProjection x) := by
  letI : CompleteSpace (unitaryFixedSubmodule π K) :=
    unitaryFixedSubmodule_completeSpace π K
  have hmap := unitaryFixedSubmodule_map_of_centralizes π K g hg
  simpa [hmap] using
    Submodule.starProjection_map_apply (π g)
      (unitaryFixedSubmodule π K) (π g x)

theorem unitaryFixedSubmodule_starProjection_mem_of_commute
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] [CompleteSpace H]
    (π : UnitaryRepresentation G H) (K J : Subgroup G)
    (hcomm : ∀ k : K, ∀ j : J, Commute (k : G) (j : G))
    {x : H} (hx : x ∈ unitaryFixedSubmodule π J) :
    (unitaryFixedSubmodule π K).starProjection x ∈
      unitaryFixedSubmodule π J := by
  letI : CompleteSpace (unitaryFixedSubmodule π K) :=
    unitaryFixedSubmodule_completeSpace π K
  rw [mem_unitaryFixedSubmodule]
  intro j
  have hj := (mem_unitaryFixedSubmodule π J x).mp hx j
  have he := unitaryFixedSubmodule_starProjection_commute π K (j : G)
    (fun k => (hcomm k j).symm) x
  simpa [hj] using he.symm

theorem norm_finset_sum_sq_eq_of_pairwise_inner_zero
    {ι H : Type*} [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (f : ι → H) (s : Finset ι)
    (horth : ∀ ⦃i j : ι⦄, i ≠ j → inner ℂ (f i) (f j) = 0) :
    ‖∑ i ∈ s, f i‖ ^ 2 = ∑ i ∈ s, ‖f i‖ ^ 2 := by
  classical
  induction s using Finset.induction_on with
  | empty => simp
  | @insert i s hi ih =>
      simp only [Finset.sum_insert hi]
      rw [norm_add_sq (𝕜 := ℂ)]
      have hzero : inner ℂ (f i) (∑ j ∈ s, f j) = 0 := by
        rw [inner_sum]
        apply Finset.sum_eq_zero
        intro j hj
        exact horth (by
          intro h
          subst j
          exact hi hj)
      simp [hzero, ih]

theorem unitaryImages_inner_sq_mul_card_le
    {ι H : Type*} [Fintype ι]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (U : ι → H ≃ₗᵢ[ℂ] H) (a b : H)
    (hb : ∀ i : ι, U i b = b)
    (horth : ∀ ⦃i j : ι⦄, i ≠ j →
      inner ℂ (U i a) (U j a) = 0) :
    (Fintype.card ι : ℝ) * ‖inner ℂ a b‖ ^ 2 ≤
      ‖a‖ ^ 2 * ‖b‖ ^ 2 := by
  classical
  have hnorm :
      ‖∑ i : ι, U i a‖ ^ 2 =
        (Fintype.card ι : ℝ) * ‖a‖ ^ 2 := by
    calc
      ‖∑ i : ι, U i a‖ ^ 2 =
          ∑ i : ι, ‖U i a‖ ^ 2 := by
            simpa using
              norm_finset_sum_sq_eq_of_pairwise_inner_zero
                (fun i : ι => U i a) Finset.univ horth
      _ = (Fintype.card ι : ℝ) * ‖a‖ ^ 2 := by simp
  have hterm (i : ι) : inner ℂ (U i a) b = inner ℂ a b := by
    calc
      inner ℂ (U i a) b = inner ℂ (U i a) (U i b) := by rw [hb i]
      _ = inner ℂ a b := (U i).inner_map_map a b
  have hinner :
      inner ℂ (∑ i : ι, U i a) b =
        (Fintype.card ι : ℂ) * inner ℂ a b := by
    rw [sum_inner]
    simp_rw [hterm]
    simp [nsmul_eq_mul]
  have hcs :
      (Fintype.card ι : ℝ) * ‖inner ℂ a b‖ ≤
        ‖∑ i : ι, U i a‖ * ‖b‖ := by
    have h := norm_inner_le_norm (𝕜 := ℂ) (∑ i : ι, U i a) b
    rw [hinner, norm_mul, Complex.norm_natCast] at h
    exact h
  have hsq :
      ((Fintype.card ι : ℝ) * ‖inner ℂ a b‖) ^ 2 ≤
        (‖∑ i : ι, U i a‖ * ‖b‖) ^ 2 :=
    (sq_le_sq₀ (by positivity) (by positivity)).mpr hcs
  rw [mul_pow, mul_pow, hnorm] at hsq
  by_cases hcard : Fintype.card ι = 0
  · simp only [hcard, Nat.cast_zero, zero_mul]
    positivity
  · have hpos : 0 < (Fintype.card ι : ℝ) := by
      exact_mod_cast Nat.pos_of_ne_zero hcard
    apply (mul_le_mul_iff_right₀ hpos).mp
    calc
      (Fintype.card ι : ℝ) *
          ((Fintype.card ι : ℝ) * ‖inner ℂ a b‖ ^ 2) =
        (Fintype.card ι : ℝ) ^ 2 * ‖inner ℂ a b‖ ^ 2 := by ring
      _ ≤ ((Fintype.card ι : ℝ) * ‖a‖ ^ 2) * ‖b‖ ^ 2 := hsq
      _ = (Fintype.card ι : ℝ) * (‖a‖ ^ 2 * ‖b‖ ^ 2) := by ring

theorem unitaryFixedSubmodule_starProjection_mem_orthogonal_of_commute
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] [CompleteSpace H]
    (π : UnitaryRepresentation G H) (K Z : Subgroup G)
    (hcomm : ∀ k : K, ∀ z : Z, Commute (k : G) (z : G))
    {x : H} (hx : x ∈ (unitaryFixedSubmodule π Z)ᗮ) :
    (unitaryFixedSubmodule π K).starProjection x ∈
      (unitaryFixedSubmodule π Z)ᗮ := by
  letI : CompleteSpace (unitaryFixedSubmodule π K) :=
    unitaryFixedSubmodule_completeSpace π K
  rw [Submodule.mem_orthogonal]
  intro z hz
  have hpz := unitaryFixedSubmodule_starProjection_mem_of_commute
    π K Z hcomm hz
  calc
    inner ℂ z ((unitaryFixedSubmodule π K).starProjection x) =
        inner ℂ ((unitaryFixedSubmodule π K).starProjection z) x :=
      (Submodule.inner_starProjection_left_eq_right
        (unitaryFixedSubmodule π K) z x).symm
    _ = 0 :=
      (Submodule.mem_orthogonal (unitaryFixedSubmodule π Z) x).mp hx
        ((unitaryFixedSubmodule π K).starProjection z) hpz

theorem unitaryFixedSubmodule_orthogonal_map_of_centralizes
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : UnitaryRepresentation G H) (Z : Subgroup G) (g : G)
    (hg : ∀ z : Z, Commute g (z : G))
    {x : H} (hx : x ∈ (unitaryFixedSubmodule π Z)ᗮ) :
    π g x ∈ (unitaryFixedSubmodule π Z)ᗮ := by
  rw [Submodule.mem_orthogonal]
  intro z hz
  have hmap := unitaryFixedSubmodule_map_of_centralizes
    π Z g⁻¹ (fun k => (hg k).inv_left)
  have hzpre : π g⁻¹ z ∈ unitaryFixedSubmodule π Z := by
    rw [← hmap]
    exact ⟨z, hz, rfl⟩
  calc
    inner ℂ z (π g x) =
        inner ℂ (π g (π g⁻¹ z)) (π g x) := by simp
    _ = inner ℂ (π g⁻¹ z) x := (π g).inner_map_map (π g⁻¹ z) x
    _ = 0 :=
      (Submodule.mem_orthogonal (unitaryFixedSubmodule π Z) x).mp
        hx (π g⁻¹ z) hzpre

theorem unitaryFixedSubmodules_inner_eq_zero_of_commute_centerComplement
    {G : Type u₁} {H : Type v₁} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] [CompleteSpace H]
    (π : UnitaryRepresentation G H) (K J Z : Subgroup G)
    (hcomm : ∀ k : K, ∀ j : J, Commute (k : G) (j : G))
    (hKZ : ∀ k : K, ∀ z : Z, Commute (k : G) (z : G))
    (hcenter : Z ≤ K ⊔ J)
    {a b : H}
    (ha : a ∈ unitaryFixedSubmodule π K)
    (hb : b ∈ unitaryFixedSubmodule π J)
    (hbZ : b ∈ (unitaryFixedSubmodule π Z)ᗮ) :
    inner ℂ a b = 0 := by
  letI : CompleteSpace (unitaryFixedSubmodule π K) :=
    unitaryFixedSubmodule_completeSpace π K
  let p : H := (unitaryFixedSubmodule π K).starProjection b
  have hpK : p ∈ unitaryFixedSubmodule π K :=
    Submodule.starProjection_apply_mem _ _
  have hpJ : p ∈ unitaryFixedSubmodule π J :=
    unitaryFixedSubmodule_starProjection_mem_of_commute
      π K J hcomm hb
  have hpJoin : p ∈ unitaryFixedSubmodule π (K ⊔ J) := by
    rw [unitaryFixedSubmodule_sup]
    exact ⟨hpK, hpJ⟩
  have hpZ : p ∈ unitaryFixedSubmodule π Z := by
    rw [mem_unitaryFixedSubmodule]
    intro z
    exact (mem_unitaryFixedSubmodule π (K ⊔ J) p).mp
      hpJoin ⟨z, hcenter z.property⟩
  have hpZorth : p ∈ (unitaryFixedSubmodule π Z)ᗮ :=
    unitaryFixedSubmodule_starProjection_mem_orthogonal_of_commute
      π K Z hKZ hbZ
  have hpzero : p = 0 := by
    exact (inner_self_eq_zero (𝕜 := ℂ)).mp
      ((Submodule.mem_orthogonal (unitaryFixedSubmodule π Z) p).mp
        hpZorth p hpZ)
  apply inner_eq_zero_symm.mp
  simpa [p, hpzero] using
    (Submodule.starProjection_inner_eq_zero
      (K := unitaryFixedSubmodule π K) b a ha)

def heisenbergConjugateSubgroup
    {G : Type*} [Group G] (X : Subgroup G) (g : G) :
    Subgroup G :=
  X.map (MulAut.conj g).toMonoidHom

theorem heisenbergFiniteFamily_centerComplement_inner_sq_le
    {G : Type u₁} {H : Type v₁} {ι : Type*}
    [Group G] [Fintype ι]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H] [CompleteSpace H]
    (π : UnitaryRepresentation G H)
    (X Z : Subgroup G) (y : ι → G)
    (hXZ : ∀ x : X, ∀ z : Z, Commute (x : G) (z : G))
    (hyZ : ∀ i : ι, ∀ z : Z, Commute (y i) (z : G))
    (hcomm : ∀ ⦃i j : ι⦄, i ≠ j →
      ∀ x : heisenbergConjugateSubgroup X (y i),
      ∀ x' : heisenbergConjugateSubgroup X (y j),
        Commute (x : G) (x' : G))
    (hcenter : ∀ ⦃i j : ι⦄, i ≠ j →
      Z ≤ heisenbergConjugateSubgroup X (y i) ⊔
        heisenbergConjugateSubgroup X (y j))
    {a b : H}
    (ha : a ∈ unitaryFixedSubmodule π X)
    (haZ : a ∈ (unitaryFixedSubmodule π Z)ᗮ)
    (hb : ∀ i : ι, π (y i) b = b) :
    (Fintype.card ι : ℝ) * ‖inner ℂ a b‖ ^ 2 ≤
      ‖a‖ ^ 2 * ‖b‖ ^ 2 := by
  have hfix (i : ι) :
      π (y i) a ∈ unitaryFixedSubmodule π
        (heisenbergConjugateSubgroup X (y i)) := by
    rw [mem_unitaryFixedSubmodule]
    rintro ⟨_, ⟨g, hg, rfl⟩⟩
    have hga := (mem_unitaryFixedSubmodule π X a).mp ha ⟨g, hg⟩
    simp [MulAut.conj_apply, map_mul, hga]
  have horthZ (i : ι) :
      π (y i) a ∈ (unitaryFixedSubmodule π Z)ᗮ :=
    unitaryFixedSubmodule_orthogonal_map_of_centralizes
      π Z (y i) (hyZ i) haZ
  have hJZ (i : ι) :
      ∀ x : heisenbergConjugateSubgroup X (y i),
      ∀ z : Z, Commute (x : G) (z : G) := by
    rintro ⟨_, ⟨g, hg, rfl⟩⟩ z
    change Commute (y i * g * (y i)⁻¹) (z : G)
    exact ((hyZ i z).mul_left (hXZ ⟨g, hg⟩ z)).mul_left
      (hyZ i z).inv_left
  apply unitaryImages_inner_sq_mul_card_le
    (fun i : ι => π (y i)) a b hb
  intro i j hij
  exact unitaryFixedSubmodules_inner_eq_zero_of_commute_centerComplement
    π (heisenbergConjugateSubgroup X (y i))
    (heisenbergConjugateSubgroup X (y j)) Z
    (hcomm hij) (hJZ i) (hcenter hij)
    (hfix i) (hfix j) (horthZ j)

theorem finiteOuterBlockProductCentral_centerComplement_inner_sq_le
    {R : Type*} [Ring R] [Algebra (ZMod 2) R]
    {H : Type v₁} [NormedAddCommGroup H]
    [InnerProductSpace ℂ H] [CompleteSpace H]
    (W : Submodule (ZMod 2) R)
    (i j k : Fin 3) (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (B : Matrix (Fin 3) (Fin 3) W)
    (π : UnitaryRepresentation
      (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) H)
    {a b : H}
    (ha : a ∈ unitaryFixedSubmodule π
      (finiteOuterBlockRootSubgroup W i j hij))
    (haZ : a ∈
      (unitaryFixedSubmodule π
        (finiteOuterBlockProductCentralRootSubgroup W i k hik B))ᗮ)
    (hb : b ∈ unitaryFixedSubmodule π
      (finiteOuterBlockRootSubgroup W j k hjk)) :
    8 * ‖inner ℂ a b‖ ^ 2 ≤ ‖a‖ ^ 2 * ‖b‖ ^ 2 := by
  letI : Fintype finiteBlockGaloisField :=
    Fintype.ofFinite finiteBlockGaloisField
  have hcard : Fintype.card finiteBlockGaloisField = 8 := by
    simpa only [Nat.card_eq_fintype_card] using
      finiteBlockGaloisField_natCard
  have hbound := heisenbergFiniteFamily_centerComplement_inner_sq_le
    π
    (finiteOuterBlockRootSubgroup W i j hij)
    (finiteOuterBlockProductCentralRootSubgroup W i k hik B)
    (fun t : finiteBlockGaloisField =>
      finiteOuterBlockGaloisConjugatorWithCoefficient W j k hjk B t)
    (by
      intro x z
      exact finiteOuterBlockProductCentralRoot_commute_left
        W i j k hij hik B x z x.property z.property)
    (by
      intro t z
      exact finiteOuterBlockProductCentralRoot_commute_right
        W i j k hjk hik B
        (finiteOuterBlockGaloisConjugatorWithCoefficient
          W j k hjk B t) z
        (finiteOuterBlockGaloisConjugatorWithCoefficient_mem
          W j k hjk B t) z.property)
    (by
      intro s t hst x x'
      exact finiteOuterBlockGaloisConjugateRootsWithCoefficient_commute
        W i j k hij hjk hik B s t x x' x.property x'.property)
    (by
      intro s t hst
      exact finiteOuterBlockProductCentralRoot_le_galoisConjugates
        W i j k hij hjk hik B s t hst)
    ha haZ
    (by
      intro t
      exact
        (mem_unitaryFixedSubmodule π
          (finiteOuterBlockRootSubgroup W j k hjk) b).mp hb
          ⟨finiteOuterBlockGaloisConjugatorWithCoefficient
            W j k hjk B t,
            finiteOuterBlockGaloisConjugatorWithCoefficient_mem
              W j k hjk B t⟩)
  simpa [hcard] using hbound

section FiniteSubgroupAveraging

variable {G : Type*} {H : Type*} [Group G]
  [NormedAddCommGroup H] [InnerProductSpace ℂ H]

def finiteUnitarySubgroupAverage
    (π : UnitaryRepresentation G H)
    (K : Subgroup G) [Fintype K] (x : H) : H :=
  (Fintype.card K : ℂ)⁻¹ • ∑ k : K, π (k : G) x

theorem finiteUnitarySubgroupAverage_fixed
    (π : UnitaryRepresentation G H)
    (K : Subgroup G) [Fintype K] (x : H) (g : K) :
    π (g : G) (finiteUnitarySubgroupAverage π K x) =
      finiteUnitarySubgroupAverage π K x := by
  classical
  unfold finiteUnitarySubgroupAverage
  rw [map_smul, map_sum]
  congr 1
  calc
    (∑ k : K, π (g : G) (π (k : G) x)) =
        ∑ k : K, π ((g * k : K) : G) x := by
          apply Finset.sum_congr rfl
          intro k _
          simp [map_mul]
    _ = ∑ k : K, π (k : G) x :=
      Function.Bijective.sum_comp (Group.mulLeft_bijective g)
        (fun k : K => π (k : G) x)

theorem inner_finiteUnitarySubgroupAverage_of_fixed_left
    (π : UnitaryRepresentation G H)
    (K : Subgroup G) [Fintype K] (a b : H)
    (ha : ∀ k : K, π (k : G) a = a) :
    inner ℂ a (finiteUnitarySubgroupAverage π K b) =
      inner ℂ a b := by
  classical
  have hcard : (Fintype.card K : ℂ) ≠ 0 := by
    exact_mod_cast Fintype.card_ne_zero
  have hterm (k : K) :
      inner ℂ a (π (k : G) b) = inner ℂ a b := by
    calc
      inner ℂ a (π (k : G) b) =
          inner ℂ (π (k : G) a) (π (k : G) b) := by rw [ha k]
      _ = inner ℂ a b := (π (k : G)).inner_map_map a b
  unfold finiteUnitarySubgroupAverage
  rw [inner_smul_right, inner_sum]
  simp_rw [hterm]
  simp [hcard]

theorem finiteUnitarySubgroupAverage_fixed_of_orbit_fixed
    (π : UnitaryRepresentation G H)
    (K J : Subgroup G) [Fintype K] (b : H)
    (horbit : ∀ (k : K) (j : J),
      π (j : G) (π (k : G) b) = π (k : G) b)
    (j : J) :
    π (j : G) (finiteUnitarySubgroupAverage π K b) =
      finiteUnitarySubgroupAverage π K b := by
  classical
  unfold finiteUnitarySubgroupAverage
  rw [map_smul, map_sum]
  congr 1
  apply Finset.sum_congr rfl
  intro k _
  exact horbit k j

theorem inner_eq_zero_of_finite_subgroupAverage_pair_orthogonal
    (π : UnitaryRepresentation G H)
    (K J : Subgroup G) [Fintype K] (a b : H)
    (ha : ∀ k : K, π (k : G) a = a)
    (horbit : ∀ (k : K) (j : J),
      π (j : G) (π (k : G) b) = π (k : G) b)
    (horth : ∀ z : H,
      (∀ k : K, π (k : G) z = z) →
      (∀ j : J, π (j : G) z = z) →
      inner ℂ a z = 0) :
    inner ℂ a b = 0 := by
  let z : H := finiteUnitarySubgroupAverage π K b
  have hzK : ∀ k : K, π (k : G) z = z :=
    finiteUnitarySubgroupAverage_fixed π K b
  have hzJ : ∀ j : J, π (j : G) z = z :=
    finiteUnitarySubgroupAverage_fixed_of_orbit_fixed
      π K J b horbit
  calc
    inner ℂ a b = inner ℂ a z :=
      (inner_finiteUnitarySubgroupAverage_of_fixed_left
        π K a b ha).symm
    _ = 0 := horth z hzK hzJ

end FiniteSubgroupAveraging

theorem finiteOuterBlockRootSubgroups_pair_inner_sq_le
    {R : Type*} [Ring R] [Algebra (ZMod 2) R]
    {H : Type v₁} [NormedAddCommGroup H]
    [InnerProductSpace ℂ H] [CompleteSpace H]
    (W : Submodule (ZMod 2) R) [Finite W]
    (i j k : Fin 3)
    (hij : i ≠ j) (hjk : j ≠ k) (hik : i ≠ k)
    (π : UnitaryRepresentation
      (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) H)
    {a b : H}
    (ha : a ∈ unitaryFixedSubmodule π
      (finiteOuterBlockRootSubgroup W i j hij))
    (hb : b ∈ unitaryFixedSubmodule π
      (finiteOuterBlockRootSubgroup W j k hjk))
    (haQ : a ∈
      (unitaryFixedSubmodule π
        (finiteOuterBlockRootSubgroup W i j hij) ⊓
       unitaryFixedSubmodule π
        (finiteOuterBlockRootSubgroup W j k hjk))ᗮ)
    (hbQ : b ∈
      (unitaryFixedSubmodule π
        (finiteOuterBlockRootSubgroup W i j hij) ⊓
       unitaryFixedSubmodule π
        (finiteOuterBlockRootSubgroup W j k hjk))ᗮ) :
    8 * ‖inner ℂ a b‖ ^ 2 ≤ ‖a‖ ^ 2 * ‖b‖ ^ 2 := by
  classical
  letI : Fintype W := Fintype.ofFinite W
  let X := finiteOuterBlockRootSubgroup W i j hij
  let Y := finiteOuterBlockRootSubgroup W j k hjk
  let Z (B : Matrix (Fin 3) (Fin 3) W) :=
    finiteOuterBlockProductCentralRootSubgroup W i k hik B
  let Q : Submodule ℂ H :=
    unitaryFixedSubmodule π X ⊓ unitaryFixedSubmodule π Y
  let U : Submodule ℂ H := unitaryFixedSubmodule π X ⊓ Qᗮ
  let V : Submodule ℂ H := unitaryFixedSubmodule π Y ⊓ Qᗮ
  let F (B : Matrix (Fin 3) (Fin 3) W) :=
    unitaryFixedSubmodule π (Z B)
  letI : Finite X := finite_finiteOuterBlockRootSubgroup W i j hij
  letI : Fintype X := Fintype.ofFinite X
  letI (B : Matrix (Fin 3) (Fin 3) W) : CompleteSpace (F B) :=
    unitaryFixedSubmodule_completeSpace π (Z B)
  have hpairCentral (B : Matrix (Fin 3) (Fin 3) W) :
      ∀ z : Z B, ∀ g :
        (X ⊔ Y : Subgroup
          (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))),
        Commute
          (z : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))
          (g : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) := by
    intro z g
    have hg := finiteOuterBlockProductCentralRoot_pair_le_centralizer
      W i j k hij hjk hik B g.property
    rw [Subgroup.mem_centralizer_iff] at hg
    change (z : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) *
      (g : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) =
      (g : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) *
      (z : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))
    exact hg z z.property
  refine inner_sq_le_of_finite_orthogonal_sector_splitting
    F U V ?_ ?_ ?_ ?_ ?_ a b ⟨ha, haQ⟩ ⟨hb, hbQ⟩
  · intro B x hx
    change (unitaryFixedSubmodule π (Z B)).starProjection x ∈
      unitaryFixedSubmodule π X ⊓ Qᗮ
    refine ⟨?_, ?_⟩
    · exact unitaryFixedSubmodule_starProjection_mem_of_commute
        π (Z B) X
        (fun z x =>
          (finiteOuterBlockProductCentralRoot_commute_left
            W i j k hij hik B x z x.property z.property).symm)
        hx.1
    · have hq : x ∈ (unitaryFixedSubmodule π (X ⊔ Y))ᗮ := by
        rw [unitaryFixedSubmodule_sup]
        exact hx.2
      have hp := unitaryFixedSubmodule_starProjection_mem_orthogonal_of_commute
        π (Z B) (X ⊔ Y) (hpairCentral B) hq
      rw [unitaryFixedSubmodule_sup] at hp
      exact hp
  · intro B x hx
    change (unitaryFixedSubmodule π (Z B)).starProjection x ∈
      unitaryFixedSubmodule π Y ⊓ Qᗮ
    refine ⟨?_, ?_⟩
    · exact unitaryFixedSubmodule_starProjection_mem_of_commute
        π (Z B) Y
        (fun z y =>
          (finiteOuterBlockProductCentralRoot_commute_right
            W i j k hjk hik B y z y.property z.property).symm)
        hx.1
    · have hq : x ∈ (unitaryFixedSubmodule π (X ⊔ Y))ᗮ := by
        rw [unitaryFixedSubmodule_sup]
        exact hx.2
      have hp := unitaryFixedSubmodule_starProjection_mem_orthogonal_of_commute
        π (Z B) (X ⊔ Y) (hpairCentral B) hq
      rw [unitaryFixedSubmodule_sup] at hp
      exact hp
  · intro B C x hx
    change (unitaryFixedSubmodule π (Z B)).starProjection x ∈
      unitaryFixedSubmodule π (Z C)
    exact unitaryFixedSubmodule_starProjection_mem_of_commute
      π (Z B) (Z C)
      (fun z w => finiteOuterBlockProductCentralRoots_commute
        W i k hik B C z w z.property w.property)
      hx
  · intro B x y hx hy hxZ _
    exact finiteOuterBlockProductCentral_centerComplement_inner_sq_le
      W i j k hij hjk hik B π hx.1 hxZ hy.1
  · intro x y hx hy _ hyF
    apply inner_eq_zero_of_finite_subgroupAverage_pair_orthogonal
      π X Y x y
    · exact (mem_unitaryFixedSubmodule π X x).mp hx.1
    · intro s t
      obtain ⟨B, hB⟩ :=
        finiteOuterBlockRoot_commutator_exists_productCentral
          W i j k hij hjk hik s t s.property t.property
      let c : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R) :=
        ⁅(s : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)),
          (t : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))⁆
      have hcb : π c⁻¹ y = y :=
        (mem_unitaryFixedSubmodule π (Z B) y).mp (hyF B)
          ⟨c⁻¹, (Z B).inv_mem hB⟩
      have htb : π (t : elementaryGroup (Fin 3)
          (Matrix (Fin 3) (Fin 3) R)) y = y :=
        (mem_unitaryFixedSubmodule π Y y).mp hy.1 t
      have hsc : Commute
          (s : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) c :=
        finiteOuterBlockProductCentralRoot_commute_left
          W i j k hij hik B s c s.property hB
      have hgroup :
          (t : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) *
              (s : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) =
            (s : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) *
              c⁻¹ *
              (t : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) := by
        calc
          (t : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) *
              (s : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) =
            c⁻¹ *
              (s : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) *
              (t : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) := by
                dsimp [c]
                simp only [commutatorElement_def]
                group
          _ = (s : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) *
              c⁻¹ *
              (t : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) := by
                rw [hsc.inv_right.eq]
      calc
        π (t : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))
            (π (s : elementaryGroup (Fin 3)
              (Matrix (Fin 3) (Fin 3) R)) y) =
          π ((t : elementaryGroup (Fin 3)
            (Matrix (Fin 3) (Fin 3) R)) * s) y := by
              simp [map_mul]
        _ = π ((s : elementaryGroup (Fin 3)
              (Matrix (Fin 3) (Fin 3) R)) * c⁻¹ * t) y := by
              rw [hgroup]
        _ = π (s : elementaryGroup (Fin 3)
              (Matrix (Fin 3) (Fin 3) R))
            (π c⁻¹ (π (t : elementaryGroup (Fin 3)
              (Matrix (Fin 3) (Fin 3) R)) y)) := by
              simp [map_mul]
        _ = π (s : elementaryGroup (Fin 3)
              (Matrix (Fin 3) (Fin 3) R)) y := by
              rw [htb, hcb]
    · intro z hzX hzY
      apply (Submodule.mem_orthogonal' Q x).mp hx.2
      exact ⟨(mem_unitaryFixedSubmodule π X z).mpr hzX,
        (mem_unitaryFixedSubmodule π Y z).mpr hzY⟩

def finiteOuterBlockCyclicRootFamily
    {R : Type*} [Ring R] [Algebra (ZMod 2) R]
    (W : Submodule (ZMod 2) R) (i : Fin 3) :
    Subgroup (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) :=
  finiteOuterBlockRootSubgroup W i (i + 1) (by
    fin_cases i <;> decide)

theorem finiteOuterBlockCyclicRootFamily_pair_inner_sq_le
    {R : Type*} [Ring R] [Algebra (ZMod 2) R]
    {H : Type v₁} [NormedAddCommGroup H]
    [InnerProductSpace ℂ H] [CompleteSpace H]
    (W : Submodule (ZMod 2) R) [Finite W]
    (π : UnitaryRepresentation
      (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) H)
    (i j : Fin 3) (hij : i ≠ j) (a b : H)
    (ha : a ∈ unitaryFixedSubmodule π
      (finiteOuterBlockCyclicRootFamily W i))
    (haQ : a ∈
      (unitaryFixedSubmodule π (finiteOuterBlockCyclicRootFamily W i) ⊓
       unitaryFixedSubmodule π (finiteOuterBlockCyclicRootFamily W j))ᗮ)
    (hb : b ∈ unitaryFixedSubmodule π
      (finiteOuterBlockCyclicRootFamily W j))
    (hbQ : b ∈
      (unitaryFixedSubmodule π (finiteOuterBlockCyclicRootFamily W i) ⊓
       unitaryFixedSubmodule π (finiteOuterBlockCyclicRootFamily W j))ᗮ) :
    8 * ‖inner ℂ a b‖ ^ 2 ≤ ‖a‖ ^ 2 * ‖b‖ ^ 2 := by
  fin_cases i <;> fin_cases j
  · exact (hij rfl).elim
  · exact finiteOuterBlockRootSubgroups_pair_inner_sq_le
      W 0 1 2 (by decide) (by decide) (by decide)
      π ha hb haQ hbQ
  · rw [inf_comm] at haQ hbQ
    have h := finiteOuterBlockRootSubgroups_pair_inner_sq_le
        W 2 0 1 (by decide) (by decide) (by decide)
        π hb ha hbQ haQ
    calc
      8 * ‖inner ℂ a b‖ ^ 2 = 8 * ‖inner ℂ b a‖ ^ 2 := by
        rw [norm_inner_symm a b]
      _ ≤ ‖b‖ ^ 2 * ‖a‖ ^ 2 := h
      _ = ‖a‖ ^ 2 * ‖b‖ ^ 2 := by rw [mul_comm]
  · rw [inf_comm] at haQ hbQ
    have h := finiteOuterBlockRootSubgroups_pair_inner_sq_le
        W 0 1 2 (by decide) (by decide) (by decide)
        π hb ha hbQ haQ
    calc
      8 * ‖inner ℂ a b‖ ^ 2 = 8 * ‖inner ℂ b a‖ ^ 2 := by
        rw [norm_inner_symm a b]
      _ ≤ ‖b‖ ^ 2 * ‖a‖ ^ 2 := h
      _ = ‖a‖ ^ 2 * ‖b‖ ^ 2 := by rw [mul_comm]
  · exact (hij rfl).elim
  · exact finiteOuterBlockRootSubgroups_pair_inner_sq_le
      W 1 2 0 (by decide) (by decide) (by decide)
      π ha hb haQ hbQ
  · exact finiteOuterBlockRootSubgroups_pair_inner_sq_le
      W 2 0 1 (by decide) (by decide) (by decide)
      π ha hb haQ hbQ
  · rw [inf_comm] at haQ hbQ
    have h := finiteOuterBlockRootSubgroups_pair_inner_sq_le
        W 1 2 0 (by decide) (by decide) (by decide)
        π hb ha hbQ haQ
    calc
      8 * ‖inner ℂ a b‖ ^ 2 = 8 * ‖inner ℂ b a‖ ^ 2 := by
        rw [norm_inner_symm a b]
      _ ≤ ‖b‖ ^ 2 * ‖a‖ ^ 2 := h
      _ = ‖a‖ ^ 2 * ‖b‖ ^ 2 := by rw [mul_comm]
  · exact (hij rfl).elim

end

section

open scoped BigOperators commutatorElement

universe u

section BinaryCoefficientSpan

variable {R : Type u} [Ring R] [Algebra (ZMod 2) R]

def finiteBlockCoefficientSpan (s : Finset R) : Submodule (ZMod 2) R :=
  Submodule.span (ZMod 2) ({1} ∪ (↑s : Set R))

theorem one_mem_finiteBlockCoefficientSpan (s : Finset R) :
    (1 : R) ∈ finiteBlockCoefficientSpan s := by
  apply Submodule.subset_span
  exact Set.mem_union_left _ (Set.mem_singleton 1)

theorem mem_finiteBlockCoefficientSpan_of_mem
    (s : Finset R) {a : R} (ha : a ∈ s) :
    a ∈ finiteBlockCoefficientSpan s := by
  apply Submodule.subset_span
  exact Set.mem_union_right _ ha

instance finiteBlockCoefficientSpan_finite (s : Finset R) :
    Finite (finiteBlockCoefficientSpan s) := by
  letI : Module.Finite (ZMod 2) (finiteBlockCoefficientSpan s) :=
    Module.Finite.span_of_finite (ZMod 2)
      (Set.finite_singleton 1 |>.union s.finite_toSet)
  exact Module.finite_of_finite (ZMod 2)

end BinaryCoefficientSpan

section FiniteBlockRoots

variable {R : Type u} [Ring R] [Algebra (ZMod 2) R]

def finiteBlockIndex (i p : Fin 3) : Fin 9 :=
  finProdFinEquiv (i, p)

theorem finiteBlockIndex_ne_of_ne
    {i j : Fin 3} (hij : i ≠ j) (p q : Fin 3) :
    finiteBlockIndex i p ≠ finiteBlockIndex j q := by
  intro h
  exact hij (congrArg Prod.fst (finProdFinEquiv.injective h))

def finiteBlockFlattenRingEquiv :
    Matrix (Fin 3) (Fin 3) (Matrix (Fin 3) (Fin 3) R) ≃+*
      Matrix (Fin 9) (Fin 9) R :=
  (Matrix.compRingEquiv (Fin 3) (Fin 3) R).trans
    (Matrix.reindexRingEquiv R finProdFinEquiv)

def finiteBlockRootHom
    (W : Submodule (ZMod 2) R) (i j : Fin 3) (hij : i ≠ j) :
    Multiplicative (Matrix (Fin 3) (Fin 3) W) →*
      (Matrix (Fin 9) (Fin 9) R)ˣ :=
  (Units.mapEquiv (finiteBlockFlattenRingEquiv (R := R)).toMulEquiv).toMonoidHom.comp
    (((elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)).subtype.comp
      (elementaryRootHom (R := Matrix (Fin 3) (Fin 3) R) i j hij)).comp
        (finiteBlockCoefficientMatrixHom W).toMultiplicative)

def finiteBlockRootSubgroup
    (W : Submodule (ZMod 2) R) (i j : Fin 3) (hij : i ≠ j) :
    Subgroup (Matrix (Fin 9) (Fin 9) R)ˣ :=
  (finiteBlockRootHom W i j hij).range

theorem finiteBlockRootHom_single
    (W : Submodule (ZMod 2) R)
    (i j : Fin 3) (hij : i ≠ j) (p q : Fin 3) (a : W) :
    finiteBlockRootHom W i j hij
        (Multiplicative.ofAdd (Matrix.single p q a)) =
      elementaryUnit (finiteBlockIndex i p) (finiteBlockIndex j q)
        (finiteBlockIndex_ne_of_ne hij p q) (a : R) := by
  apply Units.ext
  change
    finiteBlockFlattenRingEquiv
      (1 + Matrix.single i j
        ((finiteBlockCoefficientMatrixHom W) (Matrix.single p q a))) =
      1 + Matrix.single (finiteBlockIndex i p) (finiteBlockIndex j q) (a : R)
  have hsingle :
      finiteBlockCoefficientMatrixHom W (Matrix.single p q a) =
        Matrix.single p q (a : R) := by
    ext k l
    by_cases hp : p = k
    · subst k
      by_cases hq : q = l
      · subst l
        simp [finiteBlockCoefficientMatrixHom]
      · simp [finiteBlockCoefficientMatrixHom, hq]
    · simp [finiteBlockCoefficientMatrixHom, hp]
  rw [hsingle]
  rw [map_add, map_one]
  congr 1
  change
    Matrix.reindex finProdFinEquiv finProdFinEquiv
      (Matrix.comp (Fin 3) (Fin 3) (Fin 3) (Fin 3) R
        (Matrix.single i j (Matrix.single p q (a : R)))) =
      Matrix.single (finiteBlockIndex i p) (finiteBlockIndex j q) (a : R)
  rw [Matrix.comp_single_single]
  ext x y
  simp [finiteBlockIndex, Matrix.reindex, Matrix.single_apply,
    Equiv.eq_symm_apply]

theorem elementaryUnit_mem_finiteBlockRootSubgroup
    (W : Submodule (ZMod 2) R)
    (i j : Fin 3) (hij : i ≠ j) (p q : Fin 3)
    (a : R) (ha : a ∈ W) :
    elementaryUnit (finiteBlockIndex i p) (finiteBlockIndex j q)
        (finiteBlockIndex_ne_of_ne hij p q) a ∈
      finiteBlockRootSubgroup W i j hij := by
  refine ⟨Multiplicative.ofAdd (Matrix.single p q (⟨a, ha⟩ : W)), ?_⟩
  exact finiteBlockRootHom_single W i j hij p q ⟨a, ha⟩

theorem finiteBlockRootSubgroup_le_elementaryGroup
    (W : Submodule (ZMod 2) R)
    (i j : Fin 3) (hij : i ≠ j) :
    finiteBlockRootSubgroup W i j hij ≤
      elementaryGroup (Fin 9) R := by
  rintro _ ⟨A, rfl⟩
  change
    finiteBlockRootHom W i j hij
        (Multiplicative.ofAdd A.toAdd) ∈
      elementaryGroup (Fin 9) R
  refine Matrix.induction_on'
    (P := fun M : Matrix (Fin 3) (Fin 3) W =>
      finiteBlockRootHom W i j hij (Multiplicative.ofAdd M) ∈
        elementaryGroup (Fin 9) R)
    A.toAdd ?_ ?_ ?_
  · change finiteBlockRootHom W i j hij 1 ∈ elementaryGroup (Fin 9) R
    rw [map_one]
    exact (elementaryGroup (Fin 9) R).one_mem
  · intro P Q hP hQ
    change
      finiteBlockRootHom W i j hij
          (Multiplicative.ofAdd (P + Q)) ∈
        elementaryGroup (Fin 9) R
    change
      finiteBlockRootHom W i j hij
          (Multiplicative.ofAdd P * Multiplicative.ofAdd Q) ∈
        elementaryGroup (Fin 9) R
    rw [map_mul]
    exact (elementaryGroup (Fin 9) R).mul_mem hP hQ
  · intro p q a
    rw [finiteBlockRootHom_single]
    exact elementaryUnit_mem _ _ _ (a : R)

def cyclicFiniteBlockRootSubgroup
    (W : Submodule (ZMod 2) R) :
    Subgroup (Matrix (Fin 9) (Fin 9) R)ˣ :=
  finiteBlockRootSubgroup W 0 1 (by decide) ⊔
    finiteBlockRootSubgroup W 1 2 (by decide) ⊔
      finiteBlockRootSubgroup W 2 0 (by decide)

theorem cyclicFiniteBlockRootSubgroup_le_elementaryGroup
    (W : Submodule (ZMod 2) R) :
    cyclicFiniteBlockRootSubgroup W ≤ elementaryGroup (Fin 9) R := by
  unfold cyclicFiniteBlockRootSubgroup
  exact sup_le
    (sup_le
      (finiteBlockRootSubgroup_le_elementaryGroup W 0 1 (by decide))
      (finiteBlockRootSubgroup_le_elementaryGroup W 1 2 (by decide)))
    (finiteBlockRootSubgroup_le_elementaryGroup W 2 0 (by decide))

theorem elementaryUnit_mem_cyclicFiniteBlockRootSubgroup_of_block_ne
    (W : Submodule (ZMod 2) R) (hW : (1 : R) ∈ W)
    (i j : Fin 3) (hij : i ≠ j) (p q : Fin 3)
    (a : R) (ha : a ∈ W) :
    elementaryUnit (finiteBlockIndex i p) (finiteBlockIndex j q)
        (finiteBlockIndex_ne_of_ne hij p q) a ∈
      cyclicFiniteBlockRootSubgroup W := by
  let H : Subgroup (Matrix (Fin 9) (Fin 9) R)ˣ :=
    cyclicFiniteBlockRootSubgroup W
  have h01 (p q : Fin 3) (a : R) (ha : a ∈ W) :
      elementaryUnit (finiteBlockIndex 0 p) (finiteBlockIndex 1 q)
          (finiteBlockIndex_ne_of_ne (by decide) p q) a ∈ H := by
    apply (show finiteBlockRootSubgroup W 0 1 (by decide) ≤ H from
      (show finiteBlockRootSubgroup W 0 1 (by decide) ≤
        (finiteBlockRootSubgroup W 0 1 (by decide) ⊔
          finiteBlockRootSubgroup W 1 2 (by decide)) ⊔
          finiteBlockRootSubgroup W 2 0 (by decide) from
        le_trans le_sup_left le_sup_left))
    exact elementaryUnit_mem_finiteBlockRootSubgroup
      W 0 1 (by decide) p q a ha
  have h12 (p q : Fin 3) (a : R) (ha : a ∈ W) :
      elementaryUnit (finiteBlockIndex 1 p) (finiteBlockIndex 2 q)
          (finiteBlockIndex_ne_of_ne (by decide) p q) a ∈ H := by
    apply (show finiteBlockRootSubgroup W 1 2 (by decide) ≤ H from
      (show finiteBlockRootSubgroup W 1 2 (by decide) ≤
        (finiteBlockRootSubgroup W 0 1 (by decide) ⊔
          finiteBlockRootSubgroup W 1 2 (by decide)) ⊔
          finiteBlockRootSubgroup W 2 0 (by decide) from
        le_trans le_sup_right le_sup_left))
    exact elementaryUnit_mem_finiteBlockRootSubgroup
      W 1 2 (by decide) p q a ha
  have h20 (p q : Fin 3) (a : R) (ha : a ∈ W) :
      elementaryUnit (finiteBlockIndex 2 p) (finiteBlockIndex 0 q)
          (finiteBlockIndex_ne_of_ne (by decide) p q) a ∈ H := by
    apply (show finiteBlockRootSubgroup W 2 0 (by decide) ≤ H from
      (show finiteBlockRootSubgroup W 2 0 (by decide) ≤
        (finiteBlockRootSubgroup W 0 1 (by decide) ⊔
          finiteBlockRootSubgroup W 1 2 (by decide)) ⊔
          finiteBlockRootSubgroup W 2 0 (by decide) from le_sup_right))
    exact elementaryUnit_mem_finiteBlockRootSubgroup
      W 2 0 (by decide) p q a ha
  have h02 (p q : Fin 3) (a : R) (ha : a ∈ W) :
      elementaryUnit (finiteBlockIndex 0 p) (finiteBlockIndex 2 q)
          (finiteBlockIndex_ne_of_ne (by decide) p q) a ∈ H :=
    elementaryUnit_mem_of_two_step H
      (finiteBlockIndex 0 p) (finiteBlockIndex 1 0)
      (finiteBlockIndex 2 q)
      (finiteBlockIndex_ne_of_ne (by decide) p 0)
      (finiteBlockIndex_ne_of_ne (by decide) 0 q)
      (finiteBlockIndex_ne_of_ne (by decide) p q) a
      (h01 p 0 a ha) (h12 0 q 1 hW)
  have h10 (p q : Fin 3) (a : R) (ha : a ∈ W) :
      elementaryUnit (finiteBlockIndex 1 p) (finiteBlockIndex 0 q)
          (finiteBlockIndex_ne_of_ne (by decide) p q) a ∈ H :=
    elementaryUnit_mem_of_two_step H
      (finiteBlockIndex 1 p) (finiteBlockIndex 2 0)
      (finiteBlockIndex 0 q)
      (finiteBlockIndex_ne_of_ne (by decide) p 0)
      (finiteBlockIndex_ne_of_ne (by decide) 0 q)
      (finiteBlockIndex_ne_of_ne (by decide) p q) a
      (h12 p 0 a ha) (h20 0 q 1 hW)
  have h21 (p q : Fin 3) (a : R) (ha : a ∈ W) :
      elementaryUnit (finiteBlockIndex 2 p) (finiteBlockIndex 1 q)
          (finiteBlockIndex_ne_of_ne (by decide) p q) a ∈ H :=
    elementaryUnit_mem_of_two_step H
      (finiteBlockIndex 2 p) (finiteBlockIndex 0 0)
      (finiteBlockIndex 1 q)
      (finiteBlockIndex_ne_of_ne (by decide) p 0)
      (finiteBlockIndex_ne_of_ne (by decide) 0 q)
      (finiteBlockIndex_ne_of_ne (by decide) p q) a
      (h20 p 0 a ha) (h01 0 q 1 hW)
  change
    elementaryUnit (finiteBlockIndex i p) (finiteBlockIndex j q)
        (finiteBlockIndex_ne_of_ne hij p q) a ∈ H
  fin_cases i <;> fin_cases j
  · exact (hij rfl).elim
  · exact h01 p q a ha
  · exact h02 p q a ha
  · exact h10 p q a ha
  · exact (hij rfl).elim
  · exact h12 p q a ha
  · exact h20 p q a ha
  · exact h21 p q a ha
  · exact (hij rfl).elim

theorem elementaryUnit_mem_cyclicFiniteBlockRootSubgroup
    (W : Submodule (ZMod 2) R) (hW : (1 : R) ∈ W)
    (x y : Fin 9) (hxy : x ≠ y) (a : R) (ha : a ∈ W) :
    elementaryUnit x y hxy a ∈ cyclicFiniteBlockRootSubgroup W := by
  obtain ⟨⟨i, p⟩, rfl⟩ :=
    (finProdFinEquiv : Fin 3 × Fin 3 ≃ Fin 9).surjective x
  obtain ⟨⟨j, q⟩, rfl⟩ :=
    (finProdFinEquiv : Fin 3 × Fin 3 ≃ Fin 9).surjective y
  change
    elementaryUnit (finiteBlockIndex i p) (finiteBlockIndex j q) hxy a ∈
      cyclicFiniteBlockRootSubgroup W
  by_cases hij : i = j
  · subst j
    let k : Fin 3 := i + 1
    have hik : i ≠ k := by
      dsimp [k]
      fin_cases i <;> decide
    exact elementaryUnit_mem_of_two_step
      (cyclicFiniteBlockRootSubgroup W)
      (finiteBlockIndex i p) (finiteBlockIndex k 0)
      (finiteBlockIndex i q)
      (finiteBlockIndex_ne_of_ne hik p 0)
      (finiteBlockIndex_ne_of_ne hik.symm 0 q)
      hxy a
      (elementaryUnit_mem_cyclicFiniteBlockRootSubgroup_of_block_ne
        W hW i k hik p 0 a ha)
      (elementaryUnit_mem_cyclicFiniteBlockRootSubgroup_of_block_ne
        W hW k i hik.symm 0 q 1 hW)
  · exact elementaryUnit_mem_cyclicFiniteBlockRootSubgroup_of_block_ne
      W hW i j hij p q a ha

theorem cyclicFiniteBlockRootSubgroup_eq_elementaryGroup
    (s : Finset R)
    (hs : Algebra.adjoin (ZMod 2) (↑s : Set R) = ⊤) :
    cyclicFiniteBlockRootSubgroup (finiteBlockCoefficientSpan s) =
      elementaryGroup (Fin 9) R := by
  let W : Submodule (ZMod 2) R := finiteBlockCoefficientSpan s
  let H : Subgroup (Matrix (Fin 9) (Fin 9) R)ˣ :=
    cyclicFiniteBlockRootSubgroup W
  have hW : (1 : R) ∈ W := one_mem_finiteBlockCoefficientSpan s
  have hunit : ∀ (i j : Fin 9) (hij : i ≠ j),
      elementaryUnit i j hij (1 : R) ∈ H := by
    intro i j hij
    exact elementaryUnit_mem_cyclicFiniteBlockRootSubgroup
      W hW i j hij 1 hW
  let C : Subalgebra (ZMod 2) R :=
    elementaryCoefficientSubalgebra 9 (by decide) H hunit
  have hgen : (↑s : Set R) ⊆ (C : Set R) := by
    intro a ha
    change ∀ (i j : Fin 9) (hij : i ≠ j),
      elementaryUnit i j hij a ∈ H
    intro i j hij
    exact elementaryUnit_mem_cyclicFiniteBlockRootSubgroup
      W hW i j hij a
      (mem_finiteBlockCoefficientSpan_of_mem s ha)
  have hC : C = ⊤ := by
    apply top_unique
    rw [← hs]
    exact Algebra.adjoin_le hgen
  change H = elementaryGroup (Fin 9) R
  apply le_antisymm
  · exact cyclicFiniteBlockRootSubgroup_le_elementaryGroup W
  · rw [elementaryGroup, Subgroup.closure_le]
    rintro _ ⟨i, j, hij, a, rfl⟩
    have ha : a ∈ C := by simp [hC]
    exact ha i j hij

end FiniteBlockRoots

end

section

open scoped BigOperators

universe vSharp

theorem hasPropertyT_of_finiteOuterBlockCyclicRootFamily_generate
    {R : Type*} [Ring R] [Algebra (ZMod 2) R]
    (W : Submodule (ZMod 2) R) [Finite W]
    (hgen :
      (⨆ i : Fin 3, finiteOuterBlockCyclicRootFamily W i) = ⊤) :
    HasPropertyT.{_, vSharp}
      (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) := by
  classical
  have hfinite (i : Fin 3) :
      Finite (finiteOuterBlockCyclicRootFamily W i) := by
    fin_cases i
    · exact finite_finiteOuterBlockRootSubgroup W 0 1 (by decide)
    · exact finite_finiteOuterBlockRootSubgroup W 1 2 (by decide)
    · exact finite_finiteOuterBlockRootSubgroup W 2 0 (by decide)
  letI (i : Fin 3) : Finite (finiteOuterBlockCyclicRootFamily W i) :=
    hfinite i
  letI (i : Fin 3) : Fintype (finiteOuterBlockCyclicRootFamily W i) :=
    Fintype.ofFinite _
  apply ErshovJaikinFiniteSpectral.hasPropertyT_of_three_finite_subgroups_friedrichs_angle
    (finiteOuterBlockCyclicRootFamily W) hgen
    (Real.sqrt (8 : ℝ))⁻¹
    (le_of_lt ErshovJaikinFiniteSpectral.inv_sqrt_eight_pos)
    ErshovJaikinFiniteSpectral.inv_sqrt_eight_lt_one_half
  intro H _ _ _ π i j hij a b ha haQ hb hbQ
  have hfixed
      (K : Subgroup
        (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R))) :
      unitaryFixedSubmodule π K = ejUnitaryFixedSubmodule π K := by
    ext z
    rfl
  rw [← hfixed] at ha haQ hb hbQ
  exact ErshovJaikinFiniteSpectral.norm_inner_le_inv_sqrt_eight_of_sq a b
    (finiteOuterBlockCyclicRootFamily_pair_inner_sq_le
      W π i j hij a b ha haQ hb hbQ)

end

section

open scoped BigOperators

def finiteOuterBlockFlattenHom
    {R : Type*} [Ring R] :
    elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R) →*
      (Matrix (Fin 9) (Fin 9) R)ˣ :=
  (Units.mapEquiv (finiteBlockFlattenRingEquiv (R := R)).toMulEquiv).toMonoidHom.comp
    (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)).subtype

theorem finiteOuterBlockRootSubgroup_map_flatten
    {R : Type*} [Ring R] [Algebra (ZMod 2) R]
    (W : Submodule (ZMod 2) R)
    (i j : Fin 3) (hij : i ≠ j) :
    (finiteOuterBlockRootSubgroup W i j hij).map
      (finiteOuterBlockFlattenHom (R := R)) =
        finiteBlockRootSubgroup W i j hij := by
  change (finiteOuterBlockRootHom W i j hij).range.map
    (finiteOuterBlockFlattenHom (R := R)) =
      (finiteBlockRootHom W i j hij).range
  rw [MonoidHom.map_range]
  rfl

theorem finiteOuterBlockCyclicRootFamily_iSup_eq_top
    {R : Type*} [Ring R] [Algebra (ZMod 2) R]
    (s : Finset R)
    (hs : Algebra.adjoin (ZMod 2) (↑s : Set R) = ⊤) :
    (⨆ i : Fin 3,
      finiteOuterBlockCyclicRootFamily (finiteBlockCoefficientSpan s) i) =
        ⊤ := by
  let W : Submodule (ZMod 2) R := finiteBlockCoefficientSpan s
  let L : Subgroup
      (elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) :=
    finiteOuterBlockRootSubgroup W 0 1 (by decide) ⊔
      finiteOuterBlockRootSubgroup W 1 2 (by decide) ⊔
        finiteOuterBlockRootSubgroup W 2 0 (by decide)
  let φ := finiteOuterBlockFlattenHom (R := R)
  have hmap :
      L.map φ = elementaryGroup (Fin 9) R := by
    calc
      L.map φ = cyclicFiniteBlockRootSubgroup W := by
        dsimp [L, φ]
        rw [Subgroup.map_sup, Subgroup.map_sup,
          finiteOuterBlockRootSubgroup_map_flatten,
          finiteOuterBlockRootSubgroup_map_flatten,
          finiteOuterBlockRootSubgroup_map_flatten]
        rfl
      _ = elementaryGroup (Fin 9) R := by
        exact cyclicFiniteBlockRootSubgroup_eq_elementaryGroup s hs
  let e :
      elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R) ≃*
        elementaryGroup (Fin 9) R :=
    (LeavittElementaryMorita.elementaryBlockGroupEquiv
      (ι := Fin 3) (κ := Fin 3) (R := R)).trans
      (LeavittElementaryMorita.elementaryReindexGroupEquiv
        (R := R) (finProdFinEquiv : Fin 3 × Fin 3 ≃ Fin 9))
  have hcompat
      (x : elementaryGroup (Fin 3) (Matrix (Fin 3) (Fin 3) R)) :
      (e x : (Matrix (Fin 9) (Fin 9) R)ˣ) = φ x := by
    rfl
  have hinj : Function.Injective φ := by
    intro x y hxy
    apply Subtype.ext
    exact (Units.mapEquiv
      (finiteBlockFlattenRingEquiv (R := R)).toMulEquiv).injective hxy
  have hLtop : L = ⊤ := by
    apply top_unique
    intro x _
    have hx :
        φ x ∈ elementaryGroup (Fin 9) R := by
      rw [← hcompat]
      exact (e x).property
    rw [← hmap] at hx
    obtain ⟨z, hz, hzx⟩ := hx
    have heq : z = x := hinj hzx
    simpa [heq] using hz
  apply top_unique
  rw [← hLtop]
  dsimp [L, W]
  exact sup_le
    (sup_le
      (le_iSup (finiteOuterBlockCyclicRootFamily
        (finiteBlockCoefficientSpan s)) 0)
      (le_iSup (finiteOuterBlockCyclicRootFamily
        (finiteBlockCoefficientSpan s)) 1))
    (le_iSup (finiteOuterBlockCyclicRootFamily
      (finiteBlockCoefficientSpan s)) 2)

theorem binaryLeavittElementaryNine_hasPropertyT_unconditional :
    HasPropertyT.{0, vSharp} (binaryLeavittElementaryGroup 9) := by
  classical
  obtain ⟨s, hs⟩ :=
    Algebra.FiniteType.out (R := ZMod 2) (A := BinaryLeavitt)
  letI : HasPropertyT.{0, vSharp}
      (elementaryGroup (Fin 3)
        (Matrix (Fin 3) (Fin 3) BinaryLeavitt)) :=
    hasPropertyT_of_finiteOuterBlockCyclicRootFamily_generate
      (finiteBlockCoefficientSpan s)
      (finiteOuterBlockCyclicRootFamily_iSup_eq_top s hs)
  exact hasPropertyT_of_mulEquiv
    ((LeavittElementaryMorita.elementaryBlockGroupEquiv
      (ι := Fin 3) (κ := Fin 3) (R := BinaryLeavitt)).trans
      (LeavittElementaryMorita.elementaryReindexGroupEquiv
        (R := BinaryLeavitt)
        (finProdFinEquiv : Fin 3 × Fin 3 ≃ Fin 9)))

theorem alphaPrefixElementaryGroup_hasPropertyT_unconditional :
    HasPropertyT.{0, vSharp} (prefixElementaryGroup alphaPrefixCode) := by
  letI : HasPropertyT.{0, vSharp} (binaryLeavittElementaryGroup 9) :=
    binaryLeavittElementaryNine_hasPropertyT_unconditional
  exact LeavittElementaryMorita.alphaPrefixElementaryGroup_hasPropertyT_of_nine

theorem alphaZeroPrefixElementaryGroup_hasPropertyT_unconditional :
    HasPropertyT.{0, vSharp} (prefixElementaryGroup alphaZeroPrefixCode) := by
  letI : HasPropertyT.{0, vSharp} (binaryLeavittElementaryGroup 9) :=
    binaryLeavittElementaryNine_hasPropertyT_unconditional
  exact LeavittElementaryMorita.alphaZeroPrefixElementaryGroup_hasPropertyT_of_nine

theorem ninePrefixElementaryGroup_hasPropertyT_unconditional :
    HasPropertyT.{0, vSharp} (prefixElementaryGroup ninePrefixCode) := by
  letI : HasPropertyT.{0, vSharp} (binaryLeavittElementaryGroup 9) :=
    binaryLeavittElementaryNine_hasPropertyT_unconditional
  exact hasPropertyT_of_mulEquiv ninePrefixElementaryGroupEquiv

end

namespace KunThomFiberCoarea

def firstFiber {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) (x : V) : Finset (V × V) :=
  U.filter (fun z => z.1 = x)

def secondFiber {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) (x : V) : Finset (V × V) :=
  U.filter (fun z => z.2 = x)

def firstMultiplicity {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) (x : V) : ℕ :=
  (firstFiber U x).card

def secondMultiplicity {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) (x : V) : ℕ :=
  (secondFiber U x).card

theorem sum_firstFiber_card {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) :
    (∑ x : V, (firstFiber U x).card) = U.card := by
  classical
  simpa [firstFiber] using
    (Finset.card_eq_sum_card_fiberwise
      (f := Prod.fst) (s := U) (t := Finset.univ)
      (fun _ _ => Finset.mem_univ _)).symm

theorem sum_secondFiber_card {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) :
    (∑ x : V, (secondFiber U x).card) = U.card := by
  classical
  simpa [secondFiber] using
    (Finset.card_eq_sum_card_fiberwise
      (f := Prod.snd) (s := U) (t := Finset.univ)
      (fun _ _ => Finset.mem_univ _)).symm

theorem natDist_card_le_sdiff {α : Type*} [DecidableEq α]
    (A B : Finset α) :
    Nat.dist A.card B.card ≤ (A \ B).card + (B \ A).card := by
  have hA := Finset.card_sdiff_add_card_inter A B
  have hB := Finset.card_sdiff_add_card_inter B A
  have hinter : (A ∩ B).card = (B ∩ A).card := by
    rw [Finset.inter_comm]
  by_cases h : A.card ≤ B.card
  · rw [Nat.dist_eq_sub_of_le h]
    omega
  · rw [Nat.dist_eq_sub_of_le_right (Nat.le_of_not_ge h)]
    omega

theorem firstFiber_sdiff {V : Type*} [DecidableEq V]
    (U W : Finset (V × V)) (x : V) :
    firstFiber (U \ W) x = firstFiber U x \ firstFiber W x := by
  classical
  ext z
  simp only [firstFiber, Finset.mem_filter, Finset.mem_sdiff]
  aesop

theorem secondFiber_sdiff {V : Type*} [DecidableEq V]
    (U W : Finset (V × V)) (x : V) :
    secondFiber (U \ W) x = secondFiber U x \ secondFiber W x := by
  classical
  ext z
  simp only [secondFiber, Finset.mem_filter, Finset.mem_sdiff]
  aesop

theorem firstMultiplicity_variation_le_relation_difference
    {V : Type*} [Fintype V] [DecidableEq V]
    (U W : Finset (V × V)) :
    (∑ x : V, Nat.dist (firstMultiplicity U x)
      (firstMultiplicity W x)) ≤
        (U \ W).card + (W \ U).card := by
  classical
  calc
    (∑ x : V, Nat.dist (firstMultiplicity U x)
      (firstMultiplicity W x)) ≤
        ∑ x : V,
          ((firstFiber U x \ firstFiber W x).card +
            (firstFiber W x \ firstFiber U x).card) := by
          apply Finset.sum_le_sum
          intro x _
          exact natDist_card_le_sdiff (firstFiber U x) (firstFiber W x)
    _ = (∑ x : V, (firstFiber (U \ W) x).card) +
          (∑ x : V, (firstFiber (W \ U) x).card) := by
          simp_rw [firstFiber_sdiff]
          rw [Finset.sum_add_distrib]
    _ = (U \ W).card + (W \ U).card := by
          rw [sum_firstFiber_card, sum_firstFiber_card]

theorem secondMultiplicity_variation_le_relation_difference
    {V : Type*} [Fintype V] [DecidableEq V]
    (U W : Finset (V × V)) :
    (∑ x : V, Nat.dist (secondMultiplicity U x)
      (secondMultiplicity W x)) ≤
        (U \ W).card + (W \ U).card := by
  classical
  calc
    (∑ x : V, Nat.dist (secondMultiplicity U x)
      (secondMultiplicity W x)) ≤
        ∑ x : V,
          ((secondFiber U x \ secondFiber W x).card +
            (secondFiber W x \ secondFiber U x).card) := by
          apply Finset.sum_le_sum
          intro x _
          exact natDist_card_le_sdiff (secondFiber U x) (secondFiber W x)
    _ = (∑ x : V, (secondFiber (U \ W) x).card) +
          (∑ x : V, (secondFiber (W \ U) x).card) := by
          simp_rw [secondFiber_sdiff]
          rw [Finset.sum_add_distrib]
    _ = (U \ W).card + (W \ U).card := by
          rw [sum_secondFiber_card, sum_secondFiber_card]

def diagonalImage {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) : Finset (V × V) :=
  U.image (p.prodCongr p)

def diagonalExit {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) : ℕ :=
  (U.filter fun z => (p.prodCongr p) z ∉ U).card

theorem diagonalImage_card {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) :
    (diagonalImage p U).card = U.card := by
  exact Finset.card_image_of_injective U (p.prodCongr p).injective

theorem firstFiber_diagonalImage {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) (x : V) :
    firstFiber (diagonalImage p U) (p x) =
      (firstFiber U x).image (p.prodCongr p) := by
  classical
  ext z
  simp only [firstFiber, diagonalImage, Finset.mem_filter,
    Finset.mem_image]
  constructor
  · rintro ⟨⟨w, hw, hzw⟩, hzfirst⟩
    refine ⟨w, ⟨hw, ?_⟩, hzw⟩
    apply p.injective
    simpa [← hzw] using hzfirst
  · rintro ⟨w, ⟨hw, hwfirst⟩, hzw⟩
    refine ⟨⟨w, hw, hzw⟩, ?_⟩
    simpa [← hzw] using congrArg p hwfirst

theorem secondFiber_diagonalImage {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) (x : V) :
    secondFiber (diagonalImage p U) (p x) =
      (secondFiber U x).image (p.prodCongr p) := by
  classical
  ext z
  simp only [secondFiber, diagonalImage, Finset.mem_filter,
    Finset.mem_image]
  constructor
  · rintro ⟨⟨w, hw, hzw⟩, hzsecond⟩
    refine ⟨w, ⟨hw, ?_⟩, hzw⟩
    apply p.injective
    simpa [← hzw] using hzsecond
  · rintro ⟨w, ⟨hw, hwsecond⟩, hzw⟩
    refine ⟨⟨w, hw, hzw⟩, ?_⟩
    simpa [← hzw] using congrArg p hwsecond

theorem firstMultiplicity_diagonalImage {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) (x : V) :
    firstMultiplicity (diagonalImage p U) (p x) =
      firstMultiplicity U x := by
  unfold firstMultiplicity
  rw [firstFiber_diagonalImage]
  exact Finset.card_image_of_injective _ (p.prodCongr p).injective

theorem secondMultiplicity_diagonalImage {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) (x : V) :
    secondMultiplicity (diagonalImage p U) (p x) =
      secondMultiplicity U x := by
  unfold secondMultiplicity
  rw [secondFiber_diagonalImage]
  exact Finset.card_image_of_injective _ (p.prodCongr p).injective

theorem diagonalImage_sdiff_eq_image_exit {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) :
    diagonalImage p U \ U =
      (U.filter fun z => (p.prodCongr p) z ∉ U).image
        (p.prodCongr p) := by
  classical
  ext z
  simp only [diagonalImage, Finset.mem_sdiff, Finset.mem_image,
    Finset.mem_filter]
  constructor
  · rintro ⟨⟨w, hw, hzw⟩, hzout⟩
    exact ⟨w, ⟨hw, by simpa [hzw] using hzout⟩, hzw⟩
  · rintro ⟨w, ⟨hw, hwout⟩, hzw⟩
    exact ⟨⟨w, hw, hzw⟩, by simpa [← hzw] using hwout⟩

theorem diagonalImage_sdiff_cards {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) :
    (diagonalImage p U \ U).card = diagonalExit p U ∧
      (U \ diagonalImage p U).card = diagonalExit p U := by
  have hforward : (diagonalImage p U \ U).card = diagonalExit p U := by
    rw [diagonalImage_sdiff_eq_image_exit]
    exact Finset.card_image_of_injective _ (p.prodCongr p).injective
  have hU := Finset.card_sdiff_add_card_inter U (diagonalImage p U)
  have hI := Finset.card_sdiff_add_card_inter (diagonalImage p U) U
  have hinter : (U ∩ diagonalImage p U).card =
      (diagonalImage p U ∩ U).card := by
    rw [Finset.inter_comm]
  have hcard := diagonalImage_card p U
  exact ⟨hforward, by omega⟩

theorem firstMultiplicity_diagonal_variation_le_twice_exit
    {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) :
    (∑ x : V, Nat.dist (firstMultiplicity U (p x))
      (firstMultiplicity U x)) ≤ 2 * diagonalExit p U := by
  classical
  calc
    (∑ x : V, Nat.dist (firstMultiplicity U (p x))
      (firstMultiplicity U x)) =
        ∑ x : V, Nat.dist (firstMultiplicity U (p x))
          (firstMultiplicity (diagonalImage p U) (p x)) := by
          apply Finset.sum_congr rfl
          intro x _
          rw [firstMultiplicity_diagonalImage]
    _ = ∑ x : V, Nat.dist (firstMultiplicity U x)
          (firstMultiplicity (diagonalImage p U) x) :=
          Equiv.sum_comp p (fun x =>
            Nat.dist (firstMultiplicity U x)
              (firstMultiplicity (diagonalImage p U) x))
    _ ≤ (U \ diagonalImage p U).card +
          (diagonalImage p U \ U).card :=
          firstMultiplicity_variation_le_relation_difference
            U (diagonalImage p U)
    _ = 2 * diagonalExit p U := by
          obtain ⟨hforward, hbackward⟩ := diagonalImage_sdiff_cards p U
          rw [hforward, hbackward]
          omega

theorem secondMultiplicity_diagonal_variation_le_twice_exit
    {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (U : Finset (V × V)) :
    (∑ x : V, Nat.dist (secondMultiplicity U (p x))
      (secondMultiplicity U x)) ≤ 2 * diagonalExit p U := by
  classical
  calc
    (∑ x : V, Nat.dist (secondMultiplicity U (p x))
      (secondMultiplicity U x)) =
        ∑ x : V, Nat.dist (secondMultiplicity U (p x))
          (secondMultiplicity (diagonalImage p U) (p x)) := by
          apply Finset.sum_congr rfl
          intro x _
          rw [secondMultiplicity_diagonalImage]
    _ = ∑ x : V, Nat.dist (secondMultiplicity U x)
          (secondMultiplicity (diagonalImage p U) x) :=
          Equiv.sum_comp p (fun x =>
            Nat.dist (secondMultiplicity U x)
              (secondMultiplicity (diagonalImage p U) x))
    _ ≤ (U \ diagonalImage p U).card +
          (diagonalImage p U \ U).card :=
          secondMultiplicity_variation_le_relation_difference
            U (diagonalImage p U)
    _ = 2 * diagonalExit p U := by
          obtain ⟨hforward, hbackward⟩ := diagonalImage_sdiff_cards p U
          rw [hforward, hbackward]
          omega

theorem firstMultiplicity_totalVariation_le_twice_diagonalBoundary
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U : Finset (V × V)) :
    (∑ i : ι, ∑ x : V,
      Nat.dist (firstMultiplicity U (σ i x))
        (firstMultiplicity U x)) ≤
          2 * SoficGroups.boundary
            (fun i => (σ i).prodCongr (σ i)) U := by
  classical
  calc
    (∑ i : ι, ∑ x : V,
      Nat.dist (firstMultiplicity U (σ i x))
        (firstMultiplicity U x)) ≤
        ∑ i : ι, 2 * diagonalExit (σ i) U := by
          apply Finset.sum_le_sum
          intro i _
          exact firstMultiplicity_diagonal_variation_le_twice_exit
            (σ i) U
    _ = 2 * SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U := by
          simp [diagonalExit, SoficGroups.boundary, Finset.mul_sum]

theorem secondMultiplicity_totalVariation_le_twice_diagonalBoundary
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U : Finset (V × V)) :
    (∑ i : ι, ∑ x : V,
      Nat.dist (secondMultiplicity U (σ i x))
        (secondMultiplicity U x)) ≤
          2 * SoficGroups.boundary
            (fun i => (σ i).prodCongr (σ i)) U := by
  classical
  calc
    (∑ i : ι, ∑ x : V,
      Nat.dist (secondMultiplicity U (σ i x))
        (secondMultiplicity U x)) ≤
        ∑ i : ι, 2 * diagonalExit (σ i) U := by
          apply Finset.sum_le_sum
          intro i _
          exact secondMultiplicity_diagonal_variation_le_twice_exit
            (σ i) U
    _ = 2 * SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U := by
          simp [diagonalExit, SoficGroups.boundary, Finset.mul_sum]

def permutationVariation {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℕ) : ℕ :=
  ∑ i : ι, ∑ x : V, Nat.dist (f (σ i x)) (f x)

def positiveNatSupport {V : Type*} [Fintype V]
    (f : V → ℕ) : Finset V :=
  Finset.univ.filter (fun x => 0 < f x)

@[simp]
theorem mem_positiveNatSupport {V : Type*} [Fintype V]
    (f : V → ℕ) (x : V) :
    x ∈ positiveNatSupport f ↔ 0 < f x := by
  simp [positiveNatSupport]

theorem card_entering_eq_card_exiting
    {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (A : Finset V) :
    (Finset.univ.filter fun x => x ∉ A ∧ p x ∈ A).card =
      (A.filter fun x => p x ∉ A).card := by
  classical
  let P : Finset V := Finset.univ.filter fun x => p x ∈ A
  have hP : P.card = A.card := by
    apply Finset.card_bij (fun x _ => p x)
    · intro x hx
      exact (Finset.mem_filter.mp hx).2
    · intro x _ y _ hxy
      exact p.injective hxy
    · intro y hy
      refine ⟨p.symm y, ?_, by simp⟩
      exact Finset.mem_filter.mpr
        ⟨Finset.mem_univ _, by simpa using hy⟩
  have hsplitA :=
    Finset.card_filter_add_card_filter_not (s := A)
      (fun x => p x ∈ A)
  have hsplitP :=
    Finset.card_filter_add_card_filter_not (s := P)
      (fun x => x ∈ A)
  have hinternal :
      (P.filter fun x => x ∈ A).card =
        (A.filter fun x => p x ∈ A).card := by
    congr 1
    ext x
    simp [P, and_comm]
  have henter :
      (P.filter fun x => x ∉ A).card =
        (Finset.univ.filter fun x => x ∉ A ∧ p x ∈ A).card := by
    congr 1
    ext x
    simp [P, and_comm]
  omega

theorem sum_indicator_nat_eq_mul_card
    {V : Type*}
    (A : Finset V) (q : V → Prop) [DecidablePred q] (m : ℕ) :
    (∑ x ∈ A, if q x then m else 0) =
      m * (A.filter q).card := by
  calc
    (∑ x ∈ A, if q x then m else 0) =
        m * (∑ x ∈ A, if q x then 1 else 0) := by
          rw [Finset.mul_sum]
          apply Finset.sum_congr rfl
          intro x _
          split <;> simp
    _ = m * (A.filter q).card := by
          congr 1
          exact Finset.sum_boole (R := ℕ) q A

theorem permutationVariation_subtract_layer
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (f : V → ℕ)
    (A : Finset V) (m : ℕ)
    (hinside : ∀ x ∈ A, m ≤ f x)
    (houtside : ∀ x, x ∉ A → f x = 0) :
    permutationVariation σ f =
      permutationVariation σ
          (fun x => if x ∈ A then f x - m else 0) +
        2 * m * SoficGroups.boundary σ A := by
  classical
  let g : V → ℕ := fun x => if x ∈ A then f x - m else 0
  have hpair (i : ι) (x : V) :
      Nat.dist (f (σ i x)) (f x) =
        Nat.dist (g (σ i x)) (g x) +
          (if x ∈ A ∧ σ i x ∉ A then m else 0) +
          (if x ∉ A ∧ σ i x ∈ A then m else 0) := by
    by_cases hx : x ∈ A
    · by_cases hy : σ i x ∈ A
      · have hxlow := hinside x hx
        have hylow := hinside (σ i x) hy
        simp [g, hx, hy, Nat.dist]
        omega
      · have hyzero := houtside (σ i x) hy
        have hxlow := hinside x hx
        simp [g, hx, hy, hyzero, Nat.dist]
        omega
    · by_cases hy : σ i x ∈ A
      · have hxzero := houtside x hx
        have hylow := hinside (σ i x) hy
        simp [g, hx, hy, hxzero, Nat.dist]
        omega
      · simp [g, hx, hy, houtside x hx,
          houtside (σ i x) hy]
  have hone (i : ι) :
      (∑ x : V, Nat.dist (f (σ i x)) (f x)) =
        (∑ x : V, Nat.dist (g (σ i x)) (g x)) +
          2 * m * (A.filter fun x => σ i x ∉ A).card := by
    have hexit :
        (∑ x : V, if x ∈ A ∧ σ i x ∉ A then m else 0) =
          m * (A.filter fun x => σ i x ∉ A).card := by
      have hset :
          Finset.univ.filter
              (fun x : V => x ∈ A ∧ σ i x ∉ A) =
            A.filter fun x => σ i x ∉ A := by
        ext x
        simp
      simpa only [hset] using
        sum_indicator_nat_eq_mul_card Finset.univ
          (fun x : V => x ∈ A ∧ σ i x ∉ A) m
    have henter :
        (∑ x : V, if x ∉ A ∧ σ i x ∈ A then m else 0) =
          m * (Finset.univ.filter fun x =>
            x ∉ A ∧ σ i x ∈ A).card :=
      sum_indicator_nat_eq_mul_card
        Finset.univ (fun x => x ∉ A ∧ σ i x ∈ A) m
    calc
      (∑ x : V, Nat.dist (f (σ i x)) (f x)) =
          ∑ x : V,
            (Nat.dist (g (σ i x)) (g x) +
              (if x ∈ A ∧ σ i x ∉ A then m else 0) +
              (if x ∉ A ∧ σ i x ∈ A then m else 0)) := by
            apply Finset.sum_congr rfl
            intro x _
            exact hpair i x
      _ = (∑ x : V, Nat.dist (g (σ i x)) (g x)) +
            (∑ x : V, if x ∈ A ∧ σ i x ∉ A then m else 0) +
            (∑ x : V, if x ∉ A ∧ σ i x ∈ A then m else 0) := by
            simp_rw [Finset.sum_add_distrib]
      _ = (∑ x : V, Nat.dist (g (σ i x)) (g x)) +
            m * (A.filter fun x => σ i x ∉ A).card +
            m * (Finset.univ.filter fun x =>
              x ∉ A ∧ σ i x ∈ A).card := by
            rw [hexit, henter]
      _ = (∑ x : V, Nat.dist (g (σ i x)) (g x)) +
            2 * m * (A.filter fun x => σ i x ∉ A).card := by
            rw [card_entering_eq_card_exiting]
            ring
  unfold permutationVariation SoficGroups.boundary
  calc
    (∑ i : ι, ∑ x : V, Nat.dist (f (σ i x)) (f x)) =
        ∑ i : ι,
          ((∑ x : V, Nat.dist (g (σ i x)) (g x)) +
            2 * m * (A.filter fun x => σ i x ∉ A).card) := by
          apply Finset.sum_congr rfl
          intro i _
          exact hone i
    _ = (∑ i : ι, ∑ x : V,
          Nat.dist (g (σ i x)) (g x)) +
          2 * m *
            ∑ i : ι, (A.filter fun x => σ i x ∉ A).card := by
          simp [Finset.sum_add_distrib, Finset.mul_sum]

theorem permutation_small_support_coarea
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (h : ℝ)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (f : V → ℕ)
    (hhalf : 2 * (positiveNatSupport f).card ≤ Fintype.card V) :
    2 * h * (∑ x : V, f x) ≤
      (permutationVariation σ f : ℝ) := by
  classical
  generalize hn : (positiveNatSupport f).card = n
  induction n using Nat.strong_induction_on generalizing f with
  | h n ih =>
    by_cases hnonempty : (positiveNatSupport f).Nonempty
    · let A : Finset V := positiveNatSupport f
      have hA : A.Nonempty := hnonempty
      have himage : (A.image f).Nonempty := Finset.image_nonempty.mpr hA
      let m : ℕ := (A.image f).min' himage
      have hm_mem : m ∈ A.image f := Finset.min'_mem _ _
      obtain ⟨z, hzA, hzm⟩ := Finset.mem_image.mp hm_mem
      have hmpos : 0 < m := by
        rw [← hzm]
        exact (mem_positiveNatSupport f z).mp hzA
      have hm_le : ∀ x ∈ A, m ≤ f x := by
        intro x hx
        exact Finset.min'_le (A.image f) (f x)
          (Finset.mem_image.mpr ⟨x, hx, rfl⟩)
      let g : V → ℕ := fun x => if x ∈ A then f x - m else 0
      have hg_sub : positiveNatSupport g ⊆ A := by
        intro x hx
        have hxpos := (mem_positiveNatSupport g x).mp hx
        by_contra hxA
        simp [g, hxA] at hxpos
      have hz_not : z ∉ positiveNatSupport g := by
        intro hz
        have hzpos := (mem_positiveNatSupport g z).mp hz
        have hzero : g z = 0 := by
          simp [g, hzA, hzm]
        simp [hzero] at hzpos
      have hstrict : positiveNatSupport g ⊂ A := by
        apply Finset.ssubset_iff_subset_ne.mpr
        refine ⟨hg_sub, ?_⟩
        intro heq
        exact hz_not (heq.symm ▸ hzA)
      have hg_card : (positiveNatSupport g).card < n := by
        rw [← hn]
        exact Finset.card_lt_card hstrict
      have hg_half :
          2 * (positiveNatSupport g).card ≤ Fintype.card V :=
        (Nat.mul_le_mul_left 2 (Finset.card_le_card hg_sub)).trans hhalf
      have hg_bound :
          2 * h * (∑ x : V, g x) ≤
            (permutationVariation σ g : ℝ) :=
        ih (positiveNatSupport g).card hg_card g hg_half rfl
      have hg_bound' :
          2 * h * (∑ x : V, (g x : ℝ)) ≤
            (permutationVariation σ g : ℝ) := by
        simpa only [Nat.cast_sum] using hg_bound
      have hhalf_real :
          (2 : ℝ) * A.card ≤ Fintype.card V := by
        exact_mod_cast hhalf
      have hmin :
          (A.card : ℝ) ≤ (Fintype.card V : ℝ) - A.card := by
        linarith
      have hcut :
          h * (A.card : ℝ) ≤
            (SoficGroups.boundary σ A : ℝ) := by
        simpa [min_eq_left hmin] using hexp A
      have houtside : ∀ x, x ∉ A → f x = 0 := by
        intro x hx
        have hxnot : ¬ 0 < f x := by
          intro hpos
          exact hx ((mem_positiveNatSupport f x).mpr hpos)
        omega
      have hsum :
          (∑ x : V, f x) =
            (∑ x : V, g x) + m * A.card := by
        calc
          (∑ x : V, f x) =
              ∑ x : V, (g x + if x ∈ A then m else 0) := by
                apply Finset.sum_congr rfl
                intro x _
                by_cases hx : x ∈ A
                · have hxlow := hm_le x hx
                  simp [g, hx]
                  omega
                · simp [g, hx, houtside x hx]
          _ = (∑ x : V, g x) +
                (∑ x : V, if x ∈ A then m else 0) := by
                rw [Finset.sum_add_distrib]
          _ = (∑ x : V, g x) + m * A.card := by
                rw [sum_indicator_nat_eq_mul_card]
                simp
      have hvar :
          permutationVariation σ f =
            permutationVariation σ g +
              2 * m * SoficGroups.boundary σ A :=
        permutationVariation_subtract_layer
          σ f A m hm_le houtside
      calc
        2 * h * (∑ x : V, f x) =
            2 * h *
              ((∑ x : V, (g x : ℝ)) +
                (m : ℝ) * (A.card : ℝ)) := by
              rw [hsum]
              simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_sum]
        _ = 2 * h * (∑ x : V, (g x : ℝ)) +
              (2 * (m : ℝ)) * (h * (A.card : ℝ)) := by
              ring
        _ ≤ (permutationVariation σ g : ℝ) +
              (2 * (m : ℝ)) *
                (SoficGroups.boundary σ A : ℝ) := by
              apply add_le_add hg_bound'
              exact mul_le_mul_of_nonneg_left hcut (by positivity)
        _ = (permutationVariation σ f : ℝ) := by
              exact_mod_cast hvar.symm
    · have hzero : ∀ x, f x = 0 := by
        intro x
        by_contra hx
        apply hnonempty
        refine ⟨x, (mem_positiveNatSupport f x).mpr ?_⟩
        exact Nat.pos_of_ne_zero hx
      simp [permutationVariation, hzero]

theorem natDist_sub_one_le (a b : ℕ) :
    Nat.dist (a - 1) (b - 1) ≤ Nat.dist a b := by
  simp only [Nat.dist]
  omega

theorem natDist_zero_indicator_le (a b : ℕ) :
    Nat.dist (if a = 0 then 1 else 0)
      (if b = 0 then 1 else 0) ≤ Nat.dist a b := by
  by_cases ha : a = 0
  · by_cases hb : b = 0
    · simp [ha, hb]
    · simp [ha, hb, Nat.dist]
      omega
  · by_cases hb : b = 0
    · simp [ha, hb, Nat.dist]
      omega
    · simp [ha, hb]

theorem permutationVariation_sub_one_le
    {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℕ) :
    permutationVariation σ (fun x => f x - 1) ≤
      permutationVariation σ f := by
  unfold permutationVariation
  apply Finset.sum_le_sum
  intro i _
  apply Finset.sum_le_sum
  intro x _
  exact natDist_sub_one_le (f (σ i x)) (f x)

theorem permutationVariation_zero_indicator_le
    {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℕ) :
    permutationVariation σ (fun x => if f x = 0 then 1 else 0) ≤
      permutationVariation σ f := by
  unfold permutationVariation
  apply Finset.sum_le_sum
  intro i _
  apply Finset.sum_le_sum
  intro x _
  exact natDist_zero_indicator_le (f (σ i x)) (f x)

def singletonSupport {V : Type*} [Fintype V]
    (f : V → ℕ) : Finset V :=
  Finset.univ.filter (fun x => f x = 1)

@[simp]
theorem mem_singletonSupport {V : Type*} [Fintype V]
    (f : V → ℕ) (x : V) :
    x ∈ singletonSupport f ↔ f x = 1 := by
  simp [singletonSupport]

theorem excess_support_card_le_half_of_singletons
    {V : Type*} [Fintype V] [DecidableEq V]
    (f : V → ℕ)
    (hsingle : Fintype.card V ≤ 2 * (singletonSupport f).card) :
    2 * (positiveNatSupport (fun x => f x - 1)).card ≤
      Fintype.card V := by
  classical
  have hsub :
      positiveNatSupport (fun x => f x - 1) ⊆
        Finset.univ \ singletonSupport f := by
    intro x hx
    have hxpos :=
      (mem_positiveNatSupport (fun x => f x - 1) x).mp hx
    apply Finset.mem_sdiff.mpr
    refine ⟨Finset.mem_univ _, ?_⟩
    intro hxone
    have hone := (mem_singletonSupport f x).mp hxone
    simp [hone] at hxpos
  have hcard := Finset.card_le_card hsub
  have hpartition := Finset.card_sdiff_add_card_inter
    (Finset.univ : Finset V) (singletonSupport f)
  have hinter :
      ((Finset.univ : Finset V) ∩ singletonSupport f).card =
        (singletonSupport f).card := by
    simp
  have huniv : (Finset.univ : Finset V).card = Fintype.card V := by
    rfl
  omega

theorem zero_support_card_le_half_of_singletons
    {V : Type*} [Fintype V] [DecidableEq V]
    (f : V → ℕ)
    (hsingle : Fintype.card V ≤ 2 * (singletonSupport f).card) :
    2 * (positiveNatSupport
      (fun x => if f x = 0 then 1 else 0)).card ≤
        Fintype.card V := by
  classical
  have hsub :
      positiveNatSupport (fun x => if f x = 0 then 1 else 0) ⊆
        Finset.univ \ singletonSupport f := by
    intro x hx
    have hxpos :=
      (mem_positiveNatSupport
        (fun x => if f x = 0 then 1 else 0) x).mp hx
    apply Finset.mem_sdiff.mpr
    refine ⟨Finset.mem_univ _, ?_⟩
    intro hxone
    have hone := (mem_singletonSupport f x).mp hxone
    simp [hone] at hxpos
  have hcard := Finset.card_le_card hsub
  have hpartition := Finset.card_sdiff_add_card_inter
    (Finset.univ : Finset V) (singletonSupport f)
  have hinter :
      ((Finset.univ : Finset V) ∩ singletonSupport f).card =
        (singletonSupport f).card := by
    simp
  have huniv : (Finset.univ : Finset V).card = Fintype.card V := by
    rfl
  omega

theorem excess_mass_le_of_diagonal_variation
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (h : ℝ)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (f : V → ℕ) (B : ℕ)
    (hsingle : Fintype.card V ≤ 2 * (singletonSupport f).card)
    (hvariation : permutationVariation σ f ≤ 2 * B) :
    h * (∑ x : V, (f x - 1 : ℕ)) ≤ (B : ℝ) := by
  have hhalf := excess_support_card_le_half_of_singletons f hsingle
  have hcoarea := permutation_small_support_coarea
    σ h hexp (fun x => f x - 1) hhalf
  have hcontract := permutationVariation_sub_one_le σ f
  have htotal :
      permutationVariation σ (fun x => f x - 1) ≤ 2 * B :=
    hcontract.trans hvariation
  have htotal_real :
      (permutationVariation σ (fun x => f x - 1) : ℝ) ≤
        2 * (B : ℝ) := by
    exact_mod_cast htotal
  linarith

theorem zero_mass_le_of_diagonal_variation
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (h : ℝ)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (f : V → ℕ) (B : ℕ)
    (hsingle : Fintype.card V ≤ 2 * (singletonSupport f).card)
    (hvariation : permutationVariation σ f ≤ 2 * B) :
    h * (Finset.univ.filter fun x : V => f x = 0).card ≤
      (B : ℝ) := by
  have hhalf := zero_support_card_le_half_of_singletons f hsingle
  have hcoarea := permutation_small_support_coarea
    σ h hexp (fun x => if f x = 0 then 1 else 0) hhalf
  have hcontract := permutationVariation_zero_indicator_le σ f
  have htotal :
      permutationVariation σ (fun x => if f x = 0 then 1 else 0) ≤
        2 * B := hcontract.trans hvariation
  have htotal_real :
      (permutationVariation σ
        (fun x => if f x = 0 then 1 else 0) : ℝ) ≤
          2 * (B : ℝ) := by
    exact_mod_cast htotal
  have hsum :
      (∑ x : V, if f x = 0 then 1 else 0) =
        (Finset.univ.filter fun x : V => f x = 0).card := by
    simp
  rw [hsum] at hcoarea
  linarith

theorem first_excess_mass_le_diagonalBoundary
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U : Finset (V × V)) (h : ℝ)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hsingle : Fintype.card V ≤
      2 * (singletonSupport (firstMultiplicity U)).card) :
    h * (∑ x : V, (firstMultiplicity U x - 1 : ℕ)) ≤
      (SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
  apply excess_mass_le_of_diagonal_variation
    σ h hexp (firstMultiplicity U)
      (SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) U) hsingle
  exact firstMultiplicity_totalVariation_le_twice_diagonalBoundary
    σ U

theorem second_excess_mass_le_diagonalBoundary
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U : Finset (V × V)) (h : ℝ)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hsingle : Fintype.card V ≤
      2 * (singletonSupport (secondMultiplicity U)).card) :
    h * (∑ x : V, (secondMultiplicity U x - 1 : ℕ)) ≤
      (SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
  apply excess_mass_le_of_diagonal_variation
    σ h hexp (secondMultiplicity U)
      (SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) U) hsingle
  exact secondMultiplicity_totalVariation_le_twice_diagonalBoundary
    σ U

theorem first_zero_mass_le_diagonalBoundary
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U : Finset (V × V)) (h : ℝ)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hsingle : Fintype.card V ≤
      2 * (singletonSupport (firstMultiplicity U)).card) :
    h * (Finset.univ.filter fun x : V =>
      firstMultiplicity U x = 0).card ≤
        (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
  apply zero_mass_le_of_diagonal_variation
    σ h hexp (firstMultiplicity U)
      (SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) U) hsingle
  exact firstMultiplicity_totalVariation_le_twice_diagonalBoundary
    σ U

def nonSingletonFirstEdges {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) : Finset (V × V) :=
  U.filter (fun z => firstMultiplicity U z.1 ≠ 1)

def nonSingletonSecondEdges {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) : Finset (V × V) :=
  U.filter (fun z => secondMultiplicity U z.2 ≠ 1)

def matchedFiberEdges {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) : Finset (V × V) :=
  U.filter (fun z =>
    firstMultiplicity U z.1 = 1 ∧ secondMultiplicity U z.2 = 1)

theorem firstFiber_nonSingletonFirstEdges
    {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) (x : V) :
    firstFiber (nonSingletonFirstEdges U) x =
      if firstMultiplicity U x ≠ 1 then firstFiber U x else ∅ := by
  classical
  ext z
  by_cases hz : z.1 = x
  · by_cases hx : firstMultiplicity U x = 1
    · simp [firstFiber, nonSingletonFirstEdges, hz, hx]
    · simp [firstFiber, nonSingletonFirstEdges, hz, hx]
  · by_cases hx : firstMultiplicity U x = 1
    · simp [firstFiber, nonSingletonFirstEdges, hz, hx]
    · simp [firstFiber, nonSingletonFirstEdges, hz, hx]

theorem secondFiber_nonSingletonSecondEdges
    {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) (x : V) :
    secondFiber (nonSingletonSecondEdges U) x =
      if secondMultiplicity U x ≠ 1 then secondFiber U x else ∅ := by
  classical
  ext z
  by_cases hz : z.2 = x
  · by_cases hx : secondMultiplicity U x = 1
    · simp [secondFiber, nonSingletonSecondEdges, hz, hx]
    · simp [secondFiber, nonSingletonSecondEdges, hz, hx]
  · by_cases hx : secondMultiplicity U x = 1
    · simp [secondFiber, nonSingletonSecondEdges, hz, hx]
    · simp [secondFiber, nonSingletonSecondEdges, hz, hx]

theorem card_nonSingletonFirstEdges_le_twice_excess
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) :
    (nonSingletonFirstEdges U).card ≤
      2 * ∑ x : V, (firstMultiplicity U x - 1 : ℕ) := by
  classical
  calc
    (nonSingletonFirstEdges U).card =
        ∑ x : V, (firstFiber (nonSingletonFirstEdges U) x).card :=
          (sum_firstFiber_card (nonSingletonFirstEdges U)).symm
    _ = ∑ x : V,
          if firstMultiplicity U x ≠ 1
            then firstMultiplicity U x else 0 := by
          apply Finset.sum_congr rfl
          intro x _
          rw [firstFiber_nonSingletonFirstEdges]
          split <;> simp [firstMultiplicity]
    _ ≤ ∑ x : V, 2 * (firstMultiplicity U x - 1) := by
          apply Finset.sum_le_sum
          intro x _
          split <;> rename_i hx
          · omega
          · omega
    _ = 2 * ∑ x : V, (firstMultiplicity U x - 1) := by
          rw [Finset.mul_sum]

theorem card_nonSingletonSecondEdges_le_twice_excess
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) :
    (nonSingletonSecondEdges U).card ≤
      2 * ∑ x : V, (secondMultiplicity U x - 1 : ℕ) := by
  classical
  calc
    (nonSingletonSecondEdges U).card =
        ∑ x : V, (secondFiber (nonSingletonSecondEdges U) x).card :=
          (sum_secondFiber_card (nonSingletonSecondEdges U)).symm
    _ = ∑ x : V,
          if secondMultiplicity U x ≠ 1
            then secondMultiplicity U x else 0 := by
          apply Finset.sum_congr rfl
          intro x _
          rw [secondFiber_nonSingletonSecondEdges]
          split <;> simp [secondMultiplicity]
    _ ≤ ∑ x : V, 2 * (secondMultiplicity U x - 1) := by
          apply Finset.sum_le_sum
          intro x _
          split <;> rename_i hx
          · omega
          · omega
    _ = 2 * ∑ x : V, (secondMultiplicity U x - 1) := by
          rw [Finset.mul_sum]

theorem nonmatchedFiberEdges_subset
    {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) :
    U \ matchedFiberEdges U ⊆
      nonSingletonFirstEdges U ∪ nonSingletonSecondEdges U := by
  classical
  intro z hz
  obtain ⟨hzU, hznot⟩ := Finset.mem_sdiff.mp hz
  have hnot : ¬ (firstMultiplicity U z.1 = 1 ∧
      secondMultiplicity U z.2 = 1) := by
    intro h
    apply hznot
    exact Finset.mem_filter.mpr ⟨hzU, h⟩
  by_cases hfirst : firstMultiplicity U z.1 = 1
  · apply Finset.mem_union_right
    apply Finset.mem_filter.mpr
    exact ⟨hzU, fun hsecond => hnot ⟨hfirst, hsecond⟩⟩
  · apply Finset.mem_union_left
    exact Finset.mem_filter.mpr ⟨hzU, hfirst⟩

theorem card_nonmatchedFiberEdges_le_twice_excess
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) :
    (U \ matchedFiberEdges U).card ≤
      2 * (∑ x : V, (firstMultiplicity U x - 1 : ℕ)) +
        2 * (∑ x : V, (secondMultiplicity U x - 1 : ℕ)) := by
  calc
    (U \ matchedFiberEdges U).card ≤
        (nonSingletonFirstEdges U ∪ nonSingletonSecondEdges U).card :=
      Finset.card_le_card (nonmatchedFiberEdges_subset U)
    _ ≤ (nonSingletonFirstEdges U).card +
          (nonSingletonSecondEdges U).card :=
      Finset.card_union_le _ _
    _ ≤ 2 * (∑ x : V, (firstMultiplicity U x - 1 : ℕ)) +
          2 * (∑ x : V, (secondMultiplicity U x - 1 : ℕ)) :=
      Nat.add_le_add
        (card_nonSingletonFirstEdges_le_twice_excess U)
        (card_nonSingletonSecondEdges_le_twice_excess U)

def singletonFirstEdges {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) : Finset (V × V) :=
  U.filter (fun z => firstMultiplicity U z.1 = 1)

theorem firstFiber_singletonFirstEdges
    {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) (x : V) :
    firstFiber (singletonFirstEdges U) x =
      if firstMultiplicity U x = 1 then firstFiber U x else ∅ := by
  classical
  ext z
  by_cases hz : z.1 = x
  · by_cases hx : firstMultiplicity U x = 1
    · simp [firstFiber, singletonFirstEdges, hz, hx]
    · simp [firstFiber, singletonFirstEdges, hz, hx]
  · by_cases hx : firstMultiplicity U x = 1
    · simp [firstFiber, singletonFirstEdges, hz, hx]
    · simp [firstFiber, singletonFirstEdges, hz, hx]

theorem card_singletonFirstEdges
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) :
    (singletonFirstEdges U).card =
      (singletonSupport (firstMultiplicity U)).card := by
  classical
  calc
    (singletonFirstEdges U).card =
        ∑ x : V, (firstFiber (singletonFirstEdges U) x).card :=
          (sum_firstFiber_card (singletonFirstEdges U)).symm
    _ = ∑ x : V, if firstMultiplicity U x = 1 then 1 else 0 := by
          apply Finset.sum_congr rfl
          intro x _
          rw [firstFiber_singletonFirstEdges]
          split <;> rename_i hx
          · simpa [firstMultiplicity] using hx
          · simp
    _ = (singletonSupport (firstMultiplicity U)).card := by
          simp [singletonSupport]

theorem singletonFirstEdges_subset_matching_union
    {V : Type*} [DecidableEq V]
    (U : Finset (V × V)) :
    singletonFirstEdges U ⊆
      matchedFiberEdges U ∪ nonSingletonSecondEdges U := by
  classical
  intro z hz
  obtain ⟨hzU, hrow⟩ := Finset.mem_filter.mp hz
  by_cases hcol : secondMultiplicity U z.2 = 1
  · apply Finset.mem_union_left
    exact Finset.mem_filter.mpr ⟨hzU, hrow, hcol⟩
  · apply Finset.mem_union_right
    exact Finset.mem_filter.mpr ⟨hzU, hcol⟩

theorem card_singletonSupport_le_matching_add_column_excess
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) :
    (singletonSupport (firstMultiplicity U)).card ≤
      (matchedFiberEdges U).card +
        2 * (∑ x : V, (secondMultiplicity U x - 1 : ℕ)) := by
  rw [← card_singletonFirstEdges U]
  calc
    (singletonFirstEdges U).card ≤
        (matchedFiberEdges U ∪ nonSingletonSecondEdges U).card :=
      Finset.card_le_card (singletonFirstEdges_subset_matching_union U)
    _ ≤ (matchedFiberEdges U).card +
          (nonSingletonSecondEdges U).card :=
      Finset.card_union_le _ _
    _ ≤ (matchedFiberEdges U).card +
          2 * (∑ x : V, (secondMultiplicity U x - 1 : ℕ)) :=
      Nat.add_le_add_left
        (card_nonSingletonSecondEdges_le_twice_excess U) _

theorem card_le_zero_singleton_excess
    {V : Type*} [Fintype V]
    (f : V → ℕ) :
    Fintype.card V ≤
      (Finset.univ.filter fun x : V => f x = 0).card +
        (singletonSupport f).card +
        ∑ x : V, (f x - 1 : ℕ) := by
  classical
  calc
    Fintype.card V = ∑ _ : V, (1 : ℕ) := by
      simp
    _ ≤ ∑ x : V,
          ((if f x = 0 then 1 else 0) +
            (if f x = 1 then 1 else 0) + (f x - 1)) := by
          apply Finset.sum_le_sum
          intro x _
          by_cases hzero : f x = 0
          · simp [hzero]
          · by_cases hone : f x = 1
            · simp [hone]
            · simp [hzero, hone]
              omega
    _ = (Finset.univ.filter fun x : V => f x = 0).card +
          (singletonSupport f).card +
          ∑ x : V, (f x - 1 : ℕ) := by
          simp [Finset.sum_add_distrib, singletonSupport]

theorem unmatched_vertices_le_zero_and_excess
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) :
    Fintype.card V - (matchedFiberEdges U).card ≤
      (Finset.univ.filter fun x : V => firstMultiplicity U x = 0).card +
        (∑ x : V, (firstMultiplicity U x - 1 : ℕ)) +
        2 * (∑ x : V, (secondMultiplicity U x - 1 : ℕ)) := by
  have hpopulation := card_le_zero_singleton_excess
    (firstMultiplicity U)
  have hsingle := card_singletonSupport_le_matching_add_column_excess U
  omega

theorem matchedFiberEdges_relation_loss_bound
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U : Finset (V × V))
    (h : ℝ) (hpositive : 0 < h)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hfirst : Fintype.card V ≤
      2 * (singletonSupport (firstMultiplicity U)).card)
    (hsecond : Fintype.card V ≤
      2 * (singletonSupport (secondMultiplicity U)).card) :
    h * ((U \ matchedFiberEdges U).card : ℝ) ≤
      4 * (SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
  have hcount := card_nonmatchedFiberEdges_le_twice_excess U
  have hcount_real :
      ((U \ matchedFiberEdges U).card : ℝ) ≤
        2 * ((∑ x : V, (firstMultiplicity U x - 1 : ℕ)) : ℝ) +
          2 * ((∑ x : V, (secondMultiplicity U x - 1 : ℕ)) : ℝ) := by
    exact_mod_cast hcount
  have hrow := first_excess_mass_le_diagonalBoundary
    σ U h hexp hfirst
  have hcol := second_excess_mass_le_diagonalBoundary
    σ U h hexp hsecond
  have hrow' :
      h * (∑ x : V, ((firstMultiplicity U x - 1 : ℕ) : ℝ)) ≤
        (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
    simpa only [Nat.cast_sum] using hrow
  have hcol' :
      h * (∑ x : V, ((secondMultiplicity U x - 1 : ℕ) : ℝ)) ≤
        (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
    simpa only [Nat.cast_sum] using hcol
  calc
    h * ((U \ matchedFiberEdges U).card : ℝ) ≤
        h *
          (2 * ((∑ x : V, (firstMultiplicity U x - 1 : ℕ)) : ℝ) +
            2 * ((∑ x : V, (secondMultiplicity U x - 1 : ℕ)) : ℝ)) :=
      mul_le_mul_of_nonneg_left hcount_real hpositive.le
    _ = 2 *
          (h * (∑ x : V, ((firstMultiplicity U x - 1 : ℕ) : ℝ))) +
          2 *
          (h * (∑ x : V, ((secondMultiplicity U x - 1 : ℕ) : ℝ))) := by
      ring
    _ ≤ 4 * (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
      linarith

theorem matchedFiberEdges_vertex_loss_bound
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U : Finset (V × V))
    (h : ℝ) (hpositive : 0 < h)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hfirst : Fintype.card V ≤
      2 * (singletonSupport (firstMultiplicity U)).card)
    (hsecond : Fintype.card V ≤
      2 * (singletonSupport (secondMultiplicity U)).card) :
    h * ((Fintype.card V - (matchedFiberEdges U).card : ℕ) : ℝ) ≤
      4 * (SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
  have hcount := unmatched_vertices_le_zero_and_excess U
  have hcount_real :
      ((Fintype.card V - (matchedFiberEdges U).card : ℕ) : ℝ) ≤
        ((Finset.univ.filter fun x : V =>
          firstMultiplicity U x = 0).card : ℝ) +
          ((∑ x : V, (firstMultiplicity U x - 1 : ℕ)) : ℝ) +
          2 * ((∑ x : V, (secondMultiplicity U x - 1 : ℕ)) : ℝ) := by
    exact_mod_cast hcount
  have hzero := first_zero_mass_le_diagonalBoundary
    σ U h hexp hfirst
  have hrow := first_excess_mass_le_diagonalBoundary
    σ U h hexp hfirst
  have hcol := second_excess_mass_le_diagonalBoundary
    σ U h hexp hsecond
  have hrow' :
      h * (∑ x : V, ((firstMultiplicity U x - 1 : ℕ) : ℝ)) ≤
        (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
    simpa only [Nat.cast_sum] using hrow
  have hcol' :
      h * (∑ x : V, ((secondMultiplicity U x - 1 : ℕ) : ℝ)) ≤
        (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
    simpa only [Nat.cast_sum] using hcol
  calc
    h * ((Fintype.card V - (matchedFiberEdges U).card : ℕ) : ℝ) ≤
        h *
          (((Finset.univ.filter fun x : V =>
            firstMultiplicity U x = 0).card : ℝ) +
            ((∑ x : V, (firstMultiplicity U x - 1 : ℕ)) : ℝ) +
            2 * ((∑ x : V, (secondMultiplicity U x - 1 : ℕ)) : ℝ)) :=
      mul_le_mul_of_nonneg_left hcount_real hpositive.le
    _ = h * ((Finset.univ.filter fun x : V =>
          firstMultiplicity U x = 0).card : ℝ) +
          h * (∑ x : V, ((firstMultiplicity U x - 1 : ℕ) : ℝ)) +
          2 *
            (h * (∑ x : V, ((secondMultiplicity U x - 1 : ℕ) : ℝ))) := by
      ring
    _ ≤ 4 * (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
      linarith

theorem exists_permutation_extending_matchedFiberEdges
    {V : Type*} [DecidableEq V] (U : Finset (V × V)) :
    ∃ p : Equiv.Perm V,
      ∀ z ∈ matchedFiberEdges U, p z.1 = z.2 := by
  classical
  let A := {z : V × V // z ∈ matchedFiberEdges U}
  let f : A → V := fun z => z.1.1
  let g : A → V := fun z => z.1.2
  have hf : Function.Injective f := by
    intro z w h
    have hz := Finset.mem_filter.mp z.property
    have hw := Finset.mem_filter.mp w.property
    have hcard :
        (U.filter fun t => t.1 = z.1.1).card ≤ 1 := by
      have heq : firstMultiplicity U z.1.1 = 1 := hz.2.1
      simpa [firstMultiplicity, firstFiber] using Nat.le_of_eq heq
    have hzmem : z.1 ∈ U.filter fun t => t.1 = z.1.1 :=
      Finset.mem_filter.mpr ⟨hz.1, rfl⟩
    have hwmem : w.1 ∈ U.filter fun t => t.1 = z.1.1 := by
      apply Finset.mem_filter.mpr
      refine ⟨hw.1, ?_⟩
      exact h.symm
    exact Subtype.ext
      ((Finset.card_le_one_iff.mp hcard) hzmem hwmem)
  have hg : Function.Injective g := by
    intro z w h
    have hz := Finset.mem_filter.mp z.property
    have hw := Finset.mem_filter.mp w.property
    have hcard :
        (U.filter fun t => t.2 = z.1.2).card ≤ 1 := by
      have heq : secondMultiplicity U z.1.2 = 1 := hz.2.2
      simpa [secondMultiplicity, secondFiber] using Nat.le_of_eq heq
    have hzmem : z.1 ∈ U.filter fun t => t.2 = z.1.2 :=
      Finset.mem_filter.mpr ⟨hz.1, rfl⟩
    have hwmem : w.1 ∈ U.filter fun t => t.2 = z.1.2 := by
      apply Finset.mem_filter.mpr
      refine ⟨hw.1, ?_⟩
      exact h.symm
    exact Subtype.ext
      ((Finset.card_le_one_iff.mp hcard) hzmem hwmem)
  obtain ⟨p, hp⟩ := Equiv.Perm.exists_extending_pair f g hf hg
  refine ⟨p, ?_⟩
  intro z hz
  exact hp ⟨z, hz⟩

theorem exists_permutationGraph_containing_matchedFiberEdges
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) :
    ∃ p : Equiv.Perm V,
      matchedFiberEdges U ⊆ SoficGroups.permutationGraph p := by
  obtain ⟨p, hp⟩ := exists_permutation_extending_matchedFiberEdges U
  refine ⟨p, ?_⟩
  intro z hz
  have h :=
    (SoficGroups.mem_permutationGraph p z.1 z.2).mpr (hp z hz).symm
  simpa only [Prod.mk.eta] using h

theorem permutationGraph_card
    {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) :
    (SoficGroups.permutationGraph p).card = Fintype.card V := by
  classical
  have hinj : Function.Injective (fun x : V => (x, p x)) := by
    intro x y h
    exact congrArg Prod.fst h
  simpa [SoficGroups.permutationGraph] using
    (Finset.card_image_of_injective Finset.univ hinj)

theorem permutationGraph_sdiff_bounds_of_matchedFiberEdges
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) (p : Equiv.Perm V)
    (hp : matchedFiberEdges U ⊆ SoficGroups.permutationGraph p) :
    (SoficGroups.permutationGraph p \ U).card ≤
        Fintype.card V - (matchedFiberEdges U).card ∧
      (U \ SoficGroups.permutationGraph p).card ≤
        (U \ matchedFiberEdges U).card := by
  classical
  have hGU : matchedFiberEdges U ⊆ U := by
    intro z hz
    exact (Finset.mem_filter.mp hz).1
  have hleftsub :
      matchedFiberEdges U ⊆ U ∩ SoficGroups.permutationGraph p := by
    intro z hz
    exact Finset.mem_inter.mpr ⟨hGU hz, hp hz⟩
  have hrightsub :
      matchedFiberEdges U ⊆ SoficGroups.permutationGraph p ∩ U := by
    intro z hz
    exact Finset.mem_inter.mpr ⟨hp hz, hGU hz⟩
  have hleftcard := Finset.card_le_card hleftsub
  have hrightcard := Finset.card_le_card hrightsub
  have hgraph := permutationGraph_card p
  have hleft := Finset.card_sdiff_add_card_inter
    (SoficGroups.permutationGraph p) U
  have hright := Finset.card_sdiff_add_card_inter
    U (SoficGroups.permutationGraph p)
  have hmatched := Finset.card_sdiff_add_card_inter U (matchedFiberEdges U)
  have hinter :
      (U ∩ matchedFiberEdges U).card =
        (matchedFiberEdges U).card := by
    have hset : U ∩ matchedFiberEdges U = matchedFiberEdges U := by
      exact Finset.inter_eq_right.mpr hGU
    rw [hset]
  have hswap :
      (U ∩ SoficGroups.permutationGraph p).card =
        (SoficGroups.permutationGraph p ∩ U).card := by
    rw [Finset.inter_comm]
  constructor <;> omega

theorem boundary_le_boundary_add_sdiff
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U W : Finset V) :
    SoficGroups.boundary σ U ≤ SoficGroups.boundary σ W +
      Fintype.card ι * ((U \ W).card + (W \ U).card) := by
  classical
  have hpoint (i : ι) :
      (U.filter fun x => σ i x ∉ U).card ≤
        (W.filter fun x => σ i x ∉ W).card +
          (U \ W).card + (W \ U).card := by
    let BU := U.filter fun x => σ i x ∉ U
    let BW := W.filter fun x => σ i x ∉ W
    let E := U \ W
    let C := (W \ U).image (σ i).symm
    have hC : C.card = (W \ U).card := by
      dsimp [C]
      exact Finset.card_image_of_injective _ (σ i).symm.injective
    have hsub : BU ⊆ (BW ∪ E) ∪ C := by
      intro x hx
      obtain ⟨hxU, hxout⟩ := Finset.mem_filter.mp hx
      by_cases hxW : x ∈ W
      · by_cases himage : σ i x ∈ W
        · apply Finset.mem_union_right
          apply Finset.mem_image.mpr
          refine ⟨σ i x, Finset.mem_sdiff.mpr ⟨himage, hxout⟩, ?_⟩
          simp
        · apply Finset.mem_union_left
          apply Finset.mem_union_left
          exact Finset.mem_filter.mpr ⟨hxW, himage⟩
      · apply Finset.mem_union_left
        apply Finset.mem_union_right
        exact Finset.mem_sdiff.mpr ⟨hxU, hxW⟩
    change BU.card ≤ BW.card + (U \ W).card + (W \ U).card
    calc
      BU.card ≤ ((BW ∪ E) ∪ C).card := Finset.card_le_card hsub
      _ ≤ (BW ∪ E).card + C.card := Finset.card_union_le _ _
      _ ≤ (BW.card + E.card) + C.card :=
        Nat.add_le_add_right (Finset.card_union_le _ _) _
      _ = BW.card + (U \ W).card + (W \ U).card := by
        rw [hC]
  unfold SoficGroups.boundary
  calc
    (∑ i : ι, (U.filter fun x => σ i x ∉ U).card) ≤
        ∑ i : ι,
          ((W.filter fun x => σ i x ∉ W).card +
            (U \ W).card + (W \ U).card) := by
          apply Finset.sum_le_sum
          intro i _
          exact hpoint i
    _ = (∑ i : ι, (W.filter fun x => σ i x ∉ W).card) +
          Fintype.card ι * ((U \ W).card + (W \ U).card) := by
          simp [Finset.sum_add_distrib, mul_add, add_assoc]

theorem exists_boundary_controlled_permutation_repair
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U : Finset (V × V))
    (h : ℝ) (hpositive : 0 < h)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hfirst : Fintype.card V ≤
      2 * (singletonSupport (firstMultiplicity U)).card)
    (hsecond : Fintype.card V ≤
      2 * (singletonSupport (secondMultiplicity U)).card) :
    ∃ q : Equiv.Perm V,
      matchedFiberEdges U ⊆ SoficGroups.permutationGraph q ∧
        h * (SoficGroups.permutationCommutationDefect σ q : ℝ) ≤
          (h + 8 * (Fintype.card ι : ℝ)) *
            (SoficGroups.boundary
              (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
  classical
  obtain ⟨q, hq⟩ :=
    exists_permutationGraph_containing_matchedFiberEdges U
  obtain ⟨hgraphleft, hgraphright⟩ :=
    permutationGraph_sdiff_bounds_of_matchedFiberEdges U q hq
  have hboundary := boundary_le_boundary_add_sdiff
    (fun i => (σ i).prodCongr (σ i))
      (SoficGroups.permutationGraph q) U
  have hdefect :
      SoficGroups.permutationCommutationDefect σ q ≤
        SoficGroups.boundary
            (fun i => (σ i).prodCongr (σ i)) U +
          Fintype.card ι *
            ((Fintype.card V - (matchedFiberEdges U).card) +
              (U \ matchedFiberEdges U).card) := by
    rw [← SoficGroups.boundary_permutationGraph_eq_commutationDefect]
    apply hboundary.trans
    exact Nat.add_le_add_left
      (Nat.mul_le_mul_left (Fintype.card ι)
        (Nat.add_le_add hgraphleft hgraphright)) _
  have hdefect_real :
      (SoficGroups.permutationCommutationDefect σ q : ℝ) ≤
        (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U : ℝ) +
          (Fintype.card ι : ℝ) *
            (((Fintype.card V - (matchedFiberEdges U).card : ℕ) : ℝ) +
              ((U \ matchedFiberEdges U).card : ℝ)) := by
    exact_mod_cast hdefect
  have hvertex := matchedFiberEdges_vertex_loss_bound
    σ U h hpositive hexp hfirst hsecond
  have hrelation := matchedFiberEdges_relation_loss_bound
    σ U h hpositive hexp hfirst hsecond
  have hsum :
      h *
          (((Fintype.card V - (matchedFiberEdges U).card : ℕ) : ℝ) +
            ((U \ matchedFiberEdges U).card : ℝ)) ≤
        8 * (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
    nlinarith
  have hdnonneg : (0 : ℝ) ≤ Fintype.card ι := by
    positivity
  have hscaled := mul_le_mul_of_nonneg_left hsum hdnonneg
  refine ⟨q, hq, ?_⟩
  calc
    h * (SoficGroups.permutationCommutationDefect σ q : ℝ) ≤
        h *
          ((SoficGroups.boundary
            (fun i => (σ i).prodCongr (σ i)) U : ℝ) +
            (Fintype.card ι : ℝ) *
              (((Fintype.card V - (matchedFiberEdges U).card : ℕ) : ℝ) +
                ((U \ matchedFiberEdges U).card : ℝ))) :=
      mul_le_mul_of_nonneg_left hdefect_real hpositive.le
    _ ≤ (h + 8 * (Fintype.card ι : ℝ)) *
          (SoficGroups.boundary
            (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
      nlinarith

theorem permutationDistance_eq_card_permutationGraph_sdiff
    {V : Type*} [Fintype V] [DecidableEq V]
    (p q : Equiv.Perm V) :
    SoficGroups.permutationDistance p q =
      (SoficGroups.permutationGraph p \
        SoficGroups.permutationGraph q).card := by
  classical
  unfold SoficGroups.permutationDistance hammingDist
  apply Finset.card_bij (fun x _ => (x, p x))
  · intro x hx
    obtain ⟨_, hne⟩ := Finset.mem_filter.mp hx
    apply Finset.mem_sdiff.mpr
    refine ⟨(SoficGroups.mem_permutationGraph p x (p x)).mpr rfl, ?_⟩
    intro hxq
    exact hne ((SoficGroups.mem_permutationGraph q x (p x)).mp hxq)
  · intro x _ y _ h
    exact congrArg Prod.fst h
  · intro z hz
    obtain ⟨hzp, hzq⟩ := Finset.mem_sdiff.mp hz
    have hzsecond :=
      (SoficGroups.mem_permutationGraph p z.1 z.2).mp hzp
    refine ⟨z.1, ?_, ?_⟩
    · apply Finset.mem_filter.mpr
      refine ⟨Finset.mem_univ _, ?_⟩
      intro heq
      apply hzq
      exact (SoficGroups.mem_permutationGraph q z.1 z.2).mpr
        (hzsecond.trans heq)
    · exact Prod.ext rfl hzsecond.symm

theorem permutationDistance_le_matching_loss_add_reference
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) (q p : Equiv.Perm V)
    (hq : matchedFiberEdges U ⊆ SoficGroups.permutationGraph q) :
    SoficGroups.permutationDistance q p ≤
      Fintype.card V - (matchedFiberEdges U).card +
        (U \ SoficGroups.permutationGraph p).card := by
  classical
  obtain ⟨hleft, _⟩ :=
    permutationGraph_sdiff_bounds_of_matchedFiberEdges U q hq
  have hsub :
      SoficGroups.permutationGraph q \
          SoficGroups.permutationGraph p ⊆
        (SoficGroups.permutationGraph q \ U) ∪
          (U \ SoficGroups.permutationGraph p) := by
    intro z hz
    obtain ⟨hzq, hznot⟩ := Finset.mem_sdiff.mp hz
    by_cases hzU : z ∈ U
    · apply Finset.mem_union_right
      exact Finset.mem_sdiff.mpr ⟨hzU, hznot⟩
    · apply Finset.mem_union_left
      exact Finset.mem_sdiff.mpr ⟨hzq, hzU⟩
  rw [permutationDistance_eq_card_permutationGraph_sdiff]
  calc
    (SoficGroups.permutationGraph q \
      SoficGroups.permutationGraph p).card ≤
        ((SoficGroups.permutationGraph q \ U) ∪
          (U \ SoficGroups.permutationGraph p)).card :=
      Finset.card_le_card hsub
    _ ≤ (SoficGroups.permutationGraph q \ U).card +
          (U \ SoficGroups.permutationGraph p).card :=
      Finset.card_union_le _ _
    _ ≤ Fintype.card V - (matchedFiberEdges U).card +
          (U \ SoficGroups.permutationGraph p).card :=
      Nat.add_le_add_right hleft _

theorem exists_boundary_controlled_permutation_repair_close_to_reference
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (U : Finset (V × V))
    (p : Equiv.Perm V) (h : ℝ) (hpositive : 0 < h)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hfirst : Fintype.card V ≤
      2 * (singletonSupport (firstMultiplicity U)).card)
    (hsecond : Fintype.card V ≤
      2 * (singletonSupport (secondMultiplicity U)).card) :
    ∃ q : Equiv.Perm V,
      h * (SoficGroups.permutationDistance q p : ℝ) ≤
          4 * (SoficGroups.boundary
            (fun i => (σ i).prodCongr (σ i)) U : ℝ) +
            h * ((U \ SoficGroups.permutationGraph p).card : ℝ) ∧
        h * (SoficGroups.permutationCommutationDefect σ q : ℝ) ≤
          (h + 8 * (Fintype.card ι : ℝ)) *
            (SoficGroups.boundary
              (fun i => (σ i).prodCongr (σ i)) U : ℝ) := by
  obtain ⟨q, hq, hdefect⟩ :=
    exists_boundary_controlled_permutation_repair
      σ U h hpositive hexp hfirst hsecond
  have hdistance :=
    permutationDistance_le_matching_loss_add_reference U q p hq
  have hdistance_real :
      (SoficGroups.permutationDistance q p : ℝ) ≤
        ((Fintype.card V - (matchedFiberEdges U).card : ℕ) : ℝ) +
          ((U \ SoficGroups.permutationGraph p).card : ℝ) := by
    exact_mod_cast hdistance
  have hvertex := matchedFiberEdges_vertex_loss_bound
    σ U h hpositive hexp hfirst hsecond
  refine ⟨q, ?_, hdefect⟩
  have hscaled := mul_le_mul_of_nonneg_left hdistance_real hpositive.le
  nlinarith

theorem hasAlmostCentralizerImprovement_of_expanding_diagonal_cuts
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ)
    (h : ℝ) (hpositive : 0 < h)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hcut : ∀ p : Equiv.Perm V,
      SoficGroups.permutationCommutationDefect σ p ≤ 2 * tolerance →
        ∃ U : Finset (V × V),
          Fintype.card V ≤
            2 * (singletonSupport (firstMultiplicity U)).card ∧
          Fintype.card V ≤
            2 * (singletonSupport (secondMultiplicity U)).card ∧
          (h + 8 * (Fintype.card ι : ℝ)) *
              (SoficGroups.boundary
                (fun i => (σ i).prodCongr (σ i)) U : ℝ) ≤
            h * (tolerance : ℝ) ∧
          (5 : ℝ) *
              (4 * (SoficGroups.boundary
                (fun i => (σ i).prodCongr (σ i)) U : ℝ) +
                h * ((U \ SoficGroups.permutationGraph p).card : ℝ)) ≤
            h * (Fintype.card V : ℝ)) :
    SoficGroups.HasAlmostCentralizerImprovement σ tolerance := by
  refine ⟨?_⟩
  intro p hp
  obtain ⟨U, hfirst, hsecond, hcutdefect, hcutdistance⟩ := hcut p hp
  obtain ⟨q, hqdistance, hqdefect⟩ :=
    exists_boundary_controlled_permutation_repair_close_to_reference
      σ U p h hpositive hexp hfirst hsecond
  have hdefect_real :
      (SoficGroups.permutationCommutationDefect σ q : ℝ) ≤
        (tolerance : ℝ) := by
    nlinarith
  have hdefect :
      SoficGroups.permutationCommutationDefect σ q ≤ tolerance := by
    exact_mod_cast hdefect_real
  have hscaled := mul_le_mul_of_nonneg_left hqdistance
    (show (0 : ℝ) ≤ 5 by norm_num)
  have hdistance_real :
      (5 : ℝ) * (SoficGroups.permutationDistance q p : ℝ) ≤
        (Fintype.card V : ℝ) := by
    nlinarith
  have hdistance :
      5 * SoficGroups.permutationDistance q p ≤ Fintype.card V := by
    exact_mod_cast hdistance_real
  exact ⟨q, hdefect, hdistance⟩

theorem firstMultiplicity_permutationGraph
    {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (x : V) :
    firstMultiplicity (SoficGroups.permutationGraph p) x = 1 := by
  classical
  have hset :
      firstFiber (SoficGroups.permutationGraph p) x =
        {(x, p x)} := by
    ext z
    constructor
    · intro hz
      obtain ⟨hzgraph, hzfirst⟩ := Finset.mem_filter.mp hz
      have hzsecond :=
        (SoficGroups.mem_permutationGraph p z.1 z.2).mp hzgraph
      apply Finset.mem_singleton.mpr
      apply Prod.ext hzfirst
      exact hzsecond.trans (congrArg p hzfirst)
    · intro hz
      have heq := Finset.mem_singleton.mp hz
      subst z
      apply Finset.mem_filter.mpr
      exact ⟨(SoficGroups.mem_permutationGraph p x (p x)).mpr rfl,
        rfl⟩
  unfold firstMultiplicity
  rw [hset]
  simp

theorem secondMultiplicity_permutationGraph
    {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (x : V) :
    secondMultiplicity (SoficGroups.permutationGraph p) x = 1 := by
  classical
  have hset :
      secondFiber (SoficGroups.permutationGraph p) x =
        {(p.symm x, x)} := by
    ext z
    constructor
    · intro hz
      obtain ⟨hzgraph, hzsecond⟩ := Finset.mem_filter.mp hz
      have hgraph :=
        (SoficGroups.mem_permutationGraph p z.1 z.2).mp hzgraph
      apply Finset.mem_singleton.mpr
      apply Prod.ext
      · apply p.injective
        simpa using hgraph.symm.trans hzsecond
      · exact hzsecond
    · intro hz
      have heq := Finset.mem_singleton.mp hz
      subst z
      apply Finset.mem_filter.mpr
      refine ⟨?_, rfl⟩
      exact (SoficGroups.mem_permutationGraph p (p.symm x) x).mpr
        (p.apply_symm_apply x).symm
  unfold secondMultiplicity
  rw [hset]
  simp

theorem card_nonSingletonMultiplicity_le_total_distance
    {V : Type*} [Fintype V]
    (f : V → ℕ) :
    (Finset.univ.filter fun x : V => f x ≠ 1).card ≤
      ∑ x : V, Nat.dist (f x) 1 := by
  classical
  calc
    (Finset.univ.filter fun x : V => f x ≠ 1).card =
        ∑ x : V, if f x ≠ 1 then 1 else 0 := by
          exact
            (Finset.sum_boole (R := ℕ)
              (fun x : V => f x ≠ 1) Finset.univ).symm
    _ ≤ ∑ x : V, Nat.dist (f x) 1 := by
          apply Finset.sum_le_sum
          intro x _
          by_cases hx : f x = 1
          · simp [hx]
          · simp [hx, Nat.dist]
            omega

theorem card_nonSingletonFirstMultiplicity_le_reference_difference
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) (p : Equiv.Perm V) :
    (Finset.univ.filter fun x : V =>
      firstMultiplicity U x ≠ 1).card ≤
        (U \ SoficGroups.permutationGraph p).card +
          (SoficGroups.permutationGraph p \ U).card := by
  have hcount := card_nonSingletonMultiplicity_le_total_distance
    (firstMultiplicity U)
  have hvariation := firstMultiplicity_variation_le_relation_difference
    U (SoficGroups.permutationGraph p)
  simp_rw [firstMultiplicity_permutationGraph] at hvariation
  exact hcount.trans hvariation

theorem card_nonSingletonSecondMultiplicity_le_reference_difference
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) (p : Equiv.Perm V) :
    (Finset.univ.filter fun x : V =>
      secondMultiplicity U x ≠ 1).card ≤
        (U \ SoficGroups.permutationGraph p).card +
          (SoficGroups.permutationGraph p \ U).card := by
  have hcount := card_nonSingletonMultiplicity_le_total_distance
    (secondMultiplicity U)
  have hvariation := secondMultiplicity_variation_le_relation_difference
    U (SoficGroups.permutationGraph p)
  simp_rw [secondMultiplicity_permutationGraph] at hvariation
  exact hcount.trans hvariation

theorem first_singleton_half_of_reference_difference
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) (p : Equiv.Perm V)
    (hnear :
      2 * ((U \ SoficGroups.permutationGraph p).card +
        (SoficGroups.permutationGraph p \ U).card) ≤
          Fintype.card V) :
    Fintype.card V ≤
      2 * (singletonSupport (firstMultiplicity U)).card := by
  have hbad := card_nonSingletonFirstMultiplicity_le_reference_difference
    U p
  have hpartition :
      (singletonSupport (firstMultiplicity U)).card +
          (Finset.univ.filter fun x : V =>
            firstMultiplicity U x ≠ 1).card = Fintype.card V := by
    simpa [singletonSupport] using
      (Finset.card_filter_add_card_filter_not
        (s := (Finset.univ : Finset V))
        (fun x => firstMultiplicity U x = 1))
  omega

theorem second_singleton_half_of_reference_difference
    {V : Type*} [Fintype V] [DecidableEq V]
    (U : Finset (V × V)) (p : Equiv.Perm V)
    (hnear :
      2 * ((U \ SoficGroups.permutationGraph p).card +
        (SoficGroups.permutationGraph p \ U).card) ≤
          Fintype.card V) :
    Fintype.card V ≤
      2 * (singletonSupport (secondMultiplicity U)).card := by
  have hbad := card_nonSingletonSecondMultiplicity_le_reference_difference
    U p
  have hpartition :
      (singletonSupport (secondMultiplicity U)).card +
          (Finset.univ.filter fun x : V =>
            secondMultiplicity U x ≠ 1).card = Fintype.card V := by
    simpa [singletonSupport] using
      (Finset.card_filter_add_card_filter_not
        (s := (Finset.univ : Finset V))
        (fun x => secondMultiplicity U x = 1))
  omega

theorem hasAlmostCentralizerImprovement_of_rooted_reference_cuts
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ)
    (h : ℝ) (hpositive : 0 < h)
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hcut : ∀ p : Equiv.Perm V,
      SoficGroups.permutationCommutationDefect σ p ≤ 2 * tolerance →
        ∃ U : Finset (V × V),
          2 * ((U \ SoficGroups.permutationGraph p).card +
            (SoficGroups.permutationGraph p \ U).card) ≤
              Fintype.card V ∧
          (h + 8 * (Fintype.card ι : ℝ)) *
              (SoficGroups.boundary
                (fun i => (σ i).prodCongr (σ i)) U : ℝ) ≤
            h * (tolerance : ℝ) ∧
          (5 : ℝ) *
              (4 * (SoficGroups.boundary
                (fun i => (σ i).prodCongr (σ i)) U : ℝ) +
                h * ((U \ SoficGroups.permutationGraph p).card : ℝ)) ≤
            h * (Fintype.card V : ℝ)) :
    SoficGroups.HasAlmostCentralizerImprovement σ tolerance := by
  apply hasAlmostCentralizerImprovement_of_expanding_diagonal_cuts
    σ tolerance h hpositive hexp
  intro p hp
  obtain ⟨U, hnear, hdefect, hdistance⟩ := hcut p hp
  exact ⟨U,
    first_singleton_half_of_reference_difference U p hnear,
    second_singleton_half_of_reference_difference U p hnear,
    hdefect, hdistance⟩

end KunThomFiberCoarea

namespace KunRootedIndicatorCrossing

universe u

open Filter
open scoped BigOperators ComplexOrder InnerProductSpace Topology

theorem sum_sq_le_sq_sum_of_same_sign
    {ι : Type*} [Fintype ι] (a : ι → ℝ)
    (h : (∀ i, 0 ≤ a i) ∨ (∀ i, a i ≤ 0)) :
    (∑ i, a i ^ 2) ≤ (∑ i, a i) ^ 2 := by
  rcases h with h | h
  · exact Finset.sum_sq_le_sq_sum_of_nonneg (fun i _ => h i)
  · have hn := Finset.sum_sq_le_sq_sum_of_nonneg
      (s := Finset.univ) (f := fun i : ι => -a i)
      (fun i _ => neg_nonneg.mpr (h i))
    simpa [sq] using hn

theorem indicator_displacements_same_sign
    {ι V : Type*} (p : ι → V → V) (f : V → ℝ)
    (hf : ∀ x, f x = 0 ∨ f x = 1) (x : V) :
    (∀ i, 0 ≤ f (p i x) - f x) ∨
      (∀ i, f (p i x) - f x ≤ 0) := by
  rcases hf x with hx | hx
  · left
    intro i
    rcases hf (p i x) with hi | hi <;> simp [hx, hi]
  · right
    intro i
    rcases hf (p i x) with hi | hi <;> simp [hx, hi]

theorem sum_indicator_displacement_sq_le
    {ι V : Type*} [Fintype ι] (p : ι → V → V) (f : V → ℝ)
    (hf : ∀ x, f x = 0 ∨ f x = 1) (x : V) :
    (∑ i, (f (p i x) - f x) ^ 2) ≤
      (∑ i, (f (p i x) - f x)) ^ 2 :=
  sum_sq_le_sq_sum_of_same_sign _
    (indicator_displacements_same_sign p f hf x)

theorem sum_sum_indicator_displacement_sq_le
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → V → V) (f : V → ℝ)
    (hf : ∀ x, f x = 0 ∨ f x = 1) :
    (∑ i, ∑ x, (f (p i x) - f x) ^ 2) ≤
      ∑ x, (∑ i, (f (p i x) - f x)) ^ 2 := by
  rw [Finset.sum_comm]
  exact Finset.sum_le_sum fun x _ =>
    sum_indicator_displacement_sq_le p f hf x

theorem sum_sum_indicator_displacement_sq_le_card_sq_mul_markov_defect
    {ι V : Type*} [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → V → V) (f : V → ℝ)
    (hf : ∀ x, f x = 0 ∨ f x = 1) :
    (∑ i, ∑ x, (f (p i x) - f x) ^ 2) ≤
      (Fintype.card ι : ℝ) ^ 2 *
        ∑ x, ((∑ i, f (p i x)) / (Fintype.card ι : ℝ) - f x) ^ 2 := by
  have hd : (Fintype.card ι : ℝ) ≠ 0 := by
    exact_mod_cast Fintype.card_ne_zero
  have hpoint (x : V) :
      (Fintype.card ι : ℝ) ^ 2 *
          ((∑ i, f (p i x)) / (Fintype.card ι : ℝ) - f x) ^ 2 =
        (∑ i, (f (p i x) - f x)) ^ 2 := by
    rw [← mul_pow]
    congr 1
    rw [mul_sub, mul_div_cancel₀ _ hd, Finset.sum_sub_distrib]
    simp [mul_comm]
  calc
    (∑ i, ∑ x, (f (p i x) - f x) ^ 2) ≤
        ∑ x, (∑ i, (f (p i x) - f x)) ^ 2 :=
      sum_sum_indicator_displacement_sq_le p f hf
    _ = (Fintype.card ι : ℝ) ^ 2 *
        ∑ x, ((∑ i, f (p i x)) / (Fintype.card ι : ℝ) - f x) ^ 2 := by
      rw [Finset.mul_sum]
      exact Finset.sum_congr rfl fun x _ => (hpoint x).symm

def permutationUnitary {V : Type*} [Fintype V] (p : Equiv.Perm V) :
    EuclideanSpace ℂ V ≃ₗᵢ[ℂ] EuclideanSpace ℂ V :=
  LinearIsometryEquiv.piLpCongrLeft 2 ℂ ℂ p

theorem permutationUnitary_mul {V : Type*} [Fintype V]
    (p q : Equiv.Perm V) (ξ : EuclideanSpace ℂ V) :
    permutationUnitary (p * q) ξ =
      permutationUnitary p (permutationUnitary q ξ) := by
  ext x
  change ξ ((p * q).symm x) = ξ (q.symm (p.symm x))
  rw [Equiv.Perm.mul_def, Equiv.symm_trans_apply]

@[simp]
theorem permutationUnitary_one {V : Type*} [Fintype V]
    (ξ : EuclideanSpace ℂ V) :
    permutationUnitary (1 : Equiv.Perm V) ξ = ξ := by
  ext x
  change ξ x = ξ x
  rfl

theorem permutationUnitary_eq_of_agree_on_support
    {V : Type*} [Fintype V] (p q : Equiv.Perm V)
    (ξ : EuclideanSpace ℂ V)
    (h : ∀ x : V, ξ x ≠ 0 → p x = q x) :
    permutationUnitary p ξ = permutationUnitary q ξ := by
  ext y
  change ξ (p.symm y) = ξ (q.symm y)
  by_cases hp : ξ (p.symm y) = 0
  · rw [hp]
    have hzero : ξ (q.symm y) = 0 := by
      by_contra hq
      have hsame : q.symm y = p.symm y := by
        apply p.injective
        simpa using h (q.symm y) hq
      apply hq
      rw [hsame]
      exact hp
    exact hzero.symm
  · have hsame : p.symm y = q.symm y := by
      apply q.injective
      simpa using (h (p.symm y) hp).symm
    rw [hsame]

theorem permutationUnitary_model_mul_of_agree_on_support
    {G V : Type*} [Group G] [Fintype V]
    (σ : G → Equiv.Perm V) (a g : G) (ξ : EuclideanSpace ℂ V)
    (hroot : ∀ x : V, ξ x ≠ 0 →
      σ (a * g) x = (σ a * σ g) x) :
    permutationUnitary (σ (a * g)) ξ =
      permutationUnitary (σ a) (permutationUnitary (σ g) ξ) := by
  rw [permutationUnitary_eq_of_agree_on_support
    (σ (a * g)) (σ a * σ g) ξ hroot,
    permutationUnitary_mul]

def indicatorVector {V : Type*}
    (f : V → ℝ) : EuclideanSpace ℂ V :=
  WithLp.toLp 2 fun x => (f x : ℂ)

def permutationMarkov {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (ξ : EuclideanSpace ℂ V) :
    EuclideanSpace ℂ V :=
  (Fintype.card ι : ℂ)⁻¹ • ∑ i, permutationUnitary (p i) ξ

@[simp]
theorem permutationMarkov_apply {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (ξ : EuclideanSpace ℂ V) (x : V) :
    permutationMarkov p ξ x =
      (∑ i, ξ ((p i).symm x)) / (Fintype.card ι : ℂ) := by
  simp [permutationMarkov, permutationUnitary, div_eq_mul_inv, mul_comm]

theorem permutation_indicator_displacement_norm_sq
    {V : Type*} [Fintype V] (p : Equiv.Perm V) (f : V → ℝ) :
    ‖permutationUnitary p (indicatorVector f) - indicatorVector f‖ ^ 2 =
      ∑ x, (f (p.symm x) - f x) ^ 2 := by
  rw [EuclideanSpace.norm_sq_eq]
  apply Finset.sum_congr rfl
  intro x _
  change ‖(f (p.symm x) : ℂ) - (f x : ℂ)‖ ^ 2 =
    (f (p.symm x) - f x) ^ 2
  rw [← Complex.ofReal_sub, Complex.norm_real, Real.norm_eq_abs,
    sq_abs]

theorem permutation_indicator_markov_defect_norm_sq
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) :
    ‖permutationMarkov p (indicatorVector f) - indicatorVector f‖ ^ 2 =
      ∑ x, ((∑ i, f ((p i).symm x)) /
        (Fintype.card ι : ℝ) - f x) ^ 2 := by
  rw [EuclideanSpace.norm_sq_eq]
  apply Finset.sum_congr rfl
  intro x _
  change ‖permutationMarkov p (indicatorVector f) x -
      indicatorVector f x‖ ^ 2 = _
  rw [permutationMarkov_apply]
  change ‖(∑ i, (f ((p i).symm x) : ℂ)) /
    (Fintype.card ι : ℂ) - (f x : ℂ)‖ ^ 2 = _
  have hcast :
      (∑ i, (f ((p i).symm x) : ℂ)) /
          (Fintype.card ι : ℂ) - (f x : ℂ) =
        (((∑ i, f ((p i).symm x)) /
          (Fintype.card ι : ℝ) - f x : ℝ) : ℂ) := by
    norm_cast
  rw [hcast, Complex.norm_real, Real.norm_eq_abs, sq_abs]

theorem sum_permutation_indicator_displacement_norm_sq_le
    {ι V : Type*} [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (hf : ∀ x, f x = 0 ∨ f x = 1) :
    (∑ i, ‖permutationUnitary (p i) (indicatorVector f) -
      indicatorVector f‖ ^ 2) ≤
        (Fintype.card ι : ℝ) ^ 2 *
          ‖permutationMarkov p (indicatorVector f) -
            indicatorVector f‖ ^ 2 := by
  simp_rw [permutation_indicator_displacement_norm_sq,
    permutation_indicator_markov_defect_norm_sq]
  exact sum_sum_indicator_displacement_sq_le_card_sq_mul_markov_defect
    (fun i x => (p i).symm x) f hf

theorem permutation_indicator_displacement_norm_le_card_mul_markov_defect
    {ι V : Type*} [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (hf : ∀ x, f x = 0 ∨ f x = 1) (i : ι) :
    ‖permutationUnitary (p i) (indicatorVector f) - indicatorVector f‖ ≤
      (Fintype.card ι : ℝ) *
        ‖permutationMarkov p (indicatorVector f) - indicatorVector f‖ := by
  have hsingle :
      ‖permutationUnitary (p i) (indicatorVector f) -
        indicatorVector f‖ ^ 2 ≤
        ∑ j, ‖permutationUnitary (p j) (indicatorVector f) -
          indicatorVector f‖ ^ 2 :=
    Finset.single_le_sum
      (f := fun j : ι =>
        ‖permutationUnitary (p j) (indicatorVector f) -
          indicatorVector f‖ ^ 2)
      (fun j _ => sq_nonneg _) (Finset.mem_univ i)
  have htotal :=
    sum_permutation_indicator_displacement_norm_sq_le p f hf
  have hsq :
      ‖permutationUnitary (p i) (indicatorVector f) -
        indicatorVector f‖ ^ 2 ≤
        ((Fintype.card ι : ℝ) *
          ‖permutationMarkov p (indicatorVector f) -
            indicatorVector f‖) ^ 2 := by
    rw [mul_pow]
    exact hsingle.trans htotal
  exact (sq_le_sq₀ (norm_nonneg _) (mul_nonneg (by positivity)
    (norm_nonneg _))).mp hsq

def normalizedIndicatorDisplacement
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) (q : Equiv.Perm V) :
    EuclideanSpace ℂ V :=
  ((‖permutationMarkov p (indicatorVector f) -
      indicatorVector f‖ : ℝ) : ℂ)⁻¹ •
    (permutationUnitary q (indicatorVector f) - indicatorVector f)

theorem norm_normalizedIndicatorDisplacement_generator_le
    {ι V : Type*} [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (hf : ∀ x, f x = 0 ∨ f x = 1)
    (hdefect : permutationMarkov p (indicatorVector f) ≠
      indicatorVector f) (i : ι) :
    ‖normalizedIndicatorDisplacement p f (p i)‖ ≤
      (Fintype.card ι : ℝ) := by
  have hpos : 0 < ‖permutationMarkov p (indicatorVector f) -
      indicatorVector f‖ :=
    norm_pos_iff.mpr (sub_ne_zero.mpr hdefect)
  rw [normalizedIndicatorDisplacement, norm_smul, norm_inv,
    Complex.norm_real, Real.norm_of_nonneg (norm_nonneg _)]
  apply (inv_mul_le_iff₀ hpos).mpr
  simpa [mul_comm] using
    permutation_indicator_displacement_norm_le_card_mul_markov_defect
      p f hf i

theorem normalizedIndicatorDisplacement_mul
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (q r : Equiv.Perm V) :
    normalizedIndicatorDisplacement p f (q * r) =
      normalizedIndicatorDisplacement p f q +
        permutationUnitary q (normalizedIndicatorDisplacement p f r) := by
  unfold normalizedIndicatorDisplacement
  rw [permutationUnitary_mul]
  simp only [map_smul, map_sub, smul_sub]
  abel

theorem norm_normalizedIndicatorDisplacement_list_prod_le
    {ι V : Type*} [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (hf : ∀ x, f x = 0 ∨ f x = 1)
    (hdefect : permutationMarkov p (indicatorVector f) ≠
      indicatorVector f) (w : List ι) :
    ‖normalizedIndicatorDisplacement p f (w.map p).prod‖ ≤
      (Fintype.card ι : ℝ) * w.length := by
  induction w with
  | nil =>
      simp [normalizedIndicatorDisplacement]
  | cons i w ih =>
      rw [List.map_cons, List.prod_cons,
        normalizedIndicatorDisplacement_mul]
      calc
        ‖normalizedIndicatorDisplacement p f (p i) +
          permutationUnitary (p i)
            (normalizedIndicatorDisplacement p f (w.map p).prod)‖ ≤
            ‖normalizedIndicatorDisplacement p f (p i)‖ +
              ‖permutationUnitary (p i)
                (normalizedIndicatorDisplacement p f (w.map p).prod)‖ :=
          norm_add_le _ _
        _ = ‖normalizedIndicatorDisplacement p f (p i)‖ +
              ‖normalizedIndicatorDisplacement p f (w.map p).prod‖ := by
          rw [(permutationUnitary (p i)).norm_map]
        _ ≤ (Fintype.card ι : ℝ) +
              (Fintype.card ι : ℝ) * w.length :=
          add_le_add
            (norm_normalizedIndicatorDisplacement_generator_le
              p f hf hdefect i) ih
        _ = (Fintype.card ι : ℝ) * (i :: w).length := by
          simp only [List.length_cons, Nat.cast_add, Nat.cast_one]
          ring

def normalizedIndicatorDefect
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) :
    EuclideanSpace ℂ V :=
  ((‖permutationMarkov p (indicatorVector f) -
      indicatorVector f‖ : ℝ) : ℂ)⁻¹ •
    (permutationMarkov p (indicatorVector f) - indicatorVector f)

theorem norm_normalizedIndicatorDefect
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (hdefect : permutationMarkov p (indicatorVector f) ≠
      indicatorVector f) :
    ‖normalizedIndicatorDefect p f‖ = 1 := by
  have hne : ‖permutationMarkov p (indicatorVector f) -
      indicatorVector f‖ ≠ 0 :=
    norm_ne_zero_iff.mpr (sub_ne_zero.mpr hdefect)
  simp [normalizedIndicatorDefect, norm_smul, norm_inv,
    Complex.norm_real, hne]

theorem average_permutation_indicator_displacement
    {ι V : Type*} [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) :
    (Fintype.card ι : ℂ)⁻¹ •
        (∑ i, (permutationUnitary (p i) (indicatorVector f) -
          indicatorVector f)) =
      permutationMarkov p (indicatorVector f) - indicatorVector f := by
  have hd : (Fintype.card ι : ℂ) ≠ 0 := by
    exact_mod_cast Fintype.card_ne_zero
  rw [Finset.sum_sub_distrib, Finset.sum_const, Finset.card_univ,
    ← Nat.cast_smul_eq_nsmul ℂ]
  simp [permutationMarkov, smul_sub, smul_smul, hd]

theorem average_normalizedIndicatorDisplacement
    {ι V : Type*} [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) :
    (Fintype.card ι : ℂ)⁻¹ •
        (∑ i, normalizedIndicatorDisplacement p f (p i)) =
      normalizedIndicatorDefect p f := by
  simp_rw [normalizedIndicatorDisplacement]
  rw [← Finset.smul_sum, smul_comm,
    average_permutation_indicator_displacement]
  rfl

theorem normalizedIndicatorDisplacement_cocycle_of_agree_on_support
    {G ι V : Type*} [Group G] [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (σ : G → Equiv.Perm V) (a g : G)
    (hroot : ∀ x : V, indicatorVector f x ≠ 0 →
      σ (a * g) x = (σ a * σ g) x) :
    normalizedIndicatorDisplacement p f (σ (a * g)) =
      normalizedIndicatorDisplacement p f (σ a) +
        permutationUnitary (σ a)
          (normalizedIndicatorDisplacement p f (σ g)) := by
  unfold normalizedIndicatorDisplacement
  rw [permutationUnitary_model_mul_of_agree_on_support
    σ a g (indicatorVector f) hroot]
  simp only [map_smul, map_sub, smul_sub]
  abel

def normalizedPairDisplacement
    {G ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (σ : G → Equiv.Perm V) (q : G × G) :
    EuclideanSpace ℂ V :=
  normalizedIndicatorDisplacement p f (σ q.1) -
    normalizedIndicatorDisplacement p f (σ q.2)

theorem normalizedPairDisplacement_diagonal
    {G ι V : Type*} [Group G] [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (σ : G → Equiv.Perm V) (a g h : G)
    (hg : ∀ x : V, indicatorVector f x ≠ 0 →
      σ (a * g) x = (σ a * σ g) x)
    (hh : ∀ x : V, indicatorVector f x ≠ 0 →
      σ (a * h) x = (σ a * σ h) x) :
    normalizedPairDisplacement p f σ (a * g, a * h) =
      permutationUnitary (σ a)
        (normalizedPairDisplacement p f σ (g, h)) := by
  unfold normalizedPairDisplacement
  rw [normalizedIndicatorDisplacement_cocycle_of_agree_on_support
    p f σ a g hg,
    normalizedIndicatorDisplacement_cocycle_of_agree_on_support
      p f σ a h hh, map_sub]
  abel

theorem normalizedPairDisplacement_inner_diagonal
    {G ι V : Type*} [Group G] [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (σ : G → Equiv.Perm V) (a g h j k : G)
    (hg : ∀ x : V, indicatorVector f x ≠ 0 →
      σ (a * g) x = (σ a * σ g) x)
    (hh : ∀ x : V, indicatorVector f x ≠ 0 →
      σ (a * h) x = (σ a * σ h) x)
    (hj : ∀ x : V, indicatorVector f x ≠ 0 →
      σ (a * j) x = (σ a * σ j) x)
    (hk : ∀ x : V, indicatorVector f x ≠ 0 →
      σ (a * k) x = (σ a * σ k) x) :
    @inner ℂ (EuclideanSpace ℂ V) _
      (normalizedPairDisplacement p f σ (a * g, a * h))
      (normalizedPairDisplacement p f σ (a * j, a * k)) =
    @inner ℂ (EuclideanSpace ℂ V) _
      (normalizedPairDisplacement p f σ (g, h))
      (normalizedPairDisplacement p f σ (j, k)) := by
  rw [normalizedPairDisplacement_diagonal p f σ a g h hg hh,
    normalizedPairDisplacement_diagonal p f σ a j k hj hk]
  exact (permutationUnitary (σ a)).inner_map_map _ _

theorem normalizedPairDisplacement_add
    {G ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (σ : G → Equiv.Perm V) (g h j : G) :
    normalizedPairDisplacement p f σ (g, h) +
      normalizedPairDisplacement p f σ (h, j) =
        normalizedPairDisplacement p f σ (g, j) := by
  unfold normalizedPairDisplacement
  abel

theorem norm_normalizedPairDisplacement_le_of_words
    {G ι V : Type*} [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (hf : ∀ x, f x = 0 ∨ f x = 1)
    (hdefect : permutationMarkov p (indicatorVector f) ≠
      indicatorVector f)
    (σ : G → Equiv.Perm V) (w : G → List ι)
    (hw : ∀ g, σ g = ((w g).map p).prod) (g h : G) :
    ‖normalizedPairDisplacement p f σ (g, h)‖ ≤
      (Fintype.card ι : ℝ) *
        ((w g).length + (w h).length) := by
  unfold normalizedPairDisplacement
  calc
    ‖normalizedIndicatorDisplacement p f (σ g) -
      normalizedIndicatorDisplacement p f (σ h)‖ ≤
        ‖normalizedIndicatorDisplacement p f (σ g)‖ +
          ‖normalizedIndicatorDisplacement p f (σ h)‖ :=
      norm_sub_le _ _
    _ ≤ (Fintype.card ι : ℝ) * (w g).length +
          (Fintype.card ι : ℝ) * (w h).length := by
      rw [hw g, hw h]
      exact add_le_add
        (norm_normalizedIndicatorDisplacement_list_prod_le
          p f hf hdefect (w g))
        (norm_normalizedIndicatorDisplacement_list_prod_le
          p f hf hdefect (w h))
    _ = (Fintype.card ι : ℝ) *
          ((w g).length + (w h).length) := by
      ring

theorem exists_hyperfilter_gram_limit_of_pointwise_bound
    {I : Type*} {H : ℕ → Type*}
    [∀ n, SeminormedAddCommGroup (H n)]
    [∀ n, InnerProductSpace ℂ (H n)]
    (v : ∀ n, I → H n) (B : I → ℝ)
    (hbound : ∀ n i, ‖v n i‖ ≤ B i) :
    ∃ K : Matrix I I ℂ,
      ∀ i j, Tendsto (fun n => ⟪v n i, v n j⟫_ℂ)
        (Filter.hyperfilter ℕ) (𝓝 (K i j)) := by
  have hinnerbound (n : ℕ) (i j : I) :
      ‖⟪v n i, v n j⟫_ℂ‖ ≤ B i * B j := by
    calc
      ‖⟪v n i, v n j⟫_ℂ‖ ≤ ‖v n i‖ * ‖v n j‖ :=
        norm_inner_le_norm _ _
      _ ≤ B i * B j :=
        mul_le_mul (hbound n i) (hbound n j)
          (norm_nonneg _) ((norm_nonneg _).trans (hbound n i))
  let b : ℕ → (q : I × I) →
      Metric.closedBall (0 : ℂ) (B q.1 * B q.2) :=
    fun n q =>
      ⟨⟪v n q.1, v n q.2⟫_ℂ,
        by simpa [Metric.mem_closedBall, dist_zero_right]
          using hinnerbound n q.1 q.2⟩
  let u := Ultrafilter.map b (Filter.hyperfilter ℕ)
  let L : (q : I × I) →
      Metric.closedBall (0 : ℂ) (B q.1 * B q.2) := u.lim
  let K : Matrix I I ℂ := fun i j => (L (i, j) : ℂ)
  refine ⟨K, ?_⟩
  have hu : Tendsto b (Filter.hyperfilter ℕ) (𝓝 L) := by
    change Filter.map b (↑(Filter.hyperfilter ℕ) : Filter ℕ) ≤
      𝓝 u.lim
    simpa only [u, Ultrafilter.coe_map] using u.le_nhds_lim
  intro i j
  have heval :
      Tendsto
        (fun f : (q : I × I) →
          Metric.closedBall (0 : ℂ) (B q.1 * B q.2) => f (i, j))
        (𝓝 L) (𝓝 (L (i, j))) :=
    (continuous_apply (i, j)).tendsto L
  have hval :
      Tendsto
        (fun z : Metric.closedBall (0 : ℂ) (B i * B j) => (z : ℂ))
        (𝓝 (L (i, j))) (𝓝 (L (i, j) : ℂ)) :=
    continuous_subtype_val.tendsto (L (i, j))
  have hcomp := hval.comp (heval.comp hu)
  change Tendsto (fun n => ⟪v n i, v n j⟫_ℂ)
    (Filter.hyperfilter ℕ) (𝓝 (L (i, j) : ℂ)) at hcomp
  exact hcomp

theorem gram_posSemidef_infinite
    {I H : Type*} [SeminormedAddCommGroup H]
    [InnerProductSpace ℂ H] (v : I → H) :
    (Matrix.gram ℂ v).PosSemidef := by
  refine ⟨Matrix.isHermitian_gram ℂ v, ?_⟩
  intro c
  calc
    (0 : ℂ) ≤
        ⟪c.sum (fun i z => z • v i),
          c.sum (fun i z => z • v i)⟫_ℂ :=
      RCLike.nonneg_iff.mpr ⟨inner_self_nonneg, inner_self_im _⟩
    _ = c.sum (fun i z =>
          c.sum (fun j w => star z * (Matrix.gram ℂ v) i j * w)) := by
      rw [Finsupp.sum_inner]
      apply Finsupp.sum_congr
      intro i hi
      rw [Finsupp.inner_sum]
      apply Finsupp.sum_congr
      intro j hj
      simp only [inner_smul_left, inner_smul_right,
        Matrix.gram_apply, RCLike.star_def]
      ring

theorem exists_hyperfilter_positive_gram_kernel_of_pointwise_bound
    {I : Type*} {H : ℕ → Type*}
    [∀ n, SeminormedAddCommGroup (H n)]
    [∀ n, InnerProductSpace ℂ (H n)]
    (v : ∀ n, I → H n) (B : I → ℝ)
    (hbound : ∀ n i, ‖v n i‖ ≤ B i) :
    ∃ K : Matrix I I ℂ,
      K.PosSemidef ∧
      ∀ i j, Tendsto (fun n => ⟪v n i, v n j⟫_ℂ)
        (Filter.hyperfilter ℕ) (𝓝 (K i j)) := by
  obtain ⟨K, hconv⟩ :=
    exists_hyperfilter_gram_limit_of_pointwise_bound v B hbound
  have hhermitian : K.IsHermitian := by
    apply Matrix.IsHermitian.ext
    intro i j
    apply tendsto_nhds_unique (hconv j i).star
    have hsymm :
        (fun n => star ⟪v n j, v n i⟫_ℂ) =
          (fun n => ⟪v n i, v n j⟫_ℂ) := by
      funext n
      exact inner_conj_symm _ _
    rw [hsymm]
    exact hconv i j
  refine ⟨K, ⟨hhermitian, ?_⟩, hconv⟩
  intro c
  have hquadratic :
      Tendsto
        (fun n => c.sum fun i z =>
          c.sum fun j w => star z * ⟪v n i, v n j⟫_ℂ * w)
        (Filter.hyperfilter ℕ)
        (𝓝 (c.sum fun i z =>
          c.sum fun j w => star z * K i j * w)) := by
    simpa only [Finsupp.sum] using
      tendsto_finsetSum c.support (fun i _ =>
        tendsto_finsetSum c.support (fun j _ =>
          (tendsto_const_nhds.mul (hconv i j)).mul
            tendsto_const_nhds))
  apply ge_of_tendsto hquadratic
  exact Eventually.of_forall fun n =>
    (gram_posSemidef_infinite (v n)).2 c

theorem exists_hyperfilter_diagonal_positive_pair_kernel
    {G : Type*} [Group G] {H : ℕ → Type*}
    [∀ n, SeminormedAddCommGroup (H n)]
    [∀ n, InnerProductSpace ℂ (H n)]
    (v : ∀ n, G × G → H n) (B : G × G → ℝ)
    (hbound : ∀ n q, ‖v n q‖ ≤ B q)
    (hdiagonal : ∀ a g h j k : G,
      ∀ᶠ n in Filter.atTop,
        ⟪v n (a * g, a * h), v n (a * j, a * k)⟫_ℂ =
          ⟪v n (g, h), v n (j, k)⟫_ℂ)
    (hadd : ∀ n (g h j : G),
      v n (g, h) + v n (h, j) = v n (g, j)) :
    ∃ K : Matrix (G × G) (G × G) ℂ,
      K.PosSemidef ∧
      (∀ a g h j k : G,
        K (a * g, a * h) (a * j, a * k) = K (g, h) (j, k)) ∧
      (∀ g h j : G, ∀ q : G × G,
        K (g, h) q + K (h, j) q = K (g, j) q) ∧
      ∀ q r, Tendsto (fun n => ⟪v n q, v n r⟫_ℂ)
        (Filter.hyperfilter ℕ) (𝓝 (K q r)) := by
  obtain ⟨K, hpositive, hconv⟩ :=
    exists_hyperfilter_positive_gram_kernel_of_pointwise_bound
      v B hbound
  refine ⟨K, hpositive, ?_, ?_, hconv⟩
  · intro a g h j k
    have hevent :
        (fun n =>
          ⟪v n (a * g, a * h), v n (a * j, a * k)⟫_ℂ) =ᶠ[
          (Filter.hyperfilter ℕ : Filter ℕ)]
            (fun n => ⟪v n (g, h), v n (j, k)⟫_ℂ) :=
      (hdiagonal a g h j k).filter_mono Nat.hyperfilter_le_atTop
    exact tendsto_nhds_unique
      (hconv (a * g, a * h) (a * j, a * k))
      (Tendsto.congr' hevent.symm (hconv (g, h) (j, k)))
  · intro g h j q
    have haddconv :=
      (hconv (g, h) q).add (hconv (h, j) q)
    have hfunctions :
        (fun n =>
          ⟪v n (g, h), v n q⟫_ℂ +
            ⟪v n (h, j), v n q⟫_ℂ) =
          (fun n => ⟪v n (g, j), v n q⟫_ℂ) := by
      funext n
      rw [← inner_add_left, hadd]
    exact tendsto_nhds_unique haddconv
      (by rw [hfunctions]; exact hconv (g, j) q)

theorem exists_hyperfilter_diagonal_positive_pair_kernel_of_rooted_indicators
    {G ι : Type*} [Group G] [Fintype ι] [Nonempty ι]
    {V : ℕ → Type*} [∀ n, Fintype (V n)]
    (p : ∀ n, ι → Equiv.Perm (V n))
    (f : ∀ n, V n → ℝ)
    (σ : ∀ n, G → Equiv.Perm (V n))
    (w : G → List ι)
    (hf : ∀ n x, f n x = 0 ∨ f n x = 1)
    (hdefect : ∀ n, permutationMarkov (p n) (indicatorVector (f n)) ≠
      indicatorVector (f n))
    (hw : ∀ n g, σ n g = ((w g).map (p n)).prod)
    (hroot : ∀ a g : G, ∀ᶠ n in Filter.atTop,
      ∀ x : V n, indicatorVector (f n) x ≠ 0 →
        σ n (a * g) x = (σ n a * σ n g) x) :
    ∃ K : Matrix (G × G) (G × G) ℂ,
      K.PosSemidef ∧
      (∀ a g h j k : G,
        K (a * g, a * h) (a * j, a * k) = K (g, h) (j, k)) ∧
      (∀ g h j : G, ∀ q : G × G,
        K (g, h) q + K (h, j) q = K (g, j) q) ∧
      ∀ q r,
        Tendsto
          (fun n =>
            ⟪normalizedPairDisplacement (p n) (f n) (σ n) q,
              normalizedPairDisplacement (p n) (f n) (σ n) r⟫_ℂ)
          (Filter.hyperfilter ℕ) (𝓝 (K q r)) := by
  let v : ∀ n, G × G → EuclideanSpace ℂ (V n) :=
    fun n q => normalizedPairDisplacement (p n) (f n) (σ n) q
  let B : G × G → ℝ := fun q =>
    (Fintype.card ι : ℝ) * ((w q.1).length + (w q.2).length)
  apply exists_hyperfilter_diagonal_positive_pair_kernel v B
  · intro n q
    exact norm_normalizedPairDisplacement_le_of_words
      (p n) (f n) (hf n) (hdefect n) (σ n) w (hw n) q.1 q.2
  · intro a g h j k
    filter_upwards [hroot a g, hroot a h, hroot a j, hroot a k]
      with n hg hh hj hk
    exact normalizedPairDisplacement_inner_diagonal
      (p n) (f n) (σ n) a g h j k hg hh hj hk
  · intro n g h j
    exact normalizedPairDisplacement_add (p n) (f n) (σ n) g h j

def scalarOperatorKernel {I : Type u} (K : Matrix I I ℂ) :
    Matrix I I (ℂ →L[ℂ] ℂ) :=
  fun g h => ContinuousLinearMap.toSpanSingleton ℂ (K g h)

theorem scalarOperatorKernel_posSemidef {I : Type u}
    (K : Matrix I I ℂ) (hK : K.PosSemidef) :
    (scalarOperatorKernel K).PosSemidef := by
  apply ((RKHS.posSemidef_tfae
    (K := scalarOperatorKernel K)).out 2 0).mp
  constructor
  · apply Matrix.IsHermitian.ext
    intro g h
    change star (ContinuousLinearMap.toSpanSingleton ℂ (K h g)) =
      ContinuousLinearMap.toSpanSingleton ℂ (K g h)
    rw [ContinuousLinearMap.star_eq_adjoint,
      ContinuousLinearMap.adjoint_toSpanSingleton]
    apply ContinuousLinearMap.ext
    intro z
    calc
      (innerSL ℂ (K h g)) z = star (K h g) * z := by
        simp only [innerSL_apply_apply, RCLike.inner_apply',
          RCLike.star_def]
      _ = K g h * z := by rw [hK.isHermitian.apply g h]
      _ = z * K g h := mul_comm _ _
      _ = (ContinuousLinearMap.toSpanSingleton ℂ (K g h)) z := by
        simp only [ContinuousLinearMap.toSpanSingleton_apply,
          smul_eq_mul]
  · intro c
    have hc := hK.2 c
    have hreal :
        0 ≤ RCLike.re (c.sum fun g z =>
          c.sum fun h w => star z * K g h * w) :=
      (RCLike.nonneg_iff.mp hc).1
    simp only [scalarOperatorKernel,
      ContinuousLinearMap.toSpanSingleton_apply,
      RCLike.inner_apply', smul_eq_mul, map_mul]
    simpa only [← RCLike.star_def, hK.isHermitian.apply,
      mul_assoc, mul_left_comm, mul_comm] using hreal

theorem preKernel_inner_single {I : Type u}
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (i j : I × ℂ) (z w : ℂ) :
    ⟪(Finsupp.single i z : RKHS.H₀ (scalarOperatorKernel K)),
      (Finsupp.single j w : RKHS.H₀ (scalarOperatorKernel K))⟫_ℂ =
      star z * w *
        ⟪scalarOperatorKernel K j.1 i.1 i.2, j.2⟫_ℂ := by
  change
    (Finsupp.single i z).sum (fun yu c =>
      (Finsupp.single j w).sum (fun xv d =>
        star c * d *
          ⟪scalarOperatorKernel K xv.1 yu.1 yu.2, xv.2⟫_ℂ)) = _
  simp

def actionPreKernelTranslation {G I : Type u} [Group G]
    (K : Matrix I I ℂ) (ρ : G →* Equiv.Perm I) (a : G) :
    RKHS.H₀ (scalarOperatorKernel K) ≃ₗ[ℂ]
      RKHS.H₀ (scalarOperatorKernel K) :=
  Finsupp.domLCongr ((ρ a).prodCongr (Equiv.refl ℂ))

theorem actionPreKernelTranslation_inner {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (a : G) (f g : RKHS.H₀ (scalarOperatorKernel K)) :
    ⟪actionPreKernelTranslation K ρ a f,
      actionPreKernelTranslation K ρ a g⟫_ℂ = ⟪f, g⟫_ℂ := by
  induction f using Finsupp.induction_linear generalizing g with
  | zero => simp
  | add f₁ f₂ ih₁ ih₂ =>
    simp [map_add, inner_add_left, ih₁ g, ih₂ g]
  | single i z =>
    induction g using Finsupp.induction_linear with
    | zero => simp
    | add g₁ g₂ ih₁ ih₂ =>
      simp [map_add, inner_add_right, ih₁, ih₂]
    | single j w =>
      simp only [actionPreKernelTranslation,
        Finsupp.domLCongr_single, preKernel_inner_single,
        scalarOperatorKernel,
        ContinuousLinearMap.toSpanSingleton_apply]
      change
        star z * w * ⟪i.2 • K (ρ a j.1) (ρ a i.1), j.2⟫_ℂ =
          star z * w * ⟪i.2 • K j.1 i.1, j.2⟫_ℂ
      rw [hinv]

def actionPreKernelTranslationIsometry {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (a : G) :
    RKHS.H₀ (scalarOperatorKernel K) ≃ₗᵢ[ℂ]
      RKHS.H₀ (scalarOperatorKernel K) :=
  (actionPreKernelTranslation K ρ a).isometryOfInner
    (actionPreKernelTranslation_inner K ρ hinv a)

def actionKernelTranslationMap {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (a : G) :
    RKHS.OfKernel (scalarOperatorKernel K) →L[ℂ]
      RKHS.OfKernel (scalarOperatorKernel K) :=
  ContinuousLinearMap.completion
    ((actionPreKernelTranslationIsometry K ρ hinv a).toLinearIsometry.toContinuousLinearMap)

@[simp]
theorem actionKernelTranslationMap_coe {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (a : G) (f : RKHS.H₀ (scalarOperatorKernel K)) :
    actionKernelTranslationMap K ρ hinv a
      (f : RKHS.OfKernel (scalarOperatorKernel K)) =
        (actionPreKernelTranslation K ρ a f :
          RKHS.OfKernel (scalarOperatorKernel K)) := by
  exact ContinuousLinearMap.completion_apply_coe
    ((actionPreKernelTranslationIsometry K ρ hinv a).toLinearIsometry.toContinuousLinearMap) f

theorem actionKernelTranslationMap_isometry {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (a : G) : Isometry (actionKernelTranslationMap K ρ hinv a) := by
  change Isometry (UniformSpace.Completion.map
    (actionPreKernelTranslationIsometry K ρ hinv a))
  exact (actionPreKernelTranslationIsometry K ρ hinv a).isometry.completion_map

theorem actionPreKernelTranslation_mul_apply {G I : Type u} [Group G]
    (K : Matrix I I ℂ) (ρ : G →* Equiv.Perm I)
    (a b : G) (f : RKHS.H₀ (scalarOperatorKernel K)) :
    actionPreKernelTranslation K ρ (a * b) f =
      actionPreKernelTranslation K ρ a
        (actionPreKernelTranslation K ρ b f) := by
  induction f using Finsupp.induction_linear with
  | zero => simp
  | add f g hf hg => simp [map_add, hf, hg]
  | single i z =>
    simp only [actionPreKernelTranslation,
      Finsupp.domLCongr_single]
    change Finsupp.single (ρ (a * b) i.1, i.2) z =
      Finsupp.single (ρ a (ρ b i.1), i.2) z
    rw [map_mul]
    rfl

@[simp]
theorem actionPreKernelTranslation_one_apply {G I : Type u} [Group G]
    (K : Matrix I I ℂ) (ρ : G →* Equiv.Perm I)
    (f : RKHS.H₀ (scalarOperatorKernel K)) :
    actionPreKernelTranslation K ρ 1 f = f := by
  induction f using Finsupp.induction_linear with
  | zero => simp
  | add f g hf hg => simp [map_add, hf, hg]
  | single i z =>
    simp only [actionPreKernelTranslation,
      Finsupp.domLCongr_single]
    change Finsupp.single (ρ 1 i.1, i.2) z =
      Finsupp.single (i.1, i.2) z
    simp

theorem actionKernelTranslationMap_mul_apply {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (a b : G) (x : RKHS.OfKernel (scalarOperatorKernel K)) :
    actionKernelTranslationMap K ρ hinv (a * b) x =
      actionKernelTranslationMap K ρ hinv a
        (actionKernelTranslationMap K ρ hinv b x) := by
  induction x using UniformSpace.Completion.induction_on with
  | hp =>
    exact isClosed_eq
      (actionKernelTranslationMap K ρ hinv (a * b)).continuous
      ((actionKernelTranslationMap K ρ hinv a).continuous.comp
        (actionKernelTranslationMap K ρ hinv b).continuous)
  | ih f =>
    simp only [actionKernelTranslationMap_coe,
      actionPreKernelTranslation_mul_apply]

@[simp]
theorem actionKernelTranslationMap_one_apply {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (x : RKHS.OfKernel (scalarOperatorKernel K)) :
    actionKernelTranslationMap K ρ hinv 1 x = x := by
  induction x using UniformSpace.Completion.induction_on with
  | hp =>
    exact isClosed_eq
      (actionKernelTranslationMap K ρ hinv 1).continuous
      continuous_id
  | ih f =>
    simp only [actionKernelTranslationMap_coe,
      actionPreKernelTranslation_one_apply]

def actionKernelTranslationLinearEquiv {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (a : G) :
    RKHS.OfKernel (scalarOperatorKernel K) ≃ₗ[ℂ]
      RKHS.OfKernel (scalarOperatorKernel K) where
  toLinearMap := (actionKernelTranslationMap K ρ hinv a).toLinearMap
  invFun := actionKernelTranslationMap K ρ hinv a⁻¹
  left_inv x := by
    calc
      actionKernelTranslationMap K ρ hinv a⁻¹
        (actionKernelTranslationMap K ρ hinv a x) =
          actionKernelTranslationMap K ρ hinv (a⁻¹ * a) x :=
            (actionKernelTranslationMap_mul_apply
              K ρ hinv a⁻¹ a x).symm
      _ = x := by simp
  right_inv x := by
    calc
      actionKernelTranslationMap K ρ hinv a
        (actionKernelTranslationMap K ρ hinv a⁻¹ x) =
          actionKernelTranslationMap K ρ hinv (a * a⁻¹) x :=
            (actionKernelTranslationMap_mul_apply
              K ρ hinv a a⁻¹ x).symm
      _ = x := by simp

def actionKernelTranslationUnitary {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (a : G) :
    RKHS.OfKernel (scalarOperatorKernel K) ≃ₗᵢ[ℂ]
      RKHS.OfKernel (scalarOperatorKernel K) where
  toLinearEquiv := actionKernelTranslationLinearEquiv K ρ hinv a
  norm_map' :=
    (actionKernelTranslationMap_isometry K ρ hinv a).norm_map_of_map_zero
      (map_zero (actionKernelTranslationMap K ρ hinv a))

def actionKernelUnitaryRepresentation {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j) :
    G →* (RKHS.OfKernel (scalarOperatorKernel K) ≃ₗᵢ[ℂ]
      RKHS.OfKernel (scalarOperatorKernel K)) where
  toFun := actionKernelTranslationUnitary K ρ hinv
  map_one' := by
    apply LinearIsometryEquiv.ext
    intro x
    change actionKernelTranslationMap K ρ hinv 1 x = x
    exact actionKernelTranslationMap_one_apply K ρ hinv x
  map_mul' a b := by
    apply LinearIsometryEquiv.ext
    intro x
    change actionKernelTranslationMap K ρ hinv (a * b) x =
      actionKernelTranslationMap K ρ hinv a
        (actionKernelTranslationMap K ρ hinv b x)
    exact actionKernelTranslationMap_mul_apply K ρ hinv a b x

def diagonalPairAction (G : Type u) [Group G] :
    G →* Equiv.Perm (G × G) where
  toFun a := (Equiv.mulLeft a).prodCongr (Equiv.mulLeft a)
  map_one' := by
    apply Equiv.ext
    intro x
    exact Prod.ext (one_mul x.1) (one_mul x.2)
  map_mul' a b := by
    apply Equiv.ext
    intro x
    apply Prod.ext
    · exact mul_assoc a b x.1
    · exact mul_assoc a b x.2

def diagonalPairKernelUnitaryRepresentation {G : Type u} [Group G]
    (K : Matrix (G × G) (G × G) ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (hinv : ∀ a g h j k : G,
      K (a * g, a * h) (a * j, a * k) = K (g, h) (j, k)) :
    G →* (RKHS.OfKernel (scalarOperatorKernel K) ≃ₗᵢ[ℂ]
      RKHS.OfKernel (scalarOperatorKernel K)) :=
  actionKernelUnitaryRepresentation K (diagonalPairAction G)
    (fun a x y => hinv a x.1 x.2 y.1 y.2)

theorem ofKernel_kerFun_one_eq_coe_single
    {I : Type u} (L : Matrix I I (ℂ →L[ℂ] ℂ))
    [Fact L.PosSemidef] (i : I) :
    RKHS.kerFun (RKHS.OfKernel L) i (1 : ℂ) =
      ((Finsupp.single (i, (1 : ℂ)) (1 : ℂ) : RKHS.H₀ L) :
        RKHS.OfKernel L) := by
  simp [RKHS.kerFun, RKHS.coeCLM]

theorem actionKernelUnitaryRepresentation_kerFun_one
    {G I : Type u} [Group G]
    (K : Matrix I I ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (ρ : G →* Equiv.Perm I)
    (hinv : ∀ a i j, K (ρ a i) (ρ a j) = K i j)
    (a : G) (i : I) :
    actionKernelUnitaryRepresentation K ρ hinv a
      (RKHS.kerFun (RKHS.OfKernel (scalarOperatorKernel K)) i
        (1 : ℂ)) =
      RKHS.kerFun (RKHS.OfKernel (scalarOperatorKernel K))
        (ρ a i) (1 : ℂ) := by
  rw [ofKernel_kerFun_one_eq_coe_single
    (scalarOperatorKernel K) i,
    ofKernel_kerFun_one_eq_coe_single
      (scalarOperatorKernel K) (ρ a i)]
  change
    actionKernelTranslationMap K ρ hinv a
      ((Finsupp.single (i, (1 : ℂ)) (1 : ℂ) :
        RKHS.H₀ (scalarOperatorKernel K)) :
          RKHS.OfKernel (scalarOperatorKernel K)) = _
  rw [actionKernelTranslationMap_coe]
  simp [actionPreKernelTranslation]

theorem diagonalPairKernelUnitaryRepresentation_kerFun_one
    {G : Type u} [Group G]
    (K : Matrix (G × G) (G × G) ℂ)
    [Fact (scalarOperatorKernel K).PosSemidef]
    (hinv : ∀ a g h j k : G,
      K (a * g, a * h) (a * j, a * k) = K (g, h) (j, k))
    (a g h : G) :
    diagonalPairKernelUnitaryRepresentation K hinv a
      (RKHS.kerFun (RKHS.OfKernel (scalarOperatorKernel K))
        (g, h) (1 : ℂ)) =
      RKHS.kerFun (RKHS.OfKernel (scalarOperatorKernel K))
        (a * g, a * h) (1 : ℂ) := by
  exact actionKernelUnitaryRepresentation_kerFun_one K
    (diagonalPairAction G)
    (fun a x y => hinv a x.1 x.2 y.1 y.2) a (g, h)

structure HilbertKernelRealization {I : Type u}
    (K : Matrix I I ℂ) where
  carrier : Type u
  [normed : NormedAddCommGroup carrier]
  [inner : InnerProductSpace ℂ carrier]
  [complete : CompleteSpace carrier]
  vector : I → carrier
  gram : ∀ g h, ⟪vector g, vector h⟫_ℂ = K g h

instance hilbertKernelRealizationNormedAddCommGroup
    {I : Type u} {K : Matrix I I ℂ}
    (R : HilbertKernelRealization K) : NormedAddCommGroup R.carrier :=
  R.normed

instance hilbertKernelRealizationInnerProductSpace
    {I : Type u} {K : Matrix I I ℂ}
    (R : HilbertKernelRealization K) : InnerProductSpace ℂ R.carrier :=
  R.inner

instance hilbertKernelRealizationCompleteSpace
    {I : Type u} {K : Matrix I I ℂ}
    (R : HilbertKernelRealization K) : CompleteSpace R.carrier :=
  R.complete

theorem hilbertKernelRealization_pair_vector_add
    {G : Type u} (K : Matrix (G × G) (G × G) ℂ)
    (R : HilbertKernelRealization K)
    (hadd : ∀ g h j : G, ∀ q : G × G,
      K (g, h) q + K (h, j) q = K (g, j) q)
    (g h j : G) :
    R.vector (g, h) + R.vector (h, j) = R.vector (g, j) := by
  have horth (q : G × G) :
      ⟪R.vector (g, h) + R.vector (h, j) - R.vector (g, j),
        R.vector q⟫_ℂ = 0 := by
    rw [inner_sub_left, inner_add_left,
      R.gram, R.gram, R.gram, hadd]
    exact sub_self _
  apply sub_eq_zero.mp
  apply (inner_self_eq_zero (𝕜 := ℂ)).mp
  rw [inner_sub_right, inner_add_right,
    horth (g, h), horth (h, j), horth (g, j)]
  simp

structure EquivariantHilbertKernelRealization
    {G : Type u} [Group G]
    (K : Matrix (G × G) (G × G) ℂ) where
  realization : HilbertKernelRealization K
  representation : G →*
    (realization.carrier ≃ₗᵢ[ℂ] realization.carrier)
  equivariant : ∀ a g h : G,
    representation a (realization.vector (g, h)) =
      realization.vector (a * g, a * h)

theorem exists_equivariantHilbertKernelRealization
    {G : Type u} [Group G]
    (K : Matrix (G × G) (G × G) ℂ)
    (hpositive : K.PosSemidef)
    (hdiagonal : ∀ a g h j k : G,
      K (a * g, a * h) (a * j, a * k) = K (g, h) (j, k)) :
    Nonempty (EquivariantHilbertKernelRealization K) := by
  letI : Fact (scalarOperatorKernel K).PosSemidef :=
    ⟨scalarOperatorKernel_posSemidef K hpositive⟩
  let H := RKHS.OfKernel (scalarOperatorKernel K)
  let R : HilbertKernelRealization K := {
    carrier := H
    vector := fun q => RKHS.kerFun H q (1 : ℂ)
    gram := by
      intro q r
      rw [RKHS.kerFun_inner, RKHS.kerFun_apply,
        RKHS.OfKernel.kernel_ofKernel]
      simp [scalarOperatorKernel,
        ContinuousLinearMap.toSpanSingleton_apply]
  }
  refine ⟨{
    realization := R
    representation := diagonalPairKernelUnitaryRepresentation K hdiagonal
    equivariant := ?_
  }⟩
  intro a g h
  exact diagonalPairKernelUnitaryRepresentation_kerFun_one
    K hdiagonal a g h

def equivariantPairCocycle {G : Type u} [Group G]
    {K : Matrix (G × G) (G × G) ℂ}
    (R : EquivariantHilbertKernelRealization K) (g : G) :
    R.realization.carrier :=
  R.realization.vector (g, 1)

theorem equivariantPairCocycle_mul {G : Type u} [Group G]
    (K : Matrix (G × G) (G × G) ℂ)
    (R : EquivariantHilbertKernelRealization K)
    (hadd : ∀ g h j : G, ∀ q : G × G,
      K (g, h) q + K (h, j) q = K (g, j) q)
    (a g : G) :
    equivariantPairCocycle R (a * g) =
      equivariantPairCocycle R a +
        R.representation a (equivariantPairCocycle R g) := by
  unfold equivariantPairCocycle
  rw [R.equivariant]
  simp only [mul_one]
  rw [add_comm]
  exact (hilbertKernelRealization_pair_vector_add K R.realization
    hadd (a * g) a 1).symm

theorem normalizedPairDisplacement_generator_of_model
    {G ι V : Type*} [Group G] [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (σ : G → Equiv.Perm V) (s : ι → G)
    (hone : σ 1 = 1) (hgenerator : ∀ i, σ (s i) = p i)
    (i : ι) :
    normalizedPairDisplacement p f σ (s i, 1) =
      normalizedIndicatorDisplacement p f (p i) := by
  simp [normalizedPairDisplacement, normalizedIndicatorDisplacement,
    hone, hgenerator]

theorem norm_average_normalizedPairDisplacement_of_model
    {G ι V : Type*} [Group G] [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (σ : G → Equiv.Perm V) (s : ι → G)
    (hone : σ 1 = 1) (hgenerator : ∀ i, σ (s i) = p i)
    (hdefect : permutationMarkov p (indicatorVector f) ≠
      indicatorVector f) :
    ‖(Fintype.card ι : ℂ)⁻¹ •
      ∑ i, normalizedPairDisplacement p f σ (s i, 1)‖ = 1 := by
  simp_rw [normalizedPairDisplacement_generator_of_model
    p f σ s hone hgenerator]
  rw [average_normalizedIndicatorDisplacement,
    norm_normalizedIndicatorDefect p f hdefect]

theorem inner_smul_finset_sum_self
    {I E : Type*} [NormedAddCommGroup E] [InnerProductSpace ℂ E]
    (z : I → E) (F : Finset I) (c : ℂ) :
    ⟪c • ∑ i ∈ F, z i, c • ∑ i ∈ F, z i⟫_ℂ =
      star c * (∑ i ∈ F, ∑ j ∈ F, ⟪z i, z j⟫_ℂ) * c := by
  rw [inner_smul_left, inner_smul_right, sum_inner]
  simp_rw [inner_sum]
  simp only [RCLike.star_def]
  ring

theorem tendsto_norm_sq_smul_finset_sum_of_gram
    {N I H : Type*} {E : N → Type*}
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    [∀ n, NormedAddCommGroup (E n)]
    [∀ n, InnerProductSpace ℂ (E n)]
    (l : Filter N) (z : ∀ n, I → E n) (v : I → H)
    (hgram : ∀ i j,
      Tendsto (fun n => ⟪z n i, z n j⟫_ℂ) l
        (𝓝 ⟪v i, v j⟫_ℂ))
    (F : Finset I) (c : ℂ) :
    Tendsto (fun n => ‖c • ∑ i ∈ F, z n i‖ ^ 2) l
      (𝓝 (‖c • ∑ i ∈ F, v i‖ ^ 2)) := by
  have hsum :
      Tendsto
        (fun n => ∑ i ∈ F, ∑ j ∈ F, ⟪z n i, z n j⟫_ℂ) l
        (𝓝 (∑ i ∈ F, ∑ j ∈ F, ⟪v i, v j⟫_ℂ)) :=
    tendsto_finsetSum F fun i _ =>
      tendsto_finsetSum F fun j _ => hgram i j
  have hinner :
      Tendsto
        (fun n => ⟪c • ∑ i ∈ F, z n i,
          c • ∑ i ∈ F, z n i⟫_ℂ) l
        (𝓝 ⟪c • ∑ i ∈ F, v i,
          c • ∑ i ∈ F, v i⟫_ℂ) := by
    simpa only [inner_smul_finset_sum_self] using
      (tendsto_const_nhds.mul hsum).mul tendsto_const_nhds
  have hreal := (Complex.continuous_re.tendsto _).comp hinner
  change Tendsto
    (fun n => (⟪c • ∑ i ∈ F, z n i,
      c • ∑ i ∈ F, z n i⟫_ℂ).re) l
    (𝓝 (⟪c • ∑ i ∈ F, v i,
      c • ∑ i ∈ F, v i⟫_ℂ).re) at hreal
  convert hreal using 1
  · funext n
    exact norm_sq_eq_re_inner (𝕜 := ℂ) (c • ∑ i ∈ F, z n i)
  · congr 1
    exact norm_sq_eq_re_inner (𝕜 := ℂ) (c • ∑ i ∈ F, v i)

theorem norm_smul_finset_sum_eq_one_of_gram
    {N I H : Type*} {E : N → Type*}
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    [∀ n, NormedAddCommGroup (E n)]
    [∀ n, InnerProductSpace ℂ (E n)]
    (l : Filter N) [NeBot l]
    (z : ∀ n, I → E n) (v : I → H)
    (hgram : ∀ i j,
      Tendsto (fun n => ⟪z n i, z n j⟫_ℂ) l
        (𝓝 ⟪v i, v j⟫_ℂ))
    (F : Finset I) (c : ℂ)
    (hnorm : ∀ n, ‖c • ∑ i ∈ F, z n i‖ = 1) :
    ‖c • ∑ i ∈ F, v i‖ = 1 := by
  have hlimit :=
    tendsto_norm_sq_smul_finset_sum_of_gram l z v hgram F c
  have hone :
      Tendsto (fun n => ‖c • ∑ i ∈ F, z n i‖ ^ 2) l
        (𝓝 (1 : ℝ)) := by
    simpa only [hnorm, one_pow] using
      (tendsto_const_nhds :
        Tendsto (fun _ : N => (1 : ℝ)) l (𝓝 1))
  have hsq : ‖c • ∑ i ∈ F, v i‖ ^ 2 = 1 :=
    tendsto_nhds_unique hlimit hone
  nlinarith [norm_nonneg (c • ∑ i ∈ F, v i)]

theorem exists_equivariant_hilbert_normalized_rooted_pair_realization
    {G ι : Type u} [Group G] [Fintype ι] [Nonempty ι]
    {V : ℕ → Type u} [∀ n, Fintype (V n)]
    (p : ∀ n, ι → Equiv.Perm (V n))
    (f : ∀ n, V n → ℝ)
    (σ : ∀ n, G → Equiv.Perm (V n))
    (s : ι → G) (w : G → List ι)
    (hf : ∀ n x, f n x = 0 ∨ f n x = 1)
    (hdefect : ∀ n, permutationMarkov (p n) (indicatorVector (f n)) ≠
      indicatorVector (f n))
    (hw : ∀ n g, σ n g = ((w g).map (p n)).prod)
    (hone : ∀ n, σ n 1 = 1)
    (hgenerator : ∀ n i, σ n (s i) = p n i)
    (hroot : ∀ a g : G, ∀ᶠ n in Filter.atTop,
      ∀ x : V n, indicatorVector (f n) x ≠ 0 →
        σ n (a * g) x = (σ n a * σ n g) x) :
    ∃ (K : Matrix (G × G) (G × G) ℂ)
      (R : EquivariantHilbertKernelRealization K),
      K.PosSemidef ∧
      (∀ a g h j k : G,
        K (a * g, a * h) (a * j, a * k) = K (g, h) (j, k)) ∧
      (∀ a g h : G,
        R.representation a (R.realization.vector (g, h)) =
          R.realization.vector (a * g, a * h)) ∧
      (∀ g h j : G,
        R.realization.vector (g, h) +
          R.realization.vector (h, j) =
            R.realization.vector (g, j)) ∧
      (∀ a g : G,
        equivariantPairCocycle R (a * g) =
          equivariantPairCocycle R a +
            R.representation a (equivariantPairCocycle R g)) ∧
      ‖(Fintype.card ι : ℂ)⁻¹ •
        ∑ i, equivariantPairCocycle R (s i)‖ = 1 ∧
      ∀ q r,
        Tendsto
          (fun n =>
            ⟪normalizedPairDisplacement (p n) (f n) (σ n) q,
              normalizedPairDisplacement (p n) (f n) (σ n) r⟫_ℂ)
          (Filter.hyperfilter ℕ)
          (𝓝 ⟪R.realization.vector q,
            R.realization.vector r⟫_ℂ) := by
  obtain ⟨K, hpositive, hdiagonal, hadd, hconv⟩ :=
    exists_hyperfilter_diagonal_positive_pair_kernel_of_rooted_indicators
      p f σ w hf hdefect hw hroot
  obtain ⟨R⟩ :=
    exists_equivariantHilbertKernelRealization K hpositive hdiagonal
  refine ⟨K, R, hpositive, hdiagonal, R.equivariant, ?_, ?_, ?_, ?_⟩
  · exact hilbertKernelRealization_pair_vector_add
      K R.realization hadd
  · exact equivariantPairCocycle_mul K R hadd
  · apply norm_smul_finset_sum_eq_one_of_gram
      (Filter.hyperfilter ℕ)
      (fun n i => normalizedPairDisplacement (p n) (f n) (σ n)
        (s i, 1))
      (fun i => equivariantPairCocycle R (s i))
      (F := Finset.univ) (c := (Fintype.card ι : ℂ)⁻¹)
    · intro i j
      simpa only [equivariantPairCocycle, R.realization.gram] using
        hconv (s i, 1) (s j, 1)
    · intro n
      simpa using norm_average_normalizedPairDisplacement_of_model
        (p n) (f n) (σ n) s (hone n) (hgenerator n) (hdefect n)
  · intro q r
    simpa only [R.realization.gram] using hconv q r

end KunRootedIndicatorCrossing

namespace KunThomInvariantOrthogonal

section

open Filter Topology
open scoped ComplexConjugate Pointwise

universe u v

variable {G : Type u} {H : Type v} [Group G]
  [NormedAddCommGroup H] [InnerProductSpace ℂ H]

def invariantSubmodule (π : SoficGroups.UnitaryRepresentation G H) :
    Submodule ℂ H where
  carrier := {x | ∀ g : G, π g x = x}
  zero_mem' := by
    intro g
    exact map_zero (π g)
  add_mem' := by
    intro x y hx hy g
    rw [map_add, hx g, hy g]
  smul_mem' := by
    intro c x hx g
    rw [map_smul, hx g]

theorem map_mem_invariantSubmodule_orthogonal
    (π : SoficGroups.UnitaryRepresentation G H) (g : G) {x : H}
    (hx : x ∈ (invariantSubmodule π)ᗮ) :
    π g x ∈ (invariantSubmodule π)ᗮ := by
  rw [Submodule.mem_orthogonal]
  intro y hy
  have hysymm : (π g).symm y = y := by
    have hyinv : π g⁻¹ y = y := hy g⁻¹
    simpa [map_inv, LinearIsometryEquiv.inv_def] using hyinv
  calc
    @inner ℂ H _ y (π g x) =
        @inner ℂ H _ ((π g).symm y) x := by
          simpa using ((π g).symm.inner_map_map y (π g x)).symm
    _ = @inner ℂ H _ y x := by rw [hysymm]
    _ = 0 := (Submodule.mem_orthogonal _ _).mp hx y hy

def orthogonalLinearIsometryEquiv
    (π : SoficGroups.UnitaryRepresentation G H) (g : G) :
    (invariantSubmodule π)ᗮ ≃ₗᵢ[ℂ] (invariantSubmodule π)ᗮ where
  toFun x := ⟨π g x, map_mem_invariantSubmodule_orthogonal π g x.property⟩
  invFun x :=
    ⟨π g⁻¹ x, map_mem_invariantSubmodule_orthogonal π g⁻¹ x.property⟩
  left_inv x := by
    apply Subtype.ext
    change π g⁻¹ (π g (x : H)) = x
    simp [map_inv, LinearIsometryEquiv.inv_def]
  right_inv x := by
    apply Subtype.ext
    change π g (π g⁻¹ (x : H)) = x
    simp [map_inv, LinearIsometryEquiv.inv_def]
  map_add' x y := by
    apply Subtype.ext
    exact map_add (π g) (x : H) (y : H)
  map_smul' c x := by
    apply Subtype.ext
    exact map_smul (π g) c (x : H)
  norm_map' x := (π g).norm_map (x : H)

def orthogonalRepresentation (π : SoficGroups.UnitaryRepresentation G H) :
    SoficGroups.UnitaryRepresentation G ((invariantSubmodule π)ᗮ) where
  toFun := orthogonalLinearIsometryEquiv π
  map_one' := by
    ext x
    change π 1 (x : H) = x
    simp
  map_mul' g h := by
    ext x
    change π (g * h) (x : H) = π g (π h (x : H))
    rw [map_mul]
    rfl

theorem orthogonalRepresentation_no_fixed
    (π : SoficGroups.UnitaryRepresentation G H)
    (x : (invariantSubmodule π)ᗮ)
    (hx : ∀ g : G, orthogonalRepresentation π g x = x) :
    x = 0 := by
  have hxinv : (x : H) ∈ invariantSubmodule π := by
    intro g
    exact congrArg Subtype.val (hx g)
  have hinner : @inner ℂ H _ (x : H) (x : H) = 0 :=
    Submodule.inner_right_of_mem_orthogonal hxinv x.property
  apply Subtype.ext
  change (x : H) = 0
  exact inner_self_eq_zero.mp hinner

theorem cocycle_one
    (π : SoficGroups.UnitaryRepresentation G H) (b : G → H)
    (hb : ∀ g h : G, b (g * h) = b g + π g (b h)) :
    b 1 = 0 := by
  have hcancel : b 1 + b 1 = b 1 + 0 := by
    simpa using (hb 1 1).symm
  exact add_left_cancel hcancel

theorem inner_cocycle_inv_of_invariant
    (π : SoficGroups.UnitaryRepresentation G H) (b : G → H)
    (hb : ∀ g h : G, b (g * h) = b g + π g (b h))
    (y : H) (hy : ∀ g : G, π g y = y) (g : G) :
    @inner ℂ H _ y (b g⁻¹) = -@inner ℂ H _ y (b g) := by
  have hysymm : (π g).symm y = y := by
    have hyinv := hy g⁻¹
    simpa [map_inv, LinearIsometryEquiv.inv_def] using hyinv
  have htransport :
      @inner ℂ H _ y (π g (b g⁻¹)) = @inner ℂ H _ y (b g⁻¹) := by
    calc
      @inner ℂ H _ y (π g (b g⁻¹)) =
          @inner ℂ H _ ((π g).symm y) (b g⁻¹) := by
            simpa using
              ((π g).symm.inner_map_map y (π g (b g⁻¹))).symm
      _ = @inner ℂ H _ y (b g⁻¹) := by rw [hysymm]
  have hsum : b g + π g (b g⁻¹) = 0 := by
    calc
      b g + π g (b g⁻¹) = b (g * g⁻¹) := (hb g g⁻¹).symm
      _ = b 1 := by rw [mul_inv_cancel]
      _ = 0 := cocycle_one π b hb
  have hinner :
      @inner ℂ H _ y (b g) + @inner ℂ H _ y (b g⁻¹) = 0 := by
    have h := congrArg (fun x : H => @inner ℂ H _ y x) hsum
    simpa [inner_add_right, htransport] using h
  apply (add_eq_zero_iff_eq_neg).mp
  simpa [add_comm] using hinner

theorem inner_cocycle_sum_eq_zero_of_invariant
    (π : SoficGroups.UnitaryRepresentation G H) (b : G → H)
    (hb : ∀ g h : G, b (g * h) = b g + π g (b h))
    (S : Finset G) (hS : ∀ g ∈ S, g⁻¹ ∈ S)
    (y : H) (hy : ∀ g : G, π g y = y) :
    @inner ℂ H _ y (∑ g ∈ S, b g) = 0 := by
  classical
  rw [inner_sum]
  have hsymmetric : S⁻¹ = S := by
    ext g
    constructor
    · intro hg
      obtain ⟨a, ha, rfl⟩ := Finset.mem_inv.mp hg
      exact hS a ha
    · intro hg
      apply Finset.mem_inv.mpr
      exact ⟨g⁻¹, hS g hg, inv_inv g⟩
  have hneg :
      (∑ g ∈ S, @inner ℂ H _ y (b g)) =
        -(∑ g ∈ S, @inner ℂ H _ y (b g)) := by
    calc
      (∑ g ∈ S, @inner ℂ H _ y (b g)) =
          ∑ g ∈ S⁻¹, @inner ℂ H _ y (b g) := by rw [hsymmetric]
      _ = ∑ g ∈ S, @inner ℂ H _ y (b g⁻¹) :=
        Finset.sum_inv_index S (fun g => @inner ℂ H _ y (b g))
      _ = ∑ g ∈ S, -@inner ℂ H _ y (b g) := by
        apply Finset.sum_congr rfl
        intro g hg
        exact inner_cocycle_inv_of_invariant π b hb y hy g
      _ = -(∑ g ∈ S, @inner ℂ H _ y (b g)) := by
        rw [Finset.sum_neg_distrib]
  have hdouble :
      (2 : ℂ) * (∑ g ∈ S, @inner ℂ H _ y (b g)) = 0 := by
    calc
      (2 : ℂ) * (∑ g ∈ S, @inner ℂ H _ y (b g)) =
          (∑ g ∈ S, @inner ℂ H _ y (b g)) +
            (∑ g ∈ S, @inner ℂ H _ y (b g)) := two_mul _
      _ = (∑ g ∈ S, @inner ℂ H _ y (b g)) +
          -(∑ g ∈ S, @inner ℂ H _ y (b g)) :=
        congrArg (fun z : ℂ => (∑ g ∈ S, @inner ℂ H _ y (b g)) + z) hneg
      _ = 0 := add_neg_cancel _
  exact (mul_eq_zero.mp hdouble).resolve_left (by norm_num)

theorem inner_smul_cocycle_sum_eq_zero_of_invariant
    (π : SoficGroups.UnitaryRepresentation G H) (b : G → H)
    (hb : ∀ g h : G, b (g * h) = b g + π g (b h))
    (S : Finset G) (hS : ∀ g ∈ S, g⁻¹ ∈ S) (c : ℂ)
    (y : H) (hy : ∀ g : G, π g y = y) :
    @inner ℂ H _ y (c • ∑ g ∈ S, b g) = 0 := by
  rw [inner_smul_right, inner_cocycle_sum_eq_zero_of_invariant π b hb S hS y hy,
    mul_zero]

theorem norm_add_le_two_sub_sq_div_four
    (x y : H) (δ : ℝ)
    (hδ : 0 ≤ δ) (hδtwo : δ ≤ 2)
    (hnorm : ‖y‖ = ‖x‖)
    (hseparated : δ * ‖x‖ ≤ ‖x - y‖) :
    ‖x + y‖ ≤ (2 - δ ^ 2 / 4) * ‖x‖ := by
  have hpar := parallelogram_law_with_norm ℂ x y
  have hsq : (δ * ‖x‖) ^ 2 ≤ ‖x - y‖ ^ 2 :=
    (sq_le_sq₀ (mul_nonneg hδ (norm_nonneg x))
      (norm_nonneg (x - y))).mpr hseparated
  have hδsq : δ ^ 2 ≤ 4 := by
    nlinarith [sq_nonneg (2 - δ), sq_nonneg δ]
  have htarget : 0 ≤ (2 - δ ^ 2 / 4) * ‖x‖ :=
    mul_nonneg (by nlinarith) (norm_nonneg x)
  have hadd :
      ‖x + y‖ ^ 2 ≤ ((2 - δ ^ 2 / 4) * ‖x‖) ^ 2 := by
    rw [hnorm] at hpar
    nlinarith [sq_nonneg (δ ^ 2 * ‖x‖)]
  exact (sq_le_sq₀ (norm_nonneg (x + y)) htarget).mp hadd

omit [InnerProductSpace ℂ H] in

theorem norm_finset_sum_le_pair_add
    {X : Type*} (S : Finset X) (f : X → H)
    (a b : X) (ha : a ∈ S) (hb : b ∈ S) (hab : a ≠ b)
    (r : ℝ) (hnorm : ∀ s ∈ S, ‖f s‖ = r) :
    ‖∑ s ∈ S, f s‖ ≤
      ‖f a + f b‖ + ((S.card : ℝ) - 2) * r := by
  classical
  let T : Finset X := (S.erase a).erase b
  have hb' : b ∈ S.erase a :=
    Finset.mem_erase.mpr ⟨Ne.symm hab, hb⟩
  have hsum :
      (∑ s ∈ S, f s) = f a + f b + ∑ s ∈ T, f s := by
    calc
      (∑ s ∈ S, f s) = f a + ∑ s ∈ S.erase a, f s :=
        (Finset.add_sum_erase S f ha).symm
      _ = f a + (f b + ∑ s ∈ T, f s) := by
        congr 1
        exact (Finset.add_sum_erase (S.erase a) f hb').symm
      _ = f a + f b + ∑ s ∈ T, f s := by abel
  have hcard : (T.card : ℝ) = (S.card : ℝ) - 2 := by
    dsimp [T]
    rw [Finset.cast_card_erase_of_mem hb',
      Finset.cast_card_erase_of_mem ha]
    ring
  have htail : (∑ s ∈ T, ‖f s‖) = (T.card : ℝ) * r := by
    calc
      (∑ s ∈ T, ‖f s‖) = ∑ _s ∈ T, r := by
        apply Finset.sum_congr rfl
        intro s hs
        exact hnorm s
          (Finset.mem_of_mem_erase (Finset.mem_of_mem_erase hs))
      _ = (T.card : ℝ) * r := by simp
  calc
    ‖∑ s ∈ S, f s‖ = ‖(f a + f b) + ∑ s ∈ T, f s‖ := by
      rw [hsum]
    _ ≤ ‖f a + f b‖ + ‖∑ s ∈ T, f s‖ :=
      norm_add_le _ _
    _ ≤ ‖f a + f b‖ + ∑ s ∈ T, ‖f s‖ := by
      exact add_le_add (le_refl _) (norm_sum_le T f)
    _ = ‖f a + f b‖ + (T.card : ℝ) * r := by rw [htail]
    _ = ‖f a + f b‖ + ((S.card : ℝ) - 2) * r := by
      rw [hcard]

end

section

open Filter Topology
open scoped ComplexConjugate Pointwise

universe u v

variable {G : Type u} {H : Type v} [Group G]
  [NormedAddCommGroup H] [InnerProductSpace ℂ H]

theorem kazhdan_generator_displacement_of_orthogonal_invariants
    [CompleteSpace H] (P : SoficGroups.KazhdanPair.{u, v} G)
    (π : SoficGroups.UnitaryRepresentation G H) (x : H)
    (hx : x ≠ 0)
    (horth : ∀ y : H,
      (∀ g : G, π g y = y) → @inner ℂ H _ y x = 0) :
    ∃ g ∈ P.generators,
      P.kazhdanConstant * ‖x‖ ≤ ‖π g x - x‖ := by
  let z : (invariantSubmodule π)ᗮ :=
    ⟨x, (Submodule.mem_orthogonal _ _).mpr
      (fun y hy => horth y hy)⟩
  have hz : z ≠ 0 := by
    intro h
    apply hx
    exact congrArg Subtype.val h
  obtain ⟨g, hg, hgap⟩ :=
    SoficGroups.kazhdan_generator_displacement P
      (orthogonalRepresentation π)
      (orthogonalRepresentation_no_fixed π) z hz
  refine ⟨g, hg, ?_⟩
  simpa [z, orthogonalRepresentation, orthogonalLinearIsometryEquiv] using hgap

theorem kazhdan_generator_sum_contraction
    [CompleteSpace H] (P : SoficGroups.KazhdanPair.{u, v} G)
    (π : SoficGroups.UnitaryRepresentation G H)
    (S : Finset G) (hone : 1 ∈ S)
    (hsub : P.generators ⊆ S) (x : H)
    (horth : ∀ y : H,
      (∀ g : G, π g y = y) → @inner ℂ H _ y x = 0) :
    ‖∑ g ∈ S, π g x‖ ≤
      ((S.card : ℝ) - P.kazhdanConstant ^ 2 / 4) * ‖x‖ := by
  classical
  by_cases hx : x = 0
  · subst x
    simp
  obtain ⟨g, hg, hgap⟩ :=
    kazhdan_generator_displacement_of_orthogonal_invariants
      P π x hx horth
  have hnormpos : 0 < ‖x‖ := norm_pos_iff.mpr hx
  have hupper : ‖π g x - x‖ ≤ 2 * ‖x‖ := by
    calc
      ‖π g x - x‖ ≤ ‖π g x‖ + ‖x‖ := norm_sub_le _ _
      _ = 2 * ‖x‖ := by rw [(π g).norm_map]; ring
  have hκtwo : P.kazhdanConstant ≤ 2 :=
    le_of_mul_le_mul_right (hgap.trans hupper) hnormpos
  have hgone : g ≠ 1 := by
    intro h
    subst g
    have hpos : 0 < P.kazhdanConstant * ‖x‖ :=
      mul_pos P.positive hnormpos
    have hbad : P.kazhdanConstant * ‖x‖ ≤ 0 := by
      simpa using hgap
    exact not_le_of_gt hpos hbad
  have hpair :
      ‖x + π g x‖ ≤
        (2 - P.kazhdanConstant ^ 2 / 4) * ‖x‖ := by
    apply norm_add_le_two_sub_sq_div_four x (π g x)
      P.kazhdanConstant P.positive.le hκtwo
      ((π g).norm_map x)
    rw [norm_sub_rev]
    exact hgap
  have hsum := norm_finset_sum_le_pair_add
    S (fun a : G => π a x) 1 g hone (hsub hg) (Ne.symm hgone)
    ‖x‖ (fun a _ => (π a).norm_map x)
  calc
    ‖∑ a ∈ S, π a x‖ ≤
        ‖π 1 x + π g x‖ + ((S.card : ℝ) - 2) * ‖x‖ := hsum
    _ = ‖x + π g x‖ + ((S.card : ℝ) - 2) * ‖x‖ := by
      simp
    _ ≤ (2 - P.kazhdanConstant ^ 2 / 4) * ‖x‖ +
        ((S.card : ℝ) - 2) * ‖x‖ :=
      add_le_add hpair (le_refl _)
    _ = ((S.card : ℝ) - P.kazhdanConstant ^ 2 / 4) * ‖x‖ := by
      ring

def unitaryFinsetMarkov
    (π : SoficGroups.UnitaryRepresentation G H)
    (S : Finset G) (x : H) : H :=
  ((S.card : ℂ)⁻¹) • S.sum (fun g => π g x)

def kazhdanMarkovContractionFactor
    (P : SoficGroups.KazhdanPair.{u, v} G) (S : Finset G) : ℝ :=
  max 0 (1 - P.kazhdanConstant ^ 2 / (4 * (S.card : ℝ)))

theorem kazhdanMarkovContractionFactor_lt_one
    (P : SoficGroups.KazhdanPair.{u, v} G)
    (S : Finset G) (hS : S.Nonempty) :
    kazhdanMarkovContractionFactor P S < 1 := by
  have hcard : 0 < (S.card : ℝ) := by
    exact_mod_cast Finset.card_pos.mpr hS
  have hpositive :
      0 < P.kazhdanConstant ^ 2 / (4 * (S.card : ℝ)) := by
    exact div_pos (sq_pos_of_pos P.positive)
      (mul_pos (by norm_num) hcard)
  unfold kazhdanMarkovContractionFactor
  exact max_lt (by norm_num) (by linarith)

theorem kazhdanMarkovContractionFactor_nonneg
    (P : SoficGroups.KazhdanPair.{u, v} G) (S : Finset G) :
    0 ≤ kazhdanMarkovContractionFactor P S :=
  le_max_left _ _

theorem unitaryFinsetMarkov_norm_le
    [CompleteSpace H] (P : SoficGroups.KazhdanPair.{u, v} G)
    (π : SoficGroups.UnitaryRepresentation G H)
    (S : Finset G) (hone : 1 ∈ S)
    (hsub : P.generators ⊆ S) (x : H)
    (horth : ∀ y : H,
      (∀ g : G, π g y = y) → @inner ℂ H _ y x = 0) :
    ‖unitaryFinsetMarkov π S x‖ ≤
      kazhdanMarkovContractionFactor P S * ‖x‖ := by
  have hcard : 0 < (S.card : ℝ) := by
    exact_mod_cast Finset.card_pos.mpr ⟨1, hone⟩
  have hsum := kazhdan_generator_sum_contraction
    P π S hone hsub x horth
  calc
    ‖unitaryFinsetMarkov π S x‖ =
        (S.card : ℝ)⁻¹ * ‖∑ g ∈ S, π g x‖ := by
      simp [unitaryFinsetMarkov, norm_smul, norm_inv]
    _ ≤ (S.card : ℝ)⁻¹ *
        (((S.card : ℝ) - P.kazhdanConstant ^ 2 / 4) * ‖x‖) :=
      mul_le_mul_of_nonneg_left hsum (inv_nonneg.mpr hcard.le)
    _ = (1 - P.kazhdanConstant ^ 2 /
        (4 * (S.card : ℝ))) * ‖x‖ := by
      field_simp
    _ ≤ kazhdanMarkovContractionFactor P S * ‖x‖ := by
      apply mul_le_mul_of_nonneg_right _ (norm_nonneg x)
      exact le_max_right 0 _

theorem unitaryFinsetMarkov_orthogonal_invariants
    (π : SoficGroups.UnitaryRepresentation G H)
    (S : Finset G) (x : H)
    (horth : ∀ y : H,
      (∀ g : G, π g y = y) → @inner ℂ H _ y x = 0) :
    ∀ y : H, (∀ g : G, π g y = y) →
      @inner ℂ H _ y (unitaryFinsetMarkov π S x) = 0 := by
  have hx : x ∈ (invariantSubmodule π)ᗮ :=
    (Submodule.mem_orthogonal _ _).mpr (fun y hy => horth y hy)
  have hsum : (∑ g ∈ S, π g x) ∈ (invariantSubmodule π)ᗮ := by
    apply Submodule.sum_mem
    intro g hg
    exact map_mem_invariantSubmodule_orthogonal π g hx
  have hmarkov :
      unitaryFinsetMarkov π S x ∈ (invariantSubmodule π)ᗮ := by
    exact (invariantSubmodule π)ᗮ.smul_mem _ hsum
  intro y hy
  exact (Submodule.mem_orthogonal _ _).mp hmarkov y hy

theorem unitaryFinsetMarkov_iterate_norm_le
    [CompleteSpace H] (P : SoficGroups.KazhdanPair.{u, v} G)
    (π : SoficGroups.UnitaryRepresentation G H)
    (S : Finset G) (hone : 1 ∈ S)
    (hsub : P.generators ⊆ S) (x : H)
    (horth : ∀ y : H,
      (∀ g : G, π g y = y) → @inner ℂ H _ y x = 0)
    (n : ℕ) :
    ‖((unitaryFinsetMarkov π S)^[n]) x‖ ≤
      kazhdanMarkovContractionFactor P S ^ n * ‖x‖ := by
  have horthn (k : ℕ) :
      ∀ y : H, (∀ g : G, π g y = y) →
        @inner ℂ H _ y (((unitaryFinsetMarkov π S)^[k]) x) = 0 := by
    induction k with
    | zero => simpa using horth
    | succ k ih =>
      rw [Function.iterate_succ_apply']
      exact unitaryFinsetMarkov_orthogonal_invariants
        π S (((unitaryFinsetMarkov π S)^[k]) x) ih
  induction n with
  | zero => simp
  | succ n ih =>
    rw [Function.iterate_succ_apply']
    calc
      ‖unitaryFinsetMarkov π S
          (((unitaryFinsetMarkov π S)^[n]) x)‖ ≤
        kazhdanMarkovContractionFactor P S *
          ‖((unitaryFinsetMarkov π S)^[n]) x‖ :=
        unitaryFinsetMarkov_norm_le P π S hone hsub _ (horthn n)
      _ ≤ kazhdanMarkovContractionFactor P S *
          (kazhdanMarkovContractionFactor P S ^ n * ‖x‖) :=
        mul_le_mul_of_nonneg_left ih
          (kazhdanMarkovContractionFactor_nonneg P S)
      _ = kazhdanMarkovContractionFactor P S ^ n.succ * ‖x‖ := by
        rw [pow_succ]
        ring

end

end KunThomInvariantOrthogonal

namespace KunRootedWordPower

open Filter Topology
open SoficGroups.KunRootedIndicatorCrossing
open SoficGroups.KunThomInvariantOrthogonal
open scoped BigOperators ComplexConjugate ComplexOrder InnerProductSpace Pointwise

universe u v w

def pairedWordAverage
    {G ι E : Type*} [Group G] [Fintype ι]
    [AddCommMonoid E] [Module ℂ E]
    (s : ι → G) (z : G × G → E) :
    ℕ → G × G → E
  | 0, q => z q
  | k + 1, q =>
      (Fintype.card ι : ℂ)⁻¹ •
        ∑ i, pairedWordAverage s z k (s i * q.1, s i * q.2)

def pairedDefectWordAverage
    {G ι E : Type*} [Group G] [Fintype ι]
    [AddCommMonoid E] [Module ℂ E]
    (s : ι → G) (z : G × G → E) (k : ℕ) : E :=
  (Fintype.card ι : ℂ)⁻¹ •
    ∑ i, pairedWordAverage s z k (s i, 1)

theorem inner_smul_fintype_sum
    {ι E : Type*} [Fintype ι]
    [NormedAddCommGroup E] [InnerProductSpace ℂ E]
    (x y : ι → E) (c : ℂ) :
    ⟪c • ∑ i, x i, c • ∑ j, y j⟫_ℂ =
      star c * (∑ i, ∑ j, ⟪x i, y j⟫_ℂ) * c := by
  rw [inner_smul_left, inner_smul_right, sum_inner]
  simp_rw [inner_sum]
  simp only [RCLike.star_def]
  ring

theorem tendsto_inner_pairedWordAverage_of_gram
    {G ι N H : Type*} [Group G] [Fintype ι]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    {E : N → Type*}
    [∀ n, NormedAddCommGroup (E n)]
    [∀ n, InnerProductSpace ℂ (E n)]
    (l : Filter N) (s : ι → G)
    (z : ∀ n, G × G → E n) (v : G × G → H)
    (hgram : ∀ q r,
      Tendsto (fun n => ⟪z n q, z n r⟫_ℂ) l
        (𝓝 ⟪v q, v r⟫_ℂ))
    (k : ℕ) (q r : G × G) :
    Tendsto
      (fun n =>
        ⟪pairedWordAverage s (z n) k q,
          pairedWordAverage s (z n) k r⟫_ℂ)
      l
      (𝓝 ⟪pairedWordAverage s v k q,
        pairedWordAverage s v k r⟫_ℂ) := by
  induction k generalizing q r with
  | zero =>
      simpa [pairedWordAverage] using hgram q r
  | succ k ih =>
      have hsum :
          Tendsto
            (fun n =>
              ∑ i : ι, ∑ j : ι,
                ⟪pairedWordAverage s (z n) k
                    (s i * q.1, s i * q.2),
                  pairedWordAverage s (z n) k
                    (s j * r.1, s j * r.2)⟫_ℂ)
            l
            (𝓝 (∑ i : ι, ∑ j : ι,
              ⟪pairedWordAverage s v k
                  (s i * q.1, s i * q.2),
                pairedWordAverage s v k
                  (s j * r.1, s j * r.2)⟫_ℂ)) :=
        tendsto_finsetSum Finset.univ fun i _ =>
          tendsto_finsetSum Finset.univ fun j _ =>
            ih (s i * q.1, s i * q.2)
              (s j * r.1, s j * r.2)
      simpa only [pairedWordAverage, inner_smul_fintype_sum] using
        (tendsto_const_nhds.mul hsum).mul tendsto_const_nhds

theorem tendsto_norm_pairedDefectWordAverage_of_gram
    {G ι N H : Type*} [Group G] [Fintype ι]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    {E : N → Type*}
    [∀ n, NormedAddCommGroup (E n)]
    [∀ n, InnerProductSpace ℂ (E n)]
    (l : Filter N) (s : ι → G)
    (z : ∀ n, G × G → E n) (v : G × G → H)
    (hgram : ∀ q r,
      Tendsto (fun n => ⟪z n q, z n r⟫_ℂ) l
        (𝓝 ⟪v q, v r⟫_ℂ))
    (k : ℕ) :
    Tendsto
      (fun n => ‖pairedDefectWordAverage s (z n) k‖)
      l
      (𝓝 ‖pairedDefectWordAverage s v k‖) := by
  have hsq :
      Tendsto
        (fun n => ‖pairedDefectWordAverage s (z n) k‖ ^ 2)
        l
        (𝓝 (‖pairedDefectWordAverage s v k‖ ^ 2)) := by
    simpa only [pairedDefectWordAverage] using
      SoficGroups.KunRootedIndicatorCrossing.tendsto_norm_sq_smul_finset_sum_of_gram
        l
        (fun n (i : ι) =>
          pairedWordAverage s (z n) k (s i, 1))
        (fun i : ι => pairedWordAverage s v k (s i, 1))
        (fun i j =>
          tendsto_inner_pairedWordAverage_of_gram l s z v hgram k
            (s i, 1) (s j, 1))
        Finset.univ (Fintype.card ι : ℂ)⁻¹
  have hroot :=
    (Real.continuous_sqrt.tendsto
      (‖pairedDefectWordAverage s v k‖ ^ 2)).comp hsq
  convert hroot using 1
  · funext n
    change ‖pairedDefectWordAverage s (z n) k‖ =
      Real.sqrt (‖pairedDefectWordAverage s (z n) k‖ ^ 2)
    exact (Real.sqrt_sq (norm_nonneg _)).symm
  · congr 1
    rw [Real.sqrt_sq (norm_nonneg _)]

def permutationMarkovLinear
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) :
    EuclideanSpace ℂ V →ₗ[ℂ] EuclideanSpace ℂ V :=
  (Fintype.card ι : ℂ)⁻¹ •
    ∑ i, (permutationUnitary (p i)).toLinearEquiv.toLinearMap

@[simp]
theorem permutationMarkovLinear_apply
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (x : EuclideanSpace ℂ V) :
    permutationMarkovLinear p x = permutationMarkov p x := by
  simp [permutationMarkovLinear, permutationMarkov]

theorem permutationMarkovLinear_pow_apply
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (k : ℕ)
    (x : EuclideanSpace ℂ V) :
    ((permutationMarkovLinear p) ^ k) x =
      ((permutationMarkov p)^[k]) x := by
  induction k with
  | zero => simp
  | succ k ih =>
      rw [pow_succ', Module.End.mul_apply,
        Function.iterate_succ_apply']
      rw [ih, permutationMarkovLinear_apply]

theorem permutationMarkov_pair_of_rooted
    {G ι V : Type*} [Group G] [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (σ : G → Equiv.Perm V) (s : ι → G)
    (hgenerator : ∀ i, σ (s i) = p i)
    (q : G × G)
    (hroot : ∀ i,
      (∀ x : V, indicatorVector f x ≠ 0 →
        σ (s i * q.1) x = (σ (s i) * σ q.1) x) ∧
      (∀ x : V, indicatorVector f x ≠ 0 →
        σ (s i * q.2) x = (σ (s i) * σ q.2) x)) :
    permutationMarkov p (normalizedPairDisplacement p f σ q) =
      pairedWordAverage s (normalizedPairDisplacement p f σ) 1 q := by
  simp only [permutationMarkov, pairedWordAverage]
  apply congrArg (fun x => (Fintype.card ι : ℂ)⁻¹ • x)
  apply Finset.sum_congr rfl
  intro i _
  rw [← hgenerator i]
  exact (normalizedPairDisplacement_diagonal p f σ
    (s i) q.1 q.2 (hroot i).1 (hroot i).2).symm

theorem eventually_permutationMarkov_pair_of_rooted
    {G ι : Type*} [Group G] [Fintype ι]
    {V : ℕ → Type*} [∀ n, Fintype (V n)]
    (p : ∀ n, ι → Equiv.Perm (V n))
    (f : ∀ n, V n → ℝ)
    (σ : ∀ n, G → Equiv.Perm (V n))
    (s : ι → G)
    (hgenerator : ∀ n i, σ n (s i) = p n i)
    (hroot : ∀ a g : G, ∀ᶠ n in Filter.atTop,
      ∀ x : V n, indicatorVector (f n) x ≠ 0 →
        σ n (a * g) x = (σ n a * σ n g) x)
    (q : G × G) :
    ∀ᶠ n in Filter.atTop,
      permutationMarkov (p n)
        (normalizedPairDisplacement (p n) (f n) (σ n) q) =
        pairedWordAverage s
          (normalizedPairDisplacement (p n) (f n) (σ n)) 1 q := by
  have hnodes :
      ∀ᶠ n in Filter.atTop, ∀ i : ι,
        (∀ x : V n, indicatorVector (f n) x ≠ 0 →
          σ n (s i * q.1) x =
            (σ n (s i) * σ n q.1) x) ∧
        (∀ x : V n, indicatorVector (f n) x ≠ 0 →
          σ n (s i * q.2) x =
            (σ n (s i) * σ n q.2) x) :=
    (Filter.eventually_all).2 fun i =>
      (hroot (s i) q.1).and (hroot (s i) q.2)
  filter_upwards [hnodes] with n hn
  exact permutationMarkov_pair_of_rooted
    (p n) (f n) (σ n) s (hgenerator n) q hn

theorem eventually_linear_pairedWordAverage_pow
    {G ι N : Type*} [Group G] [Fintype ι]
    {E : N → Type*}
    [∀ n, AddCommMonoid (E n)]
    [∀ n, Module ℂ (E n)]
    (l : Filter N) (s : ι → G)
    (L : ∀ n, E n →ₗ[ℂ] E n)
    (z : ∀ n, G × G → E n)
    (hbase : ∀ q, ∀ᶠ n in l,
      L n (z n q) = pairedWordAverage s (z n) 1 q)
    (k : ℕ) (q : G × G) :
    ∀ᶠ n in l,
      ((L n) ^ k) (z n q) = pairedWordAverage s (z n) k q := by
  induction k generalizing q with
  | zero =>
      exact Filter.Eventually.of_forall fun n => by
        simp [pairedWordAverage]
  | succ k ih =>
      have hnodes :
          ∀ᶠ n in l, ∀ i : ι,
            ((L n) ^ k) (z n (s i * q.1, s i * q.2)) =
              pairedWordAverage s (z n) k
                (s i * q.1, s i * q.2) :=
        (Filter.eventually_all).2 fun i =>
          ih (s i * q.1, s i * q.2)
      filter_upwards [hbase q, hnodes] with n hn hnode
      rw [pow_succ, Module.End.mul_apply, hn,
        pairedWordAverage, pairedWordAverage, map_smul, map_sum]
      apply congrArg (fun x => (Fintype.card ι : ℂ)⁻¹ • x)
      exact Finset.sum_congr rfl fun i _ => hnode i

theorem eventually_linear_pairedDefectWordAverage_pow
    {G ι N : Type*} [Group G] [Fintype ι]
    {E : N → Type*}
    [∀ n, AddCommMonoid (E n)]
    [∀ n, Module ℂ (E n)]
    (l : Filter N) (s : ι → G)
    (L : ∀ n, E n →ₗ[ℂ] E n)
    (z : ∀ n, G × G → E n)
    (hbase : ∀ q, ∀ᶠ n in l,
      L n (z n q) = pairedWordAverage s (z n) 1 q)
    (k : ℕ) :
    ∀ᶠ n in l,
      ((L n) ^ k) (pairedDefectWordAverage s (z n) 0) =
        pairedDefectWordAverage s (z n) k := by
  have hnodes :
      ∀ᶠ n in l, ∀ i : ι,
        ((L n) ^ k) (z n (s i, 1)) =
          pairedWordAverage s (z n) k (s i, 1) :=
    (Filter.eventually_all).2 fun i =>
      eventually_linear_pairedWordAverage_pow l s L z hbase k
        (s i, 1)
  filter_upwards [hnodes] with n hn
  simp only [pairedDefectWordAverage, pairedWordAverage,
    map_smul, map_sum]
  exact congrArg (fun x => (Fintype.card ι : ℂ)⁻¹ • x)
    (Finset.sum_congr rfl fun i _ => hn i)

theorem pairedDefectWordAverage_zero_eq_normalizedIndicatorDefect
    {G ι V : Type*} [Group G] [Fintype ι] [Nonempty ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ)
    (σ : G → Equiv.Perm V) (s : ι → G)
    (hone : σ 1 = 1) (hgenerator : ∀ i, σ (s i) = p i) :
    pairedDefectWordAverage s
      (normalizedPairDisplacement p f σ) 0 =
        normalizedIndicatorDefect p f := by
  simp only [pairedDefectWordAverage, pairedWordAverage]
  simp_rw [normalizedPairDisplacement_generator_of_model
    p f σ s hone hgenerator]
  exact average_normalizedIndicatorDisplacement p f

theorem tendsto_norm_normalizedIndicatorDefect_markov_pow
    {G ι H : Type*} [Group G] [Fintype ι] [Nonempty ι]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    {V : ℕ → Type*} [∀ n, Fintype (V n)]
    (p : ∀ n, ι → Equiv.Perm (V n))
    (f : ∀ n, V n → ℝ)
    (σ : ∀ n, G → Equiv.Perm (V n))
    (s : ι → G)
    (v : G × G → H)
    (hone : ∀ n, σ n 1 = 1)
    (hgenerator : ∀ n i, σ n (s i) = p n i)
    (hroot : ∀ a g : G, ∀ᶠ n in Filter.atTop,
      ∀ x : V n, indicatorVector (f n) x ≠ 0 →
        σ n (a * g) x = (σ n a * σ n g) x)
    (hgram : ∀ q r,
      Tendsto
        (fun n =>
          ⟪normalizedPairDisplacement (p n) (f n) (σ n) q,
            normalizedPairDisplacement (p n) (f n) (σ n) r⟫_ℂ)
        (Filter.hyperfilter ℕ)
        (𝓝 ⟪v q, v r⟫_ℂ))
    (k : ℕ) :
    Tendsto
      (fun n =>
        ‖((permutationMarkov (p n))^[k])
          (normalizedIndicatorDefect (p n) (f n))‖)
      (Filter.hyperfilter ℕ)
      (𝓝 ‖pairedDefectWordAverage s v k‖) := by
  let z : ∀ n, G × G → EuclideanSpace ℂ (V n) :=
    fun n => normalizedPairDisplacement (p n) (f n) (σ n)
  let L : ∀ n, EuclideanSpace ℂ (V n) →ₗ[ℂ]
      EuclideanSpace ℂ (V n) :=
    fun n => permutationMarkovLinear (p n)
  have hbase : ∀ q, ∀ᶠ n in Filter.atTop,
      L n (z n q) = pairedWordAverage s (z n) 1 q := by
    intro q
    simpa only [L, permutationMarkovLinear_apply, z] using
      eventually_permutationMarkov_pair_of_rooted
        p f σ s hgenerator hroot q
  have hp := eventually_linear_pairedDefectWordAverage_pow
    Filter.atTop s L z hbase k
  have hpow :
      ∀ᶠ n in Filter.atTop,
        ((permutationMarkov (p n))^[k])
          (normalizedIndicatorDefect (p n) (f n)) =
            pairedDefectWordAverage s (z n) k := by
    filter_upwards [hp] with n hn
    rw [← permutationMarkovLinear_pow_apply]
    change ((L n) ^ k) (normalizedIndicatorDefect (p n) (f n)) =
      pairedDefectWordAverage s (z n) k
    rw [← pairedDefectWordAverage_zero_eq_normalizedIndicatorDefect
      (p n) (f n) (σ n) s (hone n) (hgenerator n)]
    exact hn
  have hlimit :=
    tendsto_norm_pairedDefectWordAverage_of_gram
      (Filter.hyperfilter ℕ) s z v hgram k
  have heq :
      (fun n =>
        ‖((permutationMarkov (p n))^[k])
          (normalizedIndicatorDefect (p n) (f n))‖) =ᶠ[
            (Filter.hyperfilter ℕ : Filter ℕ)]
        (fun n => ‖pairedDefectWordAverage s (z n) k‖) :=
    (hpow.filter_mono Nat.hyperfilter_le_atTop).mono
      fun n hn => congrArg norm hn
  exact hlimit.congr' heq.symm

def representationFamilyMarkovLinear
    {G ι H : Type*} [Group G] [Fintype ι]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : SoficGroups.UnitaryRepresentation G H) (s : ι → G) :
    H →ₗ[ℂ] H :=
  (Fintype.card ι : ℂ)⁻¹ •
    ∑ i, (π (s i)).toLinearEquiv.toLinearMap

theorem representationFamilyMarkovLinear_subtype_apply
    {G H : Type*} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : SoficGroups.UnitaryRepresentation G H)
    (S : Finset G) (x : H) :
    representationFamilyMarkovLinear π (fun i : ↥S => (i : G)) x =
      unitaryFinsetMarkov π S x := by
  simp [representationFamilyMarkovLinear, unitaryFinsetMarkov,
    ← Finset.sum_coe_sort S]

theorem representationFamilyMarkovLinear_subtype_pow_apply
    {G H : Type*} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : SoficGroups.UnitaryRepresentation G H)
    (S : Finset G) (k : ℕ) (x : H) :
    (representationFamilyMarkovLinear π
        (fun i : ↥S => (i : G)) ^ k) x =
      ((unitaryFinsetMarkov π S)^[k]) x := by
  induction k with
  | zero => simp
  | succ k ih =>
      rw [pow_succ', Module.End.mul_apply,
        Function.iterate_succ_apply', ih,
        representationFamilyMarkovLinear_subtype_apply]

theorem representationFamilyMarkovLinear_pair_of_equivariant
    {G ι H : Type*} [Group G] [Fintype ι]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : SoficGroups.UnitaryRepresentation G H)
    (s : ι → G) (v : G × G → H)
    (hequivariant : ∀ a g h : G,
      π a (v (g, h)) = v (a * g, a * h))
    (q : G × G) :
    representationFamilyMarkovLinear π s (v q) =
      pairedWordAverage s v 1 q := by
  rcases q with ⟨g, h⟩
  simp [representationFamilyMarkovLinear, pairedWordAverage,
    hequivariant]

theorem linear_pairedWordAverage_pow
    {G ι E : Type*} [Group G] [Fintype ι]
    [AddCommMonoid E] [Module ℂ E]
    (s : ι → G) (L : E →ₗ[ℂ] E)
    (z : G × G → E)
    (hbase : ∀ q, L (z q) = pairedWordAverage s z 1 q)
    (k : ℕ) (q : G × G) :
    (L ^ k) (z q) = pairedWordAverage s z k q := by
  induction k generalizing q with
  | zero => simp [pairedWordAverage]
  | succ k ih =>
      rw [pow_succ, Module.End.mul_apply, hbase q,
        pairedWordAverage, pairedWordAverage,
        map_smul, map_sum]
      apply congrArg (fun x => (Fintype.card ι : ℂ)⁻¹ • x)
      exact Finset.sum_congr rfl fun i _ =>
        ih (s i * q.1, s i * q.2)

theorem pairedDefectWordAverage_eq_unitaryFinsetMarkov_iterate
    {G H : Type*} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : SoficGroups.UnitaryRepresentation G H)
    (S : Finset G) (v : G × G → H)
    (hequivariant : ∀ a g h : G,
      π a (v (g, h)) = v (a * g, a * h))
    (k : ℕ) :
    pairedDefectWordAverage (fun i : ↥S => (i : G)) v k =
      ((unitaryFinsetMarkov π S)^[k])
        (pairedDefectWordAverage (fun i : ↥S => (i : G)) v 0) := by
  let s : ↥S → G := fun i => (i : G)
  let L : H →ₗ[ℂ] H := representationFamilyMarkovLinear π s
  have hbase : ∀ q, L (v q) = pairedWordAverage s v 1 q :=
    fun q => representationFamilyMarkovLinear_pair_of_equivariant
      π s v hequivariant q
  have hpow :
      (L ^ k) (pairedDefectWordAverage s v 0) =
        pairedDefectWordAverage s v k := by
    simp only [pairedDefectWordAverage, pairedWordAverage,
      map_smul, map_sum]
    apply congrArg (fun x => (Fintype.card (↥S) : ℂ)⁻¹ • x)
    exact Finset.sum_congr rfl fun i _ =>
      linear_pairedWordAverage_pow s L v hbase k (s i, 1)
  have hrewrite :=
    representationFamilyMarkovLinear_subtype_pow_apply
      π S k (pairedDefectWordAverage s v 0)
  exact hpow.symm.trans hrewrite

theorem eventually_normalizedIndicatorDefect_markov_pow_lt_of_rooted
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, u} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    {V : ℕ → Type u} [∀ n, Fintype (V n)]
    (p : ∀ n, ↥S → Equiv.Perm (V n))
    (f : ∀ n, V n → ℝ)
    (σ : ∀ n, G → Equiv.Perm (V n))
    (w : G → List ↥S)
    (hf : ∀ n x, f n x = 0 ∨ f n x = 1)
    (hdefect : ∀ n,
      permutationMarkov (p n) (indicatorVector (f n)) ≠
        indicatorVector (f n))
    (hw : ∀ n g, σ n g = ((w g).map (p n)).prod)
    (hone : ∀ n, σ n 1 = 1)
    (hgenerator : ∀ n (i : ↥S), σ n (i : G) = p n i)
    (hroot : ∀ a g : G, ∀ᶠ n in Filter.atTop,
      ∀ x : V n, indicatorVector (f n) x ≠ 0 →
        σ n (a * g) x = (σ n a * σ n g) x)
    (k : ℕ) (ε : ℝ) (hε : 0 < ε) :
    ∀ᶠ n in (Filter.hyperfilter ℕ : Filter ℕ),
      ‖((permutationMarkov (p n))^[k])
          (normalizedIndicatorDefect (p n) (f n))‖ <
        kazhdanMarkovContractionFactor P S ^ k + ε := by
  letI : Nonempty (↥S) := ⟨⟨1, honeS⟩⟩
  let s : ↥S → G := fun i => (i : G)
  obtain ⟨K, R, _hpositive, _hdiagonal, hequivariant,
      _hadd, hcocycle, hunit, hgram⟩ :=
    exists_equivariant_hilbert_normalized_rooted_pair_realization
      p f σ s w hf hdefect hw hone hgenerator hroot
  let z : R.realization.carrier :=
    pairedDefectWordAverage s R.realization.vector 0
  have hzone : ‖z‖ = 1 := by
    simpa only [z, pairedDefectWordAverage, pairedWordAverage,
      equivariantPairCocycle] using hunit
  have hzform :
      z = (S.card : ℂ)⁻¹ •
        ∑ g ∈ S, equivariantPairCocycle R g := by
    change
      (Fintype.card (↥S) : ℂ)⁻¹ •
        (∑ i : ↥S, R.realization.vector ((i : G), 1)) =
          (S.card : ℂ)⁻¹ •
            ∑ g ∈ S, equivariantPairCocycle R g
    rw [Fintype.card_coe, ← Finset.sum_coe_sort S]
    rfl
  have horth : ∀ y : R.realization.carrier,
      (∀ g : G, R.representation g y = y) →
        @inner ℂ R.realization.carrier _ y z = 0 := by
    intro y hy
    rw [hzform]
    exact inner_smul_cocycle_sum_eq_zero_of_invariant
      R.representation (equivariantPairCocycle R) hcocycle
      S hsymmetric (S.card : ℂ)⁻¹ y hy
  have hbound :
      ‖pairedDefectWordAverage s R.realization.vector k‖ ≤
        kazhdanMarkovContractionFactor P S ^ k := by
    rw [pairedDefectWordAverage_eq_unitaryFinsetMarkov_iterate
      R.representation S R.realization.vector hequivariant k]
    change ‖((unitaryFinsetMarkov R.representation S)^[k]) z‖ ≤ _
    calc
      ‖((unitaryFinsetMarkov R.representation S)^[k]) z‖ ≤
          kazhdanMarkovContractionFactor P S ^ k * ‖z‖ :=
        unitaryFinsetMarkov_iterate_norm_le
          P R.representation S honeS hcover z horth k
      _ = kazhdanMarkovContractionFactor P S ^ k := by
        rw [hzone, mul_one]
  have hstrict :
      ‖pairedDefectWordAverage s R.realization.vector k‖ <
        kazhdanMarkovContractionFactor P S ^ k + ε :=
    hbound.trans_lt (lt_add_of_pos_right _ hε)
  have hlimit := tendsto_norm_normalizedIndicatorDefect_markov_pow
    p f σ s R.realization.vector hone hgenerator hroot hgram k
  exact hlimit.eventually (Iio_mem_nhds hstrict)

structure RootedIndicatorMarkovModel (G ι : Type u) where
  carrier : Type u
  [fintype : Fintype carrier]
  generator : ι → Equiv.Perm carrier
  indicator : carrier → ℝ
  evaluation : G → Equiv.Perm carrier

instance rootedIndicatorMarkovModelFintype
    {G ι : Type u} (X : RootedIndicatorMarkovModel G ι) : Fintype X.carrier :=
  X.fintype

structure RootedIndicatorMarkovModel.IsGenerated
    {G ι : Type u} [Group G] [Fintype ι]
    (X : RootedIndicatorMarkovModel G ι)
    (s : ι → G) (w : G → List ι) : Prop where
  indicator_mem : ∀ x, X.indicator x = 0 ∨ X.indicator x = 1
  word_evaluation : ∀ g,
    X.evaluation g = ((w g).map X.generator).prod
  identity_evaluation : X.evaluation 1 = 1
  generator_evaluation : ∀ i, X.evaluation (s i) = X.generator i

structure RootedIndicatorMarkovModel.IsRootedAtRadius
    {G ι : Type u} [Group G]
    (X : RootedIndicatorMarkovModel G ι)
    (w : G → List ι) (r : ℕ) : Prop where
  out : ∀ a g : G,
    (w a).length + (w g).length + (w (a * g)).length ≤ r →
      ∀ x : X.carrier, indicatorVector X.indicator x ≠ 0 →
        X.evaluation (a * g) x =
          (X.evaluation a * X.evaluation g) x

theorem eventually_rooted_of_growing_word_radius
    {G ι : Type u} [Group G]
    (X : ℕ → RootedIndicatorMarkovModel G ι)
    (w : G → List ι)
    (hroot : ∀ n, (X n).IsRootedAtRadius w n)
    (a g : G) :
    ∀ᶠ n in Filter.atTop,
      ∀ x : (X n).carrier,
        indicatorVector (X n).indicator x ≠ 0 →
          (X n).evaluation (a * g) x =
            ((X n).evaluation a * (X n).evaluation g) x := by
  filter_upwards [Filter.eventually_ge_atTop
    ((w a).length + (w g).length + (w (a * g)).length)]
      with n hn
  exact (hroot n).out a g hn

theorem exists_rooted_word_radius_normalized_markov_contraction
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, u} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (w : G → List ↥S)
    (k : ℕ) (ε : ℝ) (hε : 0 < ε) :
    ∃ r : ℕ, ∀ X : RootedIndicatorMarkovModel G ↥S,
      X.IsGenerated (fun i : ↥S => (i : G)) w →
      X.IsRootedAtRadius w r →
      permutationMarkov X.generator (indicatorVector X.indicator) ≠
        indicatorVector X.indicator →
      ‖((permutationMarkov X.generator)^[k])
          (normalizedIndicatorDefect X.generator X.indicator)‖ <
        kazhdanMarkovContractionFactor P S ^ k + ε := by
  classical
  letI : Nonempty (↥S) := ⟨⟨1, honeS⟩⟩
  by_contra h
  push Not at h
  choose X hgenerated hradius hdefect hbad using h
  let V : ℕ → Type u := fun n => (X n).carrier
  let p : ∀ n, ↥S → Equiv.Perm (V n) :=
    fun n => (X n).generator
  let f : ∀ n, V n → ℝ := fun n => (X n).indicator
  let σ : ∀ n, G → Equiv.Perm (V n) :=
    fun n => (X n).evaluation
  have hf : ∀ n x, f n x = 0 ∨ f n x = 1 :=
    fun n => (hgenerated n).indicator_mem
  have hw : ∀ n g, σ n g = ((w g).map (p n)).prod :=
    fun n => (hgenerated n).word_evaluation
  have hone : ∀ n, σ n 1 = 1 :=
    fun n => (hgenerated n).identity_evaluation
  have hgenerator : ∀ n (i : ↥S), σ n (i : G) = p n i :=
    fun n => (hgenerated n).generator_evaluation
  have hroots : ∀ a g : G, ∀ᶠ n in Filter.atTop,
      ∀ x : V n, indicatorVector (f n) x ≠ 0 →
        σ n (a * g) x = (σ n a * σ n g) x := by
    intro a g
    exact eventually_rooted_of_growing_word_radius
      X w hradius a g
  have hstrict :=
    eventually_normalizedIndicatorDefect_markov_pow_lt_of_rooted
      P S honeS hcover hsymmetric p f σ w hf hdefect
        hw hone hgenerator hroots k ε hε
  have hbad' : ∀ n,
      kazhdanMarkovContractionFactor P S ^ k + ε ≤
        ‖((permutationMarkov (p n))^[k])
          (normalizedIndicatorDefect (p n) (f n))‖ :=
    hbad
  obtain ⟨n, hlt, hge⟩ :=
    (hstrict.and (Filter.Eventually.of_forall hbad')).exists
  exact (not_lt_of_ge hge) hlt

theorem permutationMarkov_iterate_difference
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (x : EuclideanSpace ℂ V)
    (k : ℕ) :
    ((permutationMarkov p)^[k + 1]) x -
        ((permutationMarkov p)^[k]) x =
      ((permutationMarkovLinear p) ^ k)
        (permutationMarkov p x - x) := by
  rw [Function.iterate_succ_apply]
  rw [← permutationMarkovLinear_pow_apply p k
    (permutationMarkov p x),
    ← permutationMarkovLinear_pow_apply p k x,
    ← map_sub]

theorem norm_normalizedIndicatorDefect_markov_pow
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) (k : ℕ) :
    ‖((permutationMarkov p)^[k])
        (normalizedIndicatorDefect p f)‖ =
      ‖((permutationMarkovLinear p) ^ k)
          (permutationMarkov p (indicatorVector f) -
            indicatorVector f)‖ /
        ‖permutationMarkov p (indicatorVector f) -
          indicatorVector f‖ := by
  rw [← permutationMarkovLinear_pow_apply]
  simp [normalizedIndicatorDefect, map_smul,
    norm_smul, norm_inv, div_eq_mul_inv,
    Complex.norm_real, mul_comm]

theorem exists_rooted_word_radius_markov_iterate_contraction
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, u} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (w : G → List ↥S)
    (k : ℕ) (ε : ℝ) (hε : 0 < ε) :
    ∃ r : ℕ, ∀ X : RootedIndicatorMarkovModel G ↥S,
      X.IsGenerated (fun i : ↥S => (i : G)) w →
      X.IsRootedAtRadius w r →
      ‖((permutationMarkov X.generator)^[k + 1])
            (indicatorVector X.indicator) -
          ((permutationMarkov X.generator)^[k])
            (indicatorVector X.indicator)‖ ≤
        (kazhdanMarkovContractionFactor P S ^ k + ε) *
          ‖permutationMarkov X.generator
              (indicatorVector X.indicator) -
            indicatorVector X.indicator‖ := by
  obtain ⟨r, hr⟩ :=
    exists_rooted_word_radius_normalized_markov_contraction
      P S honeS hcover hsymmetric w k ε hε
  refine ⟨r, ?_⟩
  intro X hgenerated hroot
  by_cases hfixed :
      permutationMarkov X.generator
        (indicatorVector X.indicator) =
          indicatorVector X.indicator
  · rw [Function.iterate_fixed hfixed (k + 1),
      Function.iterate_fixed hfixed k, hfixed]
    simp
  · have hpositive :
        0 < ‖permutationMarkov X.generator
          (indicatorVector X.indicator) -
            indicatorVector X.indicator‖ :=
      norm_pos_iff.mpr (sub_ne_zero.mpr hfixed)
    have hnormalized := hr X hgenerated hroot hfixed
    rw [norm_normalizedIndicatorDefect_markov_pow]
      at hnormalized
    have hdenormalized :=
      (div_lt_iff₀ hpositive).mp hnormalized
    rw [permutationMarkov_iterate_difference]
    exact hdenormalized.le

end KunRootedWordPower

namespace KunActualSoficRootRadius

open Filter Topology
open scoped BigOperators Pointwise

def modelMultiplicationBad {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (g h : G) :
    Finset (Fin M.size) :=
  Finset.univ.filter (fun x =>
    M.action (g * h) x ≠ (M.action g * M.action h) x)

@[simp]
theorem mem_modelMultiplicationBad {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (g h : G)
    (x : Fin M.size) :
    x ∈ modelMultiplicationBad M g h ↔
      M.action (g * h) x ≠ (M.action g * M.action h) x := by
  simp only [modelMultiplicationBad, Finset.mem_filter,
    Finset.mem_univ, true_and]

theorem modelMultiplicationBad_density_tendsto_zero
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G) (g h : G) :
    Tendsto
      (fun n =>
        ((modelMultiplicationBad (A.model n) g h).card : ℝ) /
          (A.model n).size)
      atTop (𝓝 0) := by
  simpa [modelMultiplicationBad, SoficGroups.normalizedHamming,
    hammingDist] using A.multiplicative g h

def modelSeparationBad {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (g h : G) :
    Finset (Fin M.size) :=
  SoficGroups.agreementSet (M.action g) (M.action h)

@[simp]
theorem mem_modelSeparationBad {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (g h : G)
    (x : Fin M.size) :
    x ∈ modelSeparationBad M g h ↔ M.action g x = M.action h x := by
  simp [modelSeparationBad, SoficGroups.agreementSet]

theorem modelSeparationBad_density_tendsto_zero
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    {g h : G} (hne : g ≠ h) :
    Tendsto
      (fun n =>
        ((modelSeparationBad (A.model n) g h).card : ℝ) /
          (A.model n).size)
      atTop (𝓝 0) := by
  have hdist :=
    SoficGroups.CompressionCriterion.normalizedHamming_distinct_tendsto
      A hne
  have hlimit :
      Tendsto
        (fun n =>
          (1 : ℝ) - SoficGroups.normalizedHamming
            ((A.model n).action g) ((A.model n).action h))
        atTop (𝓝 0) := by
    have hone :
        Tendsto (fun _ : ℕ => (1 : ℝ)) atTop (𝓝 1) :=
      tendsto_const_nhds
    simpa using hone.sub hdist
  convert hlimit using 1
  funext n
  have hcard :
      (SoficGroups.agreementSet
        ((A.model n).action g) ((A.model n).action h)).card +
        hammingDist
          (fun x => (A.model n).action g x)
          (fun x => (A.model n).action h x) =
        (A.model n).size := by
    simpa using SoficGroups.agreementSet_card_add_hammingDist
      ((A.model n).action g) ((A.model n).action h)
  have hreal :
      ((SoficGroups.agreementSet
          ((A.model n).action g) ((A.model n).action h)).card : ℝ) +
        (hammingDist
          (fun x => (A.model n).action g x)
          (fun x => (A.model n).action h x) : ℝ) =
          (A.model n).size := by
    exact_mod_cast hcard
  have hden : ((A.model n).size : ℝ) ≠ 0 := by
    exact_mod_cast (A.model n).size_pos.ne'
  simp only [modelSeparationBad, SoficGroups.normalizedHamming,
    Fintype.card_fin]
  field_simp
  linarith

def finiteMultiplicationBad {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (F : Finset G) :
    Finset (Fin M.size) := by
  classical
  exact (F.product F).biUnion fun q =>
    modelMultiplicationBad M q.1 q.2

def finiteSeparationBad {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (F : Finset G) :
    Finset (Fin M.size) := by
  classical
  exact ((F.product F).filter fun q => q.1 ≠ q.2).biUnion fun q =>
    modelSeparationBad M q.1 q.2

def finiteRootBad {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (F : Finset G) :
    Finset (Fin M.size) :=
  finiteMultiplicationBad M F ∪ finiteSeparationBad M F

theorem finiteMultiplicationBad_density_tendsto_zero
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G) (F : Finset G) :
    Tendsto
      (fun n =>
        ((finiteMultiplicationBad (A.model n) F).card : ℝ) /
          (A.model n).size)
      atTop (𝓝 0) := by
  classical
  have h := SoficGroups.finite_union_bad_density_tendsto_zero
    (F.product F)
    (fun n => (Finset.univ : Finset (Fin (A.model n).size)))
    (fun n (q : G × G) =>
      modelMultiplicationBad (A.model n) q.1 q.2)
    (fun q _ => by
      simpa only [Finset.univ_inter, Finset.card_univ,
        Fintype.card_fin] using
        modelMultiplicationBad_density_tendsto_zero A q.1 q.2)
  simpa only [finiteMultiplicationBad, Finset.univ_inter,
    Finset.card_univ, Fintype.card_fin] using h

theorem finiteSeparationBad_density_tendsto_zero
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G) (F : Finset G) :
    Tendsto
      (fun n =>
        ((finiteSeparationBad (A.model n) F).card : ℝ) /
          (A.model n).size)
      atTop (𝓝 0) := by
  classical
  have h := SoficGroups.finite_union_bad_density_tendsto_zero
    ((F.product F).filter fun q : G × G => q.1 ≠ q.2)
    (fun n => (Finset.univ : Finset (Fin (A.model n).size)))
    (fun n (q : G × G) =>
      modelSeparationBad (A.model n) q.1 q.2)
    (fun q hq => by
      simpa only [Finset.univ_inter, Finset.card_univ,
        Fintype.card_fin] using
        modelSeparationBad_density_tendsto_zero
          A (Finset.mem_filter.mp hq).2)
  simpa only [finiteSeparationBad, Finset.univ_inter,
    Finset.card_univ, Fintype.card_fin] using h

theorem finiteRootBad_density_tendsto_zero
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G) (F : Finset G) :
    Tendsto
      (fun n =>
        ((finiteRootBad (A.model n) F).card : ℝ) /
          (A.model n).size)
      atTop (𝓝 0) := by
  have hsum :
      Tendsto
        (fun n =>
          ((finiteMultiplicationBad (A.model n) F).card : ℝ) /
              (A.model n).size +
            ((finiteSeparationBad (A.model n) F).card : ℝ) /
              (A.model n).size)
        atTop (𝓝 0) := by
    simpa using
      (finiteMultiplicationBad_density_tendsto_zero A F).add
        (finiteSeparationBad_density_tendsto_zero A F)
  refine squeeze_zero (fun n => by positivity) ?_ hsum
  intro n
  have hcard :
      ((finiteRootBad (A.model n) F).card : ℝ) ≤
        (finiteMultiplicationBad (A.model n) F).card +
          (finiteSeparationBad (A.model n) F).card := by
    exact_mod_cast Finset.card_union_le
      (finiteMultiplicationBad (A.model n) F)
      (finiteSeparationBad (A.model n) F)
  calc
    ((finiteRootBad (A.model n) F).card : ℝ) /
        (A.model n).size ≤
      (((finiteMultiplicationBad (A.model n) F).card : ℝ) +
        (finiteSeparationBad (A.model n) F).card) /
          (A.model n).size :=
        div_le_div_of_nonneg_right hcard (by positivity)
    _ = ((finiteMultiplicationBad (A.model n) F).card : ℝ) /
          (A.model n).size +
        ((finiteSeparationBad (A.model n) F).card : ℝ) /
          (A.model n).size := by
        rw [add_div]

theorem finiteRootBad_multiplicative
    {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (F : Finset G)
    {g h : G} (hg : g ∈ F) (hh : h ∈ F)
    {x : Fin M.size} (hx : x ∉ finiteRootBad M F) :
    M.action (g * h) x = (M.action g * M.action h) x := by
  classical
  have hnot : x ∉ modelMultiplicationBad M g h := by
    intro hbad
    apply hx
    apply Finset.mem_union_left
    exact Finset.mem_biUnion.mpr
      ⟨(g, h), Finset.mem_product.mpr ⟨hg, hh⟩, hbad⟩
  simpa using hnot

theorem finiteRootBad_separated
    {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (F : Finset G)
    {g h : G} (hg : g ∈ F) (hh : h ∈ F) (hne : g ≠ h)
    {x : Fin M.size} (hx : x ∉ finiteRootBad M F) :
    M.action g x ≠ M.action h x := by
  classical
  intro heq
  apply hx
  apply Finset.mem_union_right
  exact Finset.mem_biUnion.mpr
    ⟨(g, h), Finset.mem_filter.mpr
      ⟨Finset.mem_product.mpr ⟨hg, hh⟩, hne⟩,
      (mem_modelSeparationBad M g h x).mpr heq⟩

theorem finiteRootBad_injective_word_evaluation
    {G : Type*} [Group G]
    (M : SoficGroups.PermutationModel G) (F : Finset G)
    {x : Fin M.size} (hx : x ∉ finiteRootBad M F) :
    Set.InjOn (fun g : G => M.action g x) (↑F : Set G) := by
  intro g hg h hh heq
  by_contra hne
  exact finiteRootBad_separated M F hg hh hne hx heq

theorem normalizedHamming_mul_le
    {V : Type*} [Fintype V] [DecidableEq V]
    (p p' q q' : Equiv.Perm V) :
    SoficGroups.normalizedHamming (p * q) (p' * q') ≤
      SoficGroups.normalizedHamming p p' +
        SoficGroups.normalizedHamming q q' := by
  calc
    SoficGroups.normalizedHamming (p * q) (p' * q') ≤
        SoficGroups.normalizedHamming (p * q) (p' * q) +
          SoficGroups.normalizedHamming (p' * q) (p' * q') :=
      SoficGroups.normalizedHamming_triangle _ _ _
    _ = SoficGroups.normalizedHamming p p' +
          SoficGroups.normalizedHamming q q' := by
      rw [SoficGroups.normalizedHamming_mul_right,
        SoficGroups.normalizedHamming_mul_left]

theorem action_list_prod_tendsto
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G) (l : List G) :
    Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          ((A.model n).action l.prod)
          ((l.map (A.model n).action).prod))
      atTop (𝓝 0) := by
  induction l with
  | nil =>
      simp [SoficGroups.PermutationModel.map_one,
        SoficGroups.normalizedHamming_self]
  | cons g l ih =>
      simp only [List.map_cons, List.prod_cons]
      have hmul := A.multiplicative g l.prod
      have hupper :
          Tendsto
            (fun n =>
              SoficGroups.normalizedHamming
                  ((A.model n).action (g * l.prod))
                  ((A.model n).action g * (A.model n).action l.prod) +
                SoficGroups.normalizedHamming
                  ((A.model n).action l.prod)
                  ((l.map (A.model n).action).prod))
            atTop (𝓝 0) := by
        simpa using hmul.add ih
      refine squeeze_zero
        (fun n => SoficGroups.normalizedHamming_nonneg _ _) ?_ hupper
      intro n
      have htriangle := SoficGroups.normalizedHamming_triangle
        ((A.model n).action (g * l.prod))
        ((A.model n).action g * (A.model n).action l.prod)
        ((A.model n).action g *
          (l.map (A.model n).action).prod)
      rw [SoficGroups.normalizedHamming_mul_left] at htriangle
      exact htriangle

def chosenWordEvaluation
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι) (n : ℕ) (g : G) :
    Equiv.Perm (Fin (A.model n).size) :=
  ((w g).map fun i => (A.model n).action (s i)).prod

theorem chosenWordEvaluation_tendsto_action
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι)
    (hw : ∀ g, ((w g).map s).prod = g) (g : G) :
    Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          ((A.model n).action g)
          (chosenWordEvaluation A s w n g))
      atTop (𝓝 0) := by
  have h := action_list_prod_tendsto A ((w g).map s)
  simpa [chosenWordEvaluation, List.map_map,
    Function.comp_def, hw g] using h

theorem chosenWordEvaluation_multiplicative_tendsto
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι)
    (hw : ∀ g, ((w g).map s).prod = g) (g h : G) :
    Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          (chosenWordEvaluation A s w n (g * h))
          (chosenWordEvaluation A s w n g *
            chosenWordEvaluation A s w n h))
      atTop (𝓝 0) := by
  have hgh := chosenWordEvaluation_tendsto_action A s w hw (g * h)
  have hgh' :
      Tendsto
        (fun n =>
          SoficGroups.normalizedHamming
            (chosenWordEvaluation A s w n (g * h))
            ((A.model n).action (g * h)))
        atTop (𝓝 0) := by
    convert hgh using 1
    funext n
    exact SoficGroups.normalizedHamming_comm _ _
  have hg := chosenWordEvaluation_tendsto_action A s w hw g
  have hh := chosenWordEvaluation_tendsto_action A s w hw h
  have hmul := A.multiplicative g h
  have hupper :
      Tendsto
        (fun n =>
          SoficGroups.normalizedHamming
              (chosenWordEvaluation A s w n (g * h))
              ((A.model n).action (g * h)) +
            SoficGroups.normalizedHamming
              ((A.model n).action (g * h))
              ((A.model n).action g * (A.model n).action h) +
            (SoficGroups.normalizedHamming
                ((A.model n).action g)
                (chosenWordEvaluation A s w n g) +
              SoficGroups.normalizedHamming
                ((A.model n).action h)
                (chosenWordEvaluation A s w n h)))
        atTop (𝓝 0) := by
    simpa using (hgh'.add hmul).add (hg.add hh)
  refine squeeze_zero
    (fun n => SoficGroups.normalizedHamming_nonneg _ _) ?_ hupper
  intro n
  have hfirst := SoficGroups.normalizedHamming_triangle
    (chosenWordEvaluation A s w n (g * h))
    ((A.model n).action (g * h))
    (chosenWordEvaluation A s w n g *
      chosenWordEvaluation A s w n h)
  have hsecond := SoficGroups.normalizedHamming_triangle
    ((A.model n).action (g * h))
    ((A.model n).action g * (A.model n).action h)
    (chosenWordEvaluation A s w n g *
      chosenWordEvaluation A s w n h)
  have hproduct := normalizedHamming_mul_le
    ((A.model n).action g) (chosenWordEvaluation A s w n g)
    ((A.model n).action h) (chosenWordEvaluation A s w n h)
  linarith

def chosenWordMultiplicationBad
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι) (n : ℕ) (g h : G) :
    Finset (Fin (A.model n).size) :=
  Finset.univ.filter (fun x =>
    chosenWordEvaluation A s w n (g * h) x ≠
      (chosenWordEvaluation A s w n g *
        chosenWordEvaluation A s w n h) x)

@[simp]
theorem mem_chosenWordMultiplicationBad
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι) (n : ℕ) (g h : G)
    (x : Fin (A.model n).size) :
    x ∈ chosenWordMultiplicationBad A s w n g h ↔
      chosenWordEvaluation A s w n (g * h) x ≠
        (chosenWordEvaluation A s w n g *
          chosenWordEvaluation A s w n h) x := by
  simp only [chosenWordMultiplicationBad, Finset.mem_filter,
    Finset.mem_univ, true_and]

theorem chosenWordMultiplicationBad_density_tendsto_zero
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι)
    (hw : ∀ g, ((w g).map s).prod = g) (g h : G) :
    Tendsto
      (fun n =>
        ((chosenWordMultiplicationBad A s w n g h).card : ℝ) /
          (A.model n).size)
      atTop (𝓝 0) := by
  simpa [chosenWordMultiplicationBad,
    SoficGroups.normalizedHamming, hammingDist] using
      chosenWordEvaluation_multiplicative_tendsto A s w hw g h

def chosenFiniteMultiplicationBad
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι)
    (F : Finset G) (n : ℕ) : Finset (Fin (A.model n).size) := by
  classical
  exact (F.product F).biUnion fun q =>
    chosenWordMultiplicationBad A s w n q.1 q.2

theorem chosenFiniteMultiplicationBad_density_tendsto_zero
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι)
    (hw : ∀ g, ((w g).map s).prod = g) (F : Finset G) :
    Tendsto
      (fun n =>
        ((chosenFiniteMultiplicationBad A s w F n).card : ℝ) /
          (A.model n).size)
      atTop (𝓝 0) := by
  classical
  have h := SoficGroups.finite_union_bad_density_tendsto_zero
    (F.product F)
    (fun n => (Finset.univ : Finset (Fin (A.model n).size)))
    (fun n (q : G × G) =>
      chosenWordMultiplicationBad A s w n q.1 q.2)
    (fun q _ => by
      simpa only [Finset.univ_inter, Finset.card_univ,
        Fintype.card_fin] using
        chosenWordMultiplicationBad_density_tendsto_zero
          A s w hw q.1 q.2)
  simpa only [chosenFiniteMultiplicationBad, Finset.univ_inter,
    Finset.card_univ, Fintype.card_fin] using h

theorem chosenFiniteMultiplicationBad_rooted
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι)
    (F : Finset G) (n : ℕ)
    {g h : G} (hg : g ∈ F) (hh : h ∈ F)
    {x : Fin (A.model n).size}
    (hx : x ∉ chosenFiniteMultiplicationBad A s w F n) :
    chosenWordEvaluation A s w n (g * h) x =
      (chosenWordEvaluation A s w n g *
        chosenWordEvaluation A s w n h) x := by
  classical
  have hnot : x ∉ chosenWordMultiplicationBad A s w n g h := by
    intro hbad
    apply hx
    exact Finset.mem_biUnion.mpr
      ⟨(g, h), Finset.mem_product.mpr ⟨hg, hh⟩, hbad⟩
  simpa using hnot

def chosenFiniteRootBad
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι)
    (F : Finset G) (n : ℕ) : Finset (Fin (A.model n).size) :=
  finiteRootBad (A.model n) F ∪
    chosenFiniteMultiplicationBad A s w F n

theorem chosenFiniteRootBad_density_tendsto_zero
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι)
    (hw : ∀ g, ((w g).map s).prod = g) (F : Finset G) :
    Tendsto
      (fun n =>
        ((chosenFiniteRootBad A s w F n).card : ℝ) /
          (A.model n).size)
      atTop (𝓝 0) := by
  have hsum :
      Tendsto
        (fun n =>
          ((finiteRootBad (A.model n) F).card : ℝ) /
              (A.model n).size +
            ((chosenFiniteMultiplicationBad A s w F n).card : ℝ) /
              (A.model n).size)
        atTop (𝓝 0) := by
    simpa using
      (finiteRootBad_density_tendsto_zero A F).add
        (chosenFiniteMultiplicationBad_density_tendsto_zero
          A s w hw F)
  refine squeeze_zero (fun n => by positivity) ?_ hsum
  intro n
  have hcard :
      ((chosenFiniteRootBad A s w F n).card : ℝ) ≤
        (finiteRootBad (A.model n) F).card +
          (chosenFiniteMultiplicationBad A s w F n).card := by
    exact_mod_cast Finset.card_union_le
      (finiteRootBad (A.model n) F)
      (chosenFiniteMultiplicationBad A s w F n)
  calc
    ((chosenFiniteRootBad A s w F n).card : ℝ) /
        (A.model n).size ≤
      (((finiteRootBad (A.model n) F).card : ℝ) +
        (chosenFiniteMultiplicationBad A s w F n).card) /
          (A.model n).size :=
        div_le_div_of_nonneg_right hcard (by positivity)
    _ = ((finiteRootBad (A.model n) F).card : ℝ) /
          (A.model n).size +
        ((chosenFiniteMultiplicationBad A s w F n).card : ℝ) /
          (A.model n).size := by
        rw [add_div]

theorem chosenFiniteRootBad_injective_word_evaluation
    {G ι : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G) (w : G → List ι)
    (F : Finset G) (n : ℕ)
    {x : Fin (A.model n).size}
    (hx : x ∉ chosenFiniteRootBad A s w F n) :
    Set.InjOn (fun g : G => (A.model n).action g x)
      (↑F : Set G) := by
  apply finiteRootBad_injective_word_evaluation
    (A.model n) F
  intro hbad
  exact hx (Finset.mem_union_left _ hbad)

theorem exists_generator_word_of_symmetric_generates
    {G : Type*} [Group G]
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (g : G) :
    ∃ l : List ↥S,
      ((l.map fun i : ↥S => (i : G)).prod) = g := by
  classical
  have hg : g ∈ Subgroup.closure (S : Set G) := by
    rw [hgenerates]
    simp
  induction hg using Subgroup.closure_induction with
  | mem x hx =>
      exact ⟨[⟨x, hx⟩], by simp⟩
  | one =>
      exact ⟨[], by simp⟩
  | mul x y _ _ ihx ihy =>
      obtain ⟨lx, hlx⟩ := ihx
      obtain ⟨ly, hly⟩ := ihy
      refine ⟨lx ++ ly, ?_⟩
      rw [List.map_append, List.prod_append, hlx, hly]
  | inv x _ ih =>
      obtain ⟨l, hl⟩ := ih
      let invLetter : ↥S → ↥S :=
        fun i => ⟨(i : G)⁻¹, hsymmetric (i : G) i.property⟩
      refine ⟨(l.map invLetter).reverse, ?_⟩
      rw [List.map_reverse, List.map_map]
      change ((l.map fun i : ↥S => (i : G)⁻¹).reverse).prod = x⁻¹
      have hmap :
          (l.map fun i : ↥S => (i : G)⁻¹) =
            (l.map (fun i : ↥S => (i : G))).map
              (fun x : G => x⁻¹) := by
        rw [List.map_map]
        rfl
      rw [hmap, ← List.prod_inv_reverse, hl]

def symmetricGeneratorWord
    {G : Type*} [Group G] [DecidableEq G]
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (g : G) : List ↥S := by
  classical
  by_cases hone : g = 1
  · exact []
  · by_cases hg : g ∈ S
    · exact [⟨g, hg⟩]
    · exact (exists_generator_word_of_symmetric_generates
        S hsymmetric hgenerates g).choose

theorem symmetricGeneratorWord_prod
    {G : Type*} [Group G] [DecidableEq G]
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (g : G) :
    (((symmetricGeneratorWord S hsymmetric hgenerates g).map
      fun i : ↥S => (i : G)).prod) = g := by
  classical
  unfold symmetricGeneratorWord
  split <;> rename_i hone
  · simp [hone]
  · split <;> rename_i hg
    · simp
    · exact (exists_generator_word_of_symmetric_generates
        S hsymmetric hgenerates g).choose_spec

@[simp]
theorem symmetricGeneratorWord_one
    {G : Type*} [Group G] [DecidableEq G]
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤) :
    symmetricGeneratorWord S hsymmetric hgenerates (1 : G) = [] := by
  simp [symmetricGeneratorWord]

theorem symmetricGeneratorWord_generator
    {G : Type*} [Group G] [DecidableEq G]
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (i : ↥S) (hi : (i : G) ≠ 1) :
    symmetricGeneratorWord S hsymmetric hgenerates (i : G) = [i] := by
  classical
  simp [symmetricGeneratorWord, hi, i.property]

theorem chosen_symmetric_wordEvaluation_one
    {G : Type*} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (n : ℕ) :
    chosenWordEvaluation A (fun i : ↥S => (i : G))
      (symmetricGeneratorWord S hsymmetric hgenerates) n 1 = 1 := by
  simp [chosenWordEvaluation]

theorem chosen_symmetric_wordEvaluation_generator
    {G : Type*} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (n : ℕ) (i : ↥S) :
    chosenWordEvaluation A (fun j : ↥S => (j : G))
      (symmetricGeneratorWord S hsymmetric hgenerates)
      n (i : G) =
        (A.model n).action (i : G) := by
  classical
  by_cases hi : (i : G) = 1
  · simp [chosenWordEvaluation, hi,
      SoficGroups.PermutationModel.map_one]
  · rw [chosenWordEvaluation,
      symmetricGeneratorWord_generator S hsymmetric hgenerates i hi]
    simp

theorem generator_word_prod_mem_pow
    {G : Type*} [Group G] [DecidableEq G]
    (S : Finset G) (l : List ↥S) :
    ((l.map fun i : ↥S => (i : G)).prod) ∈ S ^ l.length := by
  induction l with
  | nil => simp
  | cons a l ih =>
      simpa [pow_succ', List.prod_cons] using
        (Finset.mul_mem_mul a.property ih)

theorem mem_generator_pow_of_chosen_word_length
    {G : Type*} [Group G] [DecidableEq G]
    (S : Finset G) (hone : 1 ∈ S)
    (w : G → List ↥S)
    (hw : ∀ g, ((w g).map fun i : ↥S => (i : G)).prod = g)
    {g : G} {r : ℕ} (hgr : (w g).length ≤ r) :
    g ∈ S ^ r := by
  have hword : g ∈ S ^ (w g).length := by
    simpa only [hw g] using generator_word_prod_mem_pow S (w g)
  exact Finset.pow_subset_pow_right hone hgr hword

def chosenCayleyRadiusBad
    {G : Type*} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (S : Finset G) (w : G → List ↥S) (n r : ℕ) :
    Finset (Fin (A.model n).size) :=
  chosenFiniteRootBad A (fun i : ↥S => (i : G)) w (S ^ r) n

theorem chosenCayleyRadiusBad_density_tendsto_zero
    {G : Type*} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (S : Finset G) (w : G → List ↥S)
    (hw : ∀ g, ((w g).map fun i : ↥S => (i : G)).prod = g)
    (r : ℕ) :
    Tendsto
      (fun n =>
        ((chosenCayleyRadiusBad A S w n r).card : ℝ) /
          (A.model n).size)
      atTop (𝓝 0) :=
  chosenFiniteRootBad_density_tendsto_zero
    A (fun i : ↥S => (i : G)) w hw (S ^ r)

theorem chosenCayleyRadiusBad_rooted
    {G : Type*} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (S : Finset G) (hone : 1 ∈ S)
    (w : G → List ↥S)
    (hw : ∀ g, ((w g).map fun i : ↥S => (i : G)).prod = g)
    (n r : ℕ) (a g : G)
    (hword : (w a).length + (w g).length +
      (w (a * g)).length ≤ r)
    {x : Fin (A.model n).size}
    (hx : x ∉ chosenCayleyRadiusBad A S w n r) :
    chosenWordEvaluation A (fun i : ↥S => (i : G)) w n (a * g) x =
      (chosenWordEvaluation A (fun i : ↥S => (i : G)) w n a *
        chosenWordEvaluation A (fun i : ↥S => (i : G)) w n g) x := by
  have ha : (w a).length ≤ r := by omega
  have hg : (w g).length ≤ r := by omega
  have ha' : a ∈ S ^ r :=
    mem_generator_pow_of_chosen_word_length S hone w hw ha
  have hg' : g ∈ S ^ r :=
    mem_generator_pow_of_chosen_word_length S hone w hw hg
  apply chosenFiniteMultiplicationBad_rooted
    A (fun i : ↥S => (i : G)) w (S ^ r) n ha' hg'
  intro hbad
  exact hx (Finset.mem_union_right _ hbad)

theorem chosenCayleyRadiusBad_injective_ball
    {G : Type*} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (S : Finset G) (w : G → List ↥S) (n r : ℕ)
    {x : Fin (A.model n).size}
    (hx : x ∉ chosenCayleyRadiusBad A S w n r) :
    Set.InjOn (fun g : G => (A.model n).action g x)
      (↑(S ^ r) : Set G) := by
  exact chosenFiniteRootBad_injective_word_evaluation
    A (fun i : ↥S => (i : G)) w (S ^ r) n hx

end KunActualSoficRootRadius

namespace KunDirectedIndicatorJensen

open scoped BigOperators

def realIndicator {V : Type*} [DecidableEq V]
    (T : Finset V) (x : V) : ℝ :=
  if x ∈ T then 1 else 0

def realPermutationMarkov {V ι : Type*} [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (x : V) : ℝ :=
  (∑ i : ι, f ((σ i).symm x)) / Fintype.card ι

theorem sq_realIndicator_displacement
    {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (T : Finset V) (x : V) :
    (realIndicator T (p x) - realIndicator T x) ^ 2 =
      (if x ∈ T ∧ p x ∉ T then (1 : ℝ) else 0) +
      (if x ∉ T ∧ p x ∈ T then (1 : ℝ) else 0) := by
  classical
  by_cases hx : x ∈ T <;> by_cases hp : p x ∈ T <;>
    simp [realIndicator, hx, hp]

theorem sum_sq_realIndicator_displacement
    {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (T : Finset V) :
    (∑ x : V,
      (realIndicator T (p x) - realIndicator T x) ^ 2) =
      2 * ((T.filter fun x => p x ∉ T).card : ℝ) := by
  classical
  simp_rw [sq_realIndicator_displacement]
  rw [Finset.sum_add_distrib]
  have hleave :
      (∑ x : V,
        if x ∈ T ∧ p x ∉ T then (1 : ℝ) else 0) =
        ((T.filter fun x => p x ∉ T).card : ℝ) := by
    rw [← Finset.sum_filter]
    simp
    congr 1
    ext x
    simp
  have henter :
      (∑ x : V,
        if x ∉ T ∧ p x ∈ T then (1 : ℝ) else 0) =
        ((Finset.univ.filter fun x => x ∉ T ∧ p x ∈ T).card : ℝ) := by
    rw [← Finset.sum_filter]
    simp
  rw [hleave, henter,
    SoficGroups.KunThomFiberCoarea.card_entering_eq_card_exiting]
  ring

theorem sum_sq_realIndicator_inverse_displacement
    {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (T : Finset V) :
    (∑ x : V,
      (realIndicator T (p.symm x) - realIndicator T x) ^ 2) =
      2 * ((T.filter fun x => p x ∉ T).card : ℝ) := by
  classical
  calc
    (∑ x : V,
      (realIndicator T (p.symm x) - realIndicator T x) ^ 2) =
        ∑ x : V,
          (realIndicator T (p.symm (p x)) -
            realIndicator T (p x)) ^ 2 := by
          exact (Equiv.sum_comp p
            (fun x : V =>
              (realIndicator T (p.symm x) - realIndicator T x) ^ 2)).symm
    _ = ∑ x : V,
          (realIndicator T (p x) - realIndicator T x) ^ 2 := by
          apply Finset.sum_congr rfl
          intro x _
          rw [p.symm_apply_apply]
          ring
    _ = 2 * ((T.filter fun x => p x ∉ T).card : ℝ) :=
      sum_sq_realIndicator_displacement p T

theorem sum_sum_sq_realIndicator_inverse_displacement
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (T : Finset V) :
    (∑ i : ι, ∑ x : V,
      (realIndicator T ((σ i).symm x) - realIndicator T x) ^ 2) =
      2 * (SoficGroups.boundary σ T : ℝ) := by
  classical
  simp_rw [sum_sq_realIndicator_inverse_displacement]
  unfold SoficGroups.boundary
  push_cast
  rw [Finset.mul_sum]

theorem realPermutationMarkov_sub_sq_le_average_sq
    {V ι : Type*} [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (x : V) :
    (realPermutationMarkov σ f x - f x) ^ 2 ≤
      (∑ i : ι,
        (f ((σ i).symm x) - f x) ^ 2) /
        (Fintype.card ι : ℝ) := by
  classical
  have hd : 0 < (Fintype.card ι : ℝ) := by
    exact_mod_cast Fintype.card_pos_iff.mpr
      (inferInstance : Nonempty ι)
  have hmean :
      realPermutationMarkov σ f x - f x =
        (∑ i : ι, (f ((σ i).symm x) - f x)) /
          (Fintype.card ι : ℝ) := by
    unfold realPermutationMarkov
    rw [Finset.sum_sub_distrib, Finset.sum_const,
      Finset.card_univ, nsmul_eq_mul]
    field_simp
  have hcauchy :
      (∑ i : ι, (f ((σ i).symm x) - f x)) ^ 2 ≤
        (Fintype.card ι : ℝ) *
          ∑ i : ι, (f ((σ i).symm x) - f x) ^ 2 := by
    simpa only [Finset.card_univ] using
      (sq_sum_le_card_mul_sum_sq
        (s := Finset.univ)
        (f := fun i : ι => f ((σ i).symm x) - f x))
  rw [hmean, div_pow]
  calc
    (∑ i : ι, (f ((σ i).symm x) - f x)) ^ 2 /
        (Fintype.card ι : ℝ) ^ 2 ≤
      ((Fintype.card ι : ℝ) *
        ∑ i : ι, (f ((σ i).symm x) - f x) ^ 2) /
          (Fintype.card ι : ℝ) ^ 2 :=
        (div_le_div_iff_of_pos_right (sq_pos_of_pos hd)).mpr hcauchy
    _ = (∑ i : ι,
        (f ((σ i).symm x) - f x) ^ 2) /
          (Fintype.card ι : ℝ) := by
        field_simp

theorem realPermutationMarkov_indicator_defect_sq_le_boundary
    {V ι : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (T : Finset V) :
    (∑ x : V,
      (realPermutationMarkov σ (realIndicator T) x -
        realIndicator T x) ^ 2) ≤
      2 * (SoficGroups.boundary σ T : ℝ) /
        (Fintype.card ι : ℝ) := by
  classical
  calc
    (∑ x : V,
      (realPermutationMarkov σ (realIndicator T) x -
        realIndicator T x) ^ 2) ≤
      ∑ x : V,
        (∑ i : ι,
          (realIndicator T ((σ i).symm x) -
            realIndicator T x) ^ 2) / (Fintype.card ι : ℝ) := by
          apply Finset.sum_le_sum
          intro x _
          exact realPermutationMarkov_sub_sq_le_average_sq
            σ (realIndicator T) x
    _ = (∑ i : ι, ∑ x : V,
          (realIndicator T ((σ i).symm x) -
            realIndicator T x) ^ 2) / (Fintype.card ι : ℝ) := by
          rw [← Finset.sum_div, Finset.sum_comm]
    _ = 2 * (SoficGroups.boundary σ T : ℝ) /
          (Fintype.card ι : ℝ) := by
          rw [sum_sum_sq_realIndicator_inverse_displacement]

end KunDirectedIndicatorJensen

namespace KunFinitePermutationMarkovMass

open scoped BigOperators

def realIndicator {V : Type*} [DecidableEq V]
    (T : Finset V) (x : V) : ℝ :=
  if x ∈ T then 1 else 0

def realPermutationMarkov {V ι : Type*} [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (x : V) : ℝ :=
  (Fintype.card ι : ℝ)⁻¹ * ∑ i : ι, f ((σ i).symm x)

theorem realPermutationMarkov_nonneg {V ι : Type*}
    [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ)
    (hf : ∀ x, 0 ≤ f x) (x : V) :
    0 ≤ realPermutationMarkov σ f x := by
  unfold realPermutationMarkov
  exact mul_nonneg (inv_nonneg.mpr (Nat.cast_nonneg _))
    (Finset.sum_nonneg fun i _ => hf ((σ i).symm x))

theorem realPermutationMarkov_le_one {V ι : Type*}
    [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ)
    (hf : ∀ x, f x ≤ 1) (x : V) :
    realPermutationMarkov σ f x ≤ 1 := by
  have hcard : (Fintype.card ι : ℝ) ≠ 0 := by
    exact_mod_cast Fintype.card_ne_zero
  have hsum :
      (∑ i : ι, f ((σ i).symm x)) ≤ ∑ _i : ι, (1 : ℝ) := by
    exact Finset.sum_le_sum fun i _ => hf ((σ i).symm x)
  calc
    realPermutationMarkov σ f x =
        (Fintype.card ι : ℝ)⁻¹ * ∑ i : ι, f ((σ i).symm x) := rfl
    _ ≤ (Fintype.card ι : ℝ)⁻¹ * ∑ _i : ι, (1 : ℝ) :=
      mul_le_mul_of_nonneg_left hsum
        (inv_nonneg.mpr (Nat.cast_nonneg _))
    _ = 1 := by
      simp [hcard]

theorem sum_realPermutationMarkov {V ι : Type*}
    [Fintype V] [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) :
    (∑ x : V, realPermutationMarkov σ f x) = ∑ x : V, f x := by
  classical
  have hcard : (Fintype.card ι : ℝ) ≠ 0 := by
    exact_mod_cast Fintype.card_ne_zero
  calc
    (∑ x : V, realPermutationMarkov σ f x) =
        (Fintype.card ι : ℝ)⁻¹ *
          ∑ i : ι, ∑ x : V, f ((σ i).symm x) := by
      simp only [realPermutationMarkov, ← Finset.mul_sum]
      rw [Finset.sum_comm]
    _ = (Fintype.card ι : ℝ)⁻¹ *
          ∑ i : ι, ∑ x : V, f x := by
      congr 1
      apply Finset.sum_congr rfl
      intro i _
      exact Equiv.sum_comp (σ i).symm f
    _ = ∑ x : V, f x := by
      simp [hcard]

theorem realPermutationMarkov_iterate_nonneg {V ι : Type*}
    [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ)
    (hf : ∀ x, 0 ≤ f x) (k : ℕ) :
    ∀ x, 0 ≤ ((realPermutationMarkov σ)^[k]) f x := by
  induction k with
  | zero => simpa using hf
  | succ k ih =>
    intro x
    rw [Function.iterate_succ_apply']
    exact realPermutationMarkov_nonneg σ _ ih x

theorem realPermutationMarkov_iterate_le_one {V ι : Type*}
    [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ)
    (hf : ∀ x, f x ≤ 1) (k : ℕ) :
    ∀ x, ((realPermutationMarkov σ)^[k]) f x ≤ 1 := by
  induction k with
  | zero => simpa using hf
  | succ k ih =>
    intro x
    rw [Function.iterate_succ_apply']
    exact realPermutationMarkov_le_one σ _ ih x

theorem sum_realPermutationMarkov_iterate {V ι : Type*}
    [Fintype V] [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (k : ℕ) :
    (∑ x : V, ((realPermutationMarkov σ)^[k]) f x) =
      ∑ x : V, f x := by
  induction k with
  | zero => simp
  | succ k ih =>
    rw [Function.iterate_succ_apply']
    exact (sum_realPermutationMarkov σ
      (((realPermutationMarkov σ)^[k]) f)).trans ih

theorem sum_realIndicator {V : Type*}
    [Fintype V] [DecidableEq V] (T : Finset V) :
    (∑ x : V, realIndicator T x) = (T.card : ℝ) := by
  classical
  simp [realIndicator]

theorem sum_realPermutationMarkov_iterate_indicator {V ι : Type*}
    [Fintype V] [DecidableEq V] [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (T : Finset V) (k : ℕ) :
    (∑ x : V,
      ((realPermutationMarkov σ)^[k]) (realIndicator T) x) =
        (T.card : ℝ) := by
  rw [sum_realPermutationMarkov_iterate]
  exact sum_realIndicator T

theorem realPermutationMarkov_iterate_indicator_mem_unitInterval
    {V ι : Type*}
    [DecidableEq V] [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (T : Finset V) (k : ℕ) (x : V) :
    0 ≤ ((realPermutationMarkov σ)^[k]) (realIndicator T) x ∧
      ((realPermutationMarkov σ)^[k]) (realIndicator T) x ≤ 1 := by
  constructor
  · apply realPermutationMarkov_iterate_nonneg
    intro y
    by_cases hy : y ∈ T
    · simp [realIndicator, hy]
    · simp [realIndicator, hy]
  · apply realPermutationMarkov_iterate_le_one
    intro y
    by_cases hy : y ∈ T
    · simp [realIndicator, hy]
    · simp [realIndicator, hy]

end KunFinitePermutationMarkovMass

namespace KunResidualExpanderDecomposition

open Filter Topology
open scoped BigOperators symmDiff

theorem boundary_eq_sum_indicator {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (A : Finset V) :
    SoficGroups.boundary σ A =
      ∑ i : ι, ∑ x : V,
        if x ∈ A ∧ σ i x ∉ A then 1 else 0 := by
  classical
  unfold SoficGroups.boundary
  apply Finset.sum_congr rfl
  intro i _
  have hfilter :
      (A.filter fun x => σ i x ∉ A) =
        Finset.univ.filter fun x : V => x ∈ A ∧ σ i x ∉ A := by
    ext x
    simp
  rw [hfilter, Finset.card_eq_sum_ones, Finset.sum_filter]

theorem boundary_eq_sum_entering_indicator {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (A : Finset V) :
    SoficGroups.boundary σ A =
      ∑ i : ι, ∑ x : V,
        if x ∉ A ∧ σ i x ∈ A then 1 else 0 := by
  classical
  unfold SoficGroups.boundary
  apply Finset.sum_congr rfl
  intro i _
  rw [← SoficGroups.KunThomFiberCoarea.card_entering_eq_card_exiting
    (σ i) A, Finset.card_eq_sum_ones, Finset.sum_filter]

theorem boundary_complement {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (A : Finset V) :
    SoficGroups.boundary σ (Finset.univ \ A) =
      SoficGroups.boundary σ A := by
  rw [boundary_eq_sum_indicator σ (Finset.univ \ A),
    boundary_eq_sum_entering_indicator σ A]
  apply Finset.sum_congr rfl
  intro i _
  apply Finset.sum_congr rfl
  intro x _
  simp

theorem boundary_le_degree_mul_card {V ι : Type*}
    [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (A : Finset V) :
    SoficGroups.boundary σ A ≤ Fintype.card ι * A.card := by
  unfold SoficGroups.boundary
  calc
    (∑ i : ι, (A.filter fun x => σ i x ∉ A).card) ≤
        ∑ _i : ι, A.card := by
      apply Finset.sum_le_sum
      intro i _
      exact Finset.card_filter_le _ _
    _ = Fintype.card ι * A.card := by
      simp

theorem boundary_inter_add_boundary_sdiff_le {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (R U : Finset V) :
    SoficGroups.boundary σ (R ∩ U) +
        SoficGroups.boundary σ (R \ U) ≤
      SoficGroups.boundary σ R + 2 * SoficGroups.boundary σ U := by
  classical
  have hpoint (i : ι) (x : V) :
      (if x ∈ R ∩ U ∧ σ i x ∉ R ∩ U then 1 else 0) +
          (if x ∈ R \ U ∧ σ i x ∉ R \ U then 1 else 0) ≤
        (if x ∈ R ∧ σ i x ∉ R then 1 else 0) +
          (if x ∈ U ∧ σ i x ∉ U then 1 else 0) +
          (if x ∉ U ∧ σ i x ∈ U then 1 else 0) := by
    by_cases hxR : x ∈ R <;>
      by_cases hxU : x ∈ U <;>
      by_cases hyR : σ i x ∈ R <;>
      by_cases hyU : σ i x ∈ U <;>
      simp [hxR, hxU, hyR, hyU]
  calc
    SoficGroups.boundary σ (R ∩ U) +
        SoficGroups.boundary σ (R \ U) =
      ∑ i : ι, ∑ x : V,
        ((if x ∈ R ∩ U ∧ σ i x ∉ R ∩ U then 1 else 0) +
         (if x ∈ R \ U ∧ σ i x ∉ R \ U then 1 else 0)) := by
          rw [boundary_eq_sum_indicator, boundary_eq_sum_indicator]
          simp_rw [Finset.sum_add_distrib]
    _ ≤ ∑ i : ι, ∑ x : V,
        ((if x ∈ R ∧ σ i x ∉ R then 1 else 0) +
         (if x ∈ U ∧ σ i x ∉ U then 1 else 0) +
         (if x ∉ U ∧ σ i x ∈ U then 1 else 0)) := by
          apply Finset.sum_le_sum
          intro i _
          apply Finset.sum_le_sum
          intro x _
          exact hpoint i x
    _ = SoficGroups.boundary σ R +
        2 * SoficGroups.boundary σ U := by
          rw [boundary_eq_sum_indicator σ R,
            boundary_eq_sum_indicator σ U]
          have henter := boundary_eq_sum_entering_indicator σ U
          rw [boundary_eq_sum_indicator σ U] at henter
          simp_rw [Finset.sum_add_distrib]
          omega

theorem exists_minimum_sparse_residual_cut {V ι : Type*}
    [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (R : Finset V) (γ : ℝ)
    (hsparse : ∃ T : Finset V, T ⊆ R ∧
      (SoficGroups.boundary σ T : ℝ) < γ * (T.card : ℝ)) :
    ∃ T : Finset V, T ⊆ R ∧
      (SoficGroups.boundary σ T : ℝ) < γ * (T.card : ℝ) ∧
      ∀ E : Finset V, E ⊆ R →
        (SoficGroups.boundary σ E : ℝ) < γ * (E.card : ℝ) →
        T.card ≤ E.card := by
  classical
  let candidates : Finset (Finset V) :=
    R.powerset.filter fun T =>
      (SoficGroups.boundary σ T : ℝ) < γ * (T.card : ℝ)
  have hcandidates : candidates.Nonempty := by
    obtain ⟨T, hTR, hT⟩ := hsparse
    refine ⟨T, ?_⟩
    simp [candidates, hTR, hT]
  obtain ⟨T, hT, hminimum⟩ :=
    Finset.exists_min_image candidates Finset.card hcandidates
  have hT' := (Finset.mem_filter.mp hT)
  refine ⟨T, Finset.mem_powerset.mp hT'.1, hT'.2, ?_⟩
  intro E hER hE
  apply hminimum E
  simp [candidates, hER, hE]

theorem close_residual_inter_properties {V : Type*} [DecidableEq V]
    (R T U : Finset V) (hTR : T ⊆ R)
    (hclose : 3 * (U ∆ T).card < T.card) :
    (R ∩ U).Nonempty ∧
      U.card ≤ 2 * (R ∩ U).card ∧
      (R ∩ U).card < 2 * T.card := by
  classical
  have hmissing :
      (T \ U).card ≤ (U ∆ T).card :=
    Finset.card_le_card
      (Finset.symmDiff_subset_sdiff' (s := U) (t := T))
  have hexcess :
      (U \ T).card ≤ (U ∆ T).card :=
    Finset.card_le_card
      (Finset.symmDiff_subset_sdiff (s := U) (t := T))
  have hTinter :
      (T ∩ U).card ≤ (R ∩ U).card := by
    apply Finset.card_le_card
    intro x hx
    exact Finset.mem_inter.mpr
      ⟨hTR (Finset.mem_inter.mp hx).1, (Finset.mem_inter.mp hx).2⟩
  have hUinter :
      (U ∩ T).card ≤ (R ∩ U).card := by
    apply Finset.card_le_card
    intro x hx
    exact Finset.mem_inter.mpr
      ⟨hTR (Finset.mem_inter.mp hx).2, (Finset.mem_inter.mp hx).1⟩
  have hTsplit := Finset.card_sdiff_add_card_inter T U
  have hUsplit := Finset.card_sdiff_add_card_inter U T
  have hintercomm : (T ∩ U).card = (U ∩ T).card := by
    rw [Finset.inter_comm]
  have hPsub : (R ∩ U).card ≤ U.card :=
    Finset.card_le_card Finset.inter_subset_right
  have hPpos : 0 < (R ∩ U).card := by omega
  exact ⟨Finset.card_pos.mp hPpos, by omega, by omega⟩

theorem minimum_sparse_cut_expands_close_residual_part
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (R T U : Finset V) (γ : ℝ)
    (hTR : T ⊆ R)
    (hminimum : ∀ E : Finset V, E ⊆ R →
      (SoficGroups.boundary σ E : ℝ) < γ * (E.card : ℝ) →
      T.card ≤ E.card)
    (hclose : 3 * (U ∆ T).card < T.card) :
    ∀ E : Finset V, E ⊆ R ∩ U →
      2 * E.card ≤ (R ∩ U).card →
      γ * (E.card : ℝ) ≤ (SoficGroups.boundary σ E : ℝ) := by
  intro E hE hhalf
  by_contra h
  have hbad :
      (SoficGroups.boundary σ E : ℝ) < γ * (E.card : ℝ) :=
    lt_of_not_ge h
  have hER : E ⊆ R := hE.trans Finset.inter_subset_left
  have hmin := hminimum E hER hbad
  have hsize := (close_residual_inter_properties R T U hTR hclose).2.2
  omega

theorem exists_expanding_residual_finpartition
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B : Finset V) (γ α : ℝ)
    (hα : 0 ≤ α)
    (himprove : ∀ T : Finset V, T ⊆ Finset.univ \ B →
      (SoficGroups.boundary σ T : ℝ) < γ * (T.card : ℝ) →
      ∃ U : Finset V, 3 * (U ∆ T).card < T.card ∧
        (SoficGroups.boundary σ U : ℝ) ≤ α * (U.card : ℝ))
    (R : Finset V) (hRB : R ⊆ Finset.univ \ B) :
    ∃ P : Finpartition R,
      (∀ C ∈ P.parts, ∀ E : Finset V, E ⊆ C →
        2 * E.card ≤ C.card →
          γ * (E.card : ℝ) ≤ (SoficGroups.boundary σ E : ℝ)) ∧
      (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) ≤
        (SoficGroups.boundary σ R : ℝ) +
          4 * α * (R.card : ℝ) := by
  classical
  have hmain : ∀ R : Finset V, R ⊆ Finset.univ \ B →
      ∃ P : Finpartition R,
        (∀ C ∈ P.parts, ∀ E : Finset V, E ⊆ C →
          2 * E.card ≤ C.card →
            γ * (E.card : ℝ) ≤
              (SoficGroups.boundary σ E : ℝ)) ∧
        (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) ≤
          (SoficGroups.boundary σ R : ℝ) +
            4 * α * (R.card : ℝ) := by
    intro R
    refine Finset.strongInductionOn R ?_
    intro R ih hRgood
    by_cases hR : R.Nonempty
    · by_cases hsparse : ∃ T : Finset V, T ⊆ R ∧
          (SoficGroups.boundary σ T : ℝ) < γ * (T.card : ℝ)
      · obtain ⟨T, hTR, hTsparse, hTminimum⟩ :=
          exists_minimum_sparse_residual_cut σ R γ hsparse
        obtain ⟨U, hclose, hUboundary⟩ :=
          himprove T (hTR.trans hRgood) hTsparse
        have hpiece :=
          close_residual_inter_properties R T U hTR hclose
        let C : Finset V := R ∩ U
        have hCnonempty : C.Nonempty := by
          simpa only [C] using hpiece.1
        have hCR : C ⊆ R := Finset.inter_subset_left
        have hstrict : R \ C ⊂ R :=
          Finset.sdiff_ssubset hCR hCnonempty
        have hresgood : R \ C ⊆ Finset.univ \ B :=
          Finset.Subset.trans Finset.sdiff_subset hRgood
        obtain ⟨Q, hQexpand, hQbudget⟩ :=
          ih (R \ C) hstrict hresgood
        have hdisjoint : Disjoint (R \ C) C :=
          Finset.sdiff_disjoint
        have hunion : (R \ C) ⊔ C = R := by
          change (R \ C) ∪ C = R
          exact Finset.sdiff_union_of_subset hCR
        let P : Finpartition R :=
          Q.extend hCnonempty.ne_empty hdisjoint hunion
        have hCnot : C ∉ Q.parts := by
          intro hCQ
          have hsub := Q.subset hCQ
          obtain ⟨x, hx⟩ := hCnonempty
          exact (Finset.mem_sdiff.mp (hsub hx)).2 hx
        refine ⟨P, ?_, ?_⟩
        · intro D hD E hED hhalf
          have hparts : D = C ∨ D ∈ Q.parts := by
            simpa [P, Finpartition.extend] using hD
          rcases hparts with rfl | hDQ
          · exact minimum_sparse_cut_expands_close_residual_part
              σ R T U γ hTR hTminimum hclose E
              (by simpa only [C] using hED)
              (by simpa only [C] using hhalf)
          · exact hQexpand D hDQ E hED hhalf
        · have hUcard : (U.card : ℝ) ≤
              2 * (C.card : ℝ) := by
            exact_mod_cast hpiece.2.1
          have hUcost :
              2 * (SoficGroups.boundary σ U : ℝ) ≤
                4 * α * (C.card : ℝ) := by
            have hscale := mul_le_mul_of_nonneg_left hUcard hα
            nlinarith
          have hsplit :
              (SoficGroups.boundary σ C : ℝ) +
                  (SoficGroups.boundary σ (R \ C) : ℝ) ≤
                (SoficGroups.boundary σ R : ℝ) +
                  2 * (SoficGroups.boundary σ U : ℝ) := by
            have h := boundary_inter_add_boundary_sdiff_le σ R U
            have hres : R \ C = R \ U := by
              ext x
              simp [C]
            simpa only [C, hres, Nat.cast_add, Nat.cast_mul,
              Nat.cast_ofNat] using
              (show
                ((SoficGroups.boundary σ (R ∩ U) +
                  SoficGroups.boundary σ (R \ U) : ℕ) : ℝ) ≤
                ((SoficGroups.boundary σ R +
                  2 * SoficGroups.boundary σ U : ℕ) : ℝ)
                from by exact_mod_cast h)
          have hcard :
              ((R \ C).card : ℝ) + (C.card : ℝ) =
                (R.card : ℝ) := by
            exact_mod_cast Finset.card_sdiff_add_card_eq_card hCR
          calc
            (∑ D ∈ P.parts, (SoficGroups.boundary σ D : ℝ)) =
                (SoficGroups.boundary σ C : ℝ) +
                  ∑ D ∈ Q.parts,
                    (SoficGroups.boundary σ D : ℝ) := by
                  simp [P, Finpartition.extend, hCnot]
            _ ≤ (SoficGroups.boundary σ C : ℝ) +
                  ((SoficGroups.boundary σ (R \ C) : ℝ) +
                    4 * α * ((R \ C).card : ℝ)) :=
                    add_le_add (le_refl _) hQbudget
            _ ≤ (SoficGroups.boundary σ R : ℝ) +
                  2 * (SoficGroups.boundary σ U : ℝ) +
                    4 * α * ((R \ C).card : ℝ) := by
                  linarith
            _ ≤ (SoficGroups.boundary σ R : ℝ) +
                  4 * α * (C.card : ℝ) +
                    4 * α * ((R \ C).card : ℝ) := by
                  linarith
            _ = (SoficGroups.boundary σ R : ℝ) +
                  4 * α * (R.card : ℝ) := by
                  nlinarith [hcard]
      · refine ⟨Finpartition.indiscrete hR.ne_empty, ?_, ?_⟩
        · intro C hC E hEC _
          have hCR : C = R := by
            simpa [Finpartition.indiscrete] using hC
          subst C
          by_contra h
          apply hsparse
          exact ⟨E, hEC, lt_of_not_ge h⟩
        · simp only [Finpartition.indiscrete, Finset.sum_singleton]
          have hnonneg : 0 ≤ 4 * α * (R.card : ℝ) := by
            positivity
          linarith
    · have hzero : R = ∅ :=
        Finset.not_nonempty_iff_eq_empty.mp hR
      subst R
      refine ⟨Finpartition.empty (Finset V), ?_, ?_⟩
      · simp
      · simp [SoficGroups.boundary]
  exact hmain R hRB

theorem exists_expanding_clean_finpartition
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B : Finset V) (γ α : ℝ)
    (hα : 0 ≤ α)
    (himprove : ∀ T : Finset V, T ⊆ Finset.univ \ B →
      (SoficGroups.boundary σ T : ℝ) < γ * (T.card : ℝ) →
      ∃ U : Finset V, 3 * (U ∆ T).card < T.card ∧
        (SoficGroups.boundary σ U : ℝ) ≤ α * (U.card : ℝ)) :
    ∃ P : Finpartition (Finset.univ \ B),
      (∀ C ∈ P.parts, ∀ E : Finset V, E ⊆ C →
        2 * E.card ≤ C.card →
          γ * (E.card : ℝ) ≤ (SoficGroups.boundary σ E : ℝ)) ∧
      (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) ≤
        (Fintype.card ι : ℝ) * (B.card : ℝ) +
          4 * α * ((Finset.univ \ B).card : ℝ) := by
  obtain ⟨P, hP, hbudget⟩ :=
    exists_expanding_residual_finpartition σ B γ α hα himprove
      (Finset.univ \ B) (Finset.Subset.refl _)
  refine ⟨P, hP, ?_⟩
  calc
    (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) ≤
        (SoficGroups.boundary σ (Finset.univ \ B) : ℝ) +
          4 * α * ((Finset.univ \ B).card : ℝ) := hbudget
    _ = (SoficGroups.boundary σ B : ℝ) +
          4 * α * ((Finset.univ \ B).card : ℝ) := by
            rw [boundary_complement]
    _ ≤ (Fintype.card ι : ℝ) * (B.card : ℝ) +
          4 * α * ((Finset.univ \ B).card : ℝ) := by
            have hdegree := boundary_le_degree_mul_card σ B
            have hdegreeReal :
                (SoficGroups.boundary σ B : ℝ) ≤
                  (Fintype.card ι : ℝ) * (B.card : ℝ) := by
              exact_mod_cast hdegree
            linarith

noncomputable def completeCleanFinpartition
    {V : Type*} [Fintype V] [DecidableEq V]
    (B : Finset V) (P : Finpartition (Finset.univ \ B)) :
    Finpartition (Finset.univ : Finset V) := by
  classical
  let parts : Finset (Finset V) :=
    P.parts ∪ (⊥ : Finpartition B).parts
  refine Finpartition.ofExistsUnique parts ?_ ?_ ?_
  · intro C _
    exact Finset.subset_univ C
  · intro x _
    by_cases hx : x ∈ B
    · refine ⟨{x}, ⟨?_, by simp⟩, ?_⟩
      · exact Finset.mem_union_right _
          (Finpartition.mem_bot_iff.mpr ⟨x, hx, rfl⟩)
      · intro C hC
        obtain ⟨hpart, hxC⟩ := hC
        rcases Finset.mem_union.mp hpart with hclean | hbad
        · have hxc := P.subset hclean hxC
          exact ((Finset.mem_sdiff.mp hxc).2 hx).elim
        · obtain ⟨y, _, hy⟩ := Finpartition.mem_bot_iff.mp hbad
          subst C
          simp only [Finset.mem_singleton] at hxC
          subst y
          rfl
    · have hxclean : x ∈ (Finset.univ \ B : Finset V) := by
        simp [hx]
      obtain ⟨C, ⟨hCP, hxC⟩, hunique⟩ :=
        P.existsUnique_mem hxclean
      refine ⟨C, ⟨Finset.mem_union_left _ hCP, hxC⟩, ?_⟩
      intro D hD
      obtain ⟨hpart, hxD⟩ := hD
      rcases Finset.mem_union.mp hpart with hclean | hbad
      · exact hunique D ⟨hclean, hxD⟩
      · obtain ⟨y, hyB, hy⟩ := Finpartition.mem_bot_iff.mp hbad
        subst D
        simp only [Finset.mem_singleton] at hxD
        exact (hx (hxD.symm ▸ hyB)).elim
  · intro hempty
    rcases Finset.mem_union.mp hempty with hclean | hbad
    · exact P.empty_notMem_parts hclean
    · obtain ⟨x, _, hx⟩ := Finpartition.mem_bot_iff.mp hbad
      simp at hx

@[simp]
theorem completeCleanFinpartition_parts
    {V : Type*} [Fintype V] [DecidableEq V]
    (B : Finset V) (P : Finpartition (Finset.univ \ B)) :
    (completeCleanFinpartition B P).parts =
      P.parts ∪ (⊥ : Finpartition B).parts := by
  rfl

theorem disjoint_clean_parts_singleton_bad_parts
    {V : Type*} [Fintype V] [DecidableEq V]
    (B : Finset V) (P : Finpartition (Finset.univ \ B)) :
    Disjoint P.parts (⊥ : Finpartition B).parts := by
  apply Finset.disjoint_left.mpr
  intro C hCP hCB
  obtain ⟨x, hxB, hxC⟩ := Finpartition.mem_bot_iff.mp hCB
  subst C
  have hxclean := P.subset hCP (Finset.mem_singleton_self x)
  exact (Finset.mem_sdiff.mp hxclean).2 hxB

theorem sum_singleton_bad_boundary_le
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B : Finset V) :
    (∑ C ∈ (⊥ : Finpartition B).parts,
      (SoficGroups.boundary σ C : ℝ)) ≤
        (Fintype.card ι : ℝ) * (B.card : ℝ) := by
  classical
  calc
    (∑ C ∈ (⊥ : Finpartition B).parts,
      (SoficGroups.boundary σ C : ℝ)) =
        ∑ x ∈ B, (SoficGroups.boundary σ {x} : ℝ) := by
          simp [Finpartition.parts_bot]
    _ ≤ ∑ _x ∈ B, (Fintype.card ι : ℝ) := by
          apply Finset.sum_le_sum
          intro x _
          have h := boundary_le_degree_mul_card σ ({x} : Finset V)
          have h' :
              SoficGroups.boundary σ ({x} : Finset V) ≤
                Fintype.card ι := by
            simpa only [Finset.card_singleton, mul_one] using h
          exact_mod_cast h'
    _ = (Fintype.card ι : ℝ) * (B.card : ℝ) := by
          simp [mul_comm]

theorem completeCleanFinpartition_half_expansion
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B : Finset V)
    (P : Finpartition (Finset.univ \ B)) (γ : ℝ)
    (hexpand : ∀ C ∈ P.parts, ∀ E : Finset V, E ⊆ C →
      2 * E.card ≤ C.card →
        γ * (E.card : ℝ) ≤ (SoficGroups.boundary σ E : ℝ)) :
    ∀ C ∈ (completeCleanFinpartition B P).parts,
      ∀ E : Finset V, E ⊆ C →
        2 * E.card ≤ C.card →
          γ * (E.card : ℝ) ≤ (SoficGroups.boundary σ E : ℝ) := by
  classical
  intro C hC E hEC hhalf
  rw [completeCleanFinpartition_parts] at hC
  rcases Finset.mem_union.mp hC with hclean | hbad
  · exact hexpand C hclean E hEC hhalf
  · obtain ⟨x, _, hx⟩ := Finpartition.mem_bot_iff.mp hbad
    subst C
    have hE : E = ∅ := by
      apply Finset.card_eq_zero.mp
      simp only [Finset.card_singleton] at hhalf
      omega
    subst E
    simp [SoficGroups.boundary]

theorem exists_expanding_full_finpartition
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B : Finset V) (γ α : ℝ)
    (hα : 0 ≤ α)
    (himprove : ∀ T : Finset V, T ⊆ Finset.univ \ B →
      (SoficGroups.boundary σ T : ℝ) < γ * (T.card : ℝ) →
      ∃ U : Finset V, 3 * (U ∆ T).card < T.card ∧
        (SoficGroups.boundary σ U : ℝ) ≤ α * (U.card : ℝ)) :
    ∃ P : Finpartition (Finset.univ : Finset V),
      (∀ C ∈ P.parts, ∀ E : Finset V, E ⊆ C →
        2 * E.card ≤ C.card →
          γ * (E.card : ℝ) ≤ (SoficGroups.boundary σ E : ℝ)) ∧
      (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) ≤
        2 * (Fintype.card ι : ℝ) * (B.card : ℝ) +
          4 * α * (Fintype.card V : ℝ) := by
  classical
  obtain ⟨Q, hQexpand, hQbudget⟩ :=
    exists_expanding_clean_finpartition σ B γ α hα himprove
  let P : Finpartition (Finset.univ : Finset V) :=
    completeCleanFinpartition B Q
  refine ⟨P, ?_, ?_⟩
  · exact completeCleanFinpartition_half_expansion
      σ B Q γ hQexpand
  · have hbad := sum_singleton_bad_boundary_le σ B
    have hdisjoint :=
      disjoint_clean_parts_singleton_bad_parts B Q
    have hclean :
        ((Finset.univ \ B).card : ℝ) ≤
          (Fintype.card V : ℝ) := by
      exact_mod_cast
        (Finset.card_le_card
          (Finset.sdiff_subset :
            Finset.univ \ B ⊆ (Finset.univ : Finset V)))
    have hscaled := mul_le_mul_of_nonneg_left hclean
      (mul_nonneg (by norm_num : (0 : ℝ) ≤ 4) hα)
    calc
      (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) =
          (∑ C ∈ Q.parts, (SoficGroups.boundary σ C : ℝ)) +
            (∑ C ∈ (⊥ : Finpartition B).parts,
              (SoficGroups.boundary σ C : ℝ)) := by
                change
                  (∑ C ∈ (completeCleanFinpartition B Q).parts,
                    (SoficGroups.boundary σ C : ℝ)) = _
                rw [completeCleanFinpartition_parts,
                  Finset.sum_union hdisjoint]
      _ ≤ ((Fintype.card ι : ℝ) * (B.card : ℝ) +
            4 * α * ((Finset.univ \ B).card : ℝ)) +
          (Fintype.card ι : ℝ) * (B.card : ℝ) :=
            add_le_add hQbudget hbad
      _ ≤ 2 * (Fintype.card ι : ℝ) * (B.card : ℝ) +
          4 * α * (Fintype.card V : ℝ) := by
            nlinarith

theorem exists_expanding_full_finpartition_sequence
    (ι : Type*) [Fintype ι]
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)]
    [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (B : (n : ℕ) → Finset (V n))
    (γ : ℝ) (hγ : 0 < γ)
    (α : ℕ → ℝ)
    (hα : ∀ n, 0 ≤ α n)
    (hαzero : Tendsto α atTop (nhds 0))
    (hbad : Tendsto
      (fun n => ((B n).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0))
    (himprove : ∀ n (T : Finset (V n)),
      T ⊆ Finset.univ \ B n →
      (SoficGroups.boundary (σ n) T : ℝ) <
        γ * (T.card : ℝ) →
      ∃ U : Finset (V n), 3 * (U ∆ T).card < T.card ∧
        (SoficGroups.boundary (σ n) U : ℝ) ≤
          α n * (U.card : ℝ)) :
    ∃ P : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)),
      0 < γ ∧
      (∀ n, ∀ C ∈ (P n).parts, ∀ E : Finset (V n), E ⊆ C →
        2 * E.card ≤ C.card →
          γ * (E.card : ℝ) ≤
            (SoficGroups.boundary (σ n) E : ℝ)) ∧
      Tendsto
        (fun n =>
          (∑ C ∈ (P n).parts,
            (SoficGroups.boundary (σ n) C : ℝ)) /
              Fintype.card (V n))
        atTop (nhds 0) := by
  classical
  have hchoose (n : ℕ) :=
    exists_expanding_full_finpartition
      (σ n) (B n) γ (α n) (hα n) (himprove n)
  let P : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)) :=
    fun n => (hchoose n).choose
  have hexpand (n : ℕ) :
      ∀ C ∈ (P n).parts, ∀ E : Finset (V n), E ⊆ C →
        2 * E.card ≤ C.card →
          γ * (E.card : ℝ) ≤
            (SoficGroups.boundary (σ n) E : ℝ) :=
    (hchoose n).choose_spec.1
  have hbudget (n : ℕ) :
      (∑ C ∈ (P n).parts,
        (SoficGroups.boundary (σ n) C : ℝ)) ≤
        2 * (Fintype.card ι : ℝ) * ((B n).card : ℝ) +
          4 * α n * (Fintype.card (V n) : ℝ) :=
    (hchoose n).choose_spec.2
  have hpositive (n : ℕ) :
      (0 : ℝ) < Fintype.card (V n) := by
    exact_mod_cast Fintype.card_pos_iff.mpr inferInstance
  have hupper (n : ℕ) :
      (∑ C ∈ (P n).parts,
        (SoficGroups.boundary (σ n) C : ℝ)) /
          Fintype.card (V n) ≤
        (2 * (Fintype.card ι : ℝ)) *
          (((B n).card : ℝ) / Fintype.card (V n)) +
            4 * α n := by
    calc
      (∑ C ∈ (P n).parts,
        (SoficGroups.boundary (σ n) C : ℝ)) /
          Fintype.card (V n) ≤
        (2 * (Fintype.card ι : ℝ) * ((B n).card : ℝ) +
          4 * α n * (Fintype.card (V n) : ℝ)) /
            Fintype.card (V n) :=
              div_le_div_of_nonneg_right (hbudget n)
                (hpositive n).le
      _ = (2 * (Fintype.card ι : ℝ)) *
            (((B n).card : ℝ) / Fintype.card (V n)) +
          4 * α n := by
            field_simp [(hpositive n).ne']
  have hlimit : Tendsto
      (fun n =>
        (2 * (Fintype.card ι : ℝ)) *
          (((B n).card : ℝ) / Fintype.card (V n)) +
            4 * α n)
      atTop (nhds 0) := by
    simpa using
      (hbad.const_mul (2 * (Fintype.card ι : ℝ))).add
        (hαzero.const_mul 4)
  refine ⟨P, hγ, hexpand, ?_⟩
  exact squeeze_zero
    (fun n => div_nonneg
      (Finset.sum_nonneg fun C _ => Nat.cast_nonneg _)
      (hpositive n).le)
    hupper hlimit

theorem original_boundary_le_completed_add_component_boundary
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (C : Finset V)
    (τ : ι → Equiv.Perm {x : V // x ∈ C})
    (hτ : ∀ i (x : V) (hx : x ∈ C) (_hy : σ i x ∈ C),
      ((τ i ⟨x, hx⟩ : {x : V // x ∈ C}) : V) = σ i x)
    (A : Finset {x : V // x ∈ C}) :
    SoficGroups.boundary σ
        (A.map (Function.Embedding.subtype (fun x : V => x ∈ C))) ≤
      SoficGroups.boundary τ A +
        SoficGroups.boundary σ C := by
  classical
  let E : Finset V :=
    A.map (Function.Embedding.subtype (fun x : V => x ∈ C))
  change
    (∑ i : ι, (E.filter fun x => σ i x ∉ E).card) ≤
      (∑ i : ι, (A.filter fun x => τ i x ∉ A).card) +
        ∑ i : ι, (C.filter fun x => σ i x ∉ C).card
  calc
    (∑ i : ι, (E.filter fun x => σ i x ∉ E).card) ≤
      ∑ i : ι,
        ((A.filter fun x => τ i x ∉ A).card +
          (C.filter fun x => σ i x ∉ C).card) := by
        apply Finset.sum_le_sum
        intro i _
        let F : Finset V :=
          (A.filter fun x => τ i x ∉ A).map
            (Function.Embedding.subtype (fun x : V => x ∈ C))
        let D : Finset V := C.filter fun x => σ i x ∉ C
        have hsub :
            (E.filter fun x => σ i x ∉ E) ⊆ F ∪ D := by
          intro x hx
          obtain ⟨hxE, hxout⟩ := Finset.mem_filter.mp hx
          obtain ⟨z, hzA, rfl⟩ := Finset.mem_map.mp hxE
          by_cases hzinternal : σ i (z : V) ∈ C
          · have hnot : τ i z ∉ A := by
              intro hmem
              apply hxout
              apply Finset.mem_map.mpr
              refine ⟨τ i z, hmem, ?_⟩
              exact hτ i (z : V) z.property hzinternal
            apply Finset.mem_union_left
            exact Finset.mem_map.mpr
              ⟨z, Finset.mem_filter.mpr ⟨hzA, hnot⟩, rfl⟩
          · apply Finset.mem_union_right
            exact Finset.mem_filter.mpr ⟨z.property, hzinternal⟩
        calc
          (E.filter fun x => σ i x ∉ E).card ≤
              (F ∪ D).card :=
                Finset.card_le_card hsub
          _ ≤ F.card + D.card :=
                Finset.card_union_le F D
          _ = (A.filter fun x => τ i x ∉ A).card +
                (C.filter fun x => σ i x ∉ C).card := by
                  simp [F, D]
    _ = (∑ i : ι, (A.filter fun x => τ i x ∉ A).card) +
          ∑ i : ι, (C.filter fun x => σ i x ∉ C).card := by
            rw [Finset.sum_add_distrib]

theorem completed_component_additive_expansion
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (C : Finset V)
    (τ : ι → Equiv.Perm {x : V // x ∈ C})
    (hτ : ∀ i (x : V) (hx : x ∈ C) (_hy : σ i x ∈ C),
      ((τ i ⟨x, hx⟩ : {x : V // x ∈ C}) : V) = σ i x)
    (γ : ℝ)
    (hexpand : ∀ E : Finset V, E ⊆ C →
      2 * E.card ≤ C.card →
        γ * (E.card : ℝ) ≤ (SoficGroups.boundary σ E : ℝ)) :
    ∀ A : Finset {x : V // x ∈ C},
      γ * min (A.card : ℝ) ((C.card : ℝ) - A.card) -
          (SoficGroups.boundary σ C : ℝ) ≤
        (SoficGroups.boundary τ A : ℝ) := by
  classical
  have hhalf (A : Finset {x : V // x ∈ C})
      (hA : 2 * A.card ≤ C.card) :
      γ * (A.card : ℝ) -
          (SoficGroups.boundary σ C : ℝ) ≤
        (SoficGroups.boundary τ A : ℝ) := by
    let E : Finset V :=
      A.map (Function.Embedding.subtype (fun x : V => x ∈ C))
    have hEC : E ⊆ C := by
      intro x hx
      exact Finset.property_of_mem_map_subtype A hx
    have hEcard : E.card = A.card := by
      dsimp [E]
      exact Finset.card_map _
    have hEhalf : 2 * E.card ≤ C.card := by
      simpa only [hEcard] using hA
    have hsource := hexpand E hEC hEhalf
    have hboundary :
        (SoficGroups.boundary σ E : ℝ) ≤
          (SoficGroups.boundary τ A : ℝ) +
            (SoficGroups.boundary σ C : ℝ) := by
      have h :=
        original_boundary_le_completed_add_component_boundary
          σ C τ hτ A
      change
        ((SoficGroups.boundary σ E : ℕ) : ℝ) ≤ _
      exact_mod_cast h
    rw [hEcard] at hsource
    linarith
  intro A
  by_cases hA : 2 * A.card ≤ C.card
  · have hreal :
        (2 : ℝ) * (A.card : ℝ) ≤ (C.card : ℝ) := by
      exact_mod_cast hA
    rw [min_eq_left (by linarith)]
    exact hhalf A hA
  · let D : Finset {x : V // x ∈ C} := Finset.univ \ A
    have hcard :
        D.card + A.card = C.card := by
      dsimp [D]
      have h :=
        Finset.card_sdiff_add_card_eq_card
          (Finset.subset_univ A)
      simpa using h
    have hDhalf : 2 * D.card ≤ C.card := by
      omega
    have hD := hhalf D hDhalf
    have hDreal :
        (D.card : ℝ) = (C.card : ℝ) - (A.card : ℝ) := by
      have hreal :
          (D.card : ℝ) + (A.card : ℝ) = (C.card : ℝ) := by
        exact_mod_cast hcard
      linarith
    have hreal :
        (C.card : ℝ) < 2 * (A.card : ℝ) := by
      exact_mod_cast Nat.lt_of_not_ge hA
    rw [min_eq_right (by linarith)]
    rw [hDreal] at hD
    have hcomplement :
        SoficGroups.boundary τ D =
          SoficGroups.boundary τ A := by
      simpa only [D] using boundary_complement τ A
    rw [hcomplement] at hD
    exact hD

end KunResidualExpanderDecomposition

namespace KunDiagonalGoodRootGraphLoss

open scoped BigOperators symmDiff

def goodPermutationGraph {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (B : Finset V) : Finset (V × V) :=
  (SoficGroups.permutationGraph p).filter
    (fun z => z.1 ∉ B ∧ z.2 ∉ B)

theorem goodPermutationGraph_subset {V : Type*}
    [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (B : Finset V) :
    goodPermutationGraph p B ⊆ SoficGroups.permutationGraph p :=
  Finset.filter_subset _ _

theorem card_filter_permutationGraph_fst_mem {V : Type*}
    [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (B : Finset V) :
    ((SoficGroups.permutationGraph p).filter
      fun z => z.1 ∈ B).card = B.card := by
  classical
  apply Finset.card_bij (fun z _ => z.1)
  · intro z hz
    exact (Finset.mem_filter.mp hz).2
  · intro z hz w hw hfirst
    have hzgraph := (Finset.mem_filter.mp hz).1
    have hwgraph := (Finset.mem_filter.mp hw).1
    have hzsecond :=
      (SoficGroups.mem_permutationGraph p z.1 z.2).mp hzgraph
    have hwsecond :=
      (SoficGroups.mem_permutationGraph p w.1 w.2).mp hwgraph
    apply Prod.ext hfirst
    simpa [hzsecond, hwsecond] using congrArg p hfirst
  · intro x hx
    refine ⟨(x, p x), ?_, rfl⟩
    exact Finset.mem_filter.mpr
      ⟨(SoficGroups.mem_permutationGraph p x (p x)).mpr rfl, hx⟩

theorem card_filter_permutationGraph_snd_mem {V : Type*}
    [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (B : Finset V) :
    ((SoficGroups.permutationGraph p).filter
      fun z => z.2 ∈ B).card = B.card := by
  classical
  apply Finset.card_bij (fun z _ => z.2)
  · intro z hz
    exact (Finset.mem_filter.mp hz).2
  · intro z hz w hw hsecond
    have hzgraph := (Finset.mem_filter.mp hz).1
    have hwgraph := (Finset.mem_filter.mp hw).1
    have hzsecond :=
      (SoficGroups.mem_permutationGraph p z.1 z.2).mp hzgraph
    have hwsecond :=
      (SoficGroups.mem_permutationGraph p w.1 w.2).mp hwgraph
    apply Prod.ext
    · apply p.injective
      simpa [hzsecond, hwsecond] using hsecond
    · exact hsecond
  · intro y hy
    refine ⟨(p.symm y, y), ?_, rfl⟩
    apply Finset.mem_filter.mpr
    refine ⟨?_, hy⟩
    apply (SoficGroups.mem_permutationGraph p (p.symm y) y).mpr
    simp

theorem permutationGraph_sdiff_goodPermutationGraph_subset {V : Type*}
    [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (B : Finset V) :
    SoficGroups.permutationGraph p \ goodPermutationGraph p B ⊆
      ((SoficGroups.permutationGraph p).filter fun z => z.1 ∈ B) ∪
        ((SoficGroups.permutationGraph p).filter fun z => z.2 ∈ B) := by
  intro z hz
  obtain ⟨hzgraph, hzgood⟩ := Finset.mem_sdiff.mp hz
  by_cases hfirst : z.1 ∈ B
  · exact Finset.mem_union_left _
      (Finset.mem_filter.mpr ⟨hzgraph, hfirst⟩)
  · have hsecond : z.2 ∈ B := by
      by_contra h
      apply hzgood
      exact Finset.mem_filter.mpr ⟨hzgraph, hfirst, h⟩
    exact Finset.mem_union_right _
      (Finset.mem_filter.mpr ⟨hzgraph, hsecond⟩)

theorem card_permutationGraph_sdiff_goodPermutationGraph_le {V : Type*}
    [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (B : Finset V) :
    (SoficGroups.permutationGraph p \ goodPermutationGraph p B).card ≤
      2 * B.card := by
  calc
    (SoficGroups.permutationGraph p \ goodPermutationGraph p B).card ≤
        (((SoficGroups.permutationGraph p).filter fun z => z.1 ∈ B) ∪
          ((SoficGroups.permutationGraph p).filter
            fun z => z.2 ∈ B)).card :=
      Finset.card_le_card
        (permutationGraph_sdiff_goodPermutationGraph_subset p B)
    _ ≤ ((SoficGroups.permutationGraph p).filter
          fun z => z.1 ∈ B).card +
        ((SoficGroups.permutationGraph p).filter
          fun z => z.2 ∈ B).card := Finset.card_union_le _ _
    _ = 2 * B.card := by
      rw [card_filter_permutationGraph_fst_mem,
        card_filter_permutationGraph_snd_mem]
      omega

theorem card_goodPermutationGraph_add_graph_loss {V : Type*}
    [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (B : Finset V) :
    (SoficGroups.permutationGraph p \ goodPermutationGraph p B).card +
        (goodPermutationGraph p B).card = Fintype.card V := by
  calc
    (SoficGroups.permutationGraph p \ goodPermutationGraph p B).card +
        (goodPermutationGraph p B).card =
        (SoficGroups.permutationGraph p).card :=
      Finset.card_sdiff_add_card_eq_card
        (goodPermutationGraph_subset p B)
    _ = Fintype.card V :=
      SoficGroups.KunThomFiberCoarea.permutationGraph_card p

theorem card_goodPermutationGraph_ge_card_sub_twice_bad {V : Type*}
    [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (B : Finset V) :
    (Fintype.card V : ℝ) - 2 * (B.card : ℝ) ≤
      ((goodPermutationGraph p B).card : ℝ) := by
  have hloss :
      (((SoficGroups.permutationGraph p \
        goodPermutationGraph p B).card : ℕ) : ℝ) ≤
          2 * (B.card : ℝ) := by
    exact_mod_cast card_permutationGraph_sdiff_goodPermutationGraph_le p B
  have htotal :
      (((SoficGroups.permutationGraph p \
        goodPermutationGraph p B).card : ℕ) : ℝ) +
          ((goodPermutationGraph p B).card : ℝ) =
        (Fintype.card V : ℝ) := by
    exact_mod_cast card_goodPermutationGraph_add_graph_loss p B
  linarith

theorem boundary_goodPermutationGraph_le_commutationDefect_add {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (p : Equiv.Perm V) (B : Finset V) :
    SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) (goodPermutationGraph p B) ≤
      SoficGroups.permutationCommutationDefect σ p +
        2 * Fintype.card ι * B.card := by
  have hboundary :=
    SoficGroups.KunThomFiberCoarea.boundary_le_boundary_add_sdiff
      (fun i => (σ i).prodCongr (σ i))
      (goodPermutationGraph p B) (SoficGroups.permutationGraph p)
  rw [SoficGroups.boundary_permutationGraph_eq_commutationDefect,
    Finset.sdiff_eq_empty_iff_subset.mpr
      (goodPermutationGraph_subset p B),
    Finset.card_empty, zero_add] at hboundary
  calc
    SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) (goodPermutationGraph p B) ≤
      SoficGroups.permutationCommutationDefect σ p +
        Fintype.card ι *
          (SoficGroups.permutationGraph p \
            goodPermutationGraph p B).card := hboundary
    _ ≤ SoficGroups.permutationCommutationDefect σ p +
        Fintype.card ι * (2 * B.card) := by
      gcongr
      exact card_permutationGraph_sdiff_goodPermutationGraph_le p B
    _ = SoficGroups.permutationCommutationDefect σ p +
        2 * Fintype.card ι * B.card := by
      ring

end KunDiagonalGoodRootGraphLoss

namespace KunCompletedPrunedComponent

open scoped BigOperators

theorem hasAlmostCentralizerImprovement_zero
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) :
    SoficGroups.HasAlmostCentralizerImprovement σ 0 := by
  refine ⟨fun p hp => ⟨p, ?_, ?_⟩⟩
  · simpa using hp
  · simp

theorem boundary_complement
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (A : Finset V) :
    SoficGroups.boundary σ (Finset.univ \ A) =
      SoficGroups.boundary σ A := by
  classical
  unfold SoficGroups.boundary
  apply Finset.sum_congr rfl
  intro i _
  calc
    ((Finset.univ \ A).filter
        (fun x => σ i x ∉ Finset.univ \ A)).card =
        (Finset.univ.filter
          (fun x => x ∉ A ∧ σ i x ∈ A)).card := by
      congr 1
      ext x
      simp only [Finset.mem_filter, Finset.mem_sdiff,
        Finset.mem_univ, true_and]
      grind
    _ = (A.filter fun x => σ i x ∉ A).card :=
      SoficGroups.KunThomFiberCoarea.card_entering_eq_card_exiting
        (σ i) A

theorem boundary_expansion_of_half
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (h : ℝ)
    (hhalf : ∀ A : Finset V,
      2 * A.card ≤ Fintype.card V →
        h * (A.card : ℝ) ≤ (SoficGroups.boundary σ A : ℝ)) :
    ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ) := by
  classical
  intro A
  by_cases hA : 2 * A.card ≤ Fintype.card V
  · have hAreal :
        (2 : ℝ) * A.card ≤ (Fintype.card V : ℝ) := by
      exact_mod_cast hA
    rw [min_eq_left (by linarith)]
    exact hhalf A hA
  · let C : Finset V := Finset.univ \ A
    have hcard : C.card + A.card = Fintype.card V := by
      dsimp [C]
      simpa using
        (Finset.card_sdiff_add_card_eq_card (Finset.subset_univ A))
    have hChalf : 2 * C.card ≤ Fintype.card V := by
      omega
    have hC := hhalf C hChalf
    have hAreal :
        (Fintype.card V : ℝ) < (2 : ℝ) * A.card := by
      exact_mod_cast Nat.lt_of_not_ge hA
    have hCreal :
        (C.card : ℝ) = (Fintype.card V : ℝ) - A.card := by
      have hcardReal :
          (C.card : ℝ) + A.card = (Fintype.card V : ℝ) := by
        exact_mod_cast hcard
      linarith
    rw [min_eq_right (by linarith)]
    rw [hCreal] at hC
    simpa [C, boundary_complement] using hC

theorem inducedBoundary_le_completed_boundary
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (B Z : Finset V)
    (hZ : Z = Finset.univ \ B)
    (τ : ι → Equiv.Perm {x : V // x ∈ Z})
    (hτ : ∀ i (x : V) (hx : x ∈ Z) (_hy : σ i x ∈ Z),
      ((τ i ⟨x, hx⟩ : {x : V // x ∈ Z}) : V) = σ i x)
    (A : Finset {x : V // x ∈ Z}) :
    SoficGroups.inducedBoundary σ B
        (A.map (Function.Embedding.subtype (fun x : V => x ∈ Z))) ≤
      SoficGroups.boundary τ A := by
  classical
  let E : Finset V :=
    A.map (Function.Embedding.subtype (fun x : V => x ∈ Z))
  have hmemZ (x : V) : x ∈ Z ↔ x ∉ B := by
    rw [hZ]
    simp
  change
    (∑ i : ι,
      (E.filter fun x => σ i x ∉ B ∧ σ i x ∉ E).card) ≤
      ∑ i : ι, (A.filter fun x => τ i x ∉ A).card
  apply Finset.sum_le_sum
  intro i _
  have hsub :
      (E.filter fun x => σ i x ∉ B ∧ σ i x ∉ E) ⊆
        (A.filter fun x => τ i x ∉ A).map
          (Function.Embedding.subtype (fun x : V => x ∈ Z)) := by
    intro x hx
    obtain ⟨hxE, hxB, hxout⟩ := Finset.mem_filter.mp hx
    obtain ⟨z, hzA, rfl⟩ := Finset.mem_map.mp hxE
    have himage : σ i (z : V) ∈ Z :=
      (hmemZ (σ i (z : V))).2 hxB
    have hnot : τ i z ∉ A := by
      intro hmem
      apply hxout
      exact Finset.mem_map.mpr
        ⟨τ i z, hmem, hτ i (z : V) z.property himage⟩
    exact Finset.mem_map.mpr
      ⟨z, Finset.mem_filter.mpr ⟨hzA, hnot⟩, rfl⟩
  calc
    (E.filter fun x => σ i x ∉ B ∧ σ i x ∉ E).card ≤
        ((A.filter fun x => τ i x ∉ A).map
          (Function.Embedding.subtype (fun x : V => x ∈ Z))).card :=
      Finset.card_le_card hsub
    _ = (A.filter fun x => τ i x ∉ A).card :=
      Finset.card_map _

theorem exists_completed_pruned_expander
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (γ ell a : ℝ)
    (hgap : ell < γ)
    (hadd : ∀ A : Finset V,
      γ * min (A.card : ℝ)
          ((Fintype.card V : ℝ) - (A.card : ℝ)) -
        a * (Fintype.card V : ℝ) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hsmall :
      2 * a * (2 * (γ - ell) + (Fintype.card ι : ℝ)) ≤
        (γ - ell) ^ 2) :
    ∃ (B : Finset V)
      (τ : ι → Equiv.Perm
        {x : V // x ∈ (Finset.univ \ B)}),
      2 * B.card ≤ Fintype.card V ∧
      (B.card : ℝ) ≤
        a * (Fintype.card V : ℝ) / (γ - ell) ∧
      (∀ i (x : V) (hx : x ∈ Finset.univ \ B)
        (_hy : σ i x ∈ Finset.univ \ B),
        ((τ i ⟨x, hx⟩ :
          {x : V // x ∈ Finset.univ \ B}) : V) = σ i x) ∧
      ∀ A : Finset {x : V // x ∈ Finset.univ \ B},
        ell * min (A.card : ℝ)
          ((Fintype.card {x : V // x ∈ Finset.univ \ B} : ℝ) -
            A.card) ≤ (SoficGroups.boundary τ A : ℝ) := by
  classical
  obtain ⟨B, hBhalf, hBsize, hprune⟩ :=
    SoficGroups.exists_pruned_expander σ γ ell a hgap hadd hsmall
  let Z : Finset V := Finset.univ \ B
  have hZ : Z = Finset.univ \ B := rfl
  choose τ hτ using
    (fun i : ι =>
      SoficGroups.exists_completion_of_internal_permutation
        (σ i) Z)
  have hcardZ :
      Fintype.card {x : V // x ∈ Z} =
        Fintype.card V - B.card := by
    rw [Fintype.card_coe]
    dsimp [Z]
    exact Finset.card_sdiff_of_subset (Finset.subset_univ B)
  have hexp :
      ∀ A : Finset {x : V // x ∈ Z},
        ell * min (A.card : ℝ)
          ((Fintype.card {x : V // x ∈ Z} : ℝ) - A.card) ≤
            (SoficGroups.boundary τ A : ℝ) := by
    apply boundary_expansion_of_half τ ell
    intro A hA
    let E : Finset V :=
      A.map (Function.Embedding.subtype (fun x : V => x ∈ Z))
    have hEcard : E.card = A.card := by
      dsimp [E]
      exact Finset.card_map _
    have hdisj : Disjoint B E := by
      apply Finset.disjoint_left.mpr
      intro x hxB hxE
      have hxZ : x ∈ Z :=
        Finset.property_of_mem_map_subtype A hxE
      rw [hZ] at hxZ
      exact (Finset.mem_sdiff.mp hxZ).2 hxB
    have hhalf : 2 * E.card ≤ Fintype.card V - B.card := by
      rw [hEcard, ← hcardZ]
      exact hA
    have hcut := hprune E hdisj hhalf
    have hbound :
        (SoficGroups.inducedBoundary σ B E : ℝ) ≤
          (SoficGroups.boundary τ A : ℝ) := by
      exact_mod_cast
        inducedBoundary_le_completed_boundary σ B Z hZ τ hτ A
    rw [hEcard] at hcut
    exact hcut.trans hbound
  refine ⟨B, τ, hBhalf, hBsize, ?_, ?_⟩
  · simpa only [Z] using hτ
  · intro A
    have hA := hexp A
    simpa only [Fintype.card_coe] using hA

end KunCompletedPrunedComponent

namespace MatchedComponentCompletion

open scoped BigOperators

noncomputable def completedRestriction {V : Type*} [Fintype V]
    (p : Equiv.Perm V) (Z : Finset V) :
    Equiv.Perm (↥Z) :=
  Classical.choose (SoficGroups.exists_completion_of_internal_permutation p Z)

theorem completedRestriction_apply_of_mem
    {V : Type*} [Fintype V]
    (p : Equiv.Perm V) (Z : Finset V)
    (x : V) (hx : x ∈ Z) (hp : p x ∈ Z) :
    ((completedRestriction p Z ⟨x, hx⟩ : {x : V // x ∈ Z}) : V) = p x :=
  (Classical.choose_spec
    (SoficGroups.exists_completion_of_internal_permutation p Z)) x hx hp

@[simp] theorem completedRestriction_one
    {V : Type*} [Fintype V] (Z : Finset V) :
    completedRestriction (1 : Equiv.Perm V) Z = 1 := by
  ext x
  simpa using completedRestriction_apply_of_mem
    (1 : Equiv.Perm V) Z x x.property x.property

def subtypeBad {V : Type*} [DecidableEq V]
    (Z E : Finset V) : Finset (↥Z) :=
  Finset.univ.filter (fun x => (x : V) ∈ E)

@[simp] theorem mem_subtypeBad
    {V : Type*} [DecidableEq V]
    (Z E : Finset V) (x : {x : V // x ∈ Z}) :
    x ∈ subtypeBad Z E ↔ (x : V) ∈ E := by
  simp [subtypeBad]

theorem card_subtypeBad
    {V : Type*} [DecidableEq V]
    (Z E : Finset V) :
    (subtypeBad Z E).card = (Z ∩ E).card := by
  classical
  have hmap :
      (subtypeBad Z E).map
        (Function.Embedding.subtype (fun x : V => x ∈ Z)) = Z ∩ E := by
    ext x
    simp [subtypeBad, and_comm]
  simpa using congrArg Finset.card hmap

theorem permutationDistance_le_subtypeBad
    {V : Type*} [DecidableEq V]
    (Z E : Finset V)
    (p q : Equiv.Perm {x : V // x ∈ Z})
    (hagrees : ∀ x : {x : V // x ∈ Z},
      (x : V) ∉ E → p x = q x) :
    SoficGroups.permutationDistance p q ≤ (subtypeBad Z E).card := by
  unfold SoficGroups.permutationDistance hammingDist
  apply Finset.card_le_card
  intro x hx
  have hneq : p x ≠ q x := (Finset.mem_filter.mp hx).2
  apply (mem_subtypeBad Z E x).2
  by_contra hnot
  exact hneq (hagrees x hnot)

theorem card_lt_five_mul_permutationDistance_of_subtypeBad
    {V : Type*} [DecidableEq V]
    (Z E : Finset V) (hZ : Z.Nonempty)
    (p q : Equiv.Perm {x : V // x ∈ Z})
    (hbad : 5 * (subtypeBad Z E).card ≤ Fintype.card {x : V // x ∈ Z})
    (hseparated : ∀ x : {x : V // x ∈ Z},
      (x : V) ∉ E → p x ≠ q x) :
    Fintype.card {x : V // x ∈ Z} <
      5 * SoficGroups.permutationDistance p q := by
  have hagree :
      (SoficGroups.agreementSet p q).card ≤ (subtypeBad Z E).card := by
    apply Finset.card_le_card
    intro x hx
    have heq : p x = q x := (Finset.mem_filter.mp hx).2
    apply (mem_subtypeBad Z E x).2
    by_contra hnot
    exact hseparated x hnot heq
  have hpartition := SoficGroups.agreementSet_card_add_hammingDist p q
  change
    (SoficGroups.agreementSet p q).card +
        SoficGroups.permutationDistance p q =
      Fintype.card {x : V // x ∈ Z} at hpartition
  have hpositive : 0 < Fintype.card {x : V // x ∈ Z} := by
    simpa only [Fintype.card_coe] using hZ.card_pos
  omega

noncomputable def sourceCompletionBad
    {V ι J : Type*} [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V) : Finset V := by
  classical
  let T := SoficGroups.CompressionCriterion.productTrackedTable F
  exact
    (Finset.univ.biUnion fun i : ι =>
      Z.filter fun z => σ i z ∉ Z) ∪
    (T.biUnion fun j =>
      Z.filter fun z => p j z ∉ Z) ∪
    (Finset.univ.biUnion fun i : ι =>
      T.biUnion fun j =>
        Z.filter fun z => p j (σ i z) ≠ σ i (p j z)) ∪
    (Finset.univ.biUnion fun i : ι =>
      T.biUnion fun j =>
        Z.filter fun z => p j (σ i z) ∉ Z) ∪
    (F.biUnion fun j =>
      F.biUnion fun k =>
        Z.filter fun z => p (j * k) z ≠ p j (p k z)) ∪
    (F.biUnion fun j =>
      F.biUnion fun k =>
        Z.filter fun z => j ≠ k ∧ p j z = p k z)

theorem sourceCompletionBad_subset
    {V ι J : Type*} [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V) :
    sourceCompletionBad σ p F Z ⊆ Z := by
  classical
  intro x hx
  simp [sourceCompletionBad] at hx
  aesop

theorem card_subtype_sourceCompletionBad
    {V ι J : Type*} [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V) :
    (subtypeBad Z (sourceCompletionBad σ p F Z)).card =
      (sourceCompletionBad σ p F Z).card := by
  rw [card_subtypeBad, Finset.inter_eq_right.mpr]
  exact sourceCompletionBad_subset σ p F Z

theorem sourceCompletionBad_good
    {V ι J : Type*} [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V)
    (x : V) (hx : x ∈ Z)
    (hgood : x ∉ sourceCompletionBad σ p F Z) :
    (∀ i, σ i x ∈ Z) ∧
    (∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
      p j x ∈ Z) ∧
    (∀ i, ∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
      p j (σ i x) = σ i (p j x)) ∧
    (∀ i, ∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
      p j (σ i x) ∈ Z) ∧
    (∀ j ∈ F, ∀ k ∈ F,
      p (j * k) x = p j (p k x)) ∧
    (∀ j ∈ F, ∀ k ∈ F, j ≠ k → p j x ≠ p k x) := by
  classical
  simp [sourceCompletionBad, hx] at hgood
  aesop

theorem completedRestriction_mul_of_not_mem_sourceCompletionBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V)
    {j k : J} (hj : j ∈ F) (hk : k ∈ F)
    (z : {x : V // x ∈ Z})
    (hz : (z : V) ∉ sourceCompletionBad σ p F Z) :
    completedRestriction (p (j * k)) Z z =
      (completedRestriction (p j) Z * completedRestriction (p k) Z) z := by
  have hg := sourceCompletionBad_good σ p F Z z z.property hz
  have hjT :=
    SoficGroups.CompressionCriterion.mem_productTrackedTable hj
  have hkT :=
    SoficGroups.CompressionCriterion.mem_productTrackedTable hk
  have hjkT :=
    SoficGroups.CompressionCriterion.mul_mem_productTrackedTable hj hk
  have hkZ : p k (z : V) ∈ Z := hg.2.1 k hkT
  have hjkZ : p (j * k) (z : V) ∈ Z := hg.2.1 (j * k) hjkT
  have hmul : p (j * k) (z : V) = p j (p k (z : V)) :=
    hg.2.2.2.2.1 j hj k hk
  have hinner : p j (p k (z : V)) ∈ Z := by
    rw [← hmul]
    exact hjkZ
  have hkvalue :
      ((completedRestriction (p k) Z z : {x : V // x ∈ Z}) : V) =
        p k (z : V) :=
    completedRestriction_apply_of_mem (p k) Z z z.property hkZ
  apply Subtype.ext
  change
    ((completedRestriction (p (j * k)) Z z : {x : V // x ∈ Z}) : V) =
      ((completedRestriction (p j) Z
        (completedRestriction (p k) Z z) : {x : V // x ∈ Z}) : V)
  calc
    ((completedRestriction (p (j * k)) Z z : {x : V // x ∈ Z}) : V) =
        p (j * k) (z : V) :=
      completedRestriction_apply_of_mem (p (j * k)) Z z z.property hjkZ
    _ = p j (p k (z : V)) := hmul
    _ = p j
        ((completedRestriction (p k) Z z : {x : V // x ∈ Z}) : V) := by
      rw [hkvalue]
    _ = ((completedRestriction (p j) Z
        (completedRestriction (p k) Z z) : {x : V // x ∈ Z}) : V) := by
      symm
      apply completedRestriction_apply_of_mem
      change
        p j ((completedRestriction (p k) Z z :
          {x : V // x ∈ Z}) : V) ∈ Z
      rw [hkvalue]
      exact hinner

theorem completedRestriction_ne_of_not_mem_sourceCompletionBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V)
    {j k : J} (hj : j ∈ F) (hk : k ∈ F) (hne : j ≠ k)
    (z : {x : V // x ∈ Z})
    (hz : (z : V) ∉ sourceCompletionBad σ p F Z) :
    completedRestriction (p j) Z z ≠ completedRestriction (p k) Z z := by
  have hg := sourceCompletionBad_good σ p F Z z z.property hz
  have hjT :=
    SoficGroups.CompressionCriterion.mem_productTrackedTable hj
  have hkT :=
    SoficGroups.CompressionCriterion.mem_productTrackedTable hk
  have hjZ : p j (z : V) ∈ Z := hg.2.1 j hjT
  have hkZ : p k (z : V) ∈ Z := hg.2.1 k hkT
  intro heq
  apply hg.2.2.2.2.2 j hj k hk hne
  have hval := congrArg
    (fun x : {x : V // x ∈ Z} => (x : V)) heq
  rwa [completedRestriction_apply_of_mem (p j) Z z z.property hjZ,
    completedRestriction_apply_of_mem (p k) Z z z.property hkZ] at hval

theorem completedRestriction_commute_of_not_mem_sourceCompletionBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V)
    (σZ : ι → Equiv.Perm {x : V // x ∈ Z})
    (hσZ : ∀ i (x : V) (hx : x ∈ Z) (_hi : σ i x ∈ Z),
      ((σZ i ⟨x, hx⟩ : {x : V // x ∈ Z}) : V) = σ i x)
    {j : J}
    (hj : j ∈ SoficGroups.CompressionCriterion.productTrackedTable F)
    (i : ι) (z : {x : V // x ∈ Z})
    (hz : (z : V) ∉ sourceCompletionBad σ p F Z) :
    completedRestriction (p j) Z (σZ i z) =
      σZ i (completedRestriction (p j) Z z) := by
  have hg := sourceCompletionBad_good σ p F Z z z.property hz
  have hσmem : σ i (z : V) ∈ Z := hg.1 i
  have hjmem : p j (z : V) ∈ Z := hg.2.1 j hj
  have hcomm : p j (σ i (z : V)) = σ i (p j (z : V)) :=
    hg.2.2.1 i j hj
  have hcomposite : p j (σ i (z : V)) ∈ Z :=
    hg.2.2.2.1 i j hj
  have hσvalue :
      ((σZ i z : {x : V // x ∈ Z}) : V) = σ i (z : V) :=
    hσZ i z z.property hσmem
  have hjvalue :
      ((completedRestriction (p j) Z z : {x : V // x ∈ Z}) : V) =
        p j (z : V) :=
    completedRestriction_apply_of_mem (p j) Z z z.property hjmem
  have hleftmem : p j ((σZ i z : {x : V // x ∈ Z}) : V) ∈ Z := by
    rw [hσvalue]
    exact hcomposite
  have hrightmem :
      σ i
        ((completedRestriction (p j) Z z : {x : V // x ∈ Z}) : V) ∈ Z := by
    rw [hjvalue, ← hcomm]
    exact hcomposite
  apply Subtype.ext
  calc
    ((completedRestriction (p j) Z (σZ i z) :
        {x : V // x ∈ Z}) : V) =
        p j ((σZ i z : {x : V // x ∈ Z}) : V) :=
      completedRestriction_apply_of_mem
        (p j) Z (σZ i z) (σZ i z).property hleftmem
    _ = p j (σ i (z : V)) := congrArg (p j) hσvalue
    _ = σ i (p j (z : V)) := hcomm
    _ = σ i
        ((completedRestriction (p j) Z z : {x : V // x ∈ Z}) : V) :=
      congrArg (σ i) hjvalue.symm
    _ = ((σZ i (completedRestriction (p j) Z z) :
        {x : V // x ∈ Z}) : V) :=
      (hσZ i (completedRestriction (p j) Z z)
        (completedRestriction (p j) Z z).property hrightmem).symm

theorem completedRestriction_mul_distance_le_sourceCompletionBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V)
    {j k : J} (hj : j ∈ F) (hk : k ∈ F) :
    SoficGroups.permutationDistance
      (completedRestriction (p (j * k)) Z)
      (completedRestriction (p j) Z * completedRestriction (p k) Z) ≤
        (sourceCompletionBad σ p F Z).card := by
  calc
    SoficGroups.permutationDistance
      (completedRestriction (p (j * k)) Z)
      (completedRestriction (p j) Z * completedRestriction (p k) Z) ≤
        (subtypeBad Z (sourceCompletionBad σ p F Z)).card := by
          apply permutationDistance_le_subtypeBad
          intro z hz
          exact completedRestriction_mul_of_not_mem_sourceCompletionBad
            σ p F Z hj hk z hz
    _ = (sourceCompletionBad σ p F Z).card :=
      card_subtype_sourceCompletionBad σ p F Z

theorem completedRestriction_separated_of_sourceCompletionBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V) (hZ : Z.Nonempty)
    (hbad : 5 * (sourceCompletionBad σ p F Z).card ≤ Z.card)
    {j k : J} (hj : j ∈ F) (hk : k ∈ F) (hne : j ≠ k) :
    Fintype.card {x : V // x ∈ Z} <
      5 * SoficGroups.permutationDistance
        (completedRestriction (p j) Z) (completedRestriction (p k) Z) := by
  apply card_lt_five_mul_permutationDistance_of_subtypeBad
    Z (sourceCompletionBad σ p F Z) hZ
  · simpa only [card_subtype_sourceCompletionBad, Fintype.card_coe]
      using hbad
  · intro z hz
    exact completedRestriction_ne_of_not_mem_sourceCompletionBad
      σ p F Z hj hk hne z hz

theorem completedRestriction_commutationDefect_le_sourceCompletionBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V)
    (σZ : ι → Equiv.Perm {x : V // x ∈ Z})
    (hσZ : ∀ i (x : V) (hx : x ∈ Z) (_hi : σ i x ∈ Z),
      ((σZ i ⟨x, hx⟩ : {x : V // x ∈ Z}) : V) = σ i x)
    {j : J}
    (hj : j ∈ SoficGroups.CompressionCriterion.productTrackedTable F) :
    SoficGroups.permutationCommutationDefect
        σZ (completedRestriction (p j) Z) ≤
      Fintype.card ι * (sourceCompletionBad σ p F Z).card := by
  classical
  unfold SoficGroups.permutationCommutationDefect
  calc
    (∑ i : ι,
      (Finset.univ.filter fun x : {x : V // x ∈ Z} =>
        completedRestriction (p j) Z (σZ i x) ≠
          σZ i (completedRestriction (p j) Z x)).card) ≤
        ∑ _i : ι, (subtypeBad Z (sourceCompletionBad σ p F Z)).card := by
          apply Finset.sum_le_sum
          intro i _
          apply Finset.card_le_card
          intro x hx
          apply (mem_subtypeBad Z (sourceCompletionBad σ p F Z) x).2
          by_contra hnot
          exact (Finset.mem_filter.mp hx).2
            (completedRestriction_commute_of_not_mem_sourceCompletionBad
              σ p F Z σZ hσZ hj i x hnot)
    _ = Fintype.card ι * (sourceCompletionBad σ p F Z).card := by
      simp [card_subtype_sourceCompletionBad]

end MatchedComponentCompletion

namespace MatchedComponentExitBudget

open Filter Topology
open scoped BigOperators

theorem card_permutation_exit_le_deleted
    {V : Type*} [Fintype V] [DecidableEq V]
    (p : Equiv.Perm V) (Z : Finset V) :
    (Z.filter fun x => p x ∉ Z).card ≤
      (Finset.univ \ Z).card := by
  apply Finset.card_le_card_of_injOn p
  · intro x hx
    exact Finset.mem_sdiff.mpr
      ⟨Finset.mem_univ _, (Finset.mem_filter.mp hx).2⟩
  · exact p.injective.injOn

theorem card_composite_exit_le_deleted
    {V : Type*} [Fintype V] [DecidableEq V]
    (p q : Equiv.Perm V) (Z : Finset V) :
    (Z.filter fun x => p (q x) ∉ Z).card ≤
      (Finset.univ \ Z).card := by
  apply Finset.card_le_card_of_injOn (p * q)
  · intro x hx
    apply Finset.mem_sdiff.mpr
    refine ⟨Finset.mem_univ _, ?_⟩
    simpa [Equiv.Perm.mul_apply] using (Finset.mem_filter.mp hx).2
  · exact (p * q).injective.injOn

theorem card_biUnion_permutation_exit_le
    {V ι : Type*} [Fintype V] [DecidableEq V]
    (I : Finset ι) (p : ι → Equiv.Perm V) (Z : Finset V) :
    (I.biUnion fun i => Z.filter fun x => p i x ∉ Z).card ≤
      I.card * (Finset.univ \ Z).card := by
  classical
  calc
    (I.biUnion fun i => Z.filter fun x => p i x ∉ Z).card ≤
        ∑ i ∈ I, (Z.filter fun x => p i x ∉ Z).card :=
      Finset.card_biUnion_le
    _ ≤ ∑ _i ∈ I, (Finset.univ \ Z).card := by
      apply Finset.sum_le_sum
      intro i _
      exact card_permutation_exit_le_deleted (p i) Z
    _ = I.card * (Finset.univ \ Z).card := by simp

theorem card_biUnion_composite_exit_le
    {V ι κ : Type*} [Fintype V] [DecidableEq V]
    (I : Finset ι) (K : Finset κ)
    (p : ι → Equiv.Perm V) (q : κ → Equiv.Perm V)
    (Z : Finset V) :
    (I.biUnion fun i =>
      K.biUnion fun k => Z.filter fun x => q k (p i x) ∉ Z).card ≤
        I.card * K.card * (Finset.univ \ Z).card := by
  classical
  calc
    (I.biUnion fun i =>
      K.biUnion fun k => Z.filter fun x => q k (p i x) ∉ Z).card ≤
        ∑ i ∈ I,
          (K.biUnion fun k => Z.filter fun x => q k (p i x) ∉ Z).card :=
      Finset.card_biUnion_le
    _ ≤ ∑ _i ∈ I, K.card * (Finset.univ \ Z).card := by
      apply Finset.sum_le_sum
      intro i _
      calc
        (K.biUnion fun k =>
          Z.filter fun x => q k (p i x) ∉ Z).card ≤
            ∑ k ∈ K, (Z.filter fun x => q k (p i x) ∉ Z).card :=
          Finset.card_biUnion_le
        _ ≤ ∑ _k ∈ K, (Finset.univ \ Z).card := by
          apply Finset.sum_le_sum
          intro k _
          exact card_composite_exit_le_deleted (q k) (p i) Z
        _ = K.card * (Finset.univ \ Z).card := by simp
    _ = I.card * K.card * (Finset.univ \ Z).card := by
      simp [Nat.mul_assoc]

noncomputable def sourceWordTestBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) : Finset V := by
  classical
  let T := SoficGroups.CompressionCriterion.productTrackedTable F
  exact
    (Finset.univ.biUnion fun i : ι =>
      T.biUnion fun j =>
        Finset.univ.filter fun z => p j (σ i z) ≠ σ i (p j z)) ∪
    (F.biUnion fun j =>
      F.biUnion fun k =>
        Finset.univ.filter fun z => p (j * k) z ≠ p j (p k z)) ∪
    (F.biUnion fun j =>
      F.biUnion fun k =>
        Finset.univ.filter fun z => j ≠ k ∧ p j z = p k z)

theorem sourceCompletionBad_subset_exit_union_wordBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V) :
    SoficGroups.MatchedComponentCompletion.sourceCompletionBad σ p F Z ⊆
      (Finset.univ.biUnion fun i : ι =>
        Z.filter fun z => σ i z ∉ Z) ∪
      ((SoficGroups.CompressionCriterion.productTrackedTable F).biUnion
        fun j => Z.filter fun z => p j z ∉ Z) ∪
      (Finset.univ.biUnion fun i : ι =>
        (SoficGroups.CompressionCriterion.productTrackedTable F).biUnion
          fun j => Z.filter fun z => p j (σ i z) ∉ Z) ∪
      sourceWordTestBad σ p F := by
  classical
  intro x hx
  simp [SoficGroups.MatchedComponentCompletion.sourceCompletionBad,
    sourceWordTestBad] at hx ⊢
  rcases hx with hgen | hfactor | hcomm | hcomposite | hmul | hsep
  · obtain ⟨hxZ, i, hi⟩ := hgen
    exact Or.inl ⟨hxZ, i, hi⟩
  · obtain ⟨j, hj, hxZ, hexit⟩ := hfactor
    exact Or.inr (Or.inl ⟨j, hj, hxZ, hexit⟩)
  · obtain ⟨i, j, hj, _, hfailure⟩ := hcomm
    exact Or.inr (Or.inr (Or.inr (Or.inl ⟨i, j, hj, hfailure⟩)))
  · obtain ⟨i, j, hj, hxZ, hfailure⟩ := hcomposite
    exact Or.inr (Or.inr (Or.inl ⟨i, j, hj, hxZ, hfailure⟩))
  · obtain ⟨j, hj, k, hk, _, hfailure⟩ := hmul
    exact Or.inr (Or.inr (Or.inr (Or.inr
      (Or.inl ⟨j, hj, k, hk, hfailure⟩))))
  · obtain ⟨j, hj, k, hk, _, hne, hfailure⟩ := hsep
    exact Or.inr (Or.inr (Or.inr (Or.inr
      (Or.inr ⟨j, hj, k, hk, hne, hfailure⟩))))

theorem card_sourceCompletionBad_le_deleted_add_wordBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V) :
    (SoficGroups.MatchedComponentCompletion.sourceCompletionBad
      σ p F Z).card ≤
        (Fintype.card ι +
          (SoficGroups.CompressionCriterion.productTrackedTable F).card +
          Fintype.card ι *
            (SoficGroups.CompressionCriterion.productTrackedTable F).card) *
          (Finset.univ \ Z).card +
        (sourceWordTestBad σ p F).card := by
  classical
  let I : Finset ι := Finset.univ
  let T : Finset J :=
    SoficGroups.CompressionCriterion.productTrackedTable F
  let A : Finset V :=
    I.biUnion fun i => Z.filter fun z => σ i z ∉ Z
  let D : Finset V :=
    T.biUnion fun j => Z.filter fun z => p j z ∉ Z
  let C : Finset V :=
    I.biUnion fun i =>
      T.biUnion fun j => Z.filter fun z => p j (σ i z) ∉ Z
  let W : Finset V := sourceWordTestBad σ p F
  let deleted : Finset V := Finset.univ \ Z
  have hA : A.card ≤ Fintype.card ι * deleted.card := by
    simpa [A, I, deleted] using
      card_biUnion_permutation_exit_le
        (Finset.univ : Finset ι) σ Z
  have hD : D.card ≤ T.card * deleted.card := by
    simpa [D, deleted] using
      card_biUnion_permutation_exit_le T p Z
  have hC : C.card ≤ Fintype.card ι * T.card * deleted.card := by
    simpa [C, I, deleted] using
      card_biUnion_composite_exit_le
        (Finset.univ : Finset ι) T σ p Z
  have hsubset :
      SoficGroups.MatchedComponentCompletion.sourceCompletionBad
          σ p F Z ⊆ A ∪ D ∪ C ∪ W := by
    simpa [A, D, C, I, T, W] using
      sourceCompletionBad_subset_exit_union_wordBad σ p F Z
  have hunion :
      (A ∪ D ∪ C ∪ W).card ≤ A.card + D.card + C.card + W.card := by
    have hAD := Finset.card_union_le A D
    have hADC := Finset.card_union_le (A ∪ D) C
    have hADCW := Finset.card_union_le (A ∪ D ∪ C) W
    omega
  calc
    (SoficGroups.MatchedComponentCompletion.sourceCompletionBad
        σ p F Z).card ≤ (A ∪ D ∪ C ∪ W).card :=
      Finset.card_le_card hsubset
    _ ≤ A.card + D.card + C.card + W.card := hunion
    _ ≤ Fintype.card ι * deleted.card +
        T.card * deleted.card +
        Fintype.card ι * T.card * deleted.card + W.card := by
      omega
    _ = (Fintype.card ι +
          (SoficGroups.CompressionCriterion.productTrackedTable F).card +
          Fintype.card ι *
            (SoficGroups.CompressionCriterion.productTrackedTable F).card) *
          (Finset.univ \ Z).card +
        (sourceWordTestBad σ p F).card := by
      dsimp [T, deleted, W]
      ring

theorem sourceCompletionBad_subset_survivors
    {V ι J : Type*} [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (Z : Finset V) :
    SoficGroups.MatchedComponentCompletion.sourceCompletionBad
      σ p F Z ⊆ Z := by
  classical
  intro x hx
  simp [SoficGroups.MatchedComponentCompletion.sourceCompletionBad] at hx
  aesop

theorem sourceCompletionBad_original_density_tendsto_zero
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    {ι J : Type*} [Fintype ι] [Group J]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (p : (n : ℕ) → J → Equiv.Perm (V n))
    (F : Finset J)
    (B : (n : ℕ) → Finset (V n))
    (hdeleted : Tendsto
      (fun n => ((B n).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0))
    (hword : Tendsto
      (fun n =>
        ((sourceWordTestBad (σ n) (p n) F).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((SoficGroups.MatchedComponentCompletion.sourceCompletionBad
          (σ n) (p n) F (Finset.univ \ B n)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0) := by
  let c : ℝ :=
    (Fintype.card ι +
      (SoficGroups.CompressionCriterion.productTrackedTable F).card +
      Fintype.card ι *
        (SoficGroups.CompressionCriterion.productTrackedTable F).card : ℕ)
  have hupper (n : ℕ) :
      ((SoficGroups.MatchedComponentCompletion.sourceCompletionBad
        (σ n) (p n) F (Finset.univ \ B n)).card : ℝ) /
          Fintype.card (V n) ≤
        c * (((B n).card : ℝ) / Fintype.card (V n)) +
          ((sourceWordTestBad (σ n) (p n) F).card : ℝ) /
            Fintype.card (V n) := by
    have hfinite := card_sourceCompletionBad_le_deleted_add_wordBad
      (σ n) (p n) F (Finset.univ \ B n)
    have hdeleted_eq :
        (Finset.univ \ (Finset.univ \ B n) : Finset (V n)) = B n := by
      ext x
      simp
    rw [hdeleted_eq] at hfinite
    have hreal :
        ((SoficGroups.MatchedComponentCompletion.sourceCompletionBad
          (σ n) (p n) F (Finset.univ \ B n)).card : ℝ) ≤
            c * ((B n).card : ℝ) +
              (sourceWordTestBad (σ n) (p n) F).card := by
      dsimp [c]
      exact_mod_cast hfinite
    calc
      ((SoficGroups.MatchedComponentCompletion.sourceCompletionBad
        (σ n) (p n) F (Finset.univ \ B n)).card : ℝ) /
          Fintype.card (V n) ≤
          (c * ((B n).card : ℝ) +
            (sourceWordTestBad (σ n) (p n) F).card) /
              Fintype.card (V n) :=
            div_le_div_of_nonneg_right hreal (by positivity)
      _ = c * (((B n).card : ℝ) / Fintype.card (V n)) +
          ((sourceWordTestBad (σ n) (p n) F).card : ℝ) /
            Fintype.card (V n) := by
          ring
  have hlimit : Tendsto
      (fun n =>
        c * (((B n).card : ℝ) / Fintype.card (V n)) +
          ((sourceWordTestBad (σ n) (p n) F).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0) := by
    simpa using (hdeleted.const_mul c).add hword
  exact squeeze_zero'
    (Filter.Eventually.of_forall fun n => by positivity)
    (Filter.Eventually.of_forall hupper)
    hlimit

theorem sourceCompletionBad_surviving_density_tendsto_zero
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    {ι J : Type*} [Fintype ι] [Group J]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (p : (n : ℕ) → J → Equiv.Perm (V n))
    (F : Finset J)
    (B : (n : ℕ) → Finset (V n))
    (hZ : ∀ n, (Finset.univ \ B n : Finset (V n)).Nonempty)
    (hdeleted : Tendsto
      (fun n => ((B n).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0))
    (hword : Tendsto
      (fun n =>
        ((sourceWordTestBad (σ n) (p n) F).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((SoficGroups.MatchedComponentCompletion.sourceCompletionBad
          (σ n) (p n) F (Finset.univ \ B n)).card : ℝ) /
            (Finset.univ \ B n : Finset (V n)).card)
      atTop (nhds 0) := by
  let U : (n : ℕ) → Finset (V n) := fun _ => Finset.univ
  let Z : (n : ℕ) → Finset (V n) := fun n => Finset.univ \ B n
  let E : (n : ℕ) → Finset (V n) := fun n =>
    SoficGroups.MatchedComponentCompletion.sourceCompletionBad
      (σ n) (p n) F (Z n)
  have hU (n : ℕ) : (U n).Nonempty := by
    obtain ⟨x, _⟩ := hZ n
    exact ⟨x, Finset.mem_univ _⟩
  have hcover : Tendsto
      (fun n => ((Z n).card : ℝ) / (U n).card)
      atTop (nhds 1) := by
    have hbase : Tendsto
        (fun n => (1 : ℝ) -
          ((B n).card : ℝ) / Fintype.card (V n))
        atTop (nhds 1) := by
      simpa using tendsto_const_nhds.sub hdeleted
    convert hbase using 1
    funext n
    have hcard : Fintype.card (V n) ≠ 0 := by
      exact Finset.card_ne_zero.mpr (hU n)
    dsimp [U, Z]
    rw [Finset.card_sdiff_of_subset (Finset.subset_univ (B n)),
      Finset.card_univ, Nat.cast_sub (Finset.card_le_univ (B n))]
    field_simp
  have hglobal : Tendsto
      (fun n => (((U n ∩ E n).card : ℝ) / (U n).card))
      atTop (nhds 0) := by
    simpa [U, Z, E] using
      sourceCompletionBad_original_density_tendsto_zero
        V σ p F B hdeleted hword
  have hretained := SoficGroups.retained_bad_density_tendsto_zero
    U Z E hU hZ
    (fun n => Finset.subset_univ (Z n)) hcover hglobal
  convert hretained using 1
  funext n
  dsimp [Z, E]
  rw [Finset.inter_eq_right.mpr
    (sourceCompletionBad_subset_survivors
      (σ n) (p n) F (Finset.univ \ B n))]

theorem pruned_component_card_tendsto_atTop
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (B : (n : ℕ) → Finset (V n))
    (hsize : Tendsto (fun n => Fintype.card (V n)) atTop atTop)
    (hdeleted : Tendsto
      (fun n => ((B n).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto (fun n => (Finset.univ \ B n : Finset (V n)).card)
      atTop atTop := by
  have hhalf : ∀ᶠ n in atTop,
      ((B n).card : ℝ) / Fintype.card (V n) < (1 / 2 : ℝ) :=
    hdeleted.eventually
      (gt_mem_nhds (by norm_num : (0 : ℝ) < 1 / 2))
  have hpositive : ∀ᶠ n in atTop, 0 < Fintype.card (V n) := by
    have hevent := (Filter.tendsto_atTop.1 hsize) 1
    filter_upwards [hevent] with n hn
    omega
  have hhalfsize :
      Tendsto (fun n => Fintype.card (V n) / 2) atTop atTop :=
    (Nat.tendsto_div_const_atTop (by norm_num : (2 : ℕ) ≠ 0)).comp hsize
  refine tendsto_atTop_mono' atTop ?_ hhalfsize
  filter_upwards [hhalf, hpositive] with n hn hnpositive
  have hrealpos : (0 : ℝ) < Fintype.card (V n) := by
    exact_mod_cast hnpositive
  have hratio := (div_lt_iff₀ hrealpos).1 hn
  have hbadlt : 2 * (B n).card < Fintype.card (V n) := by
    exact_mod_cast (show
      (2 : ℝ) * (B n).card < Fintype.card (V n) by linarith)
  rw [Finset.card_sdiff_of_subset (Finset.subset_univ (B n)),
    Finset.card_univ]
  omega

end MatchedComponentExitBudget

namespace KunRealComplexMarkovBridge

open scoped BigOperators ComplexOrder InnerProductSpace Topology

def realMarkov {ι V : Type*} [Fintype ι]
    (p : ι → Equiv.Perm V) (f : V → ℝ) (x : V) : ℝ :=
  (∑ i, f ((p i).symm x)) / (Fintype.card ι : ℝ)

def permutationUnitary {V : Type*} [Fintype V] (p : Equiv.Perm V) :
    EuclideanSpace ℂ V ≃ₗᵢ[ℂ] EuclideanSpace ℂ V :=
  LinearIsometryEquiv.piLpCongrLeft 2 ℂ ℂ p

def indicatorVector {V : Type*}
    (f : V → ℝ) : EuclideanSpace ℂ V :=
  WithLp.toLp 2 fun x => (f x : ℂ)

@[simp]
theorem indicatorVector_apply {V : Type*}
    (f : V → ℝ) (x : V) :
    indicatorVector f x = (f x : ℂ) := rfl

def permutationMarkov {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (ξ : EuclideanSpace ℂ V) :
    EuclideanSpace ℂ V :=
  (Fintype.card ι : ℂ)⁻¹ • ∑ i, permutationUnitary (p i) ξ

@[simp]
theorem permutationMarkov_apply {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (ξ : EuclideanSpace ℂ V) (x : V) :
    permutationMarkov p ξ x =
      (∑ i, ξ ((p i).symm x)) / (Fintype.card ι : ℂ) := by
  simp [permutationMarkov, permutationUnitary, div_eq_mul_inv, mul_comm]

theorem indicatorVector_realMarkov
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) :
    indicatorVector (realMarkov p f) =
      permutationMarkov p (indicatorVector f) := by
  ext x
  rw [indicatorVector_apply, permutationMarkov_apply]
  simp only [indicatorVector_apply]
  change (((∑ i, f ((p i).symm x)) /
    (Fintype.card ι : ℝ) : ℝ) : ℂ) =
      (∑ i, (f ((p i).symm x) : ℂ)) / (Fintype.card ι : ℂ)
  norm_cast

theorem indicatorVector_iterate_realMarkov
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) (k : ℕ) :
    indicatorVector (((realMarkov p)^[k]) f) =
      ((permutationMarkov p)^[k]) (indicatorVector f) := by
  induction k with
  | zero => simp
  | succ k ih =>
      rw [Function.iterate_succ_apply', Function.iterate_succ_apply',
        indicatorVector_realMarkov, ih]

theorem norm_indicatorVector_sub_sq
    {V : Type*} [Fintype V] (f g : V → ℝ) :
    ‖indicatorVector f - indicatorVector g‖ ^ 2 =
      ∑ x, (f x - g x) ^ 2 := by
  rw [EuclideanSpace.norm_sq_eq]
  apply Finset.sum_congr rfl
  intro x _
  change ‖(f x : ℂ) - (g x : ℂ)‖ ^ 2 = (f x - g x) ^ 2
  rw [← Complex.ofReal_sub, Complex.norm_real, Real.norm_eq_abs, sq_abs]

theorem norm_permutationMarkov_indicator_sub_sq
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) :
    ‖permutationMarkov p (indicatorVector f) - indicatorVector f‖ ^ 2 =
      ∑ x, (realMarkov p f x - f x) ^ 2 := by
  rw [← indicatorVector_realMarkov, norm_indicatorVector_sub_sq]

theorem norm_iterate_permutationMarkov_indicator_sub_sq
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) (k : ℕ) :
    ‖((permutationMarkov p)^[k]) (indicatorVector f) -
        indicatorVector f‖ ^ 2 =
      ∑ x, ((((realMarkov p)^[k]) f) x - f x) ^ 2 := by
  rw [← indicatorVector_iterate_realMarkov,
    norm_indicatorVector_sub_sq]

theorem norm_iterate_permutationMarkov_indicator_sub_iterate_sq
    {ι V : Type*} [Fintype ι] [Fintype V]
    (p : ι → Equiv.Perm V) (f : V → ℝ) (k : ℕ) :
    ‖((permutationMarkov p)^[k + 1]) (indicatorVector f) -
        ((permutationMarkov p)^[k]) (indicatorVector f)‖ ^ 2 =
      ∑ x, ((((realMarkov p)^[k + 1]) f) x -
        (((realMarkov p)^[k]) f) x) ^ 2 := by
  rw [← indicatorVector_iterate_realMarkov,
    ← indicatorVector_iterate_realMarkov,
    norm_indicatorVector_sub_sq]

end KunRealComplexMarkovBridge

namespace KunRootedWordPower

section

open Filter Topology
open SoficGroups.KunRootedIndicatorCrossing
open SoficGroups.KunThomInvariantOrthogonal
open scoped BigOperators ComplexConjugate ComplexOrder InnerProductSpace Pointwise

universe u v

theorem RootedIndicatorMarkovModel.IsRootedAtRadius.mono
    {G ι : Type u} [Group G]
    {X : RootedIndicatorMarkovModel G ι}
    {w : G → List ι} {r R : ℕ}
    (h : X.IsRootedAtRadius w R) (hr : r ≤ R) :
    X.IsRootedAtRadius w r :=
  ⟨fun a g hword => h.out a g (hword.trans hr)⟩

theorem exists_rooted_word_radius_all_markov_iterate_contractions
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, u} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (w : G → List ↥S)
    (k : ℕ) (ε : ℝ) (hε : 0 < ε) :
    ∃ r : ℕ, ∀ X : RootedIndicatorMarkovModel G ↥S,
      X.IsGenerated (fun i : ↥S => (i : G)) w →
      X.IsRootedAtRadius w r →
      ∀ j ≤ k,
        ‖((permutationMarkov X.generator)^[j + 1])
              (indicatorVector X.indicator) -
            ((permutationMarkov X.generator)^[j])
              (indicatorVector X.indicator)‖ ≤
          (kazhdanMarkovContractionFactor P S ^ j + ε) *
            ‖permutationMarkov X.generator
                (indicatorVector X.indicator) -
              indicatorVector X.indicator‖ := by
  classical
  have hexists : ∀ j : ℕ, ∃ r : ℕ,
      ∀ X : RootedIndicatorMarkovModel G ↥S,
        X.IsGenerated (fun i : ↥S => (i : G)) w →
        X.IsRootedAtRadius w r →
        ‖((permutationMarkov X.generator)^[j + 1])
              (indicatorVector X.indicator) -
            ((permutationMarkov X.generator)^[j])
              (indicatorVector X.indicator)‖ ≤
          (kazhdanMarkovContractionFactor P S ^ j + ε) *
            ‖permutationMarkov X.generator
                (indicatorVector X.indicator) -
              indicatorVector X.indicator‖ :=
    fun j => exists_rooted_word_radius_markov_iterate_contraction
      P S honeS hcover hsymmetric w j ε hε
  choose r hr using hexists
  let R := ∑ j ∈ Finset.range (k + 1), r j
  refine ⟨R, ?_⟩
  intro X hgenerated hroot j hj
  have hjmem : j ∈ Finset.range (k + 1) :=
    Finset.mem_range.mpr (Nat.lt_succ_iff.mpr hj)
  have hrj : r j ≤ R := by
    exact Finset.single_le_sum
      (f := r) (fun i _ => Nat.zero_le _) hjmem
  exact hr j X hgenerated (hroot.mono hrj)

theorem norm_iterate_sub_le_sum_successive
    {E : Type*} [NormedAddCommGroup E]
    (F : E → E) (x : E) (k : ℕ) :
    ‖(F^[k]) x - x‖ ≤
      ∑ j ∈ Finset.range k,
        ‖(F^[j + 1]) x - (F^[j]) x‖ := by
  induction k with
  | zero => simp
  | succ k ih =>
      rw [Finset.sum_range_succ]
      calc
        ‖(F^[k + 1]) x - x‖ =
            ‖((F^[k]) x - x) +
              ((F^[k + 1]) x - (F^[k]) x)‖ := by
              congr 1
              abel
        _ ≤ ‖(F^[k]) x - x‖ +
              ‖(F^[k + 1]) x - (F^[k]) x‖ :=
          norm_add_le _ _
        _ ≤ (∑ j ∈ Finset.range k,
              ‖(F^[j + 1]) x - (F^[j]) x‖) +
              ‖(F^[k + 1]) x - (F^[k]) x‖ :=
          add_le_add ih (le_refl _)

theorem sum_geometric_budget_le
    (q : ℝ) (hqzero : 0 ≤ q) (hqone : q < 1) (k : ℕ) :
    (∑ j ∈ Finset.range k,
      (q ^ j +
        (((k + 1 : ℕ) : ℝ) * (1 - q))⁻¹)) ≤
      2 / (1 - q) := by
  have hgap : 0 < 1 - q := sub_pos.mpr hqone
  have hkpos : 0 < ((k + 1 : ℕ) : ℝ) := by positivity
  have hgeom :
      (∑ j ∈ Finset.range k, q ^ j) ≤ (1 - q)⁻¹ := by
    simpa using
      (geom_sum_Ico_le_of_lt_one (m := 0) (n := k)
        hqzero hqone)
  have hratio :
      (k : ℝ) / ((k + 1 : ℕ) : ℝ) ≤ 1 := by
    apply (div_le_iff₀ hkpos).2
    rw [one_mul]
    exact_mod_cast Nat.le_succ k
  have hnoise :
      (k : ℝ) *
        (((k + 1 : ℕ) : ℝ) * (1 - q))⁻¹ ≤
        (1 - q)⁻¹ := by
    calc
      (k : ℝ) *
          (((k + 1 : ℕ) : ℝ) * (1 - q))⁻¹ =
        ((k : ℝ) / ((k + 1 : ℕ) : ℝ)) *
          (1 - q)⁻¹ := by
            field_simp
      _ ≤ 1 * (1 - q)⁻¹ :=
        mul_le_mul_of_nonneg_right hratio
          (inv_nonneg.mpr hgap.le)
      _ = (1 - q)⁻¹ := one_mul _
  calc
    (∑ j ∈ Finset.range k,
      (q ^ j + (((k + 1 : ℕ) : ℝ) * (1 - q))⁻¹)) =
        (∑ j ∈ Finset.range k, q ^ j) +
          (k : ℝ) *
            (((k + 1 : ℕ) : ℝ) * (1 - q))⁻¹ := by
              rw [Finset.sum_add_distrib]
              simp
    _ ≤ (1 - q)⁻¹ + (1 - q)⁻¹ :=
      add_le_add hgeom hnoise
    _ = 2 / (1 - q) := by ring

theorem exists_rooted_word_radius_geometric_markov_displacement
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, u} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (w : G → List ↥S)
    (k : ℕ) :
    ∃ r : ℕ, ∀ X : RootedIndicatorMarkovModel G ↥S,
      X.IsGenerated (fun i : ↥S => (i : G)) w →
      X.IsRootedAtRadius w r →
      ‖((permutationMarkov X.generator)^[k])
          (indicatorVector X.indicator) -
        indicatorVector X.indicator‖ ≤
      (2 / (1 - kazhdanMarkovContractionFactor P S)) *
        ‖permutationMarkov X.generator
            (indicatorVector X.indicator) -
          indicatorVector X.indicator‖ := by
  let q := kazhdanMarkovContractionFactor P S
  have hqzero : 0 ≤ q :=
    kazhdanMarkovContractionFactor_nonneg P S
  have hqone : q < 1 :=
    kazhdanMarkovContractionFactor_lt_one P S ⟨1, honeS⟩
  let ε : ℝ := (((k + 1 : ℕ) : ℝ) * (1 - q))⁻¹
  have hε : 0 < ε :=
    inv_pos.mpr (mul_pos (by positivity) (sub_pos.mpr hqone))
  obtain ⟨r, hr⟩ :=
    exists_rooted_word_radius_all_markov_iterate_contractions
      P S honeS hcover hsymmetric w k ε hε
  refine ⟨r, ?_⟩
  intro X hgenerated hroot
  let d : ℝ :=
    ‖permutationMarkov X.generator
        (indicatorVector X.indicator) -
      indicatorVector X.indicator‖
  have hsteps : ∀ j ∈ Finset.range k,
      ‖((permutationMarkov X.generator)^[j + 1])
          (indicatorVector X.indicator) -
        ((permutationMarkov X.generator)^[j])
          (indicatorVector X.indicator)‖ ≤
        (q ^ j + ε) * d := by
    intro j hj
    exact hr X hgenerated hroot j
      (Nat.le_of_lt (Finset.mem_range.mp hj))
  calc
    ‖((permutationMarkov X.generator)^[k])
        (indicatorVector X.indicator) -
      indicatorVector X.indicator‖ ≤
        ∑ j ∈ Finset.range k,
          ‖((permutationMarkov X.generator)^[j + 1])
              (indicatorVector X.indicator) -
            ((permutationMarkov X.generator)^[j])
              (indicatorVector X.indicator)‖ :=
      norm_iterate_sub_le_sum_successive
        (permutationMarkov X.generator)
        (indicatorVector X.indicator) k
    _ ≤ ∑ j ∈ Finset.range k, (q ^ j + ε) * d :=
      Finset.sum_le_sum hsteps
    _ = (∑ j ∈ Finset.range k, (q ^ j + ε)) * d := by
      rw [Finset.sum_mul]
    _ ≤ (2 / (1 - q)) * d :=
      mul_le_mul_of_nonneg_right
        (sum_geometric_budget_le q hqzero hqone k)
        (norm_nonneg _)
    _ = (2 / (1 - kazhdanMarkovContractionFactor P S)) *
        ‖permutationMarkov X.generator
            (indicatorVector X.indicator) -
          indicatorVector X.indicator‖ := by
      rfl

end

section

open Filter Topology
open SoficGroups.KunRootedIndicatorCrossing
open SoficGroups.KunThomInvariantOrthogonal
open scoped BigOperators ComplexConjugate ComplexOrder InnerProductSpace Pointwise

universe u

theorem rooted_realMarkov_eq_mass_realPermutationMarkov
    {ι V : Type*} [Fintype ι]
    (p : ι → Equiv.Perm V) :
    SoficGroups.KunRealComplexMarkovBridge.realMarkov p =
      SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov p := by
  funext f x
  simp [SoficGroups.KunRealComplexMarkovBridge.realMarkov,
    SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov,
    div_eq_mul_inv, mul_comm]

theorem rooted_markov_real_iterate_sq_error
    {ι V : Type*} [Fintype ι] [Fintype V] [DecidableEq V]
    (p : ι → Equiv.Perm V) (T : Finset V) (k : ℕ) :
    ‖((permutationMarkov p)^[k])
        (indicatorVector
          (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)) -
        indicatorVector
          (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)‖ ^ 2 =
      ∑ x : V,
        ((((SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov p)^[k])
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)) x -
          if x ∈ T then (1 : ℝ) else 0) ^ 2 := by
  have h :=
    SoficGroups.KunRealComplexMarkovBridge.norm_iterate_permutationMarkov_indicator_sub_sq
      p (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T) k
  have hcomplex :
      SoficGroups.KunRealComplexMarkovBridge.permutationMarkov p =
        SoficGroups.KunRootedIndicatorCrossing.permutationMarkov p := rfl
  have hvector :
      SoficGroups.KunRealComplexMarkovBridge.indicatorVector
          (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T) =
        SoficGroups.KunRootedIndicatorCrossing.indicatorVector
          (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T) := rfl
  rw [rooted_realMarkov_eq_mass_realPermutationMarkov] at h
  rw [hcomplex, hvector] at h
  simpa [SoficGroups.KunFinitePermutationMarkovMass.realIndicator] using h

theorem rooted_indicator_defect_sq_le_boundary
    {ι V : Type*} [Fintype ι] [Nonempty ι]
    [Fintype V] [DecidableEq V]
    (p : ι → Equiv.Perm V) (T : Finset V) :
    ‖permutationMarkov p
        (indicatorVector
          (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)) -
        indicatorVector
          (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)‖ ^ 2 ≤
      2 * (SoficGroups.boundary p T : ℝ) /
        (Fintype.card ι : ℝ) := by
  have hcomplex :
      SoficGroups.KunRealComplexMarkovBridge.permutationMarkov p =
        SoficGroups.KunRootedIndicatorCrossing.permutationMarkov p := rfl
  have hvector :
      SoficGroups.KunRealComplexMarkovBridge.indicatorVector
          (SoficGroups.KunDirectedIndicatorJensen.realIndicator T) =
        SoficGroups.KunRootedIndicatorCrossing.indicatorVector
          (SoficGroups.KunDirectedIndicatorJensen.realIndicator T) := rfl
  have hreal :
      SoficGroups.KunRealComplexMarkovBridge.realMarkov p
          (SoficGroups.KunDirectedIndicatorJensen.realIndicator T) =
        SoficGroups.KunDirectedIndicatorJensen.realPermutationMarkov p
          (SoficGroups.KunDirectedIndicatorJensen.realIndicator T) := rfl
  have henergy :=
    SoficGroups.KunRealComplexMarkovBridge.norm_permutationMarkov_indicator_sub_sq
      p (SoficGroups.KunDirectedIndicatorJensen.realIndicator T)
  rw [hcomplex, hvector, hreal] at henergy
  have hindicator :
      SoficGroups.KunFinitePermutationMarkovMass.realIndicator T =
        SoficGroups.KunDirectedIndicatorJensen.realIndicator T := by
    funext x
    simp [SoficGroups.KunFinitePermutationMarkovMass.realIndicator,
      SoficGroups.KunDirectedIndicatorJensen.realIndicator]
  rw [hindicator]
  calc
    ‖permutationMarkov p
        (indicatorVector
          (SoficGroups.KunDirectedIndicatorJensen.realIndicator T)) -
        indicatorVector
          (SoficGroups.KunDirectedIndicatorJensen.realIndicator T)‖ ^ 2 =
      ∑ x,
        (SoficGroups.KunDirectedIndicatorJensen.realPermutationMarkov p
          (SoficGroups.KunDirectedIndicatorJensen.realIndicator T) x -
            SoficGroups.KunDirectedIndicatorJensen.realIndicator T x) ^ 2 := by
          exact henergy
    _ ≤ 2 * (SoficGroups.boundary p T : ℝ) /
        (Fintype.card ι : ℝ) :=
      SoficGroups.KunDirectedIndicatorJensen.realPermutationMarkov_indicator_defect_sq_le_boundary
        p T

end

end KunRootedWordPower

namespace KunActualRootedModelBridge

open SoficGroups.KunActualSoficRootRadius
open SoficGroups.KunRootedIndicatorCrossing
open SoficGroups.KunRootedWordPower
open SoficGroups.KunThomInvariantOrthogonal
open scoped BigOperators

universe u

def sourceFiniteIndicator
    {V : Type*} [DecidableEq V] (T : Finset V) (x : V) : ℝ :=
  if x ∈ T then 1 else 0

def sourceRootedIndicatorMarkovModel
    {G : Type} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (n : ℕ) (T : Finset (Fin (A.model n).size)) :
    RootedIndicatorMarkovModel G ↥S where
  carrier := Fin (A.model n).size
  fintype := inferInstance
  generator i := (A.model n).action (i : G)
  indicator := sourceFiniteIndicator T
  evaluation :=
    chosenWordEvaluation A (fun i : ↥S => (i : G))
      (symmetricGeneratorWord S hsymmetric hgenerates) n

theorem sourceRootedIndicatorMarkovModel_isGenerated
    {G : Type} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (n : ℕ) (T : Finset (Fin (A.model n).size)) :
    (sourceRootedIndicatorMarkovModel
      A S hsymmetric hgenerates n T).IsGenerated
        (fun i : ↥S => (i : G))
        (symmetricGeneratorWord S hsymmetric hgenerates) := by
  refine ⟨?_, ?_, ?_, ?_⟩
  · intro x
    change sourceFiniteIndicator T x = 0 ∨
      sourceFiniteIndicator T x = 1
    by_cases hx : x ∈ T
    · right
      unfold sourceFiniteIndicator
      split
      · rfl
      · rename_i hnot
        exact (hnot hx).elim
    · left
      unfold sourceFiniteIndicator
      split
      · rename_i hmem
        exact (hx hmem).elim
      · rfl
  · intro g
    rfl
  · exact chosen_symmetric_wordEvaluation_one
      A S hsymmetric hgenerates n
  · intro i
    exact chosen_symmetric_wordEvaluation_generator
      A S hsymmetric hgenerates n i

theorem sourceRootedIndicatorMarkovModel_isRootedAtRadius
    {G : Type} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (S : Finset G) (hone : 1 ∈ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (n r : ℕ) (T : Finset (Fin (A.model n).size))
    (hgood : Disjoint T
      (chosenCayleyRadiusBad A S
        (symmetricGeneratorWord S hsymmetric hgenerates) n r)) :
    (sourceRootedIndicatorMarkovModel
      A S hsymmetric hgenerates n T).IsRootedAtRadius
        (symmetricGeneratorWord S hsymmetric hgenerates) r := by
  refine ⟨?_⟩
  intro a g hword x hx
  have hxreal : sourceFiniteIndicator T x ≠ 0 := by
    intro hzero
    apply hx
    change (sourceFiniteIndicator T x : ℂ) = 0
    exact_mod_cast hzero
  have hxT : x ∈ T := by
    by_contra hnot
    apply hxreal
    unfold sourceFiniteIndicator
    split
    · rename_i hmem
      exact (hnot hmem).elim
    · rfl
  have hxgood := Finset.disjoint_left.mp hgood hxT
  exact chosenCayleyRadiusBad_rooted
    A S hone (symmetricGeneratorWord S hsymmetric hgenerates)
    (symmetricGeneratorWord_prod S hsymmetric hgenerates)
    n r a g hword hxgood

end KunActualRootedModelBridge

namespace KunSharpThresholdCut

open MeasureTheory Set
open scoped BigOperators ENNReal symmDiff

def upperLevel {V : Type*} [Fintype V]
    (f : V → ℝ) (t : ℝ) : Finset V :=
  Finset.univ.filter (fun x => t < f x)

def highCrossingProfile {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (a t : ℝ) : ℝ :=
  Finset.univ.sum (fun i : ι =>
    (Finset.univ.filter (fun x : V => a < f x)).sum (fun x =>
      (Ico (f (σ i x)) (f x)).indicator (fun _ => (1 : ℝ)) t))

theorem highCrossingProfile_eq_boundary {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (a t : ℝ)
    (hat : a < t) :
    highCrossingProfile σ f a t =
      (SoficGroups.boundary σ (upperLevel f t) : ℝ) := by
  classical
  unfold highCrossingProfile SoficGroups.boundary upperLevel
  push_cast
  apply Finset.sum_congr rfl
  intro i _
  rw [Finset.card_eq_sum_ones]
  push_cast
  rw [Finset.sum_filter, Finset.sum_filter, Finset.sum_filter]
  apply Finset.sum_congr rfl
  intro x _
  simp only [mem_Ico, indicator,
    Finset.mem_filter, Finset.mem_univ, true_and]
  split_ifs
  all_goals grind

theorem integrableOn_crossingIndicator
    (a b c d : ℝ) :
    IntegrableOn ((Ico a b).indicator (fun _ => (1 : ℝ)))
      (Ioo c d) := by
  exact (integrableOn_const (μ := volume)
    (C := (1 : ℝ)) (s := Ioo c d)
    (by simp [Real.volume_Ioo])).indicator measurableSet_Ico

theorem integrableOn_highCrossingProfile {V ι : Type*}
    [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (a c d : ℝ) :
    IntegrableOn (highCrossingProfile σ f a) (Ioo c d) := by
  unfold highCrossingProfile
  exact integrable_finsetSum _ fun i _ =>
    integrable_finsetSum _ fun x _ =>
      integrableOn_crossingIndicator (f (σ i x)) (f x) c d

theorem setIntegral_crossingIndicator_le_abs
    (a b c d : ℝ) :
    (∫ t in Ioo c d,
      (Ico a b).indicator (fun _ => (1 : ℝ)) t) ≤ |b - a| := by
  calc
    (∫ t in Ioo c d,
        (Ico a b).indicator (fun _ => (1 : ℝ)) t) =
        (volume.restrict (Ioo c d)).real (Ico a b) := by
          exact integral_indicator_one (μ := volume.restrict (Ioo c d))
            measurableSet_Ico
    _ = volume.real (Ico a b ∩ Ioo c d) :=
      measureReal_restrict_apply measurableSet_Ico
    _ ≤ volume.real (Ico a b) :=
      measureReal_mono inter_subset_left
        (by simp [Real.volume_Ico])
    _ = max (b - a) 0 := Real.volume_real_Ico
    _ ≤ |b - a| := max_le (le_abs_self _) (abs_nonneg _)

theorem setIntegral_highCrossingProfile_le_variation {V ι : Type*}
    [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (a c d : ℝ) :
    (∫ t in Ioo c d, highCrossingProfile σ f a t) ≤
      ∑ i : ι, ∑ x ∈ Finset.univ.filter (fun x : V => a < f x),
        |f (σ i x) - f x| := by
  classical
  let H : Finset V := Finset.univ.filter fun x : V => a < f x
  have hint (i : ι) (x : V) :
      Integrable
        ((Ico (f (σ i x)) (f x)).indicator (fun _ => (1 : ℝ)))
        (volume.restrict (Ioo c d)) :=
    integrableOn_crossingIndicator (f (σ i x)) (f x) c d
  calc
    (∫ t in Ioo c d, highCrossingProfile σ f a t) =
        ∑ i : ι, ∑ x ∈ H, (∫ t in Ioo c d,
          (Ico (f (σ i x)) (f x)).indicator (fun _ => (1 : ℝ)) t) := by
      unfold highCrossingProfile
      change (∫ t in Ioo c d, ∑ i : ι, ∑ x ∈ H,
        (Ico (f (σ i x)) (f x)).indicator (fun _ => (1 : ℝ)) t) = _
      rw [integral_finsetSum Finset.univ
        (fun i _ => integrable_finsetSum H
          (fun x _ => hint i x))]
      apply Finset.sum_congr rfl
      intro i _
      rw [integral_finsetSum H (fun x _ => hint i x)]
    _ ≤ ∑ i : ι, ∑ x ∈ H, |f (σ i x) - f x| := by
      apply Finset.sum_le_sum
      intro i _
      apply Finset.sum_le_sum
      intro x _
      calc
        (∫ t in Ioo c d,
          (Ico (f (σ i x)) (f x)).indicator (fun _ => (1 : ℝ)) t) ≤
            |f x - f (σ i x)| :=
              setIntegral_crossingIndicator_le_abs
                (f (σ i x)) (f x) c d
        _ = |f (σ i x) - f x| := abs_sub_comm _ _
    _ = ∑ i : ι, ∑ x ∈ Finset.univ.filter
        (fun x : V => a < f x), |f (σ i x) - f x| := by
      rfl

theorem card_symmDiff_upperLevel_le_nine_sq_error {V : Type*}
    [Fintype V] [DecidableEq V]
    (T : Finset V) (f : V → ℝ) (t : ℝ)
    (hlow : (1 / 3 : ℝ) ≤ t) (hhigh : t ≤ (2 / 3 : ℝ)) :
    (((upperLevel f t ∆ T).card : ℝ)) ≤
      9 * ∑ x : V, (f x - if x ∈ T then (1 : ℝ) else 0) ^ 2 := by
  classical
  let D : Finset V := upperLevel f t ∆ T
  have hpoint (x : V) (hx : x ∈ D) :
      (1 : ℝ) ≤
        9 * (f x - if x ∈ T then (1 : ℝ) else 0) ^ 2 := by
    rcases (Finset.mem_symmDiff.mp hx) with hx | hx
    · obtain ⟨hxlevel, hxT⟩ := hx
      have hfx : t < f x := (Finset.mem_filter.mp hxlevel).2
      simp only [if_neg hxT]
      nlinarith [sq_nonneg (3 * f x - 1)]
    · obtain ⟨hxT, hxlevel⟩ := hx
      have hfx : f x ≤ t := by
        apply le_of_not_gt
        intro h
        exact hxlevel
          (Finset.mem_filter.mpr ⟨Finset.mem_univ x, h⟩)
      simp only [if_pos hxT]
      nlinarith [sq_nonneg (3 * f x - 2)]
  have hcard :
      (D.card : ℝ) = ∑ x : V, if x ∈ D then (1 : ℝ) else 0 := by
    simp
  change (D.card : ℝ) ≤ _
  rw [hcard]
  calc
    (∑ x : V, if x ∈ D then (1 : ℝ) else 0) ≤
        ∑ x : V,
          9 * (f x - if x ∈ T then (1 : ℝ) else 0) ^ 2 := by
      apply Finset.sum_le_sum
      intro x _
      by_cases hx : x ∈ D
      · simpa only [if_pos hx] using hpoint x hx
      · simp only [if_neg hx]
        positivity
    _ = 9 * ∑ x : V,
        (f x - if x ∈ T then (1 : ℝ) else 0) ^ 2 := by
      rw [Finset.mul_sum]

theorem exists_upperLevel_boundary_and_symmDiff_le {V ι : Type*}
    [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (T : Finset V) (f : V → ℝ) :
    ∃ t ∈ Ioo (1 / 3 : ℝ) (2 / 3 : ℝ),
      (SoficGroups.boundary σ (upperLevel f t) : ℝ) ≤
          3 * ∑ i : ι,
            ∑ x ∈ Finset.univ.filter
              (fun x : V => (1 / 3 : ℝ) < f x),
                |f (σ i x) - f x| ∧
        (((upperLevel f t ∆ T).card : ℝ)) ≤
          9 * ∑ x : V,
            (f x - if x ∈ T then (1 : ℝ) else 0) ^ 2 := by
  have hpos : volume (Ioo (1 / 3 : ℝ) (2 / 3 : ℝ)) ≠ 0 := by
    norm_num [Real.volume_Ioo]
  have hfin : volume (Ioo (1 / 3 : ℝ) (2 / 3 : ℝ)) ≠ ∞ := by
    simp [Real.volume_Ioo]
  obtain ⟨t, ht, hmean⟩ :=
    exists_le_setAverage (μ := volume)
      (s := Ioo (1 / 3 : ℝ) (2 / 3 : ℝ))
      hpos hfin
      (integrableOn_highCrossingProfile σ f (1 / 3) _ _)
  refine ⟨t, ht, ?_, ?_⟩
  · rw [← highCrossingProfile_eq_boundary σ f (1 / 3) t ht.1]
    calc
      highCrossingProfile σ f (1 / 3) t ≤
          ⨍ u in Ioo (1 / 3 : ℝ) (2 / 3 : ℝ),
            highCrossingProfile σ f (1 / 3) u := hmean
      _ = 3 * (∫ u in Ioo (1 / 3 : ℝ) (2 / 3 : ℝ),
            highCrossingProfile σ f (1 / 3) u) := by
        rw [setAverage_eq, Real.volume_real_Ioo]
        norm_num
      _ ≤ 3 * ∑ i : ι,
          ∑ x ∈ Finset.univ.filter
            (fun x : V => (1 / 3 : ℝ) < f x),
              |f (σ i x) - f x| :=
        mul_le_mul_of_nonneg_left
          (setIntegral_highCrossingProfile_le_variation
            σ f (1 / 3) (1 / 3) (2 / 3)) (by norm_num)
  · exact card_symmDiff_upperLevel_le_nine_sq_error
      T f t ht.1.le ht.2.le

end KunSharpThresholdCut

namespace KunActualFinalRestrictedVariation

open scoped BigOperators

def realMarkov {V ι : Type*} [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (x : V) : ℝ :=
  (∑ i : ι, f ((σ i).symm x)) / (Fintype.card ι : ℝ)

theorem sum_permutation_mul_eq_sum_inverse_mul
    {V : Type*} [Fintype V]
    (p : Equiv.Perm V) (f : V → ℝ) :
    (∑ x : V, f (p x) * f x) =
      ∑ x : V, f x * f (p.symm x) := by
  calc
    (∑ x : V, f (p x) * f x) =
        ∑ x : V, f (p (p.symm x)) * f (p.symm x) :=
      (Equiv.sum_comp p.symm
        (fun x : V => f (p x) * f x)).symm
    _ = ∑ x : V, f x * f (p.symm x) := by
      apply Finset.sum_congr rfl
      intro x _
      rw [p.apply_symm_apply]

theorem sum_sq_displacement_eq_twice_inverse_residual
    {V : Type*} [Fintype V]
    (p : Equiv.Perm V) (f : V → ℝ) :
    (∑ x : V, (f (p x) - f x) ^ 2) =
      2 * ∑ x : V, f x * (f x - f (p.symm x)) := by
  have hsquare :
      (∑ x : V, f (p x) ^ 2) = ∑ x : V, f x ^ 2 :=
    Equiv.sum_comp p (fun x : V => f x ^ 2)
  have hcross := sum_permutation_mul_eq_sum_inverse_mul p f
  calc
    (∑ x : V, (f (p x) - f x) ^ 2) =
        (∑ x : V, f (p x) ^ 2) +
          (∑ x : V, f x ^ 2) -
            2 * ∑ x : V, f (p x) * f x := by
      calc
        (∑ x : V, (f (p x) - f x) ^ 2) =
            ∑ x : V,
              (f (p x) ^ 2 + f x ^ 2 -
                2 * (f (p x) * f x)) := by
          apply Finset.sum_congr rfl
          intro x _
          ring
        _ = _ := by
          rw [Finset.sum_sub_distrib, Finset.sum_add_distrib,
            ← Finset.mul_sum]
    _ = 2 * ∑ x : V, f x * (f x - f (p.symm x)) := by
      rw [hsquare, hcross]
      simp_rw [mul_sub]
      rw [Finset.sum_sub_distrib]
      ring_nf

theorem sum_sum_sq_displacement_eq_twice_card_mul_realMarkov_residual
    {V ι : Type*} [Fintype V] [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) :
    (∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2) =
      2 * (Fintype.card ι : ℝ) *
        ∑ x : V, f x * (f x - realMarkov σ f x) := by
  classical
  have hd : 0 < (Fintype.card ι : ℝ) := by
    exact_mod_cast Fintype.card_pos_iff.mpr
      (inferInstance : Nonempty ι)
  calc
    (∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2) =
        2 * ∑ x : V, ∑ i : ι,
          f x * (f x - f ((σ i).symm x)) := by
      simp_rw [sum_sq_displacement_eq_twice_inverse_residual]
      rw [← Finset.mul_sum, Finset.sum_comm]
    _ = 2 * (Fintype.card ι : ℝ) *
        ∑ x : V, f x * (f x - realMarkov σ f x) := by
      rw [mul_assoc]
      congr 1
      rw [Finset.mul_sum]
      apply Finset.sum_congr rfl
      intro x _
      unfold realMarkov
      simp_rw [mul_sub]
      rw [Finset.sum_sub_distrib, Finset.sum_const,
        Finset.card_univ, nsmul_eq_mul]
      rw [← Finset.mul_sum]
      field_simp

theorem sum_sq_le_card_of_unit_interval_mass
    {V : Type*} [Fintype V]
    (T : Finset V) (f : V → ℝ)
    (hfzero : ∀ x, 0 ≤ f x) (hfone : ∀ x, f x ≤ 1)
    (hmass : (∑ x : V, f x) = (T.card : ℝ)) :
    (∑ x : V, f x ^ 2) ≤ (T.card : ℝ) := by
  calc
    (∑ x : V, f x ^ 2) ≤ ∑ x : V, f x := by
      apply Finset.sum_le_sum
      intro x _
      nlinarith [mul_nonneg (hfzero x)
        (sub_nonneg.mpr (hfone x))]
    _ = (T.card : ℝ) := hmass

theorem realMarkov_residual_pairing_le_sqrt_card_mul_residual
    {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (T : Finset V) (f : V → ℝ)
    (hfzero : ∀ x, 0 ≤ f x) (hfone : ∀ x, f x ≤ 1)
    (hmass : (∑ x : V, f x) = (T.card : ℝ)) :
    (∑ x : V, f x * (f x - realMarkov σ f x)) ≤
      Real.sqrt (T.card : ℝ) *
        Real.sqrt (∑ x : V,
          (realMarkov σ f x - f x) ^ 2) := by
  have hsquare := sum_sq_le_card_of_unit_interval_mass
    T f hfzero hfone hmass
  calc
    (∑ x : V, f x * (f x - realMarkov σ f x)) ≤
        Real.sqrt (∑ x : V, f x ^ 2) *
          Real.sqrt (∑ x : V,
            (f x - realMarkov σ f x) ^ 2) :=
      Real.sum_mul_le_sqrt_mul_sqrt Finset.univ f
        (fun x => f x - realMarkov σ f x)
    _ ≤ Real.sqrt (T.card : ℝ) *
          Real.sqrt (∑ x : V,
            (f x - realMarkov σ f x) ^ 2) :=
      mul_le_mul_of_nonneg_right (Real.sqrt_le_sqrt hsquare)
        (Real.sqrt_nonneg _)
    _ = Real.sqrt (T.card : ℝ) *
          Real.sqrt (∑ x : V,
            (realMarkov σ f x - f x) ^ 2) := by
      congr 2
      apply Finset.sum_congr rfl
      intro x _
      ring

theorem sum_sum_sq_displacement_le_twice_card_mul_sqrt_card_mul_residual
    {V ι : Type*} [Fintype V]
    [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (T : Finset V) (f : V → ℝ)
    (hfzero : ∀ x, 0 ≤ f x) (hfone : ∀ x, f x ≤ 1)
    (hmass : (∑ x : V, f x) = (T.card : ℝ)) :
    (∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2) ≤
      2 * (Fintype.card ι : ℝ) * Real.sqrt (T.card : ℝ) *
        Real.sqrt (∑ x : V,
          (realMarkov σ f x - f x) ^ 2) := by
  rw [sum_sum_sq_displacement_eq_twice_card_mul_realMarkov_residual]
  have hpair := realMarkov_residual_pairing_le_sqrt_card_mul_residual
    σ T f hfzero hfone hmass
  have hfactor : 0 ≤ 2 * (Fintype.card ι : ℝ) := by positivity
  nlinarith [mul_nonneg hfactor
    (sub_nonneg.mpr hpair)]

theorem card_highSupport_le_three_card
    {V : Type*} [Fintype V]
    (T : Finset V) (f : V → ℝ)
    (hfzero : ∀ x, 0 ≤ f x)
    (hmass : (∑ x : V, f x) = (T.card : ℝ)) :
    (((Finset.univ.filter fun x : V =>
      (1 / 3 : ℝ) < f x).card : ℝ)) ≤ 3 * (T.card : ℝ) := by
  classical
  let H : Finset V :=
    Finset.univ.filter fun x : V => (1 / 3 : ℝ) < f x
  have hpoint (x : V) (hx : x ∈ H) :
      (1 : ℝ) ≤ 3 * f x := by
    have hx' : (1 / 3 : ℝ) < f x :=
      (Finset.mem_filter.mp hx).2
    linarith
  have hhigh : (H.card : ℝ) ≤ 3 * ∑ x ∈ H, f x := by
    calc
      (H.card : ℝ) = ∑ _x ∈ H, (1 : ℝ) := by simp
      _ ≤ ∑ x ∈ H, 3 * f x :=
        Finset.sum_le_sum fun x hx => hpoint x hx
      _ = 3 * ∑ x ∈ H, f x := by rw [Finset.mul_sum]
  have hsum : (∑ x ∈ H, f x) ≤ ∑ x : V, f x := by
    apply Finset.sum_le_sum_of_subset_of_nonneg
      (Finset.subset_univ H)
    intro x _ _
    exact hfzero x
  change (H.card : ℝ) ≤ 3 * (T.card : ℝ)
  calc
    (H.card : ℝ) ≤ 3 * ∑ x ∈ H, f x := hhigh
    _ ≤ 3 * ∑ x : V, f x :=
      mul_le_mul_of_nonneg_left hsum (by norm_num)
    _ = 3 * (T.card : ℝ) := by rw [hmass]

theorem filtered_variation_sq_le_card_mul_filtered_energy
    {V ι : Type*} [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (H : Finset V) :
    (∑ i : ι, ∑ x ∈ H, |f (σ i x) - f x|) ^ 2 ≤
      (Fintype.card ι : ℝ) * (H.card : ℝ) *
        ∑ i : ι, ∑ x ∈ H, (f (σ i x) - f x) ^ 2 := by
  classical
  have hcs := Finset.sum_mul_sq_le_sq_mul_sq
    (Finset.univ.product H)
    (fun _ : ι × V => (1 : ℝ))
    (fun z : ι × V => |f (σ z.1 z.2) - f z.2|)
  simpa [Finset.sum_product, sq_abs, mul_assoc] using hcs

theorem filtered_variation_sq_le_card_mul_energy
    {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (H : Finset V) :
    (∑ i : ι, ∑ x ∈ H, |f (σ i x) - f x|) ^ 2 ≤
      (Fintype.card ι : ℝ) * (H.card : ℝ) *
        ∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2 := by
  classical
  have henergy :
      (∑ i : ι, ∑ x ∈ H, (f (σ i x) - f x) ^ 2) ≤
        ∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2 := by
    apply Finset.sum_le_sum
    intro i _
    apply Finset.sum_le_sum_of_subset_of_nonneg
      (Finset.subset_univ H)
    intro x _ _
    exact sq_nonneg _
  calc
    (∑ i : ι, ∑ x ∈ H, |f (σ i x) - f x|) ^ 2 ≤
        (Fintype.card ι : ℝ) * (H.card : ℝ) *
          ∑ i : ι, ∑ x ∈ H, (f (σ i x) - f x) ^ 2 :=
      filtered_variation_sq_le_card_mul_filtered_energy σ f H
    _ ≤ (Fintype.card ι : ℝ) * (H.card : ℝ) *
          ∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2 :=
      mul_le_mul_of_nonneg_left henergy
        (mul_nonneg (Nat.cast_nonneg _) (Nat.cast_nonneg _))

theorem highSupport_variation_sq_le_three_mul_reference_energy
    {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (T : Finset V)
    (hhigh :
      ((Finset.univ.filter
        (fun x : V => (1 / 3 : ℝ) < f x)).card : ℝ) ≤
          3 * (T.card : ℝ)) :
    (∑ i : ι,
      ∑ x ∈ Finset.univ.filter
        (fun x : V => (1 / 3 : ℝ) < f x),
          |f (σ i x) - f x|) ^ 2 ≤
      3 * (Fintype.card ι : ℝ) * (T.card : ℝ) *
        ∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2 := by
  have henergy :
      0 ≤ ∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2 :=
    Finset.sum_nonneg fun i _ =>
      Finset.sum_nonneg fun x _ => sq_nonneg _
  calc
    (∑ i : ι,
      ∑ x ∈ Finset.univ.filter
        (fun x : V => (1 / 3 : ℝ) < f x),
          |f (σ i x) - f x|) ^ 2 ≤
        (Fintype.card ι : ℝ) *
          ((Finset.univ.filter
            (fun x : V => (1 / 3 : ℝ) < f x)).card : ℝ) *
          ∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2 :=
      filtered_variation_sq_le_card_mul_energy σ f
        (Finset.univ.filter fun x : V => (1 / 3 : ℝ) < f x)
    _ ≤ (Fintype.card ι : ℝ) * (3 * (T.card : ℝ)) *
        ∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2 :=
      mul_le_mul_of_nonneg_right
        (mul_le_mul_of_nonneg_left hhigh (Nat.cast_nonneg _)) henergy
    _ = 3 * (Fintype.card ι : ℝ) * (T.card : ℝ) *
        ∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2 := by
      ring

theorem high_variation_le_of_markov_square_bounds
    {d t α η b r E H : ℝ}
    (hd : 0 ≤ d) (ht : 0 ≤ t) (hα : 0 ≤ α) (hη : 0 ≤ η)
    (hbase : b ^ 2 ≤ t)
    (hresidual : r ≤ η * b)
    (henergy : E ≤ 2 * d * Real.sqrt t * r)
    (hcauchy : H ^ 2 ≤ 3 * d * t * E)
    (hsmall : 486 * d ^ 2 * η ≤ 4 * α ^ 2) :
    9 * H ≤ 2 * α * t := by
  have hsqrt : 0 ≤ Real.sqrt t := Real.sqrt_nonneg t
  have hsqrt_sq : (Real.sqrt t) ^ 2 = t := Real.sq_sqrt ht
  have hb_sqrt : b ≤ Real.sqrt t := Real.le_sqrt_of_sq_le hbase
  have hr_sqrt : r ≤ η * Real.sqrt t :=
    hresidual.trans (mul_le_mul_of_nonneg_left hb_sqrt hη)
  have henergy' : E ≤ 2 * d * η * t := by
    calc
      E ≤ 2 * d * Real.sqrt t * r := henergy
      _ ≤ 2 * d * Real.sqrt t * (η * Real.sqrt t) :=
        mul_le_mul_of_nonneg_left hr_sqrt
          (mul_nonneg (mul_nonneg (by norm_num) hd) hsqrt)
      _ = 2 * d * η * (Real.sqrt t) ^ 2 := by ring
      _ = 2 * d * η * t := by rw [hsqrt_sq]
  have hcauchy' : H ^ 2 ≤ 6 * d ^ 2 * η * t ^ 2 := by
    calc
      H ^ 2 ≤ 3 * d * t * E := hcauchy
      _ ≤ 3 * d * t * (2 * d * η * t) :=
        mul_le_mul_of_nonneg_left henergy'
          (mul_nonneg (mul_nonneg (by norm_num) hd) ht)
      _ = 6 * d ^ 2 * η * t ^ 2 := by ring
  have hsquare : (9 * H) ^ 2 ≤ (2 * α * t) ^ 2 := by
    have hsmall' := mul_le_mul_of_nonneg_right hsmall (sq_nonneg t)
    nlinarith
  nlinarith [mul_nonneg hα ht]

theorem highSupport_variation_le_of_realMarkov_residual_and_highSupport
    {V ι : Type*} [Fintype V]
    [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (T : Finset V) (f : V → ℝ)
    (α η b : ℝ)
    (hfzero : ∀ x, 0 ≤ f x) (hfone : ∀ x, f x ≤ 1)
    (hmass : (∑ x : V, f x) = (T.card : ℝ))
    (hhigh :
      ((Finset.univ.filter
        (fun x : V => (1 / 3 : ℝ) < f x)).card : ℝ) ≤
          3 * (T.card : ℝ))
    (hα : 0 ≤ α) (hη : 0 ≤ η)
    (hbase : b ^ 2 ≤ (T.card : ℝ))
    (hresidual :
      Real.sqrt (∑ x : V,
        (realMarkov σ f x - f x) ^ 2) ≤ η * b)
    (hsmall :
      486 * (Fintype.card ι : ℝ) ^ 2 * η ≤ 4 * α ^ 2) :
    9 * (∑ i : ι,
      ∑ x ∈ Finset.univ.filter
        (fun x : V => (1 / 3 : ℝ) < f x),
          |f (σ i x) - f x|) ≤ 2 * α * (T.card : ℝ) := by
  exact high_variation_le_of_markov_square_bounds
    (d := (Fintype.card ι : ℝ))
    (t := (T.card : ℝ))
    (α := α) (η := η) (b := b)
    (r := Real.sqrt (∑ x : V,
      (realMarkov σ f x - f x) ^ 2))
    (E := ∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2)
    (H := ∑ i : ι,
      ∑ x ∈ Finset.univ.filter
        (fun x : V => (1 / 3 : ℝ) < f x),
          |f (σ i x) - f x|)
    (Nat.cast_nonneg _) (Nat.cast_nonneg _)
    hα hη hbase hresidual
    (sum_sum_sq_displacement_le_twice_card_mul_sqrt_card_mul_residual
      σ T f hfzero hfone hmass)
    (highSupport_variation_sq_le_three_mul_reference_energy
      σ f T hhigh)
    hsmall

theorem highSupport_variation_le_of_realMarkov_residual
    {V ι : Type*} [Fintype V]
    [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (T : Finset V) (f : V → ℝ)
    (α η b : ℝ)
    (hfzero : ∀ x, 0 ≤ f x) (hfone : ∀ x, f x ≤ 1)
    (hmass : (∑ x : V, f x) = (T.card : ℝ))
    (hα : 0 ≤ α) (hη : 0 ≤ η)
    (hbase : b ^ 2 ≤ (T.card : ℝ))
    (hresidual :
      Real.sqrt (∑ x : V,
        (realMarkov σ f x - f x) ^ 2) ≤ η * b)
    (hsmall :
      486 * (Fintype.card ι : ℝ) ^ 2 * η ≤ 4 * α ^ 2) :
    9 * (∑ i : ι,
      ∑ x ∈ Finset.univ.filter
        (fun x : V => (1 / 3 : ℝ) < f x),
          |f (σ i x) - f x|) ≤ 2 * α * (T.card : ℝ) := by
  exact highSupport_variation_le_of_realMarkov_residual_and_highSupport
    σ T f α η b hfzero hfone hmass
    (card_highSupport_le_three_card T f hfzero hmass)
    hα hη hbase hresidual hsmall

end KunActualFinalRestrictedVariation

namespace MatchedFirstStageWordRadiusTransfer

open Filter Topology
open scoped BigOperators

theorem card_completed_sourceWordTestBad_le_sourceCompletionBad
    {V ι J : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V) (p : J → Equiv.Perm V)
    (F : Finset J) (P : Finset V) :
    (SoficGroups.MatchedComponentExitBudget.sourceWordTestBad
      (fun i => SoficGroups.MatchedComponentCompletion.completedRestriction
        (σ i) P)
      (fun j => SoficGroups.MatchedComponentCompletion.completedRestriction
        (p j) P)
      F).card ≤
      (SoficGroups.MatchedComponentCompletion.sourceCompletionBad
        σ p F P).card := by
  classical
  let σP : ι → Equiv.Perm {x : V // x ∈ P} := fun i =>
    SoficGroups.MatchedComponentCompletion.completedRestriction (σ i) P
  let pP : J → Equiv.Perm {x : V // x ∈ P} := fun j =>
    SoficGroups.MatchedComponentCompletion.completedRestriction (p j) P
  let W : Finset {x : V // x ∈ P} :=
    SoficGroups.MatchedComponentExitBudget.sourceWordTestBad σP pP F
  have hσP :
      ∀ i (x : V) (hx : x ∈ P) (_hi : σ i x ∈ P),
        ((σP i ⟨x, hx⟩ : {x : V // x ∈ P}) : V) = σ i x := by
    intro i x hx hi
    exact SoficGroups.MatchedComponentCompletion.completedRestriction_apply_of_mem
      (σ i) P x hx hi
  have hinject :
      W.map (Function.Embedding.subtype (fun x : V => x ∈ P)) ⊆
        SoficGroups.MatchedComponentCompletion.sourceCompletionBad
          σ p F P := by
    intro x hx
    obtain ⟨z, hz, rfl⟩ := Finset.mem_map.mp hx
    by_contra hnot
    have hwords : z ∈ W := hz
    simp [W, SoficGroups.MatchedComponentExitBudget.sourceWordTestBad,
      σP, pP] at hwords
    rcases hwords with hcomm | hmul | hsep
    · obtain ⟨i, j, hj, hfailure⟩ := hcomm
      exact hfailure
        (SoficGroups.MatchedComponentCompletion.completedRestriction_commute_of_not_mem_sourceCompletionBad
          σ p F P σP hσP hj i z hnot)
    · obtain ⟨j, hj, k, hk, hfailure⟩ := hmul
      apply hfailure
      simpa [Equiv.Perm.mul_apply] using
        SoficGroups.MatchedComponentCompletion.completedRestriction_mul_of_not_mem_sourceCompletionBad
          σ p F P hj hk z hnot
    · obtain ⟨j, hj, k, hk, hne, heq⟩ := hsep
      exact
        (SoficGroups.MatchedComponentCompletion.completedRestriction_ne_of_not_mem_sourceCompletionBad
          σ p F P hj hk hne z hnot) heq
  change W.card ≤ _
  calc
    W.card =
        (W.map (Function.Embedding.subtype (fun x : V => x ∈ P))).card :=
      (Finset.card_map _).symm
    _ ≤ (SoficGroups.MatchedComponentCompletion.sourceCompletionBad
          σ p F P).card := Finset.card_le_card hinject

theorem completed_sourceWordTestBad_density_tendsto_zero
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    {ι J : Type*} [Fintype ι] [Group J]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (p : (n : ℕ) → J → Equiv.Perm (V n))
    (F : Finset J)
    (P E : (n : ℕ) → Finset (V n))
    (hcapture : ∀ n,
      SoficGroups.MatchedComponentCompletion.sourceCompletionBad
        (σ n) (p n) F (P n) ⊆ P n ∩ E n)
    (hradius : Tendsto
      (fun n => (((P n ∩ E n).card : ℝ) / (P n).card))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((SoficGroups.MatchedComponentExitBudget.sourceWordTestBad
          (fun i => SoficGroups.MatchedComponentCompletion.completedRestriction
            (σ n i) (P n))
          (fun j => SoficGroups.MatchedComponentCompletion.completedRestriction
            (p n j) (P n))
          F).card : ℝ) / (P n).card)
      atTop (nhds 0) := by
  have hupper (n : ℕ) :
      ((SoficGroups.MatchedComponentExitBudget.sourceWordTestBad
        (fun i => SoficGroups.MatchedComponentCompletion.completedRestriction
          (σ n i) (P n))
        (fun j => SoficGroups.MatchedComponentCompletion.completedRestriction
          (p n j) (P n))
        F).card : ℝ) / (P n).card ≤
          (((P n ∩ E n).card : ℝ) / (P n).card) := by
    have hfirst := card_completed_sourceWordTestBad_le_sourceCompletionBad
      (σ n) (p n) F (P n)
    have hsecond := Finset.card_le_card (hcapture n)
    have hcard :
        (SoficGroups.MatchedComponentExitBudget.sourceWordTestBad
          (fun i => SoficGroups.MatchedComponentCompletion.completedRestriction
            (σ n i) (P n))
          (fun j => SoficGroups.MatchedComponentCompletion.completedRestriction
            (p n j) (P n))
          F).card ≤ (P n ∩ E n).card := hfirst.trans hsecond
    apply div_le_div_of_nonneg_right _ (by positivity)
    exact_mod_cast hcard
  exact squeeze_zero'
    (Filter.Eventually.of_forall fun n => by positivity)
    (Filter.Eventually.of_forall hupper)
    hradius

theorem completed_sourceWordTestBad_density_tendsto_zero_of_matchedRadius
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    {ι κ J : Type*} [Fintype ι] [Group J]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (p : (n : ℕ) → J → Equiv.Perm (V n))
    (F : Finset J)
    (U P : (n : ℕ) → Finset (V n))
    (Q : (n : ℕ) → Finpartition (U n))
    (I : ℕ → Finset κ)
    (w : (n : ℕ) → κ → Equiv.Perm (V n))
    (r : ℕ → ℕ)
    (B : (n : ℕ) → ℕ → Finset (V n))
    (hcapture : ∀ n,
      SoficGroups.MatchedComponentCompletion.sourceCompletionBad
        (σ n) (p n) F (P n) ⊆
          P n ∩ SoficGroups.matchedRadiusBad
            (Q n) (I (r n)) (w n) (B n (r n)))
    (hradius : Tendsto
      (fun n =>
        (((P n ∩ SoficGroups.matchedRadiusBad
          (Q n) (I (r n)) (w n) (B n (r n))).card : ℝ) / (P n).card))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((SoficGroups.MatchedComponentExitBudget.sourceWordTestBad
          (fun i => SoficGroups.MatchedComponentCompletion.completedRestriction
            (σ n i) (P n))
          (fun j => SoficGroups.MatchedComponentCompletion.completedRestriction
            (p n j) (P n))
          F).card : ℝ) / (P n).card)
      atTop (nhds 0) := by
  exact completed_sourceWordTestBad_density_tendsto_zero
    V σ p F P
    (fun n => SoficGroups.matchedRadiusBad
      (Q n) (I (r n)) (w n) (B n (r n)))
    hcapture hradius

theorem pruned_sourceCompletionBad_density_tendsto_zero_of_matchedRadius
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    {ι κ J : Type*} [Fintype ι] [Group J]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (p : (n : ℕ) → J → Equiv.Perm (V n))
    (F : Finset J)
    (U P : (n : ℕ) → Finset (V n))
    (Q : (n : ℕ) → Finpartition (U n))
    (I : ℕ → Finset κ)
    (w : (n : ℕ) → κ → Equiv.Perm (V n))
    (r : ℕ → ℕ)
    (B : (n : ℕ) → ℕ → Finset (V n))
    (D : (n : ℕ) → Finset {x : V n // x ∈ P n})
    (hcapture : ∀ n,
      SoficGroups.MatchedComponentCompletion.sourceCompletionBad
        (σ n) (p n) F (P n) ⊆
          P n ∩ SoficGroups.matchedRadiusBad
            (Q n) (I (r n)) (w n) (B n (r n)))
    (hradius : Tendsto
      (fun n =>
        (((P n ∩ SoficGroups.matchedRadiusBad
          (Q n) (I (r n)) (w n) (B n (r n))).card : ℝ) / (P n).card))
      atTop (nhds 0))
    (hZ : ∀ n,
      (Finset.univ \ D n :
        Finset {x : V n // x ∈ P n}).Nonempty)
    (hdeleted : Tendsto
      (fun n => ((D n).card : ℝ) / (P n).card)
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((SoficGroups.MatchedComponentCompletion.sourceCompletionBad
          (fun i => SoficGroups.MatchedComponentCompletion.completedRestriction
            (σ n i) (P n))
          (fun j => SoficGroups.MatchedComponentCompletion.completedRestriction
            (p n j) (P n))
          F (Finset.univ \ D n)).card : ℝ) /
          (Finset.univ \ D n :
            Finset {x : V n // x ∈ P n}).card)
      atTop (nhds 0) := by
  have hword :=
    completed_sourceWordTestBad_density_tendsto_zero_of_matchedRadius
      V σ p F U P Q I w r B hcapture hradius
  apply SoficGroups.MatchedComponentExitBudget.sourceCompletionBad_surviving_density_tendsto_zero
      (fun n => {x : V n // x ∈ P n})
      (fun n i =>
        SoficGroups.MatchedComponentCompletion.completedRestriction
          (σ n i) (P n))
      (fun n j =>
        SoficGroups.MatchedComponentCompletion.completedRestriction
          (p n j) (P n))
      F D hZ
  · simpa only [Fintype.card_coe] using hdeleted
  · simpa only [Fintype.card_coe] using hword

end MatchedFirstStageWordRadiusTransfer

namespace SourceCompressionMatching

open Filter Topology
open scoped BigOperators symmDiff

theorem lt_exp_mul_of_equal_log_floor
    {x y H r : ℝ} (hx : 0 < x) (hy : 0 < y) (hH : 0 < H)
    (hrank :
      ⌊(Real.log x + r) / H⌋ = ⌊(Real.log y + r) / H⌋) :
    y < Real.exp H * x := by
  have hyfloor := Int.lt_floor_add_one ((Real.log y + r) / H)
  rw [← hrank] at hyfloor
  have hxloor := Int.floor_le ((Real.log x + r) / H)
  have hratio :
      (Real.log y + r) / H < (Real.log x + r) / H + 1 :=
    hyfloor.trans_le (by
      simpa [add_comm] using (add_le_add_right hxloor 1))
  have hscaled := mul_lt_mul_of_pos_right hratio hH
  have hcancel :
      ((Real.log x + r) / H + 1) * H =
        Real.log x + r + H := by
    rw [add_mul, div_mul_cancel₀ _ hH.ne', one_mul]
  have hlog : Real.log y < Real.log x + H := by
    rw [div_mul_cancel₀ _ hH.ne', hcancel] at hscaled
    linarith
  have hexp := (Real.exp_lt_exp).2 hlog
  rw [Real.exp_log hy, Real.exp_add, Real.exp_log hx] at hexp
  simpa [mul_comm] using hexp

theorem transported_maximumOverlapPart_card_lt_exp_mul
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (C : Finset V) (hC : C ∈ Q.parts)
    (H r : ℝ) (hH : 0 < H) (x : V) (hx : x ∈ C)
    (hTx : T x ∈ SoficGroups.maximumOverlapPart Q
      (C.map T.toEmbedding))
    (hrank :
      SoficGroups.MidrankPermutationEnergy.offsetFloorRank
          (fun z : V =>
            Real.log (SoficGroups.partitionComponentSize Q z : ℝ))
          H r (T x) =
        SoficGroups.MidrankPermutationEnergy.offsetFloorRank
          (fun z : V =>
            Real.log (SoficGroups.partitionComponentSize Q z : ℝ))
          H r x) :
    ((SoficGroups.maximumOverlapPart Q
      (C.map T.toEmbedding)).card : ℝ) <
        Real.exp H * (C.card : ℝ) := by
  let D := SoficGroups.maximumOverlapPart Q (C.map T.toEmbedding)
  have hCne : C.Nonempty := Q.nonempty_of_mem_parts hC
  have hD : D ∈ Q.parts :=
    SoficGroups.maximumOverlapPart_mem Q (C.map T.toEmbedding)
      ((Finset.map_nonempty).2 hCne) (Finset.subset_univ _)
  have hsource : SoficGroups.partitionComponentSize Q x = C.card :=
    SoficGroups.partitionComponentSize_eq_card_of_mem Q C hC x hx
  have htarget : SoficGroups.partitionComponentSize Q (T x) = D.card :=
    SoficGroups.partitionComponentSize_eq_card_of_mem
      Q D hD (T x) hTx
  have hfloor :
      ⌊(Real.log (C.card : ℝ) + r) / H⌋ =
        ⌊(Real.log (D.card : ℝ) + r) / H⌋ := by
    simpa [SoficGroups.MidrankPermutationEnergy.offsetFloorRank,
      hsource, htarget] using hrank.symm
  have hxpos : (0 : ℝ) < C.card := by
    exact_mod_cast hCne.card_pos
  have hypos : (0 : ℝ) < D.card := by
    exact_mod_cast (Q.nonempty_of_mem_parts hD).card_pos
  exact lt_exp_mul_of_equal_log_floor hxpos hypos hH hfloor

theorem card_symmDiff_add_twice_inter
    {V : Type*} [DecidableEq V] (C D : Finset V) :
    (C ∆ D).card + 2 * (C ∩ D).card = C.card + D.card := by
  have hdis : Disjoint (C \ D) (D \ C) := by
    apply Finset.disjoint_left.mpr
    intro x hx hy
    exact (Finset.mem_sdiff.mp hx).2 (Finset.mem_sdiff.mp hy).1
  have hsym : (C ∆ D).card = (C \ D).card + (D \ C).card := by
    rw [Finset.symmDiff_def, Finset.card_union_of_disjoint hdis]
  have hC := Finset.card_sdiff_add_card_inter C D
  have hD := Finset.card_sdiff_add_card_inter D C
  rw [Finset.inter_comm D C] at hD
  omega

theorem symmDiff_card_lt_of_overlap_and_exp_card
    {V : Type*} [DecidableEq V]
    (C D : Finset V) (H eta : ℝ)
    (hoverlap :
      (1 - eta) * (C.card : ℝ) ≤ ((C ∩ D).card : ℝ))
    (hcard : (D.card : ℝ) < Real.exp H * (C.card : ℝ)) :
    ((C ∆ D).card : ℝ) <
      (Real.exp H - 1 + 2 * eta) * (C.card : ℝ) := by
  have hexact :
      ((C ∆ D).card : ℝ) + 2 * ((C ∩ D).card : ℝ) =
        (C.card : ℝ) + (D.card : ℝ) := by
    exact_mod_cast card_symmDiff_add_twice_inter C D
  nlinarith

theorem target_majority_of_overlap_and_exp_card
    {V : Type*} [DecidableEq V]
    (C D : Finset V) (hC : C.Nonempty) (H eta : ℝ)
    (hoverlap :
      (1 - eta) * (C.card : ℝ) ≤ ((C ∩ D).card : ℝ))
    (hcard : (D.card : ℝ) < Real.exp H * (C.card : ℝ))
    (hsmall : 2 * (Real.exp H - 1 + 2 * eta) < 1) :
    D.card < 2 * (C ∩ D).card := by
  have hbound :=
    symmDiff_card_lt_of_overlap_and_exp_card C D H eta hoverlap hcard
  have hpositive : (0 : ℝ) < C.card := by
    exact_mod_cast hC.card_pos
  have hreal :
      (2 : ℝ) * ((C ∆ D).card : ℝ) < (C.card : ℝ) := by
    calc
      (2 : ℝ) * ((C ∆ D).card : ℝ) <
          2 * ((Real.exp H - 1 + 2 * eta) * (C.card : ℝ)) :=
        mul_lt_mul_of_pos_left hbound (by norm_num)
      _ = (2 * (Real.exp H - 1 + 2 * eta)) * (C.card : ℝ) := by
        ring
      _ < 1 * (C.card : ℝ) :=
        mul_lt_mul_of_pos_right hsmall hpositive
      _ = (C.card : ℝ) := one_mul _
  have hnat : 2 * (C ∆ D).card < C.card := by
    exact_mod_cast hreal
  exact SoficGroups.target_majority_of_small_symmDiff C D hnat

theorem symmDiff_density_tendsto_zero_of_log_rank_bounds
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    (U : ∀ n, Finset (V n)) (hU : ∀ n, (U n).Nonempty)
    (P : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (D : ∀ n, Finset (V n) → Finset (V n))
    (H eta : ℕ → ℝ)
    (hH : ∀ n, 0 ≤ H n) (heta : ∀ n, 0 ≤ eta n)
    (hHzero : Tendsto H atTop (nhds 0))
    (hetazero : Tendsto eta atTop (nhds 0))
    (hbound : ∀ n C, C ∈ R n →
      ((C ∆ D n C).card : ℝ) ≤
        (Real.exp (H n) - 1 + 2 * eta n) * (C.card : ℝ)) :
    Tendsto
      (fun n =>
        ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) / (U n).card)
      atTop (nhds 0) := by
  have hcoeff : Tendsto
      (fun n => Real.exp (H n) - 1 + 2 * eta n)
      atTop (nhds 0) := by
    have hexp : Tendsto (fun n => Real.exp (H n)) atTop (nhds 1) := by
      simpa [Function.comp_def] using
        (Real.continuous_exp.tendsto (0 : ℝ)).comp hHzero
    have hfirst : Tendsto
        (fun n => Real.exp (H n) - 1) atTop (nhds 0) := by
      simpa using hexp.sub_const 1
    have hsecond : Tendsto
        (fun n => (2 : ℝ) * eta n) atTop (nhds 0) := by
      simpa using hetazero.const_mul 2
    simpa only [zero_add] using hfirst.add hsecond
  refine squeeze_zero (fun n => by positivity) ?_ hcoeff
  intro n
  have hpos : (0 : ℝ) < (U n).card := by
    exact_mod_cast (hU n).card_pos
  have hexp : 1 ≤ Real.exp (H n) := by
    simpa using (Real.exp_le_exp.mpr (hH n))
  have hnonneg : 0 ≤ Real.exp (H n) - 1 + 2 * eta n := by
    nlinarith [heta n]
  have hmassnat :
      (∑ C ∈ R n, C.card) ≤ (U n).card := by
    calc
      (∑ C ∈ R n, C.card) =
          (SoficGroups.matchedRetainedSupport (R n)).card :=
        (SoficGroups.matchedRetainedSupport_card
          (P n) (R n) (hR n)).symm
      _ ≤ (U n).card :=
        Finset.card_le_card
          (SoficGroups.matchedRetainedSupport_subset
            (P n) (R n) (hR n))
  have hmass :
      (∑ C ∈ R n, (C.card : ℝ)) ≤ (U n).card := by
    exact_mod_cast hmassnat
  have hsum :
      ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) ≤
        (Real.exp (H n) - 1 + 2 * eta n) *
          (∑ C ∈ R n, (C.card : ℝ)) := by
    calc
      ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) =
          ∑ C ∈ R n, ((C ∆ D n C).card : ℝ) := by
            simp
      _ ≤ ∑ C ∈ R n,
          (Real.exp (H n) - 1 + 2 * eta n) * (C.card : ℝ) := by
            exact Finset.sum_le_sum fun C hC => hbound n C hC
      _ = (Real.exp (H n) - 1 + 2 * eta n) *
          (∑ C ∈ R n, (C.card : ℝ)) := by
            rw [Finset.mul_sum]
  calc
    ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) / (U n).card ≤
        ((Real.exp (H n) - 1 + 2 * eta n) *
          (∑ C ∈ R n, (C.card : ℝ))) / (U n).card :=
      (div_le_div_iff_of_pos_right hpos).2 hsum
    _ ≤ ((Real.exp (H n) - 1 + 2 * eta n) *
          (U n).card) / (U n).card := by
      apply (div_le_div_iff_of_pos_right hpos).2
      exact mul_le_mul_of_nonneg_left hmass hnonneg
    _ = Real.exp (H n) - 1 + 2 * eta n := by
      field_simp

end SourceCompressionMatching

namespace SourceCompressionTransportCrossing

open Filter Topology
open scoped BigOperators

theorem mem_partitionWordCrossing_univ
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (p : Equiv.Perm V) (x : V) :
    x ∈ SoficGroups.partitionWordCrossing Q p ↔
      Q.part x ≠ Q.part (p x) := by
  simp only [SoficGroups.partitionWordCrossing, Finset.mem_filter,
    Finset.mem_univ, true_and]
  rw [Q.mem_part_iff_part_eq_part (Finset.mem_univ _)
    (Finset.mem_univ _)]
  simp [eq_comm]

theorem card_partitionWordCrossing_le_add_distance
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (p q : Equiv.Perm V) :
    (SoficGroups.partitionWordCrossing Q p).card ≤
      (SoficGroups.partitionWordCrossing Q q).card +
        SoficGroups.permutationDistance p q := by
  classical
  have hsub :
      SoficGroups.partitionWordCrossing Q p ⊆
        SoficGroups.partitionWordCrossing Q q ∪
          Finset.univ.filter (fun x : V => p x ≠ q x) := by
    intro x hx
    by_cases heq : p x = q x
    · apply Finset.mem_union_left
      apply (mem_partitionWordCrossing_univ Q q x).2
      have hp := (mem_partitionWordCrossing_univ Q p x).1 hx
      simpa [heq] using hp
    · apply Finset.mem_union_right
      exact Finset.mem_filter.2 ⟨Finset.mem_univ x, heq⟩
  calc
    (SoficGroups.partitionWordCrossing Q p).card ≤
        (SoficGroups.partitionWordCrossing Q q ∪
          Finset.univ.filter (fun x : V => p x ≠ q x)).card :=
      Finset.card_le_card hsub
    _ ≤ (SoficGroups.partitionWordCrossing Q q).card +
        (Finset.univ.filter (fun x : V => p x ≠ q x)).card :=
      Finset.card_union_le _ _
    _ = (SoficGroups.partitionWordCrossing Q q).card +
        SoficGroups.permutationDistance p q := by
      simp [SoficGroups.permutationDistance, hammingDist]

theorem tendsto_action_inverse
    {G : Type*} [Group G] (A : SoficGroups.SoficApproximation G)
    (u : G) :
    Tendsto
      (fun n => SoficGroups.normalizedHamming
        (((A.model n).action u)⁻¹)
        ((A.model n).action (u⁻¹)))
      atTop (nhds 0) := by
  have heq :
      (fun n => SoficGroups.normalizedHamming
        (((A.model n).action u)⁻¹)
        ((A.model n).action (u⁻¹))) =
      (fun n => SoficGroups.normalizedHamming
        ((A.model n).action (u * u⁻¹))
        ((A.model n).action u * (A.model n).action (u⁻¹))) := by
    funext n
    calc
      SoficGroups.normalizedHamming
          (((A.model n).action u)⁻¹)
          ((A.model n).action (u⁻¹)) =
        SoficGroups.normalizedHamming
          ((A.model n).action u * ((A.model n).action u)⁻¹)
          ((A.model n).action u * (A.model n).action (u⁻¹)) :=
        (SoficGroups.normalizedHamming_mul_left
          ((A.model n).action u)
          (((A.model n).action u)⁻¹)
          ((A.model n).action (u⁻¹))).symm
      _ = SoficGroups.normalizedHamming
          ((A.model n).action (u * u⁻¹))
          ((A.model n).action u * (A.model n).action (u⁻¹)) := by
        simp [(A.model n).map_one]
  rw [heq]
  exact A.multiplicative u (u⁻¹)

theorem tendsto_action_conjugate
    {G : Type*} [Group G] (A : SoficGroups.SoficApproximation G)
    (u g : G) :
    Tendsto
      (fun n => SoficGroups.normalizedHamming
        ((A.model n).action (u * g * u⁻¹))
        ((A.model n).action u * (A.model n).action g *
          ((A.model n).action u)⁻¹))
      atTop (nhds 0) := by
  have hbound : ∀ n,
      SoficGroups.normalizedHamming
          ((A.model n).action (u * g * u⁻¹))
          ((A.model n).action u * (A.model n).action g *
            ((A.model n).action u)⁻¹) ≤
        SoficGroups.normalizedHamming
          ((A.model n).action (u * g * u⁻¹))
          ((A.model n).action (u * g) * (A.model n).action (u⁻¹)) +
        (SoficGroups.normalizedHamming
          ((A.model n).action (u * g))
          ((A.model n).action u * (A.model n).action g) +
          SoficGroups.normalizedHamming
            ((A.model n).action (u⁻¹))
            (((A.model n).action u)⁻¹)) := by
    intro n
    calc
      SoficGroups.normalizedHamming
          ((A.model n).action (u * g * u⁻¹))
          ((A.model n).action u * (A.model n).action g *
            ((A.model n).action u)⁻¹) ≤
        SoficGroups.normalizedHamming
          ((A.model n).action (u * g * u⁻¹))
          ((A.model n).action (u * g) * (A.model n).action (u⁻¹)) +
        SoficGroups.normalizedHamming
          ((A.model n).action (u * g) * (A.model n).action (u⁻¹))
          ((A.model n).action u * (A.model n).action g *
            ((A.model n).action u)⁻¹) :=
        SoficGroups.normalizedHamming_triangle _ _ _
      _ ≤ SoficGroups.normalizedHamming
          ((A.model n).action (u * g * u⁻¹))
          ((A.model n).action (u * g) * (A.model n).action (u⁻¹)) +
        (SoficGroups.normalizedHamming
          ((A.model n).action (u * g) * (A.model n).action (u⁻¹))
          (((A.model n).action u * (A.model n).action g) *
            (A.model n).action (u⁻¹)) +
          SoficGroups.normalizedHamming
            (((A.model n).action u * (A.model n).action g) *
              (A.model n).action (u⁻¹))
            (((A.model n).action u * (A.model n).action g) *
              ((A.model n).action u)⁻¹)) := by
        gcongr
        exact SoficGroups.normalizedHamming_triangle _ _ _
      _ = SoficGroups.normalizedHamming
          ((A.model n).action (u * g * u⁻¹))
          ((A.model n).action (u * g) * (A.model n).action (u⁻¹)) +
        (SoficGroups.normalizedHamming
          ((A.model n).action (u * g))
          ((A.model n).action u * (A.model n).action g) +
          SoficGroups.normalizedHamming
            ((A.model n).action (u⁻¹))
            (((A.model n).action u)⁻¹)) := by
        rw [SoficGroups.normalizedHamming_mul_right,
          SoficGroups.normalizedHamming_mul_left]
  apply squeeze_zero
    (fun n => SoficGroups.normalizedHamming_nonneg _ _) hbound
  convert (A.multiplicative (u * g) (u⁻¹)).add
    ((A.multiplicative u g).add
      (tendsto_action_inverse A u)) using 1
  · funext n
    rw [SoficGroups.normalizedHamming_comm
      ((A.model n).action (u⁻¹))
      (((A.model n).action u)⁻¹)]
  · norm_num

theorem conjugated_word_crossing_density_tendsto_zero
    {G : Type*} [Group G] (A : SoficGroups.SoficApproximation G)
    (u g : G)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hword : Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((A.model n).action (u * g * u⁻¹))).card : ℝ) /
            (A.model n).size)
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((A.model n).action u * (A.model n).action g *
            ((A.model n).action u)⁻¹)).card : ℝ) /
              (A.model n).size)
      atTop (nhds 0) := by
  have hdist : Tendsto
      (fun n => SoficGroups.normalizedHamming
        ((A.model n).action u * (A.model n).action g *
          ((A.model n).action u)⁻¹)
        ((A.model n).action (u * g * u⁻¹)))
      atTop (nhds 0) := by
    have heq :
        (fun n => SoficGroups.normalizedHamming
          ((A.model n).action u * (A.model n).action g *
            ((A.model n).action u)⁻¹)
          ((A.model n).action (u * g * u⁻¹))) =
        (fun n => SoficGroups.normalizedHamming
          ((A.model n).action (u * g * u⁻¹))
          ((A.model n).action u * (A.model n).action g *
            ((A.model n).action u)⁻¹)) := by
      funext n
      exact SoficGroups.normalizedHamming_comm _ _
    rw [heq]
    exact tendsto_action_conjugate A u g
  have hupper : Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((A.model n).action (u * g * u⁻¹))).card : ℝ) /
            (A.model n).size +
        SoficGroups.normalizedHamming
          ((A.model n).action u * (A.model n).action g *
            ((A.model n).action u)⁻¹)
          ((A.model n).action (u * g * u⁻¹)))
      atTop (nhds 0) := by
    simpa using hword.add hdist
  refine squeeze_zero (fun n => by positivity) ?_ hupper
  intro n
  have hnat := card_partitionWordCrossing_le_add_distance (Q n)
    ((A.model n).action u * (A.model n).action g *
      ((A.model n).action u)⁻¹)
    ((A.model n).action (u * g * u⁻¹))
  have hreal :
      ((SoficGroups.partitionWordCrossing (Q n)
        ((A.model n).action u * (A.model n).action g *
          ((A.model n).action u)⁻¹)).card : ℝ) ≤
      ((SoficGroups.partitionWordCrossing (Q n)
        ((A.model n).action (u * g * u⁻¹))).card : ℝ) +
      (SoficGroups.permutationDistance
        ((A.model n).action u * (A.model n).action g *
          ((A.model n).action u)⁻¹)
        ((A.model n).action (u * g * u⁻¹)) : ℝ) := by
    exact_mod_cast hnat
  calc
    ((SoficGroups.partitionWordCrossing (Q n)
        ((A.model n).action u * (A.model n).action g *
          ((A.model n).action u)⁻¹)).card : ℝ) /
        (A.model n).size ≤
      (((SoficGroups.partitionWordCrossing (Q n)
        ((A.model n).action (u * g * u⁻¹))).card : ℝ) +
      (SoficGroups.permutationDistance
        ((A.model n).action u * (A.model n).action g *
          ((A.model n).action u)⁻¹)
        ((A.model n).action (u * g * u⁻¹)) : ℝ)) /
          (A.model n).size :=
      div_le_div_of_nonneg_right hreal (by positivity)
    _ = ((SoficGroups.partitionWordCrossing (Q n)
        ((A.model n).action (u * g * u⁻¹))).card : ℝ) /
          (A.model n).size +
      SoficGroups.normalizedHamming
        ((A.model n).action u * (A.model n).action g *
          ((A.model n).action u)⁻¹)
        ((A.model n).action (u * g * u⁻¹)) := by
      simp [add_div, SoficGroups.normalizedHamming,
        SoficGroups.permutationDistance]

end SourceCompressionTransportCrossing

namespace KunResidualRetainedSelection

open Filter Topology
open scoped BigOperators Pointwise symmDiff

theorem exists_matchedRetained_part_boundary_and_bad_density_le
    {V ι : Type*} [DecidableEq V] [Fintype ι]
    (σ : ι → Equiv.Perm V) {U : Finset V}
    (P : Finpartition U) (R : Finset (Finset V))
    (hR : R ⊆ P.parts) (hRne : R.Nonempty) (B : Finset V) :
    ∃ C ∈ R,
      (SoficGroups.boundary σ C : ℝ) / C.card ≤
        ((∑ D ∈ R, (SoficGroups.boundary σ D : ℝ)) +
          ((SoficGroups.matchedRetainedSupport R ∩ B).card : ℝ)) /
            (SoficGroups.matchedRetainedSupport R).card ∧
      ((C ∩ B).card : ℝ) / C.card ≤
        ((∑ D ∈ R, (SoficGroups.boundary σ D : ℝ)) +
          ((SoficGroups.matchedRetainedSupport R ∩ B).card : ℝ)) /
            (SoficGroups.matchedRetainedSupport R).card := by
  let PR := SoficGroups.matchedRetainedFinpartition P R hR
  have hweight : ∀ C ∈ R, 0 < (C.card : ℝ) := by
    intro C hC
    exact_mod_cast (P.nonempty_of_mem_parts (hR hC)).card_pos
  obtain ⟨C, hC, haverage⟩ :=
    SoficGroups.matched_exists_le_weighted_average R hRne
      (fun C : Finset V => (C.card : ℝ))
      (fun C : Finset V => (SoficGroups.boundary σ C : ℝ) +
        ((C ∩ B).card : ℝ)) hweight
  have hbad :
      (∑ D ∈ R, ((D ∩ B).card : ℝ)) =
        ((SoficGroups.matchedRetainedSupport R ∩ B).card : ℝ) := by
    have h := SoficGroups.matched_sum_card_inter_partition PR B
    exact_mod_cast h
  have hmass :
      (∑ D ∈ R, (D.card : ℝ)) =
        ((SoficGroups.matchedRetainedSupport R).card : ℝ) := by
    exact_mod_cast (SoficGroups.matchedRetainedSupport_card P R hR).symm
  have haverage' :
      ((SoficGroups.boundary σ C : ℝ) + ((C ∩ B).card : ℝ)) /
          C.card ≤
        ((∑ D ∈ R, (SoficGroups.boundary σ D : ℝ)) +
          ((SoficGroups.matchedRetainedSupport R ∩ B).card : ℝ)) /
            (SoficGroups.matchedRetainedSupport R).card := by
    simpa only [Finset.sum_add_distrib, hbad, hmass] using haverage
  have hden : (0 : ℝ) ≤ C.card := Nat.cast_nonneg _
  refine ⟨C, hC, ?_, ?_⟩
  · exact (div_le_div_of_nonneg_right
      (le_add_of_nonneg_right (Nat.cast_nonneg (C ∩ B).card)) hden).trans
        haverage'
  · exact (div_le_div_of_nonneg_right
      (le_add_of_nonneg_left
        (Nat.cast_nonneg (SoficGroups.boundary σ C))) hden).trans
        haverage'

theorem matchedRetained_boundary_density_tendsto_zero
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    {ι : Type*} [Fintype ι]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (U : ∀ n, Finset (V n)) (hU : ∀ n, (U n).Nonempty)
    (P : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (hRne : ∀ n, (R n).Nonempty)
    (hdiscard : Tendsto
      (fun n => (((U n \ SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
        (U n).card)) atTop (𝓝 0))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ)) /
          (U n).card) atTop (𝓝 0)) :
    Tendsto
      (fun n =>
        (∑ C ∈ R n, (SoficGroups.boundary (σ n) C : ℝ)) /
          (SoficGroups.matchedRetainedSupport (R n)).card)
      atTop (𝓝 0) := by
  have hcover := SoficGroups.matchedRetainedSupport_cover_density_tendsto_one
    U hU P R hR hdiscard
  have hhalf : ∀ᶠ n in atTop,
      (1 / 2 : ℝ) ≤
        ((SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
          (U n).card :=
    (hcover.eventually (lt_mem_nhds (by norm_num : (1 / 2 : ℝ) < 1))).mono
      fun _ h => h.le
  have htwice : Tendsto
      (fun n =>
        (2 : ℝ) *
          ((∑ C ∈ (P n).parts,
            (SoficGroups.boundary (σ n) C : ℝ)) / (U n).card))
      atTop (𝓝 0) := by
    simpa only [mul_zero] using
      (tendsto_const_nhds.mul hboundary :
        Tendsto
          (fun n =>
            (2 : ℝ) *
              ((∑ C ∈ (P n).parts,
                (SoficGroups.boundary (σ n) C : ℝ)) / (U n).card))
          atTop (𝓝 ((2 : ℝ) * 0)))
  refine squeeze_zero'
    (Eventually.of_forall fun n => by positivity) ?_ htwice
  filter_upwards [hhalf] with n hn
  have hucard : (0 : ℝ) < (U n).card := by
    exact_mod_cast (hU n).card_pos
  have hrcard :
      (0 : ℝ) < (SoficGroups.matchedRetainedSupport (R n)).card := by
    exact_mod_cast
      (SoficGroups.matchedRetainedSupport_nonempty
        (P n) (R n) (hR n) (hRne n)).card_pos
  have hmass :
      ((U n).card : ℝ) ≤
        2 * (SoficGroups.matchedRetainedSupport (R n)).card := by
    have h := (le_div_iff₀ hucard).1 hn
    linarith
  have hsum :
      (∑ C ∈ R n, (SoficGroups.boundary (σ n) C : ℝ)) ≤
        ∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ) := by
    apply Finset.sum_le_sum_of_subset_of_nonneg (hR n)
    intro C _ _
    positivity
  calc
    (∑ C ∈ R n, (SoficGroups.boundary (σ n) C : ℝ)) /
        (SoficGroups.matchedRetainedSupport (R n)).card ≤
      (∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ)) /
        (SoficGroups.matchedRetainedSupport (R n)).card :=
          div_le_div_of_nonneg_right hsum hrcard.le
    _ ≤ 2 *
      ((∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ)) /
        (U n).card) := by
      rw [← mul_div_assoc]
      apply (div_le_div_iff₀ hrcard hucard).2
      simpa [mul_assoc, mul_comm, mul_left_comm] using
        (mul_le_mul_of_nonneg_left hmass
          (Finset.sum_nonneg fun C _ =>
            Nat.cast_nonneg (SoficGroups.boundary (σ n) C)))

theorem exists_matchedRetained_parts_with_vanishing_boundary_and_bad_density
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    {ι : Type*} [Fintype ι]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (U : ∀ n, Finset (V n)) (hU : ∀ n, (U n).Nonempty)
    (P : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (hRne : ∀ n, (R n).Nonempty)
    (hdiscard : Tendsto
      (fun n => (((U n \ SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
        (U n).card)) atTop (𝓝 0))
    (B : ∀ n, Finset (V n))
    (hbad : Tendsto
      (fun n => (((U n ∩ B n).card : ℝ) / (U n).card))
      atTop (𝓝 0))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ)) /
          (U n).card) atTop (𝓝 0)) :
    ∃ C : ∀ n, Finset (V n),
      (∀ n, C n ∈ R n) ∧
        Tendsto
          (fun n => (SoficGroups.boundary (σ n) (C n) : ℝ) / (C n).card)
          atTop (𝓝 0) ∧
        Tendsto
          (fun n => (((C n ∩ B n).card : ℝ) / (C n).card))
          atTop (𝓝 0) := by
  have hretboundary := matchedRetained_boundary_density_tendsto_zero
    σ U hU P R hR hRne hdiscard hboundary
  have hretbad := SoficGroups.matchedRetained_bad_density_tendsto_zero
    U hU P R hR hRne hdiscard B hbad
  have hcombined : Tendsto
      (fun n =>
        ((∑ D ∈ R n, (SoficGroups.boundary (σ n) D : ℝ)) +
          ((SoficGroups.matchedRetainedSupport (R n) ∩ B n).card : ℝ)) /
            (SoficGroups.matchedRetainedSupport (R n)).card)
      atTop (𝓝 0) := by
    simpa only [add_div, add_zero] using hretboundary.add hretbad
  have hchoose (n : ℕ) :=
    exists_matchedRetained_part_boundary_and_bad_density_le
      (σ n) (P n) (R n) (hR n) (hRne n) (B n)
  let C : ∀ n, Finset (V n) := fun n => (hchoose n).choose
  have hC (n : ℕ) : C n ∈ R n := (hchoose n).choose_spec.1
  have hCb (n : ℕ) :
      (SoficGroups.boundary (σ n) (C n) : ℝ) / (C n).card ≤
        ((∑ D ∈ R n, (SoficGroups.boundary (σ n) D : ℝ)) +
          ((SoficGroups.matchedRetainedSupport (R n) ∩ B n).card : ℝ)) /
            (SoficGroups.matchedRetainedSupport (R n)).card :=
    (hchoose n).choose_spec.2.1
  have hCe (n : ℕ) :
      ((C n ∩ B n).card : ℝ) / (C n).card ≤
        ((∑ D ∈ R n, (SoficGroups.boundary (σ n) D : ℝ)) +
          ((SoficGroups.matchedRetainedSupport (R n) ∩ B n).card : ℝ)) /
            (SoficGroups.matchedRetainedSupport (R n)).card :=
    (hchoose n).choose_spec.2.2
  exact ⟨C, hC,
    squeeze_zero (fun n => by positivity) hCb hcombined,
    squeeze_zero (fun n => by positivity) hCe hcombined⟩

theorem exists_matched_slow_diagonal_large_components_with_vanishing_boundary
    {K : Type*} [Group K] [Infinite K] [DecidableEq K]
    (S : Finset K) (hS : 1 ∈ S)
    (hgen : Subgroup.closure (S : Set K) = ⊤)
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    {ι κ : Type*} [Fintype κ]
    (σ : (n : ℕ) → κ → Equiv.Perm (V n))
    (U : ∀ n, Finset (V n)) (hU : ∀ n, (U n).Nonempty)
    (P Q : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (hRne : ∀ n, (R n).Nonempty)
    (D : ∀ n, Finset (V n) → Finset (V n))
    (hD : ∀ n C, C ∈ R n → D n C ∈ (Q n).parts)
    (hmajor : ∀ n C, C ∈ R n →
      (D n C).card < 2 * (C ∩ D n C).card)
    (hdiscard : Tendsto
      (fun n =>
        (((U n \ SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
          (U n).card)) atTop (𝓝 0))
    (hsymm : Tendsto
      (fun n =>
        ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) / (U n).card)
      atTop (𝓝 0))
    (I : ℕ → Finset ι)
    (w : ∀ n, ι → Equiv.Perm (V n))
    (hword : ∀ k, Tendsto
      (fun n =>
        ((∑ i ∈ I k,
          (SoficGroups.partitionWordCrossing (Q n) (w n i)).card : ℕ) :
            ℝ) / (U n).card)
      atTop (𝓝 0))
    (B : ∀ n, ℕ → Finset (V n))
    (hbad : ∀ k, Tendsto
      (fun n => (((U n ∩ B n k).card : ℝ) / (U n).card))
      atTop (𝓝 0))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ)) /
          (U n).card) atTop (𝓝 0))
    (hrealize : ∀ n k (C : Finset (V n)), C ∈ R n →
      ∀ x ∈ C,
        x ∉ SoficGroups.matchedRadiusBad
          (P n) (I k) (w n) (B n k) →
          ∃ f : K → V n,
            Set.MapsTo f (↑(S ^ (k / 2)) : Set K) (↑C : Set (V n)) ∧
              Set.InjOn f (↑(S ^ (k / 2)) : Set K)) :
    ∃ (r : ℕ → ℕ) (C : ∀ n, Finset (V n)),
      Tendsto r atTop atTop ∧
        (∀ n, C n ∈ R n) ∧
        Tendsto
          (fun n =>
            (SoficGroups.boundary (σ n) (C n) : ℝ) / (C n).card)
          atTop (𝓝 0) ∧
        Tendsto
          (fun n =>
            (((C n ∩
              SoficGroups.matchedRadiusBad
                (P n) (I (r n)) (w n) (B n (r n))).card : ℝ) /
                  (C n).card))
          atTop (𝓝 0) ∧
        Tendsto (fun n => (C n).card) atTop atTop := by
  obtain ⟨r, hr, herror⟩ :=
    SoficGroups.exists_matched_slow_diagonal_word_errors
      U P Q R hR D hD hmajor hdiscard hsymm I w hword B hbad
  let B' : ∀ n, Finset (V n) := fun n =>
    SoficGroups.matchedRadiusBad (P n) (I (r n)) (w n) (B n (r n))
  have hB' : Tendsto
      (fun n => (((U n ∩ B' n).card : ℝ) / (U n).card))
      atTop (𝓝 0) := by
    refine squeeze_zero (fun n => by positivity) ?_ herror
    intro n
    have hcard :
        ((U n ∩ B' n).card : ℝ) ≤
          ((∑ i ∈ I (r n),
            (SoficGroups.partitionWordCrossing
              (P n) (w n i)).card : ℕ) : ℝ) +
            ((U n ∩ B n (r n)).card : ℝ) := by
      have h := SoficGroups.matchedRadiusBad_card_le
        (P n) (I (r n)) (w n) (B n (r n))
      have h' :
          (U n ∩
            SoficGroups.matchedRadiusBad
              (P n) (I (r n)) (w n) (B n (r n))).card ≤
                (∑ i ∈ I (r n),
                  (SoficGroups.partitionWordCrossing
                    (P n) (w n i)).card) +
                  (U n ∩ B n (r n)).card := by
        omega
      dsimp [B']
      exact_mod_cast h'
    exact div_le_div_of_nonneg_right hcard (by positivity)
  obtain ⟨C, hC, hCboundary, hCerror⟩ :=
    exists_matchedRetained_parts_with_vanishing_boundary_and_bad_density
      σ U hU P R hR hRne hdiscard B' hB' hboundary
  have hCnonempty (n : ℕ) : (C n).Nonempty :=
    (P n).nonempty_of_mem_parts (hR n (hC n))
  have hgood : ∀ᶠ n in atTop, ∃ x ∈ C n, x ∉ B' n :=
    SoficGroups.matched_eventually_exists_good_vertex
      C B' hCnonempty hCerror
  have hhalf : Tendsto (fun n => r n / 2) atTop atTop :=
    (Nat.tendsto_div_const_atTop (by norm_num : (2 : ℕ) ≠ 0)).comp hr
  have hclosure :
      (Subgroup.closure (S : Set K) : Set K).Infinite := by
    simpa [hgen] using (Set.infinite_univ (α := K))
  have hlarge : Tendsto (fun n => (C n).card) atTop atTop := by
    refine tendsto_atTop_mono' atTop ?_ hhalf
    filter_upwards [hgood] with n hn
    obtain ⟨x, hx, hx'⟩ := hn
    obtain ⟨f, hf, hfinj⟩ :=
      hrealize n (r n) (C n) (hC n) x hx hx'
    exact (Nat.le_succ (r n / 2)).trans
      ((Finset.add_one_le_card_pow hS hclosure (r n / 2)).trans
        (Finset.card_le_card_of_injOn f hf hfinj))
  exact ⟨r, C, hr, hC, hCboundary, hCerror, hlarge⟩

theorem matchedRetained_parts_eventually_nonempty_of_discard
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    (U : ∀ n, Finset (V n)) (hU : ∀ n, (U n).Nonempty)
    (R : ∀ n, Finset (Finset (V n)))
    (hdiscard : Tendsto
      (fun n =>
        (((U n \ SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
          (U n).card)) atTop (𝓝 0)) :
    ∀ᶠ n in atTop, (R n).Nonempty := by
  filter_upwards [hdiscard.eventually (gt_mem_nhds zero_lt_one)] with n hn
  by_contra hR
  have hrempty : R n = ∅ := Finset.not_nonempty_iff_eq_empty.mp hR
  have hucard : ((U n).card : ℝ) ≠ 0 := by
    exact_mod_cast (hU n).card_pos.ne'
  have hsupport : SoficGroups.matchedRetainedSupport (R n) = ∅ := by
    simp [SoficGroups.matchedRetainedSupport, hrempty]
  simp only [hsupport, Finset.sdiff_empty] at hn
  rw [div_self hucard] at hn
  exact (lt_irrefl (1 : ℝ)) hn

theorem exists_matched_slow_diagonal_large_components_on_guarded_tail
    {K : Type*} [Group K] [Infinite K] [DecidableEq K]
    (S : Finset K) (hS : 1 ∈ S)
    (hgen : Subgroup.closure (S : Set K) = ⊤)
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    {ι κ : Type*} [Fintype κ]
    (σ : (n : ℕ) → κ → Equiv.Perm (V n))
    (U : ∀ n, Finset (V n)) (hU : ∀ n, (U n).Nonempty)
    (P Q : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (D : ∀ n, Finset (V n) → Finset (V n))
    (hD : ∀ n C, C ∈ R n → D n C ∈ (Q n).parts)
    (guard : ℕ → Prop)
    (hguard : ∀ᶠ n in atTop, guard n)
    (hmajor : ∀ n, guard n → ∀ C, C ∈ R n →
      (D n C).card < 2 * (C ∩ D n C).card)
    (hdiscard : Tendsto
      (fun n =>
        (((U n \ SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
          (U n).card)) atTop (𝓝 0))
    (hsymm : Tendsto
      (fun n =>
        ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) /
          (U n).card)
      atTop (𝓝 0))
    (I : ℕ → Finset ι)
    (w : ∀ n, ι → Equiv.Perm (V n))
    (hword : ∀ k, Tendsto
      (fun n =>
        ((∑ i ∈ I k,
          (SoficGroups.partitionWordCrossing (Q n) (w n i)).card :
            ℕ) : ℝ) / (U n).card)
      atTop (𝓝 0))
    (B : ∀ n, ℕ → Finset (V n))
    (hbad : ∀ k, Tendsto
      (fun n => (((U n ∩ B n k).card : ℝ) / (U n).card))
      atTop (𝓝 0))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ)) /
          (U n).card) atTop (𝓝 0))
    (hrealize : ∀ n k (C : Finset (V n)), C ∈ R n →
      ∀ x ∈ C,
        x ∉ SoficGroups.matchedRadiusBad
          (P n) (I k) (w n) (B n k) →
          ∃ f : K → V n,
            Set.MapsTo f (↑(S ^ (k / 2)) : Set K)
              (↑C : Set (V n)) ∧
              Set.InjOn f (↑(S ^ (k / 2)) : Set K))
    (N₀ : ℕ) :
    ∃ (N : ℕ) (r : ℕ → ℕ)
      (C : (n : ℕ) → Finset (V (n + N))),
      N₀ ≤ N ∧
        (∀ n, guard (n + N)) ∧
        Tendsto r atTop atTop ∧
        (∀ n, C n ∈ R (n + N)) ∧
        Tendsto
          (fun n =>
            (SoficGroups.boundary (σ (n + N)) (C n) : ℝ) /
              (C n).card)
          atTop (𝓝 0) ∧
        Tendsto
          (fun n =>
            (((C n ∩
              SoficGroups.matchedRadiusBad
                (P (n + N)) (I (r n)) (w (n + N))
                (B (n + N) (r n))).card : ℝ) /
                  (C n).card))
          atTop (𝓝 0) ∧
        Tendsto (fun n => (C n).card) atTop atTop := by
  have hretained :=
    matchedRetained_parts_eventually_nonempty_of_discard
      U hU R hdiscard
  obtain ⟨N₁, hN₁⟩ :=
    eventually_atTop.1 (hretained.and hguard)
  let N : ℕ := max N₀ N₁
  have htail (n : ℕ) :
      (R (n + N)).Nonempty ∧ guard (n + N) :=
    hN₁ (n + N) (by dsimp [N]; omega)
  have hshift : Tendsto (fun n : ℕ => n + N) atTop atTop :=
    tendsto_add_atTop_nat N
  have hdiscard' : Tendsto
      (fun n =>
        (((U (n + N) \
          SoficGroups.matchedRetainedSupport (R (n + N))).card : ℝ) /
            (U (n + N)).card))
      atTop (𝓝 0) := by
    simpa only [Function.comp_def] using hdiscard.comp hshift
  have hsymm' : Tendsto
      (fun n =>
        ((∑ C ∈ R (n + N),
          (C ∆ D (n + N) C).card : ℕ) : ℝ) /
            (U (n + N)).card)
      atTop (𝓝 0) := by
    simpa only [Function.comp_def] using hsymm.comp hshift
  have hword' (k : ℕ) : Tendsto
      (fun n =>
        ((∑ i ∈ I k,
          (SoficGroups.partitionWordCrossing
            (Q (n + N)) (w (n + N) i)).card : ℕ) : ℝ) /
              (U (n + N)).card)
      atTop (𝓝 0) := by
    simpa only [Function.comp_def] using (hword k).comp hshift
  have hbad' (k : ℕ) : Tendsto
      (fun n =>
        (((U (n + N) ∩ B (n + N) k).card : ℝ) /
          (U (n + N)).card))
      atTop (𝓝 0) := by
    simpa only [Function.comp_def] using (hbad k).comp hshift
  have hboundary' : Tendsto
      (fun n =>
        (∑ C ∈ (P (n + N)).parts,
          (SoficGroups.boundary (σ (n + N)) C : ℝ)) /
            (U (n + N)).card)
      atTop (𝓝 0) := by
    simpa only [Function.comp_def] using hboundary.comp hshift
  obtain ⟨r, C, hr, hC, hCboundary, hCbad, hClarge⟩ :=
    exists_matched_slow_diagonal_large_components_with_vanishing_boundary
      S hS hgen
      (fun n => σ (n + N))
      (fun n => U (n + N))
      (fun n => hU (n + N))
      (fun n => P (n + N))
      (fun n => Q (n + N))
      (fun n => R (n + N))
      (fun n => hR (n + N))
      (fun n => (htail n).1)
      (fun n C => D (n + N) C)
      (fun n C hC => hD (n + N) C hC)
      (fun n C hC => hmajor (n + N) (htail n).2 C hC)
      hdiscard' hsymm' I
      (fun n => w (n + N))
      hword'
      (fun n k => B (n + N) k)
      hbad' hboundary'
      (fun n k C hC x hx hx' =>
        hrealize (n + N) k C hC x hx hx')
  refine ⟨N, r, C, ?_, (fun n => (htail n).2), hr, hC,
    hCboundary, hCbad, hClarge⟩
  exact le_max_left _ _

theorem source_compression_scale_guard_eventually
    (H eta : ℕ → ℝ)
    (hH : Tendsto H atTop (𝓝 0))
    (heta : Tendsto eta atTop (𝓝 0)) :
    ∀ᶠ n in atTop,
      eta n ≤ (1 : ℝ) / 2 ∧
        2 * (Real.exp (H n) - 1 + 2 * eta n) < 1 := by
  have hhalf : ∀ᶠ n in atTop, eta n ≤ (1 : ℝ) / 2 :=
    (heta.eventually (gt_mem_nhds (by norm_num :
      (0 : ℝ) < (1 : ℝ) / 2))).mono fun _ h => h.le
  have hexp : Tendsto
      (fun n => Real.exp (H n)) atTop (𝓝 1) := by
    simpa only [Function.comp_def, Real.exp_zero] using
      (Real.continuous_exp.tendsto (0 : ℝ)).comp hH
  have hinner : Tendsto
      (fun n => Real.exp (H n) - 1 + 2 * eta n)
      atTop (𝓝 0) := by
    have htwo : Tendsto
        (fun n => (2 : ℝ) * eta n) atTop (𝓝 0) := by
      simpa only [mul_zero] using
        ((tendsto_const_nhds :
          Tendsto (fun _ : ℕ => (2 : ℝ)) atTop (𝓝 2)).mul heta)
    have hone : Tendsto
        (fun _ : ℕ => (1 : ℝ)) atTop (𝓝 1) :=
      tendsto_const_nhds
    simpa only [sub_self, add_zero] using (hexp.sub hone).add htwo
  have hsmallLimit : Tendsto
      (fun n => (2 : ℝ) * (Real.exp (H n) - 1 + 2 * eta n))
      atTop (𝓝 0) := by
    simpa only [mul_zero] using
      ((tendsto_const_nhds :
        Tendsto (fun _ : ℕ => (2 : ℝ)) atTop (𝓝 2)).mul hinner)
  exact hhalf.and
    (hsmallLimit.eventually (gt_mem_nhds zero_lt_one))

theorem exists_matched_slow_diagonal_large_components_on_source_scale_tail
    {K : Type*} [Group K] [Infinite K] [DecidableEq K]
    (S : Finset K) (hS : 1 ∈ S)
    (hgen : Subgroup.closure (S : Set K) = ⊤)
    {V : ℕ → Type*} [∀ n, DecidableEq (V n)]
    {ι κ : Type*} [Fintype κ]
    (σ : (n : ℕ) → κ → Equiv.Perm (V n))
    (U : ∀ n, Finset (V n)) (hU : ∀ n, (U n).Nonempty)
    (P Q : ∀ n, Finpartition (U n))
    (R : ∀ n, Finset (Finset (V n)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (D : ∀ n, Finset (V n) → Finset (V n))
    (hD : ∀ n C, C ∈ R n → D n C ∈ (Q n).parts)
    (H eta : ℕ → ℝ)
    (hH : Tendsto H atTop (𝓝 0))
    (heta : Tendsto eta atTop (𝓝 0))
    (hmajor : ∀ n,
      eta n ≤ (1 : ℝ) / 2 →
      2 * (Real.exp (H n) - 1 + 2 * eta n) < 1 →
        ∀ C, C ∈ R n →
          (D n C).card < 2 * (C ∩ D n C).card)
    (hdiscard : Tendsto
      (fun n =>
        (((U n \ SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
          (U n).card)) atTop (𝓝 0))
    (hsymm : Tendsto
      (fun n =>
        ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) /
          (U n).card)
      atTop (𝓝 0))
    (I : ℕ → Finset ι)
    (w : ∀ n, ι → Equiv.Perm (V n))
    (hword : ∀ k, Tendsto
      (fun n =>
        ((∑ i ∈ I k,
          (SoficGroups.partitionWordCrossing (Q n) (w n i)).card :
            ℕ) : ℝ) / (U n).card)
      atTop (𝓝 0))
    (B : ∀ n, ℕ → Finset (V n))
    (hbad : ∀ k, Tendsto
      (fun n => (((U n ∩ B n k).card : ℝ) / (U n).card))
      atTop (𝓝 0))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ)) /
          (U n).card) atTop (𝓝 0))
    (hrealize : ∀ n k (C : Finset (V n)), C ∈ R n →
      ∀ x ∈ C,
        x ∉ SoficGroups.matchedRadiusBad
          (P n) (I k) (w n) (B n k) →
          ∃ f : K → V n,
            Set.MapsTo f (↑(S ^ (k / 2)) : Set K)
              (↑C : Set (V n)) ∧
              Set.InjOn f (↑(S ^ (k / 2)) : Set K))
    (N₀ : ℕ) :
    ∃ (N : ℕ) (r : ℕ → ℕ)
      (C : (n : ℕ) → Finset (V (n + N))),
      N₀ ≤ N ∧
        (∀ n, eta (n + N) ≤ (1 : ℝ) / 2) ∧
        (∀ n,
          2 * (Real.exp (H (n + N)) - 1 +
            2 * eta (n + N)) < 1) ∧
        Tendsto r atTop atTop ∧
        (∀ n, C n ∈ R (n + N)) ∧
        Tendsto
          (fun n =>
            (SoficGroups.boundary (σ (n + N)) (C n) : ℝ) /
              (C n).card)
          atTop (𝓝 0) ∧
        Tendsto
          (fun n =>
            (((C n ∩
              SoficGroups.matchedRadiusBad
                (P (n + N)) (I (r n)) (w (n + N))
                (B (n + N) (r n))).card : ℝ) /
                  (C n).card))
          atTop (𝓝 0) ∧
        Tendsto (fun n => (C n).card) atTop atTop := by
  let guard : ℕ → Prop := fun n =>
    eta n ≤ (1 : ℝ) / 2 ∧
      2 * (Real.exp (H n) - 1 + 2 * eta n) < 1
  have hguard : ∀ᶠ n in atTop, guard n :=
    source_compression_scale_guard_eventually H eta hH heta
  obtain ⟨N, r, C, hN, hg, hr, hC, hCboundary, hCbad, hClarge⟩ :=
    exists_matched_slow_diagonal_large_components_on_guarded_tail
      S hS hgen σ U hU P Q R hR D hD guard hguard
      (fun n hn C hC => hmajor n hn.1 hn.2 C hC)
      hdiscard hsymm I w hword B hbad hboundary hrealize N₀
  exact ⟨N, r, C, hN,
    (fun n => (hg n).1), (fun n => (hg n).2),
    hr, hC, hCboundary, hCbad, hClarge⟩

end KunResidualRetainedSelection

namespace KunUniversalGoodRootReferenceCuts

open scoped symmDiff

theorem reference_difference_le_symmDiff_add_missing
    {α : Type*} [DecidableEq α]
    (U T W : Finset α) (hsub : T ⊆ W) :
    (U \ W).card + (W \ U).card ≤
      (U ∆ T).card + (W \ T).card := by
  have hdisjoint : Disjoint (U \ W) (W \ U) :=
    Finset.disjoint_of_subset_right Finset.sdiff_subset
      Finset.sdiff_disjoint
  have htw : (T ∆ W).card = (W \ T).card := by
    rw [Finset.symmDiff_def,
      Finset.sdiff_eq_empty_iff_subset.mpr hsub,
      Finset.empty_union]
  calc
    (U \ W).card + (W \ U).card = (U ∆ W).card := by
      rw [Finset.symmDiff_def,
        Finset.card_union_of_disjoint hdisjoint]
    _ ≤ ((U ∆ T) ∪ (T ∆ W)).card :=
      Finset.card_le_card (symmDiff_triangle U T W)
    _ ≤ (U ∆ T).card + (T ∆ W).card :=
      Finset.card_union_le _ _
    _ = (U ∆ T).card + (W \ T).card := by rw [htw]

theorem reference_difference_le_of_good_root_threshold
    {V ι : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (p : Equiv.Perm V)
    (B : Finset V) (T U : Finset (V × V))
    (t : ℕ) (q : ℝ) (hq : q < 1)
    (hsub : T ⊆ SoficGroups.permutationGraph p)
    (hmissing :
      (SoficGroups.permutationGraph p \ T).card ≤ 2 * B.card)
    (hbad :
      2 * (Fintype.card ι : ℝ) * (B.card : ℝ) ≤ (t : ℝ))
    (hdefect : SoficGroups.permutationCommutationDefect σ p ≤ 2 * t)
    (hboundary :
      SoficGroups.boundary (fun i => (σ i).prodCongr (σ i)) T ≤
        SoficGroups.permutationCommutationDefect σ p +
          2 * Fintype.card ι * B.card)
    (hthreshold :
      ((U ∆ T).card : ℝ) ≤
        72 * (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) T : ℝ) /
            ((Fintype.card ι : ℝ) * (1 - q) ^ 2)) :
    (((U \ SoficGroups.permutationGraph p).card +
      (SoficGroups.permutationGraph p \ U).card : ℕ) : ℝ) ≤
        (216 / ((Fintype.card ι : ℝ) * (1 - q) ^ 2) +
          1 / (Fintype.card ι : ℝ)) * (t : ℝ) := by
  have hd : 0 < (Fintype.card ι : ℝ) := by
    exact_mod_cast Fintype.card_pos_iff.mpr
      (inferInstance : Nonempty ι)
  have hden : 0 < (Fintype.card ι : ℝ) * (1 - q) ^ 2 :=
    mul_pos hd (sq_pos_of_pos (sub_pos.mpr hq))
  have hdefect_real :
      (SoficGroups.permutationCommutationDefect σ p : ℝ) ≤
        2 * (t : ℝ) := by
    exact_mod_cast hdefect
  have hboundary_real :
      (SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) T : ℝ) ≤
          3 * (t : ℝ) := by
    have hbound :
        (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) T : ℝ) ≤
            (SoficGroups.permutationCommutationDefect σ p : ℝ) +
              2 * (Fintype.card ι : ℝ) * (B.card : ℝ) := by
      exact_mod_cast hboundary
    linarith
  have hmissing_real :
      ((SoficGroups.permutationGraph p \ T).card : ℝ) ≤
        (t : ℝ) / (Fintype.card ι : ℝ) := by
    have hm :
        ((SoficGroups.permutationGraph p \ T).card : ℝ) ≤
          2 * (B.card : ℝ) := by
      exact_mod_cast hmissing
    apply (le_div_iff₀ hd).2
    nlinarith
  have htransfer :
      (((U \ SoficGroups.permutationGraph p).card +
        (SoficGroups.permutationGraph p \ U).card : ℕ) : ℝ) ≤
          ((U ∆ T).card : ℝ) +
            ((SoficGroups.permutationGraph p \ T).card : ℝ) := by
    exact_mod_cast reference_difference_le_symmDiff_add_missing
      U T (SoficGroups.permutationGraph p) hsub
  calc
    (((U \ SoficGroups.permutationGraph p).card +
      (SoficGroups.permutationGraph p \ U).card : ℕ) : ℝ) ≤
        ((U ∆ T).card : ℝ) +
          ((SoficGroups.permutationGraph p \ T).card : ℝ) := htransfer
    _ ≤ 72 * (SoficGroups.boundary
          (fun i => (σ i).prodCongr (σ i)) T : ℝ) /
            ((Fintype.card ι : ℝ) * (1 - q) ^ 2) +
          (t : ℝ) / (Fintype.card ι : ℝ) :=
      add_le_add hthreshold hmissing_real
    _ ≤ 72 * (3 * (t : ℝ)) /
          ((Fintype.card ι : ℝ) * (1 - q) ^ 2) +
          (t : ℝ) / (Fintype.card ι : ℝ) := by
      gcongr
    _ = (216 / ((Fintype.card ι : ℝ) * (1 - q) ^ 2) +
          1 / (Fintype.card ι : ℝ)) * (t : ℝ) := by
      ring

private theorem rooted_reference_cut_bounds_of_slow_tolerance
    {h d C t N Δ u e : ℝ}
    (hh : 0 < h) (hd : 0 ≤ d) (hC : 0 ≤ C)
    (ht : 0 ≤ t) (hN : 0 < N)
    (hdifference : Δ ≤ C * t)
    (hcard : u ≤ N + Δ)
    (hboundary : e ≤ (h * t / (2 * (h + 8 * d) * N)) * u)
    (hslow : 5 * (4 + h * C) * t ≤ h * N) :
    2 * Δ ≤ N ∧
      (h + 8 * d) * e ≤ h * t ∧
      5 * (4 * e + h * Δ) ≤ h * N := by
  have hden : 0 < h + 8 * d := by nlinarith
  have hCt : 5 * (C * t) ≤ N := by
    have hscaled : h * (5 * (C * t)) ≤ h * N := by
      nlinarith [mul_nonneg (by norm_num : (0 : ℝ) ≤ 20) ht]
    exact le_of_mul_le_mul_left hscaled hh
  have hCtzero : 0 ≤ C * t := mul_nonneg hC ht
  have hnear : 2 * Δ ≤ N := by nlinarith
  have hu : u ≤ 2 * N := by nlinarith
  have hcoefficient : 0 ≤ h * t / (2 * (h + 8 * d) * N) := by
    positivity
  have he : e ≤ h * t / (h + 8 * d) := by
    calc
      e ≤ (h * t / (2 * (h + 8 * d) * N)) * u := hboundary
      _ ≤ (h * t / (2 * (h + 8 * d) * N)) * (2 * N) :=
        mul_le_mul_of_nonneg_left hu hcoefficient
      _ = h * t / (h + 8 * d) := by field_simp
  have himprovement : (h + 8 * d) * e ≤ h * t := by
    have he' := (le_div_iff₀ hden).mp he
    nlinarith
  have het : e ≤ t := by
    calc
      e ≤ h * t / (h + 8 * d) := he
      _ ≤ t := (div_le_iff₀ hden).2 (by nlinarith)
  refine ⟨hnear, himprovement, ?_⟩
  calc
    5 * (4 * e + h * Δ) ≤ 5 * (4 * t + h * (C * t)) := by
      gcongr
    _ = 5 * (4 + h * C) * t := by ring
    _ ≤ h * N := hslow

theorem hasAlmostCentralizerImprovement_of_universal_good_root_thresholds
    {V ι : Type*}
    [Fintype V] [Nonempty V] [DecidableEq V]
    [Fintype ι] [Nonempty ι]
    (σ : ι → Equiv.Perm V) (tolerance : ℕ)
    (h q : ℝ) (hpositive : 0 < h) (hq : q < 1)
    (B : Finset V)
    (good : Equiv.Perm V → Finset (V × V))
    (hexp : ∀ A : Finset V,
      h * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ))
    (hbad :
      2 * (Fintype.card ι : ℝ) * (B.card : ℝ) ≤
        (tolerance : ℝ))
    (hgood_subset : ∀ p : Equiv.Perm V,
      good p ⊆ SoficGroups.permutationGraph p)
    (hgood_missing : ∀ p : Equiv.Perm V,
      (SoficGroups.permutationGraph p \ good p).card ≤
        2 * B.card)
    (hgood_boundary : ∀ p : Equiv.Perm V,
      SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) (good p) ≤
          SoficGroups.permutationCommutationDefect σ p +
            2 * Fintype.card ι * B.card)
    (hslow :
      5 * (4 + h *
        (216 / ((Fintype.card ι : ℝ) * (1 - q) ^ 2) +
          1 / (Fintype.card ι : ℝ))) * (tolerance : ℝ) ≤
            h * (Fintype.card V : ℝ))
    (hthreshold : ∀ p : Equiv.Perm V,
      SoficGroups.permutationCommutationDefect σ p ≤ 2 * tolerance →
        ∃ U : Finset (V × V),
          ((U ∆ good p).card : ℝ) ≤
            72 * (SoficGroups.boundary
              (fun i => (σ i).prodCongr (σ i)) (good p) : ℝ) /
                ((Fintype.card ι : ℝ) * (1 - q) ^ 2) ∧
          (SoficGroups.boundary
            (fun i => (σ i).prodCongr (σ i)) U : ℝ) ≤
              (h * (tolerance : ℝ) /
                (2 * (h + 8 * (Fintype.card ι : ℝ)) *
                  (Fintype.card V : ℝ))) * (U.card : ℝ)) :
    SoficGroups.HasAlmostCentralizerImprovement σ tolerance := by
  let d : ℝ := Fintype.card ι
  let C : ℝ := 216 / (d * (1 - q) ^ 2) + 1 / d
  have hd : 0 < d := by
    dsimp [d]
    exact_mod_cast Fintype.card_pos_iff.mpr
      (inferInstance : Nonempty ι)
  have hC : 0 ≤ C := by
    dsimp [C]
    positivity
  apply SoficGroups.KunThomFiberCoarea.hasAlmostCentralizerImprovement_of_rooted_reference_cuts
    σ tolerance h hpositive hexp
  intro p hp
  obtain ⟨U, hnear_good, hboundary⟩ := hthreshold p hp
  have hdifference :
      (((U \ SoficGroups.permutationGraph p).card +
        (SoficGroups.permutationGraph p \ U).card : ℕ) : ℝ) ≤
          C * (tolerance : ℝ) := by
    simpa only [C, d] using
      reference_difference_le_of_good_root_threshold
        σ p B (good p) U tolerance q hq
        (hgood_subset p) (hgood_missing p)
        hbad hp (hgood_boundary p) hnear_good
  have hN : 0 < (Fintype.card V : ℝ) := by
    exact_mod_cast Fintype.card_pos_iff.mpr
      (inferInstance : Nonempty V)
  have hcardnat :
      U.card ≤ Fintype.card V +
        ((U \ SoficGroups.permutationGraph p).card +
          (SoficGroups.permutationGraph p \ U).card) := by
    have hinter := Finset.card_sdiff_add_card_inter
      U (SoficGroups.permutationGraph p)
    have hsubset :
        (U ∩ SoficGroups.permutationGraph p).card ≤
          (SoficGroups.permutationGraph p).card :=
      Finset.card_le_card Finset.inter_subset_right
    have hgraph := SoficGroups.KunThomFiberCoarea.permutationGraph_card p
    omega
  have hcard :
      (U.card : ℝ) ≤ (Fintype.card V : ℝ) +
        (((U \ SoficGroups.permutationGraph p).card +
          (SoficGroups.permutationGraph p \ U).card : ℕ) : ℝ) := by
    exact_mod_cast hcardnat
  have hslow' :
      5 * (4 + h * C) * (tolerance : ℝ) ≤
        h * (Fintype.card V : ℝ) := by
    simpa only [C, d] using hslow
  have hboundary' :
      (SoficGroups.boundary
        (fun i => (σ i).prodCongr (σ i)) U : ℝ) ≤
        (h * (tolerance : ℝ) /
          (2 * (h + 8 * d) * (Fintype.card V : ℝ))) *
            (U.card : ℝ) := by
    simpa only [d] using hboundary
  obtain ⟨hnear, himprovement, hdistance⟩ :=
    rooted_reference_cut_bounds_of_slow_tolerance
      hpositive hd.le hC (Nat.cast_nonneg tolerance) hN
      hdifference hcard hboundary' hslow'
  refine ⟨U, ?_, ?_, ?_⟩
  · exact_mod_cast hnear
  · simpa only [d] using himprovement
  · have hleft :
        ((U \ SoficGroups.permutationGraph p).card : ℝ) ≤
          (((U \ SoficGroups.permutationGraph p).card +
            (SoficGroups.permutationGraph p \ U).card : ℕ) : ℝ) := by
      exact_mod_cast Nat.le_add_right
        (U \ SoficGroups.permutationGraph p).card
        (SoficGroups.permutationGraph p \ U).card
    nlinarith [mul_nonneg hpositive.le
      (sub_nonneg.mpr hleft)]

end KunUniversalGoodRootReferenceCuts

namespace KunRootedWordPower

open Filter Topology
open SoficGroups.KunRootedIndicatorCrossing
open SoficGroups.KunThomInvariantOrthogonal
open scoped BigOperators ComplexConjugate ComplexOrder InnerProductSpace Pointwise symmDiff

universe u

local instance rootedSparseModelDecidableEq
    {G ι : Type u} (X : RootedIndicatorMarkovModel G ι) :
    DecidableEq X.carrier :=
  Classical.decEq X.carrier

theorem exists_rooted_word_radius_real_markov_sq_error_le_boundary
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, u} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (w : G → List ↥S)
    (k : ℕ) :
    ∃ r : ℕ, ∀ X : RootedIndicatorMarkovModel G ↥S,
      X.IsGenerated (fun i : ↥S => (i : G)) w →
      X.IsRootedAtRadius w r →
      ∀ T : Finset X.carrier,
        (∀ x : X.carrier,
          X.indicator x = if x ∈ T then (1 : ℝ) else 0) →
        (∑ x : X.carrier,
          ((((SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov
              X.generator)^[k])
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)) x -
              if x ∈ T then (1 : ℝ) else 0) ^ 2) ≤
          8 * (SoficGroups.boundary X.generator T : ℝ) /
            ((S.card : ℝ) *
              (1 - kazhdanMarkovContractionFactor P S) ^ 2) := by
  letI : Nonempty (↥S) := ⟨⟨1, honeS⟩⟩
  let q := kazhdanMarkovContractionFactor P S
  have hgap : 0 < 1 - q :=
    sub_pos.mpr
      (kazhdanMarkovContractionFactor_lt_one P S ⟨1, honeS⟩)
  have hdegree : 0 < (S.card : ℝ) := by
    exact_mod_cast Finset.card_pos.mpr ⟨1, honeS⟩
  obtain ⟨r, hr⟩ :=
    exists_rooted_word_radius_geometric_markov_displacement
      P S honeS hcover hsymmetric w k
  refine ⟨r, ?_⟩
  intro X hgenerated hroot T hindicator
  let χ : X.carrier → ℝ :=
    SoficGroups.KunFinitePermutationMarkovMass.realIndicator T
  have hχ : X.indicator = χ := by
    funext x
    simpa [χ,
      SoficGroups.KunFinitePermutationMarkovMass.realIndicator]
      using hindicator x
  have hgeo := hr X hgenerated hroot
  rw [hχ] at hgeo
  have hjensen :
      ‖permutationMarkov X.generator (indicatorVector χ) -
        indicatorVector χ‖ ^ 2 ≤
        2 * (SoficGroups.boundary X.generator T : ℝ) /
          (S.card : ℝ) := by
    simpa [χ, Fintype.card_coe] using
      rooted_indicator_defect_sq_le_boundary X.generator T
  have hcoef : 0 ≤ 2 / (1 - q) :=
    div_nonneg (by norm_num) hgap.le
  have hsquare :
      ‖((permutationMarkov X.generator)^[k])
          (indicatorVector χ) - indicatorVector χ‖ ^ 2 ≤
        (2 / (1 - q)) ^ 2 *
          ‖permutationMarkov X.generator (indicatorVector χ) -
            indicatorVector χ‖ ^ 2 := by
    calc
      ‖((permutationMarkov X.generator)^[k])
          (indicatorVector χ) - indicatorVector χ‖ ^ 2 ≤
        ((2 / (1 - q)) *
          ‖permutationMarkov X.generator (indicatorVector χ) -
            indicatorVector χ‖) ^ 2 :=
        (sq_le_sq₀ (norm_nonneg _)
          (mul_nonneg hcoef (norm_nonneg _))).mpr hgeo
      _ = (2 / (1 - q)) ^ 2 *
          ‖permutationMarkov X.generator (indicatorVector χ) -
            indicatorVector χ‖ ^ 2 := by
        rw [mul_pow]
  rw [← rooted_markov_real_iterate_sq_error X.generator T k]
  change
    ‖((permutationMarkov X.generator)^[k])
        (indicatorVector χ) - indicatorVector χ‖ ^ 2 ≤
      8 * (SoficGroups.boundary X.generator T : ℝ) /
        ((S.card : ℝ) * (1 - q) ^ 2)
  calc
    ‖((permutationMarkov X.generator)^[k])
        (indicatorVector χ) - indicatorVector χ‖ ^ 2 ≤
      (2 / (1 - q)) ^ 2 *
        ‖permutationMarkov X.generator (indicatorVector χ) -
          indicatorVector χ‖ ^ 2 := hsquare
    _ ≤ (2 / (1 - q)) ^ 2 *
        (2 * (SoficGroups.boundary X.generator T : ℝ) /
          (S.card : ℝ)) :=
      mul_le_mul_of_nonneg_left hjensen (sq_nonneg _)
    _ = 8 * (SoficGroups.boundary X.generator T : ℝ) /
        ((S.card : ℝ) * (1 - q) ^ 2) := by
      field_simp
      ring

theorem rooted_final_realMarkov_eq_mass_realPermutationMarkov
    {ι V : Type*} [Fintype ι]
    (p : ι → Equiv.Perm V) :
    SoficGroups.KunActualFinalRestrictedVariation.realMarkov p =
      SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov p := by
  funext f x
  simp [SoficGroups.KunActualFinalRestrictedVariation.realMarkov,
    SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov,
    div_eq_mul_inv, mul_comm]

theorem rooted_real_markov_iterate_residual_sqrt_eq
    {ι V : Type*} [Fintype ι] [Fintype V] [DecidableEq V]
    (p : ι → Equiv.Perm V) (T : Finset V) (k : ℕ) :
    Real.sqrt
      (∑ x : V,
        (SoficGroups.KunActualFinalRestrictedVariation.realMarkov p
          ((((SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov p)^[k])
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T))) x -
          ((((SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov p)^[k])
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)) x)) ^ 2) =
      ‖((permutationMarkov p)^[k + 1])
          (indicatorVector
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)) -
        ((permutationMarkov p)^[k])
          (indicatorVector
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T))‖ := by
  have hcomplex :
      SoficGroups.KunRealComplexMarkovBridge.permutationMarkov p =
        SoficGroups.KunRootedIndicatorCrossing.permutationMarkov p := rfl
  have hvector :
      SoficGroups.KunRealComplexMarkovBridge.indicatorVector
          (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T) =
        SoficGroups.KunRootedIndicatorCrossing.indicatorVector
          (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T) := rfl
  have henergy :=
    SoficGroups.KunRealComplexMarkovBridge.norm_iterate_permutationMarkov_indicator_sub_iterate_sq
      p (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T) k
  rw [hcomplex, hvector,
    rooted_realMarkov_eq_mass_realPermutationMarkov] at henergy
  have hfinal := rooted_final_realMarkov_eq_mass_realPermutationMarkov p
  have hsum :
      (∑ x : V,
        (SoficGroups.KunActualFinalRestrictedVariation.realMarkov p
          ((((SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov p)^[k])
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T))) x -
          ((((SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov p)^[k])
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)) x)) ^ 2) =
      ‖((permutationMarkov p)^[k + 1])
          (indicatorVector
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)) -
        ((permutationMarkov p)^[k])
          (indicatorVector
            (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T))‖ ^ 2 := by
    rw [hfinal]
    simpa only [Function.iterate_succ_apply'] using henergy.symm
  rw [hsum, Real.sqrt_sq (norm_nonneg _)]

theorem exists_rooted_word_radius_sparse_cut_of_boundary
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, u} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (w : G → List ↥S)
    (γ α : ℝ) (_hγ : 0 < γ) (hα : 0 < α)
    (hγsmall :
      216 * γ <
        (S.card : ℝ) *
          (1 - kazhdanMarkovContractionFactor P S) ^ 2) :
    ∃ (k r : ℕ), ∀ X : RootedIndicatorMarkovModel G ↥S,
      X.IsGenerated (fun i : ↥S => (i : G)) w →
      X.IsRootedAtRadius w r →
      ∀ T : Finset X.carrier,
        T.Nonempty →
        (∀ x : X.carrier,
          X.indicator x = if x ∈ T then (1 : ℝ) else 0) →
        (SoficGroups.boundary X.generator T : ℝ) <
          γ * (T.card : ℝ) →
        ∃ U : Finset X.carrier,
          (((U ∆ T).card : ℝ)) ≤
            9 * (∑ x : X.carrier,
              ((((SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov
                X.generator)^[k])
                  (SoficGroups.KunFinitePermutationMarkovMass.realIndicator T)) x -
                if x ∈ T then (1 : ℝ) else 0) ^ 2) ∧
          (((U ∆ T).card : ℝ)) ≤
            72 * (SoficGroups.boundary X.generator T : ℝ) /
              ((S.card : ℝ) *
                (1 - kazhdanMarkovContractionFactor P S) ^ 2) ∧
          3 * (U ∆ T).card < T.card ∧
          (SoficGroups.boundary X.generator U : ℝ) ≤
            α * (U.card : ℝ) := by
  classical
  letI : Nonempty (↥S) := ⟨⟨1, honeS⟩⟩
  let q := kazhdanMarkovContractionFactor P S
  have hqzero : 0 ≤ q :=
    kazhdanMarkovContractionFactor_nonneg P S
  have hqone : q < 1 :=
    kazhdanMarkovContractionFactor_lt_one P S ⟨1, honeS⟩
  have hgap : 0 < 1 - q := sub_pos.mpr hqone
  have hdegree : 0 < (S.card : ℝ) := by
    exact_mod_cast Finset.card_pos.mpr ⟨1, honeS⟩
  let η : ℝ := 4 * α ^ 2 / (486 * (S.card : ℝ) ^ 2)
  have hη : 0 < η := by
    dsimp [η]
    positivity
  obtain ⟨k, hk⟩ := exists_pow_lt_of_lt_one hη hqone
  let ε : ℝ := (η - q ^ k) / 2
  have hε : 0 < ε := by
    dsimp [ε]
    linarith
  obtain ⟨rnear, hnear⟩ :=
    exists_rooted_word_radius_real_markov_sq_error_le_boundary
      P S honeS hcover hsymmetric w k
  obtain ⟨rfinal, hfinal⟩ :=
    exists_rooted_word_radius_markov_iterate_contraction
      P S honeS hcover hsymmetric w k ε hε
  refine ⟨k, max rnear rfinal, ?_⟩
  intro X hgenerated hroot T hT hindicator hboundary
  have hrootnear := hroot.mono (le_max_left rnear rfinal)
  have hrootfinal := hroot.mono (le_max_right rnear rfinal)
  let χ : X.carrier → ℝ :=
    SoficGroups.KunFinitePermutationMarkovMass.realIndicator T
  let f : X.carrier → ℝ :=
    ((SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov
      X.generator)^[k]) χ
  let b : ℝ :=
    ‖permutationMarkov X.generator (indicatorVector χ) -
      indicatorVector χ‖
  have hχ : X.indicator = χ := by
    funext x
    simpa [χ,
      SoficGroups.KunFinitePermutationMarkovMass.realIndicator]
      using hindicator x
  have hD :
      (∑ x : X.carrier,
        (f x - if x ∈ T then (1 : ℝ) else 0) ^ 2) ≤
        8 * (SoficGroups.boundary X.generator T : ℝ) /
          ((S.card : ℝ) * (1 - q) ^ 2) := by
    simpa [f, χ, q] using
      hnear X hgenerated hrootnear T hindicator
  have hstep := hfinal X hgenerated hrootfinal
  rw [hχ] at hstep
  have hresidual :
      Real.sqrt
        (∑ x : X.carrier,
          (SoficGroups.KunActualFinalRestrictedVariation.realMarkov
            X.generator f x - f x) ^ 2) ≤ η * b := by
    calc
      Real.sqrt
          (∑ x : X.carrier,
            (SoficGroups.KunActualFinalRestrictedVariation.realMarkov
              X.generator f x - f x) ^ 2) =
          ‖((permutationMarkov X.generator)^[k + 1])
              (indicatorVector χ) -
            ((permutationMarkov X.generator)^[k])
              (indicatorVector χ)‖ := by
            simpa [f, χ] using
              rooted_real_markov_iterate_residual_sqrt_eq
                X.generator T k
      _ ≤ (q ^ k + ε) * b := hstep
      _ ≤ η * b := by
        apply mul_le_mul_of_nonneg_right _ (norm_nonneg _)
        dsimp [ε]
        linarith
  have hfzero : ∀ x : X.carrier, 0 ≤ f x := by
    intro x
    exact (SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov_iterate_indicator_mem_unitInterval
      X.generator T k x).1
  have hfone : ∀ x : X.carrier, f x ≤ 1 := by
    intro x
    exact (SoficGroups.KunFinitePermutationMarkovMass.realPermutationMarkov_iterate_indicator_mem_unitInterval
      X.generator T k x).2
  have hmass : (∑ x : X.carrier, f x) = (T.card : ℝ) :=
    SoficGroups.KunFinitePermutationMarkovMass.sum_realPermutationMarkov_iterate_indicator
      X.generator T k
  have hjensen :
      b ^ 2 ≤
        2 * (SoficGroups.boundary X.generator T : ℝ) /
          (S.card : ℝ) := by
    simpa [b, χ, Fintype.card_coe] using
      rooted_indicator_defect_sq_le_boundary X.generator T
  have hgaple : 1 - q ≤ 1 := by linarith
  have hgapzero : 0 ≤ 1 - q := hgap.le
  have hgap_sq_le_one : (1 - q) ^ 2 ≤ 1 := by
    nlinarith [sq_nonneg (1 - q)]
  have hgamma_degree : 2 * γ ≤ (S.card : ℝ) := by
    have hsmalldegree :
        (S.card : ℝ) * (1 - q) ^ 2 ≤ (S.card : ℝ) := by
      nlinarith [mul_nonneg hdegree.le
        (sub_nonneg.mpr hgap_sq_le_one)]
    change 216 * γ < (S.card : ℝ) * (1 - q) ^ 2
      at hγsmall
    nlinarith only [hγsmall, hsmalldegree, _hγ]
  have hbase : b ^ 2 ≤ (T.card : ℝ) := by
    refine hjensen.trans ?_
    apply (div_le_iff₀ hdegree).2
    have hscaled :=
      mul_le_mul_of_nonneg_right hgamma_degree
        (Nat.cast_nonneg T.card)
    have hboundary' :=
      mul_le_mul_of_nonneg_left hboundary.le
        (by norm_num : (0 : ℝ) ≤ 2)
    nlinarith only [hscaled, hboundary']
  have hsmall :
      486 * (Fintype.card (↥S) : ℝ) ^ 2 * η ≤
        4 * α ^ 2 := by
    dsimp [η]
    rw [Fintype.card_coe]
    field_simp
    exact le_rfl
  have hvariation :=
    SoficGroups.KunActualFinalRestrictedVariation.highSupport_variation_le_of_realMarkov_residual
      X.generator T f α η b hfzero hfone hmass
        hα.le hη.le hbase hresidual hsmall
  obtain ⟨t, _ht, hcut, hdistance⟩ :=
    SoficGroups.KunSharpThresholdCut.exists_upperLevel_boundary_and_symmDiff_le
      X.generator T f
  let U : Finset X.carrier :=
    SoficGroups.KunSharpThresholdCut.upperLevel f t
  have hquant :
      (((U ∆ T).card : ℝ)) ≤
        72 * (SoficGroups.boundary X.generator T : ℝ) /
          ((S.card : ℝ) * (1 - q) ^ 2) := by
    calc
      (((U ∆ T).card : ℝ)) ≤
          9 * ∑ x : X.carrier,
            (f x - if x ∈ T then (1 : ℝ) else 0) ^ 2 :=
        hdistance
      _ ≤ 9 *
          (8 * (SoficGroups.boundary X.generator T : ℝ) /
            ((S.card : ℝ) * (1 - q) ^ 2)) :=
        mul_le_mul_of_nonneg_left hD (by norm_num)
      _ = 72 * (SoficGroups.boundary X.generator T : ℝ) /
          ((S.card : ℝ) * (1 - q) ^ 2) := by ring
  have hTpos : 0 < (T.card : ℝ) := by
    exact_mod_cast Finset.card_pos.mpr hT
  have hdenom :
      0 < (S.card : ℝ) * (1 - q) ^ 2 :=
    mul_pos hdegree (sq_pos_of_pos hgap)
  have hscaled :
      216 * (SoficGroups.boundary X.generator T : ℝ) <
        ((S.card : ℝ) * (1 - q) ^ 2) * (T.card : ℝ) := by
    calc
      216 * (SoficGroups.boundary X.generator T : ℝ) <
        216 * (γ * (T.card : ℝ)) :=
        mul_lt_mul_of_pos_left hboundary (by norm_num)
      _ = (216 * γ) * (T.card : ℝ) := by ring
      _ < ((S.card : ℝ) * (1 - q) ^ 2) * (T.card : ℝ) :=
        mul_lt_mul_of_pos_right hγsmall hTpos
  have hclose_real :
      (3 : ℝ) * (((U ∆ T).card : ℝ)) < (T.card : ℝ) := by
    calc
      (3 : ℝ) * (((U ∆ T).card : ℝ)) ≤
          216 * (SoficGroups.boundary X.generator T : ℝ) /
            ((S.card : ℝ) * (1 - q) ^ 2) := by
        calc
          (3 : ℝ) * (((U ∆ T).card : ℝ)) ≤
            3 * (72 * (SoficGroups.boundary X.generator T : ℝ) /
              ((S.card : ℝ) * (1 - q) ^ 2)) :=
            mul_le_mul_of_nonneg_left hquant (by norm_num)
          _ = 216 * (SoficGroups.boundary X.generator T : ℝ) /
              ((S.card : ℝ) * (1 - q) ^ 2) := by ring
      _ < (T.card : ℝ) :=
        (div_lt_iff₀ hdenom).2 (by nlinarith only [hscaled])
  have hclose : 3 * (U ∆ T).card < T.card := by
    exact_mod_cast hclose_real
  have hsub : T ⊆ U ∪ (U ∆ T) := by
    intro x hx
    by_cases hxU : x ∈ U
    · exact Finset.mem_union.mpr (Or.inl hxU)
    · exact Finset.mem_union.mpr
        (Or.inr (Finset.mem_symmDiff.mpr (Or.inr ⟨hx, hxU⟩)))
  have hcard : T.card ≤ U.card + (U ∆ T).card :=
    (Finset.card_le_card hsub).trans (Finset.card_union_le U (U ∆ T))
  have hcardreal :
      (T.card : ℝ) ≤ (U.card : ℝ) + (((U ∆ T).card : ℝ)) := by
    exact_mod_cast hcard
  have hlarge :
      2 * (T.card : ℝ) ≤ 3 * (U.card : ℝ) := by
    linarith only [hcardreal, hclose_real]
  have hscaledlarge :=
    mul_le_mul_of_nonneg_left hlarge hα.le
  have hboundaryU :
      (SoficGroups.boundary X.generator U : ℝ) ≤
        α * (U.card : ℝ) := by
    change
      (SoficGroups.boundary X.generator
        (SoficGroups.KunSharpThresholdCut.upperLevel f t) : ℝ) ≤ _
    nlinarith only [hcut, hvariation, hscaledlarge]
  exact ⟨U, by simpa [f, χ] using hdistance,
    by simpa [q] using hquant, hclose, hboundaryU⟩

end KunRootedWordPower

namespace SourceCompressionRetainedDiscard

open Filter Topology
open scoped BigOperators symmDiff

noncomputable def witnesslessComponents
    {V : Type*} [Fintype V] [DecidableEq V]
    (P Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (b : V → ℤ) (eta : ℝ) :
    Finset (Finset V) :=
  (P.parts \ SoficGroups.insufficientOverlapComponents P Q eta).filter
    (fun C => ∀ y ∈ C ∩ SoficGroups.maximumOverlapPart Q C,
      b (T.symm y) ≠ b y)

noncomputable def retainedComponents
    {V : Type*} [Fintype V] [DecidableEq V]
    (P Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (b : V → ℤ) (eta : ℝ) :
    Finset (Finset V) :=
  P.parts \ (SoficGroups.insufficientOverlapComponents P Q eta ∪
    witnesslessComponents P Q T b eta)

theorem witnesslessComponents_subset_parts
    {V : Type*} [Fintype V] [DecidableEq V]
    (P Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (b : V → ℤ) (eta : ℝ) :
    witnesslessComponents P Q T b eta ⊆ P.parts := by
  intro C hC
  exact (Finset.mem_sdiff.mp
    (Finset.mem_filter.mp hC).1).1

theorem overlapBad_disjoint_witnesslessComponents
    {V : Type*} [Fintype V] [DecidableEq V]
    (P Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (b : V → ℤ) (eta : ℝ) :
    Disjoint (SoficGroups.insufficientOverlapComponents P Q eta)
      (witnesslessComponents P Q T b eta) := by
  apply Finset.disjoint_left.mpr
  intro C hbad hwitnessless
  exact (Finset.mem_sdiff.mp
    (Finset.mem_filter.mp hwitnessless).1).2 hbad

theorem retainedComponents_spec
    {V : Type*} [Fintype V] [DecidableEq V]
    (P Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (b : V → ℤ) (eta : ℝ)
    (C : Finset V)
    (hC : C ∈ retainedComponents P Q T b eta) :
    C ∈ P.parts ∧
      SoficGroups.maximumOverlapPart Q C ∈ Q.parts ∧
      (1 - eta) * (C.card : ℝ) ≤
        ((C ∩ SoficGroups.maximumOverlapPart Q C).card : ℝ) ∧
      ∃ y ∈ C ∩ SoficGroups.maximumOverlapPart Q C,
        b (T.symm y) = b y := by
  have hmem := Finset.mem_sdiff.mp hC
  have hpart : C ∈ P.parts := hmem.1
  have hnotbad : C ∉ SoficGroups.insufficientOverlapComponents P Q eta :=
    fun h => hmem.2 (Finset.mem_union_left _ h)
  have hnotwitnessless : C ∉ witnesslessComponents P Q T b eta :=
    fun h => hmem.2 (Finset.mem_union_right _ h)
  have htarget : SoficGroups.maximumOverlapPart Q C ∈ Q.parts :=
    SoficGroups.maximumOverlapPart_mem Q C
      (P.nonempty_of_mem_parts hpart) (P.subset hpart)
  have hoverlap :=
    SoficGroups.maximumOverlapPart_overlap_of_not_mem_insufficient
      P Q eta C hpart hnotbad
  refine ⟨hpart, htarget, hoverlap, ?_⟩
  by_contra hnone
  push Not at hnone
  apply hnotwitnessless
  exact Finset.mem_filter.mpr
    ⟨Finset.mem_sdiff.mpr ⟨hpart, hnotbad⟩, hnone⟩

theorem witnessless_component_card_le_twice_rankChanging
    {V : Type*} [Fintype V] [DecidableEq V]
    (P Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (b : V → ℤ)
    (eta : ℝ) (heta : eta ≤ (1 : ℝ) / 2)
    (C : Finset V)
    (hC : C ∈ witnesslessComponents P Q T b eta) :
    C.card ≤
      2 * (C ∩ SoficGroups.RankArcCharging.rankChangingArc
        (Finset.univ : Finset V) b T.symm).card := by
  have hfilter := Finset.mem_filter.mp hC
  have hgood := Finset.mem_sdiff.mp hfilter.1
  have hpart : C ∈ P.parts := hgood.1
  have hnotbad : C ∉ SoficGroups.insufficientOverlapComponents P Q eta :=
    hgood.2
  have hoverlap :=
    SoficGroups.maximumOverlapPart_overlap_of_not_mem_insufficient
      P Q eta C hpart hnotbad
  have hsubset :
      C ∩ SoficGroups.maximumOverlapPart Q C ⊆
        C ∩ SoficGroups.RankArcCharging.rankChangingArc
          (Finset.univ : Finset V) b T.symm := by
    intro y hy
    have hy' := Finset.mem_inter.mp hy
    refine Finset.mem_inter.mpr ⟨hy'.1, ?_⟩
    exact Finset.mem_filter.mpr
      ⟨Finset.mem_univ y, hfilter.2 y hy⟩
  have hcard :
      ((C ∩ SoficGroups.maximumOverlapPart Q C).card : ℝ) ≤
        ((C ∩ SoficGroups.RankArcCharging.rankChangingArc
          (Finset.univ : Finset V) b T.symm).card : ℝ) := by
    exact_mod_cast Finset.card_le_card hsubset
  have hhalf :
      (1 / 2 : ℝ) * (C.card : ℝ) ≤
        (1 - eta) * (C.card : ℝ) := by
    apply mul_le_mul_of_nonneg_right (by linarith) (by positivity)
  have hreal :
      (C.card : ℝ) ≤
        2 * ((C ∩ SoficGroups.RankArcCharging.rankChangingArc
          (Finset.univ : Finset V) b T.symm).card : ℝ) := by
    linarith
  exact_mod_cast hreal

theorem witnesslessComponents_mass_le_twice_rankChanging
    {V : Type*} [Fintype V] [DecidableEq V]
    (P Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (b : V → ℤ)
    (eta : ℝ) (heta : eta ≤ (1 : ℝ) / 2) :
    (∑ C ∈ witnesslessComponents P Q T b eta, C.card) ≤
      2 * (SoficGroups.RankArcCharging.rankChangingArc
        (Finset.univ : Finset V) b T.symm).card := by
  let B := SoficGroups.RankArcCharging.rankChangingArc
    (Finset.univ : Finset V) b T.symm
  have hsum :
      (∑ C ∈ witnesslessComponents P Q T b eta, (C ∩ B).card) ≤
        ∑ C ∈ P.parts, (C ∩ B).card := by
    exact Finset.sum_le_sum_of_subset_of_nonneg
      (witnesslessComponents_subset_parts P Q T b eta)
      (fun _ _ _ => Nat.zero_le _)
  have hpartition :
      (∑ C ∈ P.parts, (C ∩ B).card) = B.card := by
    simpa using SoficGroups.matched_sum_card_inter_partition P B
  calc
    (∑ C ∈ witnesslessComponents P Q T b eta, C.card) ≤
        ∑ C ∈ witnesslessComponents P Q T b eta,
          2 * (C ∩ B).card := by
      exact Finset.sum_le_sum fun C hC =>
        witnessless_component_card_le_twice_rankChanging
          P Q T b eta heta C hC
    _ = 2 * (∑ C ∈ witnesslessComponents P Q T b eta,
          (C ∩ B).card) := by
      simp [Finset.mul_sum]
    _ ≤ 2 * (∑ C ∈ P.parts, (C ∩ B).card) :=
      Nat.mul_le_mul_left 2 hsum
    _ = 2 * B.card := by rw [hpartition]

theorem retained_missing_card_le_overlap_add_twice_rankChanging
    {V : Type*} [Fintype V] [DecidableEq V]
    (P Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (b : V → ℤ)
    (eta : ℝ) (heta : eta ≤ (1 : ℝ) / 2) :
    ((Finset.univ : Finset V) \
      SoficGroups.matchedRetainedSupport
        (retainedComponents P Q T b eta)).card ≤
      (∑ C ∈ SoficGroups.insufficientOverlapComponents P Q eta, C.card) +
        2 * (SoficGroups.RankArcCharging.rankChangingArc
          (Finset.univ : Finset V) b T.symm).card := by
  let O := SoficGroups.insufficientOverlapComponents P Q eta
  let W := witnesslessComponents P Q T b eta
  let R := retainedComponents P Q T b eta
  let B := SoficGroups.RankArcCharging.rankChangingArc
    (Finset.univ : Finset V) b T.symm
  have hR : R ⊆ P.parts := Finset.sdiff_subset
  have hmiss :
      ((Finset.univ : Finset V) \
        SoficGroups.matchedRetainedSupport R).card =
          ∑ C ∈ P.parts \ R, C.card := by
    have hsplit :
        (∑ C ∈ P.parts \ R, C.card) +
          (∑ C ∈ R, C.card) =
            ∑ C ∈ P.parts, C.card :=
      Finset.sum_sdiff hR
    have hcover := P.sum_card_parts
    have hret := SoficGroups.matchedRetainedSupport_card P R hR
    have hcard := Finset.card_sdiff_add_card_eq_card
      (SoficGroups.matchedRetainedSupport_subset P R hR)
    omega
  have hsubset : P.parts \ R ⊆ O ∪ W := by
    intro C hC
    have hC' := Finset.mem_sdiff.mp hC
    by_contra hbad
    apply hC'.2
    change C ∈ P.parts \ (O ∪ W)
    exact Finset.mem_sdiff.mpr ⟨hC'.1, hbad⟩
  have hsum :
      (∑ C ∈ P.parts \ R, C.card) ≤
        ∑ C ∈ O ∪ W, C.card :=
    Finset.sum_le_sum_of_subset_of_nonneg hsubset
      (fun _ _ _ => Nat.zero_le _)
  have hdis : Disjoint O W :=
    overlapBad_disjoint_witnesslessComponents P Q T b eta
  have hunion :
      (∑ C ∈ O ∪ W, C.card) =
        (∑ C ∈ O, C.card) + (∑ C ∈ W, C.card) :=
    Finset.sum_union hdis
  have hwitness : (∑ C ∈ W, C.card) ≤ 2 * B.card :=
    witnesslessComponents_mass_le_twice_rankChanging
      P Q T b eta heta
  change
    ((Finset.univ : Finset V) \
      SoficGroups.matchedRetainedSupport R).card ≤
        (∑ C ∈ O, C.card) + 2 * B.card
  omega

theorem retained_missing_density_tendsto_zero
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (P Q : (n : ℕ) → Finpartition
      (Finset.univ : Finset (V n)))
    (T : (n : ℕ) → Equiv.Perm (V n))
    (b : (n : ℕ) → V n → ℤ) (eta : ℕ → ℝ)
    (heta : Tendsto eta atTop (nhds 0))
    (hoverlap : Tendsto
      (fun n =>
        ((∑ C ∈ SoficGroups.insufficientOverlapComponents
          (P n) (Q n) (eta n), C.card : ℕ) : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0))
    (hrank : Tendsto
      (fun n =>
        ((SoficGroups.RankArcCharging.rankChangingArc
          (Finset.univ : Finset (V n)) (b n) (T n).symm).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        (((Finset.univ : Finset (V n)) \
          SoficGroups.matchedRetainedSupport
            (retainedComponents (P n) (Q n) (T n) (b n)
              (eta n))).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0) := by
  have hhalf : ∀ᶠ n in atTop, eta n < (1 : ℝ) / 2 :=
    heta.eventually (gt_mem_nhds (by norm_num))
  have htwice : Tendsto
      (fun n => (2 : ℝ) *
        (((SoficGroups.RankArcCharging.rankChangingArc
          (Finset.univ : Finset (V n)) (b n) (T n).symm).card : ℝ) /
            Fintype.card (V n)))
      atTop (nhds 0) := by
    simpa using hrank.const_mul 2
  have hupper : Tendsto
      (fun n =>
        ((∑ C ∈ SoficGroups.insufficientOverlapComponents
          (P n) (Q n) (eta n), C.card : ℕ) : ℝ) /
            Fintype.card (V n) +
          (2 : ℝ) *
            (((SoficGroups.RankArcCharging.rankChangingArc
              (Finset.univ : Finset (V n)) (b n) (T n).symm).card : ℝ) /
                Fintype.card (V n)))
      atTop (nhds 0) := by
    simpa only [zero_add] using hoverlap.add htwice
  refine squeeze_zero'
    (Eventually.of_forall fun n => by positivity) ?_ hupper
  filter_upwards [hhalf] with n hn
  have hnat := retained_missing_card_le_overlap_add_twice_rankChanging
    (P n) (Q n) (T n) (b n) (eta n) hn.le
  have hreal :
      (((Finset.univ : Finset (V n)) \
        SoficGroups.matchedRetainedSupport
          (retainedComponents (P n) (Q n) (T n) (b n)
            (eta n))).card : ℝ) ≤
        ((∑ C ∈ SoficGroups.insufficientOverlapComponents
          (P n) (Q n) (eta n), C.card : ℕ) : ℝ) +
          2 * ((SoficGroups.RankArcCharging.rankChangingArc
            (Finset.univ : Finset (V n)) (b n) (T n).symm).card : ℝ) := by
    exact_mod_cast hnat
  calc
    (((Finset.univ : Finset (V n)) \
      SoficGroups.matchedRetainedSupport
        (retainedComponents (P n) (Q n) (T n) (b n)
          (eta n))).card : ℝ) / Fintype.card (V n) ≤
        (((∑ C ∈ SoficGroups.insufficientOverlapComponents
          (P n) (Q n) (eta n), C.card : ℕ) : ℝ) +
          2 * ((SoficGroups.RankArcCharging.rankChangingArc
            (Finset.univ : Finset (V n)) (b n) (T n).symm).card : ℝ)) /
            Fintype.card (V n) :=
      div_le_div_of_nonneg_right hreal (by positivity)
    _ = ((∑ C ∈ SoficGroups.insufficientOverlapComponents
          (P n) (Q n) (eta n), C.card : ℕ) : ℝ) /
            Fintype.card (V n) +
          (2 : ℝ) *
            (((SoficGroups.RankArcCharging.rankChangingArc
              (Finset.univ : Finset (V n)) (b n) (T n).symm).card : ℝ) /
                Fintype.card (V n)) := by
      ring

end SourceCompressionRetainedDiscard

namespace SourceGeneratedWordCrossing

open Filter Topology
open scoped BigOperators

theorem mem_partitionWordCrossing_univ
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (p : Equiv.Perm V) (x : V) :
    x ∈ SoficGroups.partitionWordCrossing Q p ↔
      Q.part x ≠ Q.part (p x) := by
  simp only [SoficGroups.partitionWordCrossing, Finset.mem_filter,
    Finset.mem_univ, true_and]
  rw [Q.mem_part_iff_part_eq_part (Finset.mem_univ _)
    (Finset.mem_univ _)]
  simp [eq_comm]

theorem card_partitionWordCrossing_le_add_distance
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (p q : Equiv.Perm V) :
    (SoficGroups.partitionWordCrossing Q p).card ≤
      (SoficGroups.partitionWordCrossing Q q).card +
        SoficGroups.permutationDistance p q := by
  classical
  have hsub :
      SoficGroups.partitionWordCrossing Q p ⊆
        SoficGroups.partitionWordCrossing Q q ∪
          Finset.univ.filter (fun x : V => p x ≠ q x) := by
    intro x hx
    by_cases heq : p x = q x
    · apply Finset.mem_union_left
      apply (mem_partitionWordCrossing_univ Q q x).2
      have hp := (mem_partitionWordCrossing_univ Q p x).1 hx
      simpa [heq] using hp
    · apply Finset.mem_union_right
      exact Finset.mem_filter.2 ⟨Finset.mem_univ x, heq⟩
  calc
    (SoficGroups.partitionWordCrossing Q p).card ≤
        (SoficGroups.partitionWordCrossing Q q ∪
          Finset.univ.filter (fun x : V => p x ≠ q x)).card :=
      Finset.card_le_card hsub
    _ ≤ (SoficGroups.partitionWordCrossing Q q).card +
        (Finset.univ.filter (fun x : V => p x ≠ q x)).card :=
      Finset.card_union_le _ _
    _ = (SoficGroups.partitionWordCrossing Q q).card +
        SoficGroups.permutationDistance p q := by
      simp [SoficGroups.permutationDistance, hammingDist]

theorem card_partitionWordCrossing_mul_le
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (p q : Equiv.Perm V) :
    (SoficGroups.partitionWordCrossing Q (p * q)).card ≤
      (SoficGroups.partitionWordCrossing Q p).card +
        (SoficGroups.partitionWordCrossing Q q).card := by
  classical
  have hsub :
      SoficGroups.partitionWordCrossing Q (p * q) ⊆
        SoficGroups.partitionWordCrossing Q q ∪
          (SoficGroups.partitionWordCrossing Q p).map
            q.symm.toEmbedding := by
    intro x hx
    have hpq := (mem_partitionWordCrossing_univ Q (p * q) x).1 hx
    by_cases hq : Q.part x ≠ Q.part (q x)
    · exact Finset.mem_union_left _
        ((mem_partitionWordCrossing_univ Q q x).2 hq)
    · apply Finset.mem_union_right
      apply Finset.mem_map.2
      refine ⟨q x, (mem_partitionWordCrossing_univ Q p (q x)).2 ?_,
        by simp⟩
      intro heq
      apply hpq
      have hpart : Q.part x = Q.part (q x) := not_ne_iff.mp hq
      simpa [Equiv.Perm.mul_apply] using hpart.trans heq
  have hcard := (Finset.card_le_card hsub).trans
    (Finset.card_union_le
      (SoficGroups.partitionWordCrossing Q q)
      ((SoficGroups.partitionWordCrossing Q p).map
        q.symm.toEmbedding))
  simpa [Nat.add_comm] using hcard

theorem sum_generator_crossing_eq_sum_partition_boundary
    {V ι : Type*} [Fintype V] [DecidableEq V]
    [Fintype ι]
    (Q : Finpartition (Finset.univ : Finset V))
    (σ : ι → Equiv.Perm V) :
    (∑ i : ι, (SoficGroups.partitionWordCrossing Q (σ i)).card) =
      ∑ C ∈ Q.parts, SoficGroups.boundary σ C := by
  classical
  have hpart (i : ι) (C : Finset V) (hC : C ∈ Q.parts) :
      C ∩ SoficGroups.partitionWordCrossing Q (σ i) =
        C.filter (fun x => σ i x ∉ C) := by
    ext x
    simp only [Finset.mem_inter, Finset.mem_filter,
      SoficGroups.partitionWordCrossing, Finset.mem_univ, true_and]
    constructor
    · rintro ⟨hx, hcross⟩
      refine ⟨hx, ?_⟩
      simpa [Q.part_eq_of_mem hC hx] using hcross
    · rintro ⟨hx, hcross⟩
      refine ⟨hx, ?_⟩
      simpa [Q.part_eq_of_mem hC hx] using hcross
  calc
    (∑ i : ι, (SoficGroups.partitionWordCrossing Q (σ i)).card) =
      ∑ i : ι, ∑ C ∈ Q.parts,
        (C.filter (fun x => σ i x ∉ C)).card := by
      apply Finset.sum_congr rfl
      intro i _
      have hsum := SoficGroups.sum_card_inter_partition Q
        (SoficGroups.partitionWordCrossing Q (σ i))
      simp only [Finset.univ_inter] at hsum
      calc
        (SoficGroups.partitionWordCrossing Q (σ i)).card =
            ∑ C ∈ Q.parts,
              (C ∩ SoficGroups.partitionWordCrossing Q (σ i)).card :=
          hsum.symm
        _ = ∑ C ∈ Q.parts,
              (C.filter (fun x => σ i x ∉ C)).card := by
          apply Finset.sum_congr rfl
          intro C hC
          rw [hpart i C hC]
    _ = ∑ C ∈ Q.parts,
        ∑ i : ι, (C.filter (fun x => σ i x ∉ C)).card := by
      rw [Finset.sum_comm]
    _ = ∑ C ∈ Q.parts, SoficGroups.boundary σ C := by
      simp [SoficGroups.boundary]

theorem generator_crossing_density_tendsto_zero
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    {ι : Type*} [Fintype ι]
    (Q : ∀ n, Finpartition (Finset.univ : Finset (V n)))
    (σ : ∀ n, ι → Equiv.Perm (V n))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary (σ n) C : ℝ)) /
            Fintype.card (V n))
      atTop (nhds 0))
    (i : ι) :
    Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          (σ n i)).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0) := by
  refine squeeze_zero (fun n => by positivity) ?_ hboundary
  intro n
  have hsingle :
      (SoficGroups.partitionWordCrossing (Q n) (σ n i)).card ≤
        ∑ j : ι,
          (SoficGroups.partitionWordCrossing (Q n) (σ n j)).card := by
    exact Finset.single_le_sum
      (fun j _ => Nat.zero_le
        (SoficGroups.partitionWordCrossing (Q n) (σ n j)).card)
      (Finset.mem_univ i)
  have hsum := sum_generator_crossing_eq_sum_partition_boundary
    (Q n) (σ n)
  have hreal :
      ((SoficGroups.partitionWordCrossing (Q n) (σ n i)).card : ℝ) ≤
        ∑ C ∈ (Q n).parts,
          (SoficGroups.boundary (σ n) C : ℝ) := by
    exact_mod_cast hsingle.trans (le_of_eq hsum)
  exact div_le_div_of_nonneg_right hreal (by positivity)

theorem list_generator_crossing_density_tendsto_zero
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    {ι : Type*}
    (Q : ∀ n, Finpartition (Finset.univ : Finset (V n)))
    (σ : ∀ n, ι → Equiv.Perm (V n))
    (hgenerator : ∀ i : ι, Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          (σ n i)).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0))
    (l : List ι) :
    Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((l.map (σ n)).prod)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0) := by
  induction l with
  | nil =>
      simp [SoficGroups.partitionWordCrossing]
  | cons i l ih =>
      have hupper : Tendsto
          (fun n =>
            ((SoficGroups.partitionWordCrossing (Q n)
              (σ n i)).card : ℝ) / Fintype.card (V n) +
            ((SoficGroups.partitionWordCrossing (Q n)
              ((l.map (σ n)).prod)).card : ℝ) /
                Fintype.card (V n))
          atTop (nhds 0) := by
        simpa using (hgenerator i).add ih
      refine squeeze_zero (fun n => by positivity) ?_ hupper
      intro n
      have hnat := card_partitionWordCrossing_mul_le (Q n)
        (σ n i) ((l.map (σ n)).prod)
      have hreal :
          ((SoficGroups.partitionWordCrossing (Q n)
            (σ n i * (l.map (σ n)).prod)).card : ℝ) ≤
          ((SoficGroups.partitionWordCrossing (Q n)
            (σ n i)).card : ℝ) +
          ((SoficGroups.partitionWordCrossing (Q n)
            ((l.map (σ n)).prod)).card : ℝ) := by
        exact_mod_cast hnat
      simpa [add_div] using
        (div_le_div_of_nonneg_right hreal
          (by positivity : (0 : ℝ) ≤ Fintype.card (V n)))

theorem action_list_prod_tendsto
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G) (l : List G) :
    Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          ((A.model n).action l.prod)
          ((l.map (A.model n).action).prod))
      atTop (nhds 0) := by
  induction l with
  | nil =>
      simp [SoficGroups.PermutationModel.map_one,
        SoficGroups.normalizedHamming_self]
  | cons g l ih =>
      simp only [List.map_cons, List.prod_cons]
      have hupper : Tendsto
          (fun n =>
            SoficGroups.normalizedHamming
                ((A.model n).action (g * l.prod))
                ((A.model n).action g * (A.model n).action l.prod) +
              SoficGroups.normalizedHamming
                ((A.model n).action l.prod)
                ((l.map (A.model n).action).prod))
          atTop (nhds 0) := by
        simpa using (A.multiplicative g l.prod).add ih
      refine squeeze_zero
        (fun n => SoficGroups.normalizedHamming_nonneg _ _) ?_ hupper
      intro n
      have htriangle := SoficGroups.normalizedHamming_triangle
        ((A.model n).action (g * l.prod))
        ((A.model n).action g * (A.model n).action l.prod)
        ((A.model n).action g *
          (l.map (A.model n).action).prod)
      rw [SoficGroups.normalizedHamming_mul_left] at htriangle
      exact htriangle

theorem exists_word_of_symmetric_generators
    {H : Type*} [Group H]
    (S : Finset H)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set H) = ⊤)
    (g : H) :
    ∃ l : List ↥S,
      ((l.map fun i : ↥S => (i : H)).prod) = g := by
  classical
  have hg : g ∈ Subgroup.closure (S : Set H) := by
    rw [hgenerates]
    simp
  induction hg using Subgroup.closure_induction with
  | mem x hx =>
      exact ⟨[⟨x, hx⟩], by simp⟩
  | one =>
      exact ⟨[], by simp⟩
  | mul x y _ _ ihx ihy =>
      obtain ⟨lx, hlx⟩ := ihx
      obtain ⟨ly, hly⟩ := ihy
      refine ⟨lx ++ ly, ?_⟩
      rw [List.map_append, List.prod_append, hlx, hly]
  | inv x _ ih =>
      obtain ⟨l, hl⟩ := ih
      let invLetter : ↥S → ↥S :=
        fun i => ⟨(i : H)⁻¹, hsymmetric (i : H) i.property⟩
      refine ⟨(l.map invLetter).reverse, ?_⟩
      rw [List.map_reverse, List.map_map]
      change ((l.map fun i : ↥S => (i : H)⁻¹).reverse).prod = x⁻¹
      have hmap :
          (l.map fun i : ↥S => (i : H)⁻¹) =
            (l.map (fun i : ↥S => (i : H))).map
              (fun z : H => z⁻¹) := by
        rw [List.map_map]
        rfl
      rw [hmap, ← List.prod_inv_reverse, hl]

theorem crossing_density_tendsto_zero_of_normalizedHamming
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (Q : ∀ n, Finpartition (Finset.univ : Finset (V n)))
    (p q : ∀ n, Equiv.Perm (V n))
    (hq : Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n) (q n)).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0))
    (hdist : Tendsto
      (fun n => SoficGroups.normalizedHamming (p n) (q n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n) (p n)).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0) := by
  have hupper : Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n) (q n)).card : ℝ) /
            Fintype.card (V n) +
          SoficGroups.normalizedHamming (p n) (q n))
      atTop (nhds 0) := by
    simpa using hq.add hdist
  refine squeeze_zero (fun n => by positivity) ?_ hupper
  intro n
  have hnat := card_partitionWordCrossing_le_add_distance
    (Q n) (p n) (q n)
  have hreal :
      ((SoficGroups.partitionWordCrossing (Q n) (p n)).card : ℝ) ≤
      ((SoficGroups.partitionWordCrossing (Q n) (q n)).card : ℝ) +
        (SoficGroups.permutationDistance (p n) (q n) : ℝ) := by
    exact_mod_cast hnat
  calc
    ((SoficGroups.partitionWordCrossing (Q n) (p n)).card : ℝ) /
        Fintype.card (V n) ≤
      (((SoficGroups.partitionWordCrossing (Q n) (q n)).card : ℝ) +
        (SoficGroups.permutationDistance (p n) (q n) : ℝ)) /
          Fintype.card (V n) :=
      div_le_div_of_nonneg_right hreal (by positivity)
    _ = ((SoficGroups.partitionWordCrossing (Q n) (q n)).card : ℝ) /
          Fintype.card (V n) +
        SoficGroups.normalizedHamming (p n) (q n) := by
      simp [add_div, SoficGroups.normalizedHamming,
        SoficGroups.permutationDistance]

theorem fixed_generated_word_crossing_density_tendsto_zero
    {G H : Type*} [Group G] [Group H]
    (A : SoficGroups.SoficApproximation G)
    (φ : H →* G) (S : Finset H)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set H) = ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S => (A.model n).action (φ (i : H))) C : ℝ)) /
              (A.model n).size)
      atTop (nhds 0))
    (g : H) :
    Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((A.model n).action (φ g))).card : ℝ) /
            (A.model n).size)
      atTop (nhds 0) := by
  classical
  obtain ⟨l, hl⟩ :=
    exists_word_of_symmetric_generators S hsymmetric hgenerates g
  have hgenerator (i : ↥S) : Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((A.model n).action (φ (i : H)))).card : ℝ) /
            (A.model n).size)
      atTop (nhds 0) := by
    simpa only [Fintype.card_fin] using
      generator_crossing_density_tendsto_zero
        (V := fun n => Fin (A.model n).size)
        Q (fun n (j : ↥S) => (A.model n).action (φ (j : H)))
        (by simpa only [Fintype.card_fin] using hboundary) i
  have hlist : Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((l.map fun i : ↥S =>
            (A.model n).action (φ (i : H))).prod)).card : ℝ) /
              (A.model n).size)
      atTop (nhds 0) := by
    simpa only [Fintype.card_fin] using
      list_generator_crossing_density_tendsto_zero
        (V := fun n => Fin (A.model n).size)
        Q (fun n (i : ↥S) => (A.model n).action (φ (i : H)))
        (fun i => by
          simpa only [Fintype.card_fin] using hgenerator i)
        l
  have hprod :
      ((l.map fun i : ↥S => φ (i : H)).prod) = φ g := by
    calc
      ((l.map fun i : ↥S => φ (i : H)).prod) =
          φ ((l.map fun i : ↥S => (i : H)).prod) := by
        simpa [List.map_map, Function.comp_def] using
          (map_list_prod φ (l.map fun i : ↥S => (i : H))).symm
      _ = φ g := by rw [hl]
  have hdist : Tendsto
      (fun n => SoficGroups.normalizedHamming
        ((A.model n).action (φ g))
        ((l.map fun i : ↥S =>
          (A.model n).action (φ (i : H))).prod))
      atTop (nhds 0) := by
    have h := action_list_prod_tendsto A
      (l.map fun i : ↥S => φ (i : H))
    rw [hprod] at h
    simpa [List.map_map, Function.comp_def] using h
  simpa only [Fintype.card_fin] using
    crossing_density_tendsto_zero_of_normalizedHamming
      (V := fun n => Fin (A.model n).size)
      Q (fun n => (A.model n).action (φ g))
      (fun n =>
        (l.map fun i : ↥S => (A.model n).action (φ (i : H))).prod)
      (by simpa only [Fintype.card_fin] using hlist)
      hdist

def sourceAlphaInclusion :
    SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode →*
      SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode where
  toFun g :=
    ⟨g.val,
      SoficGroups.SourceGeneration.alphaPrefixElementaryGroup_le_nine
        g.property⟩
  map_one' := rfl
  map_mul' _ _ := rfl

theorem source_alpha_word_crossing_density_tendsto_zero
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure
      (S : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) = ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action (sourceAlphaInclusion i)) C : ℝ)) /
              (A.model n).size)
      atTop (nhds 0))
    (g : SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode) :
    Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((A.model n).action (sourceAlphaInclusion g))).card : ℝ) /
            (A.model n).size)
      atTop (nhds 0) :=
  fixed_generated_word_crossing_density_tendsto_zero
    A sourceAlphaInclusion S hsymmetric hgenerates Q hboundary g

end SourceGeneratedWordCrossing

namespace KunRootedUniversalToleranceNumerics

theorem rooted_graph_boundary_lt_of_slow_tolerance
    {h d q t N b c e : ℝ}
    (hh : 0 < h) (hd : 0 < d) (hq : q < 1)
    (ht : 0 < t)
    (hbad : 2 * d * b ≤ t)
    (hmissing : N - 2 * b ≤ c)
    (hboundary : e ≤ 3 * t)
    (hslow :
      5 * (4 + h *
        (216 / (d * (1 - q) ^ 2) + 1 / d)) * t ≤ h * N) :
    e < (d * (1 - q) ^ 2 / 288) * c := by
  let δ : ℝ := d * (1 - q) ^ 2
  let γ : ℝ := δ / 288
  let C : ℝ := 216 / δ + 1 / d
  have hδ : 0 < δ := by
    dsimp [δ]
    positivity
  have hγ : 0 < γ := by
    dsimp [γ]
    positivity
  have hC : 0 ≤ C := by
    dsimp [C]
    positivity
  have hslowCscaled : h * (5 * C * t) ≤ h * N := by
    have hslow' : 5 * (4 + h * C) * t ≤ h * N := by
      simpa only [C, δ] using hslow
    nlinarith [mul_pos hh ht]
  have hslowC : 5 * C * t ≤ N :=
    le_of_mul_le_mul_left hslowCscaled hh
  have hb : 2 * b ≤ t / d := by
    apply (le_div_iff₀ hd).2
    nlinarith [hbad]
  have hgraph : N - t / d ≤ c := by
    linarith
  have hgraphscaled : γ * (N - t / d) ≤ γ * c :=
    mul_le_mul_of_nonneg_left hgraph hγ.le
  have hNscaled : γ * (5 * C * t) ≤ γ * N :=
    mul_le_mul_of_nonneg_left hslowC hγ.le
  have hγC : γ * C = (3 / 4 : ℝ) + γ / d := by
    change
      (δ / 288) * (216 / δ + 1 / d) =
        (3 / 4 : ℝ) + (δ / 288) / d
    field_simp [ne_of_gt hδ, ne_of_gt hd]
    ring
  have hidentity :
      γ * (5 * C * t) - γ * (t / d) =
        (15 / 4 : ℝ) * t + 4 * (γ / d) * t := by
    calc
      γ * (5 * C * t) - γ * (t / d) =
          5 * (γ * C) * t - (γ / d) * t := by ring
      _ = 5 * ((3 / 4 : ℝ) + γ / d) * t -
          (γ / d) * t := by rw [hγC]
      _ = (15 / 4 : ℝ) * t + 4 * (γ / d) * t := by ring
  have hpositive : 0 ≤ 4 * (γ / d) * t := by
    positivity
  have hstrict : 3 * t < γ * c := by
    nlinarith [hgraphscaled, hNscaled, hidentity]
  simpa only [γ, δ] using lt_of_le_of_lt hboundary hstrict

theorem rooted_graph_coefficient_small
    {d q : ℝ} (hd : 0 < d) (hq : q < 1) :
    0 < d * (1 - q) ^ 2 / 288 ∧
      216 * (d * (1 - q) ^ 2 / 288) < d * (1 - q) ^ 2 := by
  have hgap : 0 < d * (1 - q) ^ 2 := by
    positivity
  constructor
  · positivity
  · nlinarith

end KunRootedUniversalToleranceNumerics

namespace SourceBothCompressionNormalization

def sourceCompressionUElement :
    SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode :=
  ⟨SoficGroups.compressionU,
    SoficGroups.compressionU_mem_ninePrefixElementaryGroup⟩

def sourceCompressionVElement :
    SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode :=
  ⟨SoficGroups.compressionV,
    SoficGroups.compressionV_mem_ninePrefixElementaryGroup⟩

def sourceAlphaElement
    (g : SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode) :
    SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode :=
  ⟨g.val,
    SoficGroups.SourceGeneration.alphaPrefixElementaryGroup_le_nine
      g.property⟩

def sourceConjugatedAlphaUElement
    (g : SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode) :
    SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode := by
  refine ⟨SoficGroups.compressionU * g.val *
    SoficGroups.compressionU⁻¹, ?_⟩
  apply SoficGroups.alphaZero_prefixElementaryGroup_le
  rw [← SoficGroups.compressionU_map_alphaPrefixElementaryGroup]
  refine ⟨g.val, g.property, ?_⟩
  simp [MulAut.conj_apply]

def sourceConjugatedAlphaVElement
    (g : SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode) :
    SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode := by
  refine ⟨SoficGroups.compressionV * g.val *
    SoficGroups.compressionV⁻¹, ?_⟩
  apply SoficGroups.alphaZero_prefixElementaryGroup_le
  rw [← SoficGroups.compressionV_map_alphaPrefixElementaryGroup]
  refine ⟨g.val, g.property, ?_⟩
  simp [MulAut.conj_apply]

theorem sourceCompressionUElement_conjugates_alpha
    (g : SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode) :
    sourceCompressionUElement * sourceAlphaElement g *
        sourceCompressionUElement⁻¹ =
      sourceAlphaElement (sourceConjugatedAlphaUElement g) := by
  apply Subtype.ext
  rfl

theorem sourceCompressionVElement_conjugates_alpha
    (g : SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode) :
    sourceCompressionVElement * sourceAlphaElement g *
        sourceCompressionVElement⁻¹ =
      sourceAlphaElement (sourceConjugatedAlphaVElement g) := by
  apply Subtype.ext
  rfl

def sourceCompressionTable :
    Fin 2 → SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode :=
  ![sourceCompressionUElement, sourceCompressionVElement]

theorem sourceCompressionTable_conjugates_alpha
    (i : Fin 2)
    (g : SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode) :
    ∃ k : SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode,
      sourceCompressionTable i * sourceAlphaElement g *
          (sourceCompressionTable i)⁻¹ =
        sourceAlphaElement k := by
  fin_cases i
  · exact ⟨sourceConjugatedAlphaUElement g,
      sourceCompressionUElement_conjugates_alpha g⟩
  · exact ⟨sourceConjugatedAlphaVElement g,
      sourceCompressionVElement_conjugates_alpha g⟩

end SourceBothCompressionNormalization

namespace KunCompletedProductDiagonalSparseCut

open SoficGroups.KunDiagonalGoodRootGraphLoss
open SoficGroups.KunRootedIndicatorCrossing
open SoficGroups.KunRootedWordPower
open SoficGroups.KunThomInvariantOrthogonal
open scoped BigOperators symmDiff

universe u

def completedDiagonalPermutationHom {V : Type*} :
    Equiv.Perm V →* Equiv.Perm (V × V) where
  toFun p := p.prodCongr p
  map_one' := by
    ext z <;> rfl
  map_mul' := by
    intro p q
    ext z <;> rfl

def completedGoodPermutationGraphIndicator
    {V : Type*} [DecidableEq V]
    (T : Finset (V × V)) (z : V × V) : ℝ :=
  if z ∈ T then 1 else 0

def completedGoodPermutationGraphRootedModel
    {G ι V : Type u} [Fintype V] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (φ : G → Equiv.Perm V)
    (p : Equiv.Perm V) (B : Finset V) :
    RootedIndicatorMarkovModel G ι where
  carrier := V × V
  fintype := inferInstance
  generator i := completedDiagonalPermutationHom (σ i)
  indicator := completedGoodPermutationGraphIndicator
    (goodPermutationGraph p B)
  evaluation g := completedDiagonalPermutationHom (φ g)

theorem completedGoodPermutationGraphRootedModel_isGenerated
    {G ι V : Type u} [Group G] [Fintype ι]
    [Fintype V] [DecidableEq V]
    (s : ι → G) (w : G → List ι)
    (σ : ι → Equiv.Perm V) (φ : G → Equiv.Perm V)
    (hword : ∀ g : G, φ g = ((w g).map σ).prod)
    (hone : φ 1 = 1)
    (hgenerator : ∀ i : ι, φ (s i) = σ i)
    (p : Equiv.Perm V) (B : Finset V) :
    (completedGoodPermutationGraphRootedModel σ φ p B).IsGenerated s w := by
  refine ⟨?_, ?_, ?_, ?_⟩
  · intro z
    change
      completedGoodPermutationGraphIndicator
          (goodPermutationGraph p B) z = 0 ∨
        completedGoodPermutationGraphIndicator
          (goodPermutationGraph p B) z = 1
    unfold completedGoodPermutationGraphIndicator
    by_cases hz : z ∈ goodPermutationGraph p B
    · exact Or.inr (if_pos hz)
    · exact Or.inl (if_neg hz)
  · intro g
    change
      completedDiagonalPermutationHom (φ g) =
        ((w g).map
          fun i : ι => completedDiagonalPermutationHom (σ i)).prod
    rw [hword g, map_list_prod, List.map_map]
    rfl
  · change
      completedDiagonalPermutationHom (φ 1) =
        (1 : Equiv.Perm (V × V))
    rw [hone, map_one]
  · intro i
    change
      completedDiagonalPermutationHom (φ (s i)) =
        completedDiagonalPermutationHom (σ i)
    rw [hgenerator i]

theorem completedGoodPermutationGraphRootedModel_isRootedAtRadius
    {G ι V : Type u} [Group G]
    [Fintype V] [DecidableEq V]
    (w : G → List ι) (σ : ι → Equiv.Perm V)
    (φ : G → Equiv.Perm V)
    (p : Equiv.Perm V) (B : Finset V) (r : ℕ)
    (hroot : ∀ a g : G,
      (w a).length + (w g).length + (w (a * g)).length ≤ r →
        ∀ x : V, x ∉ B →
          φ (a * g) x = (φ a * φ g) x) :
    (completedGoodPermutationGraphRootedModel
      σ φ p B).IsRootedAtRadius w r := by
  refine ⟨?_⟩
  intro a g hword z hz
  have hzreal :
      completedGoodPermutationGraphIndicator
        (goodPermutationGraph p B) z ≠ 0 := by
    intro hzero
    apply hz
    change
      (completedGoodPermutationGraphIndicator
        (goodPermutationGraph p B) z : ℂ) = 0
    exact_mod_cast hzero
  have hzgraph : z ∈ goodPermutationGraph p B := by
    by_contra hnot
    apply hzreal
    exact if_neg hnot
  have hgood : z.1 ∉ B ∧ z.2 ∉ B :=
    (Finset.mem_filter.mp hzgraph).2
  apply Prod.ext
  · exact hroot a g hword z.1 hgood.1
  · exact hroot a g hword z.2 hgood.2

theorem exists_completed_goodPermutationGraph_sparse_cut
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, u} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (w : G → List ↥S)
    (γ α : ℝ) (hγ : 0 < γ) (hα : 0 < α)
    (hγsmall :
      216 * γ <
        (S.card : ℝ) *
          (1 - kazhdanMarkovContractionFactor P S) ^ 2) :
    ∃ r : ℕ,
      ∀ (V : Type u) [Fintype V] [DecidableEq V]
        (σ : ↥S → Equiv.Perm V) (φ : G → Equiv.Perm V),
      (∀ g : G, φ g = ((w g).map σ).prod) →
      φ 1 = 1 →
      (∀ i : ↥S, φ (i : G) = σ i) →
      ∀ (p : Equiv.Perm V) (B : Finset V),
      (∀ a g : G,
        (w a).length + (w g).length + (w (a * g)).length ≤ r →
          ∀ x : V, x ∉ B →
            φ (a * g) x = (φ a * φ g) x) →
      let T := goodPermutationGraph p B
      T.Nonempty →
      (SoficGroups.boundary
        (fun i : ↥S => (σ i).prodCongr (σ i)) T : ℝ) <
          γ * (T.card : ℝ) →
      ∃ U : Finset (V × V),
        (((U ∆ T).card : ℝ)) ≤
          72 * (SoficGroups.boundary
            (fun i : ↥S => (σ i).prodCongr (σ i)) T : ℝ) /
              ((S.card : ℝ) *
                (1 - kazhdanMarkovContractionFactor P S) ^ 2) ∧
        3 * (U ∆ T).card < T.card ∧
        (SoficGroups.boundary
          (fun i : ↥S => (σ i).prodCongr (σ i)) U : ℝ) ≤
            α * (U.card : ℝ) := by
  classical
  obtain ⟨k, r, hr⟩ :=
    exists_rooted_word_radius_sparse_cut_of_boundary
      P S honeS hcover hsymmetric w γ α hγ hα hγsmall
  refine ⟨r, ?_⟩
  intro V _ _ σ φ hword hone hgenerator p B hroot
  have hproductInstance :
      (instDecidableEqProd : DecidableEq (V × V)) =
        Classical.decEq (V × V) :=
    Subsingleton.elim _ _
  letI : DecidableEq (V × V) := Classical.decEq (V × V)
  dsimp only
  intro hT hboundary
  rw [hproductInstance] at hboundary ⊢
  let X : RootedIndicatorMarkovModel G ↥S :=
    completedGoodPermutationGraphRootedModel σ φ p B
  let T : Finset X.carrier := goodPermutationGraph p B
  have hgenerated : X.IsGenerated (fun i : ↥S => (i : G)) w :=
    completedGoodPermutationGraphRootedModel_isGenerated
      (fun i : ↥S => (i : G)) w σ φ
        hword hone hgenerator p B
  have hrooted : X.IsRootedAtRadius w r :=
    completedGoodPermutationGraphRootedModel_isRootedAtRadius
      w σ φ p B r hroot
  have hindicator : ∀ z : X.carrier,
      X.indicator z = if z ∈ T then (1 : ℝ) else 0 := by
    intro z
    by_cases hz : z ∈ goodPermutationGraph p B
    · have hzT : z ∈ T := hz
      rw [if_pos hzT]
      change
        completedGoodPermutationGraphIndicator
          (goodPermutationGraph p B) z = 1
      exact if_pos hz
    · have hzT : z ∉ T := hz
      rw [if_neg hzT]
      change
        completedGoodPermutationGraphIndicator
          (goodPermutationGraph p B) z = 0
      exact if_neg hz
  have hT' : T.Nonempty := hT
  have hboundary' :
      (SoficGroups.boundary X.generator T : ℝ) <
        γ * (T.card : ℝ) := by
    change
      (SoficGroups.boundary
        (fun i : ↥S => (σ i).prodCongr (σ i))
        (goodPermutationGraph p B) : ℝ) <
          γ * ((goodPermutationGraph p B).card : ℝ)
    exact hboundary
  obtain ⟨U, _hmarkov, hdistance, hclose, hcut⟩ :=
    hr X hgenerated hrooted T hT' hindicator hboundary'
  refine ⟨U, ?_, ?_, ?_⟩
  · exact hdistance
  · exact hclose
  · exact hcut

end KunCompletedProductDiagonalSparseCut

namespace KunTransportedAmbientOverlap

open Filter Topology
open scoped BigOperators symmDiff

theorem intersection_generator_exit_subset_union
    {V : Type*} [DecidableEq V]
    (p : Equiv.Perm V) (C D : Finset V) :
    ((C ∩ D).filter fun x => p x ∉ C ∩ D) ⊆
      ((C.filter fun x => p x ∉ C) ∩ D) ∪
        ((D.filter fun x => p x ∉ D) ∩ C) := by
  intro x hx
  obtain ⟨hxCD, hout⟩ := Finset.mem_filter.mp hx
  obtain ⟨hxC, hxD⟩ := Finset.mem_inter.mp hxCD
  by_cases hpC : p x ∈ C
  · apply Finset.mem_union_right
    apply Finset.mem_inter.mpr
    refine ⟨Finset.mem_filter.mpr ⟨hxD, ?_⟩, hxC⟩
    intro hpD
    exact hout (Finset.mem_inter.mpr ⟨hpC, hpD⟩)
  · apply Finset.mem_union_left
    exact Finset.mem_inter.mpr
      ⟨Finset.mem_filter.mpr ⟨hxC, hpC⟩, hxD⟩

theorem sum_intersection_generator_exit_card_le
    {V : Type*} [DecidableEq V]
    {U : Finset V} (P Q : Finpartition U)
    (p : Equiv.Perm V) :
    (∑ C ∈ P.parts, ∑ D ∈ Q.parts,
      ((C ∩ D).filter fun x => p x ∉ C ∩ D).card) ≤
      (∑ C ∈ P.parts,
        (C.filter fun x => p x ∉ C).card) +
      (∑ D ∈ Q.parts,
        (D.filter fun x => p x ∉ D).card) := by
  classical
  have hcell (C D : Finset V) :
      ((C ∩ D).filter fun x => p x ∉ C ∩ D).card ≤
        (((C.filter fun x => p x ∉ C) ∩ D).card) +
          (((D.filter fun x => p x ∉ D) ∩ C).card) :=
    (Finset.card_le_card
      (intersection_generator_exit_subset_union p C D)).trans
        (Finset.card_union_le _ _)
  have hfirst (C : Finset V) (hC : C ∈ P.parts) :
      (∑ D ∈ Q.parts,
        ((C.filter fun x => p x ∉ C) ∩ D).card) =
        (C.filter fun x => p x ∉ C).card := by
    have h := SoficGroups.sum_card_inter_partition Q
      (C.filter fun x => p x ∉ C)
    have hsub :
        (C.filter fun x => p x ∉ C) ⊆ U :=
      (Finset.filter_subset _ _).trans (P.subset hC)
    simpa [Finset.inter_comm,
      Finset.inter_eq_right.mpr hsub] using h
  have hsecond (D : Finset V) (hD : D ∈ Q.parts) :
      (∑ C ∈ P.parts,
        ((D.filter fun x => p x ∉ D) ∩ C).card) =
        (D.filter fun x => p x ∉ D).card := by
    have h := SoficGroups.sum_card_inter_partition P
      (D.filter fun x => p x ∉ D)
    have hsub :
        (D.filter fun x => p x ∉ D) ⊆ U :=
      (Finset.filter_subset _ _).trans (Q.subset hD)
    simpa [Finset.inter_comm,
      Finset.inter_eq_right.mpr hsub] using h
  calc
    (∑ C ∈ P.parts, ∑ D ∈ Q.parts,
      ((C ∩ D).filter fun x => p x ∉ C ∩ D).card) ≤
        ∑ C ∈ P.parts, ∑ D ∈ Q.parts,
          ((((C.filter fun x => p x ∉ C) ∩ D).card) +
            (((D.filter fun x => p x ∉ D) ∩ C).card)) := by
      apply Finset.sum_le_sum
      intro C _
      apply Finset.sum_le_sum
      intro D _
      exact hcell C D
    _ = (∑ C ∈ P.parts, ∑ D ∈ Q.parts,
          ((C.filter fun x => p x ∉ C) ∩ D).card) +
        (∑ D ∈ Q.parts, ∑ C ∈ P.parts,
          ((D.filter fun x => p x ∉ D) ∩ C).card) := by
      simp_rw [Finset.sum_add_distrib]
      congr 1
      rw [Finset.sum_comm]
    _ = (∑ C ∈ P.parts,
          (C.filter fun x => p x ∉ C).card) +
        (∑ D ∈ Q.parts,
          (D.filter fun x => p x ∉ D).card) := by
      congr 1
      · apply Finset.sum_congr rfl
        intro C hC
        exact hfirst C hC
      · apply Finset.sum_congr rfl
        intro D hD
        exact hsecond D hD

theorem sum_intersection_boundary_le_partition_boundaries
    {V ι : Type*} [DecidableEq V] [Fintype ι]
    {U : Finset V} (P Q : Finpartition U)
    (σ : ι → Equiv.Perm V) :
    (∑ C ∈ P.parts, ∑ D ∈ Q.parts,
      SoficGroups.boundary σ (C ∩ D)) ≤
      (∑ C ∈ P.parts, SoficGroups.boundary σ C) +
        (∑ D ∈ Q.parts, SoficGroups.boundary σ D) := by
  classical
  calc
    (∑ C ∈ P.parts, ∑ D ∈ Q.parts,
      SoficGroups.boundary σ (C ∩ D)) =
      ∑ i : ι, ∑ C ∈ P.parts, ∑ D ∈ Q.parts,
        ((C ∩ D).filter fun x => σ i x ∉ C ∩ D).card := by
      simp_rw [SoficGroups.boundary]
      calc
        (∑ C ∈ P.parts, ∑ D ∈ Q.parts, ∑ i : ι,
          ((C ∩ D).filter fun x => σ i x ∉ C ∩ D).card) =
            ∑ C ∈ P.parts, ∑ i : ι, ∑ D ∈ Q.parts,
              ((C ∩ D).filter fun x => σ i x ∉ C ∩ D).card := by
          apply Finset.sum_congr rfl
          intro C _
          rw [Finset.sum_comm]
        _ = ∑ i : ι, ∑ C ∈ P.parts, ∑ D ∈ Q.parts,
              ((C ∩ D).filter fun x => σ i x ∉ C ∩ D).card := by
          rw [Finset.sum_comm]
    _ ≤ ∑ i : ι,
      ((∑ C ∈ P.parts, (C.filter fun x => σ i x ∉ C).card) +
        (∑ D ∈ Q.parts, (D.filter fun x => σ i x ∉ D).card)) := by
      apply Finset.sum_le_sum
      intro i _
      exact sum_intersection_generator_exit_card_le P Q (σ i)
    _ = (∑ C ∈ P.parts, SoficGroups.boundary σ C) +
        (∑ D ∈ Q.parts, SoficGroups.boundary σ D) := by
      simp_rw [Finset.sum_add_distrib]
      congr 1
      · simp_rw [SoficGroups.boundary]
        rw [Finset.sum_comm]
      · simp_rw [SoficGroups.boundary]
        rw [Finset.sum_comm]

theorem dominant_component_loss_le_ambient_intersection_boundaries
    {V ι : Type*} [DecidableEq V] [Fintype ι]
    {U : Finset V} (P Q : Finpartition U)
    (σ : ι → Equiv.Perm V) (gamma : ℝ)
    (hexp : ∀ C ∈ P.parts, ∀ E : Finset V, E ⊆ C →
      2 * E.card ≤ C.card →
        gamma * (E.card : ℝ) ≤
          (SoficGroups.boundary σ E : ℝ))
    (C : Finset V) (hC : C ∈ P.parts) :
    gamma *
        ((C.card : ℝ) -
          ((C ∩ SoficGroups.maximumOverlapPart Q C).card : ℝ)) ≤
      ∑ E ∈ Q.parts,
        (SoficGroups.boundary σ (C ∩ E) : ℝ) := by
  classical
  let D : Finset V := SoficGroups.maximumOverlapPart Q C
  have hCU : C ⊆ U := P.subset hC
  have hD : D ∈ Q.parts :=
    SoficGroups.maximumOverlapPart_mem Q C
      (P.nonempty_of_mem_parts hC) hCU
  have hmax : ∀ E ∈ Q.parts, (C ∩ E).card ≤ (C ∩ D).card :=
    SoficGroups.maximumOverlapPart_maximal Q C
      (P.nonempty_of_mem_parts hC) hCU
  have hsmall (E : Finset V) (hE : E ∈ Q.parts.erase D) :
      gamma * ((C ∩ E).card : ℝ) ≤
        (SoficGroups.boundary σ (C ∩ E) : ℝ) := by
    obtain ⟨hne, hEmem⟩ := Finset.mem_erase.mp hE
    have hdisj : Disjoint (C ∩ E) (C ∩ D) :=
      (Q.disjoint hEmem hD hne).mono
        Finset.inter_subset_right Finset.inter_subset_right
    have hunion : (C ∩ E) ∪ (C ∩ D) ⊆ C :=
      Finset.union_subset Finset.inter_subset_left
        Finset.inter_subset_left
    have hcard :
        (C ∩ E).card + (C ∩ D).card ≤ C.card := by
      rw [← Finset.card_union_of_disjoint hdisj]
      exact Finset.card_le_card hunion
    have hhalf : 2 * (C ∩ E).card ≤ C.card := by
      have hmaximum := hmax E hEmem
      omega
    exact hexp C hC (C ∩ E) Finset.inter_subset_left hhalf
  have hsum :
      (∑ E ∈ Q.parts, ((C ∩ E).card : ℝ)) =
        (C.card : ℝ) := by
    exact_mod_cast
      SoficGroups.sum_card_component_inter_partition Q C hCU
  have herase :
      (∑ E ∈ Q.parts.erase D, ((C ∩ E).card : ℝ)) =
        (C.card : ℝ) - ((C ∩ D).card : ℝ) := by
    have hsplit := Finset.add_sum_erase Q.parts
      (fun E : Finset V => ((C ∩ E).card : ℝ)) hD
    linarith
  change gamma * ((C.card : ℝ) - ((C ∩ D).card : ℝ)) ≤ _
  calc
    gamma * ((C.card : ℝ) - ((C ∩ D).card : ℝ)) =
        ∑ E ∈ Q.parts.erase D,
          gamma * ((C ∩ E).card : ℝ) := by
      rw [← Finset.mul_sum, herase]
    _ ≤ ∑ E ∈ Q.parts.erase D,
          (SoficGroups.boundary σ (C ∩ E) : ℝ) :=
      Finset.sum_le_sum hsmall
    _ ≤ ∑ E ∈ Q.parts,
          (SoficGroups.boundary σ (C ∩ E) : ℝ) := by
      apply Finset.sum_le_sum_of_subset_of_nonneg
        (Finset.erase_subset _ _)
      intro E _ _
      exact Nat.cast_nonneg _

theorem sum_dominant_component_losses_le_partition_boundaries
    {V ι : Type*} [DecidableEq V] [Fintype ι]
    {U : Finset V} (P Q : Finpartition U)
    (σ : ι → Equiv.Perm V) (gamma : ℝ)
    (hexp : ∀ C ∈ P.parts, ∀ E : Finset V, E ⊆ C →
      2 * E.card ≤ C.card →
        gamma * (E.card : ℝ) ≤
          (SoficGroups.boundary σ E : ℝ)) :
    gamma *
        (∑ C ∈ P.parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart Q C).card : ℝ))) ≤
      (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) +
        (∑ D ∈ Q.parts, (SoficGroups.boundary σ D : ℝ)) := by
  classical
  calc
    gamma *
        (∑ C ∈ P.parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart Q C).card : ℝ))) =
      ∑ C ∈ P.parts,
        gamma * ((C.card : ℝ) -
          ((C ∩ SoficGroups.maximumOverlapPart Q C).card : ℝ)) := by
        rw [Finset.mul_sum]
    _ ≤ ∑ C ∈ P.parts, ∑ D ∈ Q.parts,
          (SoficGroups.boundary σ (C ∩ D) : ℝ) := by
        apply Finset.sum_le_sum
        intro C hC
        exact dominant_component_loss_le_ambient_intersection_boundaries
          P Q σ gamma hexp C hC
    _ ≤ (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) +
        (∑ D ∈ Q.parts, (SoficGroups.boundary σ D : ℝ)) := by
      exact_mod_cast
        sum_intersection_boundary_le_partition_boundaries P Q σ

theorem dominant_component_loss_density_tendsto_zero
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    {ι : Type*} [Fintype ι]
    (P Q : ∀ n, Finpartition (Finset.univ : Finset (V n)))
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (gamma : ℝ) (hgamma : 0 < gamma)
    (hexp : ∀ n C, C ∈ (P n).parts →
      ∀ E : Finset (V n), E ⊆ C →
        2 * E.card ≤ C.card →
          gamma * (E.card : ℝ) ≤
            (SoficGroups.boundary (σ n) E : ℝ))
    (hsource : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts,
          (SoficGroups.boundary (σ n) C : ℝ)) /
            Fintype.card (V n))
      atTop (nhds 0))
    (htarget : Tendsto
      (fun n =>
        (∑ D ∈ (Q n).parts,
          (SoficGroups.boundary (σ n) D : ℝ)) /
            Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
              Fintype.card (V n))
      atTop (nhds 0) := by
  have hupper : Tendsto
      (fun n => (1 / gamma) *
        ((∑ C ∈ (P n).parts,
          (SoficGroups.boundary (σ n) C : ℝ)) /
            Fintype.card (V n) +
          (∑ D ∈ (Q n).parts,
            (SoficGroups.boundary (σ n) D : ℝ)) /
              Fintype.card (V n)))
      atTop (nhds 0) := by
    simpa only [add_zero, mul_zero] using
      ((tendsto_const_nhds :
        Tendsto (fun _ : ℕ => (1 / gamma : ℝ))
          atTop (nhds (1 / gamma))).mul (hsource.add htarget))
  refine squeeze_zero (fun n => ?_) (fun n => ?_) hupper
  · apply div_nonneg
    · apply Finset.sum_nonneg
      intro C _
      apply sub_nonneg.mpr
      exact_mod_cast Finset.card_le_card
        (Finset.inter_subset_left :
          C ∩ SoficGroups.maximumOverlapPart (Q n) C ⊆ C)
    · exact Nat.cast_nonneg _
  · have hcard : (0 : ℝ) < Fintype.card (V n) := by
      exact_mod_cast Fintype.card_pos_iff.mpr inferInstance
    have hbound :=
      sum_dominant_component_losses_le_partition_boundaries
        (P n) (Q n) (σ n) gamma (hexp n)
    have hdivide :
        (∑ C ∈ (P n).parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) ≤
          ((∑ C ∈ (P n).parts,
            (SoficGroups.boundary (σ n) C : ℝ)) +
            (∑ D ∈ (Q n).parts,
              (SoficGroups.boundary (σ n) D : ℝ))) / gamma := by
      apply (le_div_iff₀ hgamma).2
      simpa [mul_comm] using hbound
    calc
      (∑ C ∈ (P n).parts,
        ((C.card : ℝ) -
          ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
            Fintype.card (V n) ≤
        (((∑ C ∈ (P n).parts,
          (SoficGroups.boundary (σ n) C : ℝ)) +
          (∑ D ∈ (Q n).parts,
            (SoficGroups.boundary (σ n) D : ℝ))) / gamma) /
              Fintype.card (V n) :=
        div_le_div_of_nonneg_right hdivide hcard.le
      _ = (1 / gamma) *
          ((∑ C ∈ (P n).parts,
            (SoficGroups.boundary (σ n) C : ℝ)) /
              Fintype.card (V n) +
            (∑ D ∈ (Q n).parts,
              (SoficGroups.boundary (σ n) D : ℝ)) /
                Fintype.card (V n)) := by
        ring

theorem boundary_conjugate_map
    {V ι : Type*} [DecidableEq V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (T : Equiv.Perm V)
    (C : Finset V) :
    SoficGroups.boundary
      (fun i => T * σ i * T⁻¹)
      (C.map T.toEmbedding) =
        SoficGroups.boundary σ C := by
  classical
  unfold SoficGroups.boundary
  apply Finset.sum_congr rfl
  intro i _
  have hfilter :
      ((C.map T.toEmbedding).filter fun y =>
        (T * σ i * T⁻¹) y ∉ C.map T.toEmbedding) =
      (C.filter fun x => σ i x ∉ C).map T.toEmbedding := by
    ext y
    simp [Equiv.Perm.mul_apply]
  rw [hfilter, Finset.card_map]

theorem transportedUnivFinpartition_half_expansion
    {V ι : Type*} [Fintype V] [DecidableEq V] [Fintype ι]
    (Q : Finpartition (Finset.univ : Finset V))
    (σ : ι → Equiv.Perm V) (T : Equiv.Perm V)
    (gamma : ℝ)
    (hexp : ∀ C ∈ Q.parts, ∀ E : Finset V, E ⊆ C →
      2 * E.card ≤ C.card →
        gamma * (E.card : ℝ) ≤
          (SoficGroups.boundary σ E : ℝ)) :
    ∀ C ∈ (SoficGroups.transportedUnivFinpartition Q T).parts,
      ∀ E : Finset V, E ⊆ C →
        2 * E.card ≤ C.card →
          gamma * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i => T * σ i * T⁻¹) E : ℝ) := by
  classical
  intro C hC
  rw [SoficGroups.transportedUnivFinpartition_parts] at hC
  obtain ⟨C₀, hC₀, rfl⟩ := Finset.mem_image.mp hC
  intro E hE hhalf
  let E₀ : Finset V := E.map T.symm.toEmbedding
  have hrecovery : E₀.map T.toEmbedding = E := by
    simp [E₀, Finset.map_map]
  have hsub : E₀ ⊆ C₀ := by
    apply (Finset.map_subset_map (f := T.toEmbedding)).mp
    simpa only [hrecovery] using hE
  have hhalf₀ : 2 * E₀.card ≤ C₀.card := by
    simpa [E₀] using hhalf
  have hsource := hexp C₀ hC₀ E₀ hsub hhalf₀
  have hboundary :=
    boundary_conjugate_map σ T E₀
  calc
    gamma * (E.card : ℝ) = gamma * (E₀.card : ℝ) := by
      simp [E₀]
    _ ≤ (SoficGroups.boundary σ E₀ : ℝ) := hsource
    _ = (SoficGroups.boundary
      (fun i => T * σ i * T⁻¹)
        (E₀.map T.toEmbedding) : ℝ) := by
      exact_mod_cast hboundary.symm
    _ = (SoficGroups.boundary
      (fun i => T * σ i * T⁻¹) E : ℝ) := by
      rw [hrecovery]

theorem sum_boundary_transportedUnivFinpartition
    {V ι : Type*} [Fintype V] [DecidableEq V] [Fintype ι]
    (Q : Finpartition (Finset.univ : Finset V))
    (σ : ι → Equiv.Perm V) (T : Equiv.Perm V) :
    (∑ C ∈ (SoficGroups.transportedUnivFinpartition Q T).parts,
      SoficGroups.boundary
        (fun i => T * σ i * T⁻¹) C) =
      ∑ C ∈ Q.parts, SoficGroups.boundary σ C := by
  classical
  rw [SoficGroups.transportedUnivFinpartition_parts]
  rw [Finset.sum_image]
  · apply Finset.sum_congr rfl
    intro C _
    exact boundary_conjugate_map σ T C
  · intro C hC D hD heq
    exact T.finsetCongr.injective heq

theorem transported_partition_boundary_density_tendsto_zero
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    {ι : Type*} [Fintype ι]
    (Q : ∀ n, Finpartition (Finset.univ : Finset (V n)))
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (T : (n : ℕ) → Equiv.Perm (V n))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary (σ n) C : ℝ)) /
            Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        (∑ C ∈
          (SoficGroups.transportedUnivFinpartition (Q n) (T n)).parts,
            (SoficGroups.boundary
              (fun i => T n * σ n i * (T n)⁻¹) C : ℝ)) /
                Fintype.card (V n))
      atTop (nhds 0) := by
  have hsum (n : ℕ) :
      (∑ C ∈
        (SoficGroups.transportedUnivFinpartition (Q n) (T n)).parts,
          (SoficGroups.boundary
            (fun i => T n * σ n i * (T n)⁻¹) C : ℝ)) =
        ∑ C ∈ (Q n).parts,
          (SoficGroups.boundary (σ n) C : ℝ) := by
    exact_mod_cast
      sum_boundary_transportedUnivFinpartition (Q n) (σ n) (T n)
  simpa only [hsum] using hboundary

theorem exists_common_slow_overlap_scales_for_transported_partitions
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    {ι κ : Type*} [Fintype ι] [Fintype κ]
    (Q : ∀ n, Finpartition (Finset.univ : Finset (V n)))
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (T : (n : ℕ) → κ → Equiv.Perm (V n))
    (gamma : ℝ) (hgamma : 0 < gamma)
    (hexp : ∀ n C, C ∈ (Q n).parts →
      ∀ E : Finset (V n), E ⊆ C →
        2 * E.card ≤ C.card →
          gamma * (E.card : ℝ) ≤
            (SoficGroups.boundary (σ n) E : ℝ))
    (hsource : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary (σ n) C : ℝ)) /
            Fintype.card (V n))
      atTop (nhds 0))
    (htarget : ∀ j : κ, Tendsto
      (fun n =>
        (∑ D ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i => T n j * σ n i * (T n j)⁻¹) D : ℝ)) /
              Fintype.card (V n))
      atTop (nhds 0)) :
    ∃ eta H : ℕ → ℝ,
      (∀ n, 0 < eta n) ∧
        Antitone eta ∧
        Tendsto eta atTop (nhds 0) ∧
        (∀ n, 0 < H n) ∧
        Antitone H ∧
        Tendsto H atTop (nhds 0) ∧
        Tendsto (fun n => eta n / H n) atTop (nhds 0) ∧
        ∀ j : κ, Tendsto
          (fun n =>
            (∑ C ∈ SoficGroups.insufficientOverlapComponents
              (SoficGroups.transportedUnivFinpartition
                (Q n) (T n j))
              (Q n) (eta n), (C.card : ℝ)) /
                Fintype.card (V n))
          atTop (nhds 0) := by
  classical
  let L : κ → ℕ → ℝ := fun j n =>
    (∑ C ∈
      (SoficGroups.transportedUnivFinpartition
        (Q n) (T n j)).parts,
      ((C.card : ℝ) -
        ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
          Fintype.card (V n)
  have hLnonneg (j : κ) (n : ℕ) : 0 ≤ L j n := by
    dsimp [L]
    apply div_nonneg
    · apply Finset.sum_nonneg
      intro C _
      apply sub_nonneg.mpr
      exact_mod_cast Finset.card_le_card
        (Finset.inter_subset_left :
          C ∩ SoficGroups.maximumOverlapPart (Q n) C ⊆ C)
    · exact Nat.cast_nonneg _
  have hLlimit (j : κ) :
      Tendsto (L j) atTop (nhds 0) := by
    apply dominant_component_loss_density_tendsto_zero
      (fun n =>
        SoficGroups.transportedUnivFinpartition (Q n) (T n j))
      Q
      (fun n i => T n j * σ n i * (T n j)⁻¹)
      gamma hgamma
    · intro n
      exact transportedUnivFinpartition_half_expansion
        (Q n) (σ n) (T n j) gamma (hexp n)
    · exact transported_partition_boundary_density_tendsto_zero
        Q σ (fun n => T n j) hsource
    · exact htarget j
  let e : ℕ → ℝ := fun n => ∑ j : κ, L j n
  have henonneg (n : ℕ) : 0 ≤ e n := by
    exact Finset.sum_nonneg fun j _ => hLnonneg j n
  have helimit : Tendsto e atTop (nhds 0) := by
    dsimp [e]
    simpa using
      tendsto_finsetSum Finset.univ
        (fun j _ => hLlimit j)
  obtain ⟨eta, H, heta, hetaanti, hetalimit,
    hH, hHanti, hHlimit, hslow, hratio⟩ :=
    SoficGroups.exists_positive_antitone_slow_overlap_scales
      e henonneg helimit
  refine ⟨eta, H, heta, hetaanti, hetalimit,
    hH, hHanti, hHlimit, hratio, ?_⟩
  intro j
  refine squeeze_zero (fun n =>
    div_nonneg (Finset.sum_nonneg fun C _ => Nat.cast_nonneg C.card)
      (Nat.cast_nonneg _)) ?_ hslow
  intro n
  let P : Finpartition (Finset.univ : Finset (V n)) :=
    SoficGroups.transportedUnivFinpartition (Q n) (T n j)
  have hmass :=
    SoficGroups.insufficientOverlapComponents_mass_le_loss
      P (Q n) (eta n)
  have hdivide :
      (∑ C ∈ SoficGroups.insufficientOverlapComponents
        P (Q n) (eta n), (C.card : ℝ)) ≤
          (∑ C ∈ P.parts,
            ((C.card : ℝ) -
              ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card :
                ℝ))) / eta n := by
    apply (le_div_iff₀ (heta n)).2
    simpa [mul_comm] using hmass
  have hcard : (0 : ℝ) < Fintype.card (V n) := by
    exact_mod_cast Fintype.card_pos_iff.mpr inferInstance
  have hsingle : L j n ≤ e n := by
    exact Finset.single_le_sum
      (fun k _ => hLnonneg k n)
      (Finset.mem_univ j)
  change
    (∑ C ∈ SoficGroups.insufficientOverlapComponents
      P (Q n) (eta n), (C.card : ℝ)) /
        Fintype.card (V n) ≤ e n / eta n
  calc
    (∑ C ∈ SoficGroups.insufficientOverlapComponents
      P (Q n) (eta n), (C.card : ℝ)) /
        Fintype.card (V n) ≤
      ((∑ C ∈ P.parts,
        ((C.card : ℝ) -
          ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
            eta n) / Fintype.card (V n) :=
      div_le_div_of_nonneg_right hdivide hcard.le
    _ = L j n / eta n := by
      dsimp [L, P]
      ring
    _ ≤ e n / eta n :=
      div_le_div_of_nonneg_right hsingle (heta n).le

end KunTransportedAmbientOverlap

namespace KunUniformCompletedRootRadiusImprovement

open SoficGroups.KunDiagonalGoodRootGraphLoss
open SoficGroups.KunThomInvariantOrthogonal
open scoped BigOperators symmDiff

universe u

theorem exists_uniform_radius_hasAlmostCentralizerImprovement
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, u} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (w : G → List ↥S)
    (h α : ℝ) (hpositive : 0 < h) (hα : 0 < α) :
    ∃ r : ℕ,
      ∀ (V : Type u) [Fintype V] [Nonempty V] [DecidableEq V]
        (σ : ↥S → Equiv.Perm V) (φ : G → Equiv.Perm V)
        (tolerance : ℕ) (B : Finset V),
      (∀ g : G, φ g = ((w g).map σ).prod) →
      φ 1 = 1 →
      (∀ i : ↥S, φ (i : G) = σ i) →
      (∀ A : Finset V,
        h * min (A.card : ℝ)
          ((Fintype.card V : ℝ) - A.card) ≤
            (SoficGroups.boundary σ A : ℝ)) →
      (5 * (4 + h *
        (216 / ((S.card : ℝ) *
          (1 - kazhdanMarkovContractionFactor P S) ^ 2) +
            1 / (S.card : ℝ))) * (tolerance : ℝ) ≤
              h * (Fintype.card V : ℝ)) →
      (tolerance = 0 ∨
        (0 < (tolerance : ℝ) ∧
          α ≤ h * (tolerance : ℝ) /
            (2 * (h + 8 * (S.card : ℝ)) *
              (Fintype.card V : ℝ)) ∧
          2 * (S.card : ℝ) * (B.card : ℝ) ≤
            (tolerance : ℝ) ∧
          ∀ a g : G,
            (w a).length + (w g).length +
                (w (a * g)).length ≤ r →
              ∀ x : V, x ∉ B →
                φ (a * g) x = (φ a * φ g) x)) →
      SoficGroups.HasAlmostCentralizerImprovement σ tolerance := by
  classical
  letI : Nonempty (↥S) := ⟨⟨1, honeS⟩⟩
  let d : ℝ := S.card
  let q : ℝ := kazhdanMarkovContractionFactor P S
  let γ : ℝ := d * (1 - q) ^ 2 / 288
  have hd : 0 < d := by
    dsimp [d]
    exact_mod_cast Finset.card_pos.mpr ⟨1, honeS⟩
  have hq : q < 1 := by
    exact kazhdanMarkovContractionFactor_lt_one
      P S ⟨1, honeS⟩
  have hγpair :=
    SoficGroups.KunRootedUniversalToleranceNumerics.rooted_graph_coefficient_small
      hd hq
  have hγ : 0 < γ := by
    simpa only [γ] using hγpair.1
  have hγsmall :
      216 * γ < (S.card : ℝ) * (1 - q) ^ 2 := by
    simpa only [γ, d] using hγpair.2
  obtain ⟨r, hspectral⟩ :=
    SoficGroups.KunCompletedProductDiagonalSparseCut.exists_completed_goodPermutationGraph_sparse_cut
      P S honeS hcover hsymmetric w γ α hγ hα
        (by simpa only [q] using hγsmall)
  refine ⟨r, ?_⟩
  intro V _ _ _ σ φ tolerance B hword hone hgenerator
    hexp hslow hcase
  rcases hcase with htzero | ⟨ht, htarget, hbadS, hlocal⟩
  · subst tolerance
    exact SoficGroups.KunCompletedPrunedComponent.hasAlmostCentralizerImprovement_zero σ
  have hbad :
      2 * (Fintype.card (↥S) : ℝ) * (B.card : ℝ) ≤
        (tolerance : ℝ) := by
    simpa only [Fintype.card_coe] using hbadS
  have hslowq :
      5 * (4 + h *
        (216 / ((Fintype.card (↥S) : ℝ) * (1 - q) ^ 2) +
          1 / (Fintype.card (↥S) : ℝ))) *
            (tolerance : ℝ) ≤
              h * (Fintype.card V : ℝ) := by
    simpa only [Fintype.card_coe, q] using hslow
  apply
    SoficGroups.KunUniversalGoodRootReferenceCuts.hasAlmostCentralizerImprovement_of_universal_good_root_thresholds
      σ tolerance h q hpositive hq B
      (fun p => goodPermutationGraph p B) hexp
      hbad
      (fun p => goodPermutationGraph_subset p B)
      (fun p => card_permutationGraph_sdiff_goodPermutationGraph_le p B)
      (fun p =>
        boundary_goodPermutationGraph_le_commutationDefect_add σ p B)
      hslowq
  intro p hp
  let T : Finset (V × V) := goodPermutationGraph p B
  have hcard :
      (Fintype.card V : ℝ) - 2 * (B.card : ℝ) ≤
        (T.card : ℝ) := by
    exact card_goodPermutationGraph_ge_card_sub_twice_bad p B
  have hboundary :
      (SoficGroups.boundary
        (fun i : ↥S => (σ i).prodCongr (σ i)) T : ℝ) ≤
          3 * (tolerance : ℝ) := by
    have hbound :=
      boundary_goodPermutationGraph_le_commutationDefect_add σ p B
    have hbound_real :
        (SoficGroups.boundary
          (fun i : ↥S => (σ i).prodCongr (σ i)) T : ℝ) ≤
          (SoficGroups.permutationCommutationDefect σ p : ℝ) +
            2 * (Fintype.card (↥S) : ℝ) * (B.card : ℝ) := by
      exact_mod_cast hbound
    have hp_real :
        (SoficGroups.permutationCommutationDefect σ p : ℝ) ≤
          2 * (tolerance : ℝ) := by
      exact_mod_cast hp
    linarith
  have hsparse :
      (SoficGroups.boundary
        (fun i : ↥S => (σ i).prodCongr (σ i)) T : ℝ) <
          γ * (T.card : ℝ) := by
    have hslowS :
        5 * (4 + h *
          (216 / (d * (1 - q) ^ 2) + 1 / d)) *
            (tolerance : ℝ) ≤
              h * (Fintype.card V : ℝ) := by
      simpa only [d, q] using hslow
    have hbad' :
        2 * d * (B.card : ℝ) ≤ (tolerance : ℝ) := by
      simpa only [d] using hbadS
    have hs :=
      SoficGroups.KunRootedUniversalToleranceNumerics.rooted_graph_boundary_lt_of_slow_tolerance
        hpositive hd hq ht hbad' hcard hboundary hslowS
    simpa only [γ] using hs
  have hT : T.Nonempty := by
    apply Finset.card_pos.mp
    have hnonnegative :
        0 ≤ (SoficGroups.boundary
          (fun i : ↥S => (σ i).prodCongr (σ i)) T : ℝ) := by
      positivity
    have hpositiveT : 0 < (T.card : ℝ) := by
      nlinarith
    exact_mod_cast hpositiveT
  obtain ⟨U, hreference, _hclose, hcut⟩ :=
    hspectral V σ φ hword hone hgenerator p B hlocal hT hsparse
  refine ⟨U, ?_, ?_⟩
  · simpa only [T, q, Fintype.card_coe] using hreference
  · calc
      (SoficGroups.boundary
        (fun i : ↥S => (σ i).prodCongr (σ i)) U : ℝ) ≤
          α * (U.card : ℝ) := hcut
      _ ≤ (h * (tolerance : ℝ) /
          (2 * (h + 8 * (Fintype.card (↥S) : ℝ)) *
            (Fintype.card V : ℝ))) * (U.card : ℝ) := by
        apply mul_le_mul_of_nonneg_right _ (Nat.cast_nonneg _)
        simpa only [Fintype.card_coe] using htarget

end KunUniformCompletedRootRadiusImprovement

namespace CompletedChosenWordLocalRoot

open Filter Topology
open scoped BigOperators

theorem normalizedHamming_mul_le
    {V : Type*} [Fintype V] [DecidableEq V]
    (p p' q q' : Equiv.Perm V) :
    SoficGroups.normalizedHamming (p * q) (p' * q') ≤
      SoficGroups.normalizedHamming p p' +
        SoficGroups.normalizedHamming q q' := by
  calc
    SoficGroups.normalizedHamming (p * q) (p' * q') ≤
        SoficGroups.normalizedHamming (p * q) (p' * q) +
          SoficGroups.normalizedHamming (p' * q) (p' * q') :=
      SoficGroups.normalizedHamming_triangle _ _ _
    _ = SoficGroups.normalizedHamming p p' +
        SoficGroups.normalizedHamming q q' := by
      rw [SoficGroups.normalizedHamming_mul_right,
        SoficGroups.normalizedHamming_mul_left]

theorem list_permutation_hamming_tendsto
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    {ι : Type*}
    (σ τ : ∀ n, ι → Equiv.Perm (V n))
    (hletter : ∀ i : ι,
      Tendsto
        (fun n => SoficGroups.normalizedHamming (σ n i) (τ n i))
        atTop (nhds 0))
    (l : List ι) :
    Tendsto
      (fun n => SoficGroups.normalizedHamming
        ((l.map (σ n)).prod) ((l.map (τ n)).prod))
      atTop (nhds 0) := by
  induction l with
  | nil =>
      simp [SoficGroups.normalizedHamming_self]
  | cons i l ih =>
      simp only [List.map_cons, List.prod_cons]
      have hupper : Tendsto
          (fun n =>
            SoficGroups.normalizedHamming (σ n i) (τ n i) +
              SoficGroups.normalizedHamming
                ((l.map (σ n)).prod) ((l.map (τ n)).prod))
          atTop (nhds 0) := by
        simpa using (hletter i).add ih
      refine squeeze_zero
        (fun n => SoficGroups.normalizedHamming_nonneg _ _) ?_ hupper
      intro n
      exact normalizedHamming_mul_le
        (σ n i) (τ n i)
        ((l.map (σ n)).prod) ((l.map (τ n)).prod)

theorem approximate_action_list_prod_tendsto
    {G : Type*} [Group G]
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (p : ∀ n, G → Equiv.Perm (V n))
    (hone : ∀ n, p n 1 = 1)
    (hmul : ∀ a g : G,
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (p n (a * g)) (p n a * p n g))
        atTop (nhds 0))
    (l : List G) :
    Tendsto
      (fun n => SoficGroups.normalizedHamming
        (p n l.prod) ((l.map (p n)).prod))
      atTop (nhds 0) := by
  induction l with
  | nil =>
      simp [hone, SoficGroups.normalizedHamming_self]
  | cons a l ih =>
      simp only [List.map_cons, List.prod_cons]
      have hupper : Tendsto
          (fun n =>
            SoficGroups.normalizedHamming
                (p n (a * l.prod)) (p n a * p n l.prod) +
              SoficGroups.normalizedHamming
                (p n l.prod) ((l.map (p n)).prod))
          atTop (nhds 0) := by
        simpa using (hmul a l.prod).add ih
      refine squeeze_zero
        (fun n => SoficGroups.normalizedHamming_nonneg _ _) ?_ hupper
      intro n
      have h := SoficGroups.normalizedHamming_triangle
        (p n (a * l.prod))
        (p n a * p n l.prod)
        (p n a * (l.map (p n)).prod)
      rw [SoficGroups.normalizedHamming_mul_left] at h
      exact h

def chosenWordEvaluation
    {G ι V : Type*}
    (σ : ι → Equiv.Perm V) (w : G → List ι) (g : G) :
    Equiv.Perm V :=
  ((w g).map σ).prod

theorem chosenWordEvaluation_tendsto_action
    {G ι : Type*} [Group G]
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (p : ∀ n, G → Equiv.Perm (V n))
    (hone : ∀ n, p n 1 = 1)
    (hmul : ∀ a g : G,
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (p n (a * g)) (p n a * p n g))
        atTop (nhds 0))
    (s : ι → G) (w : G → List ι)
    (hw : ∀ g : G, ((w g).map s).prod = g)
    (σ : ∀ n, ι → Equiv.Perm (V n))
    (hletter : ∀ i : ι,
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (σ n i) (p n (s i)))
        atTop (nhds 0))
    (g : G) :
    Tendsto
      (fun n => SoficGroups.normalizedHamming
        (chosenWordEvaluation (σ n) w g) (p n g))
      atTop (nhds 0) := by
  have hσ : Tendsto
      (fun n => SoficGroups.normalizedHamming
        (chosenWordEvaluation (σ n) w g)
        (((w g).map fun i => p n (s i)).prod))
      atTop (nhds 0) := by
    exact list_permutation_hamming_tendsto V
      σ (fun n i => p n (s i)) hletter (w g)
  have hp : Tendsto
      (fun n => SoficGroups.normalizedHamming
        (p n g) (((w g).map fun i => p n (s i)).prod))
      atTop (nhds 0) := by
    have h := approximate_action_list_prod_tendsto
      V p hone hmul ((w g).map s)
    simpa [List.map_map, Function.comp_def, hw g] using h
  have hp' : Tendsto
      (fun n => SoficGroups.normalizedHamming
        (((w g).map fun i => p n (s i)).prod) (p n g))
      atTop (nhds 0) := by
    have heq :
        (fun n => SoficGroups.normalizedHamming
          (((w g).map fun i => p n (s i)).prod) (p n g)) =
        (fun n => SoficGroups.normalizedHamming
          (p n g) (((w g).map fun i => p n (s i)).prod)) := by
      funext n
      exact SoficGroups.normalizedHamming_comm _ _
    rw [heq]
    exact hp
  have hupper : Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          (chosenWordEvaluation (σ n) w g)
          (((w g).map fun i => p n (s i)).prod) +
        SoficGroups.normalizedHamming
          (((w g).map fun i => p n (s i)).prod) (p n g))
      atTop (nhds 0) := by
    simpa using hσ.add hp'
  exact squeeze_zero
    (fun n => SoficGroups.normalizedHamming_nonneg _ _)
    (fun n => SoficGroups.normalizedHamming_triangle _ _ _)
    hupper

theorem chosenWordEvaluation_multiplicative_tendsto
    {G ι : Type*} [Group G]
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (p : ∀ n, G → Equiv.Perm (V n))
    (hone : ∀ n, p n 1 = 1)
    (hmul : ∀ a g : G,
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (p n (a * g)) (p n a * p n g))
        atTop (nhds 0))
    (s : ι → G) (w : G → List ι)
    (hw : ∀ g : G, ((w g).map s).prod = g)
    (σ : ∀ n, ι → Equiv.Perm (V n))
    (hletter : ∀ i : ι,
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (σ n i) (p n (s i)))
        atTop (nhds 0))
    (a g : G) :
    Tendsto
      (fun n => SoficGroups.normalizedHamming
        (chosenWordEvaluation (σ n) w (a * g))
        (chosenWordEvaluation (σ n) w a *
          chosenWordEvaluation (σ n) w g))
      atTop (nhds 0) := by
  let φ : ∀ n, G → Equiv.Perm (V n) :=
    fun n k => chosenWordEvaluation (σ n) w k
  have hφ (k : G) : Tendsto
      (fun n => SoficGroups.normalizedHamming (φ n k) (p n k))
      atTop (nhds 0) :=
    chosenWordEvaluation_tendsto_action
      V p hone hmul s w hw σ hletter k
  have hpa : Tendsto
      (fun n => SoficGroups.normalizedHamming (p n a) (φ n a))
      atTop (nhds 0) := by
    have heq :
        (fun n => SoficGroups.normalizedHamming (p n a) (φ n a)) =
        (fun n => SoficGroups.normalizedHamming (φ n a) (p n a)) := by
      funext n
      exact SoficGroups.normalizedHamming_comm _ _
    rw [heq]
    exact hφ a
  have hpg : Tendsto
      (fun n => SoficGroups.normalizedHamming (p n g) (φ n g))
      atTop (nhds 0) := by
    have heq :
        (fun n => SoficGroups.normalizedHamming (p n g) (φ n g)) =
        (fun n => SoficGroups.normalizedHamming (φ n g) (p n g)) := by
      funext n
      exact SoficGroups.normalizedHamming_comm _ _
    rw [heq]
    exact hφ g
  have hupper : Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          (φ n (a * g)) (p n (a * g)) +
        (SoficGroups.normalizedHamming
          (p n (a * g)) (p n a * p n g) +
        (SoficGroups.normalizedHamming (p n a) (φ n a) +
          SoficGroups.normalizedHamming (p n g) (φ n g))))
      atTop (nhds 0) := by
    simpa using (hφ (a * g)).add
      ((hmul a g).add (hpa.add hpg))
  change Tendsto
    (fun n => SoficGroups.normalizedHamming
      (φ n (a * g)) (φ n a * φ n g)) atTop (nhds 0)
  refine squeeze_zero
    (fun n => SoficGroups.normalizedHamming_nonneg _ _) ?_ hupper
  intro n
  calc
    SoficGroups.normalizedHamming
        (φ n (a * g)) (φ n a * φ n g) ≤
      SoficGroups.normalizedHamming
        (φ n (a * g)) (p n (a * g)) +
      SoficGroups.normalizedHamming
        (p n (a * g)) (φ n a * φ n g) :=
      SoficGroups.normalizedHamming_triangle _ _ _
    _ ≤ SoficGroups.normalizedHamming
        (φ n (a * g)) (p n (a * g)) +
      (SoficGroups.normalizedHamming
        (p n (a * g)) (p n a * p n g) +
        SoficGroups.normalizedHamming
          (p n a * p n g) (φ n a * φ n g)) := by
      gcongr
      exact SoficGroups.normalizedHamming_triangle _ _ _
    _ ≤ SoficGroups.normalizedHamming
        (φ n (a * g)) (p n (a * g)) +
      (SoficGroups.normalizedHamming
        (p n (a * g)) (p n a * p n g) +
        (SoficGroups.normalizedHamming (p n a) (φ n a) +
          SoficGroups.normalizedHamming (p n g) (φ n g))) := by
      gcongr
      exact normalizedHamming_mul_le
        (p n a) (φ n a) (p n g) (φ n g)

end CompletedChosenWordLocalRoot

namespace CompletedSourceChosenWordRestrictionTransfer

open Filter Topology
open SoficGroups.MatchedComponentCompletion
open SoficGroups.MatchedComponentExitBudget
open SoficGroups.MatchedFirstStageWordRadiusTransfer
open scoped BigOperators

theorem completedGenerator_permutationDistance_le_deleted
    {V : Type*} [Fintype V] [DecidableEq V]
    (σ : Equiv.Perm V) (Z : Finset V)
    (τ : Equiv.Perm {x : V // x ∈ Z})
    (hagrees : ∀ x : {x : V // x ∈ Z},
      σ (x : V) ∈ Z →
        ((τ x : {x : V // x ∈ Z}) : V) = σ (x : V)) :
    SoficGroups.permutationDistance
      τ (completedRestriction σ Z) ≤
        (Finset.univ \ Z).card := by
  let E : Finset V := Z.filter fun x => σ x ∉ Z
  have hpoint : ∀ x : {x : V // x ∈ Z},
      (x : V) ∉ E → τ x = completedRestriction σ Z x := by
    intro x hx
    have hinside : σ (x : V) ∈ Z := by
      by_contra hout
      apply hx
      exact Finset.mem_filter.mpr ⟨x.property, hout⟩
    apply Subtype.ext
    calc
      ((τ x : {x : V // x ∈ Z}) : V) =
          σ (x : V) := hagrees x hinside
      _ = ((completedRestriction σ Z x :
          {x : V // x ∈ Z}) : V) := by
        symm
        exact completedRestriction_apply_of_mem
          σ Z x x.property hinside
  calc
    SoficGroups.permutationDistance
        τ (completedRestriction σ Z) ≤
      (subtypeBad Z E).card :=
        permutationDistance_le_subtypeBad Z E
          τ (completedRestriction σ Z) hpoint
    _ = (Z ∩ E).card := card_subtypeBad Z E
    _ ≤ E.card := Finset.card_le_card Finset.inter_subset_right
    _ ≤ (Finset.univ \ Z).card := by
      simpa only [E] using
        card_permutation_exit_le_deleted σ Z

theorem completedGenerator_normalizedHamming_le_deleted
    {V : Type*} [Fintype V] [DecidableEq V]
    (σ : Equiv.Perm V) (Z : Finset V)
    (τ : Equiv.Perm {x : V // x ∈ Z})
    (hagrees : ∀ x : {x : V // x ∈ Z},
      σ (x : V) ∈ Z →
        ((τ x : {x : V // x ∈ Z}) : V) = σ (x : V)) :
    SoficGroups.normalizedHamming
      τ (completedRestriction σ Z) ≤
        (((Finset.univ \ Z).card : ℝ) / Z.card) := by
  have hnat :=
    completedGenerator_permutationDistance_le_deleted
      σ Z τ hagrees
  have hreal :
      (SoficGroups.permutationDistance
        τ (completedRestriction σ Z) : ℝ) ≤
          (Finset.univ \ Z).card := by
    exact_mod_cast hnat
  have hdiv := div_le_div_of_nonneg_right hreal
    (show (0 : ℝ) ≤ (Z.card : ℝ) by positivity)
  simpa only [SoficGroups.normalizedHamming,
    SoficGroups.permutationDistance, Fintype.card_coe] using hdiv

theorem completedGenerator_normalizedHamming_tendsto_zero
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (σ : (n : ℕ) → Equiv.Perm (V n))
    (Z : (n : ℕ) → Finset (V n))
    (τ : (n : ℕ) → Equiv.Perm {x : V n // x ∈ Z n})
    (hagrees : ∀ n, ∀ x : {x : V n // x ∈ Z n},
      σ n (x : V n) ∈ Z n →
        ((τ n x : {x : V n // x ∈ Z n}) : V n) =
          σ n (x : V n))
    (hdeleted : Tendsto
      (fun n => (((Finset.univ \ Z n).card : ℝ) / (Z n).card))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          (τ n) (completedRestriction (σ n) (Z n)))
      atTop (nhds 0) := by
  apply squeeze_zero'
    (Filter.Eventually.of_forall fun n =>
      SoficGroups.normalizedHamming_nonneg
        (τ n) (completedRestriction (σ n) (Z n)))
    (Filter.Eventually.of_forall fun n =>
      completedGenerator_normalizedHamming_le_deleted
        (σ n) (Z n) (τ n) (hagrees n))
    hdeleted

end CompletedSourceChosenWordRestrictionTransfer

namespace CompletedSourceFinalGeneratorTransfer

open Filter Topology
open SoficGroups.MatchedComponentCompletion
open SoficGroups.CompletedSourceChosenWordRestrictionTransfer

theorem surviving_card_ratio_tendsto_one
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (D : (n : ℕ) → Finset (V n))
    (hZ : ∀ n, (Finset.univ \ D n : Finset (V n)).Nonempty)
    (hdeleted : Tendsto
      (fun n => ((D n).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        (((Finset.univ \ D n : Finset (V n)).card : ℝ) /
          Fintype.card (V n)))
      atTop (nhds 1) := by
  have hbase : Tendsto
      (fun n => (1 : ℝ) -
        ((D n).card : ℝ) / Fintype.card (V n))
      atTop (nhds 1) := by
    simpa using tendsto_const_nhds.sub hdeleted
  convert hbase using 1
  funext n
  have hU : (Finset.univ : Finset (V n)).Nonempty := by
    obtain ⟨x, _⟩ := hZ n
    exact ⟨x, Finset.mem_univ x⟩
  have hcard : Fintype.card (V n) ≠ 0 := by
    exact Finset.card_ne_zero.mpr hU
  rw [Finset.card_sdiff_of_subset
      (Finset.subset_univ (D n)),
    Finset.card_univ,
    Nat.cast_sub (Finset.card_le_univ (D n))]
  field_simp

theorem deleted_density_relative_survivors
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (D : (n : ℕ) → Finset (V n))
    (hZ : ∀ n, (Finset.univ \ D n : Finset (V n)).Nonempty)
    (hdeleted : Tendsto
      (fun n => ((D n).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((D n).card : ℝ) /
          (Finset.univ \ D n : Finset (V n)).card)
      atTop (nhds 0) := by
  have hcover :=
    surviving_card_ratio_tendsto_one V D hZ hdeleted
  have hquotient : Tendsto
      ((fun n => ((D n).card : ℝ) / Fintype.card (V n)) /
        (fun n =>
          ((Finset.univ \ D n : Finset (V n)).card : ℝ) /
            Fintype.card (V n)))
      atTop (nhds 0) := by
    simpa only [zero_div] using
      hdeleted.div hcover (by norm_num : (1 : ℝ) ≠ 0)
  convert hquotient using 1
  funext n
  have hN : Fintype.card (V n) ≠ 0 := by
    obtain ⟨x, _⟩ := hZ n
    exact Finset.card_ne_zero.mpr
      (show (Finset.univ : Finset (V n)).Nonempty from
        ⟨x, Finset.mem_univ x⟩)
  have hNreal : (Fintype.card (V n) : ℝ) ≠ 0 := by
    exact_mod_cast hN
  have hZreal :
      ((Finset.univ \ D n : Finset (V n)).card : ℝ) ≠ 0 := by
    exact_mod_cast Finset.card_ne_zero.mpr (hZ n)
  change
    ((D n).card : ℝ) /
        (Finset.univ \ D n : Finset (V n)).card =
      (((D n).card : ℝ) / Fintype.card (V n)) /
        (((Finset.univ \ D n : Finset (V n)).card : ℝ) /
          Fintype.card (V n))
  field_simp [hNreal, hZreal]

theorem twiceCompleted_sourceGenerator_normalizedHamming_tendsto_zero
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    {ι J : Type*}
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (p : (n : ℕ) → J → Equiv.Perm (V n))
    (s : ι → J)
    (P : (n : ℕ) → Finset (V n))
    (D : (n : ℕ) → Finset {x : V n // x ∈ P n})
    (τ : (n : ℕ) → (i : ι) →
      Equiv.Perm
        {x : {x : V n // x ∈ P n} //
          x ∈ (Finset.univ \ D n :
            Finset {x : V n // x ∈ P n})})
    (hsource : ∀ n i, σ n i = p n (s i))
    (hagrees : ∀ n i,
      ∀ x : {x : {x : V n // x ∈ P n} //
        x ∈ (Finset.univ \ D n :
          Finset {x : V n // x ∈ P n})},
        completedRestriction (σ n i) (P n) x.val ∈
          (Finset.univ \ D n :
            Finset {x : V n // x ∈ P n}) →
        (τ n i x).val =
          completedRestriction (σ n i) (P n) x.val)
    (hZ : ∀ n,
      (Finset.univ \ D n :
        Finset {x : V n // x ∈ P n}).Nonempty)
    (hdeleted : Tendsto
      (fun n => ((D n).card : ℝ) / (P n).card)
      atTop (nhds 0)) :
    ∀ i : ι,
      Tendsto
        (fun n =>
          SoficGroups.normalizedHamming
            (τ n i)
            (completedRestriction
              (completedRestriction (p n (s i)) (P n))
              (Finset.univ \ D n)))
        atTop (nhds 0) := by
  intro i
  have hdeletedbase : Tendsto
      (fun n =>
        ((D n).card : ℝ) /
          Fintype.card {x : V n // x ∈ P n})
      atTop (nhds 0) := by
    simpa only [Fintype.card_coe] using hdeleted
  have hsurvivors :=
    deleted_density_relative_survivors
      (fun n => {x : V n // x ∈ P n}) D hZ hdeletedbase
  have hdeletedfinal : Tendsto
      (fun n =>
        (((Finset.univ \
          (Finset.univ \ D n :
            Finset {x : V n // x ∈ P n})).card : ℝ) /
          (Finset.univ \ D n :
            Finset {x : V n // x ∈ P n}).card))
      atTop (nhds 0) := by
    convert hsurvivors using 1
    funext n
    have hset :
        (Finset.univ \
          (Finset.univ \ D n :
            Finset {x : V n // x ∈ P n})) = D n := by
      ext x
      simp
    rw [hset]
  have hletter :=
    completedGenerator_normalizedHamming_tendsto_zero
      (fun n => {x : V n // x ∈ P n})
      (fun n => completedRestriction (σ n i) (P n))
      (fun n => (Finset.univ \ D n :
        Finset {x : V n // x ∈ P n}))
      (fun n => τ n i)
      (fun n => hagrees n i)
      hdeletedfinal
  convert hletter using 1
  funext n
  rw [hsource n i]

end CompletedSourceFinalGeneratorTransfer

namespace CompletedPrescribedSpectralRadiusSchedule

open Filter Topology
open scoped Pointwise

theorem mem_generator_pow_of_chosen_word_length
    {G : Type*} [Group G] [DecidableEq G]
    (S : Finset G) (hone : 1 ∈ S)
    (w : G → List ↥S)
    (hw : ∀ a : G,
      ((w a).map fun i : ↥S => (i : G)).prod = a)
    {a : G} {r : ℕ} (ha : (w a).length ≤ r) :
    a ∈ S ^ r := by
  have hprod : ∀ l : List ↥S,
      ((l.map fun i : ↥S => (i : G)).prod) ∈ S ^ l.length := by
    intro l
    induction l with
    | nil => simp
    | cons i l ih =>
        simpa [pow_succ', List.prod_cons] using
          (Finset.mul_mem_mul i.property ih)
  apply Finset.pow_subset_pow_right hone ha
  simpa only [hw a] using hprod (w a)

def multiplicationBad
    {G V : Type*} [Group G] [Fintype V] [DecidableEq V]
    (φ : G → Equiv.Perm V) (a g : G) : Finset V :=
  Finset.univ.filter (fun x => φ (a * g) x ≠ (φ a * φ g) x)

def fixedRadiusRootBad
    {G V : Type*} [Group G] [DecidableEq G]
    [Fintype V] [DecidableEq V]
    (φ : G → Equiv.Perm V) (S : Finset G) (r : ℕ) : Finset V :=
  ((S ^ r).product (S ^ r)).biUnion fun ag =>
    multiplicationBad φ ag.1 ag.2

theorem fixedRadiusRootBad_rooted
    {G V : Type*} [Group G] [DecidableEq G]
    [Fintype V] [DecidableEq V]
    (S : Finset G) (hone : 1 ∈ S)
    (w : G → List ↥S)
    (hw : ∀ a : G,
      ((w a).map fun i : ↥S => (i : G)).prod = a)
    (φ : G → Equiv.Perm V) (r : ℕ)
    (a g : G)
    (hr : (w a).length + (w g).length +
      (w (a * g)).length ≤ r)
    (x : V) (hx : x ∉ fixedRadiusRootBad φ S r) :
    φ (a * g) x = (φ a * φ g) x := by
  have ha : a ∈ S ^ r :=
    mem_generator_pow_of_chosen_word_length S hone w hw (by omega)
  have hg : g ∈ S ^ r :=
    mem_generator_pow_of_chosen_word_length S hone w hw (by omega)
  by_contra hfailure
  apply hx
  unfold fixedRadiusRootBad
  apply Finset.mem_biUnion.mpr
  refine ⟨(a, g), Finset.mem_product.mpr ⟨ha, hg⟩, ?_⟩
  unfold multiplicationBad
  exact Finset.mem_filter.mpr ⟨Finset.mem_univ x, hfailure⟩

theorem fixedRadiusRootBad_density_tendsto_zero
    {G : Type*} [Group G] [DecidableEq G]
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (φ : ∀ n, G → Equiv.Perm (V n))
    (S : Finset G)
    (hmul : ∀ a g : G,
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (φ n (a * g)) (φ n a * φ n g))
        atTop (𝓝 0))
    (r : ℕ) :
    Tendsto
      (fun n =>
        ((fixedRadiusRootBad (φ n) S r).card : ℝ) /
          Fintype.card (V n))
      atTop (𝓝 0) := by
  classical
  have hpair : ∀ ag ∈ (S ^ r).product (S ^ r),
      Tendsto
        (fun n =>
          (((Finset.univ : Finset (V n)) ∩
            multiplicationBad (φ n) ag.1 ag.2).card : ℝ) /
              (Finset.univ : Finset (V n)).card)
        atTop (𝓝 0) := by
    intro ag _
    simpa [multiplicationBad, SoficGroups.normalizedHamming,
      hammingDist] using hmul ag.1 ag.2
  have h := SoficGroups.finite_union_bad_density_tendsto_zero
    ((S ^ r).product (S ^ r))
    (fun n => (Finset.univ : Finset (V n)))
    (fun n ag => multiplicationBad (φ n) ag.1 ag.2)
    hpair
  simpa [fixedRadiusRootBad] using h

end CompletedPrescribedSpectralRadiusSchedule

namespace KunSourceUnconditionalFullDecomposition

section

open Filter Topology
open SoficGroups.KunActualSoficRootRadius
open SoficGroups.KunActualRootedModelBridge
open SoficGroups.KunRootedWordPower
open SoficGroups.KunThomInvariantOrthogonal
open scoped BigOperators symmDiff

theorem exists_source_sparse_cut_at_radius
    {G : Type} [Group G] [DecidableEq G]
    (P : SoficGroups.KazhdanPair.{0, 0} G)
    (S : Finset G) (hone : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (γ α : ℝ) (hγ : 0 < γ) (hα : 0 < α)
    (hsmall :
      216 * γ <
        (S.card : ℝ) *
          (1 - kazhdanMarkovContractionFactor P S) ^ 2) :
    ∃ r : ℕ,
      ∀ (A : SoficGroups.SoficApproximation G) (n : ℕ)
        (T : Finset (Fin (A.model n).size)),
      Disjoint T
        (chosenCayleyRadiusBad A S
          (symmetricGeneratorWord S hsymmetric hgenerates) n r) →
      (SoficGroups.boundary
        (fun i : ↥S => (A.model n).action (i : G)) T : ℝ) <
          γ * (T.card : ℝ) →
      ∃ U : Finset (Fin (A.model n).size),
        3 * (U ∆ T).card < T.card ∧
          (SoficGroups.boundary
            (fun i : ↥S => (A.model n).action (i : G)) U : ℝ) ≤
              α * (U.card : ℝ) := by
  classical
  obtain ⟨k, r, hr⟩ :=
    exists_rooted_word_radius_sparse_cut_of_boundary
      P S hone hcover hsymmetric
      (symmetricGeneratorWord S hsymmetric hgenerates)
      γ α hγ hα hsmall
  refine ⟨r, ?_⟩
  intro A n T hgood hboundary
  have hvertexInstance :
      (instDecidableEqFin (A.model n).size :
        DecidableEq (Fin (A.model n).size)) =
          Classical.decEq (Fin (A.model n).size) :=
    Subsingleton.elim _ _
  letI : DecidableEq (Fin (A.model n).size) :=
    Classical.decEq (Fin (A.model n).size)
  rw [hvertexInstance] at hboundary ⊢
  have hT : T.Nonempty := by
    by_contra hnot
    have hempty : T = ∅ :=
      Finset.not_nonempty_iff_eq_empty.mp hnot
    subst T
    simp [SoficGroups.boundary] at hboundary
  let X :=
    sourceRootedIndicatorMarkovModel
      A S hsymmetric hgenerates n T
  have hgenerated :
      X.IsGenerated (fun i : ↥S => (i : G))
        (symmetricGeneratorWord S hsymmetric hgenerates) :=
    sourceRootedIndicatorMarkovModel_isGenerated
      A S hsymmetric hgenerates n T
  have hrooted :
      X.IsRootedAtRadius
        (symmetricGeneratorWord S hsymmetric hgenerates) r :=
    sourceRootedIndicatorMarkovModel_isRootedAtRadius
      A S hone hsymmetric hgenerates n r T hgood
  have hboundary' :
      (SoficGroups.boundary X.generator T : ℝ) <
        γ * (T.card : ℝ) := by
    change
      (SoficGroups.boundary
        (fun i : ↥S => (A.model n).action (i : G)) T : ℝ) <
          γ * (T.card : ℝ)
    exact hboundary
  obtain ⟨U, _hmarkov, _hreference, hclose, hcut⟩ :=
    hr X hgenerated hrooted T hT
      (by
        intro x
        dsimp only [X, sourceRootedIndicatorMarkovModel,
          sourceFiniteIndicator]
        split
        next hleft =>
          split
          next => rfl
          next hright =>
            exfalso
            apply hright
            exact Finset.mem_def.mpr (Finset.mem_def.mp hleft)
        next hleft =>
          split
          next hright =>
            exfalso
            apply hleft
            exact Finset.mem_def.mpr (Finset.mem_def.mp hright)
          next => rfl)
      hboundary'
  exact ⟨U, hclose, hcut⟩

theorem exists_source_full_finpartition_sequence_of_kazhdan
    {G : Type} [Group G] [DecidableEq G]
    (A : SoficGroups.SoficApproximation G)
    (P : SoficGroups.KazhdanPair.{0, 0} G)
    (S : Finset G) (hone : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤) :
    ∃ (γ : ℝ)
      (Q : (n : ℕ) →
        Finpartition
          (Finset.univ : Finset (Fin (A.model n).size))),
      0 < γ ∧
        (∀ n, ∀ C ∈ (Q n).parts,
          ∀ E : Finset (Fin (A.model n).size),
            E ⊆ C →
            2 * E.card ≤ C.card →
            γ * (E.card : ℝ) ≤
              (SoficGroups.boundary
                (fun i : ↥S =>
                  (A.model n).action (i : G)) E : ℝ)) ∧
        Tendsto
          (fun n =>
            (∑ C ∈ (Q n).parts,
              (SoficGroups.boundary
                (fun i : ↥S =>
                  (A.model n).action (i : G)) C : ℝ)) /
                  (A.model n).size)
          atTop (𝓝 0) := by
  classical
  letI : Nonempty (↥S) := ⟨⟨1, hone⟩⟩
  let q : ℝ := kazhdanMarkovContractionFactor P S
  let γ : ℝ := (S.card : ℝ) * (1 - q) ^ 2 / 288
  have hq : q < 1 :=
    kazhdanMarkovContractionFactor_lt_one P S ⟨1, hone⟩
  have hd : 0 < (S.card : ℝ) := by
    exact_mod_cast Finset.card_pos.mpr ⟨1, hone⟩
  have hγ : 0 < γ := by
    dsimp [γ]
    positivity
  have hsmall :
      216 * γ <
        (S.card : ℝ) *
          (1 - kazhdanMarkovContractionFactor P S) ^ 2 := by
    have hgap : 0 < (S.card : ℝ) * (1 - q) ^ 2 := by
      positivity
    dsimp [γ, q]
    nlinarith
  let α : ℕ → ℝ := fun j => 1 / ((j : ℝ) + 1)
  have hα (j : ℕ) : 0 < α j := by
    dsimp [α]
    positivity
  have hαzero : Tendsto α atTop (𝓝 0) := by
    simpa [α] using
      (tendsto_one_div_add_atTop_nhds_zero_nat (𝕜 := ℝ))
  have hsparse (j : ℕ) :=
    exists_source_sparse_cut_at_radius
      P S hone hcover hsymmetric hgenerates
      γ (α j) hγ (hα j) hsmall
  let radius : ℕ → ℕ := fun j => (hsparse j).choose
  let w : G → List ↥S :=
    symmetricGeneratorWord S hsymmetric hgenerates
  have hw : ∀ g : G,
      ((w g).map fun i : ↥S => (i : G)).prod = g := by
    intro g
    exact symmetricGeneratorWord_prod S hsymmetric hgenerates g
  let e : ℕ → ℕ → ℝ := fun n j =>
    ((chosenCayleyRadiusBad A S w n (radius j)).card : ℝ) /
      (A.model n).size
  have henonnegative : ∀ n j, 0 ≤ e n j := by
    intro n j
    dsimp [e]
    positivity
  have hezero (j : ℕ) :
      Tendsto (fun n => e n j) atTop (𝓝 0) := by
    simpa only [e] using
      chosenCayleyRadiusBad_density_tendsto_zero
        A S w hw (radius j)
  obtain ⟨m, hm, he⟩ :=
    SoficGroups.exists_diverging_radius_with_vanishing_diagonal_error
      e henonnegative hezero
  let B : (n : ℕ) → Finset (Fin (A.model n).size) :=
    fun n => chosenCayleyRadiusBad A S w n (radius (m n))
  let a : ℕ → ℝ := fun n => α (m n)
  let σ : (n : ℕ) → ↥S → Equiv.Perm (Fin (A.model n).size) :=
    fun n i => (A.model n).action (i : G)
  letI (n : ℕ) : Nonempty (Fin (A.model n).size) :=
    ⟨⟨0, (A.model n).size_pos⟩⟩
  have hazero : Tendsto a atTop (𝓝 0) := by
    exact hαzero.comp hm
  have hbad :
      Tendsto
        (fun n =>
          ((B n).card : ℝ) /
            Fintype.card (Fin (A.model n).size))
        atTop (𝓝 0) := by
    simpa only [B, e, Fintype.card_fin] using he
  have himprove :
      ∀ n (T : Finset (Fin (A.model n).size)),
        T ⊆ Finset.univ \ B n →
        (SoficGroups.boundary (σ n) T : ℝ) <
          γ * (T.card : ℝ) →
        ∃ U : Finset (Fin (A.model n).size),
          3 * (U ∆ T).card < T.card ∧
            (SoficGroups.boundary (σ n) U : ℝ) ≤
              a n * (U.card : ℝ) := by
    intro n T hT hboundary
    have hdisjoint : Disjoint T (B n) := by
      apply Finset.disjoint_left.mpr
      intro x hx hbadx
      exact (Finset.mem_sdiff.mp (hT hx)).2 hbadx
    have hgood :
        Disjoint T
          (chosenCayleyRadiusBad A S
            (symmetricGeneratorWord S hsymmetric hgenerates)
            n ((hsparse (m n)).choose)) := by
      simpa only [B, w, radius] using hdisjoint
    have hboundary' :
        (SoficGroups.boundary
          (fun i : ↥S => (A.model n).action (i : G)) T : ℝ) <
            γ * (T.card : ℝ) := by
      simpa only [σ] using hboundary
    obtain ⟨U, hclose, hcut⟩ :=
      (hsparse (m n)).choose_spec A n T hgood hboundary'
    refine ⟨U, hclose, ?_⟩
    simpa only [σ, a] using hcut
  obtain ⟨Q, hγ', hQ, hbudget⟩ :=
    SoficGroups.KunResidualExpanderDecomposition.exists_expanding_full_finpartition_sequence
        (↥S) (fun n => Fin (A.model n).size)
        σ B γ hγ a
        (fun n => (hα (m n)).le)
        hazero hbad himprove
  refine ⟨γ, Q, hγ', ?_, ?_⟩
  · simpa only [σ] using hQ
  · simpa only [σ, Fintype.card_fin] using hbudget

end

section

open Filter Topology

theorem exists_source_subgroup_and_ambient_full_finpartition_sequences
    {G Γ : Type} [Group G] [Group Γ]
    [DecidableEq G] [DecidableEq Γ]
    (A : SoficGroups.SoficApproximation G)
    (f : Γ →* G) (hf : Function.Injective f)
    (PΓ : SoficGroups.KazhdanPair.{0, 0} Γ)
    (PG : SoficGroups.KazhdanPair.{0, 0} G)
    (SΓ : Finset Γ) (SG : Finset G)
    (honeΓ : 1 ∈ SΓ) (honeG : 1 ∈ SG)
    (hcoverΓ : PΓ.generators ⊆ SΓ)
    (hcoverG : PG.generators ⊆ SG)
    (hsymmetricΓ : ∀ g ∈ SΓ, g⁻¹ ∈ SΓ)
    (hsymmetricG : ∀ g ∈ SG, g⁻¹ ∈ SG)
    (hgeneratesΓ : Subgroup.closure (SΓ : Set Γ) = ⊤)
    (hgeneratesG : Subgroup.closure (SG : Set G) = ⊤) :
    ∃ (γΓ γG : ℝ)
      (QΓ QG : (n : ℕ) →
        Finpartition
          (Finset.univ : Finset (Fin (A.model n).size))),
      0 < γΓ ∧
      0 < γG ∧
      (∀ n, ∀ C ∈ (QΓ n).parts,
        ∀ E : Finset (Fin (A.model n).size),
          E ⊆ C →
          2 * E.card ≤ C.card →
          γΓ * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action (f (i : Γ))) E : ℝ)) ∧
      (∀ n, ∀ C ∈ (QG n).parts,
        ∀ E : Finset (Fin (A.model n).size),
          E ⊆ C →
          2 * E.card ≤ C.card →
          γG * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥SG =>
                (A.model n).action (i : G)) E : ℝ)) ∧
      Tendsto
        (fun n =>
          (∑ C ∈ (QΓ n).parts,
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action (f (i : Γ))) C : ℝ)) /
                (A.model n).size)
        atTop (𝓝 0) ∧
      Tendsto
        (fun n =>
          (∑ C ∈ (QG n).parts,
            (SoficGroups.boundary
              (fun i : ↥SG =>
                (A.model n).action (i : G)) C : ℝ)) /
                (A.model n).size)
        atTop (𝓝 0) := by
  obtain ⟨γΓ, QΓ, hγΓ, hexpΓ, hbudgetΓ⟩ :=
    exists_source_full_finpartition_sequence_of_kazhdan
      (SoficGroups.pullbackSoficApproximation f hf A)
      PΓ SΓ honeΓ hcoverΓ hsymmetricΓ hgeneratesΓ
  obtain ⟨γG, QG, hγG, hexpG, hbudgetG⟩ :=
    exists_source_full_finpartition_sequence_of_kazhdan
      A PG SG honeG hcoverG hsymmetricG hgeneratesG
  refine ⟨γΓ, γG, QΓ, QG, hγΓ, hγG, ?_, hexpG, ?_,
    hbudgetG⟩
  · exact hexpΓ
  · exact hbudgetΓ

end

end KunSourceUnconditionalFullDecomposition

namespace KunActualCompressedSourceGroupFoundations

universe v

theorem alphaZeroPrefixElementaryGroup_infinite :
    Infinite
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaZeroPrefixCode) := by
  letI : Infinite (SoficGroups.binaryLeavittElementaryGroup 3) :=
    SoficGroups.binaryLeavittEL3_infinite
  exact Infinite.of_injective
    (SoficGroups.binaryPrefixElementaryGroupEquiv
      SoficGroups.alphaZeroPrefixCode)
    (SoficGroups.binaryPrefixElementaryGroupEquiv
      SoficGroups.alphaZeroPrefixCode).injective

end KunActualCompressedSourceGroupFoundations

namespace KunExactKazhdanGeneratorChange

universe u v

theorem unitary_word_displacement_le
    {G : Type u} {H : Type v} [Group G]
    [NormedAddCommGroup H] [InnerProductSpace ℂ H]
    (π : SoficGroups.UnitaryRepresentation G H)
    (ξ : H) (l : List G) (δ : ℝ)
    (hletters : ∀ g ∈ l, ‖π g ξ - ξ‖ ≤ δ) :
    ‖π l.prod ξ - ξ‖ ≤ (l.length : ℝ) * δ := by
  induction l with
  | nil =>
      simp
  | cons g l ih =>
      have hg : ‖π g ξ - ξ‖ ≤ δ :=
        hletters g (by simp)
      have htail :
          ∀ a ∈ l, ‖π a ξ - ξ‖ ≤ δ := by
        intro a ha
        exact hletters a (by simp [ha])
      have hword := ih htail
      calc
        ‖π (g :: l).prod ξ - ξ‖ =
            ‖π g (π l.prod ξ - ξ) + (π g ξ - ξ)‖ := by
              congr 1
              simp [map_mul, map_sub]
        _ ≤ ‖π g (π l.prod ξ - ξ)‖ +
              ‖π g ξ - ξ‖ := norm_add_le _ _
        _ = ‖π l.prod ξ - ξ‖ + ‖π g ξ - ξ‖ := by
              rw [LinearIsometryEquiv.norm_map]
        _ ≤ (l.length : ℝ) * δ + δ := by linarith
        _ = ((g :: l).length : ℝ) * δ := by
              simp
              ring

theorem exists_word_of_symmetric_generating_finset
    {G : Type u} [Group G] (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤) (g : G) :
    ∃ l : List ↥S, ((l.map fun i : ↥S => (i : G)).prod) = g := by
  classical
  have hg : g ∈ Subgroup.closure (S : Set G) := by
    rw [hgenerates]
    simp
  induction hg using Subgroup.closure_induction with
  | mem x hx =>
      exact ⟨[⟨x, hx⟩], by simp⟩
  | one =>
      exact ⟨[], by simp⟩
  | mul x y _ _ ihx ihy =>
      obtain ⟨lx, hlx⟩ := ihx
      obtain ⟨ly, hly⟩ := ihy
      refine ⟨lx ++ ly, ?_⟩
      rw [List.map_append, List.prod_append, hlx, hly]
  | inv x _ ih =>
      obtain ⟨l, hl⟩ := ih
      let invLetter : ↥S → ↥S :=
        fun i => ⟨(i : G)⁻¹, hsymmetric (i : G) i.property⟩
      refine ⟨(l.map invLetter).reverse, ?_⟩
      rw [List.map_reverse, List.map_map]
      change ((l.map fun i : ↥S => (i : G)⁻¹).reverse).prod = x⁻¹
      have hmap :
          (l.map fun i : ↥S => (i : G)⁻¹) =
            (l.map fun i : ↥S => (i : G)).map
              (fun z : G => z⁻¹) := by
        rw [List.map_map]
        rfl
      rw [hmap, ← List.prod_inv_reverse, hl]

def symmetricGeneratingWord
    {G : Type u} [Group G] (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤) (g : G) :
    List ↥S :=
  (exists_word_of_symmetric_generating_finset
    S hsymmetric hgenerates g).choose

theorem symmetricGeneratingWord_prod
    {G : Type u} [Group G] (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤) (g : G) :
    (((symmetricGeneratingWord S hsymmetric hgenerates g).map
      fun i : ↥S => (i : G)).prod) = g :=
  (exists_word_of_symmetric_generating_finset
    S hsymmetric hgenerates g).choose_spec

def kazhdanPairOnSymmetricGeneratingFinset
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, v} G)
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤) :
    SoficGroups.KazhdanPair.{u, v} G := by
  classical
  let w : G → List ↥S :=
    symmetricGeneratingWord S hsymmetric hgenerates
  let L : ℕ := 1 + ∑ g ∈ P.generators, (w g).length
  have hL : 0 < L := by
    dsimp [L]
    omega
  have hLreal : 0 < (L : ℝ) := by
    exact_mod_cast hL
  refine
    { generators := S
      kazhdanConstant := P.kazhdanConstant / (L : ℝ)
      positive := div_pos P.positive hLreal
      invariant := ?_ }
  intro H _ _ _ π ξ hξ hS
  apply P.invariant H π ξ hξ
  intro g hg
  have hlength :
      (w g).length < L := by
    have hsingle :
        (w g).length ≤
          ∑ a ∈ P.generators, (w a).length :=
      Finset.single_le_sum
        (fun a _ => Nat.zero_le (w a).length) hg
    dsimp [L]
    omega
  have hlengthreal :
      ((w g).length : ℝ) < (L : ℝ) := by
    exact_mod_cast hlength
  have hδ : 0 < P.kazhdanConstant / (L : ℝ) :=
    div_pos P.positive hLreal
  have hword :
      ‖π (((w g).map fun i : ↥S => (i : G)).prod) ξ - ξ‖ ≤
        ((w g).length : ℝ) *
          (P.kazhdanConstant / (L : ℝ)) := by
    have hbound :=
      unitary_word_displacement_le π ξ
        ((w g).map fun i : ↥S => (i : G))
        (P.kazhdanConstant / (L : ℝ))
        (by
          intro a ha
          obtain ⟨i, _hi, rfl⟩ := List.mem_map.mp ha
          exact (hS (i : G) i.property).le)
    simpa only [List.length_map] using hbound
  calc
    ‖π g ξ - ξ‖ =
        ‖π (((w g).map fun i : ↥S => (i : G)).prod) ξ - ξ‖ := by
          rw [show
            (((w g).map fun i : ↥S => (i : G)).prod) = g from
              symmetricGeneratingWord_prod
                S hsymmetric hgenerates g]
    _ ≤ ((w g).length : ℝ) *
          (P.kazhdanConstant / (L : ℝ)) := hword
    _ < (L : ℝ) * (P.kazhdanConstant / (L : ℝ)) :=
      mul_lt_mul_of_pos_right hlengthreal hδ
    _ = P.kazhdanConstant := by
      field_simp [Nat.cast_ne_zero.mpr hL.ne']

theorem kazhdanPairOnSymmetricGeneratingFinset_generators
    {G : Type u} [Group G]
    (P : SoficGroups.KazhdanPair.{u, v} G)
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤) :
    (kazhdanPairOnSymmetricGeneratingFinset
      P S hsymmetric hgenerates).generators = S := by
  rfl

theorem exists_kazhdanPair_with_exact_symmetric_generators
    {G : Type u} [Group G]
    [SoficGroups.HasPropertyT.{u, v} G]
    (S : Finset G)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤) :
    ∃ P : SoficGroups.KazhdanPair.{u, v} G,
      P.generators = S := by
  obtain ⟨P⟩ :=
    SoficGroups.HasPropertyT.exists_kazhdanPair (G := G)
  exact ⟨kazhdanPairOnSymmetricGeneratingFinset
    P S hsymmetric hgenerates,
    kazhdanPairOnSymmetricGeneratingFinset_generators
      P S hsymmetric hgenerates⟩

end KunExactKazhdanGeneratorChange

namespace KunExactActualSourceAmbientGenerators

section

open SoficGroups.KunExactKazhdanGeneratorChange

def sourceAlphaInclusion :
    SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode →*
      SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode where
  toFun g :=
    ⟨g.val,
      SoficGroups.SourceGeneration.alphaPrefixElementaryGroup_le_nine
        g.property⟩
  map_one' := rfl
  map_mul' _ _ := rfl

theorem sourceAlphaInclusion_injective :
    Function.Injective sourceAlphaInclusion := by
  intro x y hxy
  apply Subtype.ext
  exact congrArg
    (fun z :
      SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode =>
        z.val) hxy

def sourceCompressionU :
    SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode :=
  ⟨SoficGroups.compressionU,
    SoficGroups.compressionU_mem_ninePrefixElementaryGroup⟩

def sourceCompressionV :
    SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode :=
  ⟨SoficGroups.compressionV,
    SoficGroups.compressionV_mem_ninePrefixElementaryGroup⟩

noncomputable def sourcePositiveGenerators
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) :
    Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) := by
  classical
  exact SΓ.image sourceAlphaInclusion ∪
    {sourceCompressionU, sourceCompressionV}

noncomputable def sourceAmbientSymmetricGenerators
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) :
    Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) := by
  classical
  exact insert 1
    (sourcePositiveGenerators SΓ ∪
      (sourcePositiveGenerators SΓ).image fun g => g⁻¹)

theorem one_mem_sourceAmbientSymmetricGenerators
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) :
    1 ∈ sourceAmbientSymmetricGenerators SΓ := by
  classical
  simp [sourceAmbientSymmetricGenerators]

theorem sourceAmbientSymmetricGenerators_inv_mem
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (g : SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode)
    (hg : g ∈ sourceAmbientSymmetricGenerators SΓ) :
    g⁻¹ ∈ sourceAmbientSymmetricGenerators SΓ := by
  classical
  have hcases :
      g = 1 ∨
        g ∈ sourcePositiveGenerators SΓ ∨
        ∃ y ∈ sourcePositiveGenerators SΓ, y⁻¹ = g := by
    simpa [sourceAmbientSymmetricGenerators, Finset.mem_image] using hg
  rcases hcases with rfl | hgpos | ⟨y, hy, rfl⟩
  · simp [sourceAmbientSymmetricGenerators]
  · have hinv :
        g⁻¹ ∈ (sourcePositiveGenerators SΓ).image
          (fun x => x⁻¹) :=
      Finset.mem_image.mpr ⟨g, hgpos, rfl⟩
    simp [sourceAmbientSymmetricGenerators, hinv]
  · simp [sourceAmbientSymmetricGenerators, hy]

theorem sourceAmbientSymmetricGenerators_generate
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hgeneratesΓ :
      Subgroup.closure
        (SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode)) = ⊤) :
    Subgroup.closure
      (sourceAmbientSymmetricGenerators SΓ : Set
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode)) = ⊤ := by
  classical
  let K : Subgroup
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) :=
    Subgroup.closure
      (sourceAmbientSymmetricGenerators SΓ : Set
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode))
  have hpositive :
      ∀ x ∈ sourcePositiveGenerators SΓ, x ∈ K := by
    intro x hx
    apply Subgroup.subset_closure
    change x ∈ sourceAmbientSymmetricGenerators SΓ
    simp [sourceAmbientSymmetricGenerators, hx]
  have hcorner :
      ∀ g :
        SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode,
        sourceAlphaInclusion g ∈ K := by
    intro g
    have hsub :
        Subgroup.closure
          (SΓ : Set
            (SoficGroups.prefixElementaryGroup
              SoficGroups.alphaPrefixCode)) ≤
            K.comap sourceAlphaInclusion := by
      rw [Subgroup.closure_le]
      intro x hx
      change sourceAlphaInclusion x ∈ K
      apply hpositive
      change sourceAlphaInclusion x ∈
        SΓ.image sourceAlphaInclusion ∪
          {sourceCompressionU, sourceCompressionV}
      exact Finset.mem_union_left _
        (Finset.mem_image.mpr ⟨x, hx, rfl⟩)
    apply hsub
    rw [hgeneratesΓ]
    simp
  let U : Subgroup SoficGroups.BinaryLeavittˣ :=
    K.map
      (SoficGroups.prefixElementaryGroup
        SoficGroups.ninePrefixCode).subtype
  have hsource :
      SoficGroups.SourceGeneration.sourceGeneratedGroup ≤ U := by
    rw [SoficGroups.SourceGeneration.sourceGeneratedGroup,
      Subgroup.closure_le]
    intro x hx
    rcases hx with hα | htables
    · let a :
          SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode := ⟨x, hα⟩
      exact ⟨sourceAlphaInclusion a, hcorner a, rfl⟩
    · simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at htables
      rcases htables with rfl | rfl
      · exact ⟨sourceCompressionU,
          hpositive sourceCompressionU
            (by simp [sourcePositiveGenerators]), rfl⟩
      · exact ⟨sourceCompressionV,
          hpositive sourceCompressionV
            (by simp [sourcePositiveGenerators]), rfl⟩
  have htop :
      (⊤ : Subgroup
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode)) ≤ K := by
    intro x _hx
    have hxin :
        (x.val : SoficGroups.BinaryLeavittˣ) ∈
          SoficGroups.SourceGeneration.sourceGeneratedGroup := by
      rw [SoficGroups.sourceGeneratedGroup_eq_nine]
      exact x.property
    obtain ⟨y, hy, hval⟩ := hsource hxin
    have heq : y = x := by
      apply Subtype.ext
      exact hval
    simpa [← heq] using hy
  exact top_unique htop

theorem exists_kazhdanPair_on_exact_sourceAmbientSymmetricGenerators
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hgeneratesΓ :
      Subgroup.closure
        (SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode)) = ⊤)
    [SoficGroups.HasPropertyT.{0, 0}
      (SoficGroups.prefixElementaryGroup
        SoficGroups.ninePrefixCode)] :
    ∃ P : SoficGroups.KazhdanPair.{0, 0}
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode),
      P.generators = sourceAmbientSymmetricGenerators SΓ := by
  exact exists_kazhdanPair_with_exact_symmetric_generators
    (sourceAmbientSymmetricGenerators SΓ)
    (sourceAmbientSymmetricGenerators_inv_mem SΓ)
    (sourceAmbientSymmetricGenerators_generate SΓ hgeneratesΓ)

end

section

def sourceCompressionTable :
    Fin 2 →
      SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode :=
  ![sourceCompressionU, sourceCompressionV]

def sourcePositiveGeneratorMap
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) :
    (↥SΓ ⊕ Fin 2) →
      SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode :=
  Sum.elim (fun i : ↥SΓ => sourceAlphaInclusion (i :
    SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    sourceCompressionTable

theorem range_sourcePositiveGeneratorMap
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) :
    Set.range (sourcePositiveGeneratorMap SΓ) =
      (sourcePositiveGenerators SΓ : Set
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode)) := by
  classical
  ext x
  constructor
  · rintro ⟨i, rfl⟩
    rcases i with i | i
    · change
        sourceAlphaInclusion
          (i :
            SoficGroups.prefixElementaryGroup
              SoficGroups.alphaPrefixCode) ∈
            sourcePositiveGenerators SΓ
      change
        sourceAlphaInclusion
          (i :
            SoficGroups.prefixElementaryGroup
              SoficGroups.alphaPrefixCode) ∈
          SΓ.image sourceAlphaInclusion ∪
            {sourceCompressionU, sourceCompressionV}
      apply Finset.mem_union_left
      exact Finset.mem_image.mpr
        ⟨(i :
          SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode), i.property, rfl⟩
    · fin_cases i
      · change sourceCompressionU ∈
          sourcePositiveGenerators SΓ
        change sourceCompressionU ∈
          SΓ.image sourceAlphaInclusion ∪
            {sourceCompressionU, sourceCompressionV}
        exact Finset.mem_union_right _ (by simp)
      · change sourceCompressionV ∈
          sourcePositiveGenerators SΓ
        change sourceCompressionV ∈
          SΓ.image sourceAlphaInclusion ∪
            {sourceCompressionU, sourceCompressionV}
        exact Finset.mem_union_right _ (by simp)
  · intro hx
    change
      x ∈ SΓ.image sourceAlphaInclusion ∪
        {sourceCompressionU, sourceCompressionV} at hx
    rcases Finset.mem_union.mp hx with hcorner | htables
    · obtain ⟨g, hg, heq⟩ := Finset.mem_image.mp hcorner
      refine ⟨Sum.inl ⟨g, hg⟩, ?_⟩
      exact heq
    · simp only [Finset.mem_insert, Finset.mem_singleton] at htables
      rcases htables with rfl | rfl
      · refine ⟨Sum.inr (0 : Fin 2), ?_⟩
        rfl
      · refine ⟨Sum.inr (1 : Fin 2), ?_⟩
        rfl

theorem sourcePositiveGenerators_generate
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hgeneratesΓ :
      Subgroup.closure
        (SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode)) = ⊤) :
    Subgroup.closure
      (sourcePositiveGenerators SΓ : Set
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode)) = ⊤ := by
  classical
  let K : Subgroup
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) :=
    Subgroup.closure
      (sourcePositiveGenerators SΓ : Set
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode))
  have hcontain :
      (sourceAmbientSymmetricGenerators SΓ : Set
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode)) ⊆
        (K : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.ninePrefixCode)) := by
    intro x hx
    have hcases :
        x = 1 ∨
          x ∈ sourcePositiveGenerators SΓ ∨
          x⁻¹ ∈ sourcePositiveGenerators SΓ := by
      simpa [sourceAmbientSymmetricGenerators,
        Finset.mem_image] using hx
    rcases hcases with rfl | hxpositive | hxinverse
    · exact K.one_mem
    · exact Subgroup.subset_closure hxpositive
    · simpa using
        K.inv_mem (Subgroup.subset_closure hxinverse)
  have hle :
      Subgroup.closure
        (sourceAmbientSymmetricGenerators SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.ninePrefixCode)) ≤ K := by
    rw [Subgroup.closure_le]
    exact hcontain
  have htop :
      (⊤ : Subgroup
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode)) ≤ K := by
    rw [← sourceAmbientSymmetricGenerators_generate SΓ hgeneratesΓ]
    exact hle
  exact top_unique htop

theorem sourcePositiveGeneratorMap_range_generate
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hgeneratesΓ :
      Subgroup.closure
        (SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode)) = ⊤) :
    Subgroup.closure
      (Set.range (sourcePositiveGeneratorMap SΓ)) = ⊤ := by
  rw [range_sourcePositiveGeneratorMap]
  exact sourcePositiveGenerators_generate SΓ hgeneratesΓ

end

end KunExactActualSourceAmbientGenerators

namespace KunUnconditionalActualSourceGeneratorData

open SoficGroups.KunExactKazhdanGeneratorChange
open SoficGroups.KunExactActualSourceAmbientGenerators

theorem exists_symmetric_generating_finset_of_finitelyGenerated
    {G : Type*} [Group G]
    (hfg : Group.FG G) :
    ∃ S : Finset G,
      1 ∈ S ∧
        (∀ g ∈ S, g⁻¹ ∈ S) ∧
        Subgroup.closure (S : Set G) = ⊤ := by
  classical
  obtain ⟨_, T, _, hT⟩ := (Group.fg_iff').1 hfg
  let S : Finset G := insert 1 (T ∪ T.image fun g => g⁻¹)
  refine ⟨S, by simp [S], ?_, ?_⟩
  · intro g hg
    have hcases :
        g = 1 ∨ g ∈ T ∨
          ∃ y ∈ T, y⁻¹ = g := by
      simpa [S, Finset.mem_image] using hg
    rcases hcases with rfl | hgT | ⟨y, hy, rfl⟩
    · simp [S]
    · have hmem :
          g⁻¹ ∈ T.image fun z => z⁻¹ :=
        Finset.mem_image.mpr ⟨g, hgT, rfl⟩
      simp [S, hmem]
    · simp [S, hy]
  · have hsubset : (T : Set G) ⊆ (S : Set G) := by
      intro g hg
      change g ∈ T at hg
      change g ∈ S
      simp [S, hg]
    apply top_unique
    rw [← hT]
    exact Subgroup.closure_mono hsubset

theorem exists_actual_source_alpha_symmetric_generators :
    ∃ SΓ : Finset
        (SoficGroups.prefixElementaryGroup
          SoficGroups.alphaPrefixCode),
      1 ∈ SΓ ∧
        (∀ g ∈ SΓ, g⁻¹ ∈ SΓ) ∧
        Subgroup.closure
          (SΓ : Set
            (SoficGroups.prefixElementaryGroup
              SoficGroups.alphaPrefixCode)) = ⊤ :=
  exists_symmetric_generating_finset_of_finitelyGenerated
    SoficGroups.alphaPrefixElementaryGroup_finitelyGenerated

theorem exists_unconditional_actual_source_generator_data :
    ∃ (SΓ : Finset
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode))
      (PΓ : SoficGroups.KazhdanPair.{0, 0}
        (SoficGroups.prefixElementaryGroup
          SoficGroups.alphaPrefixCode))
      (PG : SoficGroups.KazhdanPair.{0, 0}
        (SoficGroups.prefixElementaryGroup
          SoficGroups.ninePrefixCode)),
      1 ∈ SΓ ∧
      (∀ g ∈ SΓ, g⁻¹ ∈ SΓ) ∧
      Subgroup.closure
        (SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode)) = ⊤ ∧
      PΓ.generators = SΓ ∧
      1 ∈ sourceAmbientSymmetricGenerators SΓ ∧
      (∀ g ∈ sourceAmbientSymmetricGenerators SΓ,
        g⁻¹ ∈ sourceAmbientSymmetricGenerators SΓ) ∧
      Subgroup.closure
        (sourceAmbientSymmetricGenerators SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.ninePrefixCode)) = ⊤ ∧
      PG.generators = sourceAmbientSymmetricGenerators SΓ ∧
      Function.Injective sourceAlphaInclusion ∧
      Subgroup.closure
        (Set.range (sourcePositiveGeneratorMap SΓ)) = ⊤ := by
  letI : SoficGroups.HasPropertyT.{0, 0}
      (SoficGroups.prefixElementaryGroup
        SoficGroups.alphaPrefixCode) :=
    SoficGroups.alphaPrefixElementaryGroup_hasPropertyT_unconditional
  letI : SoficGroups.HasPropertyT.{0, 0}
      (SoficGroups.prefixElementaryGroup
        SoficGroups.ninePrefixCode) :=
    SoficGroups.ninePrefixElementaryGroup_hasPropertyT_unconditional
  obtain ⟨SΓ, honeΓ, hsymmetricΓ, hgeneratesΓ⟩ :=
    exists_actual_source_alpha_symmetric_generators
  obtain ⟨PΓ, hPΓ⟩ :=
    exists_kazhdanPair_with_exact_symmetric_generators
      SΓ hsymmetricΓ hgeneratesΓ
  obtain ⟨PG, hPG⟩ :=
    exists_kazhdanPair_on_exact_sourceAmbientSymmetricGenerators
      SΓ hgeneratesΓ
  refine ⟨SΓ, PΓ, PG, honeΓ, hsymmetricΓ, hgeneratesΓ,
    hPΓ, one_mem_sourceAmbientSymmetricGenerators SΓ,
    sourceAmbientSymmetricGenerators_inv_mem SΓ,
    sourceAmbientSymmetricGenerators_generate SΓ hgeneratesΓ,
    hPG, sourceAlphaInclusion_injective, ?_⟩
  exact sourcePositiveGeneratorMap_range_generate SΓ hgeneratesΓ

end KunUnconditionalActualSourceGeneratorData

namespace SourceCommonComponentComparisonBad

open Filter Topology
open scoped BigOperators

noncomputable def comparisonBad
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (p : Equiv.Perm V) (eta : ℝ) : Finset V := by
  classical
  exact Finset.univ.filter fun x =>
    ¬ (1 - eta) * (SoficGroups.partitionComponentSize Q x : ℝ) ≤
      (SoficGroups.partitionComponentSize Q (p x) : ℝ)

noncomputable def familyComparisonBad
    {V ι : Type*} [Fintype V] [DecidableEq V] [Fintype ι]
    (Q : Finpartition (Finset.univ : Finset V))
    (p : ι → Equiv.Perm V) (eta : ℝ) : Finset (ι × V) := by
  classical
  exact Finset.univ.filter fun e =>
    ¬ (1 - eta) * (SoficGroups.partitionComponentSize Q e.2 : ℝ) ≤
      (SoficGroups.partitionComponentSize Q (p e.1 e.2) : ℝ)

theorem familyComparisonBad_card
    {V ι : Type*} [Fintype V] [DecidableEq V] [Fintype ι]
    (Q : Finpartition (Finset.univ : Finset V))
    (p : ι → Equiv.Perm V) (eta : ℝ) :
    (familyComparisonBad Q p eta).card =
      ∑ i : ι, (comparisonBad Q (p i) eta).card := by
  classical
  unfold familyComparisonBad
  rw [Finset.card_filter, ← Finset.univ_product_univ,
    Finset.sum_product]
  apply Finset.sum_congr rfl
  intro i _
  unfold comparisonBad
  rw [Finset.card_filter]

theorem comparisonBad_subset_partitionWordCrossing
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (p : Equiv.Perm V) (eta : ℝ) (heta : 0 ≤ eta) :
    comparisonBad Q p eta ⊆ SoficGroups.partitionWordCrossing Q p := by
  classical
  intro x hx
  unfold comparisonBad at hx
  have hbad := (Finset.mem_filter.mp hx).2
  apply Finset.mem_filter.mpr
  refine ⟨Finset.mem_univ x, ?_⟩
  intro hsame
  apply hbad
  have hpart : Q.part (p x) = Q.part x :=
    Q.part_eq_of_mem (Q.part_mem.mpr (Finset.mem_univ x)) hsame
  have hsize : SoficGroups.partitionComponentSize Q (p x) =
      SoficGroups.partitionComponentSize Q x := by
    unfold SoficGroups.partitionComponentSize
    rw [hpart]
  rw [hsize]
  have hnonneg : (0 : ℝ) ≤
      (SoficGroups.partitionComponentSize Q x : ℝ) := by
    positivity
  nlinarith

noncomputable def overlapRetainedComponents
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (eta : ℝ) : Finset (Finset V) :=
  (SoficGroups.transportedUnivFinpartition Q T).parts \
    SoficGroups.insufficientOverlapComponents
      (SoficGroups.transportedUnivFinpartition Q T) Q eta

theorem comparisonBad_subset_matchedWordPreimageBad
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (eta : ℝ) :
    comparisonBad Q T eta ⊆
      SoficGroups.matchedWordPreimageBad
        (Finset.univ : Finset V)
        (overlapRetainedComponents Q T eta)
        (SoficGroups.maximumOverlapPart Q) T := by
  classical
  intro x hx
  have hbad : ¬ (1 - eta) *
        (SoficGroups.partitionComponentSize Q x : ℝ) ≤
      (SoficGroups.partitionComponentSize Q (T x) : ℝ) := by
    unfold comparisonBad at hx
    exact (Finset.mem_filter.mp hx).2
  apply Finset.mem_filter.mpr
  refine ⟨Finset.mem_univ x, Finset.mem_sdiff.mpr
    ⟨Finset.mem_univ (T x), ?_⟩⟩
  intro hcore
  obtain ⟨C, hC, hy⟩ := Finset.mem_biUnion.mp hcore
  have hparts : C ∈
      (SoficGroups.transportedUnivFinpartition Q T).parts :=
    (Finset.mem_sdiff.mp hC).1
  have hret : C ∉ SoficGroups.insufficientOverlapComponents
      (SoficGroups.transportedUnivFinpartition Q T) Q eta :=
    (Finset.mem_sdiff.mp hC).2
  have hyC : T x ∈ C := (Finset.mem_inter.mp hy).1
  have hyD : T x ∈ SoficGroups.maximumOverlapPart Q C :=
    (Finset.mem_inter.mp hy).2
  have hxpart : Q.part x ∈ Q.parts :=
    Q.part_mem.mpr (Finset.mem_univ x)
  have hmap : (Q.part x).map T.toEmbedding ∈
      (SoficGroups.transportedUnivFinpartition Q T).parts := by
    rw [SoficGroups.transportedUnivFinpartition_parts]
    exact Finset.mem_image_of_mem
      (fun D : Finset V => D.map T.toEmbedding) hxpart
  have hyMap : T x ∈ (Q.part x).map T.toEmbedding :=
    Finset.mem_map.mpr
      ⟨x, Q.mem_part (Finset.mem_univ x), rfl⟩
  have heq : (Q.part x).map T.toEmbedding = C := by
    have hfirst :=
      (SoficGroups.transportedUnivFinpartition Q T).part_eq_of_mem
        hmap hyMap
    have hsecond :=
      (SoficGroups.transportedUnivFinpartition Q T).part_eq_of_mem
        hparts hyC
    exact hfirst.symm.trans hsecond
  apply hbad
  apply SoficGroups.partitionComponentSize_transport_lower_of_retained
    Q T (Q.part x) hxpart eta
  · simpa only [heq] using hret
  · exact Q.mem_part (Finset.mem_univ x)
  · simpa only [heq] using hyD

theorem matchedCore_missing_card_le_overlap_and_loss
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (eta : ℝ) :
    ((Finset.univ : Finset V) \
      SoficGroups.matchedCore
        (overlapRetainedComponents Q T eta)
        (SoficGroups.maximumOverlapPart Q)).card ≤
      (∑ C ∈ SoficGroups.insufficientOverlapComponents
        (SoficGroups.transportedUnivFinpartition Q T) Q eta,
          C.card) +
      ∑ C ∈ (SoficGroups.transportedUnivFinpartition Q T).parts,
        (C \
          SoficGroups.maximumOverlapPart Q C).card := by
  classical
  let P := SoficGroups.transportedUnivFinpartition Q T
  let O := SoficGroups.insufficientOverlapComponents P Q eta
  let R := P.parts \
    SoficGroups.insufficientOverlapComponents P Q eta
  have hR : R ⊆ P.parts := Finset.sdiff_subset
  have hO : O ⊆ P.parts :=
    SoficGroups.insufficientOverlapComponents_subset P Q eta
  have hparts : P.parts \ R = O := by
    ext C
    constructor
    · intro h
      obtain ⟨hCP, hnot⟩ := Finset.mem_sdiff.mp h
      by_contra hCO
      exact hnot (Finset.mem_sdiff.mpr ⟨hCP, hCO⟩)
    · intro h
      exact Finset.mem_sdiff.mpr
        ⟨hO h, fun hR' => (Finset.mem_sdiff.mp hR').2 h⟩
  have hmissing :
      ((Finset.univ : Finset V) \
        SoficGroups.matchedRetainedSupport R).card =
        ∑ C ∈ O, C.card := by
    have hsplit := Finset.sum_sdiff hR (f := fun C : Finset V => C.card)
    rw [hparts] at hsplit
    have hfull := P.sum_card_parts
    have hret := SoficGroups.matchedRetainedSupport_card P R hR
    have hcard := Finset.card_sdiff_add_card_eq_card
      (SoficGroups.matchedRetainedSupport_subset P R hR)
    omega
  change
    ((Finset.univ : Finset V) \
      SoficGroups.matchedCore R
        (SoficGroups.maximumOverlapPart Q)).card ≤
      (∑ C ∈ O, C.card) +
        ∑ C ∈ P.parts,
          (C \ SoficGroups.maximumOverlapPart Q C).card
  rw [SoficGroups.matchedCore_missing_card P R hR
    (SoficGroups.maximumOverlapPart Q), hmissing]
  apply Nat.add_le_add_left
  exact Finset.sum_le_sum_of_subset_of_nonneg hR
    (fun _ _ _ => Nat.zero_le _)

theorem comparisonBad_card_le_overlap_and_loss
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (eta : ℝ) :
    (comparisonBad Q T eta).card ≤
      (∑ C ∈ SoficGroups.insufficientOverlapComponents
        (SoficGroups.transportedUnivFinpartition Q T) Q eta,
          C.card) +
      ∑ C ∈ (SoficGroups.transportedUnivFinpartition Q T).parts,
        (C \
          SoficGroups.maximumOverlapPart Q C).card := by
  calc
    (comparisonBad Q T eta).card ≤
        (SoficGroups.matchedWordPreimageBad
          (Finset.univ : Finset V)
          (overlapRetainedComponents Q T eta)
          (SoficGroups.maximumOverlapPart Q) T).card :=
      Finset.card_le_card
        (comparisonBad_subset_matchedWordPreimageBad Q T eta)
    _ ≤ ((Finset.univ : Finset V) \
          SoficGroups.matchedCore
            (overlapRetainedComponents Q T eta)
            (SoficGroups.maximumOverlapPart Q)).card :=
      SoficGroups.matchedWordPreimageBad_card_le
        (Finset.univ : Finset V)
        (overlapRetainedComponents Q T eta)
        (SoficGroups.maximumOverlapPart Q) T
    _ ≤ _ := matchedCore_missing_card_le_overlap_and_loss Q T eta

theorem cast_card_sdiff_eq_sub_card_inter
    {V : Type*} [DecidableEq V] (C D : Finset V) :
    ((C \ D).card : ℝ) =
      (C.card : ℝ) - ((C ∩ D).card : ℝ) := by
  have hnat := Finset.card_sdiff_add_card_inter C D
  have hreal : ((C \ D).card : ℝ) +
      ((C ∩ D).card : ℝ) = (C.card : ℝ) := by
    exact_mod_cast hnat
  linarith

theorem subgroup_comparisonBad_density_tendsto_zero
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (Q : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (p : (n : ℕ) → Equiv.Perm (V n))
    (eta : ℕ → ℝ) (heta : ∀ n, 0 ≤ eta n)
    (hcross : Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n) (p n)).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((comparisonBad (Q n) (p n) (eta n)).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0) := by
  refine squeeze_zero (fun n => by positivity) ?_ hcross
  intro n
  have hnat := Finset.card_le_card
    (comparisonBad_subset_partitionWordCrossing
      (Q n) (p n) (eta n) (heta n))
  have hreal :
      ((comparisonBad (Q n) (p n) (eta n)).card : ℝ) ≤
        ((SoficGroups.partitionWordCrossing
          (Q n) (p n)).card : ℝ) := by
    exact_mod_cast hnat
  exact div_le_div_of_nonneg_right hreal (by positivity)

theorem transported_comparisonBad_density_tendsto_zero
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (Q : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (T : (n : ℕ) → Equiv.Perm (V n))
    (eta : ℕ → ℝ)
    (hoverlap : Tendsto
      (fun n =>
        (∑ C ∈ SoficGroups.insufficientOverlapComponents
          (SoficGroups.transportedUnivFinpartition (Q n) (T n))
          (Q n) (eta n), (C.card : ℝ)) /
            Fintype.card (V n))
      atTop (nhds 0))
    (hloss : Tendsto
      (fun n =>
        (∑ C ∈
          (SoficGroups.transportedUnivFinpartition (Q n) (T n)).parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
              Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((comparisonBad (Q n) (T n) (eta n)).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0) := by
  have hlimit : Tendsto
      (fun n =>
        (∑ C ∈ SoficGroups.insufficientOverlapComponents
          (SoficGroups.transportedUnivFinpartition (Q n) (T n))
          (Q n) (eta n), (C.card : ℝ)) /
            Fintype.card (V n) +
        (∑ C ∈
          (SoficGroups.transportedUnivFinpartition (Q n) (T n)).parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
              Fintype.card (V n))
      atTop (nhds 0) := by
    simpa only [zero_add] using hoverlap.add hloss
  refine squeeze_zero (fun n => by positivity) ?_ hlimit
  intro n
  have hnat := comparisonBad_card_le_overlap_and_loss
    (Q n) (T n) (eta n)
  have hreal :
      ((comparisonBad (Q n) (T n) (eta n)).card : ℝ) ≤
        (∑ C ∈ SoficGroups.insufficientOverlapComponents
          (SoficGroups.transportedUnivFinpartition (Q n) (T n))
          (Q n) (eta n), (C.card : ℝ)) +
        ∑ C ∈
          (SoficGroups.transportedUnivFinpartition (Q n) (T n)).parts,
          ((C \ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ) := by
    exact_mod_cast hnat
  simp_rw [cast_card_sdiff_eq_sub_card_inter] at hreal
  calc
    ((comparisonBad (Q n) (T n) (eta n)).card : ℝ) /
        Fintype.card (V n) ≤
      ((∑ C ∈ SoficGroups.insufficientOverlapComponents
        (SoficGroups.transportedUnivFinpartition (Q n) (T n))
        (Q n) (eta n), (C.card : ℝ)) +
        ∑ C ∈
          (SoficGroups.transportedUnivFinpartition (Q n) (T n)).parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
              Fintype.card (V n) :=
      div_le_div_of_nonneg_right hreal (by positivity)
    _ = _ := by ring

theorem combined_positive_comparisonBad_density_tendsto_zero
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (ι κ : Type*) [Fintype ι] [Fintype κ]
    (Q : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (T : (n : ℕ) → κ → Equiv.Perm (V n))
    (eta : ℕ → ℝ) (heta : ∀ n, 0 ≤ eta n)
    (hcross : ∀ i : ι, Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing
          (Q n) (σ n i)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0))
    (hoverlap : ∀ j : κ, Tendsto
      (fun n =>
        (∑ C ∈ SoficGroups.insufficientOverlapComponents
          (SoficGroups.transportedUnivFinpartition
            (Q n) (T n j)) (Q n) (eta n), (C.card : ℝ)) /
              Fintype.card (V n))
      atTop (nhds 0))
    (hloss : ∀ j : κ, Tendsto
      (fun n =>
        (∑ C ∈
          (SoficGroups.transportedUnivFinpartition
            (Q n) (T n j)).parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
              Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((familyComparisonBad (Q n)
          (Sum.elim (σ n) (T n)) (eta n)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0) := by
  classical
  have hsingle (i : ι ⊕ κ) : Tendsto
      (fun n =>
        ((comparisonBad (Q n)
          (Sum.elim (σ n) (T n) i) (eta n)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0) := by
    cases i with
    | inl i =>
        exact subgroup_comparisonBad_density_tendsto_zero
          V Q (fun n => σ n i) eta heta (hcross i)
    | inr j =>
        exact transported_comparisonBad_density_tendsto_zero
          V Q (fun n => T n j) eta (hoverlap j) (hloss j)
  have hsum : Tendsto
      (fun n => ∑ i : ι ⊕ κ,
        ((comparisonBad (Q n)
          (Sum.elim (σ n) (T n) i) (eta n)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0) := by
    simpa using
      tendsto_finsetSum Finset.univ (fun i _ => hsingle i)
  have hrewrite (n : ℕ) :
      ((familyComparisonBad (Q n)
        (Sum.elim (σ n) (T n)) (eta n)).card : ℝ) /
          Fintype.card (V n) =
        ∑ i : ι ⊕ κ,
          ((comparisonBad (Q n)
            (Sum.elim (σ n) (T n) i) (eta n)).card : ℝ) /
              Fintype.card (V n) := by
    rw [familyComparisonBad_card]
    push_cast
    rw [Finset.sum_div]
  simpa only [hrewrite] using hsum

end SourceCommonComponentComparisonBad

namespace SourceCommonOffsetMidrankEnergy

open Filter Topology
open scoped BigOperators

noncomputable def realComponentSize
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V)) (x : V) : ℝ :=
  (SoficGroups.partitionComponentSize Q x : ℝ)

noncomputable def componentLogRank
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (H r : ℝ) : V → ℤ :=
  SoficGroups.MidrankPermutationEnergy.offsetFloorRank
    (fun x => Real.log (realComponentSize Q x)) H r

noncomputable def componentSizeComparisonBad
    {V ι : Type*} [Fintype V] [DecidableEq V] [Fintype ι]
    (Q : Finpartition (Finset.univ : Finset V))
    (p : ι → Equiv.Perm V) (eta : ℝ) : Finset (ι × V) := by
  classical
  exact Finset.univ.filter fun e =>
    ¬ (1 - eta) * realComponentSize Q e.2 ≤
      realComponentSize Q (p e.1 e.2)

theorem componentSizeComparison_of_not_mem
    {V ι : Type*} [Fintype V] [DecidableEq V] [Fintype ι]
    (Q : Finpartition (Finset.univ : Finset V))
    (p : ι → Equiv.Perm V) (eta : ℝ)
    (i : ι) (x : V)
    (hx : (i, x) ∉ componentSizeComparisonBad Q p eta) :
    (1 - eta) * realComponentSize Q x ≤
      realComponentSize Q (p i x) := by
  classical
  by_contra h
  apply hx
  unfold componentSizeComparisonBad
  exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, h⟩

theorem exists_common_component_log_rank_with_vanishing_drops
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    (ι : Type*) [Fintype ι]
    (Q : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (p : (n : ℕ) → ι → Equiv.Perm (V n))
    (eta H : ℕ → ℝ)
    (heta0 : ∀ n, 0 ≤ eta n)
    (heta1 : ∀ n, eta n < 1)
    (hH : ∀ n, 0 < H n)
    (heta : Tendsto eta atTop (nhds 0))
    (hratio : Tendsto (fun n => eta n / H n) atTop (nhds 0))
    (hbad : Tendsto
      (fun n =>
        ((componentSizeComparisonBad (Q n) (p n) (eta n)).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0)) :
    ∃ r : ℕ → ℝ,
      (∀ n, r n ∈ Set.Ico 0 (H n)) ∧
      Tendsto
        (fun n =>
          (∑ i : ι,
            ((SoficGroups.MidrankPermutationEnergy.rankDecreasingVertices
              Finset.univ
              (componentLogRank (Q n) (H n) (r n))
              (p n i)).card : ℝ)) /
            Fintype.card (V n))
        atTop (nhds 0) := by
  classical
  let B : (n : ℕ) → Finset (ι × V n) :=
    fun n => componentSizeComparisonBad (Q n) (p n) (eta n)
  let E : (n : ℕ) → Finset (ι × V n) :=
    fun n => Finset.univ \ B n
  have hN (n : ℕ) : (0 : ℝ) < Fintype.card (V n) := by
    exact_mod_cast Fintype.card_pos_iff.mpr inferInstance
  have hpositive (n : ℕ) (e : ι × V n) (_he : e ∈ E n) :
      0 < realComponentSize (Q n) e.2 := by
    have hpart : (Q n).part e.2 ∈ (Q n).parts :=
      (Q n).part_mem.mpr (Finset.mem_univ e.2)
    have hnonempty := (Q n).nonempty_of_mem_parts hpart
    unfold realComponentSize SoficGroups.partitionComponentSize
    exact_mod_cast Finset.card_pos.mpr hnonempty
  have hcard (n : ℕ) :
      ((E n).card : ℝ) ≤
        (Fintype.card ι : ℝ) * (Fintype.card (V n) : ℝ) := by
    have hnat : (E n).card ≤ Fintype.card ι * Fintype.card (V n) := by
      simpa only [Fintype.card_prod] using
        (Finset.card_le_univ (E n))
    exact_mod_cast hnat
  have hcomparison (n : ℕ) (e : ι × V n) (he : e ∈ E n) :
      (1 - eta n) * realComponentSize (Q n) e.2 ≤
        realComponentSize (Q n) (p n e.1 e.2) := by
    apply componentSizeComparison_of_not_mem (Q n) (p n) (eta n)
      e.1 e.2
    exact (Finset.mem_sdiff.mp he).2
  have hexceptions : Tendsto
      (fun n =>
        (((Finset.univ : Finset (ι × V n)) \ E n).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0) := by
    simpa [E, B] using hbad
  obtain ⟨r, hr, hdrop⟩ :=
    SoficGroups.ExceptionalRankOffset.exists_common_log_rank_offsets_tendsto_zero_except
        (fun n => ι × V n) E
        (fun n e => realComponentSize (Q n) e.2)
        (fun n e => realComponentSize (Q n) (p n e.1 e.2))
        eta H (fun n => (Fintype.card (V n) : ℝ))
        (Fintype.card ι : ℝ)
        hpositive heta0 heta1 hH hN hcard hcomparison
        heta hratio hexceptions
  have hrewrite (n : ℕ) :
      SoficGroups.rankDropCount
        (fun e : ι × V n => Real.log (realComponentSize (Q n) e.2))
        (fun e : ι × V n =>
          Real.log (realComponentSize (Q n) (p n e.1 e.2)))
        (H n) (r n) =
        ∑ i : ι,
          ((SoficGroups.MidrankPermutationEnergy.rankDecreasingVertices
            Finset.univ (componentLogRank (Q n) (H n) (r n))
            (p n i)).card : ℝ) := by
    simpa only [componentLogRank] using
      (SoficGroups.MidrankPermutationEnergy.rankDropCount_eq_sum_rankDecreasingVertices
        (fun x : V n => Real.log (realComponentSize (Q n) x))
        (p n) (H n) (r n))
  refine ⟨r, hr, ?_⟩
  simpa only [hrewrite] using hdrop

theorem exists_common_component_log_rank_with_vanishing_midrank_energy
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    (ι : Type*) [Fintype ι]
    (Q A : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (p : (n : ℕ) → ι → Equiv.Perm (V n))
    (eta H : ℕ → ℝ)
    (heta0 : ∀ n, 0 ≤ eta n)
    (heta1 : ∀ n, eta n < 1)
    (hH : ∀ n, 0 < H n)
    (heta : Tendsto eta atTop (nhds 0))
    (hratio : Tendsto (fun n => eta n / H n) atTop (nhds 0))
    (hbad : Tendsto
      (fun n =>
        ((componentSizeComparisonBad (Q n) (p n) (eta n)).card : ℝ) /
          Fintype.card (V n))
      atTop (nhds 0))
    (hcross : Tendsto
      (fun n =>
        (∑ i : ι,
          ((SoficGroups.partitionWordCrossing (A n) (p n i)).card : ℝ)) /
            Fintype.card (V n))
      atTop (nhds 0)) :
    ∃ r : ℕ → ℝ,
      (∀ n, r n ∈ Set.Ico 0 (H n)) ∧
      Tendsto
        (fun n =>
          (∑ i : ι,
            ((SoficGroups.MidrankPermutationEnergy.rankDecreasingVertices
              Finset.univ
              (componentLogRank (Q n) (H n) (r n))
              (p n i)).card : ℝ)) /
            Fintype.card (V n))
        atTop (nhds 0) ∧
      Tendsto
        (fun n =>
          (∑ i : ι, ∑ x : V n,
            (SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
              (A n) (componentLogRank (Q n) (H n) (r n)) (p n i x) -
             SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
              (A n) (componentLogRank (Q n) (H n) (r n)) x) ^ 2) /
            Fintype.card (V n))
        atTop (nhds 0) := by
  obtain ⟨r, hr, hdrop⟩ :=
    exists_common_component_log_rank_with_vanishing_drops
      V ι Q p eta H heta0 heta1 hH heta hratio hbad
  refine ⟨r, hr, hdrop, ?_⟩
  apply SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank_permutation_energy_tendsto_zero
      V (fun _ => ι) A
      (fun n => componentLogRank (Q n) (H n) (r n)) p
      (fun n => (Fintype.card (V n) : ℝ))
  · intro n
    exact_mod_cast Fintype.card_pos_iff.mpr inferInstance
  · exact hcross
  · exact hdrop

end SourceCommonOffsetMidrankEnergy

namespace SourceCommonComponentRankNoBad

open Filter Topology
open scoped BigOperators

theorem exists_common_positive_component_log_rank_with_vanishing_midrank_energy
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    (ι κ : Type*) [Fintype ι] [Fintype κ]
    (Q A : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (T : (n : ℕ) → κ → Equiv.Perm (V n))
    (eta H : ℕ → ℝ)
    (heta0 : ∀ n, 0 ≤ eta n)
    (heta1 : ∀ n, eta n < 1)
    (hH : ∀ n, 0 < H n)
    (heta : Tendsto eta atTop (nhds 0))
    (hratio : Tendsto (fun n => eta n / H n) atTop (nhds 0))
    (hcrossQ : ∀ i : ι, Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing
          (Q n) (σ n i)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0))
    (hoverlap : ∀ j : κ, Tendsto
      (fun n =>
        (∑ C ∈ SoficGroups.insufficientOverlapComponents
          (SoficGroups.transportedUnivFinpartition
            (Q n) (T n j)) (Q n) (eta n), (C.card : ℝ)) /
              Fintype.card (V n))
      atTop (nhds 0))
    (hloss : ∀ j : κ, Tendsto
      (fun n =>
        (∑ C ∈
          (SoficGroups.transportedUnivFinpartition
            (Q n) (T n j)).parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
              Fintype.card (V n))
      atTop (nhds 0))
    (hcrossA : Tendsto
      (fun n =>
        (∑ i : ι ⊕ κ,
          ((SoficGroups.partitionWordCrossing
            (A n) (Sum.elim (σ n) (T n) i)).card : ℝ)) /
              Fintype.card (V n))
      atTop (nhds 0)) :
    ∃ r : ℕ → ℝ,
      (∀ n, r n ∈ Set.Ico 0 (H n)) ∧
      Tendsto
        (fun n =>
          (∑ i : ι ⊕ κ,
            ((SoficGroups.MidrankPermutationEnergy.rankDecreasingVertices
              Finset.univ
              (SoficGroups.SourceCommonOffsetMidrankEnergy.componentLogRank
                (Q n) (H n) (r n))
              (Sum.elim (σ n) (T n) i)).card : ℝ)) /
            Fintype.card (V n))
        atTop (nhds 0) ∧
      Tendsto
        (fun n =>
          (∑ i : ι ⊕ κ, ∑ x : V n,
            (SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
              (A n)
              (SoficGroups.SourceCommonOffsetMidrankEnergy.componentLogRank
                (Q n) (H n) (r n))
              (Sum.elim (σ n) (T n) i x) -
             SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
              (A n)
              (SoficGroups.SourceCommonOffsetMidrankEnergy.componentLogRank
                (Q n) (H n) (r n)) x) ^ 2) /
            Fintype.card (V n))
        atTop (nhds 0) := by
  have hsource :=
    SoficGroups.SourceCommonComponentComparisonBad.combined_positive_comparisonBad_density_tendsto_zero
        V ι κ Q σ T eta heta0 hcrossQ hoverlap hloss
  have hsets (n : ℕ) :
      SoficGroups.SourceCommonOffsetMidrankEnergy.componentSizeComparisonBad
        (Q n) (Sum.elim (σ n) (T n)) (eta n) =
      SoficGroups.SourceCommonComponentComparisonBad.familyComparisonBad
        (Q n) (Sum.elim (σ n) (T n)) (eta n) := by
    classical
    ext e
    constructor
    · intro he
      unfold
        SoficGroups.SourceCommonOffsetMidrankEnergy.componentSizeComparisonBad
        at he
      have hfail := (Finset.mem_filter.mp he).2
      unfold SoficGroups.SourceCommonComponentComparisonBad.familyComparisonBad
      apply Finset.mem_filter.mpr
      refine ⟨Finset.mem_univ _, ?_⟩
      simpa only
        [SoficGroups.SourceCommonOffsetMidrankEnergy.realComponentSize]
        using hfail
    · intro he
      unfold
        SoficGroups.SourceCommonComponentComparisonBad.familyComparisonBad
        at he
      have hfail := (Finset.mem_filter.mp he).2
      unfold
        SoficGroups.SourceCommonOffsetMidrankEnergy.componentSizeComparisonBad
      apply Finset.mem_filter.mpr
      refine ⟨Finset.mem_univ _, ?_⟩
      simpa only
        [SoficGroups.SourceCommonOffsetMidrankEnergy.realComponentSize]
        using hfail
  have hbad : Tendsto
      (fun n =>
        ((SoficGroups.SourceCommonOffsetMidrankEnergy.componentSizeComparisonBad
          (Q n) (Sum.elim (σ n) (T n)) (eta n)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0) := by
    simpa only [hsets] using hsource
  exact
    SoficGroups.SourceCommonOffsetMidrankEnergy.exists_common_component_log_rank_with_vanishing_midrank_energy
        V (ι ⊕ κ) Q A (fun n => Sum.elim (σ n) (T n))
        eta H heta0 heta1 hH heta hratio hbad hcrossA

end SourceCommonComponentRankNoBad

namespace KunPositiveWordMidrankEnergy

open Filter Topology
open scoped BigOperators

noncomputable def squaredPermutationEnergy
    {V : Type*} [Fintype V] (f : V → ℝ) (p : Equiv.Perm V) : ℝ :=
  ∑ x : V, (f (p x) - f x) ^ 2

theorem squaredPermutationEnergy_nonneg
    {V : Type*} [Fintype V] (f : V → ℝ) (p : Equiv.Perm V) :
    0 ≤ squaredPermutationEnergy f p := by
  exact Finset.sum_nonneg fun _ _ => sq_nonneg _

theorem squaredPermutationEnergy_inv
    {V : Type*} [Fintype V] (f : V → ℝ) (p : Equiv.Perm V) :
    squaredPermutationEnergy f p⁻¹ = squaredPermutationEnergy f p := by
  unfold squaredPermutationEnergy
  calc
    (∑ x : V, (f (p⁻¹ x) - f x) ^ 2) =
        ∑ x : V, (f x - f (p x)) ^ 2 := by
          simpa using
            (Equiv.sum_comp p
              (fun x : V => (f (p⁻¹ x) - f x) ^ 2)).symm
    _ = ∑ x : V, (f (p x) - f x) ^ 2 := by
      apply Finset.sum_congr rfl
      intro x _
      ring

theorem squaredPermutationEnergy_mul_le
    {V : Type*} [Fintype V]
    (f : V → ℝ) (p q : Equiv.Perm V) :
    squaredPermutationEnergy f (p * q) ≤
      2 * squaredPermutationEnergy f p +
        2 * squaredPermutationEnergy f q := by
  unfold squaredPermutationEnergy
  calc
    (∑ x : V, (f ((p * q) x) - f x) ^ 2) ≤
        ∑ x : V,
          (2 * (f (p (q x)) - f (q x)) ^ 2 +
           2 * (f (q x) - f x) ^ 2) := by
      apply Finset.sum_le_sum
      intro x _
      simp only [Equiv.Perm.mul_apply]
      nlinarith [sq_nonneg
        ((f (p (q x)) - f (q x)) - (f (q x) - f x))]
    _ = 2 * (∑ x : V, (f (p x) - f x) ^ 2) +
          2 * (∑ x : V, (f (q x) - f x) ^ 2) := by
      rw [Finset.sum_add_distrib, ← Finset.mul_sum, ← Finset.mul_sum,
        Equiv.sum_comp q (fun x : V => (f (p x) - f x) ^ 2)]

theorem squaredPermutationEnergy_le_add_hammingDist
    {V : Type*} [Fintype V] [DecidableEq V]
    (f : V → ℝ) (hf0 : ∀ x, 0 ≤ f x) (hf1 : ∀ x, f x ≤ 1)
    (p q : Equiv.Perm V) :
    squaredPermutationEnergy f p ≤
      squaredPermutationEnergy f q +
        (hammingDist (fun x => p x) (fun x => q x) : ℝ) := by
  classical
  have hpoint (x : V) :
      (f (p x) - f x) ^ 2 ≤
        (f (q x) - f x) ^ 2 +
          if p x = q x then 0 else 1 := by
    split_ifs with hx
    · simp only [hx, add_zero, le_refl]
    · have hp0 := hf0 (p x)
      have hp1 := hf1 (p x)
      have hx0 := hf0 x
      have hx1 := hf1 x
      nlinarith [sq_nonneg (f (q x) - f x),
        mul_nonneg
          (show 0 ≤ 1 - (f (p x) - f x) by linarith)
          (show 0 ≤ 1 + (f (p x) - f x) by linarith)]
  have hindicator :
      (∑ x : V, if p x = q x then (0 : ℝ) else 1) =
        (hammingDist (fun x => p x) (fun x => q x) : ℝ) := by
    have hswitch (x : V) :
        (if p x = q x then (0 : ℝ) else 1) =
          if p x ≠ q x then 1 else 0 := by
      split_ifs <;> simp_all
    simp_rw [hswitch]
    simpa [hammingDist] using
      (Finset.sum_boole
        (fun x : V => p x ≠ q x) (Finset.univ : Finset V))
  unfold squaredPermutationEnergy
  calc
    (∑ x : V, (f (p x) - f x) ^ 2) ≤
        ∑ x : V,
          ((f (q x) - f x) ^ 2 +
            if p x = q x then 0 else 1) :=
      Finset.sum_le_sum fun x _ => hpoint x
    _ = (∑ x : V, (f (q x) - f x) ^ 2) +
          (hammingDist (fun x => p x) (fun x => q x) : ℝ) := by
      rw [Finset.sum_add_distrib, hindicator]

theorem squaredPermutationEnergy_tendsto_of_normalizedHamming
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (f : (n : ℕ) → V n → ℝ)
    (hf0 : ∀ n x, 0 ≤ f n x)
    (hf1 : ∀ n x, f n x ≤ 1)
    (p q : (n : ℕ) → Equiv.Perm (V n))
    (hq : Tendsto
      (fun n => squaredPermutationEnergy (f n) (q n) /
        Fintype.card (V n)) atTop (𝓝 0))
    (hd : Tendsto
      (fun n => SoficGroups.normalizedHamming (p n) (q n))
      atTop (𝓝 0)) :
    Tendsto
      (fun n => squaredPermutationEnergy (f n) (p n) /
        Fintype.card (V n)) atTop (𝓝 0) := by
  have hupper : Tendsto
      (fun n => squaredPermutationEnergy (f n) (q n) /
        Fintype.card (V n) +
          SoficGroups.normalizedHamming (p n) (q n))
      atTop (𝓝 0) := by
    simpa only [add_zero] using hq.add hd
  refine squeeze_zero (fun n =>
    div_nonneg (squaredPermutationEnergy_nonneg (f n) (p n))
      (Nat.cast_nonneg _)) ?_ hupper
  intro n
  have he := squaredPermutationEnergy_le_add_hammingDist
    (f n) (hf0 n) (hf1 n) (p n) (q n)
  calc
    squaredPermutationEnergy (f n) (p n) /
        Fintype.card (V n) ≤
      (squaredPermutationEnergy (f n) (q n) +
        (hammingDist (fun x => p n x) (fun x => q n x) : ℝ)) /
          Fintype.card (V n) :=
      div_le_div_of_nonneg_right he (Nat.cast_nonneg _)
    _ = squaredPermutationEnergy (f n) (q n) /
          Fintype.card (V n) +
        SoficGroups.normalizedHamming (p n) (q n) := by
      rw [add_div]
      rfl

theorem squaredPermutationEnergy_mul_tendsto_zero
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    (f : (n : ℕ) → V n → ℝ)
    (p q : (n : ℕ) → Equiv.Perm (V n))
    (hp : Tendsto
      (fun n => squaredPermutationEnergy (f n) (p n) /
        Fintype.card (V n)) atTop (𝓝 0))
    (hq : Tendsto
      (fun n => squaredPermutationEnergy (f n) (q n) /
        Fintype.card (V n)) atTop (𝓝 0)) :
    Tendsto
      (fun n => squaredPermutationEnergy (f n) (p n * q n) /
        Fintype.card (V n)) atTop (𝓝 0) := by
  have hupper : Tendsto
      (fun n =>
        2 * (squaredPermutationEnergy (f n) (p n) /
          Fintype.card (V n)) +
        2 * (squaredPermutationEnergy (f n) (q n) /
          Fintype.card (V n))) atTop (𝓝 0) := by
    simpa using
      (Filter.Tendsto.const_mul (2 : ℝ) hp).add
        (Filter.Tendsto.const_mul (2 : ℝ) hq)
  refine squeeze_zero (fun n =>
    div_nonneg (squaredPermutationEnergy_nonneg (f n) (p n * q n))
      (Nat.cast_nonneg _)) ?_ hupper
  intro n
  calc
    squaredPermutationEnergy (f n) (p n * q n) /
        Fintype.card (V n) ≤
      (2 * squaredPermutationEnergy (f n) (p n) +
        2 * squaredPermutationEnergy (f n) (q n)) /
          Fintype.card (V n) :=
      div_le_div_of_nonneg_right
        (squaredPermutationEnergy_mul_le (f n) (p n) (q n))
        (Nat.cast_nonneg _)
    _ = 2 * (squaredPermutationEnergy (f n) (p n) /
          Fintype.card (V n)) +
        2 * (squaredPermutationEnergy (f n) (q n) /
          Fintype.card (V n)) := by ring

theorem sofic_action_inverse_normalizedHamming_tendsto_zero
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G) (g : G) :
    Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          (((A.model n).action g)⁻¹)
          ((A.model n).action (g⁻¹)))
      atTop (𝓝 0) := by
  have heq :
      (fun n =>
        SoficGroups.normalizedHamming
          (((A.model n).action g)⁻¹)
          ((A.model n).action (g⁻¹))) =
        (fun n =>
          SoficGroups.normalizedHamming
            ((A.model n).action (g * g⁻¹))
            ((A.model n).action g *
              (A.model n).action (g⁻¹))) := by
    funext n
    calc
      SoficGroups.normalizedHamming
          (((A.model n).action g)⁻¹)
          ((A.model n).action (g⁻¹)) =
        SoficGroups.normalizedHamming
          ((A.model n).action g *
            ((A.model n).action g)⁻¹)
          ((A.model n).action g *
            (A.model n).action (g⁻¹)) :=
        (SoficGroups.normalizedHamming_mul_left
          ((A.model n).action g)
          (((A.model n).action g)⁻¹)
          ((A.model n).action (g⁻¹))).symm
      _ = SoficGroups.normalizedHamming
          ((A.model n).action (g * g⁻¹))
          ((A.model n).action g *
            (A.model n).action (g⁻¹)) := by
        simp [(A.model n).map_one]
  rw [heq]
  exact A.multiplicative g (g⁻¹)

theorem sofic_action_squared_energy_mul
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (f : (n : ℕ) → Fin (A.model n).size → ℝ)
    (hf0 : ∀ n x, 0 ≤ f n x)
    (hf1 : ∀ n x, f n x ≤ 1)
    (g h : G)
    (hg : Tendsto
      (fun n =>
        squaredPermutationEnergy (f n) ((A.model n).action g) /
          (A.model n).size) atTop (𝓝 0))
    (hh : Tendsto
      (fun n =>
        squaredPermutationEnergy (f n) ((A.model n).action h) /
          (A.model n).size) atTop (𝓝 0)) :
    Tendsto
      (fun n =>
        squaredPermutationEnergy (f n) ((A.model n).action (g * h)) /
          (A.model n).size) atTop (𝓝 0) := by
  have hproduct : Tendsto
      (fun n =>
        squaredPermutationEnergy (f n)
          ((A.model n).action g * (A.model n).action h) /
          (A.model n).size) atTop (𝓝 0) := by
    simpa only [Fintype.card_fin] using
      (squaredPermutationEnergy_mul_tendsto_zero
        (fun n => Fin (A.model n).size) f
        (fun n => (A.model n).action g)
        (fun n => (A.model n).action h)
        (by simpa only [Fintype.card_fin] using hg)
        (by simpa only [Fintype.card_fin] using hh))
  simpa only [Fintype.card_fin] using
    (squaredPermutationEnergy_tendsto_of_normalizedHamming
      (fun n => Fin (A.model n).size) f hf0 hf1
      (fun n => (A.model n).action (g * h))
      (fun n => (A.model n).action g * (A.model n).action h)
      (by simpa only [Fintype.card_fin] using hproduct)
      (A.multiplicative g h))

theorem sofic_action_squared_energy_inv
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (f : (n : ℕ) → Fin (A.model n).size → ℝ)
    (hf0 : ∀ n x, 0 ≤ f n x)
    (hf1 : ∀ n x, f n x ≤ 1)
    (g : G)
    (hg : Tendsto
      (fun n =>
        squaredPermutationEnergy (f n) ((A.model n).action g) /
          (A.model n).size) atTop (𝓝 0)) :
    Tendsto
      (fun n =>
        squaredPermutationEnergy (f n) ((A.model n).action (g⁻¹)) /
          (A.model n).size) atTop (𝓝 0) := by
  have htrue : Tendsto
      (fun n =>
        squaredPermutationEnergy (f n) (((A.model n).action g)⁻¹) /
          (A.model n).size) atTop (𝓝 0) := by
    simpa only [squaredPermutationEnergy_inv] using hg
  have hd : Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          ((A.model n).action (g⁻¹))
          (((A.model n).action g)⁻¹)) atTop (𝓝 0) := by
    have heq :
        (fun n =>
          SoficGroups.normalizedHamming
            ((A.model n).action (g⁻¹))
            (((A.model n).action g)⁻¹)) =
          (fun n =>
            SoficGroups.normalizedHamming
              (((A.model n).action g)⁻¹)
              ((A.model n).action (g⁻¹))) := by
      funext n
      exact SoficGroups.normalizedHamming_comm _ _
    rw [heq]
    exact sofic_action_inverse_normalizedHamming_tendsto_zero A g
  simpa only [Fintype.card_fin] using
    (squaredPermutationEnergy_tendsto_of_normalizedHamming
      (fun n => Fin (A.model n).size) f hf0 hf1
      (fun n => (A.model n).action (g⁻¹))
      (fun n => ((A.model n).action g)⁻¹)
      (by simpa only [Fintype.card_fin] using htrue) hd)

theorem action_energy_tendsto_zero_of_positive_generator_sum
    {G ι : Type*} [Group G] [Fintype ι]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G)
    (hgenerate : Subgroup.closure (Set.range s) = ⊤)
    (f : (n : ℕ) → Fin (A.model n).size → ℝ)
    (hf0 : ∀ n x, 0 ≤ f n x)
    (hf1 : ∀ n x, f n x ≤ 1)
    (hpositive : Tendsto
      (fun n =>
        (∑ i : ι,
          squaredPermutationEnergy (f n)
            ((A.model n).action (s i))) /
          (A.model n).size) atTop (𝓝 0)) :
    ∀ g : G,
      Tendsto
        (fun n =>
          squaredPermutationEnergy (f n) ((A.model n).action g) /
            (A.model n).size) atTop (𝓝 0) := by
  classical
  have hsingle (i : ι) :
      Tendsto
        (fun n =>
          squaredPermutationEnergy (f n) ((A.model n).action (s i)) /
            (A.model n).size) atTop (𝓝 0) := by
    refine squeeze_zero (fun n =>
      div_nonneg
        (squaredPermutationEnergy_nonneg (f n)
          ((A.model n).action (s i)))
        (Nat.cast_nonneg _)) ?_ hpositive
    intro n
    apply div_le_div_of_nonneg_right _ (Nat.cast_nonneg _)
    exact Finset.single_le_sum
      (fun j _ => squaredPermutationEnergy_nonneg
        (f n) ((A.model n).action (s j)))
      (Finset.mem_univ i)
  intro g
  have hg : g ∈ Subgroup.closure (Set.range s) := by
    rw [hgenerate]
    exact Subgroup.mem_top g
  induction hg using Subgroup.closure_induction with
  | mem x hx =>
      obtain ⟨i, rfl⟩ := hx
      exact hsingle i
  | one =>
      have heq :
          (fun n =>
            squaredPermutationEnergy (f n) ((A.model n).action 1) /
              (A.model n).size) =
            (fun _ : ℕ => (0 : ℝ)) := by
        funext n
        simp [squaredPermutationEnergy, (A.model n).map_one]
      rw [heq]
      exact tendsto_const_nhds
  | mul x y _ _ hx hy =>
      exact sofic_action_squared_energy_mul A f hf0 hf1 x y hx hy
  | inv x _ hx =>
      exact sofic_action_squared_energy_inv A f hf0 hf1 x hx

theorem sum_action_energy_tendsto_zero_of_positive_generator_sum
    {G ι : Type*} [Group G] [Fintype ι]
    (A : SoficGroups.SoficApproximation G)
    (s : ι → G)
    (hgenerate : Subgroup.closure (Set.range s) = ⊤)
    (f : (n : ℕ) → Fin (A.model n).size → ℝ)
    (hf0 : ∀ n x, 0 ≤ f n x)
    (hf1 : ∀ n x, f n x ≤ 1)
    (hpositive : Tendsto
      (fun n =>
        (∑ i : ι,
          squaredPermutationEnergy (f n)
            ((A.model n).action (s i))) /
          (A.model n).size) atTop (𝓝 0))
    (S : Finset G) :
    Tendsto
      (fun n =>
        (∑ g ∈ S,
          squaredPermutationEnergy (f n) ((A.model n).action g)) /
          (A.model n).size) atTop (𝓝 0) := by
  have hall := action_energy_tendsto_zero_of_positive_generator_sum
    A s hgenerate f hf0 hf1 hpositive
  have hsum : Tendsto
      (fun n =>
        ∑ g ∈ S,
          squaredPermutationEnergy (f n) ((A.model n).action g) /
            (A.model n).size) atTop (𝓝 0) := by
    simpa using tendsto_finsetSum S (fun g _ => hall g)
  simpa only [Finset.sum_div] using hsum

end KunPositiveWordMidrankEnergy

namespace KunAdditiveMedianPoincare

open SoficGroups.CheegerPoincare
open Filter Topology
open scoped BigOperators

def permutationRealVariation
    {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) : ℝ :=
  ∑ i : ι, ∑ x : V, |f (σ i x) - f x|

theorem sum_indicator_real_eq_mul_card
    {V : Type*} (A : Finset V)
    (q : V → Prop) [DecidablePred q] (m : ℝ) :
    (∑ x ∈ A, if q x then m else 0) =
      m * (A.filter q).card := by
  calc
    (∑ x ∈ A, if q x then m else 0) =
        m * (∑ x ∈ A, if q x then (1 : ℝ) else 0) := by
          rw [Finset.mul_sum]
          apply Finset.sum_congr rfl
          intro x _
          split <;> simp
    _ = m * (A.filter q).card := by
          congr 1
          exact Finset.sum_boole (R := ℝ) q A

theorem permutationRealVariation_subtract_layer
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (f : V → ℝ)
    (A : Finset V) (m : ℝ) (hm : 0 ≤ m)
    (hinside : ∀ x ∈ A, m ≤ f x)
    (houtside : ∀ x, x ∉ A → f x = 0) :
    permutationRealVariation σ f =
      permutationRealVariation σ
        (fun x => if x ∈ A then f x - m else 0) +
        2 * m * (SoficGroups.boundary σ A : ℝ) := by
  classical
  let g : V → ℝ := fun x => if x ∈ A then f x - m else 0
  have hpair (i : ι) (x : V) :
      |f (σ i x) - f x| =
        |g (σ i x) - g x| +
          (if x ∈ A ∧ σ i x ∉ A then m else 0) +
          (if x ∉ A ∧ σ i x ∈ A then m else 0) := by
    by_cases hx : x ∈ A
    · by_cases hy : σ i x ∈ A
      · simp [g, hx, hy, sub_sub_sub_cancel_right]
      · have hyzero := houtside (σ i x) hy
        have hxnonnegative : 0 ≤ f x := hm.trans (hinside x hx)
        simp [g, hx, hy, hyzero,
          abs_of_nonneg hxnonnegative,
          abs_of_nonpos (sub_nonpos.mpr (hinside x hx))]
    · by_cases hy : σ i x ∈ A
      · have hxzero := houtside x hx
        have hynonnegative : 0 ≤ f (σ i x) :=
          hm.trans (hinside (σ i x) hy)
        have hysub : 0 ≤ f (σ i x) - m :=
          sub_nonneg.mpr (hinside (σ i x) hy)
        simp [g, hx, hy, hxzero,
          abs_of_nonneg hynonnegative, abs_of_nonneg hysub]
      · simp [g, hx, hy, houtside x hx,
          houtside (σ i x) hy]
  have hone (i : ι) :
      (∑ x : V, |f (σ i x) - f x|) =
        (∑ x : V, |g (σ i x) - g x|) +
          2 * m * (A.filter fun x => σ i x ∉ A).card := by
    have hexit :
        (∑ x : V, if x ∈ A ∧ σ i x ∉ A then m else 0) =
          m * (A.filter fun x => σ i x ∉ A).card := by
      have hset :
          Finset.univ.filter
            (fun x : V => x ∈ A ∧ σ i x ∉ A) =
              A.filter fun x => σ i x ∉ A := by
        ext x
        simp
      simpa only [hset] using
        sum_indicator_real_eq_mul_card Finset.univ
          (fun x : V => x ∈ A ∧ σ i x ∉ A) m
    have henter :
        (∑ x : V, if x ∉ A ∧ σ i x ∈ A then m else 0) =
          m * (Finset.univ.filter fun x =>
            x ∉ A ∧ σ i x ∈ A).card :=
      sum_indicator_real_eq_mul_card
        Finset.univ (fun x => x ∉ A ∧ σ i x ∈ A) m
    calc
      (∑ x : V, |f (σ i x) - f x|) =
          ∑ x : V,
            (|g (σ i x) - g x| +
              (if x ∈ A ∧ σ i x ∉ A then m else 0) +
              (if x ∉ A ∧ σ i x ∈ A then m else 0)) := by
            apply Finset.sum_congr rfl
            intro x _
            exact hpair i x
      _ = (∑ x : V, |g (σ i x) - g x|) +
            (∑ x : V,
              if x ∈ A ∧ σ i x ∉ A then m else 0) +
            (∑ x : V,
              if x ∉ A ∧ σ i x ∈ A then m else 0) := by
            simp_rw [Finset.sum_add_distrib]
      _ = (∑ x : V, |g (σ i x) - g x|) +
            m * (A.filter fun x => σ i x ∉ A).card +
            m * (Finset.univ.filter fun x =>
              x ∉ A ∧ σ i x ∈ A).card := by
            rw [hexit, henter]
      _ = (∑ x : V, |g (σ i x) - g x|) +
            2 * m * (A.filter fun x => σ i x ∉ A).card := by
            have hcross :
                (Finset.univ.filter fun x =>
                  x ∉ A ∧ σ i x ∈ A).card =
                  (A.filter fun x => σ i x ∉ A).card :=
              SoficGroups.KunThomFiberCoarea.card_entering_eq_card_exiting
                (σ i) A
            rw [hcross]
            ring
  unfold permutationRealVariation SoficGroups.boundary
  calc
    (∑ i : ι, ∑ x : V, |f (σ i x) - f x|) =
        ∑ i : ι,
          ((∑ x : V, |g (σ i x) - g x|) +
            2 * m * (A.filter fun x => σ i x ∉ A).card) := by
          apply Finset.sum_congr rfl
          intro i _
          exact hone i
    _ = (∑ i : ι, ∑ x : V, |g (σ i x) - g x|) +
          2 * m *
            (∑ i : ι, (A.filter fun x => σ i x ∉ A).card) := by
          push_cast
          simp [Finset.sum_add_distrib, Finset.mul_sum]

theorem additive_permutation_small_support_coarea
    {V ι : Type*} [Fintype V]
    [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (γ ε : ℝ)
    (hε : 0 ≤ ε)
    (hexp : ∀ A : Finset V,
      γ * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ) + ε)
    (f : V → ℝ) (M : ℝ) (hM : 0 ≤ M)
    (hf : ∀ x, 0 ≤ f x)
    (hfM : ∀ x, f x ≤ M)
    (hhalf :
      2 * (SoficGroups.CheegerPoincare.positiveSupport f).card ≤
        Fintype.card V) :
    2 * γ * (∑ x : V, f x) ≤
      permutationRealVariation σ f + 2 * ε * M := by
  classical
  generalize hn :
    (SoficGroups.CheegerPoincare.positiveSupport f).card = n
  induction n using Nat.strong_induction_on generalizing f M with
  | h n ih =>
    by_cases hnonempty :
        (SoficGroups.CheegerPoincare.positiveSupport f).Nonempty
    · let A : Finset V :=
        SoficGroups.CheegerPoincare.positiveSupport f
      have hA : A.Nonempty := hnonempty
      have himage : (A.image f).Nonempty :=
        Finset.image_nonempty.mpr hA
      let m : ℝ := (A.image f).min' himage
      have hmem : m ∈ A.image f := Finset.min'_mem _ _
      obtain ⟨z, hzA, hzm⟩ := Finset.mem_image.mp hmem
      have hmpos : 0 < m := by
        rw [← hzm]
        exact
          (SoficGroups.CheegerPoincare.mem_positiveSupport f z).mp hzA
      have hmle : ∀ x ∈ A, m ≤ f x := by
        intro x hx
        exact Finset.min'_le (A.image f) (f x)
          (Finset.mem_image.mpr ⟨x, hx, rfl⟩)
      have hmM : m ≤ M := by
        rw [← hzm]
        exact hfM z
      let g : V → ℝ := fun x =>
        if x ∈ A then f x - m else 0
      have hgnonnegative : ∀ x, 0 ≤ g x := by
        intro x
        by_cases hx : x ∈ A
        · simpa [g, hx] using sub_nonneg.mpr (hmle x hx)
        · simp [g, hx]
      have hgupper : ∀ x, g x ≤ M - m := by
        intro x
        by_cases hx : x ∈ A
        · simp only [g, if_pos hx]
          linarith [hfM x]
        · simp only [g, if_neg hx]
          linarith
      have hgsub :
          SoficGroups.CheegerPoincare.positiveSupport g ⊆ A := by
        intro x hx
        have hpositive :=
          (SoficGroups.CheegerPoincare.mem_positiveSupport g x).mp hx
        by_contra hxA
        simp [g, hxA] at hpositive
      have hznot :
          z ∉ SoficGroups.CheegerPoincare.positiveSupport g := by
        intro hz
        have hpositive :=
          (SoficGroups.CheegerPoincare.mem_positiveSupport g z).mp hz
        have hzero : g z = 0 := by
          simp [g, hzA, hzm]
        simp [hzero] at hpositive
      have hstrict :
          SoficGroups.CheegerPoincare.positiveSupport g ⊂ A := by
        apply Finset.ssubset_iff_subset_ne.mpr
        refine ⟨hgsub, ?_⟩
        intro heq
        exact hznot (heq.symm ▸ hzA)
      have hgcard :
          (SoficGroups.CheegerPoincare.positiveSupport g).card < n := by
        rw [← hn]
        exact Finset.card_lt_card hstrict
      have hghalf :
          2 * (SoficGroups.CheegerPoincare.positiveSupport g).card ≤
            Fintype.card V :=
        (Nat.mul_le_mul_left 2 (Finset.card_le_card hgsub)).trans hhalf
      have hgbound :
          2 * γ * (∑ x : V, g x) ≤
            permutationRealVariation σ g + 2 * ε * (M - m) :=
        ih (SoficGroups.CheegerPoincare.positiveSupport g).card
          hgcard g (M - m) (sub_nonneg.mpr hmM)
          hgnonnegative hgupper hghalf rfl
      have hhalfre : (2 : ℝ) * A.card ≤ Fintype.card V := by
        exact_mod_cast hhalf
      have hmin :
          (A.card : ℝ) ≤ (Fintype.card V : ℝ) - A.card := by
        linarith
      have hcut :
          γ * (A.card : ℝ) ≤
            (SoficGroups.boundary σ A : ℝ) + ε := by
        simpa [min_eq_left hmin] using hexp A
      have houtside : ∀ x, x ∉ A → f x = 0 := by
        intro x hx
        have hnot : ¬ 0 < f x := by
          intro hpositive
          exact hx
            ((SoficGroups.CheegerPoincare.mem_positiveSupport f x).mpr
              hpositive)
        exact le_antisymm (le_of_not_gt hnot) (hf x)
      have hsumindicator :
          (∑ x : V, if x ∈ A then m else 0) =
            m * (A.card : ℝ) := by
        simpa using
          sum_indicator_real_eq_mul_card Finset.univ
            (fun x : V => x ∈ A) m
      have hsum :
          (∑ x : V, f x) =
            (∑ x : V, g x) + m * (A.card : ℝ) := by
        calc
          (∑ x : V, f x) =
              ∑ x : V,
                (g x + if x ∈ A then m else 0) := by
              apply Finset.sum_congr rfl
              intro x _
              by_cases hx : x ∈ A
              · simp [g, hx]
              · simp [g, hx, houtside x hx]
          _ = (∑ x : V, g x) +
              (∑ x : V, if x ∈ A then m else 0) := by
              rw [Finset.sum_add_distrib]
          _ = (∑ x : V, g x) + m * (A.card : ℝ) := by
              rw [hsumindicator]
      have hvariation :
          permutationRealVariation σ f =
            permutationRealVariation σ g +
              2 * m * (SoficGroups.boundary σ A : ℝ) :=
        permutationRealVariation_subtract_layer
          σ f A m hmpos.le hmle houtside
      have hscaled :=
        mul_le_mul_of_nonneg_left hcut
          (show 0 ≤ 2 * m by positivity)
      rw [hsum, hvariation]
      nlinarith
    · have hzero : ∀ x, f x = 0 := by
        intro x
        have hx : ¬ 0 < f x := by
          intro hpositive
          apply hnonempty
          exact ⟨x,
            (SoficGroups.CheegerPoincare.mem_positiveSupport f x).mpr
              hpositive⟩
        exact le_antisymm (le_of_not_gt hx) (hf x)
      simp [permutationRealVariation, hzero]
      positivity

theorem positive_negative_abs_eq (a b : ℝ) :
    |max a 0 - max b 0| +
      |max (-a) 0 - max (-b) 0| = |a - b| := by
  rcases le_total 0 a with ha | ha <;>
    rcases le_total 0 b with hb | hb <;>
    rcases le_total a b with hab | hab <;>
    simp_all [abs_of_nonneg, abs_of_nonpos] <;> linarith

theorem permutationRealVariation_positive_negative
    {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) (m : ℝ) :
    permutationRealVariation σ (fun x => max (f x - m) 0) +
      permutationRealVariation σ (fun x => max (m - f x) 0) =
        permutationRealVariation σ f := by
  unfold permutationRealVariation
  rw [← Finset.sum_add_distrib]
  apply Finset.sum_congr rfl
  intro i _
  rw [← Finset.sum_add_distrib]
  apply Finset.sum_congr rfl
  intro x _
  have hx : m - f x = -(f x - m) := by ring
  have hy : m - f (σ i x) = -(f (σ i x) - m) := by ring
  have hxy :
      (f (σ i x) - m) - (f x - m) = f (σ i x) - f x := by
    ring
  simpa only [hx, hy, hxy] using
    positive_negative_abs_eq (f (σ i x) - m) (f x - m)

theorem exists_bounded_finite_real_median
    {V : Type*} [Fintype V] [Nonempty V]
    (f : V → ℝ)
    (hf : ∀ x, 0 ≤ f x)
    (hf_one : ∀ x, f x ≤ 1) :
    ∃ m : ℝ, 0 ≤ m ∧ m ≤ 1 ∧
      2 * (SoficGroups.CheegerPoincare.lowerLevel f m).card ≤
          Fintype.card V ∧
      2 * (SoficGroups.CheegerPoincare.upperLevel f m).card ≤
          Fintype.card V := by
  classical
  obtain ⟨m, hbelow, habove⟩ :=
    SoficGroups.CheegerPoincare.exists_finite_real_median f
  have hcard : 0 < Fintype.card V := Fintype.card_pos_iff.mpr
    (inferInstance : Nonempty V)
  have hm_nonnegative : 0 ≤ m := by
    by_contra hnot
    have hm_negative : m < 0 := lt_of_not_ge hnot
    have hupper :
        SoficGroups.CheegerPoincare.upperLevel f m =
          (Finset.univ : Finset V) := by
      ext x
      simp only [SoficGroups.CheegerPoincare.mem_upperLevel,
        Finset.mem_univ, iff_true]
      exact hm_negative.trans_le (hf x)
    rw [hupper, Finset.card_univ] at habove
    omega
  have hm_one : m ≤ 1 := by
    by_contra hnot
    have hm_greater : 1 < m := lt_of_not_ge hnot
    have hlower :
        SoficGroups.CheegerPoincare.lowerLevel f m =
          (Finset.univ : Finset V) := by
      ext x
      simp only [SoficGroups.CheegerPoincare.mem_lowerLevel,
        Finset.mem_univ, iff_true]
      exact (hf_one x).trans_lt hm_greater
    rw [hlower, Finset.card_univ] at hbelow
    omega
  exact ⟨m, hm_nonnegative, hm_one, hbelow, habove⟩

theorem additive_permutation_median_absolute_deviation
    {V ι : Type*} [Fintype V] [Nonempty V]
    [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (γ ε : ℝ)
    (hε : 0 ≤ ε)
    (hexp : ∀ A : Finset V,
      γ * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ) + ε)
    (f : V → ℝ)
    (hf : ∀ x, 0 ≤ f x)
    (hf_one : ∀ x, f x ≤ 1) :
    ∃ m : ℝ, 0 ≤ m ∧ m ≤ 1 ∧
      2 * γ * (∑ x : V, |f x - m|) ≤
        permutationRealVariation σ f + 4 * ε := by
  classical
  obtain ⟨m, hm_nonnegative, hm_one, hbelow, habove⟩ :=
    exists_bounded_finite_real_median f hf hf_one
  let p : V → ℝ := fun x => max (f x - m) 0
  let q : V → ℝ := fun x => max (m - f x) 0
  have hp_nonnegative : ∀ x, 0 ≤ p x := by
    intro x
    exact le_max_right _ _
  have hq_nonnegative : ∀ x, 0 ≤ q x := by
    intro x
    exact le_max_right _ _
  have hp_one : ∀ x, p x ≤ 1 := by
    intro x
    apply max_le
    · linarith [hf_one x]
    · norm_num
  have hq_one : ∀ x, q x ≤ 1 := by
    intro x
    apply max_le
    · linarith [hf x]
    · norm_num
  have hp_half :
      2 * (SoficGroups.CheegerPoincare.positiveSupport p).card ≤
        Fintype.card V := by
    simpa only [p, SoficGroups.CheegerPoincare.positiveSupport_max_sub]
      using habove
  have hq_half :
      2 * (SoficGroups.CheegerPoincare.positiveSupport q).card ≤
        Fintype.card V := by
    simpa only [q,
      SoficGroups.CheegerPoincare.positiveSupport_max_sub_reverse]
      using hbelow
  have hp_coarea := additive_permutation_small_support_coarea
    σ γ ε hε hexp p 1 (by norm_num) hp_nonnegative hp_one hp_half
  have hq_coarea := additive_permutation_small_support_coarea
    σ γ ε hε hexp q 1 (by norm_num) hq_nonnegative hq_one hq_half
  have hvariation :
      permutationRealVariation σ p +
        permutationRealVariation σ q =
          permutationRealVariation σ f := by
    simpa only [p, q] using
      permutationRealVariation_positive_negative σ f m
  have hpoint (x : V) : p x + q x = |f x - m| := by
    dsimp [p, q]
    rcases le_total m (f x) with hx | hx
    · rw [max_eq_left (sub_nonneg.mpr hx),
        max_eq_right (sub_nonpos.mpr hx),
        abs_of_nonneg (sub_nonneg.mpr hx)]
      ring
    · rw [max_eq_right (sub_nonpos.mpr hx),
        max_eq_left (sub_nonneg.mpr hx),
        abs_of_nonpos (sub_nonpos.mpr hx)]
      ring
  have hmass :
      (∑ x : V, p x) + (∑ x : V, q x) =
        ∑ x : V, |f x - m| := by
    rw [← Finset.sum_add_distrib]
    apply Finset.sum_congr rfl
    intro x _
    exact hpoint x
  refine ⟨m, hm_nonnegative, hm_one, ?_⟩
  rw [← hmass, ← hvariation]
  nlinarith [hp_coarea, hq_coarea]

theorem additive_permutation_median_variance
    {V ι : Type*} [Fintype V] [Nonempty V]
    [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (γ ε : ℝ)
    (hγ : 0 ≤ γ)
    (hε : 0 ≤ ε)
    (hexp : ∀ A : Finset V,
      γ * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ) + ε)
    (f : V → ℝ)
    (hf : ∀ x, 0 ≤ f x)
    (hf_one : ∀ x, f x ≤ 1) :
    2 * γ *
        (∑ x : V,
          (f x - SoficGroups.CheegerPoincare.finiteMean f) ^ 2) ≤
      permutationRealVariation σ f + 4 * ε := by
  obtain ⟨m, hm_nonnegative, hm_one, hmedian⟩ :=
    additive_permutation_median_absolute_deviation
      σ γ ε hε hexp f hf hf_one
  have hpoint (x : V) : (f x - m) ^ 2 ≤ |f x - m| := by
    have hlower : -1 ≤ f x - m := by
      linarith [hf x]
    have hupper : f x - m ≤ 1 := by
      linarith [hf_one x]
    rcases le_total 0 (f x - m) with hx | hx
    · rw [abs_of_nonneg hx]
      nlinarith
    · rw [abs_of_nonpos hx]
      nlinarith
  have hsq :
      (∑ x : V, (f x - m) ^ 2) ≤
        ∑ x : V, |f x - m| := by
    exact Finset.sum_le_sum fun x _ => hpoint x
  have hmean :=
    SoficGroups.CheegerPoincare.sum_sq_sub_finiteMean_le f m
  have hfactor : 0 ≤ 2 * γ := mul_nonneg (by norm_num) hγ
  calc
    2 * γ *
        (∑ x : V,
          (f x - SoficGroups.CheegerPoincare.finiteMean f) ^ 2) ≤
        2 * γ * (∑ x : V, (f x - m) ^ 2) :=
      mul_le_mul_of_nonneg_left hmean hfactor
    _ ≤ 2 * γ * (∑ x : V, |f x - m|) :=
      mul_le_mul_of_nonneg_left hsq hfactor
    _ ≤ permutationRealVariation σ f + 4 * ε := hmedian

theorem additive_permutation_finiteVariance
    {V ι : Type*} [Fintype V] [Nonempty V]
    [Fintype ι] [DecidableEq V]
    (σ : ι → Equiv.Perm V) (γ ε : ℝ)
    (hγ : 0 ≤ γ)
    (hε : 0 ≤ ε)
    (hexp : ∀ A : Finset V,
      γ * min (A.card : ℝ)
        ((Fintype.card V : ℝ) - A.card) ≤
          (SoficGroups.boundary σ A : ℝ) + ε)
    (f : V → ℝ)
    (hf : ∀ x, 0 ≤ f x)
    (hf_one : ∀ x, f x ≤ 1) :
    2 * γ * (Fintype.card V : ℝ) *
        SoficGroups.CheegerPoincare.finiteVariance f ≤
      permutationRealVariation σ f + 4 * ε := by
  have hvariance := additive_permutation_median_variance
    σ γ ε hγ hε hexp f hf hf_one
  rw [← SoficGroups.CheegerPoincare.card_mul_finiteVariance f]
    at hvariance
  nlinarith

end KunAdditiveMedianPoincare

namespace KunCompletedComponentMidrankVariation

open Filter Topology
open scoped BigOperators

def permutationRealVariation
    {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) : ℝ :=
  ∑ i : ι, ∑ x : V, |f (σ i x) - f x|

theorem permutationRealVariation_sq_le_card_mul_energy
    {V ι : Type*} [Fintype V] [Fintype ι]
    (σ : ι → Equiv.Perm V) (f : V → ℝ) :
    permutationRealVariation σ f ^ 2 ≤
      ((Fintype.card ι : ℝ) * Fintype.card V) *
        (∑ i : ι, ∑ x : V, (f (σ i x) - f x) ^ 2) := by
  classical
  have h := Finset.sum_mul_sq_le_sq_mul_sq
    (Finset.univ : Finset (ι × V))
    (fun _ : ι × V => (1 : ℝ))
    (fun z : ι × V => |f (σ z.1 z.2) - f z.2|)
  simpa only [one_mul, one_pow, sq_abs,
    ← Finset.univ_product_univ, Finset.sum_product,
    Finset.sum_const_zero, Finset.sum_const, Finset.card_product,
    Finset.card_univ, Nat.cast_mul, nsmul_eq_mul, mul_one,
    permutationRealVariation] using h

theorem normalized_permutationRealVariation_tendsto_zero_of_energy
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    (ι : Type*) [Fintype ι]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (f : (n : ℕ) → V n → ℝ)
    (henergy : Tendsto
      (fun n =>
        (∑ i : ι, ∑ x : V n,
          (f n (σ n i x) - f n x) ^ 2) /
            (Fintype.card (V n) : ℝ))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        permutationRealVariation (σ n) (f n) /
          (Fintype.card (V n) : ℝ))
      atTop (nhds 0) := by
  have hN (n : ℕ) : (0 : ℝ) < Fintype.card (V n) := by
    exact_mod_cast Fintype.card_pos_iff.mpr inferInstance
  have hupper (n : ℕ) :
      permutationRealVariation (σ n) (f n) /
          (Fintype.card (V n) : ℝ) ≤
        Real.sqrt
          ((Fintype.card ι : ℝ) *
            ((∑ i : ι, ∑ x : V n,
              (f n (σ n i x) - f n x) ^ 2) /
                (Fintype.card (V n) : ℝ))) := by
    apply Real.le_sqrt_of_sq_le
    calc
      (permutationRealVariation (σ n) (f n) /
        (Fintype.card (V n) : ℝ)) ^ 2 =
          permutationRealVariation (σ n) (f n) ^ 2 /
            (Fintype.card (V n) : ℝ) ^ 2 := by
              ring
      _ ≤
          (((Fintype.card ι : ℝ) * Fintype.card (V n)) *
            (∑ i : ι, ∑ x : V n,
              (f n (σ n i x) - f n x) ^ 2)) /
            (Fintype.card (V n) : ℝ) ^ 2 := by
              exact div_le_div_of_nonneg_right
                (permutationRealVariation_sq_le_card_mul_energy
                  (σ n) (f n))
                (sq_nonneg (Fintype.card (V n) : ℝ))
      _ = (Fintype.card ι : ℝ) *
          ((∑ i : ι, ∑ x : V n,
            (f n (σ n i x) - f n x) ^ 2) /
              (Fintype.card (V n) : ℝ)) := by
            field_simp [ne_of_gt (hN n)]
  have hroot : Tendsto
      (fun n =>
        Real.sqrt
          ((Fintype.card ι : ℝ) *
            ((∑ i : ι, ∑ x : V n,
              (f n (σ n i x) - f n x) ^ 2) /
                (Fintype.card (V n) : ℝ))))
      atTop (nhds 0) := by
    have hscaled : Tendsto
        (fun n =>
          (Fintype.card ι : ℝ) *
            ((∑ i : ι, ∑ x : V n,
              (f n (σ n i x) - f n x) ^ 2) /
                (Fintype.card (V n) : ℝ)))
        atTop (nhds 0) := by
      simpa using henergy.const_mul (Fintype.card ι : ℝ)
    simpa only [Function.comp_def, Real.sqrt_zero] using
      (Real.continuous_sqrt.tendsto (0 : ℝ)).comp hscaled
  apply squeeze_zero'
    (Eventually.of_forall (fun n => ?_))
    (Eventually.of_forall hupper)
    hroot
  apply div_nonneg _ (hN n).le
  unfold permutationRealVariation
  exact Finset.sum_nonneg fun _ _ =>
    Finset.sum_nonneg fun _ _ => abs_nonneg _

theorem sum_partition_parts_eq
    {V : Type*} [Fintype V] [DecidableEq V]
    (P : Finpartition (Finset.univ : Finset V)) (f : V → ℝ) :
    (∑ C ∈ P.parts, ∑ x ∈ C, f x) = ∑ x : V, f x := by
  classical
  calc
    (∑ C ∈ P.parts, ∑ x ∈ C, f x) =
        ∑ x ∈ P.parts.biUnion id, f x := by
          symm
          exact Finset.sum_biUnion P.disjoint
    _ = ∑ x : V, f x := by rw [P.biUnion_parts]

theorem completed_component_real_variation_le
    {V ι : Type*} [DecidableEq V] [Fintype ι]
    (σ : ι → Equiv.Perm V)
    (C : Finset V)
    (τ : ι → Equiv.Perm {x : V // x ∈ C})
    (hτ : ∀ i (x : V) (hx : x ∈ C) (_hy : σ i x ∈ C),
      ((τ i ⟨x, hx⟩ : {x : V // x ∈ C}) : V) = σ i x)
    (f : V → ℝ)
    (hf0 : ∀ x, 0 ≤ f x)
    (hf1 : ∀ x, f x ≤ 1) :
    permutationRealVariation τ (fun x => f (x : V)) ≤
      (∑ i : ι, ∑ x ∈ C, |f (σ i x) - f x|) +
        (SoficGroups.boundary σ C : ℝ) := by
  classical
  have hunit (x y : V) : |f x - f y| ≤ (1 : ℝ) := by
    apply (abs_le).2
    constructor <;> linarith [hf0 x, hf0 y, hf1 x, hf1 y]
  have hpoint (i : ι) (x : {x : V // x ∈ C}) :
      |f ((τ i x : {x : V // x ∈ C}) : V) - f (x : V)| ≤
        |f (σ i (x : V)) - f (x : V)| +
          if σ i (x : V) ∈ C then 0 else 1 := by
    by_cases hinside : σ i (x : V) ∈ C
    · simp only [if_pos hinside, add_zero]
      rw [hτ i (x : V) x.property hinside]
    · simp only [if_neg hinside]
      linarith [hunit
        ((τ i x : {x : V // x ∈ C}) : V) (x : V),
        abs_nonneg (f (σ i (x : V)) - f (x : V))]
  calc
    permutationRealVariation τ (fun x => f (x : V)) ≤
        ∑ i : ι, ∑ x : {x : V // x ∈ C},
          (|f (σ i (x : V)) - f (x : V)| +
            if σ i (x : V) ∈ C then 0 else 1) := by
          unfold permutationRealVariation
          apply Finset.sum_le_sum
          intro i _
          apply Finset.sum_le_sum
          intro x _
          exact hpoint i x
    _ = ∑ i : ι,
          ((∑ x ∈ C, |f (σ i x) - f x|) +
            ((C.filter fun x => σ i x ∉ C).card : ℝ)) := by
          apply Finset.sum_congr rfl
          intro i _
          rw [Finset.sum_add_distrib]
          have horiginal :
              (∑ x : {x : V // x ∈ C},
                |f (σ i (x : V)) - f (x : V)|) =
                ∑ x ∈ C, |f (σ i x) - f x| :=
            (Finset.sum_subtype C (fun _ => Iff.rfl)
              (fun x : V => |f (σ i x) - f x|)).symm
          have hmiss :
              (∑ x : {x : V // x ∈ C},
                if σ i (x : V) ∈ C then (0 : ℝ) else 1) =
                ((C.filter fun x => σ i x ∉ C).card : ℝ) := by
            calc
              (∑ x : {x : V // x ∈ C},
                if σ i (x : V) ∈ C then (0 : ℝ) else 1) =
                  ∑ x ∈ C,
                    if σ i x ∈ C then (0 : ℝ) else 1 :=
                (Finset.sum_subtype C (fun _ => Iff.rfl)
                  (fun x : V => if σ i x ∈ C then (0 : ℝ) else 1)).symm
              _ = ((C.filter fun x => σ i x ∉ C).card : ℝ) := by
                simpa only [ite_not] using
                  (Finset.sum_boole (R := ℝ)
                    (fun x : V => σ i x ∉ C) C)
          rw [horiginal, hmiss]
    _ = (∑ i : ι, ∑ x ∈ C, |f (σ i x) - f x|) +
          (SoficGroups.boundary σ C : ℝ) := by
          simp [SoficGroups.boundary, Finset.sum_add_distrib]

theorem sum_completed_component_real_variation_le
    {V ι : Type*} [Fintype V] [DecidableEq V] [Fintype ι]
    (P : Finpartition (Finset.univ : Finset V))
    (σ : ι → Equiv.Perm V)
    (τ : (C : Finset V) → ι → Equiv.Perm {x : V // x ∈ C})
    (hτ : ∀ C ∈ P.parts, ∀ i (x : V)
      (hx : x ∈ C) (_hy : σ i x ∈ C),
      ((τ C i ⟨x, hx⟩ : {x : V // x ∈ C}) : V) = σ i x)
    (f : V → ℝ)
    (hf0 : ∀ x, 0 ≤ f x)
    (hf1 : ∀ x, f x ≤ 1) :
    (∑ C ∈ P.parts,
      permutationRealVariation (τ C) (fun x => f (x : V))) ≤
      permutationRealVariation σ f +
        ∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ) := by
  classical
  have hparts :
      (∑ C ∈ P.parts, ∑ i : ι, ∑ x ∈ C,
        |f (σ i x) - f x|) =
        permutationRealVariation σ f := by
    unfold permutationRealVariation
    rw [Finset.sum_comm]
    apply Finset.sum_congr rfl
    intro i _
    exact sum_partition_parts_eq P
      (fun x : V => |f (σ i x) - f x|)
  calc
    (∑ C ∈ P.parts,
      permutationRealVariation (τ C) (fun x => f (x : V))) ≤
        ∑ C ∈ P.parts,
          ((∑ i : ι, ∑ x ∈ C, |f (σ i x) - f x|) +
            (SoficGroups.boundary σ C : ℝ)) := by
          apply Finset.sum_le_sum
          intro C hC
          exact completed_component_real_variation_le
            σ C (τ C) (hτ C hC) f hf0 hf1
    _ = permutationRealVariation σ f +
          ∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ) := by
          rw [Finset.sum_add_distrib, hparts]

end KunCompletedComponentMidrankVariation

namespace KunGlobalActualAdditiveMidrankVariance

open Filter Topology
open scoped BigOperators

theorem weighted_component_midrankVariance_additive_bound
    {V ι : Type*} [Fintype V] [DecidableEq V] [Fintype ι]
    (P : Finpartition (Finset.univ : Finset V))
    (σ : ι → Equiv.Perm V)
    (τ : (C : Finset V) → ι → Equiv.Perm {x : V // x ∈ C})
    (γ : ℝ) (hγ : 0 ≤ γ)
    (hτ : ∀ C ∈ P.parts, ∀ i (x : V)
      (hx : x ∈ C) (_hy : σ i x ∈ C),
      ((τ C i ⟨x, hx⟩ : {x : V // x ∈ C}) : V) = σ i x)
    (hexpand : ∀ C ∈ P.parts, ∀ E : Finset V, E ⊆ C →
      2 * E.card ≤ C.card →
        γ * (E.card : ℝ) ≤ (SoficGroups.boundary σ E : ℝ))
    (b : V → ℤ) :
    2 * γ *
        (∑ C ∈ P.parts,
          (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C b)) ≤
      SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
        σ (SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank P b) +
        5 * (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) := by
  classical
  let f : V → ℝ :=
    SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank P b
  have hf0 (x : V) : 0 ≤ f x :=
    SoficGroups.componentVertexMidrank_nonneg (P.part x) b x
  have hf1 (x : V) : f x ≤ 1 :=
    SoficGroups.componentVertexMidrank_le_one (P.part x) b x
  have hcomponent (C : Finset V) (hC : C ∈ P.parts) :
      2 * γ * (C.card : ℝ) *
          SoficGroups.midrankVariance
            (SoficGroups.componentRankMassList C b) ≤
        SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
          (τ C) (fun x : {x : V // x ∈ C} => f (x : V)) +
          4 * (SoficGroups.boundary σ C : ℝ) := by
    have hCne : C.Nonempty := P.nonempty_of_mem_parts hC
    letI : Nonempty {x : V // x ∈ C} :=
      ⟨⟨hCne.choose, hCne.choose_spec⟩⟩
    have hrestrict :
        (fun x : {x : V // x ∈ C} => f (x : V)) =
          (fun x : {x : V // x ∈ C} =>
            SoficGroups.componentVertexMidrank C b (x : V)) := by
      funext x
      change
        SoficGroups.componentVertexMidrank (P.part (x : V)) b (x : V) =
          SoficGroups.componentVertexMidrank C b (x : V)
      rw [P.part_eq_of_mem hC x.property]
    have hcut (E : Finset {x : V // x ∈ C}) :
        γ * min (E.card : ℝ)
            ((Fintype.card {x : V // x ∈ C} : ℝ) - E.card) ≤
          (SoficGroups.boundary (τ C) E : ℝ) +
            (SoficGroups.boundary σ C : ℝ) := by
      have h :=
        SoficGroups.KunResidualExpanderDecomposition.completed_component_additive_expansion
          σ C (τ C) (hτ C hC) γ (hexpand C hC) E
      have h' :
          γ * min (E.card : ℝ) ((C.card : ℝ) - E.card) ≤
            (SoficGroups.boundary (τ C) E : ℝ) +
              (SoficGroups.boundary σ C : ℝ) := by
        linarith
      simpa only [Fintype.card_coe] using h'
    have hp :=
      SoficGroups.KunAdditiveMedianPoincare.additive_permutation_finiteVariance
        (τ C) γ (SoficGroups.boundary σ C : ℝ)
        hγ (Nat.cast_nonneg _) hcut
        (fun x : {x : V // x ∈ C} =>
          SoficGroups.componentVertexMidrank C b (x : V))
        (fun x => SoficGroups.componentVertexMidrank_nonneg C b (x : V))
        (fun x => SoficGroups.componentVertexMidrank_le_one C b (x : V))
    rw [Fintype.card_coe,
      SoficGroups.ComponentMidrankVariance.componentVertexMidrank_finiteVariance_eq
        C b hCne] at hp
    rw [← hrestrict] at hp
    simpa only
      [SoficGroups.KunAdditiveMedianPoincare.permutationRealVariation,
       SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation]
      using hp
  have hsummed :
      2 * γ *
          (∑ C ∈ P.parts,
            (C.card : ℝ) *
              SoficGroups.midrankVariance
                (SoficGroups.componentRankMassList C b)) ≤
        (∑ C ∈ P.parts,
          SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
            (τ C) (fun x : {x : V // x ∈ C} => f (x : V))) +
          4 * (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) := by
    calc
      2 * γ *
          (∑ C ∈ P.parts,
            (C.card : ℝ) *
              SoficGroups.midrankVariance
                (SoficGroups.componentRankMassList C b)) =
        ∑ C ∈ P.parts,
          2 * γ * (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C b) := by
              rw [Finset.mul_sum]
              apply Finset.sum_congr rfl
              intro C _
              ring
      _ ≤ ∑ C ∈ P.parts,
          (SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
            (τ C) (fun x : {x : V // x ∈ C} => f (x : V)) +
            4 * (SoficGroups.boundary σ C : ℝ)) := by
              apply Finset.sum_le_sum
              intro C hC
              exact hcomponent C hC
      _ = (∑ C ∈ P.parts,
          SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
            (τ C) (fun x : {x : V // x ∈ C} => f (x : V))) +
          4 * (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ)) := by
              rw [Finset.sum_add_distrib, Finset.mul_sum]
  have hcompletion :=
    SoficGroups.KunCompletedComponentMidrankVariation.sum_completed_component_real_variation_le
      P σ τ hτ f hf0 hf1
  change
    2 * γ *
        (∑ C ∈ P.parts,
          (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C b)) ≤
      SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
        σ f +
        5 * (∑ C ∈ P.parts, (SoficGroups.boundary σ C : ℝ))
  linarith

theorem weighted_component_midrankVariance_tendsto_zero_of_additive_expansion
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    (ι : Type*) [Fintype ι]
    (P : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (τ : (n : ℕ) → (C : Finset (V n)) →
      ι → Equiv.Perm {x : V n // x ∈ C})
    (b : (n : ℕ) → V n → ℤ)
    (γ : ℝ) (hγ : 0 < γ)
    (hτ : ∀ n C, C ∈ (P n).parts → ∀ i (x : V n)
      (hx : x ∈ C) (_hy : σ n i x ∈ C),
      ((τ n C i ⟨x, hx⟩ : {x : V n // x ∈ C}) : V n) =
        σ n i x)
    (hexpand : ∀ n C, C ∈ (P n).parts → ∀ E : Finset (V n),
      E ⊆ C → 2 * E.card ≤ C.card →
        γ * (E.card : ℝ) ≤ (SoficGroups.boundary (σ n) E : ℝ))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts,
          (SoficGroups.boundary (σ n) C : ℝ)) /
            (Fintype.card (V n) : ℝ))
      atTop (nhds 0))
    (henergy : Tendsto
      (fun n =>
        (∑ i : ι, ∑ x : V n,
          (SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
            (P n) (b n) (σ n i x) -
           SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
            (P n) (b n) x) ^ 2) /
              (Fintype.card (V n) : ℝ))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts,
          (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C (b n))) /
                (Fintype.card (V n) : ℝ))
      atTop (nhds 0) := by
  classical
  let f : (n : ℕ) → V n → ℝ :=
    fun n =>
      SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
        (P n) (b n)
  have hN (n : ℕ) : (0 : ℝ) < Fintype.card (V n) := by
    exact_mod_cast Fintype.card_pos_iff.mpr inferInstance
  have hvariation : Tendsto
      (fun n =>
        SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
          (σ n) (f n) / (Fintype.card (V n) : ℝ))
      atTop (nhds 0) := by
    apply SoficGroups.KunCompletedComponentMidrankVariation.normalized_permutationRealVariation_tendsto_zero_of_energy
      V ι σ f
    exact henergy
  have hnonnegative : ∀ n,
      0 ≤
        (∑ C ∈ (P n).parts,
          (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C (b n))) /
                (Fintype.card (V n) : ℝ) := by
    intro n
    apply div_nonneg _ (hN n).le
    apply Finset.sum_nonneg
    intro C hC
    apply mul_nonneg (Nat.cast_nonneg _)
    rw [← SoficGroups.ComponentMidrankVariance.componentVertexMidrank_finiteVariance_eq
      C (b n) ((P n).nonempty_of_mem_parts hC)]
    exact SoficGroups.CheegerPoincare.finiteVariance_nonneg _
  have hupper (n : ℕ) :
      (∑ C ∈ (P n).parts,
        (C.card : ℝ) *
          SoficGroups.midrankVariance
            (SoficGroups.componentRankMassList C (b n))) /
              (Fintype.card (V n) : ℝ) ≤
        (SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
          (σ n) (f n) / (Fintype.card (V n) : ℝ) +
          5 * ((∑ C ∈ (P n).parts,
            (SoficGroups.boundary (σ n) C : ℝ)) /
              (Fintype.card (V n) : ℝ))) / (2 * γ) := by
    have hfinite :=
      weighted_component_midrankVariance_additive_bound
        (P n) (σ n) (τ n) γ hγ.le (hτ n)
          (hexpand n) (b n)
    have hfinite' :=
      (div_le_div_iff_of_pos_right (hN n)).2 hfinite
    apply (le_div_iff₀ (mul_pos (by norm_num : (0 : ℝ) < 2) hγ)).2
    calc
      ((∑ C ∈ (P n).parts,
        (C.card : ℝ) *
          SoficGroups.midrankVariance
            (SoficGroups.componentRankMassList C (b n))) /
              (Fintype.card (V n) : ℝ)) * (2 * γ) =
          (2 * γ *
            (∑ C ∈ (P n).parts,
              (C.card : ℝ) *
                SoficGroups.midrankVariance
                  (SoficGroups.componentRankMassList C (b n)))) /
                    (Fintype.card (V n) : ℝ) := by ring
      _ ≤
          (SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
            (σ n) (f n) +
            5 * (∑ C ∈ (P n).parts,
              (SoficGroups.boundary (σ n) C : ℝ))) /
                (Fintype.card (V n) : ℝ) := hfinite'
      _ =
          SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
            (σ n) (f n) / (Fintype.card (V n) : ℝ) +
            5 * ((∑ C ∈ (P n).parts,
              (SoficGroups.boundary (σ n) C : ℝ)) /
                (Fintype.card (V n) : ℝ)) := by ring
  have hlimit : Tendsto
      (fun n =>
        (SoficGroups.KunCompletedComponentMidrankVariation.permutationRealVariation
          (σ n) (f n) / (Fintype.card (V n) : ℝ) +
          5 * ((∑ C ∈ (P n).parts,
            (SoficGroups.boundary (σ n) C : ℝ)) /
              (Fintype.card (V n) : ℝ))) / (2 * γ))
      atTop (nhds 0) := by
    have hsum := hvariation.add (hboundary.const_mul (5 : ℝ))
    have hscaled := hsum.mul_const ((2 * γ)⁻¹)
    simpa only [div_eq_mul_inv, zero_add, zero_mul, mul_zero] using hscaled
  exact squeeze_zero'
    (Eventually.of_forall hnonnegative)
    (Eventually.of_forall hupper)
    hlimit

theorem weighted_component_midrankVariance_tendsto_zero_of_source_half_expansion
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    (ι : Type*) [Fintype ι]
    (P : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (b : (n : ℕ) → V n → ℤ)
    (γ : ℝ) (hγ : 0 < γ)
    (hexpand : ∀ n C, C ∈ (P n).parts → ∀ E : Finset (V n),
      E ⊆ C → 2 * E.card ≤ C.card →
        γ * (E.card : ℝ) ≤ (SoficGroups.boundary (σ n) E : ℝ))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts,
          (SoficGroups.boundary (σ n) C : ℝ)) /
            (Fintype.card (V n) : ℝ))
      atTop (nhds 0))
    (henergy : Tendsto
      (fun n =>
        (∑ i : ι, ∑ x : V n,
          (SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
            (P n) (b n) (σ n i x) -
           SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
            (P n) (b n) x) ^ 2) /
              (Fintype.card (V n) : ℝ))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts,
          (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C (b n))) /
                (Fintype.card (V n) : ℝ))
      atTop (nhds 0) := by
  classical
  let τ : (n : ℕ) → (C : Finset (V n)) →
      ι → Equiv.Perm {x : V n // x ∈ C} :=
    fun n C i =>
      Classical.choose
        (SoficGroups.exists_completion_of_internal_permutation
          (σ n i) C)
  have hτ (n : ℕ) (C : Finset (V n)) (_hC : C ∈ (P n).parts)
      (i : ι) (x : V n) (hx : x ∈ C) (hy : σ n i x ∈ C) :
      ((τ n C i ⟨x, hx⟩ : {x : V n // x ∈ C}) : V n) =
        σ n i x := by
    exact Classical.choose_spec
      (SoficGroups.exists_completion_of_internal_permutation
        (σ n i) C) x hx hy
  exact weighted_component_midrankVariance_tendsto_zero_of_additive_expansion
    V ι P σ τ b γ hγ hτ hexpand hboundary henergy

end KunGlobalActualAdditiveMidrankVariance

namespace KunCommonRankArcInvariance

open Filter Topology
open scoped BigOperators

theorem exists_maximizing_partition_ranks
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (P : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (b : (n : ℕ) → V n → ℤ) :
    ∃ j : (n : ℕ) → Finset (V n) → ℤ,
      ∀ n C, C ∈ (P n).parts →
        j n C ∈ C.image (b n) ∧
          ∀ k ∈ C.image (b n),
            SoficGroups.componentRankMass C (b n) k ≤
              SoficGroups.componentRankMass C (b n) (j n C) := by
  classical
  let j : (n : ℕ) → Finset (V n) → ℤ := fun n C =>
    if h : C.Nonempty then
      (SoficGroups.exists_maximal_componentRankMass
        C (b n) h).choose
    else 0
  refine ⟨j, ?_⟩
  intro n C hC
  have hn : C.Nonempty := (P n).nonempty_of_mem_parts hC
  have h := (SoficGroups.exists_maximal_componentRankMass
    C (b n) hn).choose_spec
  simpa only [j, dif_pos hn] using h

theorem maximizing_partition_rank_omitted_density_tendsto_zero
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (P : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (b : (n : ℕ) → V n → ℤ)
    (j : (n : ℕ) → Finset (V n) → ℤ)
    (hmax : ∀ n C, C ∈ (P n).parts →
      ∀ k ∈ C.image (b n),
        SoficGroups.componentRankMass C (b n) k ≤
          SoficGroups.componentRankMass C (b n) (j n C))
    (hvariance : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts,
          (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C (b n))) /
                Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        ((((Finset.univ : Finset (V n)) \
          SoficGroups.RankArcCharging.selectedRankSupport
            (P n) (b n) (j n)).card : ℝ) /
              Fintype.card (V n)))
      atTop (nhds 0) := by
  classical
  have hupper : Tendsto
      (fun n =>
        (12 : ℝ) *
          ((∑ C ∈ (P n).parts,
            (C.card : ℝ) *
              SoficGroups.midrankVariance
                (SoficGroups.componentRankMassList C (b n))) /
                  Fintype.card (V n)))
      atTop (nhds 0) := by
    simpa only [mul_zero] using
      ((tendsto_const_nhds :
        Tendsto (fun _ : ℕ => (12 : ℝ)) atTop (nhds 12)).mul
          hvariance)
  refine squeeze_zero (fun n =>
    div_nonneg (Nat.cast_nonneg _) (Nat.cast_nonneg _)) ?_ hupper
  intro n
  have hfinite :=
    SoficGroups.actual_weighted_midrank_dominant_mass_le
      (P n).parts (fun C : Finset (V n) => C) (b n) (j n)
      (fun C hC => (P n).nonempty_of_mem_parts hC)
      (fun C hC => hmax n C hC)
  have hcard :=
    SoficGroups.RankArcCharging.card_sdiff_selectedRankSupport
      (P n) (b n) (j n)
  have hcast :
      ((((Finset.univ : Finset (V n)) \
        SoficGroups.RankArcCharging.selectedRankSupport
          (P n) (b n) (j n)).card : ℕ) : ℝ) =
        ∑ C ∈ (P n).parts,
          (((C.card -
            (C.filter fun x => b n x = j n C).card : ℕ) : ℝ)) := by
    exact_mod_cast hcard
  calc
    ((((Finset.univ : Finset (V n)) \
      SoficGroups.RankArcCharging.selectedRankSupport
        (P n) (b n) (j n)).card : ℝ) /
          Fintype.card (V n)) ≤
      (12 * (∑ C ∈ (P n).parts,
        (C.card : ℝ) *
          SoficGroups.midrankVariance
            (SoficGroups.componentRankMassList C (b n)))) /
              Fintype.card (V n) := by
      apply div_le_div_of_nonneg_right _ (Nat.cast_nonneg _)
      rw [hcast]
      exact hfinite
    _ = (12 : ℝ) *
        ((∑ C ∈ (P n).parts,
          (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C (b n))) /
                Fintype.card (V n)) := by
      ring

theorem rankChangingArc_density_tendsto_zero_of_selected_support
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    {κ : Type*}
    (P : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (b : (n : ℕ) → V n → ℤ)
    (j : (n : ℕ) → Finset (V n) → ℤ)
    (w : (n : ℕ) → κ → Equiv.Perm (V n))
    (homitted : Tendsto
      (fun n =>
        ((((Finset.univ : Finset (V n)) \
          SoficGroups.RankArcCharging.selectedRankSupport
            (P n) (b n) (j n)).card : ℝ) /
              Fintype.card (V n)))
      atTop (nhds 0))
    (hcross : ∀ i : κ, Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing
          (P n) (w n i)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0)) :
    ∀ i : κ, Tendsto
      (fun n =>
        ((SoficGroups.RankArcCharging.rankChangingArc
          (Finset.univ : Finset (V n))
          (b n) (w n i)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0) := by
  intro i
  exact SoficGroups.RankArcCharging.rankChangingArc_density_tendsto_zero
    V (fun n => (Finset.univ : Finset (V n)))
    P b j (fun n => w n i)
    (fun n => (Fintype.card (V n) : ℝ))
    (fun n => by
      exact_mod_cast Fintype.card_pos_iff.mpr inferInstance)
    (hcross i) homitted

theorem exists_common_rank_invariance_of_midrank_variance
    {V : ℕ → Type*}
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    {κ : Type*}
    (P : (n : ℕ) → Finpartition (Finset.univ : Finset (V n)))
    (b : (n : ℕ) → V n → ℤ)
    (w : (n : ℕ) → κ → Equiv.Perm (V n))
    (hvariance : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts,
          (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C (b n))) /
                Fintype.card (V n))
      atTop (nhds 0))
    (hcross : ∀ i : κ, Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing
          (P n) (w n i)).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0)) :
    ∃ j : (n : ℕ) → Finset (V n) → ℤ,
      (∀ n C, C ∈ (P n).parts →
        j n C ∈ C.image (b n) ∧
          ∀ k ∈ C.image (b n),
            SoficGroups.componentRankMass C (b n) k ≤
              SoficGroups.componentRankMass C (b n) (j n C)) ∧
      Tendsto
        (fun n =>
          ((((Finset.univ : Finset (V n)) \
            SoficGroups.RankArcCharging.selectedRankSupport
              (P n) (b n) (j n)).card : ℝ) /
                Fintype.card (V n)))
        atTop (nhds 0) ∧
      ∀ i : κ, Tendsto
        (fun n =>
          ((SoficGroups.RankArcCharging.rankChangingArc
            (Finset.univ : Finset (V n))
            (b n) (w n i)).card : ℝ) /
              Fintype.card (V n))
        atTop (nhds 0) := by
  obtain ⟨j, hj⟩ := exists_maximizing_partition_ranks P b
  have homitted :=
    maximizing_partition_rank_omitted_density_tendsto_zero
      P b j (fun n C hC => (hj n C hC).2) hvariance
  exact ⟨j, hj, homitted,
    rankChangingArc_density_tendsto_zero_of_selected_support
      P b j w homitted hcross⟩

theorem sofic_action_inverse_normalizedHamming_tendsto_zero
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G) (g : G) :
    Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          (((A.model n).action g)⁻¹)
          ((A.model n).action (g⁻¹)))
      atTop (nhds 0) := by
  have heq :
      (fun n =>
        SoficGroups.normalizedHamming
          (((A.model n).action g)⁻¹)
          ((A.model n).action (g⁻¹))) =
        (fun n =>
          SoficGroups.normalizedHamming
            ((A.model n).action (g * g⁻¹))
            ((A.model n).action g *
              (A.model n).action (g⁻¹))) := by
    funext n
    calc
      SoficGroups.normalizedHamming
          (((A.model n).action g)⁻¹)
          ((A.model n).action (g⁻¹)) =
        SoficGroups.normalizedHamming
          ((A.model n).action g *
            ((A.model n).action g)⁻¹)
          ((A.model n).action g *
            (A.model n).action (g⁻¹)) :=
        (SoficGroups.normalizedHamming_mul_left
          ((A.model n).action g)
          (((A.model n).action g)⁻¹)
          ((A.model n).action (g⁻¹))).symm
      _ = SoficGroups.normalizedHamming
          ((A.model n).action (g * g⁻¹))
          ((A.model n).action g *
            (A.model n).action (g⁻¹)) := by
        simp [(A.model n).map_one]
  rw [heq]
  exact A.multiplicative g (g⁻¹)

end KunCommonRankArcInvariance

namespace ChosenCayleyMatchedComponentRealization

open Filter Topology
open SoficGroups.KunActualSoficRootRadius
open SoficGroups.KunResidualRetainedSelection
open scoped BigOperators Pointwise symmDiff

def sourceFirstFactorApproximation
    {K J : Type*} [Group K] [Group J]
    (A : SoficGroups.SoficApproximation (K × J)) :
    SoficGroups.SoficApproximation K :=
  SoficGroups.pullbackSoficApproximation
    (MonoidHom.inl K J)
    (fun _ _ h => congrArg Prod.fst h)
    A

def sourceFirstFactorCayleyRadiusBad
    {K J : Type*} [Group K] [Group J] [DecidableEq K]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (n k : ℕ) : Finset (Fin (A.model n).size) :=
  chosenCayleyRadiusBad
    (sourceFirstFactorApproximation A)
    S (symmetricGeneratorWord S hsymmetric hgenerates) n k

theorem sourceFirstFactorCayleyRadiusBad_density_tendsto_zero
    {K J : Type*} [Group K] [Group J] [DecidableEq K]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (k : ℕ) :
    Tendsto
      (fun n =>
        ((sourceFirstFactorCayleyRadiusBad
          A S hsymmetric hgenerates n k).card : ℝ) /
            (A.model n).size)
      atTop (nhds 0) := by
  exact chosenCayleyRadiusBad_density_tendsto_zero
    (sourceFirstFactorApproximation A)
    S (symmetricGeneratorWord S hsymmetric hgenerates)
    (symmetricGeneratorWord_prod S hsymmetric hgenerates) k

theorem sourceFirstFactor_injective_ball
    {K J : Type*} [Group K] [Group J] [DecidableEq K]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (n k : ℕ)
    {x : Fin (A.model n).size}
    (hx : x ∉ sourceFirstFactorCayleyRadiusBad
      A S hsymmetric hgenerates n k) :
    Set.InjOn
      (fun g : K => (A.model n).action (g, 1) x)
      (↑(S ^ k) : Set K) := by
  exact chosenCayleyRadiusBad_injective_ball
    (sourceFirstFactorApproximation A)
    S (symmetricGeneratorWord S hsymmetric hgenerates)
    n k hx

end ChosenCayleyMatchedComponentRealization

namespace CanonicalProductRadiusBadMatchedCapture

open Filter Topology
open SoficGroups.KunActualSoficRootRadius
open SoficGroups.ChosenCayleyMatchedComponentRealization
open SoficGroups.MatchedComponentCompletion
open SoficGroups.MatchedComponentExitBudget
open scoped BigOperators Pointwise symmDiff

def sourceProductRadiusLabels
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (S : Finset K) (F : Finset J) (k : ℕ) :
    Finset (K × J) :=
  ((S ^ k).image fun a : K => (a, (1 : J))) ∪
    (((SoficGroups.CompressionCriterion.productTrackedTable F).image
      fun j : J => ((1 : K), j)) ∪
      (S.biUnion fun a =>
        (SoficGroups.CompressionCriterion.productTrackedTable F).image
          fun j : J => (a, j)))

theorem firstFactor_mem_sourceProductRadiusLabels
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (S : Finset K) (F : Finset J) (k : ℕ)
    {a : K} (ha : a ∈ S ^ k) :
    (a, (1 : J)) ∈ sourceProductRadiusLabels S F k := by
  apply Finset.mem_union_left
  exact Finset.mem_image.mpr ⟨a, ha, rfl⟩

theorem secondFactor_mem_sourceProductRadiusLabels
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (S : Finset K) (F : Finset J) (k : ℕ)
    {j : J}
    (hj : j ∈ SoficGroups.CompressionCriterion.productTrackedTable F) :
    ((1 : K), j) ∈ sourceProductRadiusLabels S F k := by
  apply Finset.mem_union_right
  apply Finset.mem_union_left
  exact Finset.mem_image.mpr ⟨j, hj, rfl⟩

theorem composite_mem_sourceProductRadiusLabels
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (S : Finset K) (F : Finset J) (k : ℕ)
    {a : K} (ha : a ∈ S)
    {j : J}
    (hj : j ∈ SoficGroups.CompressionCriterion.productTrackedTable F) :
    (a, j) ∈ sourceProductRadiusLabels S F k := by
  apply Finset.mem_union_right
  apply Finset.mem_union_right
  apply Finset.mem_biUnion.mpr
  exact ⟨a, ha, Finset.mem_image.mpr ⟨j, hj, rfl⟩⟩

theorem generator_mem_sourceProductRadiusLabels
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (S : Finset K) (F : Finset J) (k : ℕ)
    {a : K} (ha : a ∈ S) :
    (a, (1 : J)) ∈ sourceProductRadiusLabels S F k :=
  composite_mem_sourceProductRadiusLabels S F k ha
    (SoficGroups.CompressionCriterion.one_mem_productTrackedTable F)

def canonicalProductRadiusBad
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K)
    (hsymmetric : ∀ a ∈ S, a⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (F : Finset J) (n k : ℕ) :
    Finset (Fin (A.model n).size) :=
  sourceFirstFactorCayleyRadiusBad
    A S hsymmetric hgenerates n k ∪
      finiteRootBad (A.model n)
        (sourceProductRadiusLabels S F k)

theorem canonicalProductRadiusBad_density_tendsto_zero
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K)
    (hsymmetric : ∀ a ∈ S, a⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (F : Finset J) (k : ℕ) :
    Tendsto
      (fun n =>
        ((canonicalProductRadiusBad
          A S hsymmetric hgenerates F n k).card : ℝ) /
            (A.model n).size)
      atTop (nhds 0) := by
  have hfactor :=
    sourceFirstFactorCayleyRadiusBad_density_tendsto_zero
      A S hsymmetric hgenerates k
  have hproduct :=
    finiteRootBad_density_tendsto_zero
      A (sourceProductRadiusLabels S F k)
  have hsum : Tendsto
      (fun n =>
        ((sourceFirstFactorCayleyRadiusBad
          A S hsymmetric hgenerates n k).card : ℝ) /
            (A.model n).size +
        ((finiteRootBad (A.model n)
          (sourceProductRadiusLabels S F k)).card : ℝ) /
            (A.model n).size)
      atTop (nhds 0) := by
    simpa using hfactor.add hproduct
  refine squeeze_zero (fun n => by positivity) ?_ hsum
  intro n
  have hcard :
      ((canonicalProductRadiusBad
        A S hsymmetric hgenerates F n k).card : ℝ) ≤
        (sourceFirstFactorCayleyRadiusBad
          A S hsymmetric hgenerates n k).card +
        (finiteRootBad (A.model n)
          (sourceProductRadiusLabels S F k)).card := by
    exact_mod_cast Finset.card_union_le
      (sourceFirstFactorCayleyRadiusBad
        A S hsymmetric hgenerates n k)
      (finiteRootBad (A.model n)
        (sourceProductRadiusLabels S F k))
  calc
    ((canonicalProductRadiusBad
      A S hsymmetric hgenerates F n k).card : ℝ) /
        (A.model n).size ≤
      (((sourceFirstFactorCayleyRadiusBad
        A S hsymmetric hgenerates n k).card : ℝ) +
        ((finiteRootBad (A.model n)
          (sourceProductRadiusLabels S F k)).card : ℝ)) /
          (A.model n).size :=
        div_le_div_of_nonneg_right hcard (by positivity)
    _ = ((sourceFirstFactorCayleyRadiusBad
          A S hsymmetric hgenerates n k).card : ℝ) /
            (A.model n).size +
        ((finiteRootBad (A.model n)
          (sourceProductRadiusLabels S F k)).card : ℝ) /
            (A.model n).size := by
      rw [add_div]

theorem sourceWordTestBad_subset_finiteProductRootBad
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K) (F : Finset J) (n k : ℕ) :
    sourceWordTestBad
      (fun i : ↥S => (A.model n).action ((i : K), 1))
      (fun j : J => (A.model n).action (1, j))
      F ⊆
        finiteRootBad (A.model n)
          (sourceProductRadiusLabels S F k) := by
  classical
  intro x hx
  by_contra hxroot
  simp only [sourceWordTestBad, Finset.mem_union,
    Finset.mem_biUnion, Finset.mem_filter,
    Finset.mem_univ, true_and] at hx
  rcases hx with (hcomm | hmul) | hsep
  · obtain ⟨i, j, hj, hfailure⟩ := hcomm
    have hfirst :=
      finiteRootBad_multiplicative
        (A.model n) (sourceProductRadiusLabels S F k)
        (secondFactor_mem_sourceProductRadiusLabels
          S F k hj)
        (generator_mem_sourceProductRadiusLabels
          S F k i.property)
        hxroot
    have hsecond :=
      finiteRootBad_multiplicative
        (A.model n) (sourceProductRadiusLabels S F k)
        (generator_mem_sourceProductRadiusLabels
          S F k i.property)
        (secondFactor_mem_sourceProductRadiusLabels
          S F k hj)
        hxroot
    apply hfailure
    calc
      (A.model n).action (1, j)
          ((A.model n).action ((i : K), 1) x) =
        (A.model n).action ((1, j) * ((i : K), 1)) x := by
          simpa [Equiv.Perm.mul_apply] using hfirst.symm
      _ = (A.model n).action
          (((i : K), 1) * (1, j)) x := by simp
      _ = (A.model n).action ((i : K), 1)
          ((A.model n).action (1, j) x) := by
          simpa [Equiv.Perm.mul_apply] using hsecond
  · obtain ⟨j, hj, l, hl, hfailure⟩ := hmul
    have hjT :=
      SoficGroups.CompressionCriterion.mem_productTrackedTable hj
    have hlT :=
      SoficGroups.CompressionCriterion.mem_productTrackedTable hl
    have hproduct :=
      finiteRootBad_multiplicative
        (A.model n) (sourceProductRadiusLabels S F k)
        (secondFactor_mem_sourceProductRadiusLabels
          S F k hjT)
        (secondFactor_mem_sourceProductRadiusLabels
          S F k hlT)
        hxroot
    apply hfailure
    simpa [Equiv.Perm.mul_apply] using hproduct
  · obtain ⟨j, hj, l, hl, hne, heq⟩ := hsep
    have hjT :=
      SoficGroups.CompressionCriterion.mem_productTrackedTable hj
    have hlT :=
      SoficGroups.CompressionCriterion.mem_productTrackedTable hl
    have hne' : ((1 : K), j) ≠ ((1 : K), l) := by
      intro h
      exact hne (congrArg Prod.snd h)
    exact finiteRootBad_separated
      (A.model n) (sourceProductRadiusLabels S F k)
      (secondFactor_mem_sourceProductRadiusLabels S F k hjT)
      (secondFactor_mem_sourceProductRadiusLabels S F k hlT)
      hne' hxroot heq

theorem component_exit_mem_partitionWordCrossing
    {V : Type*} [DecidableEq V]
    {U : Finset V} (P : Finpartition U)
    (C : Finset V) (hC : C ∈ P.parts)
    (p : Equiv.Perm V) {x : V}
    (hx : x ∈ C) (hout : p x ∉ C) :
    x ∈ SoficGroups.partitionWordCrossing P p := by
  have hxU : x ∈ U := P.subset hC hx
  change x ∈ U.filter fun y => p y ∉ P.part y
  apply Finset.mem_filter.mpr
  refine ⟨hxU, ?_⟩
  rwa [P.part_eq_of_mem hC hx]

theorem sourceCompletionBad_subset_canonical_matchedRadiusBad
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K)
    (hsymmetric : ∀ a ∈ S, a⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (F : Finset J) (n k : ℕ)
    {U : Finset (Fin (A.model n).size)}
    (P : Finpartition U)
    (C : Finset (Fin (A.model n).size))
    (hC : C ∈ P.parts) :
    sourceCompletionBad
      (fun i : ↥S => (A.model n).action ((i : K), 1))
      (fun j : J => (A.model n).action (1, j))
      F C ⊆
      C ∩ SoficGroups.matchedRadiusBad
        P (sourceProductRadiusLabels S F k)
        ((A.model n).action)
        (canonicalProductRadiusBad
          A S hsymmetric hgenerates F n k) := by
  classical
  intro x hx
  have hxC : x ∈ C :=
    sourceCompletionBad_subset
      (fun i : ↥S => (A.model n).action ((i : K), 1))
      (fun j : J => (A.model n).action (1, j))
      F C hx
  refine Finset.mem_inter.mpr ⟨hxC, ?_⟩
  by_contra hnot
  have hnotbad :
      x ∉ canonicalProductRadiusBad
        A S hsymmetric hgenerates F n k := by
    intro hbad
    apply hnot
    exact Finset.mem_union_left _ hbad
  have hroot :
      x ∉ finiteRootBad (A.model n)
        (sourceProductRadiusLabels S F k) := by
    intro hbad
    exact hnotbad (Finset.mem_union_right _ hbad)
  have hnotcross :
      ∀ q ∈ sourceProductRadiusLabels S F k,
        x ∉ SoficGroups.partitionWordCrossing
          P ((A.model n).action q) := by
    intro q hq hcross
    apply hnot
    apply Finset.mem_union_right
    exact Finset.mem_biUnion.mpr ⟨q, hq, hcross⟩
  have hcovered :=
    sourceCompletionBad_subset_exit_union_wordBad
      (fun i : ↥S => (A.model n).action ((i : K), 1))
      (fun j : J => (A.model n).action (1, j))
      F C hx
  simp only [Finset.mem_union, Finset.mem_biUnion,
    Finset.mem_filter, Finset.mem_univ, true_and] at hcovered
  rcases hcovered with ((hgen | hfactor) | hcomposite) | hword
  · obtain ⟨i, hx', hout⟩ := hgen
    apply hnotcross
      ((i : K), 1)
      (generator_mem_sourceProductRadiusLabels
        S F k i.property)
    exact component_exit_mem_partitionWordCrossing
      P C hC _ hx' hout
  · obtain ⟨j, hj, hx', hout⟩ := hfactor
    apply hnotcross
      ((1 : K), j)
      (secondFactor_mem_sourceProductRadiusLabels S F k hj)
    exact component_exit_mem_partitionWordCrossing
      P C hC _ hx' hout
  · obtain ⟨i, j, hj, hx', hout⟩ := hcomposite
    have hpair :=
      finiteRootBad_multiplicative
        (A.model n) (sourceProductRadiusLabels S F k)
        (secondFactor_mem_sourceProductRadiusLabels S F k hj)
        (generator_mem_sourceProductRadiusLabels
          S F k i.property)
        hroot
    have hvalue :
        (A.model n).action ((i : K), j) x =
          (A.model n).action (1, j)
            ((A.model n).action ((i : K), 1) x) := by
      simpa [Equiv.Perm.mul_apply] using hpair
    apply hnotcross
      ((i : K), j)
      (composite_mem_sourceProductRadiusLabels
        S F k i.property hj)
    apply component_exit_mem_partitionWordCrossing
      P C hC _ hx'
    rw [hvalue]
    exact hout
  · apply hroot
    exact sourceWordTestBad_subset_finiteProductRootBad
      A S F n k hword

theorem canonical_source_matched_component_cayley_ball_realization
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K) (honeS : 1 ∈ S)
    (hsymmetric : ∀ a ∈ S, a⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (F : Finset J) (n k : ℕ)
    {U : Finset (Fin (A.model n).size)}
    (P : Finpartition U)
    (C : Finset (Fin (A.model n).size))
    (hC : C ∈ P.parts)
    (x : Fin (A.model n).size) (hx : x ∈ C)
    (hgood : x ∉
      SoficGroups.matchedRadiusBad
        P (sourceProductRadiusLabels S F k)
        ((A.model n).action)
        (canonicalProductRadiusBad
          A S hsymmetric hgenerates F n k)) :
    ∃ f : K → Fin (A.model n).size,
      Set.MapsTo f
        (↑(S ^ (k / 2)) : Set K)
        (↑C : Set (Fin (A.model n).size)) ∧
      Set.InjOn f (↑(S ^ (k / 2)) : Set K) := by
  have hxsource :
      x ∉ sourceFirstFactorCayleyRadiusBad
        A S hsymmetric hgenerates n k := by
    intro hbad
    apply hgood
    apply Finset.mem_union_left
    exact Finset.mem_union_left _ hbad
  have hroot :=
    sourceFirstFactor_injective_ball
      A S hsymmetric hgenerates n k hxsource
  refine ⟨fun a => (A.model n).action (a, 1) x, ?_, ?_⟩
  · intro a ha
    have hak : a ∈ S ^ k :=
      Finset.pow_subset_pow_right honeS
        (Nat.div_le_self k 2) ha
    have halabel :=
      firstFactor_mem_sourceProductRadiusLabels S F k hak
    have hnotcross :
        x ∉ SoficGroups.partitionWordCrossing
          P ((A.model n).action (a, 1)) := by
      intro hcross
      apply hgood
      apply Finset.mem_union_right
      exact Finset.mem_biUnion.mpr
        ⟨(a, 1), halabel, hcross⟩
    have himage : (A.model n).action (a, 1) x ∈ C := by
      by_contra hout
      apply hnotcross
      exact component_exit_mem_partitionWordCrossing
        P C hC _ hx hout
    exact himage
  · apply hroot.mono
    intro a ha
    exact Finset.pow_subset_pow_right honeS
      (Nat.div_le_self k 2) ha

end CanonicalProductRadiusBadMatchedCapture

namespace CompletedSelectedCentralizerPairwiseSource

open Filter Topology
open SoficGroups.MatchedComponentCompletion
open SoficGroups.MatchedFirstStageWordRadiusTransfer
open SoficGroups.CanonicalProductRadiusBadMatchedCapture
open scoped BigOperators Pointwise

theorem eventually_five_mul_sourceCompletionBad_le_of_density
    (V : ℕ → Type*) [∀ n, DecidableEq (V n)]
    {ι J : Type*} [Fintype ι] [Group J]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (p : (n : ℕ) → J → Equiv.Perm (V n))
    (F : Finset J)
    (Z : (n : ℕ) → Finset (V n))
    (hZ : ∀ n, (Z n).Nonempty)
    (hbad : Tendsto
      (fun n =>
        ((sourceCompletionBad
          (σ n) (p n) F (Z n)).card : ℝ) / (Z n).card)
      atTop (nhds 0)) :
    ∀ᶠ n in atTop,
      5 * (sourceCompletionBad
        (σ n) (p n) F (Z n)).card ≤ (Z n).card := by
  have hsmall : ∀ᶠ n in atTop,
      ((sourceCompletionBad
        (σ n) (p n) F (Z n)).card : ℝ) /
          (Z n).card < (1 / 5 : ℝ) :=
    hbad.eventually (gt_mem_nhds (by norm_num))
  filter_upwards [hsmall] with n hn
  have hpositive : (0 : ℝ) < (Z n).card := by
    exact_mod_cast (hZ n).card_pos
  have hreal := (div_lt_iff₀ hpositive).mp hn
  have hstrict :
      5 * (sourceCompletionBad
        (σ n) (p n) F (Z n)).card < (Z n).card := by
    exact_mod_cast (show
      (5 : ℝ) * (sourceCompletionBad
        (σ n) (p n) F (Z n)).card < (Z n).card by
          linarith)
  exact hstrict.le

theorem eventually_completed_sourceCentralizer_table_of_bad_density
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    {ι J : Type*} [Fintype ι] [Group J]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (p : (n : ℕ) → J → Equiv.Perm (V n))
    (F : Finset J)
    (Z : (n : ℕ) → Finset (V n))
    (hZ : ∀ n, (Z n).Nonempty)
    (hbad : Tendsto
      (fun n =>
        ((sourceCompletionBad
          (σ n) (p n) F (Z n)).card : ℝ) /
            (Z n).card)
      atTop (nhds 0))
    (σZ : (n : ℕ) → ι →
      Equiv.Perm {x : V n // x ∈ Z n})
    (hσZ : ∀ n i (x : V n) (hx : x ∈ Z n)
      (_hi : σ n i x ∈ Z n),
        ((σZ n i ⟨x, hx⟩ :
          {x : V n // x ∈ Z n}) : V n) = σ n i x)
    (t : ℕ → ℕ)
    (ht : ∀ n,
      2 * Fintype.card ι *
        (sourceCompletionBad
          (σ n) (p n) F (Z n)).card ≤ t n) :
    ∀ᶠ n in atTop,
      (∀ a ∈ F, ∀ b ∈ F,
        5 * SoficGroups.permutationDistance
          (completedRestriction (p n (a * b)) (Z n))
          (completedRestriction (p n a) (Z n) *
            completedRestriction (p n b) (Z n)) ≤
          Fintype.card {x : V n // x ∈ Z n}) ∧
      (∀ a ∈ F, ∀ b ∈ F, a ≠ b →
        Fintype.card {x : V n // x ∈ Z n} <
          5 * SoficGroups.permutationDistance
            (completedRestriction (p n a) (Z n))
            (completedRestriction (p n b) (Z n))) ∧
      (∀ a ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
        SoficGroups.permutationCommutationDefect
          (σZ n) (completedRestriction (p n a) (Z n)) ≤
            t n) := by
  have hevent :=
    eventually_five_mul_sourceCompletionBad_le_of_density
      V σ p F Z hZ hbad
  filter_upwards [hevent] with n hn
  refine ⟨?_, ?_, ?_⟩
  · intro a ha b hb
    have hdist :=
      completedRestriction_mul_distance_le_sourceCompletionBad
        (σ n) (p n) F (Z n) ha hb
    simpa only [Fintype.card_coe] using
      (Nat.mul_le_mul_left 5 hdist).trans hn
  · intro a ha b hb hab
    exact completedRestriction_separated_of_sourceCompletionBad
      (σ n) (p n) F (Z n) (hZ n) hn ha hb hab
  · intro a ha
    have hdef :=
      completedRestriction_commutationDefect_le_sourceCompletionBad
        (σ n) (p n) F (Z n)
        (σZ n) (hσZ n) ha
    have hscale :
        Fintype.card ι *
          (sourceCompletionBad
            (σ n) (p n) F (Z n)).card ≤ t n := by
      have hdegree : Fintype.card ι ≤ 2 * Fintype.card ι := by
        omega
      exact (Nat.mul_le_mul_right
        (sourceCompletionBad
          (σ n) (p n) F (Z n)).card hdegree).trans (ht n)
    exact hdef.trans hscale

end CompletedSelectedCentralizerPairwiseSource

namespace KunActualSelectedCentralizerFiniteModel

open Filter Topology

noncomputable def trackedCompletedAlmostCentralizer
    {V ι J : Type} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V)
    (p : J → Equiv.Perm V)
    (F : Finset J) (t : ℕ)
    (hdefect : ∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
      SoficGroups.permutationCommutationDefect σ (p j) ≤ t) :
    J → SoficGroups.AlmostCentralizerElement σ t := by
  classical
  intro j
  by_cases hj : j ∈ SoficGroups.CompressionCriterion.productTrackedTable F
  · exact ⟨p j, hdefect j hj⟩
  · exact ⟨1, by simp⟩

theorem trackedCompletedAlmostCentralizer_permutation_of_mem
    {V ι J : Type} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V)
    (p : J → Equiv.Perm V)
    (F : Finset J) (t : ℕ)
    (hdefect : ∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
      SoficGroups.permutationCommutationDefect σ (p j) ≤ t)
    {j : J}
    (hj : j ∈ SoficGroups.CompressionCriterion.productTrackedTable F) :
    (trackedCompletedAlmostCentralizer σ p F t hdefect j).permutation =
      p j := by
  classical
  simp [trackedCompletedAlmostCentralizer, hj]

theorem trackedCompletedAlmostCentralizer_map_one
    {V ι J : Type} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V)
    (p : J → Equiv.Perm V)
    (hp : p 1 = 1)
    (F : Finset J) (t : ℕ)
    (hdefect : ∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
      SoficGroups.permutationCommutationDefect σ (p j) ≤ t) :
    (trackedCompletedAlmostCentralizer σ p F t hdefect 1).permutation = 1 := by
  rw [trackedCompletedAlmostCentralizer_permutation_of_mem
    σ p F t hdefect
      (SoficGroups.CompressionCriterion.one_mem_productTrackedTable F), hp]

theorem trackedCompletedAlmostCentralizer_multiplicative
    {V ι J : Type} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V)
    (p : J → Equiv.Perm V)
    (F : Finset J) (t : ℕ)
    (hdefect : ∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
      SoficGroups.permutationCommutationDefect σ (p j) ≤ t)
    (hmul : ∀ x ∈ F, ∀ y ∈ F,
      5 * SoficGroups.permutationDistance
        (p (x * y)) (p x * p y) ≤ Fintype.card V) :
    ∀ x ∈ F, ∀ y ∈ F,
      5 * SoficGroups.permutationDistance
        (trackedCompletedAlmostCentralizer
          σ p F t hdefect (x * y)).permutation
        ((trackedCompletedAlmostCentralizer
          σ p F t hdefect x).permutation *
         (trackedCompletedAlmostCentralizer
          σ p F t hdefect y).permutation) ≤ Fintype.card V := by
  intro x hx y hy
  rw [trackedCompletedAlmostCentralizer_permutation_of_mem
    σ p F t hdefect
      (SoficGroups.CompressionCriterion.mul_mem_productTrackedTable hx hy),
    trackedCompletedAlmostCentralizer_permutation_of_mem
      σ p F t hdefect
        (SoficGroups.CompressionCriterion.mem_productTrackedTable hx),
    trackedCompletedAlmostCentralizer_permutation_of_mem
      σ p F t hdefect
        (SoficGroups.CompressionCriterion.mem_productTrackedTable hy)]
  exact hmul x hx y hy

theorem trackedCompletedAlmostCentralizer_separated
    {V ι J : Type} [Fintype V] [DecidableEq V]
    [Fintype ι] [Group J]
    (σ : ι → Equiv.Perm V)
    (p : J → Equiv.Perm V)
    (F : Finset J) (t : ℕ)
    (hdefect : ∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
      SoficGroups.permutationCommutationDefect σ (p j) ≤ t)
    (hsep : ∀ x ∈ F, ∀ y ∈ F, x ≠ y →
      Fintype.card V < 5 * SoficGroups.permutationDistance (p x) (p y)) :
    ∀ x ∈ F, ∀ y ∈ F, x ≠ y →
      Fintype.card V <
        5 * SoficGroups.permutationDistance
          (trackedCompletedAlmostCentralizer
            σ p F t hdefect x).permutation
          (trackedCompletedAlmostCentralizer
            σ p F t hdefect y).permutation := by
  intro x hx y hy hxy
  rw [trackedCompletedAlmostCentralizer_permutation_of_mem
    σ p F t hdefect
      (SoficGroups.CompressionCriterion.mem_productTrackedTable hx),
    trackedCompletedAlmostCentralizer_permutation_of_mem
      σ p F t hdefect
        (SoficGroups.CompressionCriterion.mem_productTrackedTable hy)]
  exact hsep x hx y hy hxy

theorem nonempty_expandingCentralizerFiniteModel_of_selected_completed_sequence
    {J : Type} [Group J] (F : Finset J)
    (V : ℕ → Type)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (ι : Type) [Fintype ι]
    (σ : (n : ℕ) → ι → Equiv.Perm (V n))
    (p : (n : ℕ) → J → Equiv.Perm (V n))
    (hp : ∀ n, p n 1 = 1)
    (t : ℕ → ℕ)
    (h : ℝ) (hpositive : 0 < h)
    (hdefect : ∀ᶠ n in atTop,
      ∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
        SoficGroups.permutationCommutationDefect
          (σ n) (p n j) ≤ t n)
    (hexp : ∀ᶠ n in atTop, ∀ E : Finset (V n),
      h * min (E.card : ℝ)
        ((Fintype.card (V n) : ℝ) - E.card) ≤
          (SoficGroups.boundary (σ n) E : ℝ))
    (hsmall : ∀ᶠ n in atTop,
      (10 : ℝ) * t n < h * Fintype.card (V n))
    (himprove : ∀ᶠ n in atTop,
      SoficGroups.HasAlmostCentralizerImprovement (σ n) (t n))
    (hmul : ∀ᶠ n in atTop, ∀ x ∈ F, ∀ y ∈ F,
      5 * SoficGroups.permutationDistance
        (p n (x * y)) (p n x * p n y) ≤ Fintype.card (V n))
    (hsep : ∀ᶠ n in atTop, ∀ x ∈ F, ∀ y ∈ F, x ≠ y →
      Fintype.card (V n) <
        5 * SoficGroups.permutationDistance (p n x) (p n y)) :
    Nonempty (SoficGroups.ExpandingCentralizerFiniteModel J F) := by
  have hgood := hdefect.and
    (hexp.and (hsmall.and (himprove.and (hmul.and hsep))))
  obtain ⟨n, hn⟩ := hgood.exists
  obtain ⟨hdefect_n, hexp_n, hsmall_n,
    himprove_n, hmul_n, hsep_n⟩ := hn
  let f := trackedCompletedAlmostCentralizer
    (σ n) (p n) F (t n) hdefect_n
  refine ⟨SoficGroups.expandingCentralizerFiniteModelOfImprovement
    F (σ n) (t n) h hpositive hexp_n hsmall_n himprove_n
      f ?_ ?_ ?_⟩
  · exact trackedCompletedAlmostCentralizer_map_one
      (σ n) (p n) (hp n) F (t n) hdefect_n
  · exact trackedCompletedAlmostCentralizer_multiplicative
      (σ n) (p n) F (t n) hdefect_n hmul_n
  · exact trackedCompletedAlmostCentralizer_separated
      (σ n) (p n) F (t n) hdefect_n hsep_n

end KunActualSelectedCentralizerFiniteModel

namespace SourceTopLevelCompression

open Filter

theorem sourceLocalPrefixTranspositionGroup_lef_of_source_finite_models
    (hmodels :
      ∀ A : SoficGroups.SoficApproximation
          (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode),
        Tendsto (fun n => (A.model n).size) atTop atTop →
          ∀ F : Finset
              (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
                  SoficGroups.ThompsonPrefixLocal.sourceLocalWord),
            Nonempty (SoficGroups.ExpandingCentralizerFiniteModel
              (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
                  SoficGroups.ThompsonPrefixLocal.sourceLocalWord) F))
    (hsource : SoficGroups.Sofic
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode)) :
    SoficGroups.LEF
      (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
        SoficGroups.ThompsonPrefixLocal.sourceLocalWord) := by
  letI : SoficGroups.Sofic
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) :=
    hsource
  letI : Countable
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) :=
    SoficGroups.ninePrefixElementaryGroup_countable
  obtain ⟨A, hA⟩ := SoficGroups.exists_soficApproximation_size_tendsto
    (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode)
  exact SoficGroups.lef_of_expanding_centralizer_models (hmodels A hA)

end SourceTopLevelCompression

namespace ThompsonFFiniteQuotient

variable {G : Type*} [Group G]

def conjugateTerm (a b : G) (n : ℕ) : G :=
  (a ^ n)⁻¹ * b * a ^ n

theorem conjugateTerm_succ (a b : G) (n : ℕ) :
    conjugateTerm a b (n + 1) =
      a⁻¹ * conjugateTerm a b n * a := by
  simp only [conjugateTerm, pow_succ, mul_inv_rev]
  group

theorem conjugation_shift (a u v w : G)
    (h : u⁻¹ * v * u = w) :
    (a⁻¹ * u * a)⁻¹ * (a⁻¹ * v * a) *
        (a⁻¹ * u * a) = a⁻¹ * w * a := by
  calc
    (a⁻¹ * u * a)⁻¹ * (a⁻¹ * v * a) *
        (a⁻¹ * u * a) = a⁻¹ * (u⁻¹ * v * u) * a := by
      group
    _ = a⁻¹ * w * a := by rw [h]

theorem conjugacy_relation_of_commute (a b : G) (n : ℕ)
    (h : Commute (a * b⁻¹) (conjugateTerm a b n)) :
    b⁻¹ * conjugateTerm a b n * b =
      conjugateTerm a b (n + 1) := by
  rw [conjugateTerm_succ]
  calc
    b⁻¹ * conjugateTerm a b n * b =
        a⁻¹ * ((a * b⁻¹) * conjugateTerm a b n) * b := by
      group
    _ = a⁻¹ * (conjugateTerm a b n * (a * b⁻¹)) * b := by
      rw [h.eq]
    _ = a⁻¹ * conjugateTerm a b n * a := by
      group

theorem conjugacy_relation_shift (a b u : G) (n : ℕ)
    (h : u⁻¹ * conjugateTerm a b n * u =
      conjugateTerm a b (n + 1)) :
    (a⁻¹ * u * a)⁻¹ * conjugateTerm a b (n + 1) *
        (a⁻¹ * u * a) = conjugateTerm a b (n + 2) := by
  rw [conjugateTerm_succ a b n,
    conjugateTerm_succ a b (n + 1)]
  exact conjugation_shift a u
    (conjugateTerm a b n) (conjugateTerm a b (n + 1)) h

theorem conjugacy_relation_step (a b : G) (n : ℕ)
    (hfirst : b⁻¹ * conjugateTerm a b 1 * b =
      conjugateTerm a b 2)
    (hprevious : b⁻¹ * conjugateTerm a b n * b =
      conjugateTerm a b (n + 1))
    (hcurrent : b⁻¹ * conjugateTerm a b (n + 1) * b =
      conjugateTerm a b (n + 2)) :
    b⁻¹ * conjugateTerm a b (n + 2) * b =
      conjugateTerm a b (n + 3) := by
  have hone : conjugateTerm a b 1 = a⁻¹ * b * a := by
    simp [conjugateTerm]
  have hshift :
      (conjugateTerm a b 1)⁻¹ *
          conjugateTerm a b (n + 1) *
          conjugateTerm a b 1 =
        conjugateTerm a b (n + 2) := by
    rw [hone]
    exact conjugacy_relation_shift a b b n hprevious
  have hdouble :
      (conjugateTerm a b 2)⁻¹ *
          conjugateTerm a b (n + 2) *
          conjugateTerm a b 2 =
        conjugateTerm a b (n + 3) := by
    rw [conjugateTerm_succ a b 1]
    exact conjugacy_relation_shift a b
      (conjugateTerm a b 1) (n + 1) hshift
  calc
    b⁻¹ * conjugateTerm a b (n + 2) * b =
        (b⁻¹ * conjugateTerm a b 1 * b)⁻¹ *
          (b⁻¹ * conjugateTerm a b (n + 1) * b) *
          (b⁻¹ * conjugateTerm a b 1 * b) := by
      rw [← hshift]
      group
    _ = (conjugateTerm a b 2)⁻¹ *
          conjugateTerm a b (n + 2) *
          conjugateTerm a b 2 := by
      rw [hfirst, hcurrent]
    _ = conjugateTerm a b (n + 3) := hdouble

theorem conjugacy_relation_all (a b : G)
    (hfirst : b⁻¹ * conjugateTerm a b 1 * b =
      conjugateTerm a b 2)
    (hsecond : b⁻¹ * conjugateTerm a b 2 * b =
      conjugateTerm a b 3) (n : ℕ) :
    b⁻¹ * conjugateTerm a b (n + 1) * b =
      conjugateTerm a b (n + 2) := by
  induction n using Nat.twoStepInduction with
  | zero => exact hfirst
  | one => exact hsecond
  | more n hprevious hcurrent =>
      simpa [Nat.add_assoc] using
        conjugacy_relation_step a b (n + 1)
          hfirst hprevious hcurrent

theorem finite_group_commute_of_thompsonF_two_relations
    {G : Type*} [Group G] [Finite G] (a b : G)
    (hfirst : Commute (a * b⁻¹) (a⁻¹ * b * a))
    (hsecond : Commute (a * b⁻¹) ((a ^ 2)⁻¹ * b * a ^ 2)) :
    Commute a b := by
  have hfirst' : b⁻¹ * conjugateTerm a b 1 * b =
      conjugateTerm a b 2 := by
    apply conjugacy_relation_of_commute a b 1
    simpa [conjugateTerm] using hfirst
  have hsecond' : b⁻¹ * conjugateTerm a b 2 * b =
      conjugateTerm a b 3 := by
    apply conjugacy_relation_of_commute a b 2
    simpa [conjugateTerm] using hsecond
  have hpositive : 0 < orderOf a := orderOf_pos a
  have hindex : orderOf a - 1 + 1 = orderOf a :=
    Nat.sub_add_cancel hpositive
  have hnext : orderOf a - 1 + 2 = orderOf a + 1 := by
    omega
  have hperiod : conjugateTerm a b (orderOf a) = b := by
    simp [conjugateTerm, pow_orderOf_eq_one]
  have hconjugate :
      conjugateTerm a b (orderOf a + 1) = a⁻¹ * b * a := by
    rw [conjugateTerm_succ, hperiod]
  have hrelation := conjugacy_relation_all a b hfirst' hsecond'
    (orderOf a - 1)
  rw [hindex, hnext, hperiod, hconjugate] at hrelation
  have heq : b = a⁻¹ * b * a := by
    simpa using hrelation
  change a * b = b * a
  calc
    a * b = a * (a⁻¹ * b * a) := congrArg (fun z : G => a * z) heq
    _ = b * a := by group

end ThompsonFFiniteQuotient

namespace ThompsonFTwoRelatorLEF

open scoped commutatorElement

def thompsonFRelator (n : ℕ) : FreeGroup (Fin 2) :=
  ⁅FreeGroup.of (0 : Fin 2) * (FreeGroup.of (1 : Fin 2))⁻¹,
    ((FreeGroup.of (0 : Fin 2)) ^ n)⁻¹ *
      FreeGroup.of (1 : Fin 2) * (FreeGroup.of (0 : Fin 2)) ^ n⁆

def thompsonFGeneratorCommutator : FreeGroup (Fin 2) :=
  ⁅FreeGroup.of (0 : Fin 2), FreeGroup.of (1 : Fin 2)⁆

theorem not_lef_of_thompsonF_two_relations
    {G : Type*} [Group G] (a b : G)
    (h₁ : Commute (a * b⁻¹) (a⁻¹ * b * a))
    (h₂ : Commute (a * b⁻¹) ((a ^ 2)⁻¹ * b * a ^ 2))
    (hne : ¬ Commute a b)
    (hfinite : ∀ (n : ℕ) (x y : Equiv.Perm (Fin n)),
      Commute (x * y⁻¹) (x⁻¹ * y * x) →
      Commute (x * y⁻¹) ((x ^ 2)⁻¹ * y * x ^ 2) →
      Commute x y) :
    ¬ SoficGroups.LEF G := by
  classical
  intro hlef
  let φ : FreeGroup (Fin 2) →* G := FreeGroup.lift ![a, b]
  let r₁ : FreeGroup (Fin 2) := thompsonFRelator 1
  let r₂ : FreeGroup (Fin 2) := thompsonFRelator 2
  let w : FreeGroup (Fin 2) := thompsonFGeneratorCommutator
  let tracked : Finset (FreeGroup (Fin 2)) := {r₁, r₂, w}
  let controls : FreeGroup (Fin 2) → Finset G :=
    fun q => Classical.choose (SoficGroups.exists_local_word_control φ q)
  have hcontrols (q : FreeGroup (Fin 2)) :
      ∀ (H : Type) [Group H] (f : G → H),
        SoficGroups.LocalMultiplicativeOn (controls q) f →
          FreeGroup.lift (fun i => f (φ (FreeGroup.of i))) q = f (φ q) :=
    Classical.choose_spec (SoficGroups.exists_local_word_control φ q)
  let support : Finset G :=
    insert 1 (insert (φ w) (tracked.biUnion controls))
  obtain ⟨n, f, hf_inj, hf_local⟩ := hlef.approximate support
  let ψ : FreeGroup (Fin 2) →* Equiv.Perm (Fin n) :=
    FreeGroup.lift (fun i => f (φ (FreeGroup.of i)))
  have hword (q : FreeGroup (Fin 2)) (hq : q ∈ tracked) :
      ψ q = f (φ q) := by
    apply hcontrols q (Equiv.Perm (Fin n)) f
    apply hf_local.mono
    intro z hz
    simp only [support, Finset.mem_insert, Finset.mem_biUnion]
    exact Or.inr (Or.inr ⟨q, hq, hz⟩)
  have hφ₁ : φ r₁ = 1 := by
    simpa [φ, r₁, thompsonFRelator] using h₁.commutator_eq
  have hφ₂ : φ r₂ = 1 := by
    simpa [φ, r₂, thompsonFRelator] using h₂.commutator_eq
  have hψ₁ : ψ r₁ = 1 := by
    calc
      ψ r₁ = f (φ r₁) := hword r₁ (by simp [tracked])
      _ = 1 := by rw [hφ₁, hf_local.map_one]
  have hψ₂ : ψ r₂ = 1 := by
    calc
      ψ r₂ = f (φ r₂) := hword r₂ (by simp [tracked])
      _ = 1 := by rw [hφ₂, hf_local.map_one]
  have hf₁ :
      Commute (f a * (f b)⁻¹) ((f a)⁻¹ * f b * f a) := by
    apply commutatorElement_eq_one_iff_commute.mp
    simpa [ψ, φ, r₁, thompsonFRelator] using hψ₁
  have hf₂ :
      Commute (f a * (f b)⁻¹)
        (((f a) ^ 2)⁻¹ * f b * (f a) ^ 2) := by
    apply commutatorElement_eq_one_iff_commute.mp
    simpa [ψ, φ, r₂, thompsonFRelator] using hψ₂
  have hψw : ψ w = 1 := by
    simpa [ψ, φ, w, thompsonFGeneratorCommutator] using
      (hfinite n (f a) (f b) hf₁ hf₂).commutator_eq
  have hφw : φ w ≠ 1 := by
    intro hz
    apply hne
    apply commutatorElement_eq_one_iff_commute.mp
    simpa [φ, w, thompsonFGeneratorCommutator] using hz
  apply hφw
  apply hf_inj
  · simp [support]
  · simp [support]
  calc
    f (φ w) = ψ w := (hword w (by simp [tracked])).symm
    _ = 1 := hψw
    _ = f 1 := hf_local.map_one.symm

end ThompsonFTwoRelatorLEF

namespace ThompsonFLocalWitness

open ThompsonPrefixInsertion

theorem prefixWordAction_inv {g : BinaryLeavittˣ}
    {a b : List (Fin 2)} (h : PrefixWordAction g a b) :
    PrefixWordAction g⁻¹ b a := by
  have hunit : (↑g⁻¹ : BinaryLeavitt) * (g : BinaryLeavitt) = 1 := by
    simp
  constructor
  · calc
      (↑g⁻¹ : BinaryLeavitt) * leavittWordS b =
          (↑g⁻¹ : BinaryLeavitt) *
            ((g : BinaryLeavitt) * leavittWordS a) := by
              rw [h.prefixing]
      _ = ((↑g⁻¹ : BinaryLeavitt) * (g : BinaryLeavitt)) *
          leavittWordS a := by rw [mul_assoc]
      _ = leavittWordS a := by rw [hunit, one_mul]
  · change leavittWordT b * (g : BinaryLeavitt) = leavittWordT a
    calc
      leavittWordT b * (g : BinaryLeavitt) =
          (leavittWordT a * (↑g⁻¹ : BinaryLeavitt)) *
            (g : BinaryLeavitt) := by rw [h.deletion]
      _ = leavittWordT a *
          ((↑g⁻¹ : BinaryLeavitt) * (g : BinaryLeavitt)) := by
            rw [mul_assoc]
      _ = leavittWordT a := by rw [hunit, mul_one]

theorem prefixWordAction_prefixInsertion {g : BinaryLeavittˣ}
    {a b : List (Fin 2)} (l : List (Fin 2))
    (h : PrefixWordAction g a b) :
    PrefixWordAction (prefixInsertionHom l g) (l ++ a) (l ++ b) := by
  have hl := leavittWordT_mul_wordS_self l
  have hl' (x : BinaryLeavitt) :
      leavittWordT l * (leavittWordS l * x) = x := by
    rw [← mul_assoc, hl, one_mul]
  constructor
  · rw [prefixInsertionHom_val, leavittWordS_append,
      leavittWordS_append]
    simp only [leavittCylinder]
    noncomm_ring [hl, hl', h.prefixing]
  · have hinv :
        (prefixInsertionHom l g)⁻¹ = prefixInsertionHom l g⁻¹ :=
      ((prefixInsertionHom l).map_inv g).symm
    rw [hinv, prefixInsertionHom_val, leavittWordT_append,
      leavittWordT_append]
    simp only [leavittCylinder]
    noncomm_ring [hl, hl', h.deletion]
    rw [← mul_assoc, h.deletion]

def rootRotation : BinaryLeavittˣ :=
  cylinderSwap [0] [1, 0] (by decide) (by decide) *
    cylinderSwap [0] [1, 1] (by decide) (by decide) *
    cylinderSwap [0] [1] (by decide) (by decide)

def rightRotation : BinaryLeavittˣ :=
  prefixInsertionHom [1] rootRotation

def generatorA : BinaryLeavittˣ := rootRotation⁻¹

def generatorB : BinaryLeavittˣ := rightRotation⁻¹

theorem rootRotation_action_zero_zero :
    PrefixWordAction rootRotation [0, 0] [0] := by
  unfold rootRotation
  rw [mul_assoc]
  refine prefixWordAction_mul (b := [1, 0]) ?_ ?_
  · exact ThompsonFiniteGeneration.cylinderSwap_prefixWordAction_of_cases
      (by decide) (by decide) (by decide)
  · refine prefixWordAction_mul (b := [1, 0]) ?_ ?_
    · exact ThompsonFiniteGeneration.cylinderSwap_prefixWordAction_of_cases
        (by decide) (by decide) (by decide)
    · exact ThompsonFiniteGeneration.cylinderSwap_prefixWordAction_of_cases
        (by decide) (by decide) (by decide)

theorem rootRotation_action_zero_one :
    PrefixWordAction rootRotation [0, 1] [1, 0] := by
  unfold rootRotation
  rw [mul_assoc]
  refine prefixWordAction_mul (b := [0]) ?_ ?_
  · exact ThompsonFiniteGeneration.cylinderSwap_prefixWordAction_of_cases
      (by decide) (by decide) (by decide)
  · refine prefixWordAction_mul (b := [1, 1]) ?_ ?_
    · exact ThompsonFiniteGeneration.cylinderSwap_prefixWordAction_of_cases
        (by decide) (by decide) (by decide)
    · exact ThompsonFiniteGeneration.cylinderSwap_prefixWordAction_of_cases
        (by decide) (by decide) (by decide)

theorem rootRotation_action_one :
    PrefixWordAction rootRotation [1] [1, 1] := by
  unfold rootRotation
  rw [mul_assoc]
  refine prefixWordAction_mul (b := [1, 1]) ?_ ?_
  · exact ThompsonFiniteGeneration.cylinderSwap_prefixWordAction_of_cases
      (by decide) (by decide) (by decide)
  · refine prefixWordAction_mul (b := [0]) ?_ ?_
    · exact ThompsonFiniteGeneration.cylinderSwap_prefixWordAction_of_cases
        (by decide) (by decide) (by decide)
    · exact ThompsonFiniteGeneration.cylinderSwap_prefixWordAction_of_cases
        (by decide) (by decide) (by decide)

theorem generatorB_eq_prefixInsertion :
    generatorB = prefixInsertionHom [1] generatorA := by
  change
    (prefixInsertionHom [1] rootRotation)⁻¹ =
      prefixInsertionHom [1] rootRotation⁻¹
  exact ((prefixInsertionHom [1]).map_inv rootRotation).symm

theorem generator_two_eq_prefixInsertion :
    generatorA⁻¹ * generatorB * generatorA =
      prefixInsertionHom [1, 1] generatorA := by
  calc
    generatorA⁻¹ * generatorB * generatorA =
        rootRotation * prefixInsertionHom [1] generatorA *
          rootRotation⁻¹ := by
            rw [generatorB_eq_prefixInsertion]
            simp [generatorA]
    _ = prefixInsertionHom [1, 1] generatorA :=
      prefixInsertionHom_conjugate_of_prefixWordAction
        rootRotation [1] [1, 1] rootRotation_action_one generatorA

theorem generator_three_eq_prefixInsertion :
    (generatorA ^ 2)⁻¹ * generatorB * generatorA ^ 2 =
      prefixInsertionHom [1, 1, 1] generatorA := by
  have hrotation :
      PrefixWordAction rootRotation [1, 1] [1, 1, 1] := by
    simpa using prefixWordAction_append rootRotation_action_one [1]
  calc
    (generatorA ^ 2)⁻¹ * generatorB * generatorA ^ 2 =
        rootRotation *
          (generatorA⁻¹ * generatorB * generatorA) *
          rootRotation⁻¹ := by
            simp [generatorA, pow_two, mul_assoc]
    _ = rootRotation * prefixInsertionHom [1, 1] generatorA *
          rootRotation⁻¹ := by rw [generator_two_eq_prefixInsertion]
    _ = prefixInsertionHom [1, 1, 1] generatorA :=
      prefixInsertionHom_conjugate_of_prefixWordAction
        rootRotation [1, 1] [1, 1, 1] hrotation generatorA

theorem generator_difference_action_one_one :
    PrefixWordAction (generatorA * generatorB⁻¹) [1, 1] [1, 1] := by
  have hrotation :
      PrefixWordAction rootRotation [1, 1] [1, 1, 1] := by
    simpa using prefixWordAction_append rootRotation_action_one [1]
  have hright :
      PrefixWordAction rightRotation [1, 1] [1, 1, 1] := by
    unfold rightRotation
    simpa using
      prefixWordAction_prefixInsertion [1] rootRotation_action_one
  change
    PrefixWordAction
      (rootRotation⁻¹ * (rightRotation⁻¹)⁻¹) [1, 1] [1, 1]
  simp only [inv_inv]
  exact prefixWordAction_mul (prefixWordAction_inv hrotation) hright

theorem commute_prefixInsertion_of_prefixWordAction_fixed
    (g : BinaryLeavittˣ) (w : List (Fin 2))
    (h : PrefixWordAction g w w) (u : BinaryLeavittˣ) :
    Commute g (prefixInsertionHom w u) := by
  have hconjugate :=
    prefixInsertionHom_conjugate_of_prefixWordAction g w w h u
  apply (commute_iff_eq _ _).2
  calc
    g * prefixInsertionHom w u =
        (g * prefixInsertionHom w u * g⁻¹) * g := by group
    _ = prefixInsertionHom w u * g := by rw [hconjugate]

theorem relator_one :
    Commute (generatorA * generatorB⁻¹)
      (generatorA⁻¹ * generatorB * generatorA) := by
  rw [generator_two_eq_prefixInsertion]
  exact commute_prefixInsertion_of_prefixWordAction_fixed
    (generatorA * generatorB⁻¹) [1, 1]
    generator_difference_action_one_one generatorA

theorem relator_two :
    Commute (generatorA * generatorB⁻¹)
      ((generatorA ^ 2)⁻¹ * generatorB * generatorA ^ 2) := by
  rw [generator_three_eq_prefixInsertion]
  apply commute_prefixInsertion_of_prefixWordAction_fixed
    (generatorA * generatorB⁻¹) [1, 1, 1] _ generatorA
  simpa using
    prefixWordAction_append generator_difference_action_one_one [1]

theorem cylinderSwap_mem_binaryPrefixTranspositionGroup
    (a b : List (Fin 2))
    (hab : ¬ a <+: b) (hba : ¬ b <+: a) :
    cylinderSwap a b hab hba ∈ binaryPrefixTranspositionGroup :=
  Subgroup.subset_closure ⟨a, b, hab, hba, rfl⟩

theorem rootRotation_mem_binaryPrefixTranspositionGroup :
    rootRotation ∈ binaryPrefixTranspositionGroup := by
  unfold rootRotation
  exact binaryPrefixTranspositionGroup.mul_mem
    (binaryPrefixTranspositionGroup.mul_mem
      (cylinderSwap_mem_binaryPrefixTranspositionGroup
        [0] [1, 0] (by decide) (by decide))
      (cylinderSwap_mem_binaryPrefixTranspositionGroup
        [0] [1, 1] (by decide) (by decide)))
    (cylinderSwap_mem_binaryPrefixTranspositionGroup
      [0] [1] (by decide) (by decide))

theorem generatorA_mem_binaryPrefixTranspositionGroup :
    generatorA ∈ binaryPrefixTranspositionGroup :=
  binaryPrefixTranspositionGroup.inv_mem
    rootRotation_mem_binaryPrefixTranspositionGroup

theorem generatorB_mem_binaryPrefixTranspositionGroup :
    generatorB ∈ binaryPrefixTranspositionGroup := by
  rw [generatorB_eq_prefixInsertion]
  exact prefixInsertionHom_mem_binaryPrefixTranspositionGroup
    [1] generatorA generatorA_mem_binaryPrefixTranspositionGroup

theorem generators_not_commute : ¬ Commute generatorA generatorB := by
  have ha_zero_one :
      PrefixWordAction generatorA [1, 0] [0, 1] :=
    prefixWordAction_inv rootRotation_action_zero_one
  have ha_one :
      PrefixWordAction generatorA [1, 1] [1] :=
    prefixWordAction_inv rootRotation_action_one
  have hb_one_one_zero :
      PrefixWordAction generatorB [1, 1, 0] [1, 0, 1] := by
    change
      PrefixWordAction rightRotation⁻¹ [1, 1, 0] [1, 0, 1]
    apply prefixWordAction_inv
    unfold rightRotation
    simpa using
      prefixWordAction_prefixInsertion [1]
        rootRotation_action_zero_one
  have hb_one_zero :
      PrefixWordAction generatorB [1, 0] [1, 0, 0] := by
    change PrefixWordAction rightRotation⁻¹ [1, 0] [1, 0, 0]
    apply prefixWordAction_inv
    unfold rightRotation
    simpa using
      prefixWordAction_prefixInsertion [1]
        rootRotation_action_zero_zero
  have hab :
      PrefixWordAction (generatorA * generatorB)
        [1, 1, 0] [0, 1, 1] :=
    prefixWordAction_mul
      (by simpa using prefixWordAction_append ha_zero_one [1])
      hb_one_one_zero
  have hba :
      PrefixWordAction (generatorB * generatorA)
        [1, 1, 0] [1, 0, 0] :=
    prefixWordAction_mul hb_one_zero
      (by simpa using prefixWordAction_append ha_one [0])
  intro hcommute
  have hwords :
      leavittWordS [0, 1, 1] = leavittWordS [1, 0, 0] := by
    calc
      leavittWordS [0, 1, 1] =
          (↑(generatorA * generatorB) : BinaryLeavitt) *
            leavittWordS [1, 1, 0] := hab.prefixing.symm
      _ = (↑(generatorB * generatorA) : BinaryLeavitt) *
            leavittWordS [1, 1, 0] := by rw [hcommute.eq]
      _ = leavittWordS [1, 0, 0] := hba.prefixing
  apply (one_ne_zero : (1 : BinaryLeavitt) ≠ 0)
  calc
    (1 : BinaryLeavitt) =
        leavittWordT [0, 1, 1] * leavittWordS [0, 1, 1] :=
      (leavittWordT_mul_wordS_self [0, 1, 1]).symm
    _ = leavittWordT [0, 1, 1] * leavittWordS [1, 0, 0] := by
      rw [hwords]
    _ = 0 := leavittWordT_mul_wordS_of_incomparable
      [0, 1, 1] [1, 0, 0] (by decide) (by decide)

def sourceGeneratorA :
    localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord :=
  ⟨prefixInsertionHom ThompsonPrefixLocal.sourceLocalWord generatorA,
    ⟨generatorA, generatorA_mem_binaryPrefixTranspositionGroup, rfl⟩⟩

def sourceGeneratorB :
    localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord :=
  ⟨prefixInsertionHom ThompsonPrefixLocal.sourceLocalWord generatorB,
    ⟨generatorB, generatorB_mem_binaryPrefixTranspositionGroup, rfl⟩⟩

theorem source_relator_one :
    Commute (sourceGeneratorA * sourceGeneratorB⁻¹)
      (sourceGeneratorA⁻¹ * sourceGeneratorB * sourceGeneratorA) := by
  apply (commute_iff_eq _ _).2
  apply Subtype.ext
  simpa only [sourceGeneratorA, sourceGeneratorB,
    Subgroup.coe_mul, Subgroup.coe_inv, map_mul, map_inv] using
    (relator_one.map
      (prefixInsertionHom ThompsonPrefixLocal.sourceLocalWord)).eq

theorem source_relator_two :
    Commute (sourceGeneratorA * sourceGeneratorB⁻¹)
      ((sourceGeneratorA ^ 2)⁻¹ * sourceGeneratorB *
        sourceGeneratorA ^ 2) := by
  apply (commute_iff_eq _ _).2
  apply Subtype.ext
  simpa only [sourceGeneratorA, sourceGeneratorB,
    Subgroup.coe_mul, Subgroup.coe_inv, Subgroup.coe_pow,
    map_mul, map_inv, map_pow] using
    (relator_two.map
      (prefixInsertionHom ThompsonPrefixLocal.sourceLocalWord)).eq

theorem source_generators_not_commute :
    ¬ Commute sourceGeneratorA sourceGeneratorB := by
  intro hcommute
  apply generators_not_commute
  apply Commute.of_map
    (prefixInsertionHom_injective ThompsonPrefixLocal.sourceLocalWord)
  apply (commute_iff_eq _ _).2
  have heq := congrArg
    (fun x :
      localPrefixTranspositionGroup ThompsonPrefixLocal.sourceLocalWord =>
      (x : BinaryLeavittˣ)) hcommute.eq
  simpa only [sourceGeneratorA, sourceGeneratorB, Subgroup.coe_mul]
    using heq

end ThompsonFLocalWitness

section

theorem sourceLocalPrefixTranspositionGroup_notLEF :
    ¬ LEF
      (ThompsonPrefixInsertion.localPrefixTranspositionGroup
        ThompsonPrefixLocal.sourceLocalWord) := by
  apply ThompsonFTwoRelatorLEF.not_lef_of_thompsonF_two_relations
    ThompsonFLocalWitness.sourceGeneratorA
    ThompsonFLocalWitness.sourceGeneratorB
    ThompsonFLocalWitness.source_relator_one
    ThompsonFLocalWitness.source_relator_two
    ThompsonFLocalWitness.source_generators_not_commute
  intro n x y hfirst hsecond
  exact ThompsonFFiniteQuotient.finite_group_commute_of_thompsonF_two_relations
    x y hfirst hsecond

end

namespace KunUnconditionalActualSourceDecomposition

open Filter Topology
open SoficGroups.KunSourceUnconditionalFullDecomposition
open SoficGroups.KunExactActualSourceAmbientGenerators
open SoficGroups.KunUnconditionalActualSourceGeneratorData

theorem exists_unconditional_actual_source_dual_finpartition_sequences
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup
        SoficGroups.ninePrefixCode)) :
    ∃ (SΓ : Finset
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode))
      (SG : Finset
          (SoficGroups.prefixElementaryGroup
            SoficGroups.ninePrefixCode))
      (QΓ QG : (n : ℕ) →
        Finpartition
          (Finset.univ : Finset (Fin (A.model n).size)))
      (γΓ γG : ℝ),
      SG = sourceAmbientSymmetricGenerators SΓ ∧
      1 ∈ SΓ ∧
      (∀ g ∈ SΓ, g⁻¹ ∈ SΓ) ∧
      Subgroup.closure
        (SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode)) = ⊤ ∧
      1 ∈ SG ∧
      (∀ g ∈ SG, g⁻¹ ∈ SG) ∧
      Subgroup.closure
        (SG : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.ninePrefixCode)) = ⊤ ∧
      Function.Injective sourceAlphaInclusion ∧
      Subgroup.closure
        (Set.range (sourcePositiveGeneratorMap SΓ)) = ⊤ ∧
      0 < γΓ ∧
      0 < γG ∧
      (∀ n, ∀ C ∈ (QΓ n).parts,
        ∀ E : Finset (Fin (A.model n).size),
          E ⊆ C →
          2 * E.card ≤ C.card →
          γΓ * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action
                  (sourceAlphaInclusion (i :
                    SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaPrefixCode))) E : ℝ)) ∧
      (∀ n, ∀ C ∈ (QG n).parts,
        ∀ E : Finset (Fin (A.model n).size),
          E ⊆ C →
          2 * E.card ≤ C.card →
          γG * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥SG =>
                (A.model n).action (i :
                  SoficGroups.prefixElementaryGroup
                    SoficGroups.ninePrefixCode)) E : ℝ)) ∧
      Tendsto
        (fun n =>
          (∑ C ∈ (QΓ n).parts,
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action
                  (sourceAlphaInclusion (i :
                    SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaPrefixCode))) C : ℝ)) /
                (A.model n).size)
        atTop (𝓝 0) ∧
      Tendsto
        (fun n =>
          (∑ C ∈ (QG n).parts,
            (SoficGroups.boundary
              (fun i : ↥SG =>
                (A.model n).action (i :
                  SoficGroups.prefixElementaryGroup
                    SoficGroups.ninePrefixCode)) C : ℝ)) /
                (A.model n).size)
        atTop (𝓝 0) := by
  classical
  obtain ⟨SΓ, PΓ, PG, honeΓ, hsymmetricΓ, hgeneratesΓ,
    hPΓ, honeG, hsymmetricG, hgeneratesG, hPG,
    hfaithful, hpositive⟩ :=
      exists_unconditional_actual_source_generator_data
  let SG := sourceAmbientSymmetricGenerators SΓ
  have hcoverΓ : PΓ.generators ⊆ SΓ := by
    rw [hPΓ]
  have hcoverG : PG.generators ⊆ SG := by
    dsimp [SG]
    rw [hPG]
  obtain ⟨γΓ, γG, QΓ, QG, hγΓ, hγG, hexpΓ,
    hexpG, hboundaryΓ, hboundaryG⟩ :=
      exists_source_subgroup_and_ambient_full_finpartition_sequences
        A sourceAlphaInclusion hfaithful
        PΓ PG SΓ SG honeΓ honeG hcoverΓ hcoverG
        hsymmetricΓ hsymmetricG hgeneratesΓ hgeneratesG
  exact ⟨SΓ, SG, QΓ, QG, γΓ, γG, rfl,
    honeΓ, hsymmetricΓ, hgeneratesΓ,
    honeG, hsymmetricG, hgeneratesG, hfaithful,
    hpositive, hγΓ, hγG, hexpΓ, hexpG,
    hboundaryΓ, hboundaryG⟩

end KunUnconditionalActualSourceDecomposition

namespace KunCombinedPrescribedRootSourceTolerance

open Filter Topology

theorem eventually_scaled_tolerance_lt
    (N t : ℕ → ℕ)
    (hN : ∀ n, 0 < N n)
    (ht : Tendsto (fun n => (t n : ℝ) / (N n : ℝ)) atTop (𝓝 0))
    (c ell : ℝ) (hc : 0 < c) (hell : 0 < ell) :
    ∀ᶠ n in atTop, c * (t n : ℝ) < ell * (N n : ℝ) := by
  have hthreshold : 0 < ell / c := div_pos hell hc
  filter_upwards [ht.eventually (gt_mem_nhds hthreshold)] with n hn
  have hNreal : (0 : ℝ) < N n := by
    exact_mod_cast hN n
  have hratio : (t n : ℝ) < (ell / c) * (N n : ℝ) :=
    (div_lt_iff₀ hNreal).mp hn
  calc
    c * (t n : ℝ) < c * ((ell / c) * (N n : ℝ)) :=
      mul_lt_mul_of_pos_left hratio hc
    _ = ell * (N n : ℝ) := by
      field_simp

theorem exists_prescribed_radius_union_source_completed_tolerance
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, DecidableEq (V n)]
    (hVpositive : ∀ n, 0 < Fintype.card (V n))
    (hV : Tendsto (fun n => Fintype.card (V n)) atTop atTop)
    (root : (n : ℕ) → ℕ → Finset (V n))
    (source : (n : ℕ) → Finset (V n))
    (hroot : ∀ r : ℕ,
      Tendsto
        (fun n => ((root n r).card : ℝ) / Fintype.card (V n))
        atTop (𝓝 0))
    (hsource : Tendsto
      (fun n => ((source n).card : ℝ) / Fintype.card (V n))
      atTop (𝓝 0))
    (δ : ℕ → ℝ)
    (hδpositive : ∀ j, 0 < δ j)
    (hδ : Tendsto δ atTop (𝓝 0))
    (R : ℕ → ℕ) (hR : ∀ j, j ≤ R j)
    (d : ℕ) (hd : 0 < d)
    (ell q : ℝ) (hell : 0 < ell) (hq : q < 1) :
    ∃ m rootError t : ℕ → ℕ,
      Tendsto m atTop atTop ∧
      Tendsto (fun n => R (m n)) atTop atTop ∧
      Tendsto (fun n => δ (m n)) atTop (𝓝 0) ∧
      Tendsto
        (fun n =>
          (((root n (R (m n)) ∪ source n).card : ℝ) /
            (δ (m n) * (Fintype.card (V n) : ℝ))))
        atTop (𝓝 0) ∧
      (∀ n,
        rootError n =
          Nat.ceil (δ (m n) * (Fintype.card (V n) : ℝ))) ∧
      (∀ n,
        δ (m n) ≤
          (rootError n : ℝ) / (Fintype.card (V n) : ℝ)) ∧
      Tendsto
        (fun n =>
          (rootError n : ℝ) / (Fintype.card (V n) : ℝ))
        atTop (𝓝 0) ∧
      (∀ n,
        t n =
          2 * d * (root n (R (m n)) ∪ source n).card +
            rootError n + 1) ∧
      (∀ n, 0 < t n) ∧
      (∀ n,
        2 * d * (root n (R (m n))).card ≤ t n) ∧
      (∀ n,
        2 * d * (source n).card ≤ t n) ∧
      (∀ n, rootError n ≤ t n) ∧
      Tendsto
        (fun n =>
          (t n : ℝ) / (Fintype.card (V n) : ℝ))
        atTop (𝓝 0) ∧
      (∀ n,
        ell * δ (m n) / (2 * (ell + 8 * (d : ℝ))) ≤
          ell * (t n : ℝ) /
            (2 * (ell + 8 * (d : ℝ)) *
              (Fintype.card (V n) : ℝ))) ∧
      (∀ᶠ n in atTop,
        (10 : ℝ) * (t n : ℝ) <
          ell * (Fintype.card (V n) : ℝ)) ∧
      (∀ᶠ n in atTop,
        (5 : ℝ) *
            (4 + ell *
              (216 / ((d : ℝ) * (1 - q) ^ 2) +
                1 / (d : ℝ))) * (t n : ℝ) ≤
          ell * (Fintype.card (V n) : ℝ)) := by
  classical
  let N : ℕ → ℕ := fun n => Fintype.card (V n)
  let B : (n : ℕ) → ℕ → Finset (V n) :=
    fun n j => root n (R j) ∪ source n
  have hNpositive (n : ℕ) : (0 : ℝ) < N n := by
    exact_mod_cast hVpositive n
  have hunion (j : ℕ) :
      Tendsto
        (fun n => ((B n j).card : ℝ) / (N n : ℝ))
        atTop (𝓝 0) := by
    have hsum : Tendsto
        (fun n =>
          ((root n (R j)).card : ℝ) / Fintype.card (V n) +
            ((source n).card : ℝ) / Fintype.card (V n))
        atTop (𝓝 0) := by
      simpa only [zero_add] using (hroot (R j)).add hsource
    refine squeeze_zero (fun n => by positivity) ?_ hsum
    intro n
    have hcard :
        ((B n j).card : ℝ) ≤
          ((root n (R j)).card : ℝ) +
            ((source n).card : ℝ) := by
      exact_mod_cast Finset.card_union_le (root n (R j)) (source n)
    calc
      ((B n j).card : ℝ) / (N n : ℝ) ≤
          (((root n (R j)).card : ℝ) +
            ((source n).card : ℝ)) / (N n : ℝ) :=
        div_le_div_of_nonneg_right hcard (hNpositive n).le
      _ = ((root n (R j)).card : ℝ) / Fintype.card (V n) +
            ((source n).card : ℝ) / Fintype.card (V n) := by
        dsimp [N]
        ring
  let e : ℕ → ℕ → ℝ := fun n j =>
    (((B n j).card : ℝ) / (N n : ℝ)) / δ j
  have hepositive (n j : ℕ) : 0 ≤ e n j := by
    dsimp [e]
    exact div_nonneg
      (div_nonneg (Nat.cast_nonneg _) (hNpositive n).le)
      (hδpositive j).le
  have hevanishes (j : ℕ) :
      Tendsto (fun n => e n j) atTop (𝓝 0) := by
    simpa [e] using (hunion j).div_const (δ j)
  obtain ⟨m, hm, herror⟩ :=
    SoficGroups.exists_diverging_radius_with_vanishing_diagonal_error
      e hepositive hevanishes
  have hδm : Tendsto (fun n => δ (m n)) atTop (𝓝 0) :=
    hδ.comp hm
  have hRm : Tendsto (fun n => R (m n)) atTop atTop :=
    tendsto_atTop_mono (fun n => hR (m n)) hm
  have hrelative : Tendsto
      (fun n =>
        ((B n (m n)).card : ℝ) /
          (δ (m n) * (N n : ℝ)))
      atTop (𝓝 0) := by
    convert herror using 1
    funext n
    dsimp [e]
    ring
  have hbadselected : Tendsto
      (fun n => ((B n (m n)).card : ℝ) / (N n : ℝ))
      atTop (𝓝 0) := by
    have hp := hrelative.mul hδm
    convert hp using 1
    · funext n
      have hne : δ (m n) ≠ 0 := (hδpositive (m n)).ne'
      field_simp
    · norm_num
  have honeover : Tendsto
      (fun n => (1 : ℝ) / (N n : ℝ))
      atTop (𝓝 0) :=
    (tendsto_one_div_atTop_nhds_zero_nat (𝕜 := ℝ)).comp hV
  let rootError : ℕ → ℕ :=
    fun n => Nat.ceil (δ (m n) * (N n : ℝ))
  have hrootlower (n : ℕ) :
      δ (m n) ≤ (rootError n : ℝ) / (N n : ℝ) := by
    apply (le_div_iff₀ (hNpositive n)).2
    exact Nat.le_ceil _
  have hrootupper (n : ℕ) :
      (rootError n : ℝ) / (N n : ℝ) ≤
        δ (m n) + 1 / (N n : ℝ) := by
    apply (div_le_iff₀ (hNpositive n)).2
    have hceil :=
      (Nat.ceil_lt_add_one
        (mul_nonneg (hδpositive (m n)).le
          (hNpositive n).le)).le
    have hone : (1 / (N n : ℝ)) * (N n : ℝ) = 1 := by
      field_simp [ne_of_gt (hNpositive n)]
    change (rootError n : ℝ) ≤ _
    dsimp [rootError] at hceil ⊢
    nlinarith
  have hrootlimit : Tendsto
      (fun n => (rootError n : ℝ) / (N n : ℝ))
      atTop (𝓝 0) := by
    have hupper : Tendsto
        (fun n => δ (m n) + 1 / (N n : ℝ))
        atTop (𝓝 0) := by
      simpa using hδm.add honeover
    exact squeeze_zero (fun n => by positivity) hrootupper hupper
  let t : ℕ → ℕ :=
    fun n => 2 * d * (B n (m n)).card + rootError n + 1
  have htpositive (n : ℕ) : 0 < t n := by
    dsimp [t]
    omega
  have hrootbudget (n : ℕ) :
      2 * d * (root n (R (m n))).card ≤ t n := by
    have hsub :
        root n (R (m n)) ⊆ B n (m n) := by
      dsimp [B]
      exact Finset.subset_union_left
    have hcard := Finset.card_le_card hsub
    have hmul :
        2 * d * (root n (R (m n))).card ≤
          2 * d * (B n (m n)).card :=
      Nat.mul_le_mul_left (2 * d) hcard
    dsimp [t]
    omega
  have hsourcebudget (n : ℕ) :
      2 * d * (source n).card ≤ t n := by
    have hsub : source n ⊆ B n (m n) := by
      dsimp [B]
      exact Finset.subset_union_right
    have hcard := Finset.card_le_card hsub
    have hmul :
        2 * d * (source n).card ≤
          2 * d * (B n (m n)).card :=
      Nat.mul_le_mul_left (2 * d) hcard
    dsimp [t]
    omega
  have hrooterrorbudget (n : ℕ) : rootError n ≤ t n := by
    dsimp [t]
    omega
  have htzero : Tendsto
      (fun n => (t n : ℝ) / (N n : ℝ))
      atTop (𝓝 0) := by
    have hscaled : Tendsto
        (fun n =>
          ((2 * d : ℕ) : ℝ) *
            (((B n (m n)).card : ℝ) / (N n : ℝ)))
        atTop (𝓝 0) := by
      simpa using hbadselected.const_mul ((2 * d : ℕ) : ℝ)
    have hsum := (hscaled.add hrootlimit).add honeover
    convert hsum using 1
    · funext n
      dsimp [t]
      push_cast
      ring
    · norm_num
  have hdreal : (0 : ℝ) < d := by
    exact_mod_cast hd
  have hden : 0 < (2 : ℝ) * (ell + 8 * (d : ℝ)) := by
    positivity
  have htarget (n : ℕ) :
      ell * δ (m n) / (2 * (ell + 8 * (d : ℝ))) ≤
        ell * (t n : ℝ) /
          (2 * (ell + 8 * (d : ℝ)) * (N n : ℝ)) := by
    have hratio : δ (m n) ≤ (t n : ℝ) / (N n : ℝ) := by
      calc
        δ (m n) ≤ (rootError n : ℝ) / (N n : ℝ) :=
          hrootlower n
        _ ≤ (t n : ℝ) / (N n : ℝ) := by
          apply div_le_div_of_nonneg_right
            (by exact_mod_cast hrooterrorbudget n)
            (hNpositive n).le
    calc
      ell * δ (m n) / (2 * (ell + 8 * (d : ℝ))) ≤
          ell * ((t n : ℝ) / (N n : ℝ)) /
            (2 * (ell + 8 * (d : ℝ))) := by
        apply div_le_div_of_nonneg_right
          (mul_le_mul_of_nonneg_left hratio hell.le) hden.le
      _ = ell * (t n : ℝ) /
            (2 * (ell + 8 * (d : ℝ)) * (N n : ℝ)) := by
        field_simp [ne_of_gt (hNpositive n), ne_of_gt hden]
  have hten :
      ∀ᶠ n in atTop,
        (10 : ℝ) * (t n : ℝ) < ell * (N n : ℝ) :=
    eventually_scaled_tolerance_lt
      N t (fun n => hVpositive n) htzero
      10 ell (by norm_num) hell
  let c : ℝ :=
    5 * (4 + ell *
      (216 / ((d : ℝ) * (1 - q) ^ 2) + 1 / (d : ℝ)))
  have hdiff : 0 < 1 - q := sub_pos.mpr hq
  have hc : 0 < c := by
    dsimp [c]
    positivity
  have hspectral :
      ∀ᶠ n in atTop,
        c * (t n : ℝ) ≤ ell * (N n : ℝ) :=
    (eventually_scaled_tolerance_lt
      N t (fun n => hVpositive n) htzero c ell hc hell).mono
      fun _ h => h.le
  refine ⟨m, rootError, t, hm, hRm, hδm,
    ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩
  · simpa only [B, N] using hrelative
  · intro n
    rfl
  · simpa only [N] using hrootlower
  · simpa only [N] using hrootlimit
  · intro n
    rfl
  · exact htpositive
  · exact hrootbudget
  · exact hsourcebudget
  · exact hrooterrorbudget
  · simpa only [N] using htzero
  · simpa only [N] using htarget
  · simpa only [N] using hten
  · simpa only [N, c] using hspectral

end KunCombinedPrescribedRootSourceTolerance

namespace KunLiteralSourceSelectedComponents

open Filter Topology
open scoped BigOperators Pointwise

def sourceConjugacyDisagreementBad
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (u g : G) (n : ℕ) : Finset (Fin (A.model n).size) := by
  classical
  exact Finset.univ.filter fun x =>
    (A.model n).action (u * g * u⁻¹) x ≠
      ((A.model n).action u * (A.model n).action g *
        ((A.model n).action u)⁻¹) x

theorem sourceConjugacyDisagreementBad_density_tendsto_zero
    {G : Type*} [Group G]
    (A : SoficGroups.SoficApproximation G)
    (u g : G) :
    Tendsto
      (fun n =>
        ((sourceConjugacyDisagreementBad A u g n).card : ℝ) /
          (A.model n).size)
      atTop (nhds 0) := by
  classical
  simpa [sourceConjugacyDisagreementBad,
    SoficGroups.normalizedHamming, hammingDist] using
    SoficGroups.SourceCompressionTransportCrossing.tendsto_action_conjugate
      A u g

end KunLiteralSourceSelectedComponents

namespace KunActualBothTransportedOverlapScales

open Filter Topology
open scoped BigOperators

theorem source_both_transported_generator_boundary_density_tendsto_zero
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure
      (S : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hsource : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode))) C : ℝ)) /
              (A.model n).size)
      atTop (nhds 0)) :
    ∀ j : Fin 2, Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action
                  (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
                (A.model n).action
                  (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                    (i : SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaPrefixCode)) *
                ((A.model n).action
                  (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)
            C : ℝ)) /
              (A.model n).size)
      atTop (nhds 0) := by
  classical
  have hsource' : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action
                (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode))) C : ℝ)) /
              (A.model n).size)
      atTop (nhds 0) := by
    exact hsource
  intro j
  have hcross (i : ↥S) : Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((A.model n).action
              (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
            (A.model n).action
              (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                (i : SoficGroups.prefixElementaryGroup
                  SoficGroups.alphaPrefixCode)) *
            ((A.model n).action
              (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)).card : ℝ) /
              (A.model n).size)
      atTop (nhds 0) := by
    obtain ⟨k, hk⟩ :=
      SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable_conjugates_alpha
        j (i : SoficGroups.prefixElementaryGroup
          SoficGroups.alphaPrefixCode)
    have hword :=
      SoficGroups.SourceGeneratedWordCrossing.source_alpha_word_crossing_density_tendsto_zero
        A S hsymmetric hgenerates Q hsource' k
    have hword' : Tendsto
        (fun n =>
          ((SoficGroups.partitionWordCrossing (Q n)
            ((A.model n).action
              (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j *
                SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode) *
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j)⁻¹))).card : ℝ) /
                (A.model n).size)
        atTop (nhds 0) := by
      rw [hk]
      exact hword
    exact
      SoficGroups.SourceCompressionTransportCrossing.conjugated_word_crossing_density_tendsto_zero
        A
        (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j)
        (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
          (i : SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode))
        Q hword'
  have hsum : Tendsto
      (fun n =>
        ∑ i : ↥S,
          ((SoficGroups.partitionWordCrossing (Q n)
            ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
              (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode)) *
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)).card : ℝ) /
                (A.model n).size)
      atTop (nhds 0) := by
    simpa using tendsto_finsetSum Finset.univ
      (fun i _ => hcross i)
  have hidentity (n : ℕ) :
      (∑ C ∈ (Q n).parts,
        (SoficGroups.boundary
          (fun i : ↥S =>
            (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
              (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode)) *
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)
          C : ℝ)) / (A.model n).size =
        ∑ i : ↥S,
          ((SoficGroups.partitionWordCrossing (Q n)
            ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
              (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode)) *
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)).card : ℝ) /
                (A.model n).size := by
    have hnat :=
      SoficGroups.SourceGeneratedWordCrossing.sum_generator_crossing_eq_sum_partition_boundary
        (Q n)
        (fun i : ↥S =>
          (A.model n).action
              (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
            (A.model n).action
              (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                (i : SoficGroups.prefixElementaryGroup
                  SoficGroups.alphaPrefixCode)) *
            ((A.model n).action
              (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)
    have hreal :
        (∑ i : ↥S,
          ((SoficGroups.partitionWordCrossing (Q n)
            ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
              (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode)) *
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)).card : ℝ)) =
          ∑ C ∈ (Q n).parts,
            (SoficGroups.boundary
              (fun i : ↥S =>
                (A.model n).action
                    (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
                  (A.model n).action
                    (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                      (i : SoficGroups.prefixElementaryGroup
                        SoficGroups.alphaPrefixCode)) *
                  ((A.model n).action
                    (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)
              C : ℝ) := by
      exact_mod_cast hnat
    rw [← hreal, Finset.sum_div]
  rw [show
    (fun n =>
      (∑ C ∈ (Q n).parts,
        (SoficGroups.boundary
          (fun i : ↥S =>
            (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
              (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode)) *
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)
          C : ℝ)) / (A.model n).size) =
      (fun n =>
        ∑ i : ↥S,
          ((SoficGroups.partitionWordCrossing (Q n)
            ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j) *
              (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode)) *
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))⁻¹)).card : ℝ) /
                (A.model n).size) from funext hidentity]
  exact hsum

theorem exists_source_both_common_slow_overlap_scales
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure
      (S : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (gamma : ℝ) (hgamma : 0 < gamma)
    (hexpand : ∀ n C, C ∈ (Q n).parts →
      ∀ E : Finset (Fin (A.model n).size), E ⊆ C →
        2 * E.card ≤ C.card →
          gamma * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥S =>
                (A.model n).action
                  (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                    (i : SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaPrefixCode))) E : ℝ))
    (hsource : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode))) C : ℝ)) /
              (A.model n).size)
      atTop (nhds 0)) :
    ∃ eta H : ℕ → ℝ,
      (∀ n, 0 < eta n) ∧
      Antitone eta ∧
      Tendsto eta atTop (nhds 0) ∧
      (∀ n, 0 < H n) ∧
      Antitone H ∧
      Tendsto H atTop (nhds 0) ∧
      Tendsto (fun n => eta n / H n) atTop (nhds 0) ∧
      (∀ j : Fin 2, Tendsto
        (fun n =>
          (∑ C ∈ SoficGroups.insufficientOverlapComponents
            (SoficGroups.transportedUnivFinpartition
              (Q n)
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j)))
            (Q n) (eta n), (C.card : ℝ)) /
              (A.model n).size)
        atTop (nhds 0)) ∧
      (∀ j : Fin 2, Tendsto
        (fun n =>
          (∑ C ∈
            (SoficGroups.transportedUnivFinpartition
              (Q n)
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))).parts,
            ((C.card : ℝ) -
              ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
                (A.model n).size)
        atTop (nhds 0)) ∧
      ∃ N : ℕ, ∀ n : ℕ, eta (n + N) < 1 := by
  classical
  have hnonempty (n : ℕ) : Nonempty (Fin (A.model n).size) :=
    Fin.pos_iff_nonempty.mp (A.model n).size_pos
  letI : ∀ n, Nonempty (Fin (A.model n).size) := hnonempty
  let σ : (n : ℕ) → ↥S → Equiv.Perm (Fin (A.model n).size) :=
    fun n i =>
      (A.model n).action
        (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
          (i : SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode))
  let T : (n : ℕ) → Fin 2 → Equiv.Perm (Fin (A.model n).size) :=
    fun n j =>
      (A.model n).action
        (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j)
  have hsource' : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary (σ n) C : ℝ)) /
            Fintype.card (Fin (A.model n).size))
      atTop (nhds 0) := by
    simpa only [σ, Fintype.card_fin] using hsource
  have htarget : ∀ j : Fin 2, Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i => T n j * σ n i * (T n j)⁻¹) C : ℝ)) /
              Fintype.card (Fin (A.model n).size))
      atTop (nhds 0) := by
    intro j
    simpa only [σ, T, Fintype.card_fin] using
      source_both_transported_generator_boundary_density_tendsto_zero
        A S hsymmetric hgenerates Q hsource j
  obtain ⟨eta, H, heta, hetaanti, heta0, hH, hHanti,
    hH0, hratio, hoverlap⟩ :=
    SoficGroups.KunTransportedAmbientOverlap.exists_common_slow_overlap_scales_for_transported_partitions
      Q σ T gamma hgamma
      (by
        intro n C hC E hE hhalf
        simpa only [σ] using hexpand n C hC E hE hhalf)
      hsource' htarget
  have hloss : ∀ j : Fin 2, Tendsto
      (fun n =>
        (∑ C ∈
          (SoficGroups.transportedUnivFinpartition
            (Q n) (T n j)).parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
              Fintype.card (Fin (A.model n).size))
      atTop (nhds 0) := by
    intro j
    apply
      SoficGroups.KunTransportedAmbientOverlap.dominant_component_loss_density_tendsto_zero
        (fun n =>
          SoficGroups.transportedUnivFinpartition (Q n) (T n j))
        Q (fun n i => T n j * σ n i * (T n j)⁻¹)
        gamma hgamma
    · intro n
      exact
        SoficGroups.KunTransportedAmbientOverlap.transportedUnivFinpartition_half_expansion
          (Q n) (σ n) (T n j) gamma
          (fun C hC E hE hhalf =>
            by simpa only [σ] using hexpand n C hC E hE hhalf)
    · exact
        SoficGroups.KunTransportedAmbientOverlap.transported_partition_boundary_density_tendsto_zero
          Q σ (fun n => T n j) hsource'
    · exact htarget j
  have htail : ∃ N : ℕ, ∀ n : ℕ, eta (n + N) < 1 := by
    have heventually : ∀ᶠ n in atTop, eta n < 1 :=
      heta0.eventually (gt_mem_nhds (by norm_num : (0 : ℝ) < 1))
    obtain ⟨N, hN⟩ := (eventually_atTop.1 heventually)
    refine ⟨N, ?_⟩
    intro n
    apply hN
    omega
  refine ⟨eta, H, heta, hetaanti, heta0, hH, hHanti,
    hH0, hratio, ?_, ?_, htail⟩
  · intro j
    simpa only [T, Fintype.card_fin] using hoverlap j
  · intro j
    simpa only [T, Fintype.card_fin] using hloss j

end KunActualBothTransportedOverlapScales
namespace SourceProductThroughAlpha

open Filter Topology
open scoped BigOperators

universe v

def sourceCompressionUAlphaHom :
    SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode →*
      SoficGroups.prefixElementaryGroup SoficGroups.alphaZeroPrefixCode :=
  ((MulAut.conj SoficGroups.compressionU).toMonoidHom.comp
    (SoficGroups.prefixElementaryGroup
      SoficGroups.alphaPrefixCode).subtype).codRestrict
        (SoficGroups.prefixElementaryGroup
          SoficGroups.alphaZeroPrefixCode)
        (by
          intro g
          rw [← SoficGroups.compressionU_map_alphaPrefixElementaryGroup]
          exact ⟨g.val, g.property, rfl⟩)

noncomputable def sourceCompressionUAlphaEquiv :
    SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode ≃*
      SoficGroups.prefixElementaryGroup SoficGroups.alphaZeroPrefixCode := by
  apply MulEquiv.ofBijective sourceCompressionUAlphaHom
  constructor
  · intro g g' heq
    apply Subtype.ext
    apply (MulAut.conj SoficGroups.compressionU).injective
    exact congrArg
      (fun k : SoficGroups.prefixElementaryGroup
          SoficGroups.alphaZeroPrefixCode =>
        (k : SoficGroups.BinaryLeavittˣ)) heq
  · intro k
    have hk :
        (k : SoficGroups.BinaryLeavittˣ) ∈
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode).map
              (MulAut.conj SoficGroups.compressionU).toMonoidHom := by
      rw [SoficGroups.compressionU_map_alphaPrefixElementaryGroup]
      exact k.property
    obtain ⟨g, hg, heq⟩ := hk
    refine ⟨⟨g, hg⟩, ?_⟩
    apply Subtype.ext
    exact heq

noncomputable def sourceCompressedGeneratingFinset
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) :
    Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaZeroPrefixCode) := by
  classical
  exact SΓ.image sourceCompressionUAlphaEquiv

theorem sourceCompressedGeneratingFinset_one_mem
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hone : 1 ∈ SΓ) :
    1 ∈ sourceCompressedGeneratingFinset SΓ := by
  classical
  change 1 ∈ SΓ.image sourceCompressionUAlphaEquiv
  exact Finset.mem_image.mpr
    ⟨1, hone, map_one sourceCompressionUAlphaEquiv⟩

theorem sourceCompressedGeneratingFinset_inv_mem
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ SΓ, g⁻¹ ∈ SΓ)
    (k : SoficGroups.prefixElementaryGroup
      SoficGroups.alphaZeroPrefixCode)
    (hk : k ∈ sourceCompressedGeneratingFinset SΓ) :
    k⁻¹ ∈ sourceCompressedGeneratingFinset SΓ := by
  classical
  change k ∈ SΓ.image sourceCompressionUAlphaEquiv at hk
  change k⁻¹ ∈ SΓ.image sourceCompressionUAlphaEquiv
  obtain ⟨g, hg, rfl⟩ := Finset.mem_image.mp hk
  exact Finset.mem_image.mpr
    ⟨g⁻¹, hsymmetric g hg,
      map_inv sourceCompressionUAlphaEquiv g⟩

theorem sourceCompressedGeneratingFinset_closure
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hgenerates : Subgroup.closure
      (SΓ : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤) :
    Subgroup.closure
      (sourceCompressedGeneratingFinset SΓ : Set
        (SoficGroups.prefixElementaryGroup
          SoficGroups.alphaZeroPrefixCode)) = ⊤ := by
  classical
  change Subgroup.closure
    ((SΓ.image sourceCompressionUAlphaEquiv : Finset
      (SoficGroups.prefixElementaryGroup
        SoficGroups.alphaZeroPrefixCode)) : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaZeroPrefixCode)) = ⊤
  rw [Finset.coe_image]
  change
    Subgroup.closure
      (sourceCompressionUAlphaEquiv.toMonoidHom ''
        (SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode))) = ⊤
  rw [← MonoidHom.map_closure, hgenerates,
    Subgroup.map_top_of_surjective
      sourceCompressionUAlphaEquiv.toMonoidHom
      sourceCompressionUAlphaEquiv.surjective]

theorem exists_sourceCompressedKazhdanPair_with_same_generators
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ SΓ, g⁻¹ ∈ SΓ)
    (hgenerates : Subgroup.closure
      (SΓ : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤) :
    ∃ P : SoficGroups.KazhdanPair.{0, v}
        (SoficGroups.prefixElementaryGroup
          SoficGroups.alphaZeroPrefixCode),
      P.generators = sourceCompressedGeneratingFinset SΓ := by
  letI : SoficGroups.HasPropertyT.{0, v}
      (SoficGroups.prefixElementaryGroup
        SoficGroups.alphaZeroPrefixCode) :=
    SoficGroups.alphaZeroPrefixElementaryGroup_hasPropertyT_unconditional
  exact
    SoficGroups.KunExactKazhdanGeneratorChange.exists_kazhdanPair_with_exact_symmetric_generators
      (sourceCompressedGeneratingFinset SΓ)
      (sourceCompressedGeneratingFinset_inv_mem SΓ hsymmetric)
      (sourceCompressedGeneratingFinset_closure SΓ hgenerates)

def sourceCompressedLocalProductToAlpha :
    (SoficGroups.prefixElementaryGroup SoficGroups.alphaZeroPrefixCode ×
      SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
        SoficGroups.ThompsonPrefixLocal.sourceLocalWord) →*
      SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode :=
  SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductHom.codRestrict
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)
      (by
        intro x
        change
          (x.1 : SoficGroups.BinaryLeavittˣ) *
            (x.2 : SoficGroups.BinaryLeavittˣ) ∈
              SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode
        exact
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode).mul_mem
              (SoficGroups.alphaZero_prefixElementaryGroup_le x.1.property)
              (SoficGroups.ThompsonPrefixInsertion.sourceLocalPrefixTranspositionGroup_le_alpha_sourceWord
                  x.2.property))

theorem sourceCompressedLocalProductEmbedding_factors_through_alpha :
    SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion.comp
        sourceCompressedLocalProductToAlpha =
      SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductEmbedding := by
  apply MonoidHom.ext
  intro x
  apply Subtype.ext
  rfl

theorem source_compressed_local_product_word_crossing_density_tendsto_zero
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ SΓ, g⁻¹ ∈ SΓ)
    (hgenerates : Subgroup.closure
      (SΓ : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥SΓ =>
              (A.model n).action
                (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                  i)) C : ℝ)) /
            (A.model n).size)
      atTop (𝓝 0))
    (z : SoficGroups.prefixElementaryGroup
          SoficGroups.alphaZeroPrefixCode ×
        SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
            SoficGroups.ThompsonPrefixLocal.sourceLocalWord) :
    Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((A.model n).action
            (SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductEmbedding
              z))).card : ℝ) /
            (A.model n).size)
      atTop (𝓝 0) := by
  have hfactor :
      SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
          (sourceCompressedLocalProductToAlpha z) =
        SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductEmbedding
          z := by
    simpa only [MonoidHom.comp_apply] using
      DFunLike.congr_fun
        sourceCompressedLocalProductEmbedding_factors_through_alpha z
  have hword :=
    SoficGroups.SourceGeneratedWordCrossing.source_alpha_word_crossing_density_tendsto_zero
        A SΓ hsymmetric hgenerates Q hboundary
          (sourceCompressedLocalProductToAlpha z)
  simpa only [hfactor] using hword

theorem source_compressed_local_product_ball_crossing_density_tendsto_zero
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ SΓ, g⁻¹ ∈ SΓ)
    (hgenerates : Subgroup.closure
      (SΓ : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥SΓ =>
              (A.model n).action
                (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                  i)) C : ℝ)) /
            (A.model n).size)
      atTop (𝓝 0))
    (I : ℕ → Finset
      (SoficGroups.prefixElementaryGroup
          SoficGroups.alphaZeroPrefixCode ×
        SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
            SoficGroups.ThompsonPrefixLocal.sourceLocalWord))
    (k : ℕ) :
    Tendsto
      (fun n =>
        ((∑ z ∈ I k,
          (SoficGroups.partitionWordCrossing (Q n)
            ((A.model n).action
              (SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductEmbedding
                z))).card : ℕ) : ℝ) /
            (A.model n).size)
      atTop (𝓝 0) := by
  have hsum :
      Tendsto
        (fun n =>
          ∑ z ∈ I k,
            ((SoficGroups.partitionWordCrossing (Q n)
              ((A.model n).action
                (SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductEmbedding
                  z))).card : ℝ) /
                (A.model n).size)
        atTop (𝓝 0) := by
    simpa using
      tendsto_finsetSum (I k) (fun z _ =>
        source_compressed_local_product_word_crossing_density_tendsto_zero
          A SΓ hsymmetric hgenerates Q hboundary z)
  simpa only [Nat.cast_sum, Finset.sum_div] using hsum

def sourceCompressedLocalProductApproximation
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode)) :
    SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup
          SoficGroups.alphaZeroPrefixCode ×
        SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
            SoficGroups.ThompsonPrefixLocal.sourceLocalWord) :=
  SoficGroups.pullbackSoficApproximation
    SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductEmbedding
    SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductEmbedding_injective
    A

@[simp]
theorem sourceCompressedLocalProductApproximation_model_size
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (n : ℕ) :
    ((sourceCompressedLocalProductApproximation A).model n).size =
      (A.model n).size := by
  rfl

theorem source_canonical_product_radius_crossing_density_tendsto_zero
    [DecidableEq
      (SoficGroups.prefixElementaryGroup
        SoficGroups.alphaZeroPrefixCode)]
    [DecidableEq
      (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
          SoficGroups.ThompsonPrefixLocal.sourceLocalWord)]
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ SΓ, g⁻¹ ∈ SΓ)
    (hgenerates : Subgroup.closure
      (SΓ : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥SΓ =>
              (A.model n).action
                (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                  i)) C : ℝ)) /
            (A.model n).size)
      atTop (𝓝 0))
    (F : Finset
      (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
          SoficGroups.ThompsonPrefixLocal.sourceLocalWord))
    (k : ℕ) :
    Tendsto
      (fun n =>
        ((∑ z ∈
          SoficGroups.CanonicalProductRadiusBadMatchedCapture.sourceProductRadiusLabels
              (sourceCompressedGeneratingFinset SΓ) F k,
          (SoficGroups.partitionWordCrossing (Q n)
            (((sourceCompressedLocalProductApproximation A).model n).action
              z)).card : ℕ) : ℝ) /
            ((sourceCompressedLocalProductApproximation A).model n).size)
      atTop (𝓝 0) := by
  change
    Tendsto
      (fun n =>
        ((∑ z ∈
          SoficGroups.CanonicalProductRadiusBadMatchedCapture.sourceProductRadiusLabels
              (sourceCompressedGeneratingFinset SΓ) F k,
          (SoficGroups.partitionWordCrossing (Q n)
            ((A.model n).action
              (SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductEmbedding
                z))).card : ℕ) : ℝ) /
              (A.model n).size)
      atTop (𝓝 0)
  exact
    source_compressed_local_product_ball_crossing_density_tendsto_zero
      A SΓ hsymmetric hgenerates Q hboundary
      (fun r =>
        SoficGroups.CanonicalProductRadiusBadMatchedCapture.sourceProductRadiusLabels
            (sourceCompressedGeneratingFinset SΓ) F r)
      k

end SourceProductThroughAlpha

namespace SourceRetainedActualMatching

open Filter Topology
open scoped BigOperators symmDiff

noncomputable def logarithmicComponentRank
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (H r : ℝ) : V → ℤ :=
  SoficGroups.MidrankPermutationEnergy.offsetFloorRank
    (fun x => Real.log (SoficGroups.partitionComponentSize Q x : ℝ))
    H r

noncomputable def retainedTransportedComponents
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V) (H r eta : ℝ) : Finset (Finset V) :=
  SoficGroups.SourceCompressionRetainedDiscard.retainedComponents
    (SoficGroups.transportedUnivFinpartition Q T) Q T
    (logarithmicComponentRank Q H r) eta

theorem retained_transport_component_matching_bounds
    {V : Type*} [Fintype V] [DecidableEq V]
    (Q : Finpartition (Finset.univ : Finset V))
    (T : Equiv.Perm V)
    (H r eta : ℝ) (hH : 0 < H)
    (C : Finset V)
    (hC : C ∈ retainedTransportedComponents Q T H r eta) :
    SoficGroups.maximumOverlapPart Q C ∈ Q.parts ∧
      (1 - eta) * (C.card : ℝ) ≤
        ((C ∩ SoficGroups.maximumOverlapPart Q C).card : ℝ) ∧
      ((C ∆ SoficGroups.maximumOverlapPart Q C).card : ℝ) <
        (Real.exp H - 1 + 2 * eta) * (C.card : ℝ) ∧
      (2 * (Real.exp H - 1 + 2 * eta) < 1 →
        (SoficGroups.maximumOverlapPart Q C).card <
          2 * (C ∩ SoficGroups.maximumOverlapPart Q C).card) := by
  classical
  have hret :
      C ∈ SoficGroups.SourceCompressionRetainedDiscard.retainedComponents
        (SoficGroups.transportedUnivFinpartition Q T) Q T
        (logarithmicComponentRank Q H r) eta := by
    exact hC
  obtain ⟨hpart, htarget, hoverlap, y, hy, hrank⟩ :=
    SoficGroups.SourceCompressionRetainedDiscard.retainedComponents_spec
      (SoficGroups.transportedUnivFinpartition Q T) Q T
      (logarithmicComponentRank Q H r) eta C hret
  have hpartImage := hpart
  rw [SoficGroups.transportedUnivFinpartition_parts] at hpartImage
  obtain ⟨C₀, hC₀, hmap⟩ := Finset.mem_image.mp hpartImage
  have hyMap : y ∈ C₀.map T.toEmbedding := by
    rw [hmap]
    exact (Finset.mem_inter.mp hy).1
  obtain ⟨x, hx, hxy⟩ := Finset.mem_map.mp hyMap
  have hxy' : T x = y := hxy
  have hTx :
      T x ∈ SoficGroups.maximumOverlapPart Q
        (C₀.map T.toEmbedding) := by
    rw [hmap]
    simpa only [hxy'] using (Finset.mem_inter.mp hy).2
  have hfloor :
      SoficGroups.MidrankPermutationEnergy.offsetFloorRank
        (fun z : V =>
          Real.log (SoficGroups.partitionComponentSize Q z : ℝ))
        H r (T x) =
      SoficGroups.MidrankPermutationEnergy.offsetFloorRank
        (fun z : V =>
          Real.log (SoficGroups.partitionComponentSize Q z : ℝ))
        H r x := by
    have heq :
        logarithmicComponentRank Q H r (T x) =
          logarithmicComponentRank Q H r x := by
      calc
        logarithmicComponentRank Q H r (T x) =
            logarithmicComponentRank Q H r y :=
          congrArg (logarithmicComponentRank Q H r) hxy'
        _ = logarithmicComponentRank Q H r (T.symm y) :=
          hrank.symm
        _ = logarithmicComponentRank Q H r x := by
          rw [← hxy', Equiv.symm_apply_apply]
    exact heq
  have hsize :=
    SoficGroups.SourceCompressionMatching.transported_maximumOverlapPart_card_lt_exp_mul
      Q T C₀ hC₀ H r hH x hx hTx hfloor
  rw [hmap] at hsize
  have hcard : C.card = C₀.card := by
    rw [← hmap, Finset.card_map]
  rw [← hcard] at hsize
  have hsymmetric :=
    SoficGroups.SourceCompressionMatching.symmDiff_card_lt_of_overlap_and_exp_card
      C (SoficGroups.maximumOverlapPart Q C) H eta
      hoverlap hsize
  refine ⟨htarget, hoverlap, hsymmetric, ?_⟩
  intro hsmall
  exact
    SoficGroups.SourceCompressionMatching.target_majority_of_overlap_and_exp_card
      C (SoficGroups.maximumOverlapPart Q C)
      ((SoficGroups.transportedUnivFinpartition Q T).nonempty_of_mem_parts hpart)
      H eta hoverlap hsize hsmall

theorem retained_source_transport_matching_of_ambient_midrank_variance
    (V : ℕ → Type*)
    [∀ n, Fintype (V n)] [∀ n, Nonempty (V n)]
    [∀ n, DecidableEq (V n)]
    (κ : Type*)
    (Q A : (n : ℕ) → Finpartition
      (Finset.univ : Finset (V n)))
    (T : (n : ℕ) → κ → Equiv.Perm (V n))
    (H r eta : ℕ → ℝ)
    (hHpos : ∀ n, 0 < H n)
    (hHzero : Tendsto H atTop (nhds 0))
    (heta0 : ∀ n, 0 ≤ eta n)
    (hetazero : Tendsto eta atTop (nhds 0))
    (hvariance : Tendsto
      (fun n =>
        (∑ C ∈ (A n).parts,
          (C.card : ℝ) *
            SoficGroups.midrankVariance
              (SoficGroups.componentRankMassList C
                (logarithmicComponentRank (Q n) (H n) (r n)))) /
                  Fintype.card (V n))
      atTop (nhds 0))
    (hcross : ∀ i : κ, Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing
          (A n) (T n i).symm).card : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0))
    (hoverlap : ∀ i : κ, Tendsto
      (fun n =>
        ((∑ C ∈ SoficGroups.insufficientOverlapComponents
          (SoficGroups.transportedUnivFinpartition (Q n) (T n i))
          (Q n) (eta n), C.card : ℕ) : ℝ) /
            Fintype.card (V n))
      atTop (nhds 0)) :
    ∀ i : κ,
      (∀ n, retainedTransportedComponents
        (Q n) (T n i) (H n) (r n) (eta n) ⊆
          (SoficGroups.transportedUnivFinpartition
            (Q n) (T n i)).parts) ∧
      (∀ n C, C ∈ retainedTransportedComponents
        (Q n) (T n i) (H n) (r n) (eta n) →
          SoficGroups.maximumOverlapPart (Q n) C ∈ (Q n).parts) ∧
      (∀ n, eta n ≤ (1 : ℝ) / 2 →
        2 * (Real.exp (H n) - 1 + 2 * eta n) < 1 →
          ∀ C, C ∈ retainedTransportedComponents
            (Q n) (T n i) (H n) (r n) (eta n) →
              (SoficGroups.maximumOverlapPart (Q n) C).card <
                2 * (C ∩ SoficGroups.maximumOverlapPart
                  (Q n) C).card) ∧
      Tendsto
        (fun n =>
          (((Finset.univ : Finset (V n)) \
            SoficGroups.matchedRetainedSupport
              (retainedTransportedComponents
                (Q n) (T n i) (H n) (r n) (eta n))).card : ℝ) /
              Fintype.card (V n))
        atTop (nhds 0) ∧
      Tendsto
        (fun n =>
          ((∑ C ∈ retainedTransportedComponents
            (Q n) (T n i) (H n) (r n) (eta n),
              (C ∆ SoficGroups.maximumOverlapPart (Q n) C).card :
                ℕ) : ℝ) / Fintype.card (V n))
        atTop (nhds 0) ∧
      (∀ n, 2 * (Real.exp (H n) - 1 + 2 * eta n) < 1 →
        Set.InjOn (SoficGroups.maximumOverlapPart (Q n))
          ((retainedTransportedComponents
            (Q n) (T n i) (H n) (r n) (eta n) :
              Finset (Finset (V n))) :
                Set (Finset (V n)))) := by
  let b : (n : ℕ) → V n → ℤ :=
    fun n => logarithmicComponentRank (Q n) (H n) (r n)
  obtain ⟨_j, _hj, _homit, hrank⟩ :=
    SoficGroups.KunCommonRankArcInvariance.exists_common_rank_invariance_of_midrank_variance
      A b (fun n i => (T n i).symm) hvariance hcross
  intro i
  let P : (n : ℕ) → Finpartition
      (Finset.univ : Finset (V n)) :=
    fun n => SoficGroups.transportedUnivFinpartition (Q n) (T n i)
  let R : (n : ℕ) → Finset (Finset (V n)) :=
    fun n => retainedTransportedComponents
      (Q n) (T n i) (H n) (r n) (eta n)
  have hparts (n : ℕ) : R n ⊆ (P n).parts := by
    exact Finset.sdiff_subset
  have htarget (n : ℕ) (C : Finset (V n)) (hC : C ∈ R n) :
      SoficGroups.maximumOverlapPart (Q n) C ∈ (Q n).parts :=
    (retained_transport_component_matching_bounds
      (Q n) (T n i) (H n) (r n) (eta n) (hHpos n) C hC).1
  have hmajor (n : ℕ)
      (_heta : eta n ≤ (1 : ℝ) / 2)
      (hsmall : 2 * (Real.exp (H n) - 1 + 2 * eta n) < 1)
      (C : Finset (V n)) (hC : C ∈ R n) :
      (SoficGroups.maximumOverlapPart (Q n) C).card <
        2 * (C ∩ SoficGroups.maximumOverlapPart (Q n) C).card :=
    (retained_transport_component_matching_bounds
      (Q n) (T n i) (H n) (r n) (eta n) (hHpos n) C hC).2.2.2 hsmall
  have hbound (n : ℕ) (C : Finset (V n)) (hC : C ∈ R n) :
      ((C ∆ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ) ≤
        (Real.exp (H n) - 1 + 2 * eta n) * (C.card : ℝ) :=
    (retained_transport_component_matching_bounds
      (Q n) (T n i) (H n) (r n) (eta n) (hHpos n) C hC).2.2.1.le
  have hdiscard :
      Tendsto
        (fun n =>
          (((Finset.univ : Finset (V n)) \
            SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
              Fintype.card (V n))
        atTop (nhds 0) := by
    exact
      SoficGroups.SourceCompressionRetainedDiscard.retained_missing_density_tendsto_zero
        V P Q (fun n => T n i) b eta hetazero
        (hoverlap i) (hrank i)
  have hsymmetric :
      Tendsto
        (fun n =>
          ((∑ C ∈ R n,
            (C ∆ SoficGroups.maximumOverlapPart (Q n) C).card :
              ℕ) : ℝ) / Fintype.card (V n))
        atTop (nhds 0) := by
    have hfull (n : ℕ) :
        (Finset.univ : Finset (V n)).Nonempty :=
      Finset.univ_nonempty
    simpa only [Finset.card_univ] using
      SoficGroups.SourceCompressionMatching.symmDiff_density_tendsto_zero_of_log_rank_bounds
        (V := V) (fun n => (Finset.univ : Finset (V n))) hfull
        P R hparts (fun n => SoficGroups.maximumOverlapPart (Q n))
        H eta (fun n => (hHpos n).le) heta0 hHzero hetazero
        hbound
  refine ⟨hparts, htarget, hmajor, hdiscard, hsymmetric, ?_⟩
  intro n hsmall
  exact SoficGroups.finpartition_dominant_matching_injOn
    (P n) (R n) (hparts n)
    (SoficGroups.maximumOverlapPart (Q n))
    (fun C hC =>
      (retained_transport_component_matching_bounds
        (Q n) (T n i) (H n) (r n) (eta n)
        (hHpos n) C hC).2.2.2 hsmall)

end SourceRetainedActualMatching

namespace KunActualBothTransportedOverlapScales

open Filter Topology
open scoped BigOperators

theorem exists_source_both_capped_overlap_scales
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure
      (S : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (gamma : ℝ) (hgamma : 0 < gamma)
    (hexpand : ∀ n C, C ∈ (Q n).parts →
      ∀ E : Finset (Fin (A.model n).size), E ⊆ C →
        2 * E.card ≤ C.card →
          gamma * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥S =>
                (A.model n).action
                  (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                    (i : SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaPrefixCode))) E : ℝ))
    (hsource : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode))) C : ℝ)) /
              (A.model n).size)
      atTop (nhds 0)) :
    ∃ eta H : ℕ → ℝ,
      (∀ n, 0 < eta n) ∧
      (∀ n, eta n < 1) ∧
      Antitone eta ∧
      Tendsto eta atTop (nhds 0) ∧
      (∀ n, 0 < H n) ∧
      Antitone H ∧
      Tendsto H atTop (nhds 0) ∧
      Tendsto (fun n => eta n / H n) atTop (nhds 0) ∧
      (∀ j : Fin 2, Tendsto
        (fun n =>
          (∑ C ∈ SoficGroups.insufficientOverlapComponents
            (SoficGroups.transportedUnivFinpartition
              (Q n)
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j)))
            (Q n) (eta n), (C.card : ℝ)) /
              (A.model n).size)
        atTop (nhds 0)) ∧
      ∀ j : Fin 2, Tendsto
        (fun n =>
          (∑ C ∈
            (SoficGroups.transportedUnivFinpartition
              (Q n)
              ((A.model n).action
                (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j))).parts,
            ((C.card : ℝ) -
              ((C ∩ SoficGroups.maximumOverlapPart (Q n) C).card : ℝ))) /
                (A.model n).size)
        atTop (nhds 0) := by
  classical
  obtain ⟨eta, H, heta, hetaanti, heta0, hH, hHanti,
    hH0, hratio, hoverlap, hloss, _htail⟩ :=
    exists_source_both_common_slow_overlap_scales
      A S hsymmetric hgenerates Q gamma hgamma hexpand hsource
  let capped : ℕ → ℝ := fun n => min (eta n) ((1 : ℝ) / 2)
  have heventually : ∀ᶠ n in atTop, eta n < (1 : ℝ) / 2 :=
    heta0.eventually (gt_mem_nhds (by norm_num : (0 : ℝ) < 1 / 2))
  have heq : capped =ᶠ[atTop] eta := by
    filter_upwards [heventually] with n hn
    exact min_eq_left hn.le
  have hcappedpositive (n : ℕ) : 0 < capped n := by
    exact lt_min (heta n) (by norm_num : (0 : ℝ) < 1 / 2)
  have hcappedone (n : ℕ) : capped n < 1 := by
    have hhalf : capped n ≤ (1 : ℝ) / 2 :=
      min_le_right _ _
    linarith
  have hcappedanti : Antitone capped := by
    intro m n hmn
    exact min_le_min (hetaanti hmn) (le_refl ((1 : ℝ) / 2))
  have hcappedzero : Tendsto capped atTop (nhds 0) :=
    heta0.congr' heq.symm
  have hcappedratio : Tendsto
      (fun n => capped n / H n) atTop (nhds 0) := by
    have heqratio :
        (fun n => capped n / H n) =ᶠ[atTop]
          (fun n => eta n / H n) := by
      filter_upwards [heq] with n hn
      rw [hn]
    exact hratio.congr' heqratio.symm
  refine ⟨capped, H, hcappedpositive, hcappedone, hcappedanti,
    hcappedzero, hH, hHanti, hH0, hcappedratio, ?_, hloss⟩
  intro j
  have heqoverlap :
      (fun n =>
        (∑ C ∈ SoficGroups.insufficientOverlapComponents
          (SoficGroups.transportedUnivFinpartition
            (Q n)
            ((A.model n).action
              (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j)))
          (Q n) (capped n), (C.card : ℝ)) /
            (A.model n).size) =ᶠ[atTop]
      (fun n =>
        (∑ C ∈ SoficGroups.insufficientOverlapComponents
          (SoficGroups.transportedUnivFinpartition
            (Q n)
            ((A.model n).action
              (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j)))
          (Q n) (eta n), (C.card : ℝ)) /
            (A.model n).size) := by
    filter_upwards [heq] with n hn
    rw [hn]
  exact (hoverlap j).congr' heqoverlap.symm

end KunActualBothTransportedOverlapScales

namespace KunLiteralNineSourceCompletedCentralizerModels

open Filter Topology
open scoped BigOperators

theorem sourceAmbientGeneratedWord_crossing_density_tendsto_zero
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure
      (S : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode)) =
          ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action
                (i : SoficGroups.prefixElementaryGroup
                  SoficGroups.ninePrefixCode)) C : ℝ)) /
              (A.model n).size)
      atTop (𝓝 0))
    (g : SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) :
    Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          ((A.model n).action g)).card : ℝ) /
            (A.model n).size)
      atTop (𝓝 0) := by
  simpa only [MonoidHom.id_apply] using
    SoficGroups.SourceGeneratedWordCrossing.fixed_generated_word_crossing_density_tendsto_zero
        A (MonoidHom.id _) S hsymmetric hgenerates Q hboundary g

theorem sourceAmbientFiniteFamily_crossing_density_tendsto_zero
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure
      (S : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode)) =
          ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action
                (i : SoficGroups.prefixElementaryGroup
                  SoficGroups.ninePrefixCode)) C : ℝ)) /
              (A.model n).size)
      atTop (𝓝 0))
    (ι : Type*) [Fintype ι]
    (g : ι →
      SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) :
    Tendsto
      (fun n =>
        (∑ i : ι,
          ((SoficGroups.partitionWordCrossing (Q n)
            ((A.model n).action (g i))).card : ℝ)) /
              (A.model n).size)
      atTop (𝓝 0) := by
  have hsum : Tendsto
      (fun n =>
        ∑ i : ι,
          ((SoficGroups.partitionWordCrossing (Q n)
            ((A.model n).action (g i))).card : ℝ) /
              (A.model n).size)
      atTop (𝓝 0) := by
    simpa using tendsto_finsetSum (Finset.univ : Finset ι)
      (fun i _ => sourceAmbientGeneratedWord_crossing_density_tendsto_zero
        A S hsymmetric hgenerates Q hboundary (g i))
  simpa only [Finset.sum_div] using hsum

theorem sourceAmbientActualInverse_crossing_density_tendsto_zero
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure
      (S : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode)) =
          ⊤)
    (Q : ∀ n, Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action
                (i : SoficGroups.prefixElementaryGroup
                  SoficGroups.ninePrefixCode)) C : ℝ)) /
              (A.model n).size)
      atTop (𝓝 0))
    (g : SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) :
    Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (Q n)
          (((A.model n).action g)⁻¹)).card : ℝ) /
            (A.model n).size)
      atTop (𝓝 0) := by
  have hlabel :=
    sourceAmbientGeneratedWord_crossing_density_tendsto_zero
      A S hsymmetric hgenerates Q hboundary (g⁻¹)
  have hinverse :=
    SoficGroups.KunCommonRankArcInvariance.sofic_action_inverse_normalizedHamming_tendsto_zero
      A g
  simpa only [Fintype.card_fin] using
    SoficGroups.SourceGeneratedWordCrossing.crossing_density_tendsto_zero_of_normalizedHamming
        Q (fun n => ((A.model n).action g)⁻¹)
          (fun n => (A.model n).action (g⁻¹))
          (by simpa only [Fintype.card_fin] using hlabel)
          hinverse

theorem exists_source_common_log_rank_with_ambient_midrank_variance
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (SG : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (QΓ QG : (n : ℕ) →
      Finpartition (Finset.univ : Finset (Fin (A.model n).size)))
    (γG : ℝ)
    (hsymmetricG : ∀ g ∈ SG, g⁻¹ ∈ SG)
    (hgeneratesG : Subgroup.closure
      (SG : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode)) =
          ⊤)
    (hpositive : Subgroup.closure
      (Set.range
        (SoficGroups.KunExactActualSourceAmbientGenerators.sourcePositiveGeneratorMap
          SΓ)) = ⊤)
    (hγG : 0 < γG)
    (hexpandG : ∀ n C, C ∈ (QG n).parts →
      ∀ E : Finset (Fin (A.model n).size), E ⊆ C →
        2 * E.card ≤ C.card →
          γG * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥SG =>
                (A.model n).action
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.ninePrefixCode)) E : ℝ))
    (hboundaryΓ : Tendsto
      (fun n =>
        (∑ C ∈ (QΓ n).parts,
          (SoficGroups.boundary
            (fun i : ↥SΓ =>
              (A.model n).action
                (SoficGroups.KunExactActualSourceAmbientGenerators.sourceAlphaInclusion
                  (i : SoficGroups.prefixElementaryGroup
                    SoficGroups.alphaPrefixCode))) C : ℝ)) /
              (A.model n).size)
      atTop (𝓝 0))
    (hboundaryG : Tendsto
      (fun n =>
        (∑ C ∈ (QG n).parts,
          (SoficGroups.boundary
            (fun i : ↥SG =>
              (A.model n).action
                (i : SoficGroups.prefixElementaryGroup
                  SoficGroups.ninePrefixCode)) C : ℝ)) /
              (A.model n).size)
      atTop (𝓝 0))
    (eta H : ℕ → ℝ)
    (heta0 : ∀ n, 0 ≤ eta n)
    (heta1 : ∀ n, eta n < 1)
    (hH : ∀ n, 0 < H n)
    (heta : Tendsto eta atTop (𝓝 0))
    (hratio : Tendsto (fun n => eta n / H n) atTop (𝓝 0))
    (hoverlap : ∀ j : Fin 2, Tendsto
      (fun n =>
        (∑ C ∈ SoficGroups.insufficientOverlapComponents
          (SoficGroups.transportedUnivFinpartition
            (QΓ n)
            ((A.model n).action
              (SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionTable
                j)))
          (QΓ n) (eta n), (C.card : ℝ)) /
            (A.model n).size)
      atTop (𝓝 0))
    (hloss : ∀ j : Fin 2, Tendsto
      (fun n =>
        (∑ C ∈
          (SoficGroups.transportedUnivFinpartition
            (QΓ n)
            ((A.model n).action
              (SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionTable
                j))).parts,
          ((C.card : ℝ) -
            ((C ∩ SoficGroups.maximumOverlapPart (QΓ n) C).card : ℝ))) /
              (A.model n).size)
      atTop (𝓝 0)) :
    ∃ r : ℕ → ℝ,
      (∀ n, r n ∈ Set.Ico 0 (H n)) ∧
      Tendsto
        (fun n =>
          (∑ C ∈ (QG n).parts,
            (C.card : ℝ) *
              SoficGroups.midrankVariance
                (SoficGroups.componentRankMassList C
                  (SoficGroups.SourceCommonOffsetMidrankEnergy.componentLogRank
                    (QΓ n) (H n) (r n)))) /
                (A.model n).size)
        atTop (𝓝 0) ∧
      (∀ j : Fin 2, Tendsto
        (fun n =>
          ((SoficGroups.partitionWordCrossing (QG n)
            (((A.model n).action
              (SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionTable
                j))⁻¹)).card : ℝ) /
              (A.model n).size)
        atTop (𝓝 0)) := by
  classical
  letI : ∀ n, Nonempty (Fin (A.model n).size) :=
    fun n => Fin.pos_iff_nonempty.mp (A.model n).size_pos
  let σ : (n : ℕ) → ↥SΓ → Equiv.Perm (Fin (A.model n).size) :=
    fun n i =>
      (A.model n).action
        (SoficGroups.KunExactActualSourceAmbientGenerators.sourceAlphaInclusion
          (i : SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode))
  let T : (n : ℕ) → Fin 2 → Equiv.Perm (Fin (A.model n).size) :=
    fun n j =>
      (A.model n).action
        (SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionTable
          j)
  have hcrossΓ : ∀ i : ↥SΓ, Tendsto
      (fun n =>
        ((SoficGroups.partitionWordCrossing (QΓ n)
          (σ n i)).card : ℝ) /
            Fintype.card (Fin (A.model n).size))
      atTop (𝓝 0) := by
    intro i
    exact
      SoficGroups.SourceGeneratedWordCrossing.generator_crossing_density_tendsto_zero
        QΓ σ
        (by simpa only [σ, Fintype.card_fin] using hboundaryΓ)
        i
  have haction (n : ℕ) (i : ↥SΓ ⊕ Fin 2) :
      (A.model n).action
        (SoficGroups.KunExactActualSourceAmbientGenerators.sourcePositiveGeneratorMap
          SΓ i) =
        Sum.elim (σ n) (T n) i := by
    cases i <;> rfl
  have hcrossG : Tendsto
      (fun n =>
        (∑ i : ↥SΓ ⊕ Fin 2,
          ((SoficGroups.partitionWordCrossing
            (QG n) (Sum.elim (σ n) (T n) i)).card : ℝ)) /
              Fintype.card (Fin (A.model n).size))
      atTop (𝓝 0) := by
    simpa only [haction, Fintype.card_fin]
      using sourceAmbientFiniteFamily_crossing_density_tendsto_zero
        A SG hsymmetricG hgeneratesG QG hboundaryG
        (↥SΓ ⊕ Fin 2)
        (SoficGroups.KunExactActualSourceAmbientGenerators.sourcePositiveGeneratorMap
          SΓ)
  obtain ⟨r, hr, _hdrop, hmidpoint⟩ :=
    SoficGroups.SourceCommonComponentRankNoBad.exists_common_positive_component_log_rank_with_vanishing_midrank_energy
      (fun n => Fin (A.model n).size)
      (↥SΓ) (Fin 2) QΓ QG σ T eta H
      heta0 heta1 hH heta hratio hcrossΓ
      (by simpa only [T, Fintype.card_fin] using hoverlap)
      (by simpa only [T, Fintype.card_fin] using hloss)
      hcrossG
  let b : (n : ℕ) → Fin (A.model n).size → ℤ :=
    fun n =>
      SoficGroups.SourceCommonOffsetMidrankEnergy.componentLogRank
        (QΓ n) (H n) (r n)
  let f : (n : ℕ) → Fin (A.model n).size → ℝ :=
    fun n =>
      SoficGroups.MidrankPermutationEnergy.partitionVertexMidrank
        (QG n) (b n)
  have hf0 : ∀ n x, 0 ≤ f n x := by
    intro n x
    exact SoficGroups.componentVertexMidrank_nonneg
      ((QG n).part x) (b n) x
  have hf1 : ∀ n x, f n x ≤ 1 := by
    intro n x
    exact SoficGroups.componentVertexMidrank_le_one
      ((QG n).part x) (b n) x
  have hmidpoint' : Tendsto
      (fun n =>
        (∑ i : ↥SΓ ⊕ Fin 2,
          ∑ x : Fin (A.model n).size,
            (f n (Sum.elim (σ n) (T n) i x) - f n x) ^ 2) /
              (A.model n).size)
      atTop (𝓝 0) := by
    simpa only [f, b, Fintype.card_fin] using hmidpoint
  have hpositiveEnergy : Tendsto
      (fun n =>
        (∑ i : ↥SΓ ⊕ Fin 2,
          SoficGroups.KunPositiveWordMidrankEnergy.squaredPermutationEnergy
            (f n)
            ((A.model n).action
              (SoficGroups.KunExactActualSourceAmbientGenerators.sourcePositiveGeneratorMap
                SΓ i))) /
              (A.model n).size)
      atTop (𝓝 0) := by
    have hpoint (n : ℕ) (i : ↥SΓ ⊕ Fin 2) :
        SoficGroups.KunPositiveWordMidrankEnergy.squaredPermutationEnergy
          (f n)
          ((A.model n).action
            (SoficGroups.KunExactActualSourceAmbientGenerators.sourcePositiveGeneratorMap
              SΓ i)) =
          ∑ x : Fin (A.model n).size,
            (f n (Sum.elim (σ n) (T n) i x) - f n x) ^ 2 := by
      rw [haction n i]
      rfl
    simpa only [hpoint] using hmidpoint'
  have hgenerators :=
    SoficGroups.KunPositiveWordMidrankEnergy.sum_action_energy_tendsto_zero_of_positive_generator_sum
      A
      (SoficGroups.KunExactActualSourceAmbientGenerators.sourcePositiveGeneratorMap
        SΓ)
      hpositive f hf0 hf1 hpositiveEnergy SG
  have hgeneratorSum (n : ℕ) :
      (∑ g ∈ SG,
        SoficGroups.KunPositiveWordMidrankEnergy.squaredPermutationEnergy
          (f n) ((A.model n).action g)) =
      ∑ i : ↥SG,
        SoficGroups.KunPositiveWordMidrankEnergy.squaredPermutationEnergy
          (f n)
          ((A.model n).action
            (i : SoficGroups.prefixElementaryGroup
              SoficGroups.ninePrefixCode)) := by
    rw [← Finset.sum_coe_sort SG]
  have hsubtypeEnergy : Tendsto
      (fun n =>
        (∑ i : ↥SG,
          SoficGroups.KunPositiveWordMidrankEnergy.squaredPermutationEnergy
            (f n)
            ((A.model n).action
              (i : SoficGroups.prefixElementaryGroup
                SoficGroups.ninePrefixCode))) /
                (A.model n).size)
      atTop (𝓝 0) := by
    simpa only [hgeneratorSum] using hgenerators
  have hgeneratorEnergy : Tendsto
      (fun n =>
        (∑ i : ↥SG, ∑ x : Fin (A.model n).size,
          (f n ((A.model n).action
            (i : SoficGroups.prefixElementaryGroup
              SoficGroups.ninePrefixCode) x) - f n x) ^ 2) /
            Fintype.card (Fin (A.model n).size))
      atTop (𝓝 0) := by
    simpa only [Fintype.card_fin,
      SoficGroups.KunPositiveWordMidrankEnergy.squaredPermutationEnergy]
      using hsubtypeEnergy
  have hvariance :=
    SoficGroups.KunGlobalActualAdditiveMidrankVariance.weighted_component_midrankVariance_tendsto_zero_of_source_half_expansion
      (fun n => Fin (A.model n).size) (↥SG) QG
      (fun n i =>
        (A.model n).action
          (i : SoficGroups.prefixElementaryGroup
            SoficGroups.ninePrefixCode))
      b γG hγG hexpandG
      (by simpa only [Fintype.card_fin] using hboundaryG)
      (by simpa only [f] using hgeneratorEnergy)
  refine ⟨r, hr, ?_, ?_⟩
  · simpa only [b, Fintype.card_fin] using hvariance
  · intro j
    exact sourceAmbientActualInverse_crossing_density_tendsto_zero
      A SG hsymmetricG hgeneratesG QG hboundaryG
      (SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionTable
        j)

end KunLiteralNineSourceCompletedCentralizerModels

namespace KunActualFirstStageReferenceExpansion

open Filter Topology
open scoped BigOperators

def componentGeneratorDisagreement
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (C : Finset V)
    (σref σact : ι → Equiv.Perm V) : ℕ :=
  ∑ i : ι, (C.filter fun x => σref i x ≠ σact i x).card

theorem componentGeneratorDisagreement_comm
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (C : Finset V)
    (σref σact : ι → Equiv.Perm V) :
    componentGeneratorDisagreement C σref σact =
      componentGeneratorDisagreement C σact σref := by
  classical
  unfold componentGeneratorDisagreement
  apply Finset.sum_congr rfl
  intro i _
  congr 1
  ext x
  simp only [Finset.mem_filter]
  exact and_congr_right fun _ => ne_comm

theorem boundary_le_boundary_add_componentGeneratorDisagreement
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σref σact : ι → Equiv.Perm V)
    (C E : Finset V) (hEC : E ⊆ C) :
    SoficGroups.boundary σref E ≤
      SoficGroups.boundary σact E +
        componentGeneratorDisagreement C σref σact := by
  classical
  unfold SoficGroups.boundary componentGeneratorDisagreement
  calc
    (∑ i : ι, (E.filter fun x => σref i x ∉ E).card) ≤
        ∑ i : ι,
          ((E.filter fun x => σact i x ∉ E).card +
            (C.filter fun x => σref i x ≠ σact i x).card) := by
          apply Finset.sum_le_sum
          intro i _
          have hsubset :
              (E.filter fun x => σref i x ∉ E) ⊆
                (E.filter fun x => σact i x ∉ E) ∪
                  (C.filter fun x => σref i x ≠ σact i x) := by
            intro x hx
            obtain ⟨hxE, href⟩ := Finset.mem_filter.mp hx
            by_cases hact : σact i x ∈ E
            · apply Finset.mem_union_right
              apply Finset.mem_filter.mpr
              refine ⟨hEC hxE, ?_⟩
              intro heq
              apply href
              rwa [heq]
            · apply Finset.mem_union_left
              exact Finset.mem_filter.mpr ⟨hxE, hact⟩
          exact (Finset.card_le_card hsubset).trans
            (Finset.card_union_le _ _)
    _ = (∑ i : ι, (E.filter fun x => σact i x ∉ E).card) +
          ∑ i : ι,
            (C.filter fun x => σref i x ≠ σact i x).card := by
          rw [Finset.sum_add_distrib]

theorem completed_actual_component_additive_expansion_of_reference
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (σref σact : ι → Equiv.Perm V) (C : Finset V)
    (τ : ι → Equiv.Perm {x : V // x ∈ C})
    (hτ : ∀ i (x : V) (hx : x ∈ C) (_hy : σact i x ∈ C),
      ((τ i ⟨x, hx⟩ : {x : V // x ∈ C}) : V) = σact i x)
    (γ : ℝ)
    (hexpand : ∀ E : Finset V, E ⊆ C →
      2 * E.card ≤ C.card →
        γ * (E.card : ℝ) ≤ (SoficGroups.boundary σref E : ℝ)) :
    ∀ E : Finset {x : V // x ∈ C},
      γ * min (E.card : ℝ) ((C.card : ℝ) - E.card) -
        ((SoficGroups.boundary σref C : ℝ) +
          2 * (componentGeneratorDisagreement C σref σact : ℝ)) ≤
        (SoficGroups.boundary τ E : ℝ) := by
  classical
  have hhalf (E : Finset {x : V // x ∈ C})
      (hE : 2 * E.card ≤ C.card) :
      γ * (E.card : ℝ) -
        ((SoficGroups.boundary σref C : ℝ) +
          2 * (componentGeneratorDisagreement C σref σact : ℝ)) ≤
        (SoficGroups.boundary τ E : ℝ) := by
    let D : Finset V :=
      E.map (Function.Embedding.subtype (fun x : V => x ∈ C))
    have hDC : D ⊆ C := by
      intro x hx
      exact Finset.property_of_mem_map_subtype E hx
    have hcard : D.card = E.card := by
      dsimp [D]
      exact Finset.card_map _
    have hhalfD : 2 * D.card ≤ C.card := by
      simpa only [hcard] using hE
    have hreference := hexpand D hDC hhalfD
    rw [hcard] at hreference
    have hchanged :=
      boundary_le_boundary_add_componentGeneratorDisagreement
        σref σact C D hDC
    have hcompleted :=
      SoficGroups.KunResidualExpanderDecomposition.original_boundary_le_completed_add_component_boundary
        σact C τ hτ E
    have hcomponent :=
      boundary_le_boundary_add_componentGeneratorDisagreement
        σact σref C C (Finset.Subset.refl C)
    rw [componentGeneratorDisagreement_comm C σact σref] at hcomponent
    have hchangedR :
        (SoficGroups.boundary σref D : ℝ) ≤
          (SoficGroups.boundary σact D : ℝ) +
            (componentGeneratorDisagreement C σref σact : ℝ) := by
      exact_mod_cast hchanged
    have hcompletedR :
        (SoficGroups.boundary σact D : ℝ) ≤
          (SoficGroups.boundary τ E : ℝ) +
            (SoficGroups.boundary σact C : ℝ) := by
      change
        ((SoficGroups.boundary σact
          (E.map (Function.Embedding.subtype
            (fun x : V => x ∈ C))) : ℕ) : ℝ) ≤ _
      exact_mod_cast hcompleted
    have hcomponentR :
        (SoficGroups.boundary σact C : ℝ) ≤
          (SoficGroups.boundary σref C : ℝ) +
            (componentGeneratorDisagreement C σref σact : ℝ) := by
      exact_mod_cast hcomponent
    linarith
  intro E
  by_cases hE : 2 * E.card ≤ C.card
  · have hreal : (2 : ℝ) * (E.card : ℝ) ≤ (C.card : ℝ) := by
      exact_mod_cast hE
    rw [min_eq_left (by linarith)]
    exact hhalf E hE
  · let D : Finset {x : V // x ∈ C} := Finset.univ \ E
    have hcard : D.card + E.card = C.card := by
      dsimp [D]
      have h :=
        Finset.card_sdiff_add_card_eq_card (Finset.subset_univ E)
      simpa using h
    have hhalfD : 2 * D.card ≤ C.card := by
      omega
    have hsmall := hhalf D hhalfD
    have hrealD : (D.card : ℝ) = (C.card : ℝ) - (E.card : ℝ) := by
      have hreal :
          (D.card : ℝ) + (E.card : ℝ) = (C.card : ℝ) := by
        exact_mod_cast hcard
      linarith
    have hrealE : (C.card : ℝ) < 2 * (E.card : ℝ) := by
      exact_mod_cast Nat.lt_of_not_ge hE
    rw [min_eq_right (by linarith)]
    rw [hrealD] at hsmall
    have hcomplement :
        SoficGroups.boundary τ D = SoficGroups.boundary τ E := by
      simpa only [D] using
        SoficGroups.KunResidualExpanderDecomposition.boundary_complement τ E
    rw [hcomplement] at hsmall
    exact hsmall

theorem completedRestriction_additive_expansion_of_reference
    {V ι : Type*} [Fintype V] [Fintype ι] [DecidableEq V]
    (σref σact : ι → Equiv.Perm V) (C : Finset V)
    (γ : ℝ)
    (hexpand : ∀ E : Finset V, E ⊆ C →
      2 * E.card ≤ C.card →
        γ * (E.card : ℝ) ≤ (SoficGroups.boundary σref E : ℝ)) :
    ∀ E : Finset {x : V // x ∈ C},
      γ * min (E.card : ℝ) ((C.card : ℝ) - E.card) -
        ((SoficGroups.boundary σref C : ℝ) +
          2 * (componentGeneratorDisagreement C σref σact : ℝ)) ≤
        (SoficGroups.boundary
          (fun i =>
            SoficGroups.MatchedComponentCompletion.completedRestriction
              (σact i) C) E : ℝ) := by
  apply completed_actual_component_additive_expansion_of_reference
    σref σact C
    (fun i =>
      SoficGroups.MatchedComponentCompletion.completedRestriction
        (σact i) C)
  · intro i x hx hy
    exact SoficGroups.MatchedComponentCompletion.completedRestriction_apply_of_mem
      (σact i) C x hx hy
  · exact hexpand

def normalizedReferenceCompletionError
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (C : Finset V) (σref σact : ι → Equiv.Perm V) : ℝ :=
  ((SoficGroups.boundary σref C : ℝ) +
    2 * (componentGeneratorDisagreement C σref σact : ℝ)) /
      (C.card : ℝ)

theorem normalizedReferenceCompletionError_tendsto_zero
    (V : ℕ → Type*) [∀ n, DecidableEq (V n)]
    (ι : Type*) [Fintype ι]
    (C : (n : ℕ) → Finset (V n))
    (σref σact : (n : ℕ) → ι → Equiv.Perm (V n))
    (hboundary : Tendsto
      (fun n =>
        (SoficGroups.boundary (σref n) (C n) : ℝ) /
          (C n).card)
      atTop (nhds 0))
    (hdisagreement : Tendsto
      (fun n =>
        (componentGeneratorDisagreement
          (C n) (σref n) (σact n) : ℝ) / (C n).card)
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        normalizedReferenceCompletionError (C n) (σref n) (σact n))
      atTop (nhds 0) := by
  have hsum :=
    hboundary.add (hdisagreement.const_mul (2 : ℝ))
  simpa only [normalizedReferenceCompletionError, add_div,
    mul_div_assoc, zero_add, mul_zero] using hsum

theorem exists_vanishing_completedRestriction_additive_expansion_of_reference
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (ι : Type*) [Fintype ι]
    (C : (n : ℕ) → Finset (V n))
    (hC : ∀ n, (C n).Nonempty)
    (σref σact : (n : ℕ) → ι → Equiv.Perm (V n))
    (γ : ℝ)
    (hexpand : ∀ n, ∀ E : Finset (V n), E ⊆ C n →
      2 * E.card ≤ (C n).card →
        γ * (E.card : ℝ) ≤
          (SoficGroups.boundary (σref n) E : ℝ))
    (hboundary : Tendsto
      (fun n =>
        (SoficGroups.boundary (σref n) (C n) : ℝ) /
          (C n).card)
      atTop (nhds 0))
    (hdisagreement : Tendsto
      (fun n =>
        (componentGeneratorDisagreement
          (C n) (σref n) (σact n) : ℝ) / (C n).card)
      atTop (nhds 0)) :
    ∃ a : ℕ → ℝ,
      (∀ n, 0 ≤ a n) ∧
      Tendsto a atTop (nhds 0) ∧
      ∀ n, ∀ E : Finset {x : V n // x ∈ C n},
        γ * min (E.card : ℝ)
          ((Fintype.card {x : V n // x ∈ C n} : ℝ) - E.card) -
            a n * Fintype.card {x : V n // x ∈ C n} ≤
          (SoficGroups.boundary
            (fun i =>
              SoficGroups.MatchedComponentCompletion.completedRestriction
                (σact n i) (C n)) E : ℝ) := by
  let a : ℕ → ℝ :=
    fun n => normalizedReferenceCompletionError
      (C n) (σref n) (σact n)
  refine ⟨a, ?_, ?_, ?_⟩
  · intro n
    unfold a normalizedReferenceCompletionError
    apply div_nonneg
    · positivity
    · exact Nat.cast_nonneg _
  · exact normalizedReferenceCompletionError_tendsto_zero
      V ι C σref σact hboundary hdisagreement
  · intro n E
    have hcard : ((C n).card : ℝ) ≠ 0 := by
      exact_mod_cast Finset.card_ne_zero.mpr (hC n)
    have h :=
      completedRestriction_additive_expansion_of_reference
        (σref n) (σact n) (C n) γ (hexpand n) E
    simpa only [a, normalizedReferenceCompletionError,
      Fintype.card_coe, div_mul_cancel₀ _ hcard] using h

theorem componentGeneratorDisagreement_le_card_mul_component_bad
    {V ι : Type*} [Fintype ι] [DecidableEq V]
    (C B : Finset V)
    (σref σact : ι → Equiv.Perm V)
    (hbad : ∀ i (x : V), x ∈ C →
      σref i x ≠ σact i x → x ∈ B) :
    componentGeneratorDisagreement C σref σact ≤
      Fintype.card ι * (C ∩ B).card := by
  classical
  unfold componentGeneratorDisagreement
  calc
    (∑ i : ι, (C.filter fun x => σref i x ≠ σact i x).card) ≤
        ∑ _i : ι, (C ∩ B).card := by
          apply Finset.sum_le_sum
          intro i _
          apply Finset.card_le_card
          intro x hx
          obtain ⟨hxC, hdisagree⟩ := Finset.mem_filter.mp hx
          exact Finset.mem_inter.mpr
            ⟨hxC, hbad i x hxC hdisagree⟩
    _ = Fintype.card ι * (C ∩ B).card := by
          simp

theorem componentGeneratorDisagreement_density_tendsto_zero_of_component_bad
    (V : ℕ → Type*) [∀ n, DecidableEq (V n)]
    (ι : Type*) [Fintype ι]
    (C B : (n : ℕ) → Finset (V n))
    (σref σact : (n : ℕ) → ι → Equiv.Perm (V n))
    (hbad : ∀ n i (x : V n), x ∈ C n →
      σref n i x ≠ σact n i x → x ∈ B n)
    (hdensity : Tendsto
      (fun n => (((C n ∩ B n).card : ℝ) / (C n).card))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        (componentGeneratorDisagreement
          (C n) (σref n) (σact n) : ℝ) / (C n).card)
      atTop (nhds 0) := by
  have hlimit : Tendsto
      (fun n =>
        (Fintype.card ι : ℝ) *
          (((C n ∩ B n).card : ℝ) / (C n).card))
      atTop (nhds 0) := by
    simpa using hdensity.const_mul (Fintype.card ι : ℝ)
  apply squeeze_zero'
    (Eventually.of_forall fun n =>
      div_nonneg (Nat.cast_nonneg _)
        (Nat.cast_nonneg _))
    (Eventually.of_forall fun n => ?_)
    hlimit
  have hnat :=
    componentGeneratorDisagreement_le_card_mul_component_bad
      (C n) (B n) (σref n) (σact n) (hbad n)
  have hreal :
      (componentGeneratorDisagreement
        (C n) (σref n) (σact n) : ℝ) ≤
        (Fintype.card ι : ℝ) *
          ((C n ∩ B n).card : ℝ) := by
    exact_mod_cast hnat
  calc
    (componentGeneratorDisagreement
      (C n) (σref n) (σact n) : ℝ) / (C n).card ≤
        ((Fintype.card ι : ℝ) *
          ((C n ∩ B n).card : ℝ)) / (C n).card :=
          div_le_div_of_nonneg_right hreal (Nat.cast_nonneg _)
    _ = (Fintype.card ι : ℝ) *
          (((C n ∩ B n).card : ℝ) / (C n).card) := by ring

theorem exists_vanishing_completedRestriction_additive_expansion_of_selected_bad
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (ι : Type*) [Fintype ι]
    (C B : (n : ℕ) → Finset (V n))
    (hC : ∀ n, (C n).Nonempty)
    (σref σact : (n : ℕ) → ι → Equiv.Perm (V n))
    (γ : ℝ)
    (hexpand : ∀ n, ∀ E : Finset (V n), E ⊆ C n →
      2 * E.card ≤ (C n).card →
        γ * (E.card : ℝ) ≤
          (SoficGroups.boundary (σref n) E : ℝ))
    (hbad : ∀ n i (x : V n), x ∈ C n →
      σref n i x ≠ σact n i x → x ∈ B n)
    (hboundary : Tendsto
      (fun n =>
        (SoficGroups.boundary (σref n) (C n) : ℝ) /
          (C n).card)
      atTop (nhds 0))
    (hbad_density : Tendsto
      (fun n =>
        (((C n ∩ B n).card : ℝ) / (C n).card))
      atTop (nhds 0)) :
    ∃ a : ℕ → ℝ,
      (∀ n, 0 ≤ a n) ∧
      Tendsto a atTop (nhds 0) ∧
      ∀ n, ∀ E : Finset {x : V n // x ∈ C n},
        γ * min (E.card : ℝ)
          ((Fintype.card {x : V n // x ∈ C n} : ℝ) - E.card) -
            a n * Fintype.card {x : V n // x ∈ C n} ≤
          (SoficGroups.boundary
            (fun i =>
              SoficGroups.MatchedComponentCompletion.completedRestriction
                (σact n i) (C n)) E : ℝ) := by
  apply exists_vanishing_completedRestriction_additive_expansion_of_reference
    V ι C hC σref σact γ hexpand hboundary
  exact componentGeneratorDisagreement_density_tendsto_zero_of_component_bad
    V ι C B σref σact hbad hbad_density

end KunActualFirstStageReferenceExpansion

namespace SourceProductThroughAlpha

open Filter Topology
open scoped BigOperators

theorem source_u_conjugated_product_generator
    (g : SoficGroups.prefixElementaryGroup
      SoficGroups.alphaPrefixCode) :
    SoficGroups.ThompsonPrefixInsertion.sourceCompressedLocalProductEmbedding
        (sourceCompressionUAlphaEquiv g, 1) =
      SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement *
        SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion g *
          (SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)⁻¹ := by
  apply Subtype.ext
  change
    (sourceCompressionUAlphaEquiv g : SoficGroups.BinaryLeavittˣ) * 1 =
      SoficGroups.compressionU *
        (g : SoficGroups.BinaryLeavittˣ) *
          SoficGroups.compressionU⁻¹
  rw [mul_one]
  change
    (MulAut.conj SoficGroups.compressionU)
        (g : SoficGroups.BinaryLeavittˣ) =
      SoficGroups.compressionU *
        (g : SoficGroups.BinaryLeavittˣ) *
          SoficGroups.compressionU⁻¹
  rw [MulAut.conj_apply]

theorem source_u_transported_reference_half_expansion
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (QΓ : (n : ℕ) → Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (gamma : ℝ)
    (hexpand : ∀ n, ∀ C ∈ (QΓ n).parts,
      ∀ E : Finset (Fin (A.model n).size), E ⊆ C →
        2 * E.card ≤ C.card →
          gamma * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action
                  (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                    i)) E : ℝ)) :
    ∀ n, ∀ C ∈
      (SoficGroups.transportedUnivFinpartition
        (QΓ n)
        ((A.model n).action
          SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)).parts,
      ∀ E : Finset (Fin (A.model n).size), E ⊆ C →
        2 * E.card ≤ C.card →
          gamma * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action
                    SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement *
                  (A.model n).action
                    (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                      i) *
                    ((A.model n).action
                      SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)⁻¹)
              E : ℝ) := by
  intro n
  exact
    SoficGroups.KunTransportedAmbientOverlap.transportedUnivFinpartition_half_expansion
      (QΓ n)
      (fun i : ↥SΓ =>
        (A.model n).action
          (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion i))
      ((A.model n).action
        SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)
      gamma (hexpand n)

theorem source_u_transported_reference_boundary_density_tendsto_zero
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (QΓ : (n : ℕ) → Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (QΓ n).parts,
          (SoficGroups.boundary
            (fun i : ↥SΓ =>
              (A.model n).action
                (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                  i)) C : ℝ)) /
            (A.model n).size)
      atTop (𝓝 0)) :
    Tendsto
      (fun n =>
        (∑ C ∈
          (SoficGroups.transportedUnivFinpartition
            (QΓ n)
            ((A.model n).action
              SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)).parts,
          (SoficGroups.boundary
            (fun i : ↥SΓ =>
              (A.model n).action
                  SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement *
                (A.model n).action
                  (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                    i) *
                  ((A.model n).action
                    SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)⁻¹)
            C : ℝ)) /
              (A.model n).size)
      atTop (𝓝 0) := by
  have h :=
    SoficGroups.KunTransportedAmbientOverlap.transported_partition_boundary_density_tendsto_zero
      (V := fun n => Fin (A.model n).size)
      QΓ
      (fun n (i : ↥SΓ) =>
        (A.model n).action
          (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion i))
      (fun n =>
        (A.model n).action
          SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)
      (by simpa only [Fintype.card_fin] using hboundary)
  simpa only [Fintype.card_fin] using h

end SourceProductThroughAlpha

namespace KunLiteralSourceSelectedComponents

open Filter Topology
open SoficGroups.CanonicalProductRadiusBadMatchedCapture
open SoficGroups.SourceProductThroughAlpha
open scoped BigOperators Pointwise

def sourceCompressionPermutation
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (n : ℕ) : Equiv.Perm (Fin (A.model n).size) :=
  (A.model n).action
    SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement

def sourceTransportedReferenceGenerators
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (n : ℕ) : ↥S → Equiv.Perm (Fin (A.model n).size) :=
  fun g => sourceCompressionPermutation A n *
    (A.model n).action
      (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion g) *
    (sourceCompressionPermutation A n)⁻¹

def sourceTransportedPartition
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (Q : (n : ℕ) →
      Finpartition (Finset.univ : Finset (Fin (A.model n).size)))
    (n : ℕ) :
    Finpartition (Finset.univ : Finset (Fin (A.model n).size)) :=
  SoficGroups.transportedUnivFinpartition
    (Q n) (sourceCompressionPermutation A n)

noncomputable def sourceGeneratorFamilyConjugacyBad
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (n : ℕ) : Finset (Fin (A.model n).size) :=
  S.biUnion fun g => sourceConjugacyDisagreementBad A
    SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement
    (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion g) n

theorem sourceGeneratorFamilyConjugacyBad_density_tendsto_zero
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) :
    Tendsto
      (fun n =>
        ((sourceGeneratorFamilyConjugacyBad A S n).card : ℝ) /
          (A.model n).size)
      atTop (nhds 0) := by
  classical
  have h := SoficGroups.finite_union_bad_density_tendsto_zero S
    (fun n => (Finset.univ : Finset (Fin (A.model n).size)))
    (fun n g => sourceConjugacyDisagreementBad A
      SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement
      (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion g) n)
    (fun g _ => by
      simpa using sourceConjugacyDisagreementBad_density_tendsto_zero A
        SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement
        (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion g))
  simpa [sourceGeneratorFamilyConjugacyBad] using h

noncomputable def sourceSelectedRadiusBad
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure
      (S : Set
        (SoficGroups.prefixElementaryGroup
          SoficGroups.alphaPrefixCode)) = ⊤)
    (F : Finset
      (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
        SoficGroups.ThompsonPrefixLocal.sourceLocalWord))
    (n k : ℕ) : Finset (Fin (A.model n).size) := by
  classical
  let SK :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset S
  let AP :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation A
  exact
    SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
      AP SK
      (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_inv_mem
        S hsymmetric)
      (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_closure
        S hgenerates)
      F n k ∪ sourceGeneratorFamilyConjugacyBad A S n

end KunLiteralSourceSelectedComponents

namespace SourceGuardedCanonicalSelection

open Filter Topology
open scoped BigOperators Pointwise symmDiff

abbrev SourceK :=
  SoficGroups.prefixElementaryGroup SoficGroups.alphaZeroPrefixCode

abbrev SourceJ :=
  SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
    SoficGroups.ThompsonPrefixLocal.sourceLocalWord

noncomputable def guardedCanonicalProductRadiusBad
    [DecidableEq SourceK] [DecidableEq SourceJ]
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ SΓ, g⁻¹ ∈ SΓ)
    (hgenerates : Subgroup.closure
      (SΓ : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤)
    (F : Finset SourceJ)
    (E : (n : ℕ) → ℕ → Finset (Fin (A.model n).size))
    (n k : ℕ) : Finset (Fin (A.model n).size) :=
  SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
    (SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation A)
    (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset SΓ)
    (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_inv_mem
      SΓ hsymmetric)
    (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_closure
      SΓ hgenerates)
    F n k ∪ E n k

theorem exists_source_guarded_canonical_selected_components_of_retained_matching
    [DecidableEq SourceK] [DecidableEq SourceJ]
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hone : 1 ∈ SΓ)
    (hsymmetric : ∀ g ∈ SΓ, g⁻¹ ∈ SΓ)
    (hgenerates : Subgroup.closure
      (SΓ : Set
        (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) =
          ⊤)
    (P Q : (n : ℕ) → Finpartition
      (Finset.univ : Finset (Fin (A.model n).size)))
    {κ : Type*} [Fintype κ]
    (σ : (n : ℕ) → κ → Equiv.Perm (Fin (A.model n).size))
    (R : (n : ℕ) → Finset (Finset (Fin (A.model n).size)))
    (hR : ∀ n, R n ⊆ (P n).parts)
    (D : (n : ℕ) → Finset (Fin (A.model n).size) →
      Finset (Fin (A.model n).size))
    (hD : ∀ n C, C ∈ R n → D n C ∈ (Q n).parts)
    (H eta : ℕ → ℝ)
    (hH : Tendsto H atTop (nhds 0))
    (heta : Tendsto eta atTop (nhds 0))
    (hmajor : ∀ n,
      eta n ≤ (1 : ℝ) / 2 →
      2 * (Real.exp (H n) - 1 + 2 * eta n) < 1 →
        ∀ C, C ∈ R n →
          (D n C).card < 2 * (C ∩ D n C).card)
    (hdiscard : Tendsto
      (fun n =>
        ((((Finset.univ : Finset (Fin (A.model n).size)) \
          SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
            (A.model n).size))
      atTop (nhds 0))
    (hsymm : Tendsto
      (fun n =>
        ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) /
          (A.model n).size)
      atTop (nhds 0))
    (F : Finset SourceJ)
    (E : (n : ℕ) → ℕ → Finset (Fin (A.model n).size))
    (hE : ∀ k, Tendsto
      (fun n => ((E n k).card : ℝ) / (A.model n).size)
      atTop (nhds 0))
    (hsource : Tendsto
      (fun n =>
        (∑ C ∈ (Q n).parts,
          (SoficGroups.boundary
            (fun i : ↥SΓ =>
              (A.model n).action
                (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                  i)) C : ℝ)) /
            (A.model n).size)
      atTop (nhds 0))
    (hboundary : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ)) /
          (A.model n).size)
      atTop (nhds 0))
    (N₀ : ℕ) :
    ∃ (N : ℕ) (r : ℕ → ℕ)
      (C : (n : ℕ) → Finset (Fin (A.model (n + N)).size)),
      N₀ ≤ N ∧
      (∀ n, eta (n + N) ≤ (1 : ℝ) / 2) ∧
      (∀ n,
        2 * (Real.exp (H (n + N)) - 1 +
          2 * eta (n + N)) < 1) ∧
      Tendsto r atTop atTop ∧
      (∀ n, C n ∈ R (n + N)) ∧
      Tendsto
        (fun n =>
          (SoficGroups.boundary (σ (n + N)) (C n) : ℝ) /
            (C n).card)
        atTop (nhds 0) ∧
      Tendsto
        (fun n =>
          (((C n ∩ SoficGroups.matchedRadiusBad
            (P (n + N))
            (SoficGroups.CanonicalProductRadiusBadMatchedCapture.sourceProductRadiusLabels
              (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset SΓ)
              F (r n))
            (((SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation
              A).model (n + N)).action)
            (guardedCanonicalProductRadiusBad
              A SΓ hsymmetric hgenerates F E (n + N) (r n))).card : ℝ) /
                (C n).card))
        atTop (nhds 0) ∧
      Tendsto (fun n => (C n).card) atTop atTop := by
  classical
  letI : Infinite SourceK :=
    SoficGroups.KunActualCompressedSourceGroupFoundations.alphaZeroPrefixElementaryGroup_infinite
  have hnonempty (n : ℕ) : Nonempty (Fin (A.model n).size) :=
    Fin.pos_iff_nonempty.mp (A.model n).size_pos
  letI : ∀ n, Nonempty (Fin (A.model n).size) := hnonempty
  let SK : Finset SourceK :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset SΓ
  let Ap : SoficGroups.SoficApproximation (SourceK × SourceJ) :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation A
  let I : ℕ → Finset (SourceK × SourceJ) := fun k =>
    SoficGroups.CanonicalProductRadiusBadMatchedCapture.sourceProductRadiusLabels
      SK F k
  let w : (n : ℕ) → SourceK × SourceJ →
      Equiv.Perm (Fin (A.model n).size) :=
    fun n z => (Ap.model n).action z
  let B : (n : ℕ) → ℕ → Finset (Fin (A.model n).size) :=
    fun n k => guardedCanonicalProductRadiusBad
      A SΓ hsymmetric hgenerates F E n k
  have hSKone : 1 ∈ SK :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_one_mem
      SΓ hone
  have hSKsym : ∀ g ∈ SK, g⁻¹ ∈ SK :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_inv_mem
      SΓ hsymmetric
  have hSKgen : Subgroup.closure (SK : Set SourceK) = ⊤ :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_closure
      SΓ hgenerates
  have hU (n : ℕ) :
      (Finset.univ : Finset (Fin (A.model n).size)).Nonempty :=
    Finset.univ_nonempty
  have hword (k : ℕ) : Tendsto
      (fun n =>
        ((∑ z ∈ I k,
          (SoficGroups.partitionWordCrossing
            (Q n) (w n z)).card : ℕ) : ℝ) /
            (Finset.univ : Finset (Fin (A.model n).size)).card)
      atTop (nhds 0) := by
    simpa only [I, w, Ap, SK, Finset.card_univ,
      Fintype.card_fin,
      SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation_model_size] using
      SoficGroups.SourceProductThroughAlpha.source_canonical_product_radius_crossing_density_tendsto_zero
        A SΓ hsymmetric hgenerates Q hsource F k
  have hbad (k : ℕ) : Tendsto
      (fun n =>
        ((((Finset.univ : Finset (Fin (A.model n).size)) ∩
          B n k).card : ℝ) /
            (Finset.univ : Finset (Fin (A.model n).size)).card))
      atTop (nhds 0) := by
    have hcanonical :=
      SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad_density_tendsto_zero
        Ap SK hSKsym hSKgen F k
    have hcanon' : Tendsto
        (fun n =>
          ((SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
            Ap SK hSKsym hSKgen F n k).card : ℝ) /
              (A.model n).size)
        atTop (nhds 0) := by
      exact hcanonical
    have hlimit : Tendsto
        (fun n =>
          ((SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
            Ap SK hSKsym hSKgen F n k).card : ℝ) /
              (A.model n).size +
            ((E n k).card : ℝ) / (A.model n).size)
        atTop (nhds 0) := by
      simpa using hcanon'.add (hE k)
    refine squeeze_zero (fun n => by positivity) ?_ hlimit
    intro n
    have hnat := Finset.card_union_le
      (SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
        Ap SK hSKsym hSKgen F n k) (E n k)
    have hreal :
        (((SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
          Ap SK hSKsym hSKgen F n k ∪ E n k).card : ℕ) : ℝ) ≤
        ((SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
          Ap SK hSKsym hSKgen F n k).card : ℝ) +
          ((E n k).card : ℝ) := by
      exact_mod_cast hnat
    simp only [Finset.univ_inter, Finset.card_univ, Fintype.card_fin]
    change
      ((B n k).card : ℝ) / (A.model n).size ≤ _
    change
      ((SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
        Ap SK hSKsym hSKgen F n k ∪ E n k).card : ℝ) /
        (A.model n).size ≤ _
    calc
      ((SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
        Ap SK hSKsym hSKgen F n k ∪ E n k).card : ℝ) /
        (A.model n).size ≤
          (((SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
            Ap SK hSKsym hSKgen F n k).card : ℝ) +
            ((E n k).card : ℝ)) /
            (A.model n).size :=
              div_le_div_of_nonneg_right hreal (by positivity)
      _ = ((SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
            Ap SK hSKsym hSKgen F n k).card : ℝ) /
              (A.model n).size +
            ((E n k).card : ℝ) / (A.model n).size := by ring
  have hrealize :
      ∀ n k (C : Finset (Fin (A.model n).size)), C ∈ R n →
        ∀ x ∈ C,
          x ∉ SoficGroups.matchedRadiusBad
            (P n) (I k) (w n) (B n k) →
            ∃ f : SourceK → Fin (A.model n).size,
              Set.MapsTo f (↑(SK ^ (k / 2)) : Set SourceK)
                (↑C : Set (Fin (A.model n).size)) ∧
              Set.InjOn f (↑(SK ^ (k / 2)) : Set SourceK) := by
    intro n k C hCR x hx hgood
    have hgoodcanonical :
        x ∉ SoficGroups.matchedRadiusBad
          (P n) (I k) (w n)
          (SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
            Ap SK hSKsym hSKgen F n k) := by
      intro hxcan
      apply hgood
      unfold SoficGroups.matchedRadiusBad at hxcan ⊢
      rcases Finset.mem_union.mp hxcan with hxB | hxW
      · apply Finset.mem_union_left
        change x ∈
          SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
            Ap SK hSKsym hSKgen F n k ∪ E n k
        exact Finset.mem_union_left _ hxB
      · exact Finset.mem_union_right _ hxW
    exact
      SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonical_source_matched_component_cayley_ball_realization
        Ap SK hSKone hSKsym hSKgen F n k (P n) C
        (hR n hCR) x hx hgoodcanonical
  have hdiscard' : Tendsto
      (fun n =>
        ((((Finset.univ : Finset (Fin (A.model n).size)) \
          SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
            (Finset.univ : Finset (Fin (A.model n).size)).card))
      atTop (nhds 0) := by
    simpa only [Finset.card_univ, Fintype.card_fin] using hdiscard
  have hsymm' : Tendsto
      (fun n =>
        ((∑ C ∈ R n, (C ∆ D n C).card : ℕ) : ℝ) /
          (Finset.univ : Finset (Fin (A.model n).size)).card)
      atTop (nhds 0) := by
    simpa only [Finset.card_univ, Fintype.card_fin] using hsymm
  have hboundary' : Tendsto
      (fun n =>
        (∑ C ∈ (P n).parts, (SoficGroups.boundary (σ n) C : ℝ)) /
          (Finset.univ : Finset (Fin (A.model n).size)).card)
      atTop (nhds 0) := by
    simpa only [Finset.card_univ, Fintype.card_fin] using hboundary
  have hselected :=
    SoficGroups.KunResidualRetainedSelection.exists_matched_slow_diagonal_large_components_on_source_scale_tail
      SK hSKone hSKgen σ
      (fun n => (Finset.univ : Finset (Fin (A.model n).size))) hU
      P Q R hR D hD H eta hH heta hmajor hdiscard' hsymm'
      I w hword B hbad hboundary' hrealize N₀
  simpa only [I, w, Ap, SK, B] using hselected

end SourceGuardedCanonicalSelection

namespace KunActualSourceURetainedNoPremise

open Filter Topology
open scoped BigOperators symmDiff

theorem exists_actual_source_u_retained_matching
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode)) :
    ∃ (SΓ : Finset
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode))
      (QΓ : (n : ℕ) →
        Finpartition (Finset.univ : Finset (Fin (A.model n).size)))
      (γΓ : ℝ)
      (H eta r : ℕ → ℝ)
      (R : (n : ℕ) → Finset (Finset (Fin (A.model n).size))),
      1 ∈ SΓ ∧
      (∀ g ∈ SΓ, g⁻¹ ∈ SΓ) ∧
      Subgroup.closure
        (SΓ : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode)) = ⊤ ∧
      0 < γΓ ∧
      (∀ n, ∀ C ∈ (QΓ n).parts,
        ∀ E : Finset (Fin (A.model n).size),
          E ⊆ C →
          2 * E.card ≤ C.card →
          γΓ * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action
                  (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                    (i : SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaPrefixCode))) E : ℝ)) ∧
      Tendsto
        (fun n =>
          (∑ C ∈ (QΓ n).parts,
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action
                  (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                    (i : SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaPrefixCode))) C : ℝ)) /
                (A.model n).size)
        atTop (𝓝 0) ∧
      (∀ n, 0 < H n) ∧
      Tendsto H atTop (𝓝 0) ∧
      (∀ n, 0 < eta n) ∧
      (∀ n, eta n < 1) ∧
      Tendsto eta atTop (𝓝 0) ∧
      (∀ n, r n ∈ Set.Ico 0 (H n)) ∧
      (∀ n,
        R n =
          SoficGroups.SourceRetainedActualMatching.retainedTransportedComponents
            (QΓ n)
            ((A.model n).action
              SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)
            (H n) (r n) (eta n)) ∧
      (∀ n,
        R n ⊆
          (SoficGroups.transportedUnivFinpartition
            (QΓ n)
            ((A.model n).action
              SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)).parts) ∧
      (∀ n C, C ∈ R n →
        SoficGroups.maximumOverlapPart (QΓ n) C ∈ (QΓ n).parts) ∧
      (∀ n, eta n ≤ (1 : ℝ) / 2 →
        2 * (Real.exp (H n) - 1 + 2 * eta n) < 1 →
          ∀ C, C ∈ R n →
            (SoficGroups.maximumOverlapPart (QΓ n) C).card <
              2 * (C ∩ SoficGroups.maximumOverlapPart
                (QΓ n) C).card) ∧
      Tendsto
        (fun n =>
          (((Finset.univ : Finset (Fin (A.model n).size)) \
            SoficGroups.matchedRetainedSupport (R n)).card : ℝ) /
              (A.model n).size)
        atTop (𝓝 0) ∧
      Tendsto
        (fun n =>
          ((∑ C ∈ R n,
            (C ∆ SoficGroups.maximumOverlapPart
              (QΓ n) C).card : ℕ) : ℝ) /
                (A.model n).size)
        atTop (𝓝 0) ∧
      (∀ n, 2 * (Real.exp (H n) - 1 + 2 * eta n) < 1 →
        Set.InjOn (SoficGroups.maximumOverlapPart (QΓ n))
          ((R n : Finset (Finset (Fin (A.model n).size))) :
            Set (Finset (Fin (A.model n).size)))) := by
  classical
  obtain ⟨SΓ, SG, QΓ, QG, γΓ, γG, _hSG,
      honeΓ, hsymmetricΓ, hgeneratesΓ,
      _honeG, hsymmetricG, hgeneratesG,
      _hfaithful, hpositive,
      hγΓ, hγG, hexpandΓ, hexpandG,
      hboundaryΓ, hboundaryG⟩ :=
    SoficGroups.KunUnconditionalActualSourceDecomposition.exists_unconditional_actual_source_dual_finpartition_sequences A
  have hexpandΓ' :
      ∀ n, ∀ C ∈ (QΓ n).parts,
        ∀ E : Finset (Fin (A.model n).size),
          E ⊆ C →
          2 * E.card ≤ C.card →
          γΓ * (E.card : ℝ) ≤
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action
                  (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                    (i : SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaPrefixCode))) E : ℝ) :=
    hexpandΓ
  have hboundaryΓ' :
      Tendsto
        (fun n =>
          (∑ C ∈ (QΓ n).parts,
            (SoficGroups.boundary
              (fun i : ↥SΓ =>
                (A.model n).action
                  (SoficGroups.SourceBothCompressionNormalization.sourceAlphaElement
                    (i : SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaPrefixCode))) C : ℝ)) /
                (A.model n).size)
        atTop (𝓝 0) :=
    hboundaryΓ
  obtain ⟨eta, H, hetapos, hetaone, _hetaanti, hetazero,
      hHpos, _hHanti, hHzero, hratio, hoverlap, hloss⟩ :=
    SoficGroups.KunActualBothTransportedOverlapScales.exists_source_both_capped_overlap_scales
        A SΓ hsymmetricΓ hgeneratesΓ QΓ γΓ hγΓ
        hexpandΓ' hboundaryΓ'
  have hoverlap' :
      ∀ j : Fin 2, Tendsto
        (fun n =>
          (∑ C ∈ SoficGroups.insufficientOverlapComponents
            (SoficGroups.transportedUnivFinpartition
              (QΓ n)
              ((A.model n).action
                (SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionTable
                  j)))
            (QΓ n) (eta n), (C.card : ℝ)) /
              (A.model n).size)
        atTop (𝓝 0) :=
    hoverlap
  have hloss' :
      ∀ j : Fin 2, Tendsto
        (fun n =>
          (∑ C ∈
            (SoficGroups.transportedUnivFinpartition
              (QΓ n)
              ((A.model n).action
                (SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionTable
                  j))).parts,
            ((C.card : ℝ) -
              ((C ∩ SoficGroups.maximumOverlapPart
                (QΓ n) C).card : ℝ))) /
                (A.model n).size)
        atTop (𝓝 0) :=
    hloss
  obtain ⟨r, hr, hvariance, hinverse⟩ :=
    SoficGroups.KunLiteralNineSourceCompletedCentralizerModels.exists_source_common_log_rank_with_ambient_midrank_variance
        A SΓ SG QΓ QG γG
        hsymmetricG hgeneratesG hpositive hγG hexpandG
        hboundaryΓ hboundaryG eta H
        (fun n => (hetapos n).le) hetaone hHpos
        hetazero hratio hoverlap' hloss'
  letI : ∀ n, Nonempty (Fin (A.model n).size) :=
    fun n => Fin.pos_iff_nonempty.mp (A.model n).size_pos
  let T : (n : ℕ) → Fin 2 → Equiv.Perm (Fin (A.model n).size) :=
    fun n j =>
      (A.model n).action
        (SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable j)
  have hvariance' :
      Tendsto
        (fun n =>
          (∑ C ∈ (QG n).parts,
            (C.card : ℝ) *
              SoficGroups.midrankVariance
                (SoficGroups.componentRankMassList C
                  (SoficGroups.SourceRetainedActualMatching.logarithmicComponentRank
                    (QΓ n) (H n) (r n)))) /
              Fintype.card (Fin (A.model n).size))
        atTop (𝓝 0) := by
    simpa only [
      SoficGroups.SourceRetainedActualMatching.logarithmicComponentRank,
      SoficGroups.SourceCommonOffsetMidrankEnergy.componentLogRank,
      SoficGroups.SourceCommonOffsetMidrankEnergy.realComponentSize,
      Fintype.card_fin] using hvariance
  have hinverse' :
      ∀ j : Fin 2, Tendsto
        (fun n =>
          ((SoficGroups.partitionWordCrossing
            (QG n) (T n j).symm).card : ℝ) /
              Fintype.card (Fin (A.model n).size))
        atTop (𝓝 0) := by
    intro j
    simpa only [T, Fintype.card_fin, Equiv.Perm.inv_def,
      SoficGroups.SourceBothCompressionNormalization.sourceCompressionTable,
      SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement,
      SoficGroups.SourceBothCompressionNormalization.sourceCompressionVElement,
      SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionTable,
      SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionU,
      SoficGroups.KunExactActualSourceAmbientGenerators.sourceCompressionV]
      using hinverse j
  have hoverlapNat :
      ∀ j : Fin 2, Tendsto
        (fun n =>
          ((∑ C ∈ SoficGroups.insufficientOverlapComponents
            (SoficGroups.transportedUnivFinpartition
              (QΓ n) (T n j))
            (QΓ n) (eta n), C.card : ℕ) : ℝ) /
              Fintype.card (Fin (A.model n).size))
        atTop (𝓝 0) := by
    intro j
    simpa only [T, Nat.cast_sum, Fintype.card_fin] using hoverlap j
  have hmatch :=
    SoficGroups.SourceRetainedActualMatching.retained_source_transport_matching_of_ambient_midrank_variance
        (fun n => Fin (A.model n).size)
        (Fin 2) QΓ QG T H r eta hHpos hHzero
        (fun n => (hetapos n).le) hetazero
        hvariance' hinverse' hoverlapNat (0 : Fin 2)
  have hTzero (n : ℕ) :
      T n (0 : Fin 2) =
        (A.model n).action
          SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement :=
    rfl
  let R : (n : ℕ) → Finset (Finset (Fin (A.model n).size)) :=
    fun n =>
      SoficGroups.SourceRetainedActualMatching.retainedTransportedComponents
        (QΓ n)
        ((A.model n).action
          SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)
        (H n) (r n) (eta n)
  obtain ⟨hparts, htarget, hmajor, hdiscard, hsymmetric, hinjective⟩ :=
    hmatch
  refine ⟨SΓ, QΓ, γΓ, H, eta, r, R,
    honeΓ, hsymmetricΓ, hgeneratesΓ, hγΓ,
    hexpandΓ', hboundaryΓ', hHpos, hHzero,
    hetapos, hetaone, hetazero, hr, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩
  · intro n
    rfl
  · simpa only [R, hTzero] using hparts
  · simpa only [R, hTzero] using htarget
  · simpa only [R, hTzero] using hmajor
  · simpa only [R, hTzero, Fintype.card_fin] using hdiscard
  · simpa only [R, hTzero, Fintype.card_fin] using hsymmetric
  · simpa only [R, hTzero] using hinjective

end KunActualSourceURetainedNoPremise

namespace KunLiteralSourceSelectedComponents

open Filter Topology
open scoped BigOperators Pointwise

noncomputable def sourceSelectedProductRadiusLabels
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (F : Finset
      (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
        SoficGroups.ThompsonPrefixLocal.sourceLocalWord))
    (k : ℕ) :
    Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaZeroPrefixCode ×
        SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
          SoficGroups.ThompsonPrefixLocal.sourceLocalWord) := by
  classical
  exact
    SoficGroups.CanonicalProductRadiusBadMatchedCapture.sourceProductRadiusLabels
      (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset S)
      F k

theorem exists_source_selected_components
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (F : Finset
      (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
        SoficGroups.ThompsonPrefixLocal.sourceLocalWord)) :
    ∃ (S : Finset
          (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
      (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
      (hgenerates : Subgroup.closure
        (S : Set
          (SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode)) = ⊤)
      (Q : (n : ℕ) →
        Finpartition (Finset.univ : Finset (Fin (A.model n).size)))
      (gamma : ℝ) (N : ℕ) (r : ℕ → ℕ)
      (C : (n : ℕ) → Finset (Fin (A.model (n + N)).size)),
      1 ∈ S ∧
      0 < gamma ∧
      Tendsto
        (fun n =>
          (∑ D ∈ (Q n).parts,
            (SoficGroups.boundary
              (fun i : ↥S =>
                (A.model n).action
                  (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                    i)) D : ℝ)) /
              (A.model n).size)
        atTop (𝓝 0) ∧
      Tendsto r atTop atTop ∧
      (∀ n, C n ∈ (sourceTransportedPartition A Q (n + N)).parts) ∧
      (∀ n, (C n).Nonempty) ∧
      (∀ n, ∀ D : Finset (Fin (A.model (n + N)).size),
        D ⊆ C n → 2 * D.card ≤ (C n).card →
          gamma * (D.card : ℝ) ≤
            (SoficGroups.boundary
              (sourceTransportedReferenceGenerators A S (n + N)) D : ℝ)) ∧
      Tendsto
        (fun n =>
          (SoficGroups.boundary
            (sourceTransportedReferenceGenerators A S (n + N))
            (C n) : ℝ) / (C n).card)
        atTop (𝓝 0) ∧
      Tendsto
        (fun n =>
          (((C n ∩ SoficGroups.matchedRadiusBad
            (sourceTransportedPartition A Q (n + N))
            (sourceSelectedProductRadiusLabels S F (r n))
            (((SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation
              A).model (n + N)).action)
            (sourceSelectedRadiusBad A S
              hsymmetric hgenerates F (n + N) (r n))).card : ℝ) /
                (C n).card))
        atTop (𝓝 0) ∧
      Tendsto (fun n => (C n).card) atTop atTop := by
  classical
  obtain ⟨S, Q, gamma, H, eta, _offset, R,
      hone, hsymmetric, hgenerates, hgamma,
      hexpand, hsource, _hHpositive, hH,
      _hetapositive, _hetaone, heta, _hoffset, _hRdef,
      hR, htarget, hmajor, hdiscard, hsymm, _hinjective⟩ :=
    SoficGroups.KunActualSourceURetainedNoPremise.exists_actual_source_u_retained_matching A
  have hsource' :
      Tendsto
        (fun n =>
          (∑ D ∈ (Q n).parts,
            (SoficGroups.boundary
              (fun i : ↥S =>
                (A.model n).action
                  (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                    i)) D : ℝ)) /
              (A.model n).size)
        atTop (𝓝 0) := by
    exact hsource
  let P : (n : ℕ) →
      Finpartition (Finset.univ : Finset (Fin (A.model n).size)) :=
    fun n => sourceTransportedPartition A Q n
  let sigma : (n : ℕ) → ↥S → Equiv.Perm (Fin (A.model n).size) :=
    fun n => sourceTransportedReferenceGenerators A S n
  let E : (n : ℕ) → ℕ → Finset (Fin (A.model n).size) :=
    fun n _ => sourceGeneratorFamilyConjugacyBad A S n
  have hRP : ∀ n, R n ⊆ (P n).parts := by
    simpa only [P, sourceTransportedPartition,
      sourceCompressionPermutation] using hR
  have hE : ∀ k, Tendsto
      (fun n => ((E n k).card : ℝ) / (A.model n).size)
      atTop (𝓝 0) := by
    intro k
    simpa only [E] using
      sourceGeneratorFamilyConjugacyBad_density_tendsto_zero A S
  have hboundary : Tendsto
      (fun n =>
        (∑ D ∈ (P n).parts,
          (SoficGroups.boundary (sigma n) D : ℝ)) /
            (A.model n).size)
      atTop (𝓝 0) := by
    change Tendsto
      (fun n =>
        (∑ D ∈
          (SoficGroups.transportedUnivFinpartition
            (Q n)
            ((A.model n).action
              SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)).parts,
          (SoficGroups.boundary
            (fun i : ↥S =>
              (A.model n).action
                  SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement *
                (A.model n).action
                  (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion i) *
                ((A.model n).action
                  SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)⁻¹)
            D : ℝ)) / (A.model n).size)
      atTop (𝓝 0)
    exact
      SoficGroups.SourceProductThroughAlpha.source_u_transported_reference_boundary_density_tendsto_zero
        A S Q hsource'
  obtain ⟨N, r, C, _hN, _hetaguard, _hexpguard,
      hr, hCR, hCboundary, hCbad, hCgrowth⟩ :=
    SoficGroups.SourceGuardedCanonicalSelection.exists_source_guarded_canonical_selected_components_of_retained_matching
        A S hone hsymmetric hgenerates
        P Q sigma R hRP
        (fun n D => SoficGroups.maximumOverlapPart (Q n) D)
        htarget H eta hH heta hmajor hdiscard hsymm
        F E hE hsource' hboundary 0
  have hCpart (n : ℕ) :
      C n ∈ (sourceTransportedPartition A Q (n + N)).parts := by
    exact hRP (n + N) (hCR n)
  have hCnonempty (n : ℕ) : (C n).Nonempty :=
    (sourceTransportedPartition A Q (n + N)).nonempty_of_mem_parts
      (hCpart n)
  have hexpand' :
      ∀ n, ∀ D ∈ (Q n).parts,
        ∀ E₀ : Finset (Fin (A.model n).size), E₀ ⊆ D →
          2 * E₀.card ≤ D.card →
            gamma * (E₀.card : ℝ) ≤
              (SoficGroups.boundary
                (fun i : ↥S =>
                  (A.model n).action
                    (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
                      i)) E₀ : ℝ) := by
    exact hexpand
  have htransported :=
    SoficGroups.SourceProductThroughAlpha.source_u_transported_reference_half_expansion
      A S Q gamma hexpand'
  refine ⟨S, hsymmetric, hgenerates, Q, gamma, N, r, C,
    hone, hgamma,
    hsource', hr, hCpart, hCnonempty, ?_, ?_, ?_, hCgrowth⟩
  · intro n D hDC hhalf
    change gamma * (D.card : ℝ) ≤
      (SoficGroups.boundary
        (fun i : ↥S =>
          (A.model (n + N)).action
              SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement *
            (A.model (n + N)).action
              (SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion i) *
            ((A.model (n + N)).action
              SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement)⁻¹)
        D : ℝ)
    exact htransported (n + N) (C n) (hCpart n) D hDC hhalf
  · simpa only [sigma] using hCboundary
  · simpa only [P, E, sourceTransportedPartition,
      sourceCompressionPermutation, sourceSelectedProductRadiusLabels,
      SoficGroups.SourceGuardedCanonicalSelection.guardedCanonicalProductRadiusBad,
      sourceSelectedRadiusBad] using hCbad

end KunLiteralSourceSelectedComponents

namespace SourceProductThroughAlpha

open scoped BigOperators

noncomputable def sourceCompressedGeneratorSubtypeEquiv
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode)) :
    (↥SΓ) ≃
      (↥(sourceCompressedGeneratingFinset SΓ)) := by
  classical
  refine
    { toFun := ?_
      invFun := ?_
      left_inv := ?_
      right_inv := ?_ }
  · intro g
    refine ⟨sourceCompressionUAlphaEquiv (g :
      SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode), ?_⟩
    change sourceCompressionUAlphaEquiv (g :
      SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode) ∈
        SΓ.image sourceCompressionUAlphaEquiv
    exact Finset.mem_image.mpr ⟨g, g.property, rfl⟩
  · intro k
    refine ⟨sourceCompressionUAlphaEquiv.symm (k :
      SoficGroups.prefixElementaryGroup SoficGroups.alphaZeroPrefixCode), ?_⟩
    have hk :
        (k : SoficGroups.prefixElementaryGroup
          SoficGroups.alphaZeroPrefixCode) ∈
          SΓ.image sourceCompressionUAlphaEquiv := by
      exact k.property
    obtain ⟨g, hg, heq⟩ := Finset.mem_image.mp hk
    rw [← heq, sourceCompressionUAlphaEquiv.symm_apply_apply]
    exact hg
  · intro g
    apply Subtype.ext
    exact sourceCompressionUAlphaEquiv.symm_apply_apply _
  · intro k
    apply Subtype.ext
    exact sourceCompressionUAlphaEquiv.apply_symm_apply _

theorem boundary_sourceCompressedGeneratorSubtypeEquiv
    {V : Type*} [DecidableEq V]
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (σ : ↥(sourceCompressedGeneratingFinset SΓ) → Equiv.Perm V)
    (E : Finset V) :
    SoficGroups.boundary
      (fun i : ↥SΓ =>
        σ (sourceCompressedGeneratorSubtypeEquiv SΓ i)) E =
      SoficGroups.boundary σ E := by
  classical
  unfold SoficGroups.boundary
  exact Equiv.sum_comp (sourceCompressedGeneratorSubtypeEquiv SΓ)
    (fun i : ↥(sourceCompressedGeneratingFinset SΓ) =>
      (E.filter fun x => σ i x ∉ E).card)

end SourceProductThroughAlpha

namespace KunGuardedCanonicalMatchedDensity

open Filter Topology

theorem matchedRadiusBad_mono_bad
    {V ι : Type*} [DecidableEq V]
    {U : Finset V} (P : Finpartition U)
    (I : Finset ι) (w : ι → Equiv.Perm V)
    {B B' : Finset V} (hB : B ⊆ B') :
    SoficGroups.matchedRadiusBad P I w B ⊆
      SoficGroups.matchedRadiusBad P I w B' := by
  intro x hx
  unfold SoficGroups.matchedRadiusBad at hx ⊢
  rcases Finset.mem_union.mp hx with hxB | hxcross
  · exact Finset.mem_union_left _ (hB hxB)
  · exact Finset.mem_union_right _ hxcross

theorem canonical_matched_density_of_guarded
    (V : ℕ → Type*) [∀ n, DecidableEq (V n)]
    (U : (n : ℕ) → Finset (V n))
    (P : (n : ℕ) → Finpartition (U n))
    {ι : Type*} (I : ℕ → Finset ι)
    (w : (n : ℕ) → ι → Equiv.Perm (V n))
    (B E C : (n : ℕ) → Finset (V n))
    (hguarded : Tendsto
      (fun n =>
        (((C n ∩ SoficGroups.matchedRadiusBad
          (P n) (I n) (w n) (B n ∪ E n)).card : ℝ) /
            (C n).card))
      atTop (nhds 0)) :
    Tendsto
      (fun n =>
        (((C n ∩ SoficGroups.matchedRadiusBad
          (P n) (I n) (w n) (B n)).card : ℝ) /
            (C n).card))
      atTop (nhds 0) := by
  refine squeeze_zero (fun n => by positivity) ?_ hguarded
  intro n
  have hsubset :
      C n ∩ SoficGroups.matchedRadiusBad
          (P n) (I n) (w n) (B n) ⊆
        C n ∩ SoficGroups.matchedRadiusBad
          (P n) (I n) (w n) (B n ∪ E n) := by
    intro x hx
    obtain ⟨hxC, hxB⟩ := Finset.mem_inter.mp hx
    exact Finset.mem_inter.mpr
      ⟨hxC, matchedRadiusBad_mono_bad
        (P n) (I n) (w n)
        (Finset.subset_union_left : B n ⊆ B n ∪ E n) hxB⟩
  have hcard :
      ((C n ∩ SoficGroups.matchedRadiusBad
        (P n) (I n) (w n) (B n)).card : ℝ) ≤
        (C n ∩ SoficGroups.matchedRadiusBad
          (P n) (I n) (w n) (B n ∪ E n)).card := by
    exact_mod_cast Finset.card_le_card hsubset
  exact div_le_div_of_nonneg_right hcard (by positivity)

end KunGuardedCanonicalMatchedDensity

namespace KunActualCanonicalSelectedPruning

open Filter Topology
open SoficGroups.MatchedComponentCompletion

theorem exists_actual_uniformly_expanding_pruned_selected_components
    {K J : Type*} [Group K] [Group J]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K)
    (ν : ℕ → ℕ)
    (Q : (n : ℕ) → Finpartition
      (Finset.univ : Finset (Fin (A.model (ν n)).size)))
    (C : (n : ℕ) → Finset (Fin (A.model (ν n)).size))
    (hC : ∀ n, C n ∈ (Q n).parts)
    (hlarge : Tendsto (fun n => (C n).card) atTop atTop)
    (γ : ℝ) (hγ : 0 < γ)
    (a : ℕ → ℝ)
    (ha : Tendsto a atTop (nhds 0))
    (hadd : ∀ n,
      ∀ E : Finset {x : Fin (A.model (ν n)).size // x ∈ C n},
        γ * min (E.card : ℝ)
            ((Fintype.card
              {x : Fin (A.model (ν n)).size // x ∈ C n} : ℝ) -
                E.card) -
          a n * Fintype.card
            {x : Fin (A.model (ν n)).size // x ∈ C n} ≤
          (SoficGroups.boundary
            (fun i : ↥S =>
              completedRestriction
                ((A.model (ν n)).action ((i : K), (1 : J)))
                (C n)) E : ℝ)) :
    ∃ (N : ℕ)
      (D : (n : ℕ) → Finset
        {x : Fin (A.model (ν (n + N))).size // x ∈ C (n + N)})
      (τ : (n : ℕ) → ↥S → Equiv.Perm
        {x : {y : Fin (A.model (ν (n + N))).size //
                y ∈ C (n + N)} //
          x ∈ (Finset.univ \ D n :
            Finset {y : Fin (A.model (ν (n + N))).size //
              y ∈ C (n + N)})}),
      (∀ n,
        (Finset.univ \ D n :
          Finset {x : Fin (A.model (ν (n + N))).size //
            x ∈ C (n + N)}).Nonempty) ∧
      Tendsto
        (fun n => ((D n).card : ℝ) / (C (n + N)).card)
        atTop (nhds 0) ∧
      Tendsto
        (fun n =>
          (Finset.univ \ D n :
            Finset {x : Fin (A.model (ν (n + N))).size //
              x ∈ C (n + N)}).card)
        atTop atTop ∧
      (∀ n (i : ↥S)
        (x : {y : Fin (A.model (ν (n + N))).size //
          y ∈ C (n + N)})
        (hx : x ∈ (Finset.univ \ D n :
          Finset {y : Fin (A.model (ν (n + N))).size //
            y ∈ C (n + N)}))
        (_hi : completedRestriction
          ((A.model (ν (n + N))).action ((i : K), (1 : J)))
          (C (n + N)) x ∈
            (Finset.univ \ D n :
              Finset {y : Fin (A.model (ν (n + N))).size //
                y ∈ C (n + N)})),
        ((τ n i ⟨x, hx⟩ :
          {z : {y : Fin (A.model (ν (n + N))).size //
                    y ∈ C (n + N)} //
            z ∈ (Finset.univ \ D n :
              Finset {y : Fin (A.model (ν (n + N))).size //
                y ∈ C (n + N)})}) :
          {y : Fin (A.model (ν (n + N))).size //
            y ∈ C (n + N)}) =
            completedRestriction
              ((A.model (ν (n + N))).action ((i : K), (1 : J)))
              (C (n + N)) x) ∧
      (∀ n,
        ∀ E : Finset
          {x : {y : Fin (A.model (ν (n + N))).size //
                  y ∈ C (n + N)} //
            x ∈ (Finset.univ \ D n :
              Finset {y : Fin (A.model (ν (n + N))).size //
                y ∈ C (n + N)})},
          (γ / 2) * min (E.card : ℝ)
            ((Fintype.card
              {x : {y : Fin (A.model (ν (n + N))).size //
                      y ∈ C (n + N)} //
                x ∈ (Finset.univ \ D n :
                  Finset {y : Fin (A.model (ν (n + N))).size //
                    y ∈ C (n + N)})} : ℝ) - E.card) ≤
            (SoficGroups.boundary (τ n) E : ℝ)) := by
  classical
  let ell : ℝ := γ / 2
  have hgap : ell < γ := by
    dsimp [ell]
    linarith
  have hgapPositive : 0 < γ - ell := sub_pos.mpr hgap
  let c : ℝ :=
    2 * (2 * (γ - ell) + (Fintype.card ↥S : ℝ))
  have hc : 0 < c := by
    dsimp [c]
    have hcard : (0 : ℝ) ≤ Fintype.card ↥S := by
      exact Nat.cast_nonneg _
    nlinarith
  have htarget : 0 < (γ - ell) ^ 2 / c :=
    div_pos (sq_pos_of_pos hgapPositive) hc
  have hsmallEvent : ∀ᶠ n in atTop,
      a n < (γ - ell) ^ 2 / c :=
    ha.eventually (gt_mem_nhds htarget)
  obtain ⟨N, hN⟩ := eventually_atTop.1 hsmallEvent
  have hsmall (n : ℕ) :
      2 * a (n + N) *
          (2 * (γ - ell) + (Fintype.card ↥S : ℝ)) ≤
        (γ - ell) ^ 2 := by
    have hratio : a (n + N) < (γ - ell) ^ 2 / c :=
      hN (n + N) (by omega)
    have hbound : a (n + N) * c < (γ - ell) ^ 2 :=
      (lt_div_iff₀ hc).mp hratio
    calc
      2 * a (n + N) *
          (2 * (γ - ell) + (Fintype.card ↥S : ℝ)) =
        a (n + N) * c := by
          dsimp [c]
          ring
      _ ≤ (γ - ell) ^ 2 := hbound.le
  have hstage (n : ℕ) :
      ∃ (D : Finset
          {x : Fin (A.model (ν (n + N))).size //
            x ∈ C (n + N)})
        (τ : ↥S → Equiv.Perm
          {x : {y : Fin (A.model (ν (n + N))).size //
                  y ∈ C (n + N)} //
            x ∈ (Finset.univ \ D :
              Finset {y : Fin (A.model (ν (n + N))).size //
                y ∈ C (n + N)})}),
        2 * D.card ≤ (C (n + N)).card ∧
        (D.card : ℝ) ≤
          a (n + N) * (C (n + N)).card / (γ - ell) ∧
        (∀ (i : ↥S)
          (x : {y : Fin (A.model (ν (n + N))).size //
            y ∈ C (n + N)})
          (hx : x ∈ (Finset.univ \ D :
            Finset {y : Fin (A.model (ν (n + N))).size //
              y ∈ C (n + N)}))
          (_hi : completedRestriction
            ((A.model (ν (n + N))).action ((i : K), (1 : J)))
            (C (n + N)) x ∈
              (Finset.univ \ D :
                Finset {y : Fin (A.model (ν (n + N))).size //
                  y ∈ C (n + N)})),
          ((τ i ⟨x, hx⟩ :
            {z : {y : Fin (A.model (ν (n + N))).size //
                      y ∈ C (n + N)} //
              z ∈ (Finset.univ \ D :
                Finset {y : Fin (A.model (ν (n + N))).size //
                  y ∈ C (n + N)})}) :
            {y : Fin (A.model (ν (n + N))).size //
              y ∈ C (n + N)}) =
              completedRestriction
                ((A.model (ν (n + N))).action ((i : K), (1 : J)))
                (C (n + N)) x) ∧
        (∀ E : Finset
          {x : {y : Fin (A.model (ν (n + N))).size //
                  y ∈ C (n + N)} //
            x ∈ (Finset.univ \ D :
              Finset {y : Fin (A.model (ν (n + N))).size //
                y ∈ C (n + N)})},
          ell * min (E.card : ℝ)
            ((Fintype.card
              {x : {y : Fin (A.model (ν (n + N))).size //
                      y ∈ C (n + N)} //
                x ∈ (Finset.univ \ D :
                  Finset {y : Fin (A.model (ν (n + N))).size //
                    y ∈ C (n + N)})} : ℝ) - E.card) ≤
            (SoficGroups.boundary τ E : ℝ)) := by
    simpa only [Fintype.card_coe] using
      SoficGroups.KunCompletedPrunedComponent.exists_completed_pruned_expander
        (fun i : ↥S =>
          completedRestriction
            ((A.model (ν (n + N))).action ((i : K), (1 : J)))
            (C (n + N)))
        γ ell (a (n + N)) hgap (hadd (n + N)) (hsmall n)
  choose D τ hhalf hbound hagree hexpand using hstage
  have hnonempty (n : ℕ) :
      (Finset.univ \ D n :
        Finset {x : Fin (A.model (ν (n + N))).size //
          x ∈ C (n + N)}).Nonempty := by
    have hCpositive : 0 < (C (n + N)).card :=
      ((Q (n + N)).nonempty_of_mem_parts (hC (n + N))).card_pos
    have hpositive :
        0 < (Finset.univ \ D n :
          Finset {x : Fin (A.model (ν (n + N))).size //
            x ∈ C (n + N)}).card := by
      rw [Finset.card_sdiff_of_subset (Finset.subset_univ (D n)),
        Finset.card_univ, Fintype.card_coe]
      have hh := hhalf n
      omega
    exact Finset.card_pos.mp hpositive
  have hshift : Tendsto (fun n : ℕ => n + N) atTop atTop :=
    tendsto_add_atTop_nat N
  have haupper : Tendsto
      (fun n => a (n + N) / (γ - ell))
      atTop (nhds 0) := by
    simpa only [Function.comp_def, zero_div] using
      (ha.comp hshift).div_const (γ - ell)
  have hdeleted : Tendsto
      (fun n => ((D n).card : ℝ) / (C (n + N)).card)
      atTop (nhds 0) := by
    apply squeeze_zero
      (fun n => by positivity)
      (fun n => ?_)
      haupper
    have hCpositive : (0 : ℝ) < (C (n + N)).card := by
      exact_mod_cast
        ((Q (n + N)).nonempty_of_mem_parts (hC (n + N))).card_pos
    calc
      ((D n).card : ℝ) / (C (n + N)).card ≤
        (a (n + N) * (C (n + N)).card /
          (γ - ell)) / (C (n + N)).card :=
          div_le_div_of_nonneg_right (hbound n) hCpositive.le
      _ = a (n + N) / (γ - ell) := by
          field_simp [hCpositive.ne', hgapPositive.ne']
  have hshiftlarge :
      Tendsto (fun n => (C (n + N)).card) atTop atTop := by
    simpa only [Function.comp_def] using hlarge.comp hshift
  have hzlarge : Tendsto
      (fun n =>
        (Finset.univ \ D n :
          Finset {x : Fin (A.model (ν (n + N))).size //
            x ∈ C (n + N)}).card)
      atTop atTop := by
    apply SoficGroups.MatchedComponentExitBudget.pruned_component_card_tendsto_atTop
      (fun n => {x : Fin (A.model (ν (n + N))).size //
        x ∈ C (n + N)}) D
    · simpa only [Fintype.card_coe] using hshiftlarge
    · simpa only [Fintype.card_coe] using hdeleted
  refine ⟨N, D, τ, hnonempty, hdeleted, hzlarge,
    hagree, ?_⟩
  simpa only [ell] using hexpand

end KunActualCanonicalSelectedPruning

namespace KunActualCanonicalPrunedSourceBadDensity

open Filter Topology
open SoficGroups.MatchedComponentCompletion
open SoficGroups.CanonicalProductRadiusBadMatchedCapture

theorem pruned_sourceCompletionBad_density_tendsto_zero_of_canonical_matched
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K)
    (hsymmetric : ∀ a ∈ S, a⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (F : Finset J) (ν : ℕ → ℕ)
    (Q : (n : ℕ) → Finpartition
      (Finset.univ : Finset (Fin (A.model (ν n)).size)))
    (C : (n : ℕ) → Finset (Fin (A.model (ν n)).size))
    (hC : ∀ n, C n ∈ (Q n).parts)
    (r : ℕ → ℕ)
    (hmatched : Tendsto
      (fun n =>
        (((C n ∩ SoficGroups.matchedRadiusBad
          (Q n) (sourceProductRadiusLabels S F (r n))
          ((A.model (ν n)).action)
          (canonicalProductRadiusBad
            A S hsymmetric hgenerates F (ν n) (r n))).card : ℝ) /
          (C n).card))
      atTop (𝓝 0))
    (D : (n : ℕ) → Finset
      {x : Fin (A.model (ν n)).size // x ∈ C n})
    (hZ : ∀ n,
      (Finset.univ \ D n :
        Finset {x : Fin (A.model (ν n)).size // x ∈ C n}).Nonempty)
    (hdeleted : Tendsto
      (fun n => ((D n).card : ℝ) / (C n).card)
      atTop (𝓝 0)) :
    Tendsto
      (fun n =>
        ((sourceCompletionBad
          (fun i : ↥S =>
            completedRestriction
              ((A.model (ν n)).action ((i : K), (1 : J))) (C n))
          (fun j : J =>
            completedRestriction
              ((A.model (ν n)).action ((1 : K), j)) (C n))
          F (Finset.univ \ D n)).card : ℝ) /
            (Finset.univ \ D n :
              Finset {x : Fin (A.model (ν n)).size // x ∈ C n}).card)
      atTop (𝓝 0) := by
  apply SoficGroups.MatchedFirstStageWordRadiusTransfer.pruned_sourceCompletionBad_density_tendsto_zero_of_matchedRadius
    (fun n => Fin (A.model (ν n)).size)
    (fun n (i : ↥S) => (A.model (ν n)).action ((i : K), (1 : J)))
    (fun n (j : J) => (A.model (ν n)).action ((1 : K), j))
    F
    (fun n => (Finset.univ : Finset (Fin (A.model (ν n)).size)))
    C Q
    (fun k => sourceProductRadiusLabels S F k)
    (fun n => (A.model (ν n)).action)
    r
    (fun n k => canonicalProductRadiusBad
      A S hsymmetric hgenerates F (ν n) k)
    D
  · intro n
    exact sourceCompletionBad_subset_canonical_matchedRadiusBad
      A S hsymmetric hgenerates F (ν n) (r n)
      (Q n) (C n) (hC n)
  · exact hmatched
  · exact hZ
  · exact hdeleted

end KunActualCanonicalPrunedSourceBadDensity

namespace KunActualTwicePrunedFirstFactorRootBad

open Filter Topology
open SoficGroups.MatchedComponentCompletion
open SoficGroups.MatchedComponentExitBudget
open SoficGroups.KunActualSoficRootRadius
open SoficGroups.CanonicalProductRadiusBadMatchedCapture
open SoficGroups.CompletedSourceFinalGeneratorTransfer
open scoped BigOperators Pointwise

noncomputable def restrictionMultiplicationBad
    {V : Type*} [DecidableEq V]
    (p q r : Equiv.Perm V) (Z : Finset V) : Finset V :=
  Z.filter (fun x => q x ∉ Z ∨ r x ∉ Z ∨ r x ≠ p (q x))

theorem completedRestriction_mul_of_not_mem_restrictionMultiplicationBad
    {V : Type*} [Fintype V] [DecidableEq V]
    (p q r : Equiv.Perm V) (Z : Finset V)
    (x : {v : V // v ∈ Z})
    (hx : (x : V) ∉ restrictionMultiplicationBad p q r Z) :
    completedRestriction r Z x =
      (completedRestriction p Z * completedRestriction q Z) x := by
  classical
  have hgood : ¬ (q (x : V) ∉ Z ∨ r (x : V) ∉ Z ∨
      r (x : V) ≠ p (q (x : V))) := by
    intro h
    exact hx (Finset.mem_filter.mpr ⟨x.property, h⟩)
  have hq : q (x : V) ∈ Z := by
    by_contra hn
    exact hgood (Or.inl hn)
  have hr : r (x : V) ∈ Z := by
    by_contra hn
    exact hgood (Or.inr (Or.inl hn))
  have hmul : r (x : V) = p (q (x : V)) := by
    by_contra hn
    exact hgood (Or.inr (Or.inr hn))
  have hpq : p (q (x : V)) ∈ Z := hmul ▸ hr
  have hqvalue :
      ((completedRestriction q Z x : {v : V // v ∈ Z}) : V) =
        q (x : V) :=
    completedRestriction_apply_of_mem q Z x x.property hq
  apply Subtype.ext
  change
    ((completedRestriction r Z x : {v : V // v ∈ Z}) : V) =
      ((completedRestriction p Z
        (completedRestriction q Z x) : {v : V // v ∈ Z}) : V)
  calc
    ((completedRestriction r Z x : {v : V // v ∈ Z}) : V) =
        r (x : V) :=
      completedRestriction_apply_of_mem r Z x x.property hr
    _ = p (q (x : V)) := hmul
    _ = p ((completedRestriction q Z x : {v : V // v ∈ Z}) : V) := by
      rw [hqvalue]
    _ = ((completedRestriction p Z
          (completedRestriction q Z x) : {v : V // v ∈ Z}) : V) := by
      symm
      apply completedRestriction_apply_of_mem
      change p ((completedRestriction q Z x : {v : V // v ∈ Z}) : V) ∈ Z
      rw [hqvalue]
      exact hpq

theorem completedRestriction_mul_distance_le_failure_add_deleted
    {V : Type*} [Fintype V] [DecidableEq V]
    (p q r : Equiv.Perm V) (Z : Finset V) :
    SoficGroups.permutationDistance
        (completedRestriction r Z)
        (completedRestriction p Z * completedRestriction q Z) ≤
      (Finset.univ.filter fun x : V => r x ≠ p (q x)).card +
        2 * (Finset.univ \ Z).card := by
  classical
  let B : Finset V := restrictionMultiplicationBad p q r Z
  let E₁ : Finset V := Z.filter fun x => q x ∉ Z
  let E₂ : Finset V := Z.filter fun x => r x ∉ Z
  let E₃ : Finset V := Finset.univ.filter fun x : V => r x ≠ p (q x)
  have hsubset : B ⊆ E₁ ∪ E₂ ∪ E₃ := by
    intro x hx
    have hx' := Finset.mem_filter.mp hx
    rcases hx'.2 with hq | hr | hmul
    · exact Finset.mem_union_left _
        (Finset.mem_union_left _ (Finset.mem_filter.mpr ⟨hx'.1, hq⟩))
    · exact Finset.mem_union_left _
        (Finset.mem_union_right _ (Finset.mem_filter.mpr ⟨hx'.1, hr⟩))
    · exact Finset.mem_union_right _
        (Finset.mem_filter.mpr ⟨Finset.mem_univ _, hmul⟩)
  have hB :
      B.card ≤ E₁.card + E₂.card + E₃.card := by
    calc
      B.card ≤ (E₁ ∪ E₂ ∪ E₃).card := Finset.card_le_card hsubset
      _ ≤ (E₁ ∪ E₂).card + E₃.card := Finset.card_union_le _ _
      _ ≤ (E₁.card + E₂.card) + E₃.card := by
        gcongr
        exact Finset.card_union_le _ _
  have hdist :
      SoficGroups.permutationDistance
        (completedRestriction r Z)
        (completedRestriction p Z * completedRestriction q Z) ≤ B.card := by
    calc
      SoficGroups.permutationDistance
          (completedRestriction r Z)
          (completedRestriction p Z * completedRestriction q Z) ≤
          (subtypeBad Z B).card :=
        permutationDistance_le_subtypeBad Z B _ _
          (fun x hx =>
            completedRestriction_mul_of_not_mem_restrictionMultiplicationBad
              p q r Z x hx)
      _ = (Z ∩ B).card := card_subtypeBad Z B
      _ ≤ B.card := Finset.card_le_card Finset.inter_subset_right
  have hE₁ : E₁.card ≤ (Finset.univ \ Z).card :=
    card_permutation_exit_le_deleted q Z
  have hE₂ : E₂.card ≤ (Finset.univ \ Z).card :=
    card_permutation_exit_le_deleted r Z
  change
    SoficGroups.permutationDistance
        (completedRestriction r Z)
        (completedRestriction p Z * completedRestriction q Z) ≤
      E₃.card + 2 * (Finset.univ \ Z).card
  omega

theorem firstFactor_completed_mul_distance_le_canonical_matched
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K)
    (hsymmetric : ∀ a ∈ S, a⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (F : Finset J) (n k : ℕ)
    {U : Finset (Fin (A.model n).size)}
    (Q : Finpartition U)
    (C : Finset (Fin (A.model n).size))
    (hC : C ∈ Q.parts)
    (a g : K)
    (ha : a ∈ S ^ k) (hg : g ∈ S ^ k)
    (hag : a * g ∈ S ^ k) :
    SoficGroups.permutationDistance
        (completedRestriction
          ((A.model n).action (a * g, (1 : J))) C)
        (completedRestriction
          ((A.model n).action (a, (1 : J))) C *
         completedRestriction
          ((A.model n).action (g, (1 : J))) C) ≤
      (C ∩ SoficGroups.matchedRadiusBad
        Q (sourceProductRadiusLabels S F k)
        ((A.model n).action)
        (canonicalProductRadiusBad A S hsymmetric hgenerates F n k)).card := by
  classical
  let B := SoficGroups.matchedRadiusBad
    Q (sourceProductRadiusLabels S F k)
    ((A.model n).action)
    (canonicalProductRadiusBad A S hsymmetric hgenerates F n k)
  calc
    SoficGroups.permutationDistance
        (completedRestriction
          ((A.model n).action (a * g, (1 : J))) C)
        (completedRestriction
          ((A.model n).action (a, (1 : J))) C *
         completedRestriction
          ((A.model n).action (g, (1 : J))) C) ≤
        (subtypeBad C B).card := by
      apply permutationDistance_le_subtypeBad C B
      intro x hx
      apply completedRestriction_mul_of_not_mem_restrictionMultiplicationBad
        ((A.model n).action (a, (1 : J)))
        ((A.model n).action (g, (1 : J)))
        ((A.model n).action (a * g, (1 : J))) C x
      intro hfailure
      have hbad := (Finset.mem_filter.mp hfailure).2
      have hnotcross (b : K) (hb : b ∈ S ^ k) :
          (x : Fin (A.model n).size) ∉
            SoficGroups.partitionWordCrossing
              Q ((A.model n).action (b, (1 : J))) := by
        intro hcross
        apply hx
        apply Finset.mem_union_right
        exact Finset.mem_biUnion.mpr
          ⟨(b, (1 : J)),
            firstFactor_mem_sourceProductRadiusLabels S F k hb,
            hcross⟩
      rcases hbad with hq | hr | hmul
      · exact hnotcross g hg
          (component_exit_mem_partitionWordCrossing
            Q C hC ((A.model n).action (g, (1 : J)))
            x.property hq)
      · exact hnotcross (a * g) hag
          (component_exit_mem_partitionWordCrossing
            Q C hC ((A.model n).action (a * g, (1 : J)))
            x.property hr)
      · have hnotroot :
            (x : Fin (A.model n).size) ∉
              finiteRootBad (A.model n)
                (sourceProductRadiusLabels S F k) := by
          intro hroot
          apply hx
          apply Finset.mem_union_left
          exact Finset.mem_union_right _ hroot
        have hroot := finiteRootBad_multiplicative
          (A.model n) (sourceProductRadiusLabels S F k)
          (firstFactor_mem_sourceProductRadiusLabels S F k ha)
          (firstFactor_mem_sourceProductRadiusLabels S F k hg)
          hnotroot
        apply hmul
        simpa [Equiv.Perm.mul_apply] using hroot
    _ = (C ∩ SoficGroups.matchedRadiusBad
        Q (sourceProductRadiusLabels S F k)
        ((A.model n).action)
        (canonicalProductRadiusBad A S hsymmetric hgenerates F n k)).card :=
      card_subtypeBad C B

theorem density_relative_survivors
    (V : ℕ → Type*) [∀ n, Fintype (V n)]
    [∀ n, DecidableEq (V n)]
    (D : (n : ℕ) → Finset (V n))
    (hZ : ∀ n, (Finset.univ \ D n : Finset (V n)).Nonempty)
    (hdeleted : Tendsto
      (fun n => ((D n).card : ℝ) / Fintype.card (V n))
      atTop (nhds 0))
    (b : ℕ → ℕ)
    (hb : Tendsto
      (fun n => (b n : ℝ) / Fintype.card (V n))
      atTop (nhds 0)) :
    Tendsto
      (fun n => (b n : ℝ) /
        (Finset.univ \ D n : Finset (V n)).card)
      atTop (nhds 0) := by
  have hcover := surviving_card_ratio_tendsto_one V D hZ hdeleted
  have hquotient : Tendsto
      ((fun n => (b n : ℝ) / Fintype.card (V n)) /
        (fun n =>
          ((Finset.univ \ D n : Finset (V n)).card : ℝ) /
            Fintype.card (V n)))
      atTop (nhds 0) := by
    simpa only [zero_div] using
      hb.div hcover (by norm_num : (1 : ℝ) ≠ 0)
  convert hquotient using 1
  funext n
  have hN : Fintype.card (V n) ≠ 0 := by
    obtain ⟨x, _⟩ := hZ n
    exact Finset.card_ne_zero.mpr
      (show (Finset.univ : Finset (V n)).Nonempty from
        ⟨x, Finset.mem_univ x⟩)
  have hNreal : (Fintype.card (V n) : ℝ) ≠ 0 := by
    exact_mod_cast hN
  have hZreal :
      ((Finset.univ \ D n : Finset (V n)).card : ℝ) ≠ 0 := by
    exact_mod_cast Finset.card_ne_zero.mpr (hZ n)
  change
    (b n : ℝ) / (Finset.univ \ D n : Finset (V n)).card =
      ((b n : ℝ) / Fintype.card (V n)) /
        (((Finset.univ \ D n : Finset (V n)).card : ℝ) /
          Fintype.card (V n))
  field_simp [hNreal, hZreal]

theorem twiceCompleted_firstFactor_mul_normalizedHamming_tendsto_zero_of_canonical_matched
    {K J : Type*} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (A : SoficGroups.SoficApproximation (K × J))
    (S : Finset K) (hone : 1 ∈ S)
    (hsymmetric : ∀ a ∈ S, a⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (F : Finset J) (ν : ℕ → ℕ)
    (Q : (n : ℕ) → Finpartition
      (Finset.univ : Finset (Fin (A.model (ν n)).size)))
    (C : (n : ℕ) → Finset (Fin (A.model (ν n)).size))
    (hC : ∀ n, C n ∈ (Q n).parts)
    (r : ℕ → ℕ) (hr : Tendsto r atTop atTop)
    (hmatched : Tendsto
      (fun n =>
        (((C n ∩ SoficGroups.matchedRadiusBad
          (Q n) (sourceProductRadiusLabels S F (r n))
          ((A.model (ν n)).action)
          (canonicalProductRadiusBad
            A S hsymmetric hgenerates F (ν n) (r n))).card : ℝ) /
            (C n).card))
      atTop (nhds 0))
    (D : (n : ℕ) → Finset
      {x : Fin (A.model (ν n)).size // x ∈ C n})
    (hZ : ∀ n,
      (Finset.univ \ D n :
        Finset {x : Fin (A.model (ν n)).size // x ∈ C n}).Nonempty)
    (hdeleted : Tendsto
      (fun n => ((D n).card : ℝ) / (C n).card)
      atTop (nhds 0))
    (a g : K) :
    Tendsto
      (fun n =>
        SoficGroups.normalizedHamming
          (completedRestriction
            (completedRestriction
              ((A.model (ν n)).action (a * g, (1 : J))) (C n))
            (Finset.univ \ D n))
          (completedRestriction
            (completedRestriction
              ((A.model (ν n)).action (a, (1 : J))) (C n))
            (Finset.univ \ D n) *
           completedRestriction
            (completedRestriction
              ((A.model (ν n)).action (g, (1 : J))) (C n))
            (Finset.univ \ D n)))
      atTop (nhds 0) := by
  classical
  let W : ℕ → Type := fun n =>
    {x : Fin (A.model (ν n)).size // x ∈ C n}
  let Z : (n : ℕ) → Finset (W n) := fun n => Finset.univ \ D n
  let B : ℕ → ℕ := fun n =>
    (C n ∩ SoficGroups.matchedRadiusBad
      (Q n) (sourceProductRadiusLabels S F (r n))
      ((A.model (ν n)).action)
      (canonicalProductRadiusBad
        A S hsymmetric hgenerates F (ν n) (r n))).card
  have hdeletedW : Tendsto
      (fun n => ((D n).card : ℝ) / Fintype.card (W n))
      atTop (nhds 0) := by
    simpa only [W, Fintype.card_coe] using hdeleted
  have hBW : Tendsto
      (fun n => (B n : ℝ) / Fintype.card (W n))
      atTop (nhds 0) := by
    simpa only [B, W, Fintype.card_coe] using hmatched
  have hBfinal : Tendsto
      (fun n => (B n : ℝ) / (Z n).card)
      atTop (nhds 0) := by
    exact density_relative_survivors W D hZ hdeletedW B hBW
  have hDfinal : Tendsto
      (fun n => ((D n).card : ℝ) / (Z n).card)
      atTop (nhds 0) := by
    exact deleted_density_relative_survivors W D hZ hdeletedW
  have hupper : Tendsto
      (fun n => (B n : ℝ) / (Z n).card +
        2 * ((D n).card : ℝ) / (Z n).card)
      atTop (nhds 0) := by
    convert hBfinal.add (hDfinal.const_mul 2) using 1 <;>
      simp [mul_div_assoc]
  let w : K → List ↥S :=
    symmetricGeneratorWord S hsymmetric hgenerates
  have hw : ∀ b : K, ((w b).map fun i : ↥S => (i : K)).prod = b :=
    symmetricGeneratorWord_prod S hsymmetric hgenerates
  have hlarge : ∀ᶠ n in atTop,
      max (w a).length (max (w g).length (w (a * g)).length) ≤ r n :=
    Filter.tendsto_atTop.1 hr _
  apply squeeze_zero'
    (Filter.Eventually.of_forall fun n =>
      SoficGroups.normalizedHamming_nonneg _ _)
    ?_ hupper
  filter_upwards [hlarge] with n hn
  have ha : a ∈ S ^ r n :=
    mem_generator_pow_of_chosen_word_length S hone w hw
      (by omega)
  have hg : g ∈ S ^ r n :=
    mem_generator_pow_of_chosen_word_length S hone w hw
      (by omega)
  have hag : a * g ∈ S ^ r n :=
    mem_generator_pow_of_chosen_word_length S hone w hw
      (by omega)
  let p : Equiv.Perm (W n) :=
    completedRestriction ((A.model (ν n)).action (a, (1 : J))) (C n)
  let q : Equiv.Perm (W n) :=
    completedRestriction ((A.model (ν n)).action (g, (1 : J))) (C n)
  let s : Equiv.Perm (W n) :=
    completedRestriction ((A.model (ν n)).action (a * g, (1 : J))) (C n)
  have hfirst :
      SoficGroups.permutationDistance s (p * q) ≤ B n := by
    exact firstFactor_completed_mul_distance_le_canonical_matched
      A S hsymmetric hgenerates F (ν n) (r n)
      (Q n) (C n) (hC n) a g ha hg hag
  have hfailure :
      (Finset.univ.filter fun x : W n =>
        s x ≠ p (q x)).card ≤ B n := by
    calc
      (Finset.univ.filter fun x : W n =>
        s x ≠ p (q x)).card =
          SoficGroups.permutationDistance s (p * q) := by
        unfold SoficGroups.permutationDistance hammingDist
        congr 1
      _ ≤ B n := hfirst
  have hdist := completedRestriction_mul_distance_le_failure_add_deleted
    p q s (Z n)
  have hcomplement :
      (Finset.univ \ Z n : Finset (W n)) = D n := by
    ext x
    simp [Z]
  have hnat :
      SoficGroups.permutationDistance
        (completedRestriction s (Z n))
        (completedRestriction p (Z n) *
          completedRestriction q (Z n)) ≤
        B n + 2 * (D n).card := by
    rw [hcomplement] at hdist
    omega
  have hreal :
      (SoficGroups.permutationDistance
        (completedRestriction s (Z n))
        (completedRestriction p (Z n) *
          completedRestriction q (Z n)) : ℝ) ≤
        (B n : ℝ) + 2 * (D n).card := by
    exact_mod_cast hnat
  have hnormalized := div_le_div_of_nonneg_right hreal
    (show (0 : ℝ) ≤ ((Z n).card : ℝ) by positivity)
  change
    SoficGroups.normalizedHamming
        (completedRestriction s (Z n))
        (completedRestriction p (Z n) *
          completedRestriction q (Z n)) ≤
      (B n : ℝ) / (Z n).card +
        2 * ((D n).card : ℝ) / (Z n).card
  simpa [SoficGroups.normalizedHamming,
    SoficGroups.permutationDistance, Fintype.card_coe, add_div,
    mul_div_assoc] using hnormalized

end KunActualTwicePrunedFirstFactorRootBad

namespace KunActualSelectedPrunedSourceFiniteModelBridge

open Filter Topology
open SoficGroups.MatchedComponentCompletion
open SoficGroups.KunActualSoficRootRadius
open scoped BigOperators Pointwise

theorem completed_generator_one_of_internal_agreement
    {G : Type} [Group G] (S : Finset G)
    {W : Type}
    (σ : ↥S → Equiv.Perm W) (Z : Finset W)
    (τ : ↥S → Equiv.Perm {x : W // x ∈ Z})
    (hagrees : ∀ i (x : W) (hx : x ∈ Z)
      (_hi : σ i x ∈ Z),
        ((τ i ⟨x, hx⟩ : {x : W // x ∈ Z}) : W) = σ i x)
    (hidentity : ∀ i : ↥S, (i : G) = 1 → σ i = 1)
    (i : ↥S) (hi : (i : G) = 1) : τ i = 1 := by
  have hσ : σ i = 1 := hidentity i hi
  ext x
  have hinside : σ i (x : W) ∈ Z := by
    rw [hσ]
    exact x.property
  simpa [hσ] using hagrees i (x : W) x.property hinside

theorem nonempty_expandingCentralizerFiniteModel_of_actual_selected_pruned_source
    {G J : Type} [Group G] [Group J]
    [DecidableEq G]
    (P : SoficGroups.KazhdanPair.{0, 0} G)
    (S : Finset G) (honeS : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set G) = ⊤)
    (F : Finset J)
    (W : ℕ → Type)
    [∀ n, Fintype (W n)] [∀ n, DecidableEq (W n)]
    (σ : (n : ℕ) → ↥S → Equiv.Perm (W n))
    (hσone : ∀ n (i : ↥S), (i : G) = 1 → σ n i = 1)
    (p : (n : ℕ) → J → Equiv.Perm (W n))
    (hp : ∀ n, p n 1 = 1)
    (Z : (n : ℕ) → Finset (W n))
    (hZ : ∀ n, (Z n).Nonempty)
    (hlarge : Tendsto (fun n => (Z n).card) atTop atTop)
    (τ : (n : ℕ) → ↥S →
      Equiv.Perm {x : W n // x ∈ Z n})
    (hτ : ∀ n i (x : W n) (hx : x ∈ Z n)
      (_hi : σ n i x ∈ Z n),
        ((τ n i ⟨x, hx⟩ :
          {x : W n // x ∈ Z n}) : W n) = σ n i x)
    (ρ : (n : ℕ) → G →
      Equiv.Perm {x : W n // x ∈ Z n})
    (hρone : ∀ n, ρ n 1 = 1)
    (hρmul : ∀ a g : G,
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (ρ n (a * g)) (ρ n a * ρ n g))
        atTop (𝓝 0))
    (hρgenerator : ∀ i : ↥S,
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (τ n i) (ρ n (i : G)))
        atTop (𝓝 0))
    (ell : ℝ) (hell : 0 < ell)
    (hexp : ∀ n, ∀ E : Finset {x : W n // x ∈ Z n},
      ell * min (E.card : ℝ)
        ((Fintype.card {x : W n // x ∈ Z n} : ℝ) - E.card) ≤
          (SoficGroups.boundary (τ n) E : ℝ))
    (hbad : Tendsto
      (fun n =>
        ((SoficGroups.MatchedComponentCompletion.sourceCompletionBad
          (σ n) (p n) F (Z n)).card : ℝ) / (Z n).card)
      atTop (𝓝 0)) :
    Nonempty (SoficGroups.ExpandingCentralizerFiniteModel J F) := by
  classical
  let V : ℕ → Type := fun n => {x : W n // x ∈ Z n}
  letI (n : ℕ) : Nonempty (V n) :=
    ⟨⟨(hZ n).choose, (hZ n).choose_spec⟩⟩
  let w : G → List ↥S :=
    SoficGroups.KunActualSoficRootRadius.symmetricGeneratorWord
      S hsymmetric hgenerates
  have hw (g : G) :
      ((w g).map fun i : ↥S => (i : G)).prod = g := by
    exact SoficGroups.KunActualSoficRootRadius.symmetricGeneratorWord_prod
      S hsymmetric hgenerates g
  let φ : (n : ℕ) → G → Equiv.Perm (V n) :=
    fun n g => ((w g).map (τ n)).prod
  have hφone (n : ℕ) : φ n 1 = 1 := by
    simp [φ, w,
      SoficGroups.KunActualSoficRootRadius.symmetricGeneratorWord_one]
  have hφgenerator (n : ℕ) (i : ↥S) :
      φ n (i : G) = τ n i := by
    by_cases hi : (i : G) = 1
    · have hτone : τ n i = 1 :=
        completed_generator_one_of_internal_agreement
          S (σ n) (Z n) (τ n) (hτ n) (hσone n) i hi
      simp [φ, w, hi, hτone,
        SoficGroups.KunActualSoficRootRadius.symmetricGeneratorWord_one]
    · simp [φ, w,
        SoficGroups.KunActualSoficRootRadius.symmetricGeneratorWord_generator
          S hsymmetric hgenerates i hi]
  have hφmul (a g : G) :
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (φ n (a * g)) (φ n a * φ n g))
        atTop (𝓝 0) := by
    simpa [φ,
      SoficGroups.CompletedChosenWordLocalRoot.chosenWordEvaluation] using
      SoficGroups.CompletedChosenWordLocalRoot.chosenWordEvaluation_multiplicative_tendsto
          V ρ hρone hρmul
          (fun i : ↥S => (i : G)) w hw τ hρgenerator a g
  let root : (n : ℕ) → ℕ → Finset (V n) :=
    fun n k =>
      SoficGroups.CompletedPrescribedSpectralRadiusSchedule.fixedRadiusRootBad
        (φ n) S k
  have hroot (k : ℕ) :
      Tendsto
        (fun n => ((root n k).card : ℝ) / Fintype.card (V n))
        atTop (𝓝 0) := by
    exact SoficGroups.CompletedPrescribedSpectralRadiusSchedule.fixedRadiusRootBad_density_tendsto_zero
      V φ S hφmul k
  let source : (n : ℕ) → Finset (V n) :=
    fun n => SoficGroups.MatchedComponentCompletion.subtypeBad
      (Z n)
      (SoficGroups.MatchedComponentCompletion.sourceCompletionBad
        (σ n) (p n) F (Z n))
  have hsource :
      Tendsto
        (fun n => ((source n).card : ℝ) / Fintype.card (V n))
        atTop (𝓝 0) := by
    simpa [source, V,
      SoficGroups.MatchedComponentCompletion.card_subtype_sourceCompletionBad,
      Fintype.card_coe] using hbad
  have hVpositive (n : ℕ) : 0 < Fintype.card (V n) := by
    simpa [V, Fintype.card_coe] using (hZ n).card_pos
  have hVlarge :
      Tendsto (fun n => Fintype.card (V n)) atTop atTop := by
    simpa [V, Fintype.card_coe] using hlarge
  let δ : ℕ → ℝ := fun j => 1 / ((j : ℝ) + 1)
  have hδpositive (j : ℕ) : 0 < δ j := by
    dsimp [δ]
    positivity
  have hδ : Tendsto δ atTop (𝓝 0) := by
    simpa [δ] using
      (tendsto_one_div_add_atTop_nhds_zero_nat (𝕜 := ℝ))
  let d : ℕ := S.card
  have hd : 0 < d := by
    dsimp [d]
    exact Finset.card_pos.mpr ⟨1, honeS⟩
  let q : ℝ :=
    SoficGroups.KunThomInvariantOrthogonal.kazhdanMarkovContractionFactor P S
  have hq : q < 1 := by
    exact SoficGroups.KunThomInvariantOrthogonal.kazhdanMarkovContractionFactor_lt_one
      P S ⟨1, honeS⟩
  let α : ℕ → ℝ :=
    fun j => ell * δ j / (2 * (ell + 8 * (d : ℝ)))
  have hα (j : ℕ) : 0 < α j := by
    dsimp [α]
    have hdreal : (0 : ℝ) < d := by exact_mod_cast hd
    positivity
  let spectral (j : ℕ) :=
    SoficGroups.KunUniformCompletedRootRadiusImprovement.exists_uniform_radius_hasAlmostCentralizerImprovement
        P S honeS hcover hsymmetric w ell (α j) hell (hα j)
  let radius : ℕ → ℕ := fun j => (spectral j).choose
  have hspectral (j : ℕ) := (spectral j).choose_spec
  let R : ℕ → ℕ := fun j => max j (radius j)
  have hR (j : ℕ) : j ≤ R j := le_max_left _ _
  obtain ⟨m, rootError, t, hm, hRm, hδm, hrelative,
      hrootError, hrootlower, hrootlimit, htdef, htpositive,
      htroot, htsource, htrooterror, htlimit, htarget,
      hsmall, hslow⟩ :=
    SoficGroups.KunCombinedPrescribedRootSourceTolerance.exists_prescribed_radius_union_source_completed_tolerance
        V hVpositive hVlarge root source hroot hsource
        δ hδpositive hδ R hR d hd ell q hell hq
  let pZ : (n : ℕ) → J → Equiv.Perm (V n) :=
    fun n j => SoficGroups.MatchedComponentCompletion.completedRestriction
      (p n j) (Z n)
  have hpZ (n : ℕ) : pZ n 1 = 1 := by
    dsimp [pZ]
    rw [hp n,
      SoficGroups.MatchedComponentCompletion.completedRestriction_one]
  have hsourcebudget (n : ℕ) :
      2 * Fintype.card (↥S) *
        (SoficGroups.MatchedComponentCompletion.sourceCompletionBad
          (σ n) (p n) F (Z n)).card ≤ t n := by
    have hbudget := htsource n
    change
      2 * S.card *
        (SoficGroups.MatchedComponentCompletion.subtypeBad
          (Z n)
          (SoficGroups.MatchedComponentCompletion.sourceCompletionBad
            (σ n) (p n) F (Z n))).card ≤ t n at hbudget
    rw [SoficGroups.MatchedComponentCompletion.card_subtype_sourceCompletionBad]
      at hbudget
    simpa only [Fintype.card_coe] using hbudget
  have htable :=
    SoficGroups.CompletedSelectedCentralizerPairwiseSource.eventually_completed_sourceCentralizer_table_of_bad_density
        W σ p F Z hZ hbad τ hτ t hsourcebudget
  have hdefect : ∀ᶠ n in atTop,
      ∀ j ∈ SoficGroups.CompressionCriterion.productTrackedTable F,
        SoficGroups.permutationCommutationDefect
          (τ n) (pZ n j) ≤ t n := by
    filter_upwards [htable] with n hn
    simpa [pZ] using hn.2.2
  have hmulJ : ∀ᶠ n in atTop,
      ∀ a ∈ F, ∀ b ∈ F,
        5 * SoficGroups.permutationDistance
          (pZ n (a * b)) (pZ n a * pZ n b) ≤
            Fintype.card (V n) := by
    filter_upwards [htable] with n hn
    simpa [pZ, V] using hn.1
  have hsepJ : ∀ᶠ n in atTop,
      ∀ a ∈ F, ∀ b ∈ F, a ≠ b →
        Fintype.card (V n) <
          5 * SoficGroups.permutationDistance (pZ n a) (pZ n b) := by
    filter_upwards [htable] with n hn
    simpa [pZ, V] using hn.2.1
  have himprove : ∀ᶠ n in atTop,
      SoficGroups.HasAlmostCentralizerImprovement (τ n) (t n) := by
    filter_upwards [hslow] with n hn
    apply hspectral (m n) (V n) (τ n) (φ n) (t n)
      (root n (R (m n)) ∪ source n)
    · intro g
      rfl
    · exact hφone n
    · exact hφgenerator n
    · exact hexp n
    · simpa [d, q] using hn
    · right
      refine ⟨by exact_mod_cast htpositive n, ?_, ?_, ?_⟩
      · simpa [α] using htarget n
      · have hbudget :
            2 * d * (root n (R (m n)) ∪ source n).card ≤ t n := by
          rw [htdef n]
          omega
        exact_mod_cast hbudget
      · intro a g hlength x hx
        have hxroot : x ∉ root n (R (m n)) := by
          intro hxroot
          exact hx (Finset.mem_union_left _ hxroot)
        have hradius : radius (m n) ≤ R (m n) := by
          exact le_max_right _ _
        exact
          SoficGroups.CompletedPrescribedSpectralRadiusSchedule.fixedRadiusRootBad_rooted
            S honeS w hw (φ n) (R (m n)) a g
            (hlength.trans hradius) x hxroot
  exact SoficGroups.KunActualSelectedCentralizerFiniteModel.nonempty_expandingCentralizerFiniteModel_of_selected_completed_sequence
      F V (↥S) τ pZ hpZ t ell hell hdefect
      (Filter.Eventually.of_forall hexp)
      hsmall himprove hmulJ hsepJ

end KunActualSelectedPrunedSourceFiniteModelBridge

namespace KunActualCanonicalSelectedFiniteModelComposition

open Filter Topology
open SoficGroups.MatchedComponentCompletion
open SoficGroups.CanonicalProductRadiusBadMatchedCapture

theorem nonempty_expandingCentralizerFiniteModel_of_canonical_selected_additive
    {K J : Type} [Group K] [Group J]
    [DecidableEq K] [DecidableEq J]
    (A : SoficGroups.SoficApproximation (K × J))
    (P : SoficGroups.KazhdanPair.{0, 0} K)
    (S : Finset K) (hone : 1 ∈ S)
    (hcover : P.generators ⊆ S)
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure (S : Set K) = ⊤)
    (F : Finset J) (ν : ℕ → ℕ)
    (Q : (n : ℕ) → Finpartition
      (Finset.univ : Finset (Fin (A.model (ν n)).size)))
    (C : (n : ℕ) → Finset (Fin (A.model (ν n)).size))
    (hC : ∀ n, C n ∈ (Q n).parts)
    (r : ℕ → ℕ) (hr : Tendsto r atTop atTop)
    (hmatched : Tendsto
      (fun n =>
        (((C n ∩ SoficGroups.matchedRadiusBad
          (Q n) (sourceProductRadiusLabels S F (r n))
          ((A.model (ν n)).action)
          (canonicalProductRadiusBad
            A S hsymmetric hgenerates F (ν n) (r n))).card : ℝ) /
            (C n).card))
      atTop (𝓝 0))
    (hlarge : Tendsto (fun n => (C n).card) atTop atTop)
    (γ : ℝ) (hγ : 0 < γ)
    (a : ℕ → ℝ) (ha : Tendsto a atTop (𝓝 0))
    (hadd : ∀ n,
      ∀ E : Finset {x : Fin (A.model (ν n)).size // x ∈ C n},
        γ * min (E.card : ℝ)
            ((Fintype.card
              {x : Fin (A.model (ν n)).size // x ∈ C n} : ℝ) -
              E.card) -
          a n * Fintype.card
            {x : Fin (A.model (ν n)).size // x ∈ C n} ≤
          (SoficGroups.boundary
            (fun i : ↥S =>
              completedRestriction
                ((A.model (ν n)).action ((i : K), (1 : J)))
                (C n)) E : ℝ)) :
    Nonempty (SoficGroups.ExpandingCentralizerFiniteModel J F) := by
  classical
  obtain ⟨N, D, τ, hZ, hdeleted, hZlarge, hagrees, hexp⟩ :=
    SoficGroups.KunActualCanonicalSelectedPruning.exists_actual_uniformly_expanding_pruned_selected_components
      A S ν Q C hC hlarge γ hγ a ha hadd
  let ν' : ℕ → ℕ := fun n => ν (n + N)
  let Q' : (n : ℕ) → Finpartition
      (Finset.univ : Finset (Fin (A.model (ν' n)).size)) :=
    fun n => Q (n + N)
  let C' : (n : ℕ) → Finset (Fin (A.model (ν' n)).size) :=
    fun n => C (n + N)
  let r' : ℕ → ℕ := fun n => r (n + N)
  have hshift : Tendsto (fun n : ℕ => n + N) atTop atTop :=
    tendsto_add_atTop_nat N
  have hC' (n : ℕ) : C' n ∈ (Q' n).parts := hC (n + N)
  have hr' : Tendsto r' atTop atTop := by
    exact hr.comp hshift
  have hmatched' : Tendsto
      (fun n =>
        (((C' n ∩ SoficGroups.matchedRadiusBad
          (Q' n) (sourceProductRadiusLabels S F (r' n))
          ((A.model (ν' n)).action)
          (canonicalProductRadiusBad
            A S hsymmetric hgenerates F (ν' n) (r' n))).card : ℝ) /
            (C' n).card))
      atTop (𝓝 0) := by
    exact hmatched.comp hshift
  let W : ℕ → Type :=
    fun n => {x : Fin (A.model (ν' n)).size // x ∈ C' n}
  let Z : (n : ℕ) → Finset (W n) :=
    fun n => Finset.univ \ D n
  let σ : (n : ℕ) → ↥S → Equiv.Perm (W n) :=
    fun n i => completedRestriction
      ((A.model (ν' n)).action ((i : K), (1 : J))) (C' n)
  let p : (n : ℕ) → J → Equiv.Perm (W n) :=
    fun n j => completedRestriction
      ((A.model (ν' n)).action ((1 : K), j)) (C' n)
  let ρ : (n : ℕ) → K →
      Equiv.Perm {x : W n // x ∈ Z n} :=
    fun n g => completedRestriction
      (completedRestriction
        ((A.model (ν' n)).action (g, (1 : J))) (C' n))
      (Z n)
  have hσone (n : ℕ) (i : ↥S) (hi : (i : K) = 1) :
      σ n i = 1 := by
    dsimp [σ]
    rw [hi]
    change completedRestriction
      ((A.model (ν' n)).action (1 : K × J)) (C' n) = 1
    rw [(A.model (ν' n)).map_one, completedRestriction_one]
  have hp (n : ℕ) : p n 1 = 1 := by
    dsimp [p]
    change completedRestriction
      ((A.model (ν' n)).action (1 : K × J)) (C' n) = 1
    rw [(A.model (ν' n)).map_one, completedRestriction_one]
  have hρone (n : ℕ) : ρ n 1 = 1 := by
    dsimp [ρ]
    change completedRestriction
      (completedRestriction
        ((A.model (ν' n)).action (1 : K × J)) (C' n))
      (Z n) = 1
    rw [(A.model (ν' n)).map_one,
      completedRestriction_one, completedRestriction_one]
  have hρmul (b g : K) :
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (ρ n (b * g)) (ρ n b * ρ n g))
        atTop (𝓝 0) := by
    exact SoficGroups.KunActualTwicePrunedFirstFactorRootBad.twiceCompleted_firstFactor_mul_normalizedHamming_tendsto_zero_of_canonical_matched
      A S hone hsymmetric hgenerates F ν' Q' C' hC'
      r' hr' hmatched' D hZ hdeleted b g
  have hagrees' : ∀ n (i : ↥S)
      (x : {y : W n // y ∈ Z n}),
        completedRestriction
            ((A.model (ν' n)).action ((i : K), (1 : J)))
            (C' n) x.val ∈ Z n →
          (τ n i x).val =
            completedRestriction
              ((A.model (ν' n)).action ((i : K), (1 : J)))
              (C' n) x.val := by
    intro n i x hx
    exact hagrees n i x.val x.property hx
  have hρgenerator (i : ↥S) :
      Tendsto
        (fun n => SoficGroups.normalizedHamming
          (τ n i) (ρ n (i : K)))
        atTop (𝓝 0) := by
    exact SoficGroups.CompletedSourceFinalGeneratorTransfer.twiceCompleted_sourceGenerator_normalizedHamming_tendsto_zero
      (fun n => Fin (A.model (ν' n)).size)
      (fun n (j : ↥S) =>
        (A.model (ν' n)).action ((j : K), (1 : J)))
      (fun n (g : K) =>
        (A.model (ν' n)).action (g, (1 : J)))
      (fun j : ↥S => (j : K)) C' D τ
      (fun _ _ => rfl) hagrees' hZ hdeleted i
  have hsource : Tendsto
      (fun n =>
        ((sourceCompletionBad (σ n) (p n) F (Z n)).card : ℝ) /
          (Z n).card)
      atTop (𝓝 0) := by
    exact SoficGroups.KunActualCanonicalPrunedSourceBadDensity.pruned_sourceCompletionBad_density_tendsto_zero_of_canonical_matched
      A S hsymmetric hgenerates F ν' Q' C' hC'
      r' hmatched' D hZ hdeleted
  have hhalf : 0 < γ / 2 := by positivity
  exact SoficGroups.KunActualSelectedPrunedSourceFiniteModelBridge.nonempty_expandingCentralizerFiniteModel_of_actual_selected_pruned_source
    P S hone hcover hsymmetric hgenerates F W σ hσone
    p hp Z hZ hZlarge τ hagrees ρ hρone hρmul hρgenerator
    (γ / 2) hhalf hexp hsource

end KunActualCanonicalSelectedFiniteModelComposition

namespace KunLiteralSourceSelectedComponents

theorem sourceTransportedReferenceGenerator_disagreement_mem
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (SΓ : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (n : ℕ) (i : ↥SΓ) (x : Fin (A.model n).size)
    (h : sourceTransportedReferenceGenerators A SΓ n i x ≠
      ((SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation A).model n).action
        (SoficGroups.SourceProductThroughAlpha.sourceCompressionUAlphaEquiv
          (i : SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode),
          1) x) :
    x ∈ sourceGeneratorFamilyConjugacyBad A SΓ n := by
  classical
  unfold sourceGeneratorFamilyConjugacyBad
  apply Finset.mem_biUnion.mpr
  refine ⟨(i : SoficGroups.prefixElementaryGroup
    SoficGroups.alphaPrefixCode), i.property, ?_⟩
  unfold sourceConjugacyDisagreementBad
  apply Finset.mem_filter.mpr
  refine ⟨Finset.mem_univ x, ?_⟩
  change
    (A.model n).action
      (SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement *
        SoficGroups.SourceGeneratedWordCrossing.sourceAlphaInclusion
          (i : SoficGroups.prefixElementaryGroup
            SoficGroups.alphaPrefixCode) *
        SoficGroups.SourceBothCompressionNormalization.sourceCompressionUElement⁻¹) x ≠
      sourceTransportedReferenceGenerators A SΓ n i x
  rw [← SoficGroups.SourceProductThroughAlpha.source_u_conjugated_product_generator]
  exact Ne.symm h

end KunLiteralSourceSelectedComponents

namespace KunActualSourceSelectedCompletedGeneratorExpansion

open Filter Topology
open scoped BigOperators

theorem exists_vanishing_completed_first_factor_additive_expansion_of_selected_source
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (S : Finset
      (SoficGroups.prefixElementaryGroup SoficGroups.alphaPrefixCode))
    (hsymmetric : ∀ g ∈ S, g⁻¹ ∈ S)
    (hgenerates : Subgroup.closure
      (S : Set
        (SoficGroups.prefixElementaryGroup
          SoficGroups.alphaPrefixCode)) = ⊤)
    (Q : (n : ℕ) →
      Finpartition (Finset.univ : Finset (Fin (A.model n).size)))
    (F : Finset
      (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
        SoficGroups.ThompsonPrefixLocal.sourceLocalWord))
    (N : ℕ) (r : ℕ → ℕ)
    (C : (n : ℕ) → Finset (Fin (A.model (n + N)).size))
    (gamma : ℝ)
    (hC : ∀ n, (C n).Nonempty)
    (hexpand : ∀ n, ∀ D : Finset (Fin (A.model (n + N)).size),
      D ⊆ C n → 2 * D.card ≤ (C n).card →
        gamma * (D.card : ℝ) ≤
          (SoficGroups.boundary
            (SoficGroups.KunLiteralSourceSelectedComponents.sourceTransportedReferenceGenerators
              A S (n + N)) D : ℝ))
    (hboundary : Tendsto
      (fun n =>
        (SoficGroups.boundary
          (SoficGroups.KunLiteralSourceSelectedComponents.sourceTransportedReferenceGenerators
            A S (n + N)) (C n) : ℝ) / (C n).card)
      atTop (nhds 0))
    (hguarded : Tendsto
      (fun n =>
        (((C n ∩ SoficGroups.matchedRadiusBad
          (SoficGroups.KunLiteralSourceSelectedComponents.sourceTransportedPartition
            A Q (n + N))
          (SoficGroups.KunLiteralSourceSelectedComponents.sourceSelectedProductRadiusLabels
            S F (r n))
          (((SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation
            A).model (n + N)).action)
          (SoficGroups.KunLiteralSourceSelectedComponents.sourceSelectedRadiusBad
            A S hsymmetric hgenerates F (n + N) (r n))).card : ℝ) /
              (C n).card))
      atTop (nhds 0)) :
    ∃ a : ℕ → ℝ,
      (∀ n, 0 ≤ a n) ∧
      Tendsto a atTop (nhds 0) ∧
      ∀ n, ∀ E : Finset
        {x : Fin (A.model (n + N)).size // x ∈ C n},
        gamma * min (E.card : ℝ)
          ((Fintype.card
            {x : Fin (A.model (n + N)).size // x ∈ C n} : ℝ) -
              E.card) -
          a n * Fintype.card
            {x : Fin (A.model (n + N)).size // x ∈ C n} ≤
            (SoficGroups.boundary
              (fun i :
                ↥(SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset
                  S) =>
                SoficGroups.MatchedComponentCompletion.completedRestriction
                  (((SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation
                    A).model (n + N)).action
                    ((i : SoficGroups.prefixElementaryGroup
                      SoficGroups.alphaZeroPrefixCode), 1))
                  (C n)) E : ℝ) := by
  classical
  have hbad_density : Tendsto
      (fun n =>
        (((C n ∩
          SoficGroups.KunLiteralSourceSelectedComponents.sourceGeneratorFamilyConjugacyBad
            A S (n + N)).card : ℝ) / (C n).card))
      atTop (nhds 0) := by
    refine squeeze_zero (fun n => by positivity) (fun n => ?_) hguarded
    apply div_le_div_of_nonneg_right _ (by positivity)
    exact_mod_cast Finset.card_le_card (by
      intro x hx
      obtain ⟨hxC, hxE⟩ := Finset.mem_inter.mp hx
      apply Finset.mem_inter.mpr
      refine ⟨hxC, ?_⟩
      unfold SoficGroups.matchedRadiusBad
      apply Finset.mem_union_left
      change x ∈
        SoficGroups.CanonicalProductRadiusBadMatchedCapture.canonicalProductRadiusBad
          (SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation A)
          (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset S)
          (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_inv_mem
            S hsymmetric)
          (SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_closure
            S hgenerates)
          F (n + N) (r n) ∪
          SoficGroups.KunLiteralSourceSelectedComponents.sourceGeneratorFamilyConjugacyBad
            A S (n + N)
      exact Finset.mem_union_right _ hxE)
  obtain ⟨a, ha_nonnegative, ha_zero, ha_expand⟩ :=
    SoficGroups.KunActualFirstStageReferenceExpansion.exists_vanishing_completedRestriction_additive_expansion_of_selected_bad
      (fun n => Fin (A.model (n + N)).size)
      (↥S) C
      (fun n =>
        SoficGroups.KunLiteralSourceSelectedComponents.sourceGeneratorFamilyConjugacyBad
          A S (n + N))
      hC
      (fun n =>
        SoficGroups.KunLiteralSourceSelectedComponents.sourceTransportedReferenceGenerators
          A S (n + N))
      (fun n (i : ↥S) =>
        ((SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation
          A).model (n + N)).action
            (SoficGroups.SourceProductThroughAlpha.sourceCompressionUAlphaEquiv
              (i : SoficGroups.prefixElementaryGroup
                SoficGroups.alphaPrefixCode), 1))
      gamma hexpand
      (fun n i x _hx hdis =>
        SoficGroups.KunLiteralSourceSelectedComponents.sourceTransportedReferenceGenerator_disagreement_mem
          A S (n + N) i x hdis)
      hboundary hbad_density
  refine ⟨a, ha_nonnegative, ha_zero, ?_⟩
  intro n E
  have h := ha_expand n E
  have hreindex :
      SoficGroups.boundary
        (fun i : ↥S =>
          SoficGroups.MatchedComponentCompletion.completedRestriction
            (((SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation
              A).model (n + N)).action
              (SoficGroups.SourceProductThroughAlpha.sourceCompressionUAlphaEquiv
                (i : SoficGroups.prefixElementaryGroup
                  SoficGroups.alphaPrefixCode), 1))
            (C n)) E =
        SoficGroups.boundary
          (fun i :
            ↥(SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset
              S) =>
            SoficGroups.MatchedComponentCompletion.completedRestriction
              (((SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation
                A).model (n + N)).action
                ((i : SoficGroups.prefixElementaryGroup
                  SoficGroups.alphaZeroPrefixCode), 1))
              (C n)) E := by
    exact
      SoficGroups.SourceProductThroughAlpha.boundary_sourceCompressedGeneratorSubtypeEquiv
        S
        (fun i :
          ↥(SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset
            S) =>
          SoficGroups.MatchedComponentCompletion.completedRestriction
            (((SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation
              A).model (n + N)).action
              ((i : SoficGroups.prefixElementaryGroup
                SoficGroups.alphaZeroPrefixCode), 1))
            (C n))
        E
  exact h.trans_eq (congrArg (fun t : ℕ => (t : ℝ)) hreindex)

end KunActualSourceSelectedCompletedGeneratorExpansion

namespace KunLiteralNineSourceFiniteModels

open Filter Topology
open SoficGroups.CanonicalProductRadiusBadMatchedCapture
open scoped BigOperators Pointwise

theorem source_ambient_nonempty_expandingCentralizerFiniteModel
    (A : SoficGroups.SoficApproximation
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode))
    (F : Finset
      (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
        SoficGroups.ThompsonPrefixLocal.sourceLocalWord)) :
    Nonempty
      (SoficGroups.ExpandingCentralizerFiniteModel
        (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
          SoficGroups.ThompsonPrefixLocal.sourceLocalWord) F) := by
  classical
  obtain ⟨S, hsymmetric, hgenerates, Q, gamma, N, r, C,
      hone, hgamma, _hsource, hr, hC, hCnonempty,
      hexpand, hboundary, hguarded, hlarge⟩ :=
    SoficGroups.KunLiteralSourceSelectedComponents.exists_source_selected_components
      A F
  let K : Type :=
    SoficGroups.prefixElementaryGroup SoficGroups.alphaZeroPrefixCode
  let J : Type :=
    SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
      SoficGroups.ThompsonPrefixLocal.sourceLocalWord
  let AP : SoficGroups.SoficApproximation (K × J) :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedLocalProductApproximation
      A
  let SK : Finset K :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset S
  have hSKone : 1 ∈ SK :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_one_mem
      S hone
  have hSKsymmetric : ∀ k ∈ SK, k⁻¹ ∈ SK :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_inv_mem
      S hsymmetric
  have hSKgenerates : Subgroup.closure (SK : Set K) = ⊤ :=
    SoficGroups.SourceProductThroughAlpha.sourceCompressedGeneratingFinset_closure
      S hgenerates
  have hpair : ∃ P : SoficGroups.KazhdanPair.{0, 0} K,
      P.generators = SK :=
    SoficGroups.SourceProductThroughAlpha.exists_sourceCompressedKazhdanPair_with_same_generators
      S hsymmetric hgenerates
  obtain ⟨PK, hPK⟩ := hpair
  have hcover : PK.generators ⊆ SK := by
    rw [hPK]
  let ν : ℕ → ℕ := fun n => n + N
  let QK : (n : ℕ) → Finpartition
      (Finset.univ : Finset (Fin (AP.model (ν n)).size)) :=
    fun n =>
      SoficGroups.KunLiteralSourceSelectedComponents.sourceTransportedPartition
        A Q (n + N)
  have hCK (n : ℕ) : C n ∈ (QK n).parts := hC n
  have hbad_eq (n : ℕ) :
      SoficGroups.KunLiteralSourceSelectedComponents.sourceSelectedRadiusBad
        A S hsymmetric hgenerates F (n + N) (r n) =
        canonicalProductRadiusBad
          AP SK hSKsymmetric hSKgenerates F (ν n) (r n) ∪
        SoficGroups.KunLiteralSourceSelectedComponents.sourceGeneratorFamilyConjugacyBad
          A S (n + N) := by
    rfl
  have hlabel_eq (n : ℕ) :
      SoficGroups.KunLiteralSourceSelectedComponents.sourceSelectedProductRadiusLabels
        S F (r n) =
      sourceProductRadiusLabels SK F (r n) := by
    rfl
  have hguarded' :
      Tendsto
        (fun n =>
          (((C n ∩ SoficGroups.matchedRadiusBad
            (QK n)
            (sourceProductRadiusLabels SK F (r n))
            ((AP.model (ν n)).action)
            (canonicalProductRadiusBad
              AP SK hSKsymmetric hSKgenerates F (ν n) (r n) ∪
              SoficGroups.KunLiteralSourceSelectedComponents.sourceGeneratorFamilyConjugacyBad
                A S (n + N))).card : ℝ) /
              (C n).card))
        atTop (𝓝 0) := by
    have hguarded_eq := hguarded
    simp_rw [hbad_eq, hlabel_eq] at hguarded_eq
    convert hguarded_eq using 1
    funext n
    simp only [QK, AP, ν]
    congr 2
  have hcanonical :
      Tendsto
        (fun n =>
          (((C n ∩ SoficGroups.matchedRadiusBad
            (QK n)
            (sourceProductRadiusLabels SK F (r n))
            ((AP.model (ν n)).action)
            (canonicalProductRadiusBad
              AP SK hSKsymmetric hSKgenerates F (ν n) (r n))).card : ℝ) /
              (C n).card))
        atTop (𝓝 0) := by
    exact SoficGroups.KunGuardedCanonicalMatchedDensity.canonical_matched_density_of_guarded
      (fun n => Fin (AP.model (ν n)).size)
      (fun n => (Finset.univ : Finset (Fin (AP.model (ν n)).size)))
      QK
      (fun n => sourceProductRadiusLabels SK F (r n))
      (fun n => (AP.model (ν n)).action)
      (fun n => canonicalProductRadiusBad
        AP SK hSKsymmetric hSKgenerates F (ν n) (r n))
      (fun n =>
        SoficGroups.KunLiteralSourceSelectedComponents.sourceGeneratorFamilyConjugacyBad
          A S (n + N))
      C hguarded'
  obtain ⟨a, _ha_nonnegative, ha, hadd⟩ :=
    SoficGroups.KunActualSourceSelectedCompletedGeneratorExpansion.exists_vanishing_completed_first_factor_additive_expansion_of_selected_source
      A S hsymmetric hgenerates Q F N r C gamma
      hCnonempty hexpand hboundary hguarded
  exact SoficGroups.KunActualCanonicalSelectedFiniteModelComposition.nonempty_expandingCentralizerFiniteModel_of_canonical_selected_additive
    AP PK SK hSKone hcover hSKsymmetric hSKgenerates F
    ν QK C hCK r hr hcanonical hlarge gamma hgamma a ha hadd

end KunLiteralNineSourceFiniteModels

namespace SourceTopLevelCompressionFinal

open SoficGroups.SourceTopLevelCompression
open SoficGroups.KunLiteralNineSourceFiniteModels

theorem sourceLocalPrefixTranspositionGroup_lef_of_sofic :
    SoficGroups.Sofic
        (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) →
      SoficGroups.LEF
        (SoficGroups.ThompsonPrefixInsertion.localPrefixTranspositionGroup
          SoficGroups.ThompsonPrefixLocal.sourceLocalWord) := by
  intro hsource
  exact sourceLocalPrefixTranspositionGroup_lef_of_source_finite_models
    (fun A _ F =>
      source_ambient_nonempty_expandingCentralizerFiniteModel A F)
    hsource

theorem ninePrefixElementaryGroup_not_sofic :
    ¬ SoficGroups.Sofic
      (SoficGroups.prefixElementaryGroup SoficGroups.ninePrefixCode) := by
  intro hsource
  exact SoficGroups.sourceLocalPrefixTranspositionGroup_notLEF
    (sourceLocalPrefixTranspositionGroup_lef_of_sofic hsource)

theorem binaryLeavittElementaryGroup_not_sofic :
    ¬ SoficGroups.Sofic (SoficGroups.binaryLeavittElementaryGroup 9) := by
  intro hsofic
  letI : SoficGroups.Sofic
    (SoficGroups.binaryLeavittElementaryGroup 9) := hsofic
  exact ninePrefixElementaryGroup_not_sofic
    (SoficGroups.sofic_of_injective
      SoficGroups.ninePrefixElementaryGroupEquiv.symm.toMonoidHom
      SoficGroups.ninePrefixElementaryGroupEquiv.symm.injective)

theorem exists_finitelyPresented_nonsofic_group :
    ∃ (G : Type) (_ : Group G),
      Group.IsFinitelyPresented G ∧ ¬ SoficGroups.Sofic G := by
  exact SoficGroups.exists_finitelyPresented_not_sofic_of_not_sofic
    binaryLeavittElementaryGroup_not_sofic

end SourceTopLevelCompressionFinal

end SoficGroups

end
