/-
Copyright (c) 2015, 2017 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Metric spaces.

Authors: Jeremy Avigad, Robert Y. Lewis, Johannes Hölzl, Mario Carneiro

Many definitions and theorems expected on metric spaces are already introduced on uniform spaces and
topological spaces. For example:
  open and closed sets, compactness, completeness, continuity and uniform continuity
-/
import data.real.nnreal analysis.topology.topological_structures
open lattice set filter classical
noncomputable theory

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

/-- Construct a metric space from a distance function and metric space axioms -/
def metric_space.uniform_space_of_dist
  (dist : α → α → ℝ)
  (dist_self : ∀ x : α, dist x x = 0)
  (dist_comm : ∀ x y : α, dist x y = dist y x)
  (dist_triangle : ∀ x y z : α, dist x z ≤ dist x y + dist y z) : uniform_space α :=
uniform_space.of_core {
  uniformity := (⨅ ε>0, principal {p:α×α | dist p.1 p.2 < ε}),
  refl       := le_infi $ assume ε, le_infi $
    by simp [set.subset_def, id_rel, dist_self, (>)] {contextual := tt},
  comp       := le_infi $ assume ε, le_infi $ assume h, lift'_le
    (mem_infi_sets (ε / 2) $ mem_infi_sets (div_pos_of_pos_of_pos h two_pos) (subset.refl _)) $
    have ∀ (a b c : α), dist a c < ε / 2 → dist c b < ε / 2 → dist a b < ε,
      from assume a b c hac hcb,
      calc dist a b ≤ dist a c + dist c b : dist_triangle _ _ _
        ... < ε / 2 + ε / 2 : add_lt_add hac hcb
        ... = ε : by rw [div_add_div_same, add_self_div_two],
    by simpa [comp_rel],
  symm       := tendsto_infi.2 $ assume ε, tendsto_infi.2 $ assume h,
    tendsto_infi' ε $ tendsto_infi' h $ tendsto_principal_principal.2 $ by simp [dist_comm] }

/-- The distance function (given an ambient metric space on `α`), which returns
  a nonnegative real number `dist x y` given `x y : α`. -/
class has_dist (α : Type*) := (dist : α → α → ℝ)

export has_dist (dist)

/-- Metric space

Each metric space induces a canonical `uniform_space` and hence a canonical `topological_space`.
This is enforced in the type class definition, by extending the `uniform_space` structure. When
instantiating a `metric_space` structure, the uniformity fields are not necessary, they will be
filled in by default. -/
class metric_space (α : Type u) extends has_dist α : Type u :=
(dist_self : ∀ x : α, dist x x = 0)
(eq_of_dist_eq_zero : ∀ {x y : α}, dist x y = 0 → x = y)
(dist_comm : ∀ x y : α, dist x y = dist y x)
(dist_triangle : ∀ x y z : α, dist x z ≤ dist x y + dist y z)
(to_uniform_space : uniform_space α := metric_space.uniform_space_of_dist dist dist_self dist_comm dist_triangle)
(uniformity_dist : uniformity = ⨅ ε>0, principal {p:α×α | dist p.1 p.2 < ε} . control_laws_tac)

theorem uniformity_dist_of_mem_uniformity {U : filter (α × α)} (D : α → α → ℝ)
  (H : ∀ s, s ∈ U.sets ↔ ∃ε>0, ∀{a b:α}, D a b < ε → (a, b) ∈ s) :
  U = ⨅ ε>0, principal {p:α×α | D p.1 p.2 < ε} :=
le_antisymm
  (le_infi $ λ ε, le_infi $ λ ε0, le_principal_iff.2 $ (H _).2 ⟨ε, ε0, λ a b, id⟩)
  (λ r ur, let ⟨ε, ε0, h⟩ := (H _).1 ur in
    mem_infi_sets ε $ mem_infi_sets ε0 $ mem_principal_sets.2 $ λ ⟨a, b⟩, h)

variables [metric_space α]

instance metric_space.to_uniform_space' : uniform_space α :=
metric_space.to_uniform_space α

@[simp] theorem dist_self (x : α) : dist x x = 0 := metric_space.dist_self x

theorem eq_of_dist_eq_zero {x y : α} : dist x y = 0 → x = y :=
metric_space.eq_of_dist_eq_zero

theorem dist_comm (x y : α) : dist x y = dist y x := metric_space.dist_comm x y

@[simp] theorem dist_eq_zero {x y : α} : dist x y = 0 ↔ x = y :=
iff.intro eq_of_dist_eq_zero (assume : x = y, this ▸ dist_self _)

@[simp] theorem zero_eq_dist {x y : α} : 0 = dist x y ↔ x = y :=
by rw [eq_comm, dist_eq_zero]

theorem dist_triangle (x y z : α) : dist x z ≤ dist x y + dist y z :=
metric_space.dist_triangle x y z

theorem dist_triangle_left (x y z : α) : dist x y ≤ dist z x + dist z y :=
by rw dist_comm z; apply dist_triangle

theorem dist_triangle_right (x y z : α) : dist x y ≤ dist x z + dist y z :=
by rw dist_comm y; apply dist_triangle

theorem swap_dist : function.swap (@dist α _) = dist :=
by funext x y; exact dist_comm _ _

theorem abs_dist_sub_le (x y z : α) : abs (dist x z - dist y z) ≤ dist x y :=
abs_sub_le_iff.2
 ⟨sub_le_iff_le_add.2 (dist_triangle _ _ _),
  sub_le_iff_le_add.2 (dist_triangle_left _ _ _)⟩

theorem dist_nonneg {x y : α} : 0 ≤ dist x y :=
have 2 * dist x y ≥ 0,
  from calc 2 * dist x y = dist x y + dist y x : by rw [dist_comm x y, two_mul]
    ... ≥ 0 : by rw ← dist_self x; apply dist_triangle,
nonneg_of_mul_nonneg_left this two_pos

@[simp] theorem dist_le_zero {x y : α} : dist x y ≤ 0 ↔ x = y :=
by simpa [le_antisymm_iff, dist_nonneg] using @dist_eq_zero _ _ x y

@[simp] theorem dist_pos {x y : α} : 0 < dist x y ↔ x ≠ y :=
by simpa [-dist_le_zero] using not_congr (@dist_le_zero _ _ x y)

section
variables [metric_space α]

def nndist (a b : α) : nnreal := ⟨dist a b, dist_nonneg⟩

@[simp] lemma nndist_self (a : α) : nndist a a = 0 := (nnreal.coe_eq_zero _).1 (dist_self a)

@[simp] lemma coe_dist (a b : α) : (nndist a b : ℝ) = dist a b := rfl

theorem eq_of_nndist_eq_zero {x y : α} : nndist x y = 0 → x = y :=
by simp [nnreal.eq_iff.symm]

theorem nndist_comm (x y : α) : nndist x y = nndist y x :=
by simpa [nnreal.eq_iff.symm] using dist_comm x y

@[simp] theorem nndist_eq_zero {x y : α} : nndist x y = 0 ↔ x = y :=
by simp [nnreal.eq_iff.symm]

@[simp] theorem zero_eq_nndist {x y : α} : 0 = nndist x y ↔ x = y :=
by simp [nnreal.eq_iff.symm]

theorem nndist_triangle (x y z : α) : nndist x z ≤ nndist x y + nndist y z :=
by simpa [nnreal.coe_le] using dist_triangle x y z

theorem nndist_triangle_left (x y z : α) : nndist x y ≤ nndist z x + nndist z y :=
by simpa [nnreal.coe_le] using dist_triangle_left x y z

theorem nndist_triangle_right (x y z : α) : nndist x y ≤ nndist x z + nndist y z :=
by simpa [nnreal.coe_le] using dist_triangle_right x y z

end

/- instantiate metric space as a topology -/
variables {x y z : α} {ε ε₁ ε₂ : ℝ} {s : set α}

/-- `ball x ε` is the set of all points `y` with `dist y x < ε` -/
def ball (x : α) (ε : ℝ) : set α := {y | dist y x < ε}

@[simp] theorem mem_ball : y ∈ ball x ε ↔ dist y x < ε := iff.rfl

theorem mem_ball' : y ∈ ball x ε ↔ dist x y < ε := by rw dist_comm; refl

/-- `closed_ball x ε` is the set of all points `y` with `dist y x ≤ ε` -/
def closed_ball (x : α) (ε : ℝ) := {y | dist y x ≤ ε}

@[simp] theorem mem_closed_ball : y ∈ closed_ball x ε ↔ dist y x ≤ ε := iff.rfl

theorem pos_of_mem_ball (hy : y ∈ ball x ε) : ε > 0 :=
lt_of_le_of_lt dist_nonneg hy

theorem mem_ball_self (h : ε > 0) : x ∈ ball x ε :=
show dist x x < ε, by rw dist_self; assumption

theorem mem_ball_comm : x ∈ ball y ε ↔ y ∈ ball x ε :=
by simp [dist_comm]

theorem ball_subset_ball (h : ε₁ ≤ ε₂) : ball x ε₁ ⊆ ball x ε₂ :=
λ y (yx : _ < ε₁), lt_of_lt_of_le yx h

theorem ball_disjoint (h : ε₁ + ε₂ ≤ dist x y) : ball x ε₁ ∩ ball y ε₂ = ∅ :=
eq_empty_iff_forall_not_mem.2 $ λ z ⟨h₁, h₂⟩,
not_lt_of_le (dist_triangle_left x y z)
  (lt_of_lt_of_le (add_lt_add h₁ h₂) h)

theorem ball_disjoint_same (h : ε ≤ dist x y / 2) : ball x ε ∩ ball y ε = ∅ :=
ball_disjoint $ by rwa [← two_mul, ← le_div_iff' two_pos]

theorem ball_subset (h : dist x y ≤ ε₂ - ε₁) : ball x ε₁ ⊆ ball y ε₂ :=
λ z zx, by rw ← add_sub_cancel'_right ε₁ ε₂; exact
lt_of_le_of_lt (dist_triangle z x y) (add_lt_add_of_lt_of_le zx h)

theorem ball_half_subset (y) (h : y ∈ ball x (ε / 2)) : ball y (ε / 2) ⊆ ball x ε :=
ball_subset $ by rw sub_self_div_two; exact le_of_lt h

theorem exists_ball_subset_ball (h : y ∈ ball x ε) : ∃ ε' > 0, ball y ε' ⊆ ball x ε :=
⟨_, sub_pos.2 h, ball_subset $ by rw sub_sub_self⟩

theorem ball_eq_empty_iff_nonpos : ε ≤ 0 ↔ ball x ε = ∅ :=
(eq_empty_iff_forall_not_mem.trans
⟨λ h, le_of_not_gt $ λ ε0, h _ $ mem_ball_self ε0,
 λ ε0 y h, not_lt_of_le ε0 $ pos_of_mem_ball h⟩).symm

theorem uniformity_dist : uniformity = (⨅ ε>0, principal {p:α×α | dist p.1 p.2 < ε}) :=
metric_space.uniformity_dist _

theorem uniformity_dist' : uniformity = (⨅ε:{ε:ℝ // ε>0}, principal {p:α×α | dist p.1 p.2 < ε.val}) :=
by simp [infi_subtype]; exact uniformity_dist

theorem mem_uniformity_dist {s : set (α×α)} :
  s ∈ (@uniformity α _).sets ↔ (∃ε>0, ∀{a b:α}, dist a b < ε → (a, b) ∈ s) :=
begin
  rw [uniformity_dist', infi_sets_eq],
  simp [subset_def],
  exact assume ⟨r, hr⟩ ⟨p, hp⟩, ⟨⟨min r p, lt_min hr hp⟩, by simp [lt_min_iff, (≥)] {contextual := tt}⟩,
  exact ⟨⟨1, zero_lt_one⟩⟩
end

theorem dist_mem_uniformity {ε:ℝ} (ε0 : 0 < ε) :
  {p:α×α | dist p.1 p.2 < ε} ∈ (@uniformity α _).sets :=
mem_uniformity_dist.2 ⟨ε, ε0, λ a b, id⟩

theorem uniform_continuous_of_metric [metric_space β] {f : α → β} :
  uniform_continuous f ↔ ∀ ε > 0, ∃ δ > 0,
    ∀{a b:α}, dist a b < δ → dist (f a) (f b) < ε :=
uniform_continuous_def.trans
⟨λ H ε ε0, mem_uniformity_dist.1 $ H _ $ dist_mem_uniformity ε0,
 λ H r ru,
  let ⟨ε, ε0, hε⟩ := mem_uniformity_dist.1 ru, ⟨δ, δ0, hδ⟩ := H _ ε0 in
  mem_uniformity_dist.2 ⟨δ, δ0, λ a b h, hε (hδ h)⟩⟩

theorem uniform_embedding_of_metric [metric_space β] {f : α → β} :
  uniform_embedding f ↔ function.injective f ∧ uniform_continuous f ∧
    ∀ δ > 0, ∃ ε > 0, ∀ {a b : α}, dist (f a) (f b) < ε → dist a b < δ :=
uniform_embedding_def'.trans $ and_congr iff.rfl $ and_congr iff.rfl
⟨λ H δ δ0, let ⟨t, tu, ht⟩ := H _ (dist_mem_uniformity δ0),
               ⟨ε, ε0, hε⟩ := mem_uniformity_dist.1 tu in
  ⟨ε, ε0, λ a b h, ht _ _ (hε h)⟩,
 λ H s su, let ⟨δ, δ0, hδ⟩ := mem_uniformity_dist.1 su, ⟨ε, ε0, hε⟩ := H _ δ0 in
  ⟨_, dist_mem_uniformity ε0, λ a b h, hδ (hε h)⟩⟩

theorem totally_bounded_of_metric {s : set α} :
  totally_bounded s ↔ ∀ ε > 0, ∃t : set α, finite t ∧ s ⊆ ⋃y∈t, ball y ε :=
⟨λ H ε ε0, H _ (dist_mem_uniformity ε0),
 λ H r ru, let ⟨ε, ε0, hε⟩ := mem_uniformity_dist.1 ru,
               ⟨t, ft, h⟩ := H ε ε0 in
  ⟨t, ft, subset.trans h $ Union_subset_Union $ λ y, Union_subset_Union $ λ yt z, hε⟩⟩

lemma cauchy_of_metric {f : filter α} :
  cauchy f ↔ f ≠ ⊥ ∧ ∀ ε > 0, ∃ t ∈ f.sets, ∀ x y ∈ t, dist x y < ε :=
cauchy_iff.trans $ and_congr iff.rfl
⟨λ H ε ε0, let ⟨t, tf, ts⟩ := H _ (dist_mem_uniformity ε0) in
   ⟨t, tf, λ x y xt yt, @ts (x, y) ⟨xt, yt⟩⟩,
 λ H r ru, let ⟨ε, ε0, hε⟩ := mem_uniformity_dist.1 ru,
               ⟨t, tf, h⟩ := H ε ε0 in
   ⟨t, tf, λ ⟨x, y⟩ ⟨hx, hy⟩, hε (h x y hx hy)⟩⟩

theorem nhds_eq_metric : nhds x = (⨅ε:{ε:ℝ // ε>0}, principal (ball x ε.val)) :=
begin
  rw [nhds_eq_uniformity, uniformity_dist', lift'_infi],
  { apply congr_arg, funext ε,
    rw [lift'_principal],
    { simp [ball, dist_comm] },
    { exact monotone_preimage } },
  { exact ⟨⟨1, zero_lt_one⟩⟩ },
  { intros, refl }
end

theorem mem_nhds_iff_metric : s ∈ (nhds x).sets ↔ ∃ε>0, ball x ε ⊆ s :=
begin
  rw [nhds_eq_metric, infi_sets_eq],
  { simp },
  { intros y z, cases y with y hy, cases z with z hz,
    refine ⟨⟨min y z, lt_min hy hz⟩, _⟩,
    simp [ball_subset_ball, min_le_left, min_le_right, (≥)] },
  { exact ⟨⟨1, zero_lt_one⟩⟩ }
end

theorem is_open_metric : is_open s ↔ ∀x∈s, ∃ε>0, ball x ε ⊆ s :=
by simp [is_open_iff_nhds, mem_nhds_iff_metric]

theorem is_open_ball : is_open (ball x ε) :=
is_open_metric.2 $ λ y, exists_ball_subset_ball

theorem ball_mem_nhds (x : α) {ε : ℝ} (ε0 : 0 < ε) : ball x ε ∈ (nhds x).sets :=
mem_nhds_sets is_open_ball (mem_ball_self ε0)

theorem tendsto_nhds_of_metric [metric_space β] {f : α → β} {a b} :
  tendsto f (nhds a) (nhds b) ↔ ∀ ε > 0,
    ∃ δ > 0, ∀{x:α}, dist x a < δ → dist (f x) b < ε :=
⟨λ H ε ε0, mem_nhds_iff_metric.1 (H (ball_mem_nhds _ ε0)),
 λ H s hs,
  let ⟨ε, ε0, hε⟩ := mem_nhds_iff_metric.1 hs, ⟨δ, δ0, hδ⟩ := H _ ε0 in
  mem_nhds_iff_metric.2 ⟨δ, δ0, λ x h, hε (hδ h)⟩⟩

theorem continuous_of_metric [metric_space β] {f : α → β} :
  continuous f ↔ ∀b (ε > 0), ∃ δ > 0, ∀a,
    dist a b < δ → dist (f a) (f b) < ε :=
continuous_iff_tendsto.trans $ forall_congr $ λ b, tendsto_nhds_of_metric

theorem exists_delta_of_continuous [metric_space β] {f : α → β} {ε:ℝ}
  (hf : continuous f) (hε : ε > 0) (b : α) :
  ∃ δ > 0, ∀a, dist a b ≤ δ → dist (f a) (f b) < ε :=
let ⟨δ, δ_pos, hδ⟩ := continuous_of_metric.1 hf b ε hε in
⟨δ / 2, half_pos δ_pos, assume a ha, hδ a $ lt_of_le_of_lt ha $ div_two_lt_of_pos δ_pos⟩

theorem eq_of_forall_dist_le {x y : α} (h : ∀ε, ε > 0 → dist x y ≤ ε) : x = y :=
eq_of_dist_eq_zero (eq_of_le_of_forall_le_of_dense dist_nonneg h)

instance metric_space.to_separated : separated α :=
separated_def.2 $ λ x y h, eq_of_forall_dist_le $
  λ ε ε0, le_of_lt (h _ (dist_mem_uniformity ε0))

/-- Instantiate the reals as a metric space. -/
instance : metric_space ℝ :=
{ dist               := λx y, abs (x - y),
  dist_self          := by simp [abs_zero],
  eq_of_dist_eq_zero := by simp [add_neg_eq_zero],
  dist_comm          := assume x y, abs_sub _ _,
  dist_triangle      := assume x y z, abs_sub_le _ _ _ }

theorem real.dist_eq (x y : ℝ) : dist x y = abs (x - y) := rfl

theorem real.dist_0_eq_abs (x : ℝ) : dist x 0 = abs x :=
by simp [real.dist_eq]

@[simp] theorem abs_dist {a b : α} : abs (dist a b) = dist a b :=
abs_of_nonneg dist_nonneg

instance : orderable_topology ℝ :=
orderable_topology_of_nhds_abs $ λ x, begin
  simp only [show ∀ r, {b : ℝ | abs (x - b) < r} = ball x r,
    by simp [-sub_eq_add_neg, abs_sub, ball, real.dist_eq]],
  apply le_antisymm,
  { simp [le_infi_iff],
    exact λ ε ε0, mem_nhds_sets (is_open_ball) (mem_ball_self ε0) },
  { intros s h,
    rcases mem_nhds_iff_metric.1 h with ⟨ε, ε0, ss⟩,
    exact mem_infi_sets _ (mem_infi_sets ε0 (mem_principal_sets.2 ss)) },
end

def metric_space.replace_uniformity {α} [U : uniform_space α] (m : metric_space α)
  (H : @uniformity _ U = @uniformity _ (metric_space.to_uniform_space α)) :
  metric_space α :=
{ dist               := @dist _ m.to_has_dist,
  dist_self          := dist_self,
  eq_of_dist_eq_zero := @eq_of_dist_eq_zero _ _,
  dist_comm          := dist_comm,
  dist_triangle      := dist_triangle,
  to_uniform_space   := U,
  uniformity_dist    := H.trans (@uniformity_dist α _) }

def metric_space.induced {α β} (f : α → β) (hf : function.injective f)
  (m : metric_space β) : metric_space α :=
{ dist               := λ x y, dist (f x) (f y),
  dist_self          := λ x, dist_self _,
  eq_of_dist_eq_zero := λ x y h, hf (dist_eq_zero.1 h),
  dist_comm          := λ x y, dist_comm _ _,
  dist_triangle      := λ x y z, dist_triangle _ _ _,
  to_uniform_space   := uniform_space.comap f m.to_uniform_space,
  uniformity_dist    := begin
    apply @uniformity_dist_of_mem_uniformity _ _ (λ x y, dist (f x) (f y)),
    refine λ s, mem_comap_sets.trans _,
    split; intro H,
    { rcases H with ⟨r, ru, rs⟩,
      rcases mem_uniformity_dist.1 ru with ⟨ε, ε0, hε⟩,
      refine ⟨ε, ε0, λ a b h, rs (hε _)⟩, exact h },
    { rcases H with ⟨ε, ε0, hε⟩,
      exact ⟨_, dist_mem_uniformity ε0, λ ⟨a, b⟩, hε⟩ }
  end }

theorem metric_space.induced_uniform_embedding {α β} (f : α → β) (hf : function.injective f)
  (m : metric_space β) :
  by haveI := metric_space.induced f hf m;
     exact uniform_embedding f :=
by let := metric_space.induced f hf m; exactI
uniform_embedding_of_metric.2 ⟨hf, uniform_continuous_comap, λ ε ε0, ⟨ε, ε0, λ a b, id⟩⟩

instance {p : α → Prop} [t : metric_space α] : metric_space (subtype p) :=
metric_space.induced subtype.val (λ x y, subtype.eq) t

theorem subtype.dist_eq {p : α → Prop} [t : metric_space α] (x y : subtype p) :
  dist x y = dist x.1 y.1 := rfl

instance prod.metric_space_max [metric_space β] : metric_space (α × β) :=
{ dist := λ x y, max (dist x.1 y.1) (dist x.2 y.2),
  dist_self := λ x, by simp,
  eq_of_dist_eq_zero := λ x y h, begin
    cases max_le_iff.1 (le_of_eq h) with h₁ h₂,
    exact prod.ext_iff.2 ⟨dist_le_zero.1 h₁, dist_le_zero.1 h₂⟩
  end,
  dist_comm := λ x y, by simp [dist_comm],
  dist_triangle := λ x y z, max_le
    (le_trans (dist_triangle _ _ _) (add_le_add (le_max_left _ _) (le_max_left _ _)))
    (le_trans (dist_triangle _ _ _) (add_le_add (le_max_right _ _) (le_max_right _ _))),
  uniformity_dist := begin
    refine uniformity_prod.trans _,
    simp [uniformity_dist, comap_infi],
    rw ← infi_inf_eq, congr, funext,
    rw ← infi_inf_eq, congr, funext,
    simp [inf_principal, ext_iff, max_lt_iff]
  end,
  to_uniform_space := prod.uniform_space }

theorem uniform_continuous_dist' : uniform_continuous (λp:α×α, dist p.1 p.2) :=
uniform_continuous_of_metric.2 (λ ε ε0, ⟨ε/2, half_pos ε0,
begin
  suffices,
  { intros p q h, cases p with p₁ p₂, cases q with q₁ q₂,
    cases max_lt_iff.1 h with h₁ h₂, clear h,
    dsimp at h₁ h₂ ⊢,
    rw real.dist_eq,
    refine abs_sub_lt_iff.2 ⟨_, _⟩,
    { revert p₁ p₂ q₁ q₂ h₁ h₂, exact this },
    { apply this; rwa dist_comm } },
  intros p₁ p₂ q₁ q₂ h₁ h₂,
  have := add_lt_add
    (abs_sub_lt_iff.1 (lt_of_le_of_lt (abs_dist_sub_le p₁ q₁ p₂) h₁)).1
    (abs_sub_lt_iff.1 (lt_of_le_of_lt (abs_dist_sub_le p₂ q₂ q₁) h₂)).1,
  rwa [add_halves, dist_comm p₂, sub_add_sub_cancel, dist_comm q₂] at this
end⟩)

theorem uniform_continuous_dist [uniform_space β] {f g : β → α}
  (hf : uniform_continuous f) (hg : uniform_continuous g) :
  uniform_continuous (λb, dist (f b) (g b)) :=
(hf.prod_mk hg).comp uniform_continuous_dist'

theorem continuous_dist' : continuous (λp:α×α, dist p.1 p.2) :=
uniform_continuous_dist'.continuous

theorem continuous_dist [topological_space β] {f g : β → α}
  (hf : continuous f) (hg : continuous g) : continuous (λb, dist (f b) (g b)) :=
(hf.prod_mk hg).comp continuous_dist'

theorem tendsto_dist {f g : β → α} {x : filter β} {a b : α}
  (hf : tendsto f x (nhds a)) (hg : tendsto g x (nhds b)) :
  tendsto (λx, dist (f x) (g x)) x (nhds (dist a b)) :=
have tendsto (λp:α×α, dist p.1 p.2) (nhds (a, b)) (nhds (dist a b)),
  from continuous_iff_tendsto.mp continuous_dist' (a, b),
(hf.prod_mk hg).comp (by rw [nhds_prod_eq] at this; exact this)

lemma nhds_comap_dist (a : α) : (nhds (0 : ℝ)).comap (λa', dist a' a) = nhds a :=
have h₁ : ∀ε, (λa', dist a' a) ⁻¹' ball 0 ε ⊆ ball a ε,
  by simp [subset_def, real.dist_0_eq_abs],
have h₂ : tendsto (λa', dist a' a) (nhds a) (nhds (dist a a)),
  from tendsto_dist tendsto_id tendsto_const_nhds,
le_antisymm
  (by simp [h₁, nhds_eq_metric, infi_le_infi, principal_mono,
      -le_principal_iff, -le_infi_iff])
  (by simpa [map_le_iff_le_comap.symm, tendsto] using h₂)

lemma tendsto_iff_dist_tendsto_zero {f : β → α} {x : filter β} {a : α} :
  (tendsto f x (nhds a)) ↔ (tendsto (λb, dist (f b) a) x (nhds 0)) :=
by rw [← nhds_comap_dist a, tendsto_comap_iff]

theorem is_closed_ball : is_closed (closed_ball x ε) :=
is_closed_le (continuous_dist continuous_id continuous_const) continuous_const

section pi
open finset lattice
variables {π : β → Type*} [fintype β] [∀b, metric_space (π b)]

instance has_dist_pi : has_dist (Πb, π b) :=
⟨λf g, ((finset.sup univ (λb, nndist (f b) (g b)) : nnreal) : ℝ)⟩

lemma dist_pi_def (f g : Πb, π b) :
  dist f g = (finset.sup univ (λb, nndist (f b) (g b)) : nnreal) := rfl

instance metric_space_pi : metric_space (Πb, π b) :=
{ dist := dist,
  dist_self := assume f, (nnreal.coe_eq_zero _).2 $ bot_unique $ finset.sup_le $ by simp,
  dist_comm := assume f g, nnreal.eq_iff.2 $ by congr; ext a; exact nndist_comm _ _,
  dist_triangle := assume f g h, show dist f h ≤ (dist f g) + (dist g h), from
    begin
      simp only [dist_pi_def, (nnreal.coe_add _ _).symm, (nnreal.coe_le _ _).symm,
        finset.sup_le_iff],
      assume b hb,
      exact le_trans (nndist_triangle _ (g b) _) (add_le_add (le_sup hb) (le_sup hb))
    end,
  eq_of_dist_eq_zero := assume f g eq0,
    begin
      simp only [dist_pi_def, nnreal.coe_eq_zero, nnreal.bot_eq_zero.symm, eq_bot_iff,
        finset.sup_le_iff] at eq0,
      exact (funext $ assume b, eq_of_nndist_eq_zero $ bot_unique $ eq0 b $ mem_univ b),
    end }

end pi

lemma lebesgue_number_lemma_of_metric
  {s : set α} {ι} {c : ι → set α} (hs : compact s)
  (hc₁ : ∀ i, is_open (c i)) (hc₂ : s ⊆ ⋃ i, c i) :
  ∃ δ > 0, ∀ x ∈ s, ∃ i, ball x δ ⊆ c i :=
let ⟨n, en, hn⟩ := lebesgue_number_lemma hs hc₁ hc₂,
    ⟨δ, δ0, hδ⟩ := mem_uniformity_dist.1 en in
⟨δ, δ0, assume x hx, let ⟨i, hi⟩ := hn x hx in
 ⟨i, assume y hy, hi (hδ (mem_ball'.mp hy))⟩⟩

lemma lebesgue_number_lemma_of_metric_sUnion
  {s : set α} {c : set (set α)} (hs : compact s)
  (hc₁ : ∀ t ∈ c, is_open t) (hc₂ : s ⊆ ⋃₀ c) :
  ∃ δ > 0, ∀ x ∈ s, ∃ t ∈ c, ball x δ ⊆ t :=
by rw sUnion_eq_Union at hc₂;
   simpa using lebesgue_number_lemma_of_metric hs (by simpa) hc₂


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Yaël Dillies
-/
import algebra.module.big_operators
import data.finset.noncomm_prod
import data.fintype.perm
import data.int.modeq
import group_theory.perm.list
import group_theory.perm.sign
import logic.equiv.fintype
/-!
# Cyclic permutations

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

This file develops the theory of cycles in permutations.

## Main definitions

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

* `equiv.perm.same_cycle`: `f.same_cycle x y` when `x` and `y` are in the same cycle of `f`.
* `equiv.perm.is_cycle`: `f` is a cycle if any two nonfixed points of `f` are related by repeated
  applications of `f`, and `f` is not the identity.
* `equiv.perm.is_cycle_on`: `f` is a cycle on a set `s` when any two points of `s` are related by
  repeated applications 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

## Notes

`equiv.perm.is_cycle` and `equiv.perm.is_cycle_on` are different in three ways:
* `is_cycle` is about the entire type while `is_cycle_on` is restricted to a set.
* `is_cycle` forbids the identity while `is_cycle_on` allows it (if `s` is a subsingleton).
* `is_cycle_on` forbids fixed points on `s` (if `s` is nontrivial), while `is_cycle` allows them.
-/

open equiv function finset
open_locale big_operators

variables {ι α β : Type*}

namespace equiv.perm

/-! ### `same_cycle` -/

section same_cycle
variables {f g : perm α} {p : α → Prop} {x y z : α}

/-- 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⟩
lemma same_cycle.rfl : same_cycle f x x := same_cycle.refl _ _

protected lemma _root_.eq.same_cycle (h : x = y) (f : perm α) : f.same_cycle x y := by rw h

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

lemma same_cycle_comm : same_cycle f x y ↔ same_cycle f y x := ⟨same_cycle.symm, same_cycle.symm⟩

@[trans] lemma same_cycle.trans : 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]⟩

@[simp] lemma same_cycle_one : same_cycle 1 x y ↔ x = y := by simp [same_cycle]

@[simp] lemma same_cycle_inv : same_cycle f⁻¹ x y ↔ same_cycle f x y :=
(equiv.neg _).exists_congr_left.trans $ by simp [same_cycle]

alias same_cycle_inv ↔ same_cycle.of_inv same_cycle.inv

@[simp] lemma same_cycle_conj : same_cycle (g * f * g⁻¹) x y ↔ same_cycle f (g⁻¹ x) (g⁻¹ y) :=
exists_congr $ λ i, by simp [conj_zpow, eq_inv_iff_eq]

lemma same_cycle.conj : same_cycle f x y → same_cycle (g * f * g⁻¹) (g x) (g y) :=
by simp [same_cycle_conj]

lemma same_cycle.apply_eq_self_iff : 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 same_cycle.eq_of_left (h : same_cycle f x y) (hx : is_fixed_pt f x) : x = y :=
let ⟨n, hn⟩ := h in (hx.perm_zpow _).eq.symm.trans hn

lemma same_cycle.eq_of_right (h : same_cycle f x y) (hy : is_fixed_pt f y) : x = y :=
h.eq_of_left $ h.apply_eq_self_iff.2 hy

@[simp] lemma same_cycle_apply_left : same_cycle f (f x) y ↔ same_cycle f x y :=
(equiv.add_right 1).exists_congr_left.trans $ by simp [zpow_sub, same_cycle]

@[simp] lemma same_cycle_apply_right : same_cycle f x (f y) ↔ same_cycle f x y :=
by rw [same_cycle_comm, same_cycle_apply_left, same_cycle_comm]

@[simp] lemma same_cycle_inv_apply_left : same_cycle f (f⁻¹ x) y ↔ same_cycle f x y :=
by rw [←same_cycle_apply_left, apply_inv_self]

@[simp] lemma same_cycle_inv_apply_right : same_cycle f x (f⁻¹ y) ↔ same_cycle f x y :=
by rw [←same_cycle_apply_right, apply_inv_self]

@[simp] lemma same_cycle_zpow_left {n : ℤ} : same_cycle f ((f ^ n) x) y ↔ same_cycle f x y :=
(equiv.add_right (n : ℤ)).exists_congr_left.trans $ by simp [same_cycle, zpow_add]

@[simp] lemma same_cycle_zpow_right {n : ℤ} : same_cycle f x ((f ^ n) y) ↔ same_cycle f x y :=
by rw [same_cycle_comm, same_cycle_zpow_left, same_cycle_comm]

@[simp] lemma same_cycle_pow_left {n : ℕ} : same_cycle f ((f ^ n) x) y ↔ same_cycle f x y :=
by rw [←zpow_coe_nat, same_cycle_zpow_left]

@[simp] lemma same_cycle_pow_right {n : ℕ} : same_cycle f x ((f ^ n) y) ↔ same_cycle f x y :=
by rw [←zpow_coe_nat, same_cycle_zpow_right]

alias same_cycle_apply_left ↔ same_cycle.of_apply_left same_cycle.apply_left
alias same_cycle_apply_right ↔ same_cycle.of_apply_right same_cycle.apply_right
alias same_cycle_inv_apply_left ↔ same_cycle.of_inv_apply_left same_cycle.inv_apply_left
alias same_cycle_inv_apply_right ↔ same_cycle.of_inv_apply_right same_cycle.inv_apply_right
alias same_cycle_pow_left ↔ same_cycle.of_pow_left same_cycle.pow_left
alias same_cycle_pow_right ↔ same_cycle.of_pow_right same_cycle.pow_right
alias same_cycle_zpow_left ↔ same_cycle.of_zpow_left same_cycle.zpow_left
alias same_cycle_zpow_right ↔ same_cycle.of_zpow_right same_cycle.zpow_right

lemma same_cycle.of_pow {n : ℕ} : same_cycle (f ^ n) x y → same_cycle f x y :=
λ ⟨m, h⟩, ⟨n * m, by simp [zpow_mul, h]⟩

lemma same_cycle.of_zpow {n : ℤ} : same_cycle (f ^ n) x y → same_cycle f x y :=
λ ⟨m, h⟩, ⟨n * m, by simp [zpow_mul, h]⟩

@[simp] lemma same_cycle_subtype_perm {h} {x y : {x // p x}} :
  (f.subtype_perm h).same_cycle x y ↔ f.same_cycle x y :=
exists_congr $ λ n, by simp [subtype.ext_iff]

alias same_cycle_subtype_perm ↔ _ same_cycle.subtype_perm

@[simp] lemma same_cycle_extend_domain {p : β → Prop} [decidable_pred p] {f : α ≃ subtype p} :
  same_cycle (g.extend_domain f) (f x) (f y) ↔ g.same_cycle x y :=
exists_congr $ λ n, by rw [←extend_domain_zpow, extend_domain_apply_image, subtype.coe_inj,
  f.injective.eq_iff]

alias same_cycle_extend_domain ↔ _ same_cycle.extend_domain

lemma same_cycle.exists_pow_eq' [finite α] : same_cycle f x y → ∃ i < order_of f, (f ^ i) x = y :=
begin
  classical,
  rintro ⟨k, rfl⟩,
  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.exists_pow_eq'' [finite α] (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.exists_pow_eq',
  { 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 α] [decidable_eq α] (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.2 (order_of_pos _).ne'),
      { refine (int.mod_lt _ $ int.coe_nat_ne_zero_iff_pos.2 $ order_of_pos _).trans_le _,
        simp [order_of_le_card_univ] },
      apply_instance }),
  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],
    apply_instance }⟩⟩

end same_cycle

/-!
### `is_cycle`
-/

section is_cycle
variables {f g : perm α} {x y : α}

/-- A cycle is a non identity permutation where 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 → same_cycle f x y

lemma is_cycle.ne_one (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

protected lemma is_cycle.same_cycle (hf : is_cycle f) (hx : f x ≠ x) (hy : f y ≠ y) :
  same_cycle f x y :=
let ⟨g, hg⟩ := hf in
let ⟨a, ha⟩ := hg.2 hx in
let ⟨b, hb⟩ := hg.2 hy in
⟨b - a, by rw [←ha, ←mul_apply, ←zpow_add, sub_add_cancel, hb]⟩

lemma is_cycle.exists_zpow_eq : is_cycle f → f x ≠ x → f y ≠ y → ∃ i : ℤ, (f ^ i) x = y :=
is_cycle.same_cycle

lemma is_cycle.inv (hf : is_cycle f) : is_cycle f⁻¹ :=
hf.imp $ λ x ⟨hx, h⟩, ⟨inv_eq_iff_eq.not.2 hx.symm, λ y hy, (h $ inv_eq_iff_eq.not.2 hy.symm).inv⟩

@[simp] lemma is_cycle_inv : is_cycle f⁻¹ ↔ is_cycle f :=
⟨λ h, by { convert h.inv, rw inv_inv }, is_cycle.inv⟩

lemma is_cycle.conj : is_cycle f → is_cycle (g * f * g⁻¹) :=
begin
  rintro ⟨x, hx, h⟩,
  refine ⟨g x, by simp [coe_mul, inv_apply_self, hx], λ y hy, _⟩,
  rw ←apply_inv_self g y,
  exact (h $ eq_inv_iff_eq.not.2 hy).conj,
end

protected lemma is_cycle.extend_domain {p : β → Prop} [decidable_pred p] (f : α ≃ subtype p) :
  is_cycle g → is_cycle (g.extend_domain f) :=
begin
  rintro ⟨a, ha, ha'⟩,
  refine ⟨f a, _, λ b hb, _⟩,
  { rw extend_domain_apply_image,
    exact subtype.coe_injective.ne (f.injective.ne ha) },
  have h : b = f (f.symm ⟨b, of_not_not $ hb ∘ extend_domain_apply_not_subtype _ _⟩),
  { rw [apply_symm_apply, subtype.coe_mk] },
  rw h at ⊢ hb,
  simp only [extend_domain_apply_image, subtype.coe_injective.ne_iff, f.injective.ne_iff] at hb,
  exact (ha' hb).extend_domain,
end

lemma is_cycle_iff_same_cycle (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⟩⟩

section finite
variables [finite α]

lemma is_cycle.exists_pow_eq (hf : is_cycle f) (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] }⟩

end finite

variables [decidable_eq α]

lemma is_cycle_swap (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 }⟩⟩

protected lemma is_swap.is_cycle : is_swap f → is_cycle f :=
by { rintro ⟨x, y, hxy, rfl⟩, exact is_cycle_swap hxy }

variables [fintype α]

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

lemma is_cycle.exists_pow_eq_one [finite β] {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 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 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

protected lemma is_cycle.order_of (hf : is_cycle f) : order_of f = f.support.card :=
begin
  rw [order_eq_card_zpowers, ←fintype.card_coe],
  convert fintype.card_congr (is_cycle.zpowers_equiv_support hf),
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 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 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.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_pow {n : ℕ} (h1 : is_cycle (f ^ n)) (h2 : f.support ⊆ (f ^ n).support) :
  is_cycle f :=
begin
  have key : ∀ x : α, (f ^ n) x ≠ x ↔ f x ≠ x,
  { simp_rw [←mem_support, ←finset.ext_iff],
    exact (support_pow_le _ n).antisymm h2 },
  obtain ⟨x, hx1, hx2⟩ := h1,
  refine ⟨x, (key x).mp hx1, λ y hy, _⟩,
  cases (hx2 ((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_zpow {n : ℤ} (h1 : is_cycle (f ^ n)) (h2 : f.support ⊆ (f ^ n).support) :
  is_cycle f :=
begin
  cases n,
  { exact h1.of_pow h2 },
  { simp only [le_eq_subset, zpow_neg_succ_of_nat, perm.support_inv] at h1 h2,
    simpa using h1.inv.of_pow h2 }
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

/-- 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 (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 (hf : is_cycle f) (hg : is_cycle g)
  (h : ∀ x ∈ f.support ∩ g.support, f x = g 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 (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.support_pow_of_pos_of_lt_order_of (hf : is_cycle f) {n : ℕ} (npos : 0 < n)
  (hn : n < order_of f) :
  (f ^ n).support = f.support :=
hf.support_pow_eq_iff.2 $ nat.not_dvd_of_pos_of_lt npos hn

lemma is_cycle.pow_iff [finite β] {f : perm β} (hf : is_cycle f) {n : ℕ} :
  is_cycle (f ^ n) ↔ n.coprime (order_of f) :=
begin
  classical,
  casesI nonempty_fintype β,
  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 [h.order_of, hr, hf.order_of] },
    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 hf'.of_pow (λ x hx, _),
    rw [hm],
    exact support_pow_le _ n hx }
end

-- TODO: Define a `set`-valued support to get rid of the `finite β` assumption
lemma is_cycle.pow_eq_one_iff [finite β] {f : perm β} (hf : is_cycle f) {n : ℕ} :
  f ^ n = 1 ↔ ∃ x, f x ≠ x ∧ (f ^ n) x = x :=
begin
  classical,
  casesI nonempty_fintype β,
  split,
  { intro h,
    obtain ⟨x, hx, -⟩ := id hf,
    exact ⟨x, hx, by simp [h]⟩ },
  { rintro ⟨x, hx, hx'⟩,
    by_cases h : support (f ^ n) = support f,
    { rw [← mem_support, ← 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

-- TODO: Define a `set`-valued support to get rid of the `finite β` assumption
lemma is_cycle.pow_eq_one_iff' [finite β] {f : perm β} (hf : is_cycle f) {n : ℕ} {x : β}
  (hx : f x ≠ x) :
  f ^ n = 1 ↔ (f ^ n) x = x :=
⟨λ h, fun_like.congr_fun h x, λ h, hf.pow_eq_one_iff.2 ⟨x, hx, h⟩⟩

-- TODO: Define a `set`-valued support to get rid of the `finite β` assumption
lemma is_cycle.pow_eq_one_iff'' [finite β] {f : perm β} (hf : is_cycle f) {n : ℕ} :
  f ^ n = 1 ↔ ∀ x, f x ≠ x → (f ^ n) x = x :=
⟨λ h x hx, (hf.pow_eq_one_iff' hx).1 h, λ h, let ⟨x, hx, _⟩ := id hf in
  (hf.pow_eq_one_iff' hx).2 (h _ hx)⟩

-- TODO: Define a `set`-valued support to get rid of the `finite β` assumption
lemma is_cycle.pow_eq_pow_iff [finite β] {f : perm β} (hf : is_cycle f) {a b : ℕ} :
  f ^ a = f ^ b ↔ ∃ x, f x ≠ x ∧ (f ^ a) x = (f ^ b) x :=
begin
  classical,
  casesI nonempty_fintype β,
  split,
  { intro h,
    obtain ⟨x, hx, -⟩ := id hf,
    exact ⟨x, hx, by simp [h]⟩ },
  { rintro ⟨x, hx, hx'⟩,
    wlog hab : a ≤ b generalizing a b,
    { exact (this hx'.symm (le_of_not_le hab)).symm },
    suffices : f ^ (b - a) = 1,
    { rw [pow_sub _ hab, mul_inv_eq_one] at this,
      rw this },
    rw hf.pow_eq_one_iff,
    by_cases hfa : (f ^ a) x ∈ f.support,
    { refine ⟨(f ^ a) x, mem_support.mp hfa, _⟩,
      simp only [pow_sub _ hab, equiv.perm.coe_mul, function.comp_app,
        inv_apply_self, ← hx'] },
    { have h := @equiv.perm.zpow_apply_comm _ f 1 a x,
      simp only [zpow_one, zpow_coe_nat] at h,
      rw [not_mem_support, h, function.injective.eq_iff (f ^ a).injective] at hfa,
      contradiction }}
end

lemma is_cycle.is_cycle_pow_pos_of_lt_prime_order [finite β] {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,
  casesI nonempty_fintype β,
  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 hf''.of_pow _,
  rw [hm],
  exact support_pow_le f n
end

end is_cycle

/-! ### `is_cycle_on` -/

section is_cycle_on
variables {f g : perm α} {s t : set α} {a b x y : α}

/-- A permutation is a cycle on `s` when any two points of `s` are related by repeated application
of the permutation. Note that this means the identity is a cycle of subsingleton sets. -/
def is_cycle_on (f : perm α) (s : set α) : Prop :=
set.bij_on f s s ∧ ∀ ⦃x⦄, x ∈ s → ∀ ⦃y⦄, y ∈ s → f.same_cycle x y

@[simp] lemma is_cycle_on_empty : f.is_cycle_on ∅ := by simp [is_cycle_on]

@[simp] lemma is_cycle_on_one : (1 : perm α).is_cycle_on s ↔ s.subsingleton :=
by simp [is_cycle_on, set.bij_on_id, set.subsingleton]

alias is_cycle_on_one ↔ is_cycle_on.subsingleton _root_.set.subsingleton.is_cycle_on_one

@[simp] lemma is_cycle_on_singleton : f.is_cycle_on {a} ↔ f a = a :=
by simp [is_cycle_on, same_cycle.rfl]

lemma is_cycle_on_of_subsingleton [subsingleton α] (f : perm α) (s : set α) : f.is_cycle_on s :=
⟨s.bij_on_of_subsingleton _, λ x _ y _, (subsingleton.elim x y).same_cycle _⟩

@[simp] lemma is_cycle_on_inv : f⁻¹.is_cycle_on s ↔ f.is_cycle_on s :=
by simp [is_cycle_on, set.bij_on_perm_inv]

alias is_cycle_on_inv ↔ is_cycle_on.of_inv is_cycle_on.inv

lemma is_cycle_on.conj (h : f.is_cycle_on s) : (g * f * g⁻¹).is_cycle_on ((g : perm α) '' s) :=
⟨(g.bij_on_image.comp h.1).comp g.bij_on_symm_image,
  λ x hx y hy, by { rw ←preimage_inv at hx hy, convert (h.2 hx hy).conj; rw apply_inv_self }⟩

lemma is_cycle_on_swap [decidable_eq α] (hab : a ≠ b) : (swap a b).is_cycle_on {a, b} :=
⟨bij_on_swap (by simp) (by simp), λ x hx y hy, begin
  rw [set.mem_insert_iff, set.mem_singleton_iff] at hx hy,
  obtain rfl | rfl := hx; obtain rfl | rfl := hy,
  { exact ⟨0, by rw [zpow_zero, coe_one, id.def]⟩ },
  { exact ⟨1, by rw [zpow_one, swap_apply_left]⟩ },
  { exact ⟨1, by rw [zpow_one, swap_apply_right]⟩ },
  { exact ⟨0, by rw [zpow_zero, coe_one, id.def]⟩ }
end⟩

protected lemma is_cycle_on.apply_ne (hf : f.is_cycle_on s) (hs : s.nontrivial) (ha : a ∈ s) :
  f a ≠ a :=
begin
  obtain ⟨b, hb, hba⟩ := hs.exists_ne a,
  obtain ⟨n, rfl⟩ := hf.2 ha hb,
  exact λ h, hba (is_fixed_pt.perm_zpow h n),
end

protected lemma is_cycle.is_cycle_on (hf : f.is_cycle) : f.is_cycle_on {x | f x ≠ x} :=
⟨f.bij_on $ λ x, f.apply_eq_iff_eq.not, λ a ha b, hf.same_cycle ha⟩

/-- This lemma demonstrates the relation between `equiv.perm.is_cycle` and `equiv.perm.is_cycle_on`
in non-degenerate cases. -/
lemma is_cycle_iff_exists_is_cycle_on :
  f.is_cycle ↔ ∃ s : set α, s.nontrivial ∧ f.is_cycle_on s ∧ ∀ ⦃x⦄, ¬ is_fixed_pt f x → x ∈ s :=
begin
  refine ⟨λ hf, ⟨{x | f x ≠ x}, _, hf.is_cycle_on, λ _, id⟩, _⟩,
  { obtain ⟨a, ha⟩ := hf,
    exact ⟨f a, f.injective.ne ha.1, a, ha.1, ha.1⟩ },
  { rintro ⟨s, hs, hf, hsf⟩,
   obtain ⟨a, ha⟩ := hs.nonempty,
   exact ⟨a, hf.apply_ne hs ha, λ b hb, hf.2 ha $ hsf hb⟩ }
end

lemma is_cycle_on.apply_mem_iff (hf : f.is_cycle_on s) : f x ∈ s ↔ x ∈ s :=
⟨λ hx, by { convert hf.1.perm_inv.1 hx, rw inv_apply_self }, λ hx, hf.1.maps_to hx⟩

/-- Note that the identity satisfies `is_cycle_on` for any subsingleton set, but not `is_cycle`. -/
lemma is_cycle_on.is_cycle_subtype_perm (hf : f.is_cycle_on s) (hs : s.nontrivial) :
  (f.subtype_perm $ λ _, hf.apply_mem_iff.symm : perm s).is_cycle :=
begin
  obtain ⟨a, ha⟩ := hs.nonempty,
  exact ⟨⟨a, ha⟩, ne_of_apply_ne (coe : s → α) (hf.apply_ne hs ha),
    λ b hb, (hf.2 (⟨a, ha⟩ : s).prop b.prop).subtype_perm⟩,
end

/-- Note that the identity is a cycle on any subsingleton set, but not a cycle. -/
protected lemma is_cycle_on.subtype_perm (hf : f.is_cycle_on s) :
  (f.subtype_perm $ λ _, hf.apply_mem_iff.symm : perm s).is_cycle_on set.univ :=
begin
  obtain hs | hs := s.subsingleton_or_nontrivial,
  { haveI := hs.coe_sort,
    exact is_cycle_on_of_subsingleton _ _ },
  convert (hf.is_cycle_subtype_perm hs).is_cycle_on,
  rw [eq_comm, set.eq_univ_iff_forall],
  exact λ x, ne_of_apply_ne (coe : s → α) (hf.apply_ne hs x.prop),
end

-- TODO: Theory of order of an element under an action
lemma is_cycle_on.pow_apply_eq {s : finset α} (hf : f.is_cycle_on s) (ha : a ∈ s) {n : ℕ} :
  (f ^ n) a = a ↔ s.card ∣ n :=
begin
  obtain rfl | hs := finset.eq_singleton_or_nontrivial ha,
  { rw [coe_singleton, is_cycle_on_singleton] at hf,
    simpa using is_fixed_pt.iterate hf n },
  classical,
  have h : ∀ x ∈ s.attach, ¬ f ↑x = ↑x := λ x hx, hf.apply_ne hs x.prop,
  have := (hf.is_cycle_subtype_perm hs).order_of,
  simp only [filter_true_of_mem h, support_subtype_perm, card_attach] at this,
  rw [←this, order_of_dvd_iff_pow_eq_one, (hf.is_cycle_subtype_perm hs).pow_eq_one_iff'
    (ne_of_apply_ne (coe : s → α) $ hf.apply_ne hs (⟨a, ha⟩ : s).prop)],
  simp only [subtype.coe_mk, subtype_perm_pow, subtype_perm_apply],
end

lemma is_cycle_on.zpow_apply_eq {s : finset α} (hf : f.is_cycle_on s) (ha : a ∈ s) :
  ∀ {n : ℤ}, (f ^ n) a = a ↔ (s.card : ℤ) ∣ n
| (int.of_nat n) := (hf.pow_apply_eq ha).trans int.coe_nat_dvd.symm
| (int.neg_succ_of_nat n) := by { rw [zpow_neg_succ_of_nat, ←inv_pow],
    exact (hf.inv.pow_apply_eq ha).trans ((dvd_neg _ _).trans int.coe_nat_dvd).symm }

lemma is_cycle_on.pow_apply_eq_pow_apply {s : finset α} (hf : f.is_cycle_on s) (ha : a ∈ s)
  {m n : ℕ} : (f ^ m) a = (f ^ n) a ↔ m ≡ n [MOD s.card] :=
begin
  rw [nat.modeq_iff_dvd, ←hf.zpow_apply_eq ha],
  simp [sub_eq_neg_add, zpow_add, eq_inv_iff_eq, eq_comm],
end

lemma is_cycle_on.zpow_apply_eq_zpow_apply {s : finset α} (hf : f.is_cycle_on s) (ha : a ∈ s)
  {m n : ℤ} : (f ^ m) a = (f ^ n) a ↔ m ≡ n [ZMOD s.card] :=
begin
  rw [int.modeq_iff_dvd, ←hf.zpow_apply_eq ha],
  simp [sub_eq_neg_add, zpow_add, eq_inv_iff_eq, eq_comm],
end

lemma is_cycle_on.pow_card_apply {s : finset α} (hf : f.is_cycle_on s) (ha : a ∈ s) :
  (f ^ s.card) a = a :=
(hf.pow_apply_eq ha).2 dvd_rfl

lemma is_cycle_on.exists_pow_eq {s : finset α} (hf : f.is_cycle_on s) (ha : a ∈ s) (hb : b ∈ s) :
  ∃ n < s.card, (f ^ n) a = b :=
begin
  classical,
  obtain ⟨n, rfl⟩ := hf.2 ha hb,
  obtain ⟨k, hk⟩ := (int.mod_modeq n s.card).symm.dvd,
  refine ⟨n.nat_mod s.card, int.nat_mod_lt (nonempty.card_pos ⟨a, ha⟩).ne', _⟩,
  rw [←zpow_coe_nat, int.nat_mod, int.to_nat_of_nonneg (int.mod_nonneg _ $ nat.cast_ne_zero.2
    (nonempty.card_pos ⟨a, ha⟩).ne'), sub_eq_iff_eq_add'.1 hk, zpow_add, zpow_mul],
  simp only [zpow_coe_nat, coe_mul, embedding_like.apply_eq_iff_eq],
  exact is_fixed_pt.perm_zpow (hf.pow_card_apply ha) _,
end

lemma is_cycle_on.exists_pow_eq' (hs : s.finite) (hf : f.is_cycle_on s) (ha : a ∈ s) (hb : b ∈ s) :
  ∃ n : ℕ, (f ^ n) a = b :=
by { lift s to finset α using id hs, obtain ⟨n, -, hn⟩ := hf.exists_pow_eq ha hb, exact ⟨n, hn⟩ }

lemma is_cycle_on.range_pow (hs : s.finite) (h : f.is_cycle_on s) (ha : a ∈ s) :
  set.range (λ n, (f ^ n) a : ℕ → α) = s :=
set.subset.antisymm (set.range_subset_iff.2 $ λ n, h.1.maps_to.perm_pow _ ha) $
  λ x, h.exists_pow_eq' hs ha

lemma is_cycle_on.range_zpow (h : f.is_cycle_on s) (ha : a ∈ s) :
  set.range (λ n, (f ^ n) a : ℤ → α) = s :=
set.subset.antisymm (set.range_subset_iff.2 $ λ n, (h.1.perm_zpow _).maps_to ha) $ h.2 ha

lemma is_cycle_on.of_pow {n : ℕ} (hf : (f ^ n).is_cycle_on s) (h : set.bij_on f s s) :
  f.is_cycle_on s :=
⟨h, λ x hx y hy, (hf.2 hx hy).of_pow⟩

lemma is_cycle_on.of_zpow {n : ℤ} (hf : (f ^ n).is_cycle_on s) (h : set.bij_on f s s) :
  f.is_cycle_on s :=
⟨h, λ x hx y hy, (hf.2 hx hy).of_zpow⟩

lemma is_cycle_on.extend_domain {p : β → Prop} [decidable_pred p] (f : α ≃ subtype p)
  (h : g.is_cycle_on s) :
  (g.extend_domain f).is_cycle_on (coe ∘ f '' s) :=
⟨h.1.extend_domain, by { rintro _ ⟨a, ha, rfl⟩ _ ⟨b, hb, rfl⟩, exact (h.2 ha hb).extend_domain }⟩

protected lemma is_cycle_on.countable (hs : f.is_cycle_on s) : s.countable :=
begin
  obtain rfl | ⟨a, ha⟩ := s.eq_empty_or_nonempty,
  { exact set.countable_empty },
  { exact (set.countable_range $ λ n : ℤ, (⇑(f ^ n) : α → α) a).mono (hs.2 ha) }
end

end is_cycle_on

/-!
### `cycle_of`
-/

section cycle_of
variables [decidable_eq α] [fintype α] {f g : perm α} {x y : α}

/-- `f.cycle_of x` is the cycle of the permutation `f` to which `x` belongs. -/
def cycle_of (f : perm α) (x : α) : perm α :=
of_subtype (subtype_perm f (λ _, same_cycle_apply_right.symm) : perm {y // same_cycle f x y})

lemma cycle_of_apply (f : perm α) (x y : α) :
  cycle_of f x y = if same_cycle f x y then f y else y :=
begin
  dsimp only [cycle_of],
  split_ifs,
  { apply of_subtype_apply_of_mem, exact h, },
  { apply of_subtype_apply_of_not_mem, exact h },
end

lemma cycle_of_inv (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_right] at *
end

@[simp] lemma cycle_of_pow_apply_self (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 (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 : same_cycle f x y → cycle_of f x y = f y :=
of_subtype_apply_of_mem _

lemma cycle_of_apply_of_not_same_cycle : ¬ same_cycle f x y → cycle_of f x y = y :=
of_subtype_apply_of_not_mem _

lemma same_cycle.cycle_of_eq (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 (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 (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 (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 (f : perm α) (x : α) : cycle_of f x x = f x :=
same_cycle.rfl.cycle_of_apply

lemma is_cycle.cycle_of_eq (hf : is_cycle f) (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 ((is_cycle_iff_same_cycle hx).1 hf).2 h)]

@[simp] lemma cycle_of_eq_one_iff (f : perm α) : 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 (f : perm α) (x : α) : cycle_of f (f x) = cycle_of f x :=
(same_cycle_apply_right.2 same_cycle.rfl).symm.cycle_of_eq

@[simp] lemma cycle_of_self_apply_pow (f : perm α) (n : ℕ) (x : α) :
  cycle_of f ((f ^ n) x) = cycle_of f x :=
same_cycle.rfl.pow_left.cycle_of_eq

@[simp] lemma cycle_of_self_apply_zpow (f : perm α) (n : ℤ) (x : α) :
  cycle_of f ((f ^ n) x) = cycle_of f x :=
same_cycle.rfl.zpow_left.cycle_of_eq

protected lemma is_cycle.cycle_of (hf : is_cycle f) : 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 (x : α) : cycle_of 1 x = 1 := (cycle_of_eq_one_iff 1).mpr rfl

lemma is_cycle_cycle_of (f : perm α) (hx : f x ≠ x) : is_cycle (cycle_of f x) :=
have cycle_of f x x ≠ x, by rwa [same_cycle.rfl.cycle_of_apply],
(is_cycle_iff_same_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 : 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 : 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 (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 (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 (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 : (f.cycle_of x).support = ∅ ↔ x ∉ f.support := by simp

lemma support_cycle_of_le (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 : 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 mem_support_cycle_of_iff' (hx : f x ≠ x) : y ∈ support (f.cycle_of x) ↔ same_cycle f x y :=
by rw [mem_support_cycle_of_iff, and_iff_left (mem_support.2 hx)]

lemma same_cycle.mem_support_iff (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 (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, ←(is_cycle_cycle_of f hx).order_of,
      ←pow_eq_mod_order_of] }
end

/-- `x` is in the support of `f` iff `equiv.perm.cycle_of f x` is a cycle. -/
lemma is_cycle_cycle_of_iff (f : perm α) : is_cycle (cycle_of f x) ↔ f x ≠ x :=
begin
  refine ⟨λ hx, _, f.is_cycle_cycle_of⟩,
  rw [ne.def, ←cycle_of_eq_one_iff f],
  exact hx.ne_one,
end

lemma is_cycle_on_support_cycle_of (f : perm α) (x : α) : f.is_cycle_on (f.cycle_of x).support :=
⟨f.bij_on $ by simp [mem_support_cycle_of_iff], λ a ha b hb,
  by { rw [mem_coe, mem_support_cycle_of_iff] at ha hb, exact ha.1.symm.trans hb.1 }⟩

lemma same_cycle.exists_pow_eq_of_mem_support (h : same_cycle f x y) (hx : x ∈ f.support) :
  ∃ (i : ℕ) (hi' : i < (f.cycle_of x).support.card), (f ^ i) x = y :=
begin
  rw mem_support at hx,
  refine (f.is_cycle_on_support_cycle_of _).exists_pow_eq _ _;
    rwa mem_support_cycle_of_iff' hx,
end

lemma same_cycle.exists_pow_eq (f : perm α) (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'⟩ := h.exists_pow_eq_of_mem_support 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 [←(is_cycle_cycle_of _ $ mem_support.1 hx).order_of,
            ←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

end cycle_of

/-!
### `cycle_factors`
-/

variables [decidable_eq α]

/-- 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_right],
            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*} [finite α] {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,
  casesI nonempty_fintype α,
  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*} [finite α] {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 : (s : set (perm α)).pairwise disjoint,
      s.noncomm_prod id (h.mono' $ λ _ _, disjoint.commute) = σ :=
begin
  obtain ⟨l, hl, rfl⟩ := s.exists_list_nodup_eq,
  simp [cycle_factors_finset_eq_list_to_finset, hl],
end

lemma cycle_factors_finset_pairwise_disjoint :
  (cycle_factors_finset f : set (perm α)).pairwise disjoint :=
(cycle_factors_finset_eq_finset.mp rfl).2.some

lemma cycle_factors_finset_mem_commute :
  (cycle_factors_finset f : set (perm α)).pairwise commute :=
(cycle_factors_finset_pairwise_disjoint _).mono' $ λ _ _, disjoint.commute

/-- The product of cycle factors is equal to the original `f : perm α`. -/
lemma cycle_factors_finset_noncomm_prod
  (comm : (cycle_factors_finset f : set (perm α)).pairwise commute :=
    cycle_factors_finset_mem_commute f) :
  f.cycle_factors_finset.noncomm_prod id comm = f :=
(cycle_factors_finset_eq_finset.mp rfl).2.some_spec

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,
  rw finset.disjoint_left,
  intros x hx hy,
  simp only [mem_cycle_factors_finset_iff, mem_support] at hx hy,
  obtain ⟨⟨⟨a, ha, -⟩, hf⟩, -, hg⟩ := ⟨hx, hy⟩,
  refine h.le_bot (_ : 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,
  refine ⟨_, _, _⟩,
  { simp [or_imp_distrib, mem_cycle_factors_finset_iff, forall_swap] },
  { rw [coe_union, set.pairwise_union_of_symmetric disjoint.symmetric],
    exact ⟨cycle_factors_finset_pairwise_disjoint _, cycle_factors_finset_pairwise_disjoint _,
      λ x hx y hy hxy, h.mono (mem_cycle_factors_finset_support_le hx)
        (mem_cycle_factors_finset_support_le hy)⟩ },
  { 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 [finite β] (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
  casesI nonempty_fintype β,
  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.le_bot (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.le_bot (mem_inter_of_mem H hf) } } }
end

section generation

variables [finite β]

open subgroup

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

variables [fintype α]

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),
      simp_rw [mul_swap_eq_swap_mul, mul_inv_cancel_right, pow_succ], 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, ←h1.order_of] 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) := h1'.of_pow
    (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, ←h1.order_of,
    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 $ by rw [hσ.order_of, h, hτ.order_of]).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*} [finite α] {σ τ π ρ : perm α}
  (hc1 : is_conj σ π) (hc2 : is_conj τ ρ)
  (hd1 : disjoint σ τ) (hd2 : disjoint π ρ) :
  is_conj (σ * τ) (π * ρ) :=
begin
  classical,
  casesI nonempty_fintype α,
  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_coe.2 (disjoint_iff_disjoint_support.1 hd1),
  have hd2'' := disjoint_coe.2 (disjoint_iff_disjoint_support.1 hd2),
  refine is_conj_of_support_equiv _ _,
  { refine ((equiv.set.of_eq hd1').trans (equiv.set.union hd1''.le_bot)).trans
      ((equiv.sum_congr (subtype_equiv f (λ a, _)) (subtype_equiv g (λ a, _))).trans
      ((equiv.set.of_eq hd2').trans (equiv.set.union hd2''.le_bot)).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''.le_bot _, set.union_apply_left hd1''.le_bot _],
      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''.le_bot _, set.union_apply_right hd1''.le_bot _],
      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

open equiv

namespace list
variables [decidable_eq α] {l : list α}

lemma nodup.is_cycle_on_form_perm (h : l.nodup) : l.form_perm.is_cycle_on {a | a ∈ l} :=
begin
  refine ⟨l.form_perm.bij_on (λ _, form_perm_mem_iff_mem), λ a ha b hb, _⟩,
  rw [set.mem_set_of, ←index_of_lt_length] at ha hb,
  rw [←index_of_nth_le ha, ←index_of_nth_le hb],
  refine ⟨l.index_of b - l.index_of a, _⟩,
  simp only [sub_eq_neg_add, zpow_add, zpow_neg, equiv.perm.inv_eq_iff_eq, zpow_coe_nat,
    equiv.perm.coe_mul, form_perm_pow_apply_nth_le _ h],
  rw add_comm,
end

end list

namespace int
open equiv

lemma add_left_one_is_cycle : (equiv.add_left 1 : perm ℤ).is_cycle :=
⟨0, one_ne_zero, λ n _, ⟨n, by simp⟩⟩

lemma add_right_one_is_cycle : (equiv.add_right 1 : perm ℤ).is_cycle :=
⟨0, one_ne_zero, λ n _, ⟨n, by simp⟩⟩

end int

namespace finset
variables [decidable_eq α] [fintype α]

lemma exists_cycle_on (s : finset α) : ∃ f : perm α, f.is_cycle_on s ∧ f.support ⊆ s :=
begin
  refine ⟨s.to_list.form_perm, _,
    λ x hx, by simpa using list.mem_of_form_perm_apply_ne _ _ (perm.mem_support.1 hx)⟩,
  convert s.nodup_to_list.is_cycle_on_form_perm,
  simp,
end

end finset

namespace set
variables {f : perm α} {s : set α}

lemma countable.exists_cycle_on (hs : s.countable) :
  ∃ f : perm α, f.is_cycle_on s ∧ {x | f x ≠ x} ⊆ s :=
begin
  classical,
  obtain hs' | hs' := s.finite_or_infinite,
  { refine ⟨hs'.to_finset.to_list.form_perm, _,
      λ x hx, by simpa using list.mem_of_form_perm_apply_ne _ _ hx⟩,
    convert hs'.to_finset.nodup_to_list.is_cycle_on_form_perm,
    simp },
  haveI := hs.to_subtype,
  haveI := hs'.to_subtype,
  obtain ⟨f⟩ : nonempty (ℤ ≃ s) := infer_instance,
  refine ⟨(equiv.add_right 1).extend_domain f, _, λ x hx, of_not_not $ λ h, hx $
    perm.extend_domain_apply_not_subtype _ _ h⟩,
  convert int.add_right_one_is_cycle.is_cycle_on.extend_domain _,
  rw [image_comp, equiv.image_eq_preimage],
  ext,
  simp,
end

lemma prod_self_eq_Union_perm (hf : f.is_cycle_on s) :
  s ×ˢ s = ⋃ n : ℤ, (λ a, (a, (f ^ n) a)) '' s :=
begin
  ext ⟨a, b⟩,
  simp only [mem_prod, mem_Union, mem_image],
  refine ⟨λ hx, _, _⟩,
  { obtain ⟨n, rfl⟩ := hf.2 hx.1 hx.2,
    exact ⟨_, _, hx.1, rfl⟩ },
  { rintro ⟨n, a, ha, ⟨⟩⟩,
    exact ⟨ha, (hf.1.perm_zpow _).maps_to ha⟩ }
end

end set

namespace finset
variables {f : perm α} {s : finset α}

lemma product_self_eq_disj_Union_perm_aux (hf : f.is_cycle_on s) :
  (range s.card : set ℕ).pairwise_disjoint
    (λ k, s.map ⟨λ i, (i, (f ^ k) i), λ i j, congr_arg prod.fst⟩) :=
begin
  obtain hs | hs := (s : set α).subsingleton_or_nontrivial,
  { refine set.subsingleton.pairwise _ _,
    simp_rw [set.subsingleton, mem_coe, ←card_le_one] at ⊢ hs,
    rwa card_range },
  classical,
  rintro m hm n hn hmn,
  simp only [disjoint_left, function.on_fun, mem_map, function.embedding.coe_fn_mk, exists_prop,
    not_exists, not_and, forall_exists_index, and_imp, prod.forall, prod.mk.inj_iff],
  rintro _ _ _ - rfl rfl a ha rfl h,
  rw [hf.pow_apply_eq_pow_apply ha] at h,
  rw [mem_coe, mem_range] at hm hn,
  exact hmn.symm (h.eq_of_lt_of_lt hn hm),
end

/--
We can partition the square `s ×ˢ s` into shifted diagonals as such:
```
01234
40123
34012
23401
12340
```

The diagonals are given by the cycle `f`.
-/
lemma product_self_eq_disj_Union_perm (hf : f.is_cycle_on s) :
  s ×ˢ s =
    (range s.card).disj_Union (λ k, s.map ⟨λ i, (i, (f ^ k) i), λ i j, congr_arg prod.fst⟩)
      (product_self_eq_disj_Union_perm_aux hf) :=
begin
  ext ⟨a, b⟩,
  simp only [mem_product, equiv.perm.coe_pow, mem_disj_Union, mem_range, mem_map,
    function.embedding.coe_fn_mk, prod.mk.inj_iff, exists_prop],
  refine ⟨λ hx, _, _⟩,
  { obtain ⟨n, hn, rfl⟩ := hf.exists_pow_eq hx.1 hx.2,
    exact ⟨n, hn, a, hx.1, rfl, by rw f.iterate_eq_pow⟩ },
  { rintro ⟨n, -, a, ha, rfl, rfl⟩,
    exact ⟨ha, (hf.1.iterate _).maps_to ha⟩ }
end

end finset

namespace finset
variables [semiring α] [add_comm_monoid β] [module α β] {s : finset ι} {σ : perm ι}

lemma sum_smul_sum_eq_sum_perm (hσ : σ.is_cycle_on s) (f : ι → α) (g : ι → β) :
  (∑ i in s, f i) • ∑ i in s, g i = ∑ k in range s.card, ∑ i in s, f i • g ((σ ^ k) i) :=
by { simp_rw [sum_smul_sum, product_self_eq_disj_Union_perm hσ, sum_disj_Union, sum_map], refl }

lemma sum_mul_sum_eq_sum_perm (hσ : σ.is_cycle_on s) (f g : ι → α) :
  (∑ i in s, f i) * ∑ i in s, g i = ∑ k in range s.card, ∑ i in s, f i * g ((σ ^ k) i) :=
sum_smul_sum_eq_sum_perm hσ f g

end finset