/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Yury Kudryashov
-/
import algebra.order.archimedean
import order.filter.at_top_bot

/-!
# `at_top` filter and archimedean (semi)rings/fields

In this file we prove that for a linear ordered archimedean semiring `R` and a function `f : α → ℕ`,
the function `coe ∘ f : α → R` tends to `at_top` along a filter `l` if and only if so does `f`.
We also prove that `coe : ℕ → R` tends to `at_top` along `at_top`, as well as version of these
two results for `ℤ` (and a ring `R`) and `ℚ` (and a field `R`).
-/

variables {α R : Type*}

open filter set

@[simp] lemma nat.comap_coe_at_top [ordered_semiring R] [nontrivial R] [archimedean R] :
  comap (coe : ℕ → R) at_top = at_top :=
comap_embedding_at_top (λ _ _, nat.cast_le) exists_nat_ge

lemma tendsto_coe_nat_at_top_iff [ordered_semiring R] [nontrivial R] [archimedean R]
  {f : α → ℕ} {l : filter α} :
  tendsto (λ n, (f n : R)) l at_top ↔ tendsto f l at_top :=
tendsto_at_top_embedding (assume a₁ a₂, nat.cast_le) exists_nat_ge

lemma tendsto_coe_nat_at_top_at_top [ordered_semiring R] [archimedean R] :
  tendsto (coe : ℕ → R) at_top at_top :=
nat.mono_cast.tendsto_at_top_at_top exists_nat_ge

@[simp] lemma int.comap_coe_at_top [ordered_ring R] [nontrivial R] [archimedean R] :
  comap (coe : ℤ → R) at_top = at_top :=
comap_embedding_at_top (λ _ _, int.cast_le) $ λ r,
  let ⟨n, hn⟩ := exists_nat_ge r in ⟨n, by exact_mod_cast hn⟩

@[simp] lemma int.comap_coe_at_bot [ordered_ring R] [nontrivial R] [archimedean R] :
  comap (coe : ℤ → R) at_bot = at_bot :=
comap_embedding_at_bot (λ _ _, int.cast_le) $ λ r,
  let ⟨n, hn⟩ := exists_nat_ge (-r) in ⟨-n, by simpa [neg_le] using hn⟩

lemma tendsto_coe_int_at_top_iff [ordered_ring R] [nontrivial R] [archimedean R]
  {f : α → ℤ} {l : filter α} :
  tendsto (λ n, (f n : R)) l at_top ↔ tendsto f l at_top :=
by rw [← tendsto_comap_iff, int.comap_coe_at_top]

lemma tendsto_coe_int_at_bot_iff [ordered_ring R] [nontrivial R] [archimedean R]
  {f : α → ℤ} {l : filter α} :
  tendsto (λ n, (f n : R)) l at_bot ↔ tendsto f l at_bot :=
by rw [← tendsto_comap_iff, int.comap_coe_at_bot]

lemma tendsto_coe_int_at_top_at_top [ordered_ring R] [archimedean R] :
  tendsto (coe : ℤ → R) at_top at_top :=
int.cast_mono.tendsto_at_top_at_top $ λ b,
  let ⟨n, hn⟩ := exists_nat_ge b in ⟨n, by exact_mod_cast hn⟩

@[simp] lemma rat.comap_coe_at_top [linear_ordered_field R] [archimedean R] :
  comap (coe : ℚ → R) at_top = at_top :=
comap_embedding_at_top (λ _ _, rat.cast_le) $ λ r, let ⟨n, hn⟩ := exists_nat_ge r in ⟨n, by simpa⟩

@[simp] lemma rat.comap_coe_at_bot [linear_ordered_field R] [archimedean R] :
  comap (coe : ℚ → R) at_bot = at_bot :=
comap_embedding_at_bot (λ _ _, rat.cast_le) $ λ r, let ⟨n, hn⟩ := exists_nat_ge (-r)
  in ⟨-n, by simpa [neg_le]⟩

lemma tendsto_coe_rat_at_top_iff [linear_ordered_field R] [archimedean R]
  {f : α → ℚ} {l : filter α} :
  tendsto (λ n, (f n : R)) l at_top ↔ tendsto f l at_top :=
by rw [← tendsto_comap_iff, rat.comap_coe_at_top]

lemma tendsto_coe_rat_at_bot_iff [linear_ordered_field R] [archimedean R]
  {f : α → ℚ} {l : filter α} :
  tendsto (λ n, (f n : R)) l at_bot ↔ tendsto f l at_bot :=
by rw [← tendsto_comap_iff, rat.comap_coe_at_bot]

lemma at_top_countable_basis_of_archimedean [linear_ordered_semiring R] [archimedean R] :
  (at_top : filter R).has_countable_basis (λ n : ℕ, true) (λ n, Ici n) :=
{ countable := countable_encodable _,
  to_has_basis := at_top_basis.to_has_basis
    (λ x hx, let ⟨n, hn⟩ := exists_nat_ge x in ⟨n, trivial, Ici_subset_Ici.2 hn⟩)
    (λ n hn, ⟨n, trivial, subset.rfl⟩) }

lemma at_bot_countable_basis_of_archimedean [linear_ordered_ring R] [archimedean R] :
  (at_bot : filter R).has_countable_basis (λ m : ℤ, true) (λ m, Iic m) :=
{ countable := countable_encodable _,
  to_has_basis := at_bot_basis.to_has_basis
    (λ x hx, let ⟨m, hm⟩ := exists_int_lt x in ⟨m, trivial, Iic_subset_Iic.2 hm.le⟩)
    (λ m hm, ⟨m, trivial, subset.rfl⟩) }

@[priority 100]
instance at_top_countably_generated_of_archimedean [linear_ordered_semiring R] [archimedean R] :
  (at_top : filter R).is_countably_generated :=
at_top_countable_basis_of_archimedean.is_countably_generated

@[priority 100]
instance at_bot_countably_generated_of_archimedean [linear_ordered_ring R] [archimedean R] :
  (at_bot : filter R).is_countably_generated :=
at_bot_countable_basis_of_archimedean.is_countably_generated

namespace filter

variables {l : filter α} {f : α → R} {r : R}

section linear_ordered_semiring

variables [linear_ordered_semiring R] [archimedean R]

/-- If a function tends to infinity along a filter, then this function multiplied by a positive
constant (on the left) also tends to infinity. The archimedean assumption is convenient to get a
statement that works on `ℕ`, `ℤ` and `ℝ`, although not necessary (a version in ordered fields is
given in `filter.tendsto.const_mul_at_top`). -/
lemma tendsto.const_mul_at_top' (hr : 0 < r) (hf : tendsto f l at_top) :
  tendsto (λx, r * f x) l at_top :=
begin
  apply tendsto_at_top.2 (λb, _),
  obtain ⟨n : ℕ, hn : 1 ≤ n • r⟩ := archimedean.arch 1 hr,
  rw nsmul_eq_mul' at hn,
  filter_upwards [tendsto_at_top.1 hf (n * max b 0)] with x hx,
  calc b ≤ 1 * max b 0 : by { rw [one_mul], exact le_max_left _ _ }
  ... ≤ (r * n) * max b 0 : mul_le_mul_of_nonneg_right hn (le_max_right _ _)
  ... = r * (n * max b 0) : by rw [mul_assoc]
  ... ≤ r * f x : mul_le_mul_of_nonneg_left hx (le_of_lt hr)
end

/-- If a function tends to infinity along a filter, then this function multiplied by a positive
constant (on the right) also tends to infinity. The archimedean assumption is convenient to get a
statement that works on `ℕ`, `ℤ` and `ℝ`, although not necessary (a version in ordered fields is
given in `filter.tendsto.at_top_mul_const`). -/
lemma tendsto.at_top_mul_const' (hr : 0 < r) (hf : tendsto f l at_top) :
  tendsto (λx, f x * r) l at_top :=
begin
  apply tendsto_at_top.2 (λb, _),
  obtain ⟨n : ℕ, hn : 1 ≤ n • r⟩ := archimedean.arch 1 hr,
  have hn' : 1 ≤ (n : R) * r, by rwa nsmul_eq_mul at hn,
  filter_upwards [tendsto_at_top.1 hf (max b 0 * n)] with x hx,
  calc b ≤ max b 0 * 1 : by { rw [mul_one], exact le_max_left _ _ }
  ... ≤ max b 0 * (n * r) : mul_le_mul_of_nonneg_left hn' (le_max_right _ _)
  ... = (max b 0 * n) * r : by rw [mul_assoc]
  ... ≤ f x * r : mul_le_mul_of_nonneg_right hx (le_of_lt hr)
end

end linear_ordered_semiring

section linear_ordered_ring

variables [linear_ordered_ring R] [archimedean R]

/-- See also `filter.tendsto.at_top_mul_neg_const` for a version of this lemma for
`linear_ordered_field`s which does not require the `archimedean` assumption. -/
lemma tendsto.at_top_mul_neg_const' (hr : r < 0) (hf : tendsto f l at_top) :
  tendsto (λx, f x * r) l at_bot :=
begin
  have h : (λ x, f x * -r) = -λ x, f x * r, { ext, simp, },
  rw tendsto_at_bot_iff_tends_to_neg_at_top,
  exact h ▸ tendsto.at_top_mul_const' (neg_pos.mpr hr) hf,
end

/-- See also `filter.tendsto.at_bot_mul_const` for a version of this lemma for
`linear_ordered_field`s which does not require the `archimedean` assumption. -/
lemma tendsto.at_bot_mul_const' (hr : 0 < r) (hf : tendsto f l at_bot) :
  tendsto (λx, f x * r) l at_bot :=
begin
  have h : (λ x, (-f) x * r) = -λ x, f x * r, { ext, simp, },
  rw tendsto_at_bot_iff_tends_to_neg_at_top at hf ⊢,
  exact h ▸  tendsto.at_top_mul_const' hr hf,
end

/-- See also `filter.tendsto.at_bot_mul_neg_const` for a version of this lemma for
`linear_ordered_field`s which does not require the `archimedean` assumption. -/
lemma tendsto.at_bot_mul_neg_const' (hr : r < 0) (hf : tendsto f l at_bot) :
  tendsto (λx, f x * r) l at_top :=
begin
  have h : (λ x, (-f) x * r) = -λ x, f x * r, { ext, simp, },
  rw tendsto_at_bot_iff_tends_to_neg_at_top at hf,
  rw tendsto_at_top_iff_tends_to_neg_at_bot,
  exact h ▸ tendsto.at_top_mul_neg_const' hr hf,
end

end linear_ordered_ring

section linear_ordered_cancel_add_comm_monoid

variables [linear_ordered_cancel_add_comm_monoid R] [archimedean R]

lemma tendsto.at_top_nsmul_const {f : α → ℕ} (hr : 0 < r) (hf : tendsto f l at_top) :
  tendsto (λ x, f x • r) l at_top :=
begin
  refine tendsto_at_top.mpr (λ s, _),
  obtain ⟨n : ℕ, hn : s ≤ n • r⟩ := archimedean.arch s hr,
  exact (tendsto_at_top.mp hf n).mono (λ a ha, hn.trans (nsmul_le_nsmul hr.le ha)),
end

end linear_ordered_cancel_add_comm_monoid

section linear_ordered_add_comm_group

variables [linear_ordered_add_comm_group R] [archimedean R]

lemma tendsto.at_top_nsmul_neg_const {f : α → ℕ} (hr : r < 0) (hf : tendsto f l at_top) :
  tendsto (λ x, f x • r) l at_bot :=
begin
  have h : (λ x, f x • -r) = -λ x, f x • r, { ext, simp, },
  rw tendsto_at_bot_iff_tends_to_neg_at_top,
  exact h ▸ tendsto.at_top_nsmul_const (neg_pos.mpr hr) hf,
end

lemma tendsto.at_top_zsmul_const {f : α → ℤ} (hr : 0 < r) (hf : tendsto f l at_top) :
  tendsto (λ x, f x • r) l at_top :=
begin
  refine tendsto_at_top.mpr (λ s, _),
  obtain ⟨n : ℕ, hn : s ≤ n • r⟩ := archimedean.arch s hr,
  replace hn : s ≤ (n : ℤ) • r, { simpa, },
  exact (tendsto_at_top.mp hf n).mono (λ a ha, hn.trans (zsmul_le_zsmul hr.le ha)),
end

lemma tendsto.at_top_zsmul_neg_const {f : α → ℤ} (hr : r < 0) (hf : tendsto f l at_top) :
  tendsto (λ x, f x • r) l at_bot :=
begin
  have h : (λ x, f x • -r) = -λ x, f x • r, { ext, simp [zsmul_neg], },
  rw tendsto_at_bot_iff_tends_to_neg_at_top,
  exact h ▸ tendsto.at_top_zsmul_const (neg_pos.mpr hr) hf,
end

lemma tendsto.at_bot_zsmul_const {f : α → ℤ} (hr : 0 < r) (hf : tendsto f l at_bot) :
  tendsto (λ x, f x • r) l at_bot :=
begin
  have h : (λ x, (-f) x • r) = -λ x, f x • r, { ext, simp, },
  rw tendsto_at_bot_iff_tends_to_neg_at_top at hf ⊢,
  exact h ▸ tendsto.at_top_zsmul_const hr hf,
end

lemma tendsto.at_bot_zsmul_neg_const {f : α → ℤ} (hr : r < 0) (hf : tendsto f l at_bot) :
  tendsto (λ x, f x • r) l at_top :=
begin
  have h : (λ x, (-f) x • r) = -λ x, f x • r, { ext, simp, },
  rw tendsto_at_bot_iff_tends_to_neg_at_top at hf,
  rw tendsto_at_top_iff_tends_to_neg_at_bot,
  exact h ▸ tendsto.at_top_zsmul_neg_const hr hf,
end

end linear_ordered_add_comm_group

end filter


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Reid Barton

! This file was ported from Lean 3 source module category_theory.limits.types
! leanprover-community/mathlib commit 4aa2a2e17940311e47007f087c9df229e7f12942
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Shapes.Images
import Mathlib.CategoryTheory.Filtered

/-!
# Limits in the category of types.

We show that the category of types has all (co)limits, by providing the usual concrete models.

We also give a characterisation of filtered colimits in `Type`, via
`colimit.ι F i xi = colimit.ι F j xj ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj`.

Finally, we prove the category of types has categorical images,
and that these agree with the range of a function.
-/

universe v u

open CategoryTheory

open CategoryTheory.Limits

namespace CategoryTheory.Limits.Types

variable {J : Type v} [SmallCategory J]

/-- (internal implementation) the limit cone of a functor,
implemented as flat sections of a pi type
-/
def limitCone (F : J ⥤ Type max v u) : Cone F
    where
  pt := F.sections
  π :=
    { app := fun j u => u.val j
      naturality := fun j j' f => by
        funext x
        simp }
#align category_theory.limits.types.limit_cone CategoryTheory.Limits.Types.limitCone

--attribute [local elab_without_expected_type] congr_fun

/-- (internal implementation) the fact that the proposed limit cone is the limit -/
def limitConeIsLimit (F : J ⥤ Type max v u) : IsLimit (limitCone.{v, u} F) where
  lift s v :=
  { val := fun j => s.π.app j v
    property := fun f => congr_fun (Cone.w s f) _ }
  uniq := fun _ _ w => by
    funext x
    apply Subtype.ext
    funext j
    exact congr_fun (w j) x
#align category_theory.limits.types.limit_cone_is_limit CategoryTheory.Limits.Types.limitConeIsLimit

/-- The category of types has all limits.

See <https://stacks.math.columbia.edu/tag/002U>.
-/
instance hasLimitsOfSize : HasLimitsOfSize.{v} (Type max v u)
    where has_limits_of_shape _ := --J 𝒥 :=
    { has_limit := fun F =>
        HasLimit.mk
          { cone := limitCone.{v, u} F
            isLimit := limitConeIsLimit F } }
#align category_theory.limits.types.has_limits_of_size CategoryTheory.Limits.Types.hasLimitsOfSize

instance : HasLimits (Type u) :=
  Types.hasLimitsOfSize.{u, u}

instance hasLimit (F : J ⥤ Type max v u) : HasLimit F :=
  (Types.hasLimitsOfSize.{v, u}.has_limits_of_shape J).has_limit F

instance hasLimit' (F : J ⥤ Type v) : HasLimit F :=
  hasLimit.{v, v} F

/-- The equivalence between a limiting cone of `F` in `Type u` and the "concrete" definition as the
sections of `F`.
-/
def isLimitEquivSections {F : J ⥤ Type max v u} {c : Cone F} (t : IsLimit c) : c.pt ≃ F.sections :=
  (IsLimit.conePointUniqueUpToIso t (limitConeIsLimit.{v, u} F)).toEquiv
#align category_theory.limits.types.is_limit_equiv_sections CategoryTheory.Limits.Types.isLimitEquivSections

@[simp]
theorem isLimitEquivSections_apply {F : J ⥤ Type max v u} {c : Cone F} (t : IsLimit c) (j : J)
    (x : c.pt) : ((isLimitEquivSections.{v, u} t) x : ∀ j, F.obj j) j = c.π.app j x :=
  rfl
#align category_theory.limits.types.is_limit_equiv_sections_apply CategoryTheory.Limits.Types.isLimitEquivSections_apply

@[simp]
theorem isLimitEquivSections_symm_apply {F : J ⥤ Type max v u} {c : Cone F} (t : IsLimit c)
    (x : F.sections) (j : J) :
    c.π.app j ((isLimitEquivSections.{v, u} t).symm x) = (x : ∀ j, F.obj j) j := by
  obtain ⟨x, rfl⟩ :=(isLimitEquivSections.{v, u} t).surjective x
  simp
#align category_theory.limits.types.is_limit_equiv_sections_symm_apply CategoryTheory.Limits.Types.isLimitEquivSections_symm_apply

-- porting note: many `haveI` have been introduced so that the `HasLimit F` instance is found
/-- The equivalence between the abstract limit of `F` in `Type max v u`
and the "concrete" definition as the sections of `F`.
-/
noncomputable def limitEquivSections (F : J ⥤ Type max v u) :
  (@limit _ _ _ _ F (hasLimit.{v, u} F) : Type max v u) ≃ F.sections :=
  haveI := hasLimit.{v, u} F; isLimitEquivSections.{v, u} (limit.isLimit F)
#align category_theory.limits.types.limit_equiv_sections CategoryTheory.Limits.Types.limitEquivSections

@[simp]
theorem limitEquivSections_apply (F : J ⥤ Type max v u)
  (x : haveI := hasLimit.{v, u} F; limit F) (j : J) :
    haveI := hasLimit.{v, u} F;
    ((limitEquivSections.{v, u} F) x : ∀ j, F.obj j) j = limit.π F j x :=
  rfl
#align category_theory.limits.types.limit_equiv_sections_apply CategoryTheory.Limits.Types.limitEquivSections_apply

@[simp]
theorem limitEquivSections_symm_apply (F : J ⥤ Type max v u) (x : F.sections) (j : J) :
    haveI := hasLimit.{v, u} F;
    limit.π F j ((limitEquivSections.{v, u} F).symm x) = (x : ∀ j, F.obj j) j :=
  isLimitEquivSections_symm_apply _ _ _
#align category_theory.limits.types.limit_equiv_sections_symm_apply CategoryTheory.Limits.Types.limitEquivSections_symm_apply

-- porting note : `limitEquivSections_symm_apply'` was removed because the linter
--   complains it is unnecessary
--@[simp]
--theorem limitEquivSections_symm_apply' (F : J ⥤ Type v) (x : F.sections) (j : J) :
--    haveI := hasLimit.{v, v} F;
--    limit.π F j ((limitEquivSections.{v, v} F).symm x) = (x : ∀ j, F.obj j) j :=
--  isLimitEquivSections_symm_apply _ _ _
--#align category_theory.limits.types.limit_equiv_sections_symm_apply' CategoryTheory.Limits.Types.limitEquivSections_symm_apply'

--porting note: removed @[ext]
/-- Construct a term of `limit F : Type u` from a family of terms `x : Π j, F.obj j`
which are "coherent": `∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j'`.
-/
noncomputable def Limit.mk (F : J ⥤ Type max v u) (x : ∀ j, F.obj j)
    (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') :
    haveI := hasLimit.{v, u} F; (limit F : Type max v u) :=
  (limitEquivSections.{v, u} F).symm ⟨x, h _ _⟩
#align category_theory.limits.types.limit.mk CategoryTheory.Limits.Types.Limit.mk

@[simp]
theorem Limit.π_mk (F : J ⥤ Type max v u) (x : ∀ j, F.obj j)
    (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') (j) :
      haveI := hasLimit.{v, u} F;
      limit.π F j (Limit.mk.{v, u} F x h) = x j := by
  dsimp [Limit.mk]
  simp
#align category_theory.limits.types.limit.π_mk CategoryTheory.Limits.Types.Limit.π_mk

-- porting note : `Limit.π_mk'` was removed because the linter complains it is unnecessary
--@[simp]
--theorem Limit.π_mk' (F : J ⥤ Type v) (x : ∀ j, F.obj j)
--    (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') (j) :
--    haveI := hasLimit.{v, v} F;
--    limit.π F j (Limit.mk.{v, v} F x h) = x j := by
--  dsimp [Limit.mk]
--  simp
--#align category_theory.limits.types.limit.π_mk' CategoryTheory.Limits.Types.Limit.π_mk'

-- PROJECT: prove this for concrete categories where the forgetful functor preserves limits
@[ext]
theorem limit_ext (F : J ⥤ Type max v u) (x y : (haveI := hasLimit.{v, u} F; limit F))
    (w : haveI := hasLimit.{v, u} F; ∀ j, limit.π F j x = limit.π F j y) :
    x = y := by
  apply (limitEquivSections.{v, u} F).injective
  ext j
  simp [w j]
#align category_theory.limits.types.limit_ext CategoryTheory.Limits.Types.limit_ext

@[ext]
theorem limit_ext' (F : J ⥤ Type v) (x y : (haveI := hasLimit.{v, v} F; limit F))
  (w : haveI := hasLimit.{v, v} F; ∀ j, limit.π F j x = limit.π F j y) :
    x = y := limit_ext.{v, v} F x y w
#align category_theory.limits.types.limit_ext' CategoryTheory.Limits.Types.limit_ext'

theorem limit_ext_iff (F : J ⥤ Type max v u) (x y : (haveI := hasLimit.{v, u} F; limit F)) :
    x = y ↔ haveI := hasLimit.{v, u} F; ∀ j, limit.π F j x = limit.π F j y :=
  ⟨fun t _ => t ▸ rfl, limit_ext.{v, u} _ _ _⟩
#align category_theory.limits.types.limit_ext_iff CategoryTheory.Limits.Types.limit_ext_iff

theorem limit_ext_iff' (F : J ⥤ Type v) (x y : (haveI := hasLimit.{v, v} F; limit F)) :
    x = y ↔ haveI := hasLimit.{v, v} F; ∀ j, limit.π F j x = limit.π F j y :=
  ⟨fun t _ => t ▸ rfl, limit_ext'.{v} _ _ _⟩
#align category_theory.limits.types.limit_ext_iff' CategoryTheory.Limits.Types.limit_ext_iff'

-- TODO: are there other limits lemmas that should have `_apply` versions?
-- Can we generate these like with `@[reassoc]`?
-- PROJECT: prove these for any concrete category where the forgetful functor preserves limits?
--porting note: @[simp] was removed because the linter said it was useless
--@[simp]
theorem Limit.w_apply {F : J ⥤ Type max v u} {j j' : J}
  {x : haveI := hasLimit.{v, u} F; limit F} (f : j ⟶ j') :
  haveI := hasLimit.{v, u} F; F.map f (limit.π F j x) = limit.π F j' x :=
  haveI := hasLimit.{v, u} F; congr_fun (limit.w F f) x
#align category_theory.limits.types.limit.w_apply CategoryTheory.Limits.Types.Limit.w_apply

--porting note: @[simp] was removed because the linter said it was useless
theorem Limit.lift_π_apply (F : J ⥤ Type max v u) (s : Cone F) (j : J) (x : s.pt) :
    haveI := hasLimit.{v, u} F;
    limit.π F j (limit.lift F s x) = s.π.app j x :=
  haveI := hasLimit.{v, u} F; congr_fun (limit.lift_π s j) x
#align category_theory.limits.types.limit.lift_π_apply CategoryTheory.Limits.Types.Limit.lift_π_apply

--porting note: @[simp] was removed because the linter said it was useless
theorem Limit.map_π_apply {F G : J ⥤ Type max v u} (α : F ⟶ G) (j : J)
  (x : haveI := hasLimit.{v, u} F; limit F) :
    haveI := hasLimit.{v, u} F;
    haveI := hasLimit.{v, u} G;
    limit.π G j (limMap α x) = α.app j (limit.π F j x) :=
  haveI := hasLimit.{v, u} F;
  haveI := hasLimit.{v, u} G;
  congr_fun (limMap_π α j) x
#align category_theory.limits.types.limit.map_π_apply CategoryTheory.Limits.Types.Limit.map_π_apply

@[simp]
theorem Limit.w_apply' {F : J ⥤ Type v} {j j' : J} {x : haveI := hasLimit.{v, v} F; limit F}
  (f : j ⟶ j') :
    haveI := hasLimit.{v, v} F; F.map f (limit.π F j x) = limit.π F j' x :=
  haveI := hasLimit.{v, v} F; congr_fun (limit.w F f) x
#align category_theory.limits.types.limit.w_apply' CategoryTheory.Limits.Types.Limit.w_apply'

@[simp]
theorem Limit.lift_π_apply' (F : J ⥤ Type v) (s : Cone F) (j : J) (x : s.pt) :
    haveI := hasLimit.{v, v} F; limit.π F j (limit.lift F s x) = s.π.app j x :=
  haveI := hasLimit.{v, v} F; congr_fun (limit.lift_π s j) x
#align category_theory.limits.types.limit.lift_π_apply' CategoryTheory.Limits.Types.Limit.lift_π_apply'

@[simp]
theorem Limit.map_π_apply' {F G : J ⥤ Type v} (α : F ⟶ G) (j : J)
  (x : haveI := hasLimit.{v, v} F; limit F) :
    haveI := hasLimit.{v, v} F;
    haveI := hasLimit.{v, v} G;
    limit.π G j (limMap α x) = α.app j (limit.π F j x) :=
  haveI := hasLimit.{v, v} F;
  haveI := hasLimit.{v, v} G;
  congr_fun (limMap_π α j) x
#align category_theory.limits.types.limit.map_π_apply' CategoryTheory.Limits.Types.Limit.map_π_apply'

/--
The relation defining the quotient type which implements the colimit of a functor `F : J ⥤ Type u`.
See `category_theory.limits.types.quot`.
-/
def Quot.Rel (F : J ⥤ Type max v u) : (Σ j, F.obj j) → (Σ j, F.obj j) → Prop := fun p p' =>
  ∃ f : p.1 ⟶ p'.1, p'.2 = F.map f p.2
#align category_theory.limits.types.quot.rel CategoryTheory.Limits.Types.Quot.Rel

-- porting note: removed @[nolint has_nonempty_instance]
/-- A quotient type implementing the colimit of a functor `F : J ⥤ Type u`,
as pairs `⟨j, x⟩` where `x : F.obj j`, modulo the equivalence relation generated by
`⟨j, x⟩ ~ ⟨j', x'⟩` whenever there is a morphism `f : j ⟶ j'` so `F.map f x = x'`.
-/
def Quot (F : J ⥤ Type max v u) : Type max v u :=
  _root_.Quot (Quot.Rel.{v, u} F)
#align category_theory.limits.types.quot CategoryTheory.Limits.Types.Quot

/-- (internal implementation) the colimit cocone of a functor,
implemented as a quotient of a sigma type
-/
def colimitCocone (F : J ⥤ Type max v u) : Cocone F
    where
  pt := Quot.{v, u} F
  ι :=
    { app := fun j x => Quot.mk _ ⟨j, x⟩
      naturality := fun _ _ f => funext fun _ => Eq.symm (Quot.sound ⟨f, rfl⟩) }
#align category_theory.limits.types.colimit_cocone CategoryTheory.Limits.Types.colimitCocone

--attribute [local elab_with_expected_type] Quot.lift

/-- (internal implementation) the fact that the proposed colimit cocone is the colimit -/
def colimitCoconeIsColimit (F : J ⥤ Type max v u) : IsColimit (colimitCocone.{v, u} F) where
  desc s :=
    Quot.lift (fun p : Σj, F.obj j => s.ι.app p.1 p.2) fun ⟨j, x⟩ ⟨j', x'⟩ ⟨f, hf⟩ => by
      dsimp at hf
      rw [hf]
      exact (congr_fun (Cocone.w s f) x).symm
  uniq s m hm := by
    funext x
    induction' x using Quot.ind with x
    exact congr_fun (hm x.1) x.2
#align category_theory.limits.types.colimit_cocone_is_colimit CategoryTheory.Limits.Types.colimitCoconeIsColimit

/-- The category of types has all colimits.

See <https://stacks.math.columbia.edu/tag/002U>.
-/
instance hasColimitsOfSize : HasColimitsOfSize.{v} (Type max v u)
    where has_colimits_of_shape _ :=
    {
      has_colimit := fun F =>
        HasColimit.mk
          { cocone := colimitCocone.{v, u} F
            isColimit := colimitCoconeIsColimit F } }
#align category_theory.limits.types.has_colimits_of_size CategoryTheory.Limits.Types.hasColimitsOfSize

instance : HasColimits (Type u) :=
  Types.hasColimitsOfSize.{u, u}

instance hasColimit (F : J ⥤ Type max v u) : HasColimit F :=
  (Types.hasColimitsOfSize.{v, u}.has_colimits_of_shape J).has_colimit F

instance hasColimit' (F : J ⥤ Type max v) : HasColimit F :=
  hasColimit.{v, v} F

/-- The equivalence between the abstract colimit of `F` in `Type u`
and the "concrete" definition as a quotient.
-/
noncomputable def colimitEquivQuot (F : J ⥤ Type max v u) :
  haveI := hasColimit.{v, u} F; colimit F ≃ Quot.{v, u} F :=
  haveI := hasColimit.{v, u} F;
  (IsColimit.coconePointUniqueUpToIso (colimit.isColimit F) (colimitCoconeIsColimit F)).toEquiv
#align category_theory.limits.types.colimit_equiv_quot CategoryTheory.Limits.Types.colimitEquivQuot

@[simp]
theorem colimitEquivQuot_symm_apply (F : J ⥤ Type max v u) (j : J) (x : F.obj j) :
    haveI := hasColimit.{v, u} F;
    (colimitEquivQuot.{v, u} F).symm (Quot.mk _ ⟨j, x⟩) = colimit.ι F j x :=
  rfl
#align category_theory.limits.types.colimit_equiv_quot_symm_apply CategoryTheory.Limits.Types.colimitEquivQuot_symm_apply

@[simp]
theorem colimitEquivQuot_apply (F : J ⥤ Type max v u) (j : J) (x : F.obj j) :
    haveI := hasColimit.{v, u} F;
    (colimitEquivQuot.{v, u} F) (colimit.ι F j x) = Quot.mk _ ⟨j, x⟩ := by
  apply (colimitEquivQuot F).symm.injective
  simp
#align category_theory.limits.types.colimit_equiv_quot_apply CategoryTheory.Limits.Types.colimitEquivQuot_apply

--porting note: @[simp] was removed because the linter said it was useless
theorem Colimit.w_apply {F : J ⥤ Type max v u} {j j' : J} {x : F.obj j} (f : j ⟶ j') :
    haveI := hasColimit.{v, u} F;
    colimit.ι F j' (F.map f x) = colimit.ι F j x :=
  haveI := hasColimit.{v, u} F; congr_fun (colimit.w F f) x
#align category_theory.limits.types.colimit.w_apply CategoryTheory.Limits.Types.Colimit.w_apply

--porting note: @[simp] was removed because the linter said it was useless
theorem Colimit.ι_desc_apply (F : J ⥤ Type max v u) (s : Cocone F) (j : J) (x : F.obj j) :
    haveI := hasColimit.{v, u} F;
    colimit.desc F s (colimit.ι F j x) = s.ι.app j x :=
  haveI := hasColimit.{v, u} F; congr_fun (colimit.ι_desc s j) x
#align category_theory.limits.types.colimit.ι_desc_apply CategoryTheory.Limits.Types.Colimit.ι_desc_apply

--porting note: @[simp] was removed because the linter said it was useless
theorem Colimit.ι_map_apply {F G : J ⥤ Type max v u} (α : F ⟶ G) (j : J) (x : F.obj j) :
  haveI := hasColimit.{v, u} F; haveI := hasColimit.{v, u} G;
  haveI := (Types.hasColimitsOfSize.{v, u}.has_colimits_of_shape J);
  colim.{v, v}.map α (colimit.ι F j x) = colimit.ι G j (α.app j x) :=
  haveI := hasColimit.{v, u} F; haveI := hasColimit.{v, u} G;
  haveI := (Types.hasColimitsOfSize.{v, u}.has_colimits_of_shape J);
  congr_fun (colimit.ι_map α j) x
#align category_theory.limits.types.colimit.ι_map_apply CategoryTheory.Limits.Types.Colimit.ι_map_apply

@[simp]
theorem Colimit.w_apply' {F : J ⥤ Type v} {j j' : J} {x : F.obj j} (f : j ⟶ j') :
    colimit.ι F j' (F.map f x) = colimit.ι F j x :=
  congr_fun (colimit.w F f) x
#align category_theory.limits.types.colimit.w_apply' CategoryTheory.Limits.Types.Colimit.w_apply'

@[simp]
theorem Colimit.ι_desc_apply' (F : J ⥤ Type v) (s : Cocone F) (j : J) (x : F.obj j) :
    colimit.desc F s (colimit.ι F j x) = s.ι.app j x :=
  congr_fun (colimit.ι_desc s j) x
#align category_theory.limits.types.colimit.ι_desc_apply' CategoryTheory.Limits.Types.Colimit.ι_desc_apply'

@[simp]
theorem Colimit.ι_map_apply' {F G : J ⥤ Type v} (α : F ⟶ G) (j : J) (x) :
    colim.map α (colimit.ι F j x) = colimit.ι G j (α.app j x) :=
  congr_fun (colimit.ι_map α j) x
#align category_theory.limits.types.colimit.ι_map_apply' CategoryTheory.Limits.Types.Colimit.ι_map_apply'

theorem colimit_sound {F : J ⥤ Type max v u} {j j' : J} {x : F.obj j} {x' : F.obj j'} (f : j ⟶ j')
    (w : F.map f x = x') : haveI := hasColimit.{v, u} F; colimit.ι F j x = colimit.ι F j' x' := by
  rw [← w, Colimit.w_apply.{v, u}]
#align category_theory.limits.types.colimit_sound CategoryTheory.Limits.Types.colimit_sound

theorem colimit_sound' {F : J ⥤ Type max v u} {j j' : J} {x : F.obj j} {x' : F.obj j'} {j'' : J}
    (f : j ⟶ j'') (f' : j' ⟶ j'') (w : F.map f x = F.map f' x') :
    haveI := hasColimit.{v, u} F; colimit.ι F j x = colimit.ι F j' x' := by
  haveI := hasColimit.{v, u} F
  rw [← colimit.w _ f, ← colimit.w _ f']
  rw [types_comp_apply, types_comp_apply, w]
#align category_theory.limits.types.colimit_sound' CategoryTheory.Limits.Types.colimit_sound'

theorem colimit_eq {F : J ⥤ Type max v u} {j j' : J} {x : F.obj j} {x' : F.obj j'}
    (w : haveI := hasColimit.{v, u} F; colimit.ι F j x = colimit.ι F j' x') :
      EqvGen (Quot.Rel.{v, u} F) ⟨j, x⟩ ⟨j', x'⟩ := by
  apply Quot.eq.1
  simpa using congr_arg (colimitEquivQuot.{v, u} F) w
#align category_theory.limits.types.colimit_eq CategoryTheory.Limits.Types.colimit_eq

theorem jointly_surjective (F : J ⥤ Type max v u) {t : Cocone F} (h : IsColimit t) (x : t.pt) :
    ∃ j y, t.ι.app j y = x := by
  suffices (fun x : t.pt => ULift.up (∃ j y, t.ι.app j y = x)) = fun _ => ULift.up.{max v u} True
    by
    have := congr_fun this x
    simpa using congr_arg ULift.down this
  refine' h.hom_ext _
  intro j
  funext y
  simp only [Functor.const_obj_obj, types_comp_apply, ULift.up_inj, eq_iff_iff, iff_true]
  exact ⟨j, y, rfl⟩
#align category_theory.limits.types.jointly_surjective CategoryTheory.Limits.Types.jointly_surjective

/-- A variant of `jointly_surjective` for `x : colimit F`. -/
theorem jointly_surjective' {F : J ⥤ Type max v u} (x : haveI := hasColimit.{v, u} F; colimit F) :
    haveI := hasColimit.{v, u} F; ∃ j y, colimit.ι F j y = x := by
  haveI := hasColimit.{v, u} F
  exact jointly_surjective.{v, u} F (colimit.isColimit F) x
#align category_theory.limits.types.jointly_surjective' CategoryTheory.Limits.Types.jointly_surjective'

namespace FilteredColimit

/- For filtered colimits of types, we can give an explicit description
  of the equivalence relation generated by the relation used to form
  the colimit.  -/
variable (F : J ⥤ Type max v u)

/-- An alternative relation on `Σ j, F.obj j`,
which generates the same equivalence relation as we use to define the colimit in `Type` above,
but that is more convenient when working with filtered colimits.

Elements in `F.obj j` and `F.obj j'` are equivalent if there is some `k : J` to the right
where their images are equal.
-/
protected def Rel (x y : Σj, F.obj j) : Prop :=
  ∃ (k : _)(f : x.1 ⟶ k)(g : y.1 ⟶ k), F.map f x.2 = F.map g y.2
#align category_theory.limits.types.filtered_colimit.rel CategoryTheory.Limits.Types.FilteredColimit.Rel

theorem rel_of_quot_rel (x y : Σj, F.obj j) :
  Quot.Rel.{v, u} F x y → FilteredColimit.Rel.{v, u} F x y :=
  fun ⟨f, h⟩ => ⟨y.1, f, 𝟙 y.1, by rw [← h, FunctorToTypes.map_id_apply]⟩
#align category_theory.limits.types.filtered_colimit.rel_of_quot_rel CategoryTheory.Limits.Types.FilteredColimit.rel_of_quot_rel

theorem eqvGen_quot_rel_of_rel (x y : Σj, F.obj j) :
    FilteredColimit.Rel.{v, u} F x y → EqvGen (Quot.Rel.{v, u} F) x y :=  fun ⟨k, f, g, h⟩ => by
  refine' EqvGen.trans _ ⟨k, F.map f x.2⟩ _ _ _
  . exact (EqvGen.rel _ _ ⟨f, rfl⟩)
  . exact (EqvGen.symm _ _ (EqvGen.rel _ _ ⟨g, h⟩))
#align category_theory.limits.types.filtered_colimit.eqv_gen_quot_rel_of_rel CategoryTheory.Limits.Types.FilteredColimit.eqvGen_quot_rel_of_rel

--attribute [local elab_without_expected_type] nat_trans.app

/-- Recognizing filtered colimits of types. -/
noncomputable def isColimitOf (t : Cocone F) (hsurj : ∀ x : t.pt, ∃ i xi, x = t.ι.app i xi)
    (hinj :
      ∀ i j xi xj,
        t.ι.app i xi = t.ι.app j xj → ∃ (k : _)(f : i ⟶ k)(g : j ⟶ k), F.map f xi = F.map g xj) :
    IsColimit t := by
  -- Strategy: Prove that the map from "the" colimit of F (defined above) to t.X
  -- is a bijection.
  haveI := hasColimit.{v, u} F
  apply IsColimit.ofIsoColimit (colimit.isColimit F)
  refine' Cocones.ext (Equiv.toIso (Equiv.ofBijective _ _)) _
  · exact colimit.desc F t
  · constructor
    · show Function.Injective _
      intro a b h
      rcases jointly_surjective.{v, u} F (colimit.isColimit F) a with ⟨i, xi, rfl⟩
      rcases jointly_surjective.{v, u} F (colimit.isColimit F) b with ⟨j, xj, rfl⟩
      replace h : (colimit.ι F i ≫ colimit.desc F t) xi = (colimit.ι F j ≫ colimit.desc F t) xj
        := h
      rw [colimit.ι_desc, colimit.ι_desc] at h
      rcases hinj i j xi xj h with ⟨k, f, g, h'⟩
      change colimit.ι F i xi = colimit.ι F j xj
      rw [← colimit.w F f, ← colimit.w F g]
      change colimit.ι F k (F.map f xi) = colimit.ι F k (F.map g xj)
      rw [h']
    . show Function.Surjective _
      intro x
      rcases hsurj x with ⟨i, xi, rfl⟩
      use colimit.ι F i xi
      apply Colimit.ι_desc_apply.{v, u}
  . intro j
    apply colimit.ι_desc
#align category_theory.limits.types.filtered_colimit.is_colimit_of CategoryTheory.Limits.Types.FilteredColimit.isColimitOf

variable [IsFilteredOrEmpty J]

protected theorem rel_equiv : _root_.Equivalence (FilteredColimit.Rel.{v, u} F) where
  refl x := ⟨x.1, 𝟙 x.1, 𝟙 x.1, rfl⟩
  symm := fun ⟨k, f, g, h⟩ => ⟨k, g, f, h.symm⟩
  trans {x y z} := fun ⟨k, f, g, h⟩ ⟨k', f', g', h'⟩ =>
    let ⟨l, fl, gl, _⟩ := IsFilteredOrEmpty.cocone_objs k k'
    let ⟨m, n, hn⟩ := IsFilteredOrEmpty.cocone_maps (g ≫ fl) (f' ≫ gl)
    ⟨m, f ≫ fl ≫ n, g' ≫ gl ≫ n,
      calc
        F.map (f ≫ fl ≫ n) x.2 = F.map (fl ≫ n) (F.map f x.2) := by simp
        _ = F.map (fl ≫ n) (F.map g y.2) := by rw [h]
        _ = F.map ((g ≫ fl) ≫ n) y.2 := by simp
        _ = F.map ((f' ≫ gl) ≫ n) y.2 := by rw [hn]
        _ = F.map (gl ≫ n) (F.map f' y.2) := by simp
        _ = F.map (gl ≫ n) (F.map g' z.2) := by rw [h']
        _ = F.map (g' ≫ gl ≫ n) z.2 := by simp⟩
#align category_theory.limits.types.filtered_colimit.rel_equiv CategoryTheory.Limits.Types.FilteredColimit.rel_equiv

protected theorem rel_eq_eqvGen_quot_rel :
    FilteredColimit.Rel.{v, u} F = EqvGen (Quot.Rel.{v, u} F) := by
  ext ⟨j, x⟩ ⟨j', y⟩
  constructor
  · apply eqvGen_quot_rel_of_rel
  · rw [← (FilteredColimit.rel_equiv F).eqvGen_iff]
    exact EqvGen.mono (rel_of_quot_rel F)
#align category_theory.limits.types.filtered_colimit.rel_eq_eqv_gen_quot_rel CategoryTheory.Limits.Types.FilteredColimit.rel_eq_eqvGen_quot_rel

theorem colimit_eq_iff_aux {i j : J} {xi : F.obj i} {xj : F.obj j} :
    (colimitCocone.{v, u} F).ι.app i xi = (colimitCocone.{v, u} F).ι.app j xj ↔
      FilteredColimit.Rel.{v, u} F ⟨i, xi⟩ ⟨j, xj⟩ := by
  change Quot.mk _ _ = Quot.mk _ _ ↔ _
  rw [Quot.eq, FilteredColimit.rel_eq_eqvGen_quot_rel]
#align category_theory.limits.types.filtered_colimit.colimit_eq_iff_aux CategoryTheory.Limits.Types.FilteredColimit.colimit_eq_iff_aux

theorem isColimit_eq_iff {t : Cocone F} (ht : IsColimit t) {i j : J} {xi : F.obj i} {xj : F.obj j} :
    t.ι.app i xi = t.ι.app j xj ↔ ∃ (k : _)(f : i ⟶ k)(g : j ⟶ k), F.map f xi = F.map g xj := by
  let t' := colimitCocone.{v, u} F
  let e : t' ≅ t := IsColimit.uniqueUpToIso (colimitCoconeIsColimit F) ht
  let e' : t'.pt ≅ t.pt := (Cocones.forget _).mapIso e
  refine' Iff.trans _ (colimit_eq_iff_aux.{v, u} F)
  exact @Equiv.apply_eq_iff_eq _ _ e'.toEquiv ((colimitCocone.{v, u} F).ι.app i xi)
    ((colimitCocone.{v, u} F).ι.app j xj)
#align category_theory.limits.types.filtered_colimit.is_colimit_eq_iff CategoryTheory.Limits.Types.FilteredColimit.isColimit_eq_iff

theorem colimit_eq_iff {i j : J} {xi : F.obj i} {xj : F.obj j} :
  haveI := hasColimit.{v, u} F;
    colimit.ι F i xi = colimit.ι F j xj ↔
      ∃ (k : _)(f : i ⟶ k)(g : j ⟶ k), F.map f xi = F.map g xj :=
  haveI := hasColimit.{v, u} F;
  isColimit_eq_iff.{v, u} _ (colimit.isColimit F)
#align category_theory.limits.types.filtered_colimit.colimit_eq_iff CategoryTheory.Limits.Types.FilteredColimit.colimit_eq_iff

end FilteredColimit

variable {α β : Type u} (f : α ⟶ β)

section

-- implementation of `HasImage`
/-- the image of a morphism in Type is just `Set.range f` -/
def Image : Type u :=
  Set.range f
#align category_theory.limits.types.image CategoryTheory.Limits.Types.Image

instance [Inhabited α] : Inhabited (Image f) where default := ⟨f default, ⟨_, rfl⟩⟩

/-- the inclusion of `Image f` into the target -/
def Image.ι : Image f ⟶ β :=
  Subtype.val
#align category_theory.limits.types.image.ι CategoryTheory.Limits.Types.Image.ι

instance : Mono (Image.ι f) :=
  (mono_iff_injective _).2 Subtype.val_injective

variable {f}

/-- the universal property for the image factorisation -/
noncomputable def Image.lift (F' : MonoFactorisation f) : Image f ⟶ F'.I :=
  (fun x => F'.e (Classical.indefiniteDescription _ x.2).1 : Image f → F'.I)
#align category_theory.limits.types.image.lift CategoryTheory.Limits.Types.Image.lift

theorem Image.lift_fac (F' : MonoFactorisation f) : Image.lift F' ≫ F'.m = Image.ι f := by
  funext x
  change (F'.e ≫ F'.m) _ = _
  rw [F'.fac, (Classical.indefiniteDescription _ x.2).2]
  rfl
#align category_theory.limits.types.image.lift_fac CategoryTheory.Limits.Types.Image.lift_fac

end

/-- the factorisation of any morphism in Type through a mono. -/
def monoFactorisation : MonoFactorisation f
    where
  I := Image f
  m := Image.ι f
  e := Set.rangeFactorization f
#align category_theory.limits.types.mono_factorisation CategoryTheory.Limits.Types.monoFactorisation

/-- the factorisation through a mono has the universal property of the image. -/
noncomputable def isImage : IsImage (monoFactorisation f)
    where
  lift := Image.lift
  lift_fac := Image.lift_fac
#align category_theory.limits.types.is_image CategoryTheory.Limits.Types.isImage

instance : HasImage f :=
  HasImage.mk ⟨_, isImage f⟩

instance : HasImages (Type u) where has_image := by infer_instance

instance : HasImageMaps (Type u) where
  has_image_map {f g} st :=
    HasImageMap.transport st (monoFactorisation f.hom) (isImage g.hom)
      (fun x => ⟨st.right x.1, ⟨st.left (Classical.choose x.2), by
        have p := st.w
        replace p := congr_fun p (Classical.choose x.2)
        simp only [Functor.id_obj, Functor.id_map, types_comp_apply] at p
        erw [p, Classical.choose_spec x.2]⟩⟩) rfl

end CategoryTheory.Limits.Types


/-
  Tactics produce either a single new tactic state, or fail.

  A tactic state is essentially a list of goals.
-/

lemma p1_1 {a b : Prop} : a → b → b ∧ a :=
begin
  intros ha hb,
  apply and.intro,
  assumption,
  assumption,
end

-- we can freely mix tactics and expressions
lemma p1_2 {a b : Prop} : a → b → b ∧ a :=
λ ha hb, ⟨by assumption, begin assumption end⟩

lemma p1_3 {a b : Prop} : a → b → b ∧ a :=
λ ha hb, ⟨by assumption, by trivial⟩ -- failing tactics are underlined in red

lemma p1_4 {a b : Prop} : a → b → b ∧ a :=
begin
  intros ha hb,
  apply and.intro,
  -- repeats a tactic until it fails
  repeat { assumption },
end

lemma p1_6 {a b : Prop} : a → b → b ∧ a :=
-- ; executes the right tactic on all new goals
by intros ha hb; apply and.intro; assumption

lemma p2 (x : ℕ) : true ∧ x = x :=
-- the orelse (<|>) operator allows backtracking
by constructor; trivial <|> refl

/-
  Rewriting
-/

lemma p3 (f : ℕ → ℕ) (a b : ℕ) (h : f (1 * (0 + a)) = f b) : f a = f (0 + b) :=
begin
-- The `rw` tactic takes a (quantified) equation and rewrites the goal using it
  rw zero_add,
-- You can also pass it multiple equations, and rewrite hypotheses
  rw [zero_add, one_mul] at h,
  assumption,
end

/-
  Induction
-/

lemma p4 {α : Type} (xs ys : list α) : (xs.append ys).length = xs.length + ys.length :=
begin
  induction xs; unfold list.append list.length,
  {rw zero_add},
  {cc}, -- congruence closure modulo associativity-commutativity
end

/-
  Tactics are Lean terms as well ("meta-programs")
-/

open tactic

-- Meta-definitions can use general recursion and
-- call to functions implemented in C++

-- Tactics are written using the `tactic` monad:
meta def tactic.interactive.intro_and_cases : tactic unit := do
h ← intro `h,  -- `h is a name literal
trace "intro_and_cases: ", trace_state, -- printf-style debugging is usually the easiest option
cases h

example (a b : Prop) : a ∧ b → a :=
begin
  intro_and_cases,
  assumption,
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.equiv.fintype
import data.finset.noncomm_prod
import group_theory.perm.sign
/-!
# 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, units.neg_neg, one_mul, units.mul_neg, eq_self_iff_true,
        pow_one, units.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

/-!
### `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 a ha b 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.forall_of_pairwise 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

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τ)) (list.pairwise_of_pairwise_cons h2)) },
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


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import data.fin.basic
import data.fintype.basic
/-!
# The structure of `fintype (fin n)`

This file contains some basic results about the `fintype` instance for `fin`,
especially properties of `finset.univ : finset (fin n)`.
-/

open finset
open fintype

namespace fin

@[simp]
lemma univ_filter_zero_lt {n : ℕ} :
  (univ : finset (fin n.succ)).filter (λ i, 0 < i) =
    univ.map (fin.succ_embedding _).to_embedding :=
begin
  ext i,
  simp only [mem_filter, mem_map, mem_univ, true_and,
  function.embedding.coe_fn_mk, exists_true_left],
  split,
  { refine cases _ _ i,
    { rintro ⟨⟨⟩⟩ },
    { intros j _, exact ⟨j, rfl⟩ } },
  { rintro ⟨i, _, rfl⟩,
    exact succ_pos _ },
end

@[simp]
lemma univ_filter_succ_lt {n : ℕ} (j : fin n) :
  (univ : finset (fin n.succ)).filter (λ i, j.succ < i) =
    (univ.filter (λ i, j < i)).map (fin.succ_embedding _).to_embedding :=
begin
  ext i,
  simp only [mem_filter, mem_map, mem_univ, true_and,
  function.embedding.coe_fn_mk, exists_true_left],
  split,
  { refine cases _ _ i,
    { rintro ⟨⟨⟩⟩ },
    { intros i hi,
      refine ⟨i, succ_lt_succ_iff.mp hi, rfl⟩ } },
  { rintro ⟨i, hi, rfl⟩, simpa },
end

end fin


import game.world8.level11 -- hide
namespace mynat -- hide

/-

# Advanced Addition World

## Level 12: `add_one_eq_succ`

We have

  * `succ_eq_add_one (n : mynat) : succ n = n + 1`

but sometimes the other way is also convenient.
-/

/- Theorem
For any natural number $d$, we have
$$ d+1 = \operatorname{succ}(d). $$
-/
theorem add_one_eq_succ (d : mynat) : d + 1 = succ d :=
begin [nat_num_game]
  rw succ_eq_add_one,
  refl,

end

end mynat -- hide