/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import order.atoms
import order.order_iso_nat
import order.rel_iso.set
import order.sup_indep
import order.zorn
import data.finset.order
import data.set.intervals.order_iso
import data.finite.set
import tactic.tfae

/-!
# Compactness properties for complete lattices

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

For complete lattices, there are numerous equivalent ways to express the fact that the relation `>`
is well-founded. In this file we define three especially-useful characterisations and provide
proofs that they are indeed equivalent to well-foundedness.

## Main definitions
 * `complete_lattice.is_sup_closed_compact`
 * `complete_lattice.is_Sup_finite_compact`
 * `complete_lattice.is_compact_element`
 * `complete_lattice.is_compactly_generated`

## Main results
The main result is that the following four conditions are equivalent for a complete lattice:
 * `well_founded (>)`
 * `complete_lattice.is_sup_closed_compact`
 * `complete_lattice.is_Sup_finite_compact`
 * `∀ k, complete_lattice.is_compact_element k`

This is demonstrated by means of the following four lemmas:
 * `complete_lattice.well_founded.is_Sup_finite_compact`
 * `complete_lattice.is_Sup_finite_compact.is_sup_closed_compact`
 * `complete_lattice.is_sup_closed_compact.well_founded`
 * `complete_lattice.is_Sup_finite_compact_iff_all_elements_compact`

 We also show well-founded lattices are compactly generated
 (`complete_lattice.compactly_generated_of_well_founded`).

## References
- [G. Călugăreanu, *Lattice Concepts of Module Theory*][calugareanu]

## Tags

complete lattice, well-founded, compact
-/

variables {α : Type*} [complete_lattice α]

namespace complete_lattice

variables (α)

/-- A compactness property for a complete lattice is that any `sup`-closed non-empty subset
contains its `Sup`. -/
def is_sup_closed_compact : Prop :=
  ∀ (s : set α) (h : s.nonempty), (∀ a b ∈ s, a ⊔ b ∈ s) → (Sup s) ∈ s

/-- A compactness property for a complete lattice is that any subset has a finite subset with the
same `Sup`. -/
def is_Sup_finite_compact : Prop :=
∀ (s : set α), ∃ (t : finset α), ↑t ⊆ s ∧ Sup s = t.sup id

/-- An element `k` of a complete lattice is said to be compact if any set with `Sup`
above `k` has a finite subset with `Sup` above `k`.  Such an element is also called
"finite" or "S-compact". -/
def is_compact_element {α : Type*} [complete_lattice α] (k : α) :=
∀ s : set α, k ≤ Sup s → ∃ t : finset α, ↑t ⊆ s ∧ k ≤ t.sup id

lemma {u} is_compact_element_iff {α : Type u} [complete_lattice α] (k : α) :
  complete_lattice.is_compact_element k ↔
    ∀ (ι : Type u) (s : ι → α), k ≤ supr s → ∃ t : finset ι, k ≤ t.sup s :=
begin
  classical,
  split,
  { intros H ι s hs,
    obtain ⟨t, ht, ht'⟩ := H (set.range s) hs,
    have : ∀ x : t, ∃ i, s i = x := λ x, ht x.prop,
    choose f hf using this,
    refine ⟨finset.univ.image f, ht'.trans _⟩,
    { rw finset.sup_le_iff,
      intros b hb,
      rw ← (show s (f ⟨b, hb⟩) = id b, from hf _),
      exact finset.le_sup (finset.mem_image_of_mem f $ finset.mem_univ ⟨b, hb⟩) } },
  { intros H s hs,
    obtain ⟨t, ht⟩ := H s coe (by { delta supr, rwa subtype.range_coe }),
    refine ⟨t.image coe, by simp, ht.trans _⟩,
    rw finset.sup_le_iff,
    exact λ x hx, @finset.le_sup _ _ _ _ _ id _ (finset.mem_image_of_mem coe hx) }
end

/-- An element `k` is compact if and only if any directed set with `Sup` above
`k` already got above `k` at some point in the set. -/
theorem is_compact_element_iff_le_of_directed_Sup_le (k : α) :
  is_compact_element k ↔
  ∀ s : set α, s.nonempty → directed_on (≤) s → k ≤ Sup s → ∃ x : α, x ∈ s ∧ k ≤ x :=
begin
  classical,
  split,
  { intros hk s hne hdir hsup,
    obtain ⟨t, ht⟩ := hk s hsup,
    -- certainly every element of t is below something in s, since ↑t ⊆ s.
    have t_below_s : ∀ x ∈ t, ∃ y ∈ s, x ≤ y, from λ x hxt, ⟨x, ht.left hxt, le_rfl⟩,
    obtain ⟨x, ⟨hxs, hsupx⟩⟩ := finset.sup_le_of_le_directed s hne hdir t t_below_s,
    exact ⟨x, ⟨hxs, le_trans ht.right hsupx⟩⟩, },
  { intros hk s hsup,
    -- Consider the set of finite joins of elements of the (plain) set s.
    let S : set α := { x | ∃ t : finset α, ↑t ⊆ s ∧ x = t.sup id },
    -- S is directed, nonempty, and still has sup above k.
    have dir_US : directed_on (≤) S,
    { rintros x ⟨c, hc⟩ y ⟨d, hd⟩,
      use x ⊔ y,
      split,
      { use c ∪ d,
        split,
        { simp only [hc.left, hd.left, set.union_subset_iff, finset.coe_union, and_self], },
        { simp only [hc.right, hd.right, finset.sup_union], }, },
      simp only [and_self, le_sup_left, le_sup_right], },
    have sup_S : Sup s ≤ Sup S,
    { apply Sup_le_Sup,
      intros x hx, use {x},
      simpa only [and_true, id.def, finset.coe_singleton, eq_self_iff_true, finset.sup_singleton,
        set.singleton_subset_iff], },
    have Sne : S.nonempty,
    { suffices : ⊥ ∈ S, from set.nonempty_of_mem this,
      use ∅,
      simp only [set.empty_subset, finset.coe_empty, finset.sup_empty,
        eq_self_iff_true, and_self], },
    -- Now apply the defn of compact and finish.
    obtain ⟨j, ⟨hjS, hjk⟩⟩ := hk S Sne dir_US (le_trans hsup sup_S),
    obtain ⟨t, ⟨htS, htsup⟩⟩ := hjS,
    use t, exact ⟨htS, by rwa ←htsup⟩, },
end

lemma is_compact_element.exists_finset_of_le_supr {k : α} (hk : is_compact_element k)
  {ι : Type*} (f : ι → α) (h : k ≤ ⨆ i, f i) : ∃ s : finset ι, k ≤ ⨆ i ∈ s, f i :=
begin
  classical,
  let g : finset ι → α := λ s, ⨆ i ∈ s, f i,
  have h1 : directed_on (≤) (set.range g),
  { rintros - ⟨s, rfl⟩ - ⟨t, rfl⟩,
    exact ⟨g (s ∪ t), ⟨s ∪ t, rfl⟩, supr_le_supr_of_subset (finset.subset_union_left s t),
      supr_le_supr_of_subset (finset.subset_union_right s t)⟩ },
  have h2 : k ≤ Sup (set.range g),
  { exact h.trans (supr_le (λ i, le_Sup_of_le ⟨{i}, rfl⟩ (le_supr_of_le i (le_supr_of_le
      (finset.mem_singleton_self i) le_rfl)))) },
  obtain ⟨-, ⟨s, rfl⟩, hs⟩ := (is_compact_element_iff_le_of_directed_Sup_le α k).mp hk
    (set.range g) (set.range_nonempty g) h1 h2,
  exact ⟨s, hs⟩,
end

/-- A compact element `k` has the property that any directed set lying strictly below `k` has
its Sup strictly below `k`. -/
lemma is_compact_element.directed_Sup_lt_of_lt {α : Type*} [complete_lattice α] {k : α}
  (hk : is_compact_element k) {s : set α} (hemp : s.nonempty) (hdir : directed_on (≤) s)
  (hbelow : ∀ x ∈ s, x < k) : Sup s < k :=
begin
  rw is_compact_element_iff_le_of_directed_Sup_le at hk,
  by_contradiction,
  have sSup : Sup s ≤ k, from Sup_le (λ s hs, (hbelow s hs).le),
  replace sSup : Sup s = k := eq_iff_le_not_lt.mpr ⟨sSup, h⟩,
  obtain ⟨x, hxs, hkx⟩ := hk s hemp hdir sSup.symm.le,
  obtain hxk := hbelow x hxs,
  exact hxk.ne (hxk.le.antisymm hkx),
end

lemma finset_sup_compact_of_compact {α β : Type*} [complete_lattice α] {f : β → α}
  (s : finset β) (h : ∀ x ∈ s, is_compact_element (f x)) : is_compact_element (s.sup f) :=
begin
  classical,
  rw is_compact_element_iff_le_of_directed_Sup_le,
  intros d hemp hdir hsup,
  change f with id ∘ f, rw ←finset.sup_finset_image,
  apply finset.sup_le_of_le_directed d hemp hdir,
  rintros x hx,
  obtain ⟨p, ⟨hps, rfl⟩⟩ := finset.mem_image.mp hx,
  specialize h p hps,
  rw is_compact_element_iff_le_of_directed_Sup_le at h,
  specialize h d hemp hdir (le_trans (finset.le_sup hps) hsup),
  simpa only [exists_prop],
end

lemma well_founded.is_Sup_finite_compact (h : well_founded ((>) : α → α → Prop)) :
  is_Sup_finite_compact α :=
λ s, begin
  obtain ⟨m, ⟨t, ⟨ht₁, rfl⟩⟩, hm⟩ := well_founded.well_founded_iff_has_min.mp h
    {x | ∃ t : finset α, ↑t ⊆ s ∧ t.sup id = x} ⟨⊥, ∅, by simp⟩,
  refine ⟨t, ht₁, (Sup_le (λ y hy, _)).antisymm _⟩,
  { classical,
    rw eq_of_le_of_not_lt (finset.sup_mono (t.subset_insert y))
      (hm _ ⟨insert y t, by simp [set.insert_subset, hy, ht₁]⟩),
    simp },
  { rw finset.sup_id_eq_Sup,
    exact Sup_le_Sup ht₁ },
end

lemma is_Sup_finite_compact.is_sup_closed_compact (h : is_Sup_finite_compact α) :
  is_sup_closed_compact α :=
begin
  intros s hne hsc, obtain ⟨t, ht₁, ht₂⟩ := h s, clear h,
  cases t.eq_empty_or_nonempty with h h,
  { subst h, rw finset.sup_empty at ht₂, rw ht₂,
    simp [eq_singleton_bot_of_Sup_eq_bot_of_nonempty ht₂ hne], },
  { rw ht₂, exact t.sup_closed_of_sup_closed h ht₁ hsc, },
end

lemma is_sup_closed_compact.well_founded (h : is_sup_closed_compact α) :
  well_founded ((>) : α → α → Prop) :=
begin
  refine rel_embedding.well_founded_iff_no_descending_seq.mpr ⟨λ a, _⟩,
  suffices : Sup (set.range a) ∈ set.range a,
  { obtain ⟨n, hn⟩ := set.mem_range.mp this,
    have h' : Sup (set.range a) < a (n+1), { change _ > _, simp [← hn, a.map_rel_iff], },
    apply lt_irrefl (a (n+1)), apply lt_of_le_of_lt _ h', apply le_Sup, apply set.mem_range_self, },
  apply h (set.range a),
  { use a 37, apply set.mem_range_self, },
  { rintros x ⟨m, hm⟩ y ⟨n, hn⟩, use m ⊔ n, rw [← hm, ← hn], apply rel_hom_class.map_sup a, },
end

lemma is_Sup_finite_compact_iff_all_elements_compact :
  is_Sup_finite_compact α ↔ (∀ k : α, is_compact_element k) :=
begin
  refine ⟨λ h k s hs, _, λ h s, _⟩,
  { obtain ⟨t, ⟨hts, htsup⟩⟩ := h s,
    use [t, hts],
    rwa ←htsup, },
  { obtain ⟨t, ⟨hts, htsup⟩⟩ := h (Sup s) s (by refl),
    have : Sup s = t.sup id,
    { suffices : t.sup id ≤ Sup s, by { apply le_antisymm; assumption },
      simp only [id.def, finset.sup_le_iff],
      intros x hx,
      exact le_Sup (hts hx) },
    use [t, hts, this] },
end

lemma well_founded_characterisations :
  tfae [well_founded ((>) : α → α → Prop),
        is_Sup_finite_compact α,
        is_sup_closed_compact α,
        ∀ k : α, is_compact_element k] :=
begin
  tfae_have : 1 → 2, by { exact well_founded.is_Sup_finite_compact α, },
  tfae_have : 2 → 3, by { exact is_Sup_finite_compact.is_sup_closed_compact α, },
  tfae_have : 3 → 1, by { exact is_sup_closed_compact.well_founded α, },
  tfae_have : 2 ↔ 4, by { exact is_Sup_finite_compact_iff_all_elements_compact α },
  tfae_finish,
end

lemma well_founded_iff_is_Sup_finite_compact :
  well_founded ((>) : α → α → Prop) ↔ is_Sup_finite_compact α :=
(well_founded_characterisations α).out 0 1

lemma is_Sup_finite_compact_iff_is_sup_closed_compact :
  is_Sup_finite_compact α ↔ is_sup_closed_compact α :=
(well_founded_characterisations α).out 1 2

lemma is_sup_closed_compact_iff_well_founded :
  is_sup_closed_compact α ↔ well_founded ((>) : α → α → Prop) :=
(well_founded_characterisations α).out 2 0

alias well_founded_iff_is_Sup_finite_compact ↔ _ is_Sup_finite_compact.well_founded
alias is_Sup_finite_compact_iff_is_sup_closed_compact ↔
      _ is_sup_closed_compact.is_Sup_finite_compact
alias is_sup_closed_compact_iff_well_founded ↔ _ _root_.well_founded.is_sup_closed_compact

variables {α}

lemma well_founded.finite_of_set_independent (h : well_founded ((>) : α → α → Prop))
  {s : set α} (hs : set_independent s) : s.finite :=
begin
  classical,
  refine set.not_infinite.mp (λ contra, _),
  obtain ⟨t, ht₁, ht₂⟩ := well_founded.is_Sup_finite_compact α h s,
  replace contra : ∃ (x : α), x ∈ s ∧ x ≠ ⊥ ∧ x ∉ t,
  { have : (s \ (insert ⊥ t : finset α)).infinite := contra.diff (finset.finite_to_set _),
    obtain ⟨x, hx₁, hx₂⟩ := this.nonempty,
    exact ⟨x, hx₁, by simpa [not_or_distrib] using hx₂⟩, },
  obtain ⟨x, hx₀, hx₁, hx₂⟩ := contra,
  replace hs : x ⊓ Sup s = ⊥,
  { have := hs.mono (by simp [ht₁, hx₀, -set.union_singleton] : ↑t ∪ {x} ≤ s) (by simp : x ∈ _),
    simpa [disjoint, hx₂, ← t.sup_id_eq_Sup, ← ht₂] using this.eq_bot, },
  apply hx₁,
  rw [← hs, eq_comm, inf_eq_left],
  exact le_Sup hx₀,
end

lemma well_founded.finite_of_independent (hwf : well_founded ((>) : α → α → Prop))
  {ι : Type*} {t : ι → α} (ht : independent t) (h_ne_bot : ∀ i, t i ≠ ⊥) : finite ι :=
begin
  haveI := (well_founded.finite_of_set_independent hwf ht.set_independent_range).to_subtype,
  exact finite.of_injective_finite_range (ht.injective h_ne_bot),
end

end complete_lattice

/-- A complete lattice is said to be compactly generated if any
element is the `Sup` of compact elements. -/
class is_compactly_generated (α : Type*) [complete_lattice α] : Prop :=
(exists_Sup_eq :
  ∀ (x : α), ∃ (s : set α), (∀ x ∈ s, complete_lattice.is_compact_element x) ∧ Sup s = x)

section
variables {α} [is_compactly_generated α] {a b : α} {s : set α}

@[simp]
lemma Sup_compact_le_eq (b) : Sup {c : α | complete_lattice.is_compact_element c ∧ c ≤ b} = b :=
begin
  rcases is_compactly_generated.exists_Sup_eq b with ⟨s, hs, rfl⟩,
  exact le_antisymm (Sup_le (λ c hc, hc.2)) (Sup_le_Sup (λ c cs, ⟨hs c cs, le_Sup cs⟩)),
end

@[simp]
theorem Sup_compact_eq_top :
  Sup {a : α | complete_lattice.is_compact_element a} = ⊤ :=
begin
  refine eq.trans (congr rfl (set.ext (λ x, _))) (Sup_compact_le_eq ⊤),
  exact (and_iff_left le_top).symm,
end

theorem le_iff_compact_le_imp {a b : α} :
  a ≤ b ↔ ∀ c : α, complete_lattice.is_compact_element c → c ≤ a → c ≤ b :=
⟨λ ab c hc ca, le_trans ca ab, λ h, begin
  rw [← Sup_compact_le_eq a, ← Sup_compact_le_eq b],
  exact Sup_le_Sup (λ c hc, ⟨hc.1, h c hc.1 hc.2⟩),
end⟩

/-- This property is sometimes referred to as `α` being upper continuous. -/
theorem inf_Sup_eq_of_directed_on (h : directed_on (≤) s):
  a ⊓ Sup s = ⨆ b ∈ s, a ⊓ b :=
le_antisymm (begin
  rw le_iff_compact_le_imp,
  by_cases hs : s.nonempty,
  { intros c hc hcinf,
    rw le_inf_iff at hcinf,
    rw complete_lattice.is_compact_element_iff_le_of_directed_Sup_le at hc,
    rcases hc s hs h hcinf.2 with ⟨d, ds, cd⟩,
    exact (le_inf hcinf.1 cd).trans (le_supr₂ d ds) },
  { rw set.not_nonempty_iff_eq_empty at hs,
    simp [hs] }
end) supr_inf_le_inf_Sup

/-- This property is equivalent to `α` being upper continuous. -/
theorem inf_Sup_eq_supr_inf_sup_finset :
  a ⊓ Sup s = ⨆ (t : finset α) (H : ↑t ⊆ s), a ⊓ (t.sup id) :=
le_antisymm (begin
  rw le_iff_compact_le_imp,
  intros c hc hcinf,
  rw le_inf_iff at hcinf,
  rcases hc s hcinf.2 with ⟨t, ht1, ht2⟩,
  exact (le_inf hcinf.1 ht2).trans (le_supr₂ t ht1),
end)
  (supr_le $ λ t, supr_le $ λ h, inf_le_inf_left _ ((finset.sup_id_eq_Sup t).symm ▸ (Sup_le_Sup h)))

theorem complete_lattice.set_independent_iff_finite {s : set α} :
  complete_lattice.set_independent s ↔
    ∀ t : finset α, ↑t ⊆ s → complete_lattice.set_independent (↑t : set α) :=
⟨λ hs t ht, hs.mono ht, λ h a ha, begin
  rw [disjoint_iff, inf_Sup_eq_supr_inf_sup_finset, supr_eq_bot],
  intro t,
  rw [supr_eq_bot, finset.sup_id_eq_Sup],
  intro ht,
  classical,
  have h' := (h (insert a t) _ (t.mem_insert_self a)).eq_bot,
  { rwa [finset.coe_insert, set.insert_diff_self_of_not_mem] at h',
    exact λ con, ((set.mem_diff a).1 (ht con)).2 (set.mem_singleton a) },
  { rw [finset.coe_insert, set.insert_subset],
    exact ⟨ha, set.subset.trans ht (set.diff_subset _ _)⟩ }
end⟩

lemma complete_lattice.set_independent_Union_of_directed {η : Type*}
  {s : η → set α} (hs : directed (⊆) s)
  (h : ∀ i, complete_lattice.set_independent (s i)) :
  complete_lattice.set_independent (⋃ i, s i) :=
begin
  by_cases hη : nonempty η,
  { resetI,
    rw complete_lattice.set_independent_iff_finite,
    intros t ht,
    obtain ⟨I, fi, hI⟩ := set.finite_subset_Union t.finite_to_set ht,
    obtain ⟨i, hi⟩ := hs.finset_le fi.to_finset,
    exact (h i).mono (set.subset.trans hI $ set.Union₂_subset $
      λ j hj, hi j (fi.mem_to_finset.2 hj)) },
  { rintros a ⟨_, ⟨i, _⟩, _⟩,
    exfalso, exact hη ⟨i⟩, },
end

lemma complete_lattice.independent_sUnion_of_directed {s : set (set α)}
  (hs : directed_on (⊆) s)
  (h : ∀ a ∈ s, complete_lattice.set_independent a) :
  complete_lattice.set_independent (⋃₀ s) :=
by rw set.sUnion_eq_Union; exact
  complete_lattice.set_independent_Union_of_directed hs.directed_coe (by simpa using h)

end

namespace complete_lattice

lemma compactly_generated_of_well_founded (h : well_founded ((>) : α → α → Prop)) :
  is_compactly_generated α :=
begin
  rw [well_founded_iff_is_Sup_finite_compact, is_Sup_finite_compact_iff_all_elements_compact] at h,
  -- x is the join of the set of compact elements {x}
  exact ⟨λ x, ⟨{x}, ⟨λ x _, h x, Sup_singleton⟩⟩⟩,
end

/-- A compact element `k` has the property that any `b < k` lies below a "maximal element below
`k`", which is to say `[⊥, k]` is coatomic. -/
theorem Iic_coatomic_of_compact_element {k : α} (h : is_compact_element k) :
  is_coatomic (set.Iic k) :=
⟨λ ⟨b, hbk⟩, begin
  by_cases htriv : b = k,
  { left, ext, simp only [htriv, set.Iic.coe_top, subtype.coe_mk], },
  right,
  obtain ⟨a, a₀, ba, h⟩ := zorn_nonempty_partial_order₀ (set.Iio k) _ b (lt_of_le_of_ne hbk htriv),
  { refine ⟨⟨a, le_of_lt a₀⟩, ⟨ne_of_lt a₀, λ c hck, by_contradiction $ λ c₀, _⟩, ba⟩,
    cases h c.1 (lt_of_le_of_ne c.2 (λ con, c₀ (subtype.ext con))) hck.le,
    exact lt_irrefl _ hck, },
  { intros S SC cC I IS,
    by_cases hS : S.nonempty,
    { exact ⟨Sup S, h.directed_Sup_lt_of_lt hS cC.directed_on SC, λ _, le_Sup⟩, },
    exact ⟨b, lt_of_le_of_ne hbk htriv, by simp only [set.not_nonempty_iff_eq_empty.mp hS,
      set.mem_empty_iff_false, forall_const, forall_prop_of_false, not_false_iff]⟩, },
end⟩

lemma coatomic_of_top_compact (h : is_compact_element (⊤ : α)) : is_coatomic α :=
(@order_iso.Iic_top α _ _).is_coatomic_iff.mp (Iic_coatomic_of_compact_element h)

end complete_lattice

section
variables [is_modular_lattice α] [is_compactly_generated α]

@[priority 100]
instance is_atomic_of_complemented_lattice [complemented_lattice α] : is_atomic α :=
⟨λ b, begin
  by_cases h : {c : α | complete_lattice.is_compact_element c ∧ c ≤ b} ⊆ {⊥},
  { left,
    rw [← Sup_compact_le_eq b, Sup_eq_bot],
    exact h },
  { rcases set.not_subset.1 h with ⟨c, ⟨hc, hcb⟩, hcbot⟩,
    right,
    have hc' := complete_lattice.Iic_coatomic_of_compact_element hc,
    rw ← is_atomic_iff_is_coatomic at hc',
    haveI := hc',
    obtain con | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le (⟨c, le_refl c⟩ : set.Iic c),
    { exfalso,
      apply hcbot,
      simp only [subtype.ext_iff, set.Iic.coe_bot, subtype.coe_mk] at con,
      exact con },
    rw [← subtype.coe_le_coe, subtype.coe_mk] at hac,
    exact ⟨a, ha.of_is_atom_coe_Iic, hac.trans hcb⟩ },
end⟩

/-- See Lemma 5.1, Călugăreanu -/
@[priority 100]
instance is_atomistic_of_complemented_lattice [complemented_lattice α] : is_atomistic α :=
⟨λ b, ⟨{a | is_atom a ∧ a ≤ b}, begin
  symmetry,
  have hle : Sup {a : α | is_atom a ∧ a ≤ b} ≤ b := (Sup_le $ λ _, and.right),
  apply (lt_or_eq_of_le hle).resolve_left (λ con, _),
  obtain ⟨c, hc⟩ := exists_is_compl (⟨Sup {a : α | is_atom a ∧ a ≤ b}, hle⟩ : set.Iic b),
  obtain rfl | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le c,
  { exact ne_of_lt con (subtype.ext_iff.1 (eq_top_of_is_compl_bot hc)) },
  { apply ha.1,
    rw eq_bot_iff,
    apply le_trans (le_inf _ hac) hc.disjoint.le_bot,
    rw [← subtype.coe_le_coe, subtype.coe_mk],
    exact le_Sup ⟨ha.of_is_atom_coe_Iic, a.2⟩ }
end, λ _, and.left⟩⟩

/-- See Theorem 6.6, Călugăreanu -/
theorem complemented_lattice_of_Sup_atoms_eq_top (h : Sup {a : α | is_atom a} = ⊤) :
  complemented_lattice α :=
⟨λ b, begin
  obtain ⟨s, ⟨s_ind, b_inf_Sup_s, s_atoms⟩, s_max⟩ := zorn_subset
    {s : set α | complete_lattice.set_independent s ∧ b ⊓ Sup s = ⊥ ∧ ∀ a ∈ s, is_atom a} _,
  { refine ⟨Sup s, disjoint_iff.mpr b_inf_Sup_s,
      codisjoint_iff_le_sup.mpr $ h.symm.trans_le $ Sup_le_iff.2 $ λ a ha, _⟩,
    rw ← inf_eq_left,
    refine (ha.le_iff.mp inf_le_left).resolve_left (λ con, ha.1 _),
    rw [eq_bot_iff, ← con],
    refine le_inf (le_refl a) ((le_Sup _).trans le_sup_right),
    rw ← disjoint_iff at *,
    have a_dis_Sup_s : disjoint a (Sup s) := con.mono_right le_sup_right,
    rw ← s_max (s ∪ {a}) ⟨λ x hx, _, ⟨_, λ x hx, _⟩⟩ (set.subset_union_left _ _),
    { exact set.mem_union_right _ (set.mem_singleton _) },
    { rw [set.mem_union, set.mem_singleton_iff] at hx,
      by_cases xa : x = a,
      { simp only [xa, set.mem_singleton, set.insert_diff_of_mem, set.union_singleton],
        exact con.mono_right (le_trans (Sup_le_Sup (set.diff_subset s {a})) le_sup_right) },
      { have h : (s ∪ {a}) \ {x} = (s \ {x}) ∪ {a},
        { simp only [set.union_singleton],
          rw set.insert_diff_of_not_mem,
          rw set.mem_singleton_iff,
          exact ne.symm xa },
        rw [h, Sup_union, Sup_singleton],
        apply (s_ind (hx.resolve_right xa)).disjoint_sup_right_of_disjoint_sup_left
          (a_dis_Sup_s.mono_right _).symm,
        rw [← Sup_insert, set.insert_diff_singleton,
          set.insert_eq_of_mem (hx.resolve_right xa)] } },
    { rw [Sup_union, Sup_singleton, ← disjoint_iff],
      exact b_inf_Sup_s.disjoint_sup_right_of_disjoint_sup_left con.symm },
    { rw [set.mem_union, set.mem_singleton_iff] at hx,
      cases hx,
      { exact s_atoms x hx },
      { rw hx,
        exact ha } } },
  { intros c hc1 hc2,
    refine ⟨⋃₀ c, ⟨complete_lattice.independent_sUnion_of_directed hc2.directed_on
      (λ s hs, (hc1 hs).1), _, λ a ha, _⟩, λ _, set.subset_sUnion_of_mem⟩,
    { rw [Sup_sUnion, ← Sup_image, inf_Sup_eq_of_directed_on, supr_eq_bot],
      { intro i,
        rw supr_eq_bot,
        intro hi,
        obtain ⟨x, xc, rfl⟩ := (set.mem_image _ _ _).1 hi,
        exact (hc1 xc).2.1 },
      { rw directed_on_image,
        refine hc2.directed_on.mono (λ s t, Sup_le_Sup) } },
    { rcases set.mem_sUnion.1 ha with ⟨s, sc, as⟩,
      exact (hc1 sc).2.2 a as } }
end⟩

/-- See Theorem 6.6, Călugăreanu -/
theorem complemented_lattice_of_is_atomistic [is_atomistic α] : complemented_lattice α :=
complemented_lattice_of_Sup_atoms_eq_top Sup_atoms_eq_top

theorem complemented_lattice_iff_is_atomistic : complemented_lattice α ↔ is_atomistic α :=
begin
  split; introsI,
  { exact is_atomistic_of_complemented_lattice },
  { exact complemented_lattice_of_is_atomistic }
end

end


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.finset.noncomm_prod
import group_theory.perm.sign
import logic.equiv.fintype
/-!
# Cyclic permutations

## Main definitions

In the following, `f : equiv.perm β`.

* `equiv.perm.is_cycle`: `f.is_cycle` when two nonfixed points of `β`
  are related by repeated application of `f`.
* `equiv.perm.same_cycle`: `f.same_cycle x y` when `x` and `y` are in the same cycle of `f`.

The following two definitions require that `β` is a `fintype`:

* `equiv.perm.cycle_of`: `f.cycle_of x` is the cycle of `f` that `x` belongs to.
* `equiv.perm.cycle_factors`: `f.cycle_factors` is a list of disjoint cyclic permutations that
  multiply to `f`.

## Main results

* This file contains several closure results:
  - `closure_is_cycle` : The symmetric group is generated by cycles
  - `closure_cycle_adjacent_swap` : The symmetric group is generated by
    a cycle and an adjacent transposition
  - `closure_cycle_coprime_swap` : The symmetric group is generated by
    a cycle and a coprime transposition
  - `closure_prime_cycle_swap` : The symmetric group is generated by
    a prime cycle and a transposition

-/

namespace equiv.perm
open equiv function finset

variables {α : Type*} {β : Type*} [decidable_eq α]

section sign_cycle

/-!
### `is_cycle`
-/

variables [fintype α]

/-- A permutation is a cycle when any two nonfixed points of the permutation are related by repeated
  application of the permutation. -/
def is_cycle (f : perm β) : Prop := ∃ x, f x ≠ x ∧ ∀ y, f y ≠ y → ∃ i : ℤ, (f ^ i) x = y

lemma is_cycle.ne_one {f : perm β} (h : is_cycle f) : f ≠ 1 :=
λ hf, by simpa [hf, is_cycle] using h

@[simp] lemma not_is_cycle_one : ¬ (1 : perm β).is_cycle :=
λ H, H.ne_one rfl

lemma is_cycle.two_le_card_support {f : perm α} (h : is_cycle f) :
  2 ≤ f.support.card :=
two_le_card_support_of_ne_one h.ne_one

lemma is_cycle_swap {α : Type*} [decidable_eq α] {x y : α} (hxy : x ≠ y) : is_cycle (swap x y) :=
⟨y, by rwa swap_apply_right,
  λ a (ha : ite (a = x) y (ite (a = y) x a) ≠ a),
    if hya : y = a then ⟨0, hya⟩
    else ⟨1, by { rw [zpow_one, swap_apply_def], split_ifs at *; cc }⟩⟩

lemma is_swap.is_cycle {α : Type*} [decidable_eq α] {f : perm α} (hf : is_swap f) : is_cycle f :=
begin
  obtain ⟨x, y, hxy, rfl⟩ := hf,
  exact is_cycle_swap hxy,
end

lemma is_cycle.inv {f : perm β} (hf : is_cycle f) : is_cycle (f⁻¹) :=
let ⟨x, hx⟩ := hf in
⟨x, by { simp only [inv_eq_iff_eq, *, forall_prop_of_true, ne.def] at *, cc },
  λ y hy, let ⟨i, hi⟩ := hx.2 y (by { simp only [inv_eq_iff_eq, *, forall_prop_of_true,
      ne.def] at *, cc }) in
    ⟨-i, by rwa [zpow_neg, inv_zpow, inv_inv]⟩⟩

lemma is_cycle.is_cycle_conj {f g : perm β} (hf : is_cycle f) : is_cycle (g * f * g⁻¹) :=
begin
  obtain ⟨a, ha1, ha2⟩ := hf,
  refine ⟨g a, by simp [ha1], λ b hb, _⟩,
  obtain ⟨i, hi⟩ := ha2 (g⁻¹ b) _,
  { refine ⟨i, _⟩,
    rw conj_zpow,
    simp [hi] },
  { contrapose! hb,
    rw [perm.mul_apply, perm.mul_apply, hb, apply_inv_self] }
end

lemma is_cycle.exists_zpow_eq {f : perm β} (hf : is_cycle f) {x y : β}
  (hx : f x ≠ x) (hy : f y ≠ y) : ∃ i : ℤ, (f ^ i) x = y :=
let ⟨g, hg⟩ := hf in
let ⟨a, ha⟩ := hg.2 x hx in
let ⟨b, hb⟩ := hg.2 y hy in
⟨b - a, by rw [← ha, ← mul_apply, ← zpow_add, sub_add_cancel, hb]⟩

lemma is_cycle.exists_pow_eq [fintype β] {f : perm β} (hf : is_cycle f) {x y : β}
  (hx : f x ≠ x) (hy : f y ≠ y) : ∃ i : ℕ, (f ^ i) x = y :=
let ⟨n, hn⟩ := hf.exists_zpow_eq hx hy in
by classical; exact ⟨(n % order_of f).to_nat, by
{ have := n.mod_nonneg (int.coe_nat_ne_zero.mpr (ne_of_gt (order_of_pos f))),
  rwa [← zpow_coe_nat, int.to_nat_of_nonneg this, ← zpow_eq_mod_order_of] }⟩

lemma is_cycle.exists_pow_eq_one [fintype β] {f : perm β} (hf : is_cycle f) :
  ∃ (k : ℕ) (hk : 1 < k), f ^ k = 1 :=
begin
  classical,
  have : is_of_fin_order f := exists_pow_eq_one f,
  rw is_of_fin_order_iff_pow_eq_one at this,
  obtain ⟨x, hx, hx'⟩ := hf,
  obtain ⟨_ | _ | k, hk, hk'⟩ := this,
  { exact absurd hk (lt_asymm hk) },
  { rw pow_one at hk',
    simpa [hk'] using hx },
  { exact ⟨k + 2, by simp, hk'⟩ }
end

/-- The subgroup generated by a cycle is in bijection with its support -/
noncomputable def is_cycle.zpowers_equiv_support {σ : perm α} (hσ : is_cycle σ) :
  (↑(subgroup.zpowers σ) : set (perm α)) ≃ (↑(σ.support) : set α) :=
equiv.of_bijective (λ τ, ⟨τ (classical.some hσ),
begin
  obtain ⟨τ, n, rfl⟩ := τ,
  rw [finset.mem_coe, coe_fn_coe_base', subtype.coe_mk, zpow_apply_mem_support, mem_support],
  exact (classical.some_spec hσ).1,
end⟩)
begin
  split,
  { rintros ⟨a, m, rfl⟩ ⟨b, n, rfl⟩ h,
    ext y,
    by_cases hy : σ y = y,
    { simp_rw [subtype.coe_mk, zpow_apply_eq_self_of_apply_eq_self hy] },
    { obtain ⟨i, rfl⟩ := (classical.some_spec hσ).2 y hy,
      rw [subtype.coe_mk, subtype.coe_mk, zpow_apply_comm σ m i, zpow_apply_comm σ n i],
      exact congr_arg _ (subtype.ext_iff.mp h) } }, by
  { rintros ⟨y, hy⟩,
    rw [finset.mem_coe, mem_support] at hy,
    obtain ⟨n, rfl⟩ := (classical.some_spec hσ).2 y hy,
    exact ⟨⟨σ ^ n, n, rfl⟩, rfl⟩ },
end

@[simp] lemma is_cycle.zpowers_equiv_support_apply {σ : perm α} (hσ : is_cycle σ) {n : ℕ} :
  hσ.zpowers_equiv_support ⟨σ ^ n, n, rfl⟩ = ⟨(σ ^ n) (classical.some hσ),
    pow_apply_mem_support.2 (mem_support.2 (classical.some_spec hσ).1)⟩ :=
rfl

@[simp] lemma is_cycle.zpowers_equiv_support_symm_apply {σ : perm α} (hσ : is_cycle σ) (n : ℕ) :
  hσ.zpowers_equiv_support.symm ⟨(σ ^ n) (classical.some hσ),
    pow_apply_mem_support.2 (mem_support.2 (classical.some_spec hσ).1)⟩ =
    ⟨σ ^ n, n, rfl⟩ :=
(equiv.symm_apply_eq _).2 hσ.zpowers_equiv_support_apply

lemma order_of_is_cycle {σ : perm α} (hσ : is_cycle σ) : order_of σ = σ.support.card :=
begin
  rw [order_eq_card_zpowers, ←fintype.card_coe],
  convert fintype.card_congr (is_cycle.zpowers_equiv_support hσ),
end

lemma is_cycle_swap_mul_aux₁ {α : Type*} [decidable_eq α] : ∀ (n : ℕ) {b x : α} {f : perm α}
  (hb : (swap x (f x) * f) b ≠ b) (h : (f ^ n) (f x) = b),
  ∃ i : ℤ, ((swap x (f x) * f) ^ i) (f x) = b
| 0         := λ b x f hb h, ⟨0, h⟩
| (n+1 : ℕ) := λ b x f hb h,
  if hfbx : f x = b then ⟨0, hfbx⟩
  else
    have f b ≠ b ∧ b ≠ x, from ne_and_ne_of_swap_mul_apply_ne_self hb,
    have hb' : (swap x (f x) * f) (f⁻¹ b) ≠ f⁻¹ b,
      by { rw [mul_apply, apply_inv_self, swap_apply_of_ne_of_ne this.2 (ne.symm hfbx),
          ne.def, ← f.injective.eq_iff, apply_inv_self],
        exact this.1 },
    let ⟨i, hi⟩ := is_cycle_swap_mul_aux₁ n hb'
      (f.injective $ by { rw [apply_inv_self], rwa [pow_succ, mul_apply] at h }) in
    ⟨i + 1, by rw [add_comm, zpow_add, mul_apply, hi, zpow_one, mul_apply, apply_inv_self,
        swap_apply_of_ne_of_ne (ne_and_ne_of_swap_mul_apply_ne_self hb).2 (ne.symm hfbx)]⟩

lemma is_cycle_swap_mul_aux₂ {α : Type*} [decidable_eq α] :
  ∀ (n : ℤ) {b x : α} {f : perm α} (hb : (swap x (f x) * f) b ≠ b) (h : (f ^ n) (f x) = b),
  ∃ i : ℤ, ((swap x (f x) * f) ^ i) (f x) = b
| (n : ℕ) := λ b x f, is_cycle_swap_mul_aux₁ n
| -[1+ n] := λ b x f hb h,
  if hfbx' : f x = b then ⟨0, hfbx'⟩
  else
  have f b ≠ b ∧ b ≠ x := ne_and_ne_of_swap_mul_apply_ne_self hb,
  have hb : (swap x (f⁻¹ x) * f⁻¹) (f⁻¹ b) ≠ f⁻¹ b,
    by { rw [mul_apply, swap_apply_def],
      split_ifs;
      simp only [inv_eq_iff_eq, perm.mul_apply, zpow_neg_succ_of_nat, ne.def,
        perm.apply_inv_self] at *;
      cc },
  let ⟨i, hi⟩ := is_cycle_swap_mul_aux₁ n hb
    (show (f⁻¹ ^ n) (f⁻¹ x) = f⁻¹ b, by
      rw [← zpow_coe_nat, ← h, ← mul_apply, ← mul_apply, ← mul_apply, zpow_neg_succ_of_nat,
        ← inv_pow, pow_succ', mul_assoc, mul_assoc, inv_mul_self, mul_one, zpow_coe_nat,
        ← pow_succ', ← pow_succ]) in
  have h : (swap x (f⁻¹ x) * f⁻¹) (f x) = f⁻¹ x, by rw [mul_apply, inv_apply_self, swap_apply_left],
  ⟨-i, by rw [← add_sub_cancel i 1, neg_sub, sub_eq_add_neg, zpow_add, zpow_one, zpow_neg,
      ← inv_zpow, mul_inv_rev, swap_inv, mul_swap_eq_swap_mul, inv_apply_self, swap_comm _ x,
      zpow_add, zpow_one, mul_apply, mul_apply (_ ^ i), h, hi, mul_apply, apply_inv_self,
      swap_apply_of_ne_of_ne this.2 (ne.symm hfbx')]⟩

lemma is_cycle.eq_swap_of_apply_apply_eq_self {α : Type*} [decidable_eq α]
  {f : perm α} (hf : is_cycle f) {x : α}
  (hfx : f x ≠ x) (hffx : f (f x) = x) : f = swap x (f x) :=
equiv.ext $ λ y,
let ⟨z, hz⟩ := hf in
let ⟨i, hi⟩ := hz.2 x hfx in
if hyx : y = x then by simp [hyx]
else if hfyx : y = f x then by simp [hfyx, hffx]
else begin
  rw [swap_apply_of_ne_of_ne hyx hfyx],
  refine by_contradiction (λ hy, _),
  cases hz.2 y hy with j hj,
  rw [← sub_add_cancel j i, zpow_add, mul_apply, hi] at hj,
  cases zpow_apply_eq_of_apply_apply_eq_self hffx (j - i) with hji hji,
  { rw [← hj, hji] at hyx, cc },
  { rw [← hj, hji] at hfyx, cc }
end

lemma is_cycle.swap_mul {α : Type*} [decidable_eq α] {f : perm α} (hf : is_cycle f) {x : α}
  (hx : f x ≠ x) (hffx : f (f x) ≠ x) : is_cycle (swap x (f x) * f) :=
⟨f x, by { simp [swap_apply_def, mul_apply, if_neg hffx, f.injective.eq_iff, if_neg hx, hx], },
  λ y hy,
  let ⟨i, hi⟩ := hf.exists_zpow_eq hx (ne_and_ne_of_swap_mul_apply_ne_self hy).1 in
  have hi : (f ^ (i - 1)) (f x) = y, from
    calc (f ^ (i - 1)) (f x) = (f ^ (i - 1) * f ^ (1 : ℤ)) x : by rw [zpow_one, mul_apply]
    ... = y : by rwa [← zpow_add, sub_add_cancel],
  is_cycle_swap_mul_aux₂ (i - 1) hy hi⟩

lemma is_cycle.sign : ∀ {f : perm α} (hf : is_cycle f),
  sign f = -(-1) ^ f.support.card
| f := λ hf,
let ⟨x, hx⟩ := hf in
calc sign f = sign (swap x (f x) * (swap x (f x) * f)) :
  by rw [← mul_assoc, mul_def, mul_def, swap_swap, trans_refl]
... = -(-1) ^ f.support.card :
  if h1 : f (f x) = x
  then
    have h : swap x (f x) * f = 1,
      begin
        rw hf.eq_swap_of_apply_apply_eq_self hx.1 h1,
        simp only [perm.mul_def, perm.one_def, swap_apply_left, swap_swap]
      end,
    by { rw [sign_mul, sign_swap hx.1.symm, h, sign_one, hf.eq_swap_of_apply_apply_eq_self hx.1 h1,
      card_support_swap hx.1.symm], refl }
  else
    have h : card (support (swap x (f x) * f)) + 1 = card (support f),
      by rw [← insert_erase (mem_support.2 hx.1), support_swap_mul_eq _ _ h1,
        card_insert_of_not_mem (not_mem_erase _ _), sdiff_singleton_eq_erase],
    have wf : card (support (swap x (f x) * f)) < card (support f),
      from card_support_swap_mul hx.1,
    by { rw [sign_mul, sign_swap hx.1.symm, (hf.swap_mul hx.1 h1).sign, ← h],
      simp only [pow_add, mul_one, neg_neg, one_mul, mul_neg, eq_self_iff_true,
        pow_one, neg_mul_neg] }
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ f, f.support.card)⟩]}

lemma is_cycle_of_is_cycle_pow {σ : perm α} {n : ℕ}
  (h1 : is_cycle (σ ^ n)) (h2 : σ.support ≤ (σ ^ n).support) : is_cycle σ :=
begin
  have key : ∀ x : α, (σ ^ n) x ≠ x ↔ σ x ≠ x,
  { simp_rw [←mem_support],
    exact finset.ext_iff.mp (le_antisymm (support_pow_le σ n) h2) },
  obtain ⟨x, hx1, hx2⟩ := h1,
  refine ⟨x, (key x).mp hx1, λ y hy, _⟩,
  cases (hx2 y ((key y).mpr hy)) with i _,
  exact ⟨n * i, by rwa zpow_mul⟩
end

-- The lemma `support_zpow_le` is relevant. It means that `h2` is equivalent to
-- `σ.support = (σ ^ n).support`, as well as to `σ.support.card ≤ (σ ^ n).support.card`.
lemma is_cycle_of_is_cycle_zpow {σ : perm α} {n : ℤ}
  (h1 : is_cycle (σ ^ n)) (h2 : σ.support ≤ (σ ^ n).support) : is_cycle σ :=
begin
  cases n,
  { exact is_cycle_of_is_cycle_pow h1 h2 },
  { simp only [le_eq_subset, zpow_neg_succ_of_nat, perm.support_inv] at h1 h2,
    simpa using is_cycle_of_is_cycle_pow h1.inv h2 }
end

lemma is_cycle.extend_domain {α : Type*} {p : β → Prop} [decidable_pred p]
  (f : α ≃ subtype p) {g : perm α} (h : is_cycle g) :
  is_cycle (g.extend_domain f) :=
begin
  obtain ⟨a, ha, ha'⟩ := h,
  refine ⟨f a, _, λ b hb, _⟩,
  { rw extend_domain_apply_image,
    exact λ con, ha (f.injective (subtype.coe_injective con)) },
  by_cases pb : p b,
  { obtain ⟨i, hi⟩ := ha' (f.symm ⟨b, pb⟩) (λ con, hb _),
    { refine ⟨i, _⟩,
      have hnat : ∀ (k : ℕ) (a : α), (g.extend_domain f ^ k) ↑(f a) = f ((g ^ k) a),
      { intros k a,
        induction k with k ih, { refl },
        rw [pow_succ, perm.mul_apply, ih, extend_domain_apply_image, pow_succ, perm.mul_apply] },
      have hint : ∀ (k : ℤ) (a : α), (g.extend_domain f ^ k) ↑(f a) = f ((g ^ k) a),
      { intros k a,
        induction k with k k,
        { rw [zpow_of_nat, zpow_of_nat, hnat] },
        rw [zpow_neg_succ_of_nat, zpow_neg_succ_of_nat, inv_eq_iff_eq, hnat, apply_inv_self] },
      rw [hint, hi, apply_symm_apply, subtype.coe_mk] },
    { rw [extend_domain_apply_subtype _ _ pb, con, apply_symm_apply, subtype.coe_mk] } },
  { exact (hb (extend_domain_apply_not_subtype _ _ pb)).elim }
end

lemma nodup_of_pairwise_disjoint_cycles {l : list (perm β)} (h1 : ∀ f ∈ l, is_cycle f)
  (h2 : l.pairwise disjoint) : l.nodup :=
nodup_of_pairwise_disjoint (λ h, (h1 1 h).ne_one rfl) h2

end sign_cycle

/-!
### `same_cycle`
-/

/-- The equivalence relation indicating that two points are in the same cycle of a permutation. -/
def same_cycle (f : perm β) (x y : β) : Prop := ∃ i : ℤ, (f ^ i) x = y

@[refl] lemma same_cycle.refl (f : perm β) (x : β) : same_cycle f x x := ⟨0, rfl⟩

@[symm] lemma same_cycle.symm {f : perm β} {x y : β} : same_cycle f x y → same_cycle f y x :=
λ ⟨i, hi⟩, ⟨-i, by rw [zpow_neg, ← hi, inv_apply_self]⟩

@[trans] lemma same_cycle.trans {f : perm β} {x y z : β} :
  same_cycle f x y → same_cycle f y z → same_cycle f x z :=
λ ⟨i, hi⟩ ⟨j, hj⟩, ⟨j + i, by rw [zpow_add, mul_apply, hi, hj]⟩

lemma same_cycle.apply_eq_self_iff {f : perm β} {x y : β} :
  same_cycle f x y → (f x = x ↔ f y = y) :=
λ ⟨i, hi⟩, by rw [← hi, ← mul_apply, ← zpow_one_add, add_comm, zpow_add_one, mul_apply,
    (f ^ i).injective.eq_iff]

lemma is_cycle.same_cycle {f : perm β} (hf : is_cycle f) {x y : β}
  (hx : f x ≠ x) (hy : f y ≠ y) : same_cycle f x y :=
hf.exists_zpow_eq hx hy

lemma same_cycle.nat' [fintype β] {f : perm β} {x y : β} (h : same_cycle f x y) :
  ∃ (i : ℕ) (h : i < order_of f), (f ^ i) x = y :=
begin
  classical,
  obtain ⟨k, rfl⟩ := h,
  use ((k % order_of f).nat_abs),
  have h₀ := int.coe_nat_pos.mpr (order_of_pos f),
  have h₁ := int.mod_nonneg k h₀.ne',
  rw [←zpow_coe_nat, int.nat_abs_of_nonneg h₁, ←zpow_eq_mod_order_of],
  refine ⟨_, rfl⟩,
  rw [←int.coe_nat_lt, int.nat_abs_of_nonneg h₁],
  exact int.mod_lt_of_pos _ h₀,
end

lemma same_cycle.nat'' [fintype β] {f : perm β} {x y : β} (h : same_cycle f x y) :
  ∃ (i : ℕ) (hpos : 0 < i) (h : i ≤ order_of f), (f ^ i) x = y :=
begin
  classical,
  obtain ⟨_|i, hi, rfl⟩ := h.nat',
  { refine ⟨order_of f, order_of_pos f, le_rfl, _⟩,
    rw [pow_order_of_eq_one, pow_zero] },
  { exact ⟨i.succ, i.zero_lt_succ, hi.le, rfl⟩ }
end

instance [fintype α] (f : perm α) : decidable_rel (same_cycle f) :=
λ x y, decidable_of_iff (∃ n ∈ list.range (fintype.card (perm α)), (f ^ n) x = y)
⟨λ ⟨n, _, hn⟩, ⟨n, hn⟩, λ ⟨i, hi⟩, ⟨(i % order_of f).nat_abs, list.mem_range.2
  (int.coe_nat_lt.1 $
    by { rw int.nat_abs_of_nonneg (int.mod_nonneg _
        (int.coe_nat_ne_zero_iff_pos.2 (order_of_pos _))),
      { apply lt_of_lt_of_le (int.mod_lt _ (int.coe_nat_ne_zero_iff_pos.2 (order_of_pos _))),
        { simp [order_of_le_card_univ] },
        exact fintype_perm },
      exact fintype_perm, }),
  by { rw [← zpow_coe_nat, int.nat_abs_of_nonneg (int.mod_nonneg _
      (int.coe_nat_ne_zero_iff_pos.2 (order_of_pos _))), ← zpow_eq_mod_order_of, hi],
    exact fintype_perm }⟩⟩

lemma same_cycle_apply {f : perm β} {x y : β} : same_cycle f x (f y) ↔ same_cycle f x y :=
⟨λ ⟨i, hi⟩, ⟨-1 + i, by rw [zpow_add, mul_apply, hi, zpow_neg_one, inv_apply_self]⟩,
 λ ⟨i, hi⟩, ⟨1 + i, by rw [zpow_add, mul_apply, hi, zpow_one]⟩⟩

lemma same_cycle_cycle {f : perm β} {x : β} (hx : f x ≠ x) : is_cycle f ↔
  (∀ {y}, same_cycle f x y ↔ f y ≠ y) :=
⟨λ hf y, ⟨λ ⟨i, hi⟩ hy, hx $
    by { rw [← zpow_apply_eq_self_of_apply_eq_self hy i, (f ^ i).injective.eq_iff] at hi,
      rw [hi, hy] },
  hf.exists_zpow_eq hx⟩,
  λ h, ⟨x, hx, λ y hy, h.2 hy⟩⟩

lemma same_cycle_inv (f : perm β) {x y : β} : same_cycle f⁻¹ x y ↔ same_cycle f x y :=
⟨λ ⟨i, hi⟩, ⟨-i, by rw [zpow_neg, ← inv_zpow, hi]⟩,
 λ ⟨i, hi⟩, ⟨-i, by rw [zpow_neg, ← inv_zpow, inv_inv, hi]⟩ ⟩

lemma same_cycle_inv_apply {f : perm β} {x y : β} : same_cycle f x (f⁻¹ y) ↔ same_cycle f x y :=
by rw [← same_cycle_inv, same_cycle_apply, same_cycle_inv]

@[simp] lemma same_cycle_pow_left_iff {f : perm β} {x y : β} {n : ℕ} :
  same_cycle f ((f ^ n) x) y ↔ same_cycle f x y :=
begin
  split,
  { rintro ⟨k, rfl⟩,
    use (k + n),
    simp [zpow_add] },
  { rintro ⟨k, rfl⟩,
    use (k - n),
    rw [←zpow_coe_nat, ←mul_apply, ←zpow_add, int.sub_add_cancel] }
end

@[simp] lemma same_cycle_zpow_left_iff {f : perm β} {x y : β} {n : ℤ} :
  same_cycle f ((f ^ n) x) y ↔ same_cycle f x y :=
begin
  cases n,
  { exact same_cycle_pow_left_iff },
  { rw [zpow_neg_succ_of_nat, ←inv_pow, ←same_cycle_inv, same_cycle_pow_left_iff, same_cycle_inv] }
end

/-- Unlike `support_congr`, which assumes that `∀ (x ∈ g.support), f x = g x)`, here
we have the weaker assumption that `∀ (x ∈ f.support), f x = g x`. -/
lemma is_cycle.support_congr [fintype α] {f g : perm α} (hf : is_cycle f) (hg : is_cycle g)
  (h : f.support ⊆ g.support) (h' : ∀ (x ∈ f.support), f x = g x) : f = g :=
begin
  have : f.support = g.support,
  { refine le_antisymm h _,
    intros z hz,
    obtain ⟨x, hx, hf'⟩ := id hf,
    have hx' : g x ≠ x,
    { rwa [←h' x (mem_support.mpr hx)] },
    obtain ⟨m, hm⟩ := hg.exists_pow_eq hx' (mem_support.mp hz),
    have h'' : ∀ (x ∈ f.support ∩ g.support), f x = g x,
    { intros x hx,
      exact h' x (mem_of_mem_inter_left hx) },
    rwa [←hm, ←pow_eq_on_of_mem_support h'' _ x (mem_inter_of_mem (mem_support.mpr hx)
          (mem_support.mpr hx')), pow_apply_mem_support, mem_support] },
  refine support_congr h _,
  simpa [←this] using h'
end

/-- If two cyclic permutations agree on all terms in their intersection,
and that intersection is not empty, then the two cyclic permutations must be equal. -/
lemma is_cycle.eq_on_support_inter_nonempty_congr [fintype α] {f g : perm α}
  (hf : is_cycle f) (hg : is_cycle g) (h : ∀ (x ∈ f.support ∩ g.support), f x = g x) {x : α}
  (hx : f x = g x) (hx' : x ∈ f.support) : f = g :=
begin
  have hx'' : x ∈ g.support,
  { rwa [mem_support, ←hx, ←mem_support] },
  have : f.support ⊆ g.support,
  { intros y hy,
    obtain ⟨k, rfl⟩ := hf.exists_pow_eq (mem_support.mp hx') (mem_support.mp hy),
    rwa [pow_eq_on_of_mem_support h _ _ (mem_inter_of_mem hx' hx''), pow_apply_mem_support] },
  rw (inter_eq_left_iff_subset _ _).mpr this at h,
  exact hf.support_congr hg this h
end

lemma is_cycle.support_pow_eq_iff [fintype α] {f : perm α} (hf : is_cycle f) {n : ℕ} :
  support (f ^ n) = support f ↔ ¬ order_of f ∣ n :=
begin
  rw order_of_dvd_iff_pow_eq_one,
  split,
  { intros h H,
    refine hf.ne_one _,
    rw [←support_eq_empty_iff, ←h, H, support_one] },
  { intro H,
    apply le_antisymm (support_pow_le _ n) _,
    intros x hx,
    contrapose! H,
    ext z,
    by_cases hz : f z = z,
    { rw [pow_apply_eq_self_of_apply_eq_self hz, one_apply] },
    { obtain ⟨k, rfl⟩ := hf.exists_pow_eq hz (mem_support.mp hx),
      apply (f ^ k).injective,
      rw [←mul_apply, (commute.pow_pow_self _ _ _).eq, mul_apply],
      simpa using H } }
end

lemma is_cycle.pow_iff [fintype β] {f : perm β} (hf : is_cycle f) {n : ℕ} :
  is_cycle (f ^ n) ↔ n.coprime (order_of f) :=
begin
  classical,
  split,
  { intro h,
    have hr : support (f ^ n) = support f,
    { rw hf.support_pow_eq_iff,
      rintro ⟨k, rfl⟩,
      refine h.ne_one _,
      simp [pow_mul, pow_order_of_eq_one] },
    have : order_of (f ^ n) = order_of f,
    { rw [order_of_is_cycle h, hr, order_of_is_cycle hf] },
    rw [order_of_pow, nat.div_eq_self] at this,
    cases this,
    { exact absurd this (order_of_pos _).ne' },
    { rwa [nat.coprime_iff_gcd_eq_one, nat.gcd_comm] } },
  { intro h,
    obtain ⟨m, hm⟩ := exists_pow_eq_self_of_coprime h,
    have hf' : is_cycle ((f ^ n) ^ m) := by rwa hm,
    refine is_cycle_of_is_cycle_pow hf' _,
    intros x hx,
    rw [hm],
    exact support_pow_le _ n hx }
end

lemma is_cycle.pow_eq_one_iff [fintype α] {f : perm α} (hf : is_cycle f) {n : ℕ} :
  f ^ n = 1 ↔ ∃ (x ∈ f.support), (f ^ n) x = x :=
begin
  split,
  { intro h,
    obtain ⟨x, hx, -⟩ := id hf,
    exact ⟨x, mem_support.mpr hx, by simp [h]⟩ },
  { rintro ⟨x, hx, hx'⟩,
    by_cases h : support (f ^ n) = support f,
    { rw [←h, mem_support] at hx,
      contradiction },
    { rw [hf.support_pow_eq_iff, not_not] at h,
      obtain ⟨k, rfl⟩ := h,
      rw [pow_mul, pow_order_of_eq_one, one_pow] } }
end

lemma is_cycle.mem_support_pos_pow_iff_of_lt_order_of [fintype α] {f : perm α} (hf : is_cycle f)
  {n : ℕ} (npos : 0 < n) (hn : n < order_of f) {x : α} :
  x ∈ (f ^ n).support ↔ x ∈ f.support :=
begin
  have : ¬ order_of f ∣ n := nat.not_dvd_of_pos_of_lt npos hn,
  rw ←hf.support_pow_eq_iff at this,
  rw this
end

lemma is_cycle.is_cycle_pow_pos_of_lt_prime_order [fintype β] {f : perm β} (hf : is_cycle f)
  (hf' : (order_of f).prime) (n : ℕ) (hn : 0 < n) (hn' : n < order_of f) : is_cycle (f ^ n) :=
begin
  classical,
  have : n.coprime (order_of f),
  { refine nat.coprime.symm _,
    rw nat.prime.coprime_iff_not_dvd hf',
    exact nat.not_dvd_of_pos_of_lt hn hn' },
  obtain ⟨m, hm⟩ := exists_pow_eq_self_of_coprime this,
  have hf'' := hf,
  rw ←hm at hf'',
  refine is_cycle_of_is_cycle_pow hf'' _,
  rw [hm],
  exact support_pow_le f n
end

/-!
### `cycle_of`
-/

/-- `f.cycle_of x` is the cycle of the permutation `f` to which `x` belongs. -/
def cycle_of [fintype α] (f : perm α) (x : α) : perm α :=
of_subtype (@subtype_perm _ f (same_cycle f x) (λ _, same_cycle_apply.symm))

lemma cycle_of_apply [fintype α] (f : perm α) (x y : α) :
  cycle_of f x y = if same_cycle f x y then f y else y := rfl

lemma cycle_of_inv [fintype α] (f : perm α) (x : α) :
  (cycle_of f x)⁻¹ = cycle_of f⁻¹ x :=
equiv.ext $ λ y, begin
  rw [inv_eq_iff_eq, cycle_of_apply, cycle_of_apply],
  split_ifs; simp [*, same_cycle_inv, same_cycle_inv_apply] at *
end

@[simp] lemma cycle_of_pow_apply_self [fintype α] (f : perm α) (x : α) :
  ∀ n : ℕ, (cycle_of f x ^ n) x = (f ^ n) x
| 0     := rfl
| (n+1) := by { rw [pow_succ, mul_apply, cycle_of_apply,
    cycle_of_pow_apply_self, if_pos, pow_succ, mul_apply],
  exact ⟨n, rfl⟩ }

@[simp] lemma cycle_of_zpow_apply_self [fintype α] (f : perm α) (x : α) :
  ∀ n : ℤ, (cycle_of f x ^ n) x = (f ^ n) x
| (n : ℕ) := cycle_of_pow_apply_self f x n
| -[1+ n] := by rw [zpow_neg_succ_of_nat, ← inv_pow, cycle_of_inv,
  zpow_neg_succ_of_nat, ← inv_pow, cycle_of_pow_apply_self]

lemma same_cycle.cycle_of_apply [fintype α] {f : perm α} {x y : α} (h : same_cycle f x y) :
  cycle_of f x y = f y := dif_pos h

lemma cycle_of_apply_of_not_same_cycle [fintype α] {f : perm α} {x y : α} (h : ¬same_cycle f x y) :
  cycle_of f x y = y := dif_neg h

lemma same_cycle.cycle_of_eq [fintype α] {f : perm α} {x y : α} (h : same_cycle f x y) :
  cycle_of f x = cycle_of f y :=
begin
  ext z,
  rw cycle_of_apply,
  split_ifs with hz hz,
  { exact (h.symm.trans hz).cycle_of_apply.symm },
  { exact (cycle_of_apply_of_not_same_cycle (mt h.trans hz)).symm }
end

@[simp] lemma cycle_of_apply_apply_zpow_self [fintype α] (f : perm α) (x : α) (k : ℤ) :
  cycle_of f x ((f ^ k) x) = (f ^ (k + 1)) x :=
begin
  rw same_cycle.cycle_of_apply,
  { rw [add_comm, zpow_add, zpow_one, mul_apply] },
  { exact ⟨k, rfl⟩ }
end

@[simp] lemma cycle_of_apply_apply_pow_self [fintype α] (f : perm α) (x : α) (k : ℕ) :
  cycle_of f x ((f ^ k) x) = (f ^ (k + 1)) x :=
by convert cycle_of_apply_apply_zpow_self f x k using 1

@[simp] lemma cycle_of_apply_apply_self [fintype α] (f : perm α) (x : α) :
  cycle_of f x (f x) = f (f x) :=
by convert cycle_of_apply_apply_pow_self f x 1 using 1

@[simp] lemma cycle_of_apply_self [fintype α] (f : perm α) (x : α) :
  cycle_of f x x = f x := (same_cycle.refl _ _).cycle_of_apply

lemma is_cycle.cycle_of_eq [fintype α] {f : perm α} (hf : is_cycle f) {x : α} (hx : f x ≠ x) :
  cycle_of f x = f :=
equiv.ext $ λ y,
  if h : same_cycle f x y then by rw [h.cycle_of_apply]
  else by rw [cycle_of_apply_of_not_same_cycle h, not_not.1 (mt ((same_cycle_cycle hx).1 hf).2 h)]

@[simp] lemma cycle_of_eq_one_iff [fintype α] (f : perm α) {x : α} : cycle_of f x = 1 ↔ f x = x :=
begin
  simp_rw [ext_iff, cycle_of_apply, one_apply],
  refine ⟨λ h, (if_pos (same_cycle.refl f x)).symm.trans (h x), λ h y, _⟩,
  by_cases hy : f y = y,
  { rw [hy, if_t_t] },
  { exact if_neg (mt same_cycle.apply_eq_self_iff (by tauto)) },
end

@[simp] lemma cycle_of_self_apply [fintype α] (f : perm α) (x : α) :
  cycle_of f (f x) = cycle_of f x :=
(same_cycle_apply.mpr (same_cycle.refl _ _)).symm.cycle_of_eq

@[simp] lemma cycle_of_self_apply_pow [fintype α] (f : perm α) (n : ℕ) (x : α) :
  cycle_of f ((f ^ n) x) = cycle_of f x :=
(same_cycle_pow_left_iff.mpr (same_cycle.refl _ _)).cycle_of_eq

@[simp] lemma cycle_of_self_apply_zpow [fintype α] (f : perm α) (n : ℤ) (x : α) :
  cycle_of f ((f ^ n) x) = cycle_of f x :=
(same_cycle_zpow_left_iff.mpr (same_cycle.refl _ _)).cycle_of_eq

lemma is_cycle.cycle_of [fintype α] {f : perm α} (hf : is_cycle f) {x : α} :
  cycle_of f x = if f x = x then 1 else f :=
begin
  by_cases hx : f x = x,
  { rwa [if_pos hx, cycle_of_eq_one_iff] },
  { rwa [if_neg hx, hf.cycle_of_eq] },
end

lemma cycle_of_one [fintype α] (x : α) : cycle_of 1 x = 1 :=
(cycle_of_eq_one_iff 1).mpr rfl

lemma is_cycle_cycle_of [fintype α] (f : perm α) {x : α} (hx : f x ≠ x) : is_cycle (cycle_of f x) :=
have cycle_of f x x ≠ x, by rwa [(same_cycle.refl _ _).cycle_of_apply],
(same_cycle_cycle this).2 $ λ y,
⟨λ h, mt h.apply_eq_self_iff.2 this,
  λ h, if hxy : same_cycle f x y then
  let ⟨i, hi⟩ := hxy in
  ⟨i, by rw [cycle_of_zpow_apply_self, hi]⟩
  else by { rw [cycle_of_apply_of_not_same_cycle hxy] at h, exact (h rfl).elim }⟩

@[simp] lemma two_le_card_support_cycle_of_iff [fintype α] {f : perm α} {x : α} :
  2 ≤ card (cycle_of f x).support ↔ f x ≠ x :=
begin
  refine ⟨λ h, _, λ h, by simpa using (is_cycle_cycle_of _ h).two_le_card_support⟩,
  contrapose! h,
  rw ←cycle_of_eq_one_iff at h,
  simp [h]
end

@[simp] lemma card_support_cycle_of_pos_iff [fintype α] {f : perm α} {x : α} :
  0 < card (cycle_of f x).support ↔ f x ≠ x :=
begin
  rw [←two_le_card_support_cycle_of_iff, ←nat.succ_le_iff],
  exact ⟨λ h, or.resolve_left h.eq_or_lt (card_support_ne_one _).symm, zero_lt_two.trans_le⟩
end

lemma pow_apply_eq_pow_mod_order_of_cycle_of_apply [fintype α] (f : perm α) (n : ℕ) (x : α) :
  (f ^ n) x = (f ^ (n % order_of (cycle_of f x))) x :=
by rw [←cycle_of_pow_apply_self f, ←cycle_of_pow_apply_self f, pow_eq_mod_order_of]

lemma cycle_of_mul_of_apply_right_eq_self [fintype α] {f g : perm α}
  (h : _root_.commute f g) (x : α) (hx : g x = x) : (f * g).cycle_of x = f.cycle_of x :=
begin
  ext y,
  by_cases hxy : (f * g).same_cycle x y,
  { obtain ⟨z, rfl⟩ := hxy,
    rw cycle_of_apply_apply_zpow_self,
    simp [h.mul_zpow, zpow_apply_eq_self_of_apply_eq_self hx] },
  { rw [cycle_of_apply_of_not_same_cycle hxy, cycle_of_apply_of_not_same_cycle],
    contrapose! hxy,
    obtain ⟨z, rfl⟩ := hxy,
    refine ⟨z, _⟩,
    simp [h.mul_zpow, zpow_apply_eq_self_of_apply_eq_self hx] }
end

lemma disjoint.cycle_of_mul_distrib [fintype α] {f g : perm α} (h : f.disjoint g) (x : α) :
  (f * g).cycle_of x = (f.cycle_of x * g.cycle_of x) :=
begin
  cases (disjoint_iff_eq_or_eq.mp h) x with hfx hgx,
  { simp [h.commute.eq, cycle_of_mul_of_apply_right_eq_self h.symm.commute, hfx] },
  { simp [cycle_of_mul_of_apply_right_eq_self h.commute, hgx] }
end

lemma support_cycle_of_eq_nil_iff [fintype α] {f : perm α} {x : α} :
  (f.cycle_of x).support = ∅ ↔ x ∉ f.support :=
by simp

lemma support_cycle_of_le [fintype α] (f : perm α) (x : α) :
  support (f.cycle_of x) ≤ support f :=
begin
  intros y hy,
  rw [mem_support, cycle_of_apply] at hy,
  split_ifs at hy,
  { exact mem_support.mpr hy },
  { exact absurd rfl hy }
end

lemma mem_support_cycle_of_iff [fintype α] {f : perm α} {x y : α} :
  y ∈ support (f.cycle_of x) ↔ same_cycle f x y ∧ x ∈ support f :=
begin
  by_cases hx : f x = x,
  { rw (cycle_of_eq_one_iff _).mpr hx,
    simp [hx] },
  { rw [mem_support, cycle_of_apply],
    split_ifs with hy,
    { simp only [hx, hy, iff_true, ne.def, not_false_iff, and_self, mem_support],
      rcases hy with ⟨k, rfl⟩,
      rw ←not_mem_support,
      simpa using hx },
    { simpa [hx] using hy } }
end

lemma same_cycle.mem_support_iff [fintype α] {f : perm α} {x y : α} (h : same_cycle f x y) :
  x ∈ support f ↔ y ∈ support f :=
⟨λ hx, support_cycle_of_le f x (mem_support_cycle_of_iff.mpr ⟨h, hx⟩),
 λ hy, support_cycle_of_le f y (mem_support_cycle_of_iff.mpr ⟨h.symm, hy⟩)⟩

lemma pow_mod_card_support_cycle_of_self_apply [fintype α] (f : perm α) (n : ℕ) (x : α) :
  (f ^ (n % (f.cycle_of x).support.card)) x = (f ^ n) x :=
begin
  by_cases hx : f x = x,
  { rw [pow_apply_eq_self_of_apply_eq_self hx, pow_apply_eq_self_of_apply_eq_self hx] },
  { rw [←cycle_of_pow_apply_self, ←cycle_of_pow_apply_self f,
        ←order_of_is_cycle (is_cycle_cycle_of f hx), ←pow_eq_mod_order_of] }
end

/-- x is in the support of f iff cycle_of f x is a cycle.-/
lemma is_cycle_cycle_of_iff [fintype α] (f : perm α) {x : α} :
  is_cycle (cycle_of f x) ↔ (f x ≠ x) :=
begin
  split,
  { intro hx, rw ne.def, rw ← cycle_of_eq_one_iff f,
    exact equiv.perm.is_cycle.ne_one hx, },
  { intro hx,
    apply equiv.perm.is_cycle_cycle_of, exact hx }
end

/-!
### `cycle_factors`
-/

/-- Given a list `l : list α` and a permutation `f : perm α` whose nonfixed points are all in `l`,
  recursively factors `f` into cycles. -/
def cycle_factors_aux [fintype α] : Π (l : list α) (f : perm α),
  (∀ {x}, f x ≠ x → x ∈ l) →
  {l : list (perm α) // l.prod = f ∧ (∀ g ∈ l, is_cycle g) ∧ l.pairwise disjoint}
| []     f h := ⟨[], by { simp only [imp_false, list.pairwise.nil, list.not_mem_nil, forall_const,
    and_true, forall_prop_of_false, not_not, not_false_iff, list.prod_nil] at *,
  ext, simp * }⟩
| (x::l) f h :=
if hx : f x = x then
  cycle_factors_aux l f (λ y hy, list.mem_of_ne_of_mem (λ h, hy (by rwa h)) (h hy))
else let ⟨m, hm₁, hm₂, hm₃⟩ := cycle_factors_aux l ((cycle_of f x)⁻¹ * f)
  (λ y hy, list.mem_of_ne_of_mem
    (λ h : y = x,
      by { rw [h, mul_apply, ne.def, inv_eq_iff_eq, cycle_of_apply_self] at hy, exact hy rfl })
    (h (λ h : f y = y, by { rw [mul_apply, h, ne.def, inv_eq_iff_eq, cycle_of_apply] at hy,
        split_ifs at hy; cc }))) in
    ⟨(cycle_of f x) :: m, by { rw [list.prod_cons, hm₁], simp },
      λ g hg, ((list.mem_cons_iff _ _ _).1 hg).elim (λ hg, hg.symm ▸ is_cycle_cycle_of _ hx)
        (hm₂ g),
      list.pairwise_cons.2 ⟨λ g hg y,
        or_iff_not_imp_left.2 (λ hfy,
          have hxy : same_cycle f x y := not_not.1 (mt cycle_of_apply_of_not_same_cycle hfy),
          have hgm : g :: m.erase g ~ m := list.cons_perm_iff_perm_erase.2 ⟨hg, list.perm.refl _⟩,
          have ∀ h ∈ m.erase g, disjoint g h, from
            (list.pairwise_cons.1 ((hgm.pairwise_iff (λ a b (h : disjoint a b), h.symm)).2 hm₃)).1,
          classical.by_cases id $ λ hgy : g y ≠ y,
            (disjoint_prod_right _ this y).resolve_right $
            have hsc : same_cycle f⁻¹ x (f y), by rwa [same_cycle_inv, same_cycle_apply],
            by { rw [disjoint_prod_perm hm₃ hgm.symm, list.prod_cons,
                ← eq_inv_mul_iff_mul_eq] at hm₁,
              rwa [hm₁, mul_apply, mul_apply, cycle_of_inv, hsc.cycle_of_apply,
                inv_apply_self, inv_eq_iff_eq, eq_comm] }),
        hm₃⟩⟩

lemma mem_list_cycles_iff {α : Type*} [fintype α] {l : list (perm α)}
  (h1 : ∀ σ : perm α, σ ∈ l → σ.is_cycle)
  (h2 : l.pairwise disjoint) {σ : perm α} :
  σ ∈ l ↔ σ.is_cycle ∧ ∀ (a : α) (h4 : σ a ≠ a), σ a = l.prod a :=
begin
  suffices : σ.is_cycle → (σ ∈ l ↔ ∀ (a : α) (h4 : σ a ≠ a), σ a = l.prod a),
  { exact ⟨λ hσ, ⟨h1 σ hσ, (this (h1 σ hσ)).mp hσ⟩, λ hσ, (this hσ.1).mpr hσ.2⟩ },
  intro h3,
  classical,
  split,
  { intros h a ha,
    exact eq_on_support_mem_disjoint h h2 _ (mem_support.mpr ha) },
  { intros h,
    have hσl : σ.support ⊆ l.prod.support,
    { intros x hx,
      rw mem_support at hx,
      rwa [mem_support, ←h _ hx] },
    obtain ⟨a, ha, -⟩ := id h3,
    rw ←mem_support at ha,
    obtain ⟨τ, hτ, hτa⟩ := exists_mem_support_of_mem_support_prod (hσl ha),
    have hτl : ∀ (x ∈ τ.support), τ x = l.prod x := eq_on_support_mem_disjoint hτ h2,
    have key : ∀ (x ∈ σ.support ∩ τ.support), σ x = τ x,
    { intros x hx,
      rw [h x (mem_support.mp (mem_of_mem_inter_left hx)), hτl x (mem_of_mem_inter_right hx)] },
    convert hτ,
    refine h3.eq_on_support_inter_nonempty_congr (h1 _ hτ) key _ ha,
    exact key a (mem_inter_of_mem ha hτa) }
end

lemma list_cycles_perm_list_cycles {α : Type*} [fintype α] {l₁ l₂ : list (perm α)}
  (h₀ : l₁.prod = l₂.prod)
  (h₁l₁ : ∀ σ : perm α, σ ∈ l₁ → σ.is_cycle) (h₁l₂ : ∀ σ : perm α, σ ∈ l₂ → σ.is_cycle)
  (h₂l₁ : l₁.pairwise disjoint) (h₂l₂ : l₂.pairwise disjoint) :
  l₁ ~ l₂ :=
begin
  classical,
  refine (list.perm_ext (nodup_of_pairwise_disjoint_cycles h₁l₁ h₂l₁)
    (nodup_of_pairwise_disjoint_cycles h₁l₂ h₂l₂)).mpr (λ σ, _),
  by_cases hσ : σ.is_cycle,
  { obtain ⟨a, ha⟩ := not_forall.mp (mt ext hσ.ne_one),
    rw [mem_list_cycles_iff h₁l₁ h₂l₁, mem_list_cycles_iff h₁l₂ h₂l₂, h₀] },
  { exact iff_of_false (mt (h₁l₁ σ) hσ) (mt (h₁l₂ σ) hσ) }
end

/-- Factors a permutation `f` into a list of disjoint cyclic permutations that multiply to `f`. -/
def cycle_factors [fintype α] [linear_order α] (f : perm α) :
  {l : list (perm α) // l.prod = f ∧ (∀ g ∈ l, is_cycle g) ∧ l.pairwise disjoint} :=
cycle_factors_aux (univ.sort (≤)) f (λ _ _, (mem_sort _).2 (mem_univ _))

/-- Factors a permutation `f` into a list of disjoint cyclic permutations that multiply to `f`,
  without a linear order. -/
def trunc_cycle_factors [fintype α] (f : perm α) :
  trunc {l : list (perm α) // l.prod = f ∧ (∀ g ∈ l, is_cycle g) ∧ l.pairwise disjoint} :=
quotient.rec_on_subsingleton (@univ α _).1
  (λ l h, trunc.mk (cycle_factors_aux l f h))
  (show ∀ x, f x ≠ x → x ∈ (@univ α _).1, from λ _ _, mem_univ _)

section cycle_factors_finset

variables [fintype α] (f : perm α)

/-- Factors a permutation `f` into a `finset` of disjoint cyclic permutations that multiply to `f`.
-/
def cycle_factors_finset : finset (perm α) :=
(trunc_cycle_factors f).lift
  (λ (l : {l : list (perm α) // l.prod = f ∧ (∀ g ∈ l, is_cycle g) ∧ l.pairwise disjoint}),
    l.val.to_finset) (λ ⟨l, hl⟩ ⟨l', hl'⟩, list.to_finset_eq_of_perm _ _
      (list_cycles_perm_list_cycles (hl'.left.symm ▸ hl.left) hl.right.left (hl'.right.left)
        hl.right.right hl'.right.right))

lemma cycle_factors_finset_eq_list_to_finset {σ : perm α} {l : list (perm α)} (hn : l.nodup) :
  σ.cycle_factors_finset = l.to_finset ↔ (∀ f : perm α, f ∈ l → f.is_cycle) ∧
    l.pairwise disjoint ∧ l.prod = σ :=
begin
  obtain ⟨⟨l', hp', hc', hd'⟩, hl⟩ := trunc.exists_rep σ.trunc_cycle_factors,
  have ht : cycle_factors_finset σ = l'.to_finset,
  { rw [cycle_factors_finset, ←hl, trunc.lift_mk] },
  rw ht,
  split,
  { intro h,
    have hn' : l'.nodup := nodup_of_pairwise_disjoint_cycles hc' hd',
    have hperm : l ~ l' := list.perm_of_nodup_nodup_to_finset_eq hn hn' h.symm,
    refine ⟨_, _, _⟩,
    { exact λ _ h, hc' _ (hperm.subset h)},
    { rwa list.perm.pairwise_iff disjoint.symmetric hperm },
    { rw [←hp', hperm.symm.prod_eq'],
      refine hd'.imp _,
      exact λ _ _, disjoint.commute } },
  { rintro ⟨hc, hd, hp⟩,
    refine list.to_finset_eq_of_perm _ _ _,
    refine list_cycles_perm_list_cycles _ hc' hc hd' hd,
    rw [hp, hp'] }
end

lemma cycle_factors_finset_eq_finset {σ : perm α} {s : finset (perm α)} :
  σ.cycle_factors_finset = s ↔ (∀ f : perm α, f ∈ s → f.is_cycle) ∧
    (∃ h : (∀ (a ∈ s) (b ∈ s), a ≠ b → disjoint a b), s.noncomm_prod id
      (λ a ha b hb, (em (a = b)).by_cases (λ h, h ▸ commute.refl a)
        (set.pairwise.mono' (λ _ _, disjoint.commute) h ha hb)) = σ) :=
begin
  obtain ⟨l, hl, rfl⟩ := s.exists_list_nodup_eq,
  rw cycle_factors_finset_eq_list_to_finset hl,
  simp only [noncomm_prod_to_finset, hl, exists_prop, list.mem_to_finset, and.congr_left_iff,
             and.congr_right_iff, list.map_id, ne.def],
  intros,
  exact ⟨list.pairwise.forall disjoint.symmetric, hl.pairwise_of_forall_ne⟩
end

lemma cycle_factors_finset_pairwise_disjoint (p : perm α) (hp : p ∈ cycle_factors_finset f)
  (q : perm α) (hq : q ∈ cycle_factors_finset f) (h : p ≠ q) :
  disjoint p q :=
begin
  have : f.cycle_factors_finset = f.cycle_factors_finset := rfl,
  obtain ⟨-, hd, -⟩ := cycle_factors_finset_eq_finset.mp this,
  exact hd p hp q hq h
end

lemma cycle_factors_finset_mem_commute (p : perm α) (hp : p ∈ cycle_factors_finset f)
  (q : perm α) (hq : q ∈ cycle_factors_finset f) :
  _root_.commute p q :=
begin
  by_cases h : p = q,
  { exact h ▸ commute.refl _ },
  { exact (cycle_factors_finset_pairwise_disjoint _ _ hp _ hq h).commute }
end

/-- The product of cycle factors is equal to the original `f : perm α`. -/
lemma cycle_factors_finset_noncomm_prod
  (comm : ∀ (g ∈ f.cycle_factors_finset) (h ∈ f.cycle_factors_finset),
    commute (id g) (id h) := cycle_factors_finset_mem_commute f) :
  f.cycle_factors_finset.noncomm_prod id (comm) = f :=
begin
  have : f.cycle_factors_finset = f.cycle_factors_finset := rfl,
  obtain ⟨-, hd, hp⟩ := cycle_factors_finset_eq_finset.mp this,
  exact hp
end

lemma mem_cycle_factors_finset_iff {f p : perm α} :
  p ∈ cycle_factors_finset f ↔ p.is_cycle ∧ ∀ (a ∈ p.support), p a = f a :=
begin
  obtain ⟨l, hl, hl'⟩ := f.cycle_factors_finset.exists_list_nodup_eq,
  rw ←hl',
  rw [eq_comm, cycle_factors_finset_eq_list_to_finset hl] at hl',
  simpa [list.mem_to_finset, ne.def, ←hl'.right.right]
    using mem_list_cycles_iff hl'.left hl'.right.left
end

lemma cycle_of_mem_cycle_factors_finset_iff {f : perm α} {x : α} :
  cycle_of f x ∈ cycle_factors_finset f ↔ x ∈ f.support :=
begin
  rw mem_cycle_factors_finset_iff,
  split,
  { rintro ⟨hc, h⟩,
    contrapose! hc,
    rw [not_mem_support, ←cycle_of_eq_one_iff] at hc,
    simp [hc] },
  { intros hx,
    refine ⟨is_cycle_cycle_of _ (mem_support.mp hx), _⟩,
    intros y hy,
    rw mem_support at hy,
    rw cycle_of_apply,
    split_ifs with H,
    { refl },
    { rw cycle_of_apply_of_not_same_cycle H at hy,
      contradiction } }
end

lemma mem_cycle_factors_finset_support_le {p f : perm α} (h : p ∈ cycle_factors_finset f) :
  p.support ≤ f.support :=
begin
  rw mem_cycle_factors_finset_iff at h,
  intros x hx,
  rwa [mem_support, ←h.right x hx, ←mem_support]
end

lemma cycle_factors_finset_eq_empty_iff {f : perm α} :
  cycle_factors_finset f = ∅ ↔ f = 1 :=
by simpa [cycle_factors_finset_eq_finset] using eq_comm

@[simp] lemma cycle_factors_finset_one :
  cycle_factors_finset (1 : perm α) = ∅ :=
by simp [cycle_factors_finset_eq_empty_iff]

@[simp] lemma cycle_factors_finset_eq_singleton_self_iff {f : perm α} :
  f.cycle_factors_finset = {f} ↔ f.is_cycle :=
by simp [cycle_factors_finset_eq_finset]

lemma is_cycle.cycle_factors_finset_eq_singleton {f : perm α} (hf : is_cycle f) :
  f.cycle_factors_finset = {f} :=
cycle_factors_finset_eq_singleton_self_iff.mpr hf

lemma cycle_factors_finset_eq_singleton_iff {f g : perm α} :
  f.cycle_factors_finset = {g} ↔ f.is_cycle ∧ f = g :=
begin
  suffices : f = g → (g.is_cycle ↔ f.is_cycle),
  { simpa [cycle_factors_finset_eq_finset, eq_comm] },
  rintro rfl,
  exact iff.rfl
end

/-- Two permutations `f g : perm α` have the same cycle factors iff they are the same. -/
lemma cycle_factors_finset_injective : function.injective (@cycle_factors_finset α _ _) :=
begin
  intros f g h,
  rw ←cycle_factors_finset_noncomm_prod f,
  simpa [h] using cycle_factors_finset_noncomm_prod g
end

lemma disjoint.disjoint_cycle_factors_finset {f g : perm α} (h : disjoint f g) :
  _root_.disjoint (cycle_factors_finset f) (cycle_factors_finset g) :=
begin
  rw disjoint_iff_disjoint_support at h,
  intros x hx,
  simp only [mem_cycle_factors_finset_iff, inf_eq_inter, mem_inter, mem_support] at hx,
  obtain ⟨⟨⟨a, ha, -⟩, hf⟩, -, hg⟩ := hx,
  refine h (_ : a ∈ f.support ∩ g.support),
  simp [ha, ←hf a ha, ←hg a ha]
end

lemma disjoint.cycle_factors_finset_mul_eq_union {f g : perm α} (h : disjoint f g) :
  cycle_factors_finset (f * g) = cycle_factors_finset f ∪ cycle_factors_finset g :=
begin
  rw cycle_factors_finset_eq_finset,
  split,
  { simp only [mem_cycle_factors_finset_iff, mem_union],
    rintro _ (⟨h, -⟩ | ⟨h, -⟩);
    exact h },
  { refine ⟨_, _⟩,
    { simp_rw mem_union,
      rintros x (hx | hx) y (hy | hy) hxy,
      { exact cycle_factors_finset_pairwise_disjoint _ _ hx _ hy hxy },
      { exact h.mono (mem_cycle_factors_finset_support_le hx)
          (mem_cycle_factors_finset_support_le hy) },
      { exact h.symm.mono (mem_cycle_factors_finset_support_le hx)
          (mem_cycle_factors_finset_support_le hy) },
      { exact cycle_factors_finset_pairwise_disjoint _ _ hx _ hy hxy } },
    { rw noncomm_prod_union_of_disjoint h.disjoint_cycle_factors_finset,
      rw [cycle_factors_finset_noncomm_prod, cycle_factors_finset_noncomm_prod] } }
end

lemma disjoint_mul_inv_of_mem_cycle_factors_finset {f g : perm α} (h : f ∈ cycle_factors_finset g) :
  disjoint (g * f⁻¹) f :=
begin
  rw mem_cycle_factors_finset_iff at h,
  intro x,
  by_cases hx : f x = x,
  { exact or.inr hx },
  { refine or.inl _,
    rw [mul_apply, ←h.right, apply_inv_self],
    rwa [←support_inv, apply_mem_support, support_inv, mem_support] }
end

/-- If c is a cycle, a ∈ c.support and c is a cycle of f, then `c = f.cycle_of a` -/
lemma cycle_is_cycle_of {f c : equiv.perm α} {a : α}
  (ha : a ∈ c.support) (hc : c ∈ f.cycle_factors_finset) : c = f.cycle_of a :=
begin
  suffices : f.cycle_of a = c.cycle_of a,
  { rw this,
    apply symm,
    exact equiv.perm.is_cycle.cycle_of_eq
     ((equiv.perm.mem_cycle_factors_finset_iff.mp hc).left)
     (equiv.perm.mem_support.mp ha), },
  let hfc := (equiv.perm.disjoint_mul_inv_of_mem_cycle_factors_finset hc).symm,
  let hfc2 := (perm.disjoint.commute hfc),
  rw ← equiv.perm.cycle_of_mul_of_apply_right_eq_self hfc2,
  simp only [hfc2.eq, inv_mul_cancel_right],
  -- a est dans le support de c, donc pas dans celui de g c⁻¹
  exact equiv.perm.not_mem_support.mp
    (finset.disjoint_left.mp (equiv.perm.disjoint.disjoint_support  hfc) ha),
end

end cycle_factors_finset

@[elab_as_eliminator] lemma cycle_induction_on [fintype β] (P : perm β → Prop) (σ : perm β)
  (base_one : P 1) (base_cycles : ∀ σ : perm β, σ.is_cycle → P σ)
  (induction_disjoint : ∀ σ τ : perm β, disjoint σ τ → is_cycle σ → P σ → P τ → P (σ * τ)) :
  P σ :=
begin
  suffices :
    ∀ l : list (perm β), (∀ τ : perm β, τ ∈ l → τ.is_cycle) → l.pairwise disjoint → P l.prod,
  { classical,
    let x := σ.trunc_cycle_factors.out,
    exact (congr_arg P x.2.1).mp (this x.1 x.2.2.1 x.2.2.2) },
  intro l,
  induction l with σ l ih,
  { exact λ _ _, base_one },
  { intros h1 h2,
    rw list.prod_cons,
    exact induction_disjoint σ l.prod
      (disjoint_prod_right _ (list.pairwise_cons.mp h2).1)
      (h1 _ (list.mem_cons_self _ _))
      (base_cycles σ (h1 σ (l.mem_cons_self σ)))
      (ih (λ τ hτ, h1 τ (list.mem_cons_of_mem σ hτ)) h2.of_cons) }
end

lemma cycle_factors_finset_mul_inv_mem_eq_sdiff [fintype α] {f g : perm α}
  (h : f ∈ cycle_factors_finset g) :
  cycle_factors_finset (g * f⁻¹) = (cycle_factors_finset g) \ {f} :=
begin
  revert f,
  apply cycle_induction_on _ g,
  { simp },
  { intros σ hσ f hf,
    simp only [cycle_factors_finset_eq_singleton_self_iff.mpr hσ, mem_singleton] at hf ⊢,
    simp [hf] },
  { intros σ τ hd hc hσ hτ f,
    simp_rw [hd.cycle_factors_finset_mul_eq_union, mem_union],
    -- if only `wlog` could work here...
    rintro (hf | hf),
    { rw [hd.commute.eq, union_comm, union_sdiff_distrib, sdiff_singleton_eq_erase,
          erase_eq_of_not_mem, mul_assoc, disjoint.cycle_factors_finset_mul_eq_union, hσ hf],
      { rw mem_cycle_factors_finset_iff at hf,
        intro x,
        cases hd.symm x with hx hx,
        { exact or.inl hx },
        { refine or.inr _,
          by_cases hfx : f x = x,
          { rw ←hfx,
            simpa [hx] using hfx.symm },
          { rw mul_apply,
            rw ←hf.right _ (mem_support.mpr hfx) at hx,
            contradiction } } },
      { exact λ H, hd.disjoint_cycle_factors_finset (mem_inter_of_mem hf H) } },
    { rw [union_sdiff_distrib, sdiff_singleton_eq_erase,
          erase_eq_of_not_mem, mul_assoc, disjoint.cycle_factors_finset_mul_eq_union, hτ hf],
      { rw mem_cycle_factors_finset_iff at hf,
        intro x,
        cases hd x with hx hx,
        { exact or.inl hx },
        { refine or.inr _,
          by_cases hfx : f x = x,
          { rw ←hfx,
            simpa [hx] using hfx.symm },
          { rw mul_apply,
            rw ←hf.right _ (mem_support.mpr hfx) at hx,
            contradiction } } },
      { exact λ H, hd.disjoint_cycle_factors_finset (mem_inter_of_mem H hf) } } }
end

lemma same_cycle.nat_of_mem_support [fintype α] (f : perm α) {x y : α} (h : same_cycle f x y)
  (hx : x ∈ f.support) :
  ∃ (i : ℕ) (hi' : i < (f.cycle_of x).support.card), (f ^ i) x = y :=
begin
  revert f,
  intro f,
  apply cycle_induction_on _ f,
  { simp },
  { intros g hg H hx,
    rw mem_support at hx,
    rw [hg.cycle_of_eq hx, ←order_of_is_cycle hg],
    exact H.nat' },
  { rintros g h hd hg IH IH' ⟨m, rfl⟩ hx,
    cases (disjoint_iff_eq_or_eq.mp hd) x with hgx hhx,
    { have hpow : ∀ (k : ℤ), ((g * h) ^ k) x = (h ^ k) x,
      { intro k,
        suffices : (g ^ k) x = x,
        { simpa [hd.commute.eq, hd.commute.symm.mul_zpow] },
        rw zpow_apply_eq_self_of_apply_eq_self,
        simpa using hgx },
      obtain ⟨k, hk, hk'⟩ := IH' _ _,
      { refine ⟨k, _, _⟩,
        { rw [←cycle_of_eq_one_iff] at hgx,
          rwa [hd.cycle_of_mul_distrib, hgx, one_mul] },
        { simpa [←zpow_coe_nat, hpow] using hk' } },
      { use m,
        simp [hpow] },
      { rw [mem_support, hd.commute.eq] at hx,
        simpa [hgx] using hx } },
    { have hpow : ∀ (k : ℤ), ((g * h) ^ k) x = (g ^ k) x,
      { intro k,
        suffices : (h ^ k) x = x,
        { simpa [hd.commute.mul_zpow] },
        rw zpow_apply_eq_self_of_apply_eq_self,
        simpa using hhx },
      obtain ⟨k, hk, hk'⟩ := IH _ _,
      { refine ⟨k, _, _⟩,
        { rw [←cycle_of_eq_one_iff] at hhx,
          rwa [hd.cycle_of_mul_distrib, hhx, mul_one] },
        { simpa [←zpow_coe_nat, hpow] using hk' } },
      { use m,
        simp [hpow] },
      { simpa [hhx] using hx } } }
end

lemma same_cycle.nat [fintype α] (f : perm α) {x y : α} (h : same_cycle f x y) :
  ∃ (i : ℕ) (hi : 0 < i) (hi' : i ≤ (f.cycle_of x).support.card + 1), (f ^ i) x = y :=
begin
  by_cases hx : x ∈ f.support,
  { obtain ⟨k, hk, hk'⟩ := same_cycle.nat_of_mem_support f h hx,
    cases k,
    { refine ⟨(f.cycle_of x).support.card, _, self_le_add_right _ _, _⟩,
      { refine zero_lt_one.trans (one_lt_card_support_of_ne_one _),
        simpa using hx },
      { simp only [perm.coe_one, id.def, pow_zero] at hk',
        subst hk',
        rw [←order_of_is_cycle (is_cycle_cycle_of _ (mem_support.mp hx)),
            ←cycle_of_pow_apply_self, pow_order_of_eq_one, one_apply] } },
    { exact ⟨k + 1, by simp, nat.le_succ_of_le hk.le, hk'⟩ } },
  { refine ⟨1, zero_lt_one, by simp, _⟩,
    obtain ⟨k, rfl⟩ := h,
    rw [not_mem_support] at hx,
    rw [pow_apply_eq_self_of_apply_eq_self hx,
        zpow_apply_eq_self_of_apply_eq_self hx] }
end

section generation

variables [fintype α] [fintype β]

open subgroup

lemma closure_is_cycle : closure {σ : perm β | is_cycle σ} = ⊤ :=
begin
  classical,
  exact top_le_iff.mp (le_trans (ge_of_eq closure_is_swap) (closure_mono (λ _, is_swap.is_cycle))),
end

lemma closure_cycle_adjacent_swap {σ : perm α} (h1 : is_cycle σ) (h2 : σ.support = ⊤) (x : α) :
  closure ({σ, swap x (σ x)} : set (perm α)) = ⊤ :=
begin
  let H := closure ({σ, swap x (σ x)} : set (perm α)),
  have h3 : σ ∈ H := subset_closure (set.mem_insert σ _),
  have h4 : swap x (σ x) ∈ H := subset_closure (set.mem_insert_of_mem _ (set.mem_singleton _)),
  have step1 : ∀ (n : ℕ), swap ((σ ^ n) x) ((σ^(n+1)) x) ∈ H,
  { intro n,
    induction n with n ih,
    { exact subset_closure (set.mem_insert_of_mem _ (set.mem_singleton _)) },
    { convert H.mul_mem (H.mul_mem h3 ih) (H.inv_mem h3),
      rw [mul_swap_eq_swap_mul, mul_inv_cancel_right], refl } },
  have step2 : ∀ (n : ℕ), swap x ((σ ^ n) x) ∈ H,
  { intro n,
    induction n with n ih,
    { convert H.one_mem,
      exact swap_self x },
    { by_cases h5 : x = (σ ^ n) x,
      { rw [pow_succ, mul_apply, ←h5], exact h4 },
      by_cases h6 : x = (σ^(n+1)) x,
      { rw [←h6, swap_self], exact H.one_mem },
      rw [swap_comm, ←swap_mul_swap_mul_swap h5 h6],
      exact H.mul_mem (H.mul_mem (step1 n) ih) (step1 n) } },
  have step3 : ∀ (y : α), swap x y ∈ H,
  { intro y,
    have hx : x ∈ (⊤ : finset α) := finset.mem_univ x,
    rw [←h2, mem_support] at hx,
    have hy : y ∈ (⊤ : finset α) := finset.mem_univ y,
    rw [←h2, mem_support] at hy,
    cases is_cycle.exists_pow_eq h1 hx hy with n hn,
    rw ← hn,
    exact step2 n },
  have step4 : ∀ (y z : α), swap y z ∈ H,
  { intros y z,
    by_cases h5 : z = x,
    { rw [h5, swap_comm], exact step3 y },
    by_cases h6 : z = y,
    { rw [h6, swap_self], exact H.one_mem },
    rw [←swap_mul_swap_mul_swap h5 h6, swap_comm z x],
    exact H.mul_mem (H.mul_mem (step3 y) (step3 z)) (step3 y) },
  rw [eq_top_iff, ←closure_is_swap, closure_le],
  rintros τ ⟨y, z, h5, h6⟩,
  rw h6,
  exact step4 y z,
end

lemma closure_cycle_coprime_swap {n : ℕ} {σ : perm α} (h0 : nat.coprime n (fintype.card α))
  (h1 : is_cycle σ) (h2 : σ.support = finset.univ) (x : α) :
  closure ({σ, swap x ((σ ^ n) x)} : set (perm α)) = ⊤ :=
begin
  rw [←finset.card_univ, ←h2, ←order_of_is_cycle h1] at h0,
  cases exists_pow_eq_self_of_coprime h0 with m hm,
  have h2' : (σ ^ n).support = ⊤ := eq.trans (support_pow_coprime h0) h2,
  have h1' : is_cycle ((σ ^ n) ^ (m : ℤ)) := by rwa ← hm at h1,
  replace h1' : is_cycle (σ ^ n) := is_cycle_of_is_cycle_pow h1'
    (le_trans (support_pow_le σ n) (ge_of_eq (congr_arg support hm))),
  rw [eq_top_iff, ←closure_cycle_adjacent_swap h1' h2' x, closure_le, set.insert_subset],
  exact ⟨subgroup.pow_mem (closure _) (subset_closure (set.mem_insert σ _)) n,
    set.singleton_subset_iff.mpr (subset_closure (set.mem_insert_of_mem _ (set.mem_singleton _)))⟩,
end

lemma closure_prime_cycle_swap {σ τ : perm α} (h0 : (fintype.card α).prime) (h1 : is_cycle σ)
  (h2 : σ.support = finset.univ) (h3 : is_swap τ) : closure ({σ, τ} : set (perm α)) = ⊤ :=
begin
  obtain ⟨x, y, h4, h5⟩ := h3,
  obtain ⟨i, hi⟩ := h1.exists_pow_eq (mem_support.mp
  ((finset.ext_iff.mp h2 x).mpr (finset.mem_univ x)))
    (mem_support.mp ((finset.ext_iff.mp h2 y).mpr (finset.mem_univ y))),
  rw [h5, ←hi],
  refine closure_cycle_coprime_swap (nat.coprime.symm
    (h0.coprime_iff_not_dvd.mpr (λ h, h4 _))) h1 h2 x,
  cases h with m hm,
  rwa [hm, pow_mul, ←finset.card_univ, ←h2, ←order_of_is_cycle h1,
    pow_order_of_eq_one, one_pow, one_apply] at hi,
end

end generation

section
variables [fintype α] {σ τ : perm α}

noncomputable theory

lemma is_conj_of_support_equiv (f : {x // x ∈ (σ.support : set α)} ≃ {x // x ∈ (τ.support : set α)})
  (hf : ∀ (x : α) (hx : x ∈ (σ.support : set α)), (f ⟨σ x, apply_mem_support.2 hx⟩ : α) =
    τ ↑(f ⟨x,hx⟩)) :
  is_conj σ τ :=
begin
  refine is_conj_iff.2 ⟨equiv.extend_subtype f, _⟩,
  rw mul_inv_eq_iff_eq_mul,
  ext,
  simp only [perm.mul_apply],
  by_cases hx : x ∈ σ.support,
  { rw [equiv.extend_subtype_apply_of_mem, equiv.extend_subtype_apply_of_mem],
    { exact hf x (finset.mem_coe.2 hx) } },
  { rwa [not_not.1 ((not_congr mem_support).1 (equiv.extend_subtype_not_mem f _ _)),
      not_not.1 ((not_congr mem_support).mp hx)] }
end

theorem is_cycle.is_conj (hσ : is_cycle σ) (hτ : is_cycle τ) (h : σ.support.card = τ.support.card) :
  is_conj σ τ :=
begin
  refine is_conj_of_support_equiv (hσ.zpowers_equiv_support.symm.trans
    ((zpowers_equiv_zpowers begin
      rw [order_of_is_cycle hσ, h, order_of_is_cycle hτ],
  end).trans hτ.zpowers_equiv_support)) _,
  intros x hx,
  simp only [perm.mul_apply, equiv.trans_apply, equiv.sum_congr_apply],
  obtain ⟨n, rfl⟩ := hσ.exists_pow_eq (classical.some_spec hσ).1 (mem_support.1 hx),
  apply eq.trans _ (congr rfl (congr rfl (congr rfl
    (congr rfl (hσ.zpowers_equiv_support_symm_apply n).symm)))),
  apply (congr rfl (congr rfl (congr rfl (hσ.zpowers_equiv_support_symm_apply (n + 1))))).trans _,
  simp only [ne.def, is_cycle.zpowers_equiv_support_apply,
    subtype.coe_mk, zpowers_equiv_zpowers_apply],
  rw [pow_succ, perm.mul_apply],
end

theorem is_cycle.is_conj_iff (hσ : is_cycle σ) (hτ : is_cycle τ) :
  is_conj σ τ ↔ σ.support.card = τ.support.card :=
⟨begin
  intro h,
  obtain ⟨π, rfl⟩ := is_conj_iff.1 h,
  apply finset.card_congr (λ a ha, π a) (λ _ ha, _) (λ _ _ _ _ ab, π.injective ab) (λ b hb, _),
  { simp [mem_support.1 ha] },
  { refine ⟨π⁻¹ b, ⟨_, π.apply_inv_self b⟩⟩,
    contrapose! hb,
    rw [mem_support, not_not] at hb,
    rw [mem_support, not_not, perm.mul_apply, perm.mul_apply, hb, perm.apply_inv_self] }
end, hσ.is_conj hτ⟩

@[simp]
lemma support_conj : (σ * τ * σ⁻¹).support = τ.support.map σ.to_embedding :=
begin
  ext,
  simp only [mem_map_equiv, perm.coe_mul, comp_app, ne.def, perm.mem_support, equiv.eq_symm_apply],
  refl,
end

lemma card_support_conj : (σ * τ * σ⁻¹).support.card = τ.support.card :=
by simp

end

theorem disjoint.is_conj_mul {α : Type*} [fintype α] {σ τ π ρ : perm α}
  (hc1 : is_conj σ π) (hc2 : is_conj τ ρ)
  (hd1 : disjoint σ τ) (hd2 : disjoint π ρ) :
  is_conj (σ * τ) (π * ρ) :=
begin
  classical,
  obtain ⟨f, rfl⟩ := is_conj_iff.1 hc1,
  obtain ⟨g, rfl⟩ := is_conj_iff.1 hc2,
  have hd1' := coe_inj.2 hd1.support_mul,
  have hd2' := coe_inj.2 hd2.support_mul,
  rw [coe_union] at *,
  have hd1'' := disjoint_iff_disjoint_coe.1 (disjoint_iff_disjoint_support.1 hd1),
  have hd2'' := disjoint_iff_disjoint_coe.1 (disjoint_iff_disjoint_support.1 hd2),
  refine is_conj_of_support_equiv _ _,
  { refine ((equiv.set.of_eq hd1').trans (equiv.set.union hd1'')).trans
      ((equiv.sum_congr (subtype_equiv f (λ a, _)) (subtype_equiv g (λ a, _))).trans
      ((equiv.set.of_eq hd2').trans (equiv.set.union hd2'')).symm);
    { simp only [set.mem_image, to_embedding_apply, exists_eq_right,
        support_conj, coe_map, apply_eq_iff_eq] } },
  { intros x hx,
    simp only [trans_apply, symm_trans_apply, set.of_eq_apply,
      set.of_eq_symm_apply, equiv.sum_congr_apply],
    rw [hd1', set.mem_union] at hx,
    cases hx with hxσ hxτ,
    { rw [mem_coe, mem_support] at hxσ,
      rw [set.union_apply_left hd1'' _, set.union_apply_left hd1'' _],
      simp only [subtype_equiv_apply, perm.coe_mul, sum.map_inl, comp_app,
        set.union_symm_apply_left, subtype.coe_mk, apply_eq_iff_eq],
      { have h := (hd2 (f x)).resolve_left _,
        { rw [mul_apply, mul_apply] at h,
          rw [h, inv_apply_self, (hd1 x).resolve_left hxσ] },
        { rwa [mul_apply, mul_apply, inv_apply_self, apply_eq_iff_eq] } },
      { rwa [subtype.coe_mk, subtype.coe_mk, mem_coe, mem_support] },
      { rwa [subtype.coe_mk, subtype.coe_mk, perm.mul_apply,
          (hd1 x).resolve_left hxσ, mem_coe, apply_mem_support, mem_support] } },
    { rw [mem_coe, ← apply_mem_support, mem_support] at hxτ,
      rw [set.union_apply_right hd1'' _, set.union_apply_right hd1'' _],
      simp only [subtype_equiv_apply, perm.coe_mul, sum.map_inr, comp_app,
        set.union_symm_apply_right, subtype.coe_mk, apply_eq_iff_eq],
      { have h := (hd2 (g (τ x))).resolve_right _,
        { rw [mul_apply, mul_apply] at h,
          rw [inv_apply_self, h, (hd1 (τ x)).resolve_right hxτ] },
        { rwa [mul_apply, mul_apply, inv_apply_self, apply_eq_iff_eq] } },
      { rwa [subtype.coe_mk, subtype.coe_mk, mem_coe, ← apply_mem_support, mem_support] },
      { rwa [subtype.coe_mk, subtype.coe_mk, perm.mul_apply,
          (hd1 (τ x)).resolve_right hxτ, mem_coe, mem_support] } } }
end

section fixed_points

/-!
### Fixed points
-/

lemma fixed_point_card_lt_of_ne_one [fintype α] {σ : perm α} (h : σ ≠ 1) :
  (filter (λ x, σ x = x) univ).card < fintype.card α - 1 :=
begin
  rw [lt_tsub_iff_left, ← lt_tsub_iff_right, ← finset.card_compl,
    finset.compl_filter],
  exact one_lt_card_support_of_ne_one h
end

end fixed_points

end equiv.perm


def f ( x : ℕ ) := x + 1

lemma p : f 3 = 4 := begin unfold f, trivial end

structure X ( n : ℕ ) :=
  ( m : ℕ )

@[reducible] def g ( x : X (f 3) ) : X 4 :=
begin
  refine (cast _ x),
  rewrite p
end

lemma h ( x : X (f 3) ) ( p : x.m = 0 ) : (g x).m = 0 :=
begin
  dsimp,
  unfold g._proof_1,
  -- What can I do with this?
  --   ⊢ (eq.rec x (eq.rec (eq.refl (X 4)) (eq.symm _root_.p))).m = 0
  admit
end


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov

! This file was ported from Lean 3 source module analysis.normed_space.completion
! leanprover-community/mathlib commit d3af0609f6db8691dffdc3e1fb7feb7da72698f2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Normed.Group.Completion
import Mathbin.Analysis.NormedSpace.OperatorNorm
import Mathbin.Topology.Algebra.UniformRing

/-!
# Normed space structure on the completion of a normed space

If `E` is a normed space over `𝕜`, then so is `uniform_space.completion E`. In this file we provide
necessary instances and define `uniform_space.completion.to_complₗᵢ` - coercion
`E → uniform_space.completion E` as a bundled linear isometry.

We also show that if `A` is a normed algebra over `𝕜`, then so is `uniform_space.completion A`.

TODO: Generalise the results here from the concrete `completion` to any `abstract_completion`.
-/

noncomputable section

namespace UniformSpace

namespace Completion

variable (𝕜 E : Type _) [NormedField 𝕜] [NormedAddCommGroup E] [NormedSpace 𝕜 E]

instance (priority := 100) NormedSpace.to_uniformContinuousConstSMul :
    UniformContinuousConstSMul 𝕜 E :=
  ⟨fun c => (lipschitzWith_smul c).UniformContinuous⟩
#align uniform_space.completion.normed_space.to_has_uniform_continuous_const_smul UniformSpace.Completion.NormedSpace.to_uniformContinuousConstSMul

instance : NormedSpace 𝕜 (Completion E) :=
  { Completion.module with
    smul := (· • ·)
    norm_smul_le := fun c x =>
      induction_on x
        (isClosed_le (continuous_const_smul _).norm (continuous_const.mul continuous_norm)) fun y =>
        by simp only [← coe_smul, norm_coe, norm_smul] }

variable {𝕜 E}

/-- Embedding of a normed space to its completion as a linear isometry. -/
def toComplₗᵢ : E →ₗᵢ[𝕜] Completion E :=
  { toCompl with
    toFun := coe
    map_smul' := coe_smul
    norm_map' := norm_coe }
#align uniform_space.completion.to_complₗᵢ UniformSpace.Completion.toComplₗᵢ

@[simp]
theorem coe_toComplₗᵢ : ⇑(toComplₗᵢ : E →ₗᵢ[𝕜] Completion E) = coe :=
  rfl
#align uniform_space.completion.coe_to_complₗᵢ UniformSpace.Completion.coe_toComplₗᵢ

/-- Embedding of a normed space to its completion as a continuous linear map. -/
def toComplL : E →L[𝕜] Completion E :=
  toComplₗᵢ.toContinuousLinearMap
#align uniform_space.completion.to_complL UniformSpace.Completion.toComplL

@[simp]
theorem coe_toComplL : ⇑(toComplL : E →L[𝕜] Completion E) = coe :=
  rfl
#align uniform_space.completion.coe_to_complL UniformSpace.Completion.coe_toComplL

@[simp]
theorem norm_toComplL {𝕜 E : Type _} [NontriviallyNormedField 𝕜] [NormedAddCommGroup E]
    [NormedSpace 𝕜 E] [Nontrivial E] : ‖(toComplL : E →L[𝕜] Completion E)‖ = 1 :=
  (toComplₗᵢ : E →ₗᵢ[𝕜] Completion E).norm_toContinuousLinearMap
#align uniform_space.completion.norm_to_complL UniformSpace.Completion.norm_toComplL

section Algebra

variable (𝕜) (A : Type _)

instance [SeminormedRing A] : NormedRing (Completion A) :=
  { Completion.ring,
    Completion.metricSpace with
    dist_eq := fun x y => by
      apply completion.induction_on₂ x y <;> clear x y
      · refine' isClosed_eq (completion.uniform_continuous_extension₂ _).Continuous _
        exact Continuous.comp completion.continuous_extension continuous_sub
      · intro x y
        rw [← completion.coe_sub, norm_coe, completion.dist_eq, dist_eq_norm]
    norm_mul := fun x y => by
      apply completion.induction_on₂ x y <;> clear x y
      ·
        exact
          isClosed_le (Continuous.comp continuous_norm continuous_mul)
            (Continuous.comp Real.continuous_mul
              (Continuous.prod_map continuous_norm continuous_norm))
      · intro x y
        simp only [← coe_mul, norm_coe]
        exact norm_mul_le x y }

instance [SeminormedCommRing A] [NormedAlgebra 𝕜 A] [UniformContinuousConstSMul 𝕜 A] :
    NormedAlgebra 𝕜 (Completion A) :=
  { Completion.algebra A 𝕜 with
    norm_smul_le := fun r x =>
      by
      apply completion.induction_on x <;> clear x
      ·
        exact
          isClosed_le (Continuous.comp continuous_norm (continuous_const_smul r))
            (Continuous.comp (continuous_mul_left _) continuous_norm)
      · intro x
        simp only [← coe_smul, norm_coe]
        exact norm_smul_le r x }

end Algebra

end Completion

end UniformSpace