import tactic
import data.set.basic

/--
An ideal of R consists of a nonempty subset of R which is closed under addition, additive inverses,
and multiplication by elements of R.
-/
@[nolint has_inhabited_instance]
structure myideal (R : Type) [comm_ring R] :=
  (iset : set R)
  (not_empty : iset.nonempty)
  (r_mul_mem' {x r}: x ∈ iset → r * x ∈ iset)
  (add_mem' {x y} : x ∈ iset → y ∈ iset → (x + y) ∈ iset)
  (neg_mem' {x} : x ∈ iset → -x ∈ iset)

attribute [ext] myideal

namespace myideal

variables {R : Type} [comm_ring R] (I : myideal R)
instance : has_mem R (myideal R) :=
{ mem := λ x i , x ∈ i.iset}

instance : has_coe (myideal R) (set R) :=
{coe := λ x, x.iset}

instance : has_subset (myideal R) :=
{ subset := λ x y, x.iset ⊆ y.iset }

theorem add_mem {x y : R}: x ∈ I → y ∈ I → x + y ∈ I := by apply add_mem'

theorem neg_mem {x : R} : x ∈ I → -x ∈ I := by apply neg_mem'

theorem r_mul_mem {x r : R} : x ∈ I → r * x ∈ I := by apply r_mul_mem'
end myideal

variables {R : Type} [comm_ring R]

/--
An integral domain has no zero divisors.
-/
def is_integral_domain (R: Type) [comm_ring R]: Prop :=
  ∀ (x y : R), x * y = 0 → x = 0 ∨ y = 0

/--
A principal ideal is of the form aR for some a ∈ R
-/
def principal_ideal (x : R) : myideal R :=
{
  iset := { i : R | ∃(v:R), i = x * v},
  not_empty := begin
    rw set.nonempty_def,
    use x,
    use 1,
    rw mul_one,
  end,
  r_mul_mem' := begin
    intro i,
    intro j,
    intro h,
    cases h,
    use (j * h_w),
    rw h_h,
    ring,
  end,
  add_mem' := begin
    intros i j hi hj,
    cases hi,
    cases hj,
    use hi_w + hj_w,
    rw mul_add,
    rw hi_h, rw hj_h,
  end,
  neg_mem' := begin
    intros i hi,
    cases hi,
    use -hi_w,
    rw hi_h,
    ring,
  end
}
/--
An integral domain is a PID iff every ideal is principal.
-/
def is_pid (R: Type) [comm_ring R]: Prop :=
  is_integral_domain R ∧ ∀(I : myideal R), ∃ (x : R), I = principal_ideal x

--1 ∈ I → I = R
lemma one_mem_ideal_R {I : myideal R} : (1:R) ∈ I → coe I = {x : R | true} :=
begin
  intro h,
  ext,
  split,
  intro, triv,
  intro h2,
  rw ←mul_one x,
  apply myideal.r_mul_mem,
  exact h,
end

lemma zero_mem_ideal {I : myideal R} : (0:R) ∈ I :=
begin
  have h := myideal.not_empty I,
  rw set.nonempty at h,
  cases h with x hx,
  have h2 : x + (-x) = 0,
  ring,
  rw ←h2,
  apply myideal.add_mem I,
  exact hx,
  apply myideal.neg_mem I,
  exact hx,
end

/--
The sum of two ideals is also an ideal.
-/
def sum_ideal (I J : myideal R) : myideal R :=
{ iset := {r : R | ∃ (i ∈ I) (j ∈ J), r = i + j},
  not_empty := begin
    have h1 := myideal.not_empty I,
    have h2 := myideal.not_empty J,
    rw set.nonempty at h1 h2 ⊢,
    cases h1,
    cases h2,
    use h1_w + h2_w,
    use h1_w, split, exact h1_h,
    use h2_w, split, exact h2_h,
    refl,
  end,
  r_mul_mem' := begin
    intros x r h,
    cases h with i h2,
    cases h2 with hi h2,
    cases h2 with j h2,
    cases h2 with hj h2,
    rw h2,
    rw mul_add,
    use r * i,
    split,
      apply myideal.r_mul_mem,
      exact hi,
    use r * j,
    split,
      apply myideal.r_mul_mem,
      exact hj,
    refl,
  end,
  add_mem' := begin
    intros x y hxm hym,
    cases hxm with xi hxi,
    cases hxi with hxi h2,
    cases h2 with xj hxj,
    cases hxj with hxj hx,
    cases hym with yi hyi,
    cases hyi with hyi h2,
    cases h2 with yj hyj,
    cases hyj with hyj hy,
    use xi + yi,
    split,
    apply myideal.add_mem, exact hxi, exact hyi,
    use xj + yj,
    split,
    apply myideal.add_mem, exact hxj, exact hyj,
    rw hy,
    rw hx,
    ring,
  end,
  neg_mem' := begin
    intros x h,
    cases h with i hi,
    cases hi with hi h2,
    cases h2 with j h2,
    cases h2 with hj h2,
    use -i,
    split,
    apply myideal.neg_mem,
    exact hi,
    use -j,
    split,
    apply myideal.neg_mem,
    exact hj,
    rw h2, ring,
  end
}

notation I ` + ` J := sum_ideal I J

/--
An element r of R is irreducible iff it is not a unit and
for all factorisations x * y = r, x or y is a unit.
-/
def irreducible (r : R) : Prop :=
  ¬is_unit r ∧ ∀(x y : R), x * y = r → is_unit x ∨ is_unit y

lemma r_prod_unit_r_unit (r a : R) (hpu : is_unit (r * a)) :
  is_unit r :=
begin
  have h2:=  is_unit.exists_right_inv hpu,
  cases h2,
  rw is_unit_iff_exists_inv',
  use a * h2_w, rw mul_comm, rw ← mul_assoc, exact h2_h,
end

lemma unit_mul_irr_is_irr (r a : R) (hirr :irreducible r) (hu: is_unit a) :
 irreducible (a * r) :=
begin
  split,
  {
    by_contra,
    cases hirr,
    apply hirr_left,
    apply r_prod_unit_r_unit r a,
    rw mul_comm,
    exact h
  },
  {
    intros x y h,
    have h2 : ∃ (b : R), r = (b * x) * y,
      rw is_unit_iff_exists_inv at hu,
      cases hu with c h3,
      use c, rw mul_assoc, rw h,
      ring_nf, rw mul_assoc, rw h3, rw mul_one,
    cases hirr,
    cases h2 with b hb,
    specialize hirr_right (b * x) y,
    rw eq_comm at hb,
    have h3 := hirr_right hb,
    cases h3,
    left,
      rw mul_comm at h3,
      apply r_prod_unit_r_unit x b,
      exact h3,
    right,
    exact h3,
  }
end

/--
  For some a and b, a divides b iff there is a c ∈ R such that a * c = b
-/
def divisible (a b: R) : Prop :=
  ∃ (c : R), b = a * c

notation a ` \ ` b := divisible a b

/--
  Two elements a b are associates iff a = b * c for some unit c.
-/
def associates (a b : R) : Prop :=
  ∃ (c : R), is_unit c ∧ b = a * c

notation a ` ~ ` b := associates a b

lemma assoc_sym (a b : R) : a ~ b → b ~ a:=
begin
  intro h,
  cases h with u h2,
  cases h2 with hunit h3,
  rw is_unit_iff_exists_inv at hunit,
  cases hunit with uinv huinv,
  use uinv,
  split,
    rw is_unit_iff_exists_inv,
    use u,
    rw mul_comm,
    exact huinv,
  rw h3,
  rw mul_assoc,
  rw huinv,
  rw mul_one,
end

lemma symm_divisible_associates_int_domain (hint : is_integral_domain R) (a b : R) : a \ b → b \ a → a ~ b :=
begin
  intros h1 h2,
  cases h1 with x hx,
  cases h2 with y hy,
  by_cases a ≠ 0,
  {
    rw hx at hy,
    apply_fun λ x, x + (-a) at hy,
    rw add_neg_self at hy,
    rw ←mul_one (-a) at hy,
    rw neg_mul_comm a 1 at hy,
    rw mul_assoc at hy,
    rw ←mul_add at hy,
    specialize hint a (x * y + (-1)),
    have h2 := hint (eq.symm hy),
    cases h2,
    exfalso, apply h, exact h2,
    apply_fun λ x, x + 1 at h2,
    rw zero_add at h2,
    rw add_assoc at h2,
    rw neg_add_self at h2,
    rw add_zero at h2,
    use x,
    split,
    rw is_unit_iff_exists_inv,
    use y,
    exact h2,
    exact hx,
  },
  {
    use 1,
    split,
    exact is_unit_one,
    rw not_ne_iff at h,
    rw h at hx,
    rw hx,
    rw h,
    rw zero_mul,
    rw zero_mul,
  }
end

lemma generators_associate_if_ideals_eq (a b : R) (hint : is_integral_domain R):
  principal_ideal a = principal_ideal b → a ~ b :=
begin
  intro h,
  have h1 : a ∈ principal_ideal a,
    use 1, rw mul_one,
  have h2 : b ∈ principal_ideal b,
    use 1, rw mul_one,
  rw h at h1,
  rw ←h at h2,
  apply symm_divisible_associates_int_domain,
  exact hint,
  exact h2,
  exact h1,
end

/--
In a dividing sequence, each term is divisible by the next term.
-/
def dividing_sequence (f : ℕ → R) : Prop :=
∀ (n : ℕ),  f (n + 1) \ f n

/--
A unique factorisation domain (UFD) is an integral domain such that:
  All infinite dividing sequences 'stabilise': past some n ∈ ℕ, all terms are associate.#check
  All irreducible elements are prime.
-/
def is_ufd  (R : Type) [comm_ring R] : Prop :=
  is_integral_domain R ∧ (∀(f : ℕ → R), dividing_sequence f →
  ∃ (m : ℕ), ∀(q : ℕ), m ≤ q → f q ~ f (q + 1) ) ∧
   (∀ (p: R), irreducible p →∀ (a b: R), p \ (a*b) → p \ a ∨ p \ b )

/--
In an ascending ideal chain, each ideal is contained in the next one.
-/
def asc_ideal_chain (i : ℕ → myideal R) : Prop :=
  ∀ (n : ℕ), i n ⊆ i (n + 1)

lemma asc_ideal_chain_add (i : ℕ → myideal R) :
asc_ideal_chain i → ∀(n : ℕ), ∀ (m : ℕ),  i n ⊆  i (m+n) :=
begin
  intros h n m,
  induction m,
  rw zero_add, refl,
  specialize h (m_n + n),
  rw nat.succ_eq_add_one,

  change (i n).iset ⊆ (i (m_n + n)).iset at m_ih,
  change (i (m_n + n)).iset ⊆ (i (m_n + n + 1)).iset at h,
  change (i n).iset ⊆ (i (m_n + 1 + n)).iset,
  apply set.subset.trans,
  exact m_ih,
  nth_rewrite_rhs 1 add_comm,
  rw add_assoc,
  nth_rewrite_rhs 0 add_comm,
  exact h,
end

lemma asc_ideal_chain_ind (i : ℕ → myideal R) :
asc_ideal_chain i ↔ ∀(n : ℕ), ∀ (m : ℕ),  n ≤ m → i n ⊆ i m :=
begin
  split,
  {
    intros h n m h2,
    have h3 : ∃ (r: ℕ), n + r = m,
      use m - n,
      linarith,
    cases h3 with s hs,
    rw ←hs,
    rw add_comm,
    apply asc_ideal_chain_add,
    exact h,
  },
  {
    intros h n,
    specialize h n (n+1),
    apply h,
    norm_num,
  }
end

theorem pid_is_noetherian (R : Type) [comm_ring R] (hpid : is_pid R)
(i :ℕ →  myideal R) (hinc : asc_ideal_chain i)  :
∃(r : ℕ), ∀(s : ℕ ), r ≤ s → i s = i (s + 1)
 :=
begin
  cases hpid with hint hpid,
  let S := set.Union (λ (x : ℕ), myideal.iset (i x)),
  let si := myideal.mk S,
  let sii : myideal R,
  apply si,
  {
    rw set.nonempty,
    let i0 := i 0,
    have hne := myideal.not_empty i0,
    rw set.nonempty at hne,
    cases hne with x0 hx0,
    use x0,
    rw set.mem_Union,
    use 0, exact hx0,
  },
  {
    intros x r h,
    rw set.mem_Union at h ⊢,
    cases h,
    use h_w,
    apply myideal.r_mul_mem',
    exact h_h,
  },{
    intros x y h1 h2,
    rw set.mem_Union at h1 h2 ⊢,
    cases h1 with i1 hi1,
    cases h2 with i2 hi2,
    by_cases i1 ≤ i2,
    {
      have h3 := ((asc_ideal_chain_ind i).mp) hinc,
      specialize h3 i1 i2,
      have h4 := h3 h,
      use i2,
      apply myideal.add_mem',
      apply set.mem_of_subset_of_mem h4,
      exact hi1,
      exact hi2,
    },
    {
      have hbt : i2 ≤ i1,
        rw le_iff_lt_or_eq,
        left,
        push_neg at h,
        exact h,
      have h3 := ((asc_ideal_chain_ind i).mp) hinc,
      specialize h3 i2 i1,
      have h4 := h3 hbt,
      use i1,
      apply myideal.add_mem',
      exact hi1,
      apply set.mem_of_subset_of_mem h4,
      exact hi2,
    }
  },{
    intros x h,
    rw set.mem_Union at h ⊢,
    cases h with b hb,
    use b,
    apply myideal.neg_mem',
    exact hb,
  },
  specialize hpid sii,
  cases hpid with a ha,
  have hasi : a ∈ sii,
    rw ha,
    change ∃(v:R), a = a * v,
    use 1,
    rw mul_one,
  change a ∈ sii.iset at hasi,
  rw set.mem_Union at hasi,
  cases hasi with q hq,
  use q,
  intro s,
  intro hsq,
  have hisq : (i q).iset = S,
  {
    ext,
    split,
      intro h,
      rw set.mem_Union,
      use q, exact h,
    intro h,
    change x ∈ sii.iset at h,
    rw ha at h,
    cases h,
    rw mul_comm at h_h,
    rw h_h,
    apply myideal.r_mul_mem',
    exact hq,
  },
  apply myideal.ext,
  apply set.subset.antisymm,
  specialize hinc s,
  exact hinc,
  apply @set.subset.trans _ (i (s + 1)).iset (i q).iset,
  rw hisq,
  exact set.subset_Union (λ (x : ℕ), myideal.iset (i x)) (s + 1),
  rw asc_ideal_chain_ind at hinc,
  specialize hinc q s,
  apply hinc,
  exact hsq,
end

theorem pid_irreducible_is_prime (hpid : is_pid R)  (p : R) (hirr : irreducible p) :
  ∀ (a b : R), p \ (a * b) → p \ a ∨  p \ b :=
begin
  cases hpid with hint hpid,
  intros a b h,
  let I := sum_ideal (principal_ideal a) (principal_ideal p),
  specialize hpid I,
  cases hpid with d hd,
  have hpi: p ∈ I,
    use 0,
    split,
    exact zero_mem_ideal,
    use p,
    split,
    use 1,
    rw mul_one,
    rw zero_add,
  rw hd at hpi,
  cases hpi with r hdr,
  cases hirr,
  specialize hirr_right d r,
  have hut := hirr_right (eq_comm.mpr hdr),
  cases hut,
  {
    right,
    have hone : (1:R) ∈ I,
      rw is_unit_iff_exists_inv at hut,
      rw hd,
      cases hut with di hdi,
      use di,
      rw hdi,
    cases hone with u h2,
    cases h2 with hu h2,
    cases h2 with v h2,
    cases h2 with hv h2,
    cases hu with s hs,
    cases hv with t ht,
    rw hs at h2,
    rw ht at h2,
    apply_fun λ x, b*x at h2,
    rw mul_one at h2,
    rw mul_add at h2,
    rw h2,
    rw ← mul_assoc,
    rw mul_comm b a,
    cases h with q hq,
    rw hq,
    use q * s + b * t,
    ring,
  },{
    have hai : a ∈ I,
      use a,
      split,
      use 1,
      rw mul_one,
      use 0,
      split,
      exact zero_mem_ideal,
      rw add_zero,
    rw hd at hai,
    cases hai with e he,
    rw is_unit_iff_exists_inv at hut,
    cases hut with ri hri,
    apply_fun λ x, x * ri at hdr,
    rw mul_assoc at hdr,
    rw hri at hdr,
    rw mul_one at hdr,
    rw ←hdr at he,
    left,
    use (ri * e),
    rw ← mul_assoc,
    exact he,
  }
end

theorem pid_is_ufd (R : Type) [hc : comm_ring R] (hpid : is_pid R): is_ufd R:=
begin
  split,
    exact hpid.left,
  split,
  {
    intro f,
    intro h,
    let i := λ(x : ℕ), principal_ideal (f x),
    have hinc : asc_ideal_chain i,
      intro n,
      change principal_ideal (f n) ⊆ principal_ideal (f (n+1)),
      specialize h n,
      cases h with y hy,
      rw hy,
      intros x h2,
      cases h2 with z hz,
      use y * z,
      rw ← mul_assoc,
      exact hz,
    have hnoet := pid_is_noetherian R hpid,
    specialize hnoet i,
    have hstab := hnoet hinc,
    cases hstab with m hm,
    use m,
    intro q,
    specialize hm q,
    intro hmq,
    have hiqs := hm hmq,
    apply generators_associate_if_ideals_eq,
    exact hpid.left,
    exact hiqs,
  },
  {
    exact pid_irreducible_is_prime hpid,
  }
end
#lint


-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que
--    (s \ t) \ u ⊆ s \ (t ∪ u)
-- ----------------------------------------------------------------------

import tactic

variable {α : Type*}
variables (s t u : set α)

-- 1ª demostración
-- ===============

example : (s \ t) \ u ⊆ s \ (t ∪ u) :=
begin
  intros x xstu,
  have xs : x ∈ s := xstu.1.1,
  have xnt : x ∉ t := xstu.1.2,
  have xnu : x ∉ u := xstu.2,
  split,
  { exact xs },
  { dsimp,
    intro xtu,
    cases xtu with xt xu,
    { show false,
      from xnt xt },
    { show false,
      from xnu xu }},
end

-- Prueba
-- ======

/-
α : Type u_1,
s t u : set α
⊢ s \ t \ u ⊆ s \ (t ∪ u)
  >> intros x xstu,
x : α,
xstu : x ∈ s \ t \ u
⊢ x ∈ s \ (t ∪ u)
  >> have xs : x ∈ s := xstu.1.1,
xs : x ∈ s
⊢ x ∈ s \ (t ∪ u)
  >> have xnt : x ∉ t := xstu.1.2,
xnt : x ∉ t
⊢ x ∈ s \ (t ∪ u)
  >> have xnu : x ∉ u := xstu.2,
xnu : x ∉ u
⊢ x ∈ s \ (t ∪ u)
  >> split,
| ⊢ x ∈ s
|   >> { exact xs },
⊢ (λ (a : α), a ∉ t ∪ u) x
  >> { dsimp,
⊢ ¬(x ∈ t ∨ x ∈ u)
  >>   intro xtu,
xtu : x ∈ t ∨ x ∈ u
⊢ false
  >>   cases xtu with xt xu,
| xt : x ∈ t
| ⊢ false
|   >>   { show false,
| ⊢ false
|   >>     from xnt xt },
xu : x ∈ u
⊢ false
  >>   { show false,
⊢ false
  >>     from xnu xu }},
no goals
-/

-- 2ª demostración
-- ===============

example : s \ t \ u ⊆ s \ (t ∪ u) :=
begin
  rintros x ⟨⟨xs, xnt⟩, xnu⟩,
  use xs,
  rintros (xt | xu),
  { contradiction },
  { contradiction },
end

-- Prueba
-- ======

/-
α : Type u_1,
s t u : set α
⊢ s \ t \ u ⊆ s \ (t ∪ u)
  >> rintros x ⟨⟨xs, xnt⟩, xnu⟩,
x : α,
xnu : x ∉ u,
xs : x ∈ s,
xnt : x ∉ t
⊢ x ∈ s \ (t ∪ u)
  >> use xs,
⊢ (λ (a : α), a ∉ t ∪ u) x
  >> rintros (xt | xu),
| xt : x ∈ t
| ⊢ false
|   >> { contradiction },
xu : x ∈ u
⊢ false
  >> { contradiction },
no goals
-/

-- 3ª demostración
-- ===============

example : s \ t \ u ⊆ s \ (t ∪ u) :=
begin
  rintros x ⟨⟨xs, xnt⟩, xnu⟩,
  use xs,
  rintros (xt | xu); contradiction
end

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que
--    s \ (t ∪ u) ⊆ (s \ t) \ u
-- ----------------------------------------------------------------------

example : s \ (t ∪ u) ⊆ (s \ t) \ u :=
begin
  rintros x ⟨xs, xntu⟩,
  use xs,
  { intro xt,
    exact xntu (or.inl xt) },
  { intro xu,
    apply xntu (or.inr xu) },
end

-- Prueba
-- ======

/-
α : Type u_1,
s t u : set α
⊢ s \ (t ∪ u) ⊆ s \ t \ u
  >> rintros x ⟨xs, xntu⟩,
x : α,
xs : x ∈ s,
xntu : x ∉ t ∪ u
⊢ x ∈ s \ t \ u
  >> use xs,
| ⊢ (λ (a : α), a ∉ t) x
|   >> { intro xt,
| xt : x ∈ t
| ⊢ false
|   >>   exact xntu (or.inl xt) },
⊢ (λ (a : α), a ∉ u) x
  >> { intro xu,
xu : x ∈ u
⊢ false
  >>   apply xntu (or.inr xu) },
no goals
-/


import data.fintype.big_operators algebra.big_operators.intervals algebra.big_operators.order

/-! # IMO 2006 A2 -/

namespace IMOSL
namespace IMO2006A2

open finset

variables {F : Type*} [linear_ordered_field F]

private lemma div_sub_lt_div_sub {a b c : F} (h : 0 < a) (h0 : a < b) (h1 : b < c) :
  c / (c - a) < b / (b - a) :=
  by rwa [div_lt_div_iff (sub_pos.mpr (lt_trans h0 h1)) (sub_pos.mpr h0),
    mul_sub, mul_sub, mul_comm, sub_lt_sub_iff_left, mul_lt_mul_right h]

def a : ℕ → F := nat.strong_rec' (λ n (f : Π m, m < n → F),
    ite (n = 0) (-1) (-(univ : finset (fin n)).sum (λ i, f i i.2 / (n.succ - i))))

private lemma a_zero : a 0 = (-1 : F) :=
  by rw [a, nat.strong_rec', if_pos rfl]

private lemma a_nonzero {n : ℕ} (h : n ≠ 0) :
  (a n : F) = - (range n).sum (λ i, a i / (n.succ - i)) :=
  by rw [← fin.sum_univ_eq_sum_range, a, nat.strong_rec', ← a, if_neg h]; refl

/-- Final solution -/
theorem final_solution {n : ℕ} (h : 0 < n) : 0 < (a n : F) :=
begin
  ---- Setup for strong induction, including the base case
  rw [← nat.succ_le_iff, le_iff_exists_add'] at h,
  rcases h with ⟨n, rfl⟩,
  induction n using nat.strong_induction_on with n n_ih,
  rcases n.eq_zero_or_pos with rfl | h,
  rw [zero_add, a_nonzero one_ne_zero, sum_range_one, a_zero, neg_div,
      neg_neg, one_div_pos, sub_pos, nat.cast_two, nat.cast_zero],
  exact two_pos,

  ---- Induction step
  have X : 0 < (n.succ.succ : F) := nat.cast_pos.mpr n.succ.succ_pos,
  rw [a_nonzero n.succ_ne_zero, neg_pos, sum_range_succ', nat.cast_zero,
      sub_zero, ← lt_neg_iff_add_neg, ← neg_div, lt_div_iff X, sum_mul],
  replace X : (a n : F) = _ := a_nonzero (ne_of_gt h),
  have X0 : (n.succ : F) ≠ 0 := nat.cast_ne_zero.mpr n.succ_ne_zero,
  rw [eq_neg_iff_add_eq_zero, ← sum_range_succ_sub_top, nat.cast_succ, add_tsub_cancel_left,
      div_one, add_sub_cancel'_right, sum_range_succ', nat.cast_zero, ← nat.cast_succ,
      sub_zero, add_eq_zero_iff_eq_neg, ← neg_div, eq_div_iff X0] at X,
  rw [← X, sum_mul]; clear X X0,
  refine sum_lt_sum_of_nonempty (nonempty_range_iff.mpr $ ne_of_gt h) (λ i h0, _),
  rw mem_range at h0,
  rw [mul_comm_div, mul_comm_div, mul_lt_mul_left (n_ih i h0)],
  refine div_sub_lt_div_sub (nat.cast_pos.mpr i.succ_pos) _ _,
  rwa [nat.cast_lt, nat.succ_lt_succ_iff],
  rw nat.cast_lt; exact n.succ.lt_succ_self
end

end IMO2006A2
end IMOSL


import linear_algebra.tensor_product

import tut2

open_locale tensor_product

variables {ℋ : Type} [complex_hilbert_space ℋ]
{ρ σ τ : ℋ →ₗ[ℂ] ℋ} [quantum_state ρ] [quantum_state σ] [quantum_state τ]

#check tensor_product
#check ρ ⊗ₜ[ℂ] σ

notation A ` ⊗ ` B := A ⊗ₜ[ℂ] B

example {a : ℂ} : a • (ρ ⊗ σ) = (a • ρ) ⊗ σ :=
begin
    exact rfl,
end

example {a : ℂ} : a • (ρ ⊗ σ) = ρ ⊗ (a • σ) :=
begin
    norm_num,
end

example {a : ℂ} : a • (ρ + σ) = a • ρ + a • σ :=
begin
    rw smul_add,
end

example : ρ ⊗ (σ + τ) = ρ ⊗ σ + ρ ⊗ τ :=
begin
    rw tensor_product.tmul_add,
end

example : (σ + τ) ⊗ ρ = σ ⊗ ρ + τ ⊗ ρ :=
begin
    rw tensor_product.add_tmul,
end


/-
Copyright (c) 2023 Tian Chen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tian Chen
-/

import analysis.mean_inequalities
import matrix.doubly_stochastic.birkhoff
import ineq.symm_sum
import ineq.doubly_stochastic

open_locale big_operators

open finset

lemma real.prod_pow {ι : Type*} {a : ℝ} {s : finset ι} {f : ι → ℝ} (h : ∀ x ∈ s, 0 ≤ f x) :
  (∏ x in s, f x) ^ a = ∏ x in s, f x ^ a :=
begin
  induction s using finset.cons_induction with i s his hs,
  { exact real.one_rpow _ },
  rw finset.forall_mem_cons at h,
  rw [prod_cons, prod_cons, real.mul_rpow h.1 (prod_nonneg h.2), hs h.2]
end

variables {ι : Type*} [fintype ι] [decidable_eq ι]

private lemma symm_mean_right_sum_le {ι' : Type*} [fintype ι']
  (c : ι' → ℝ) (hc0 : ∀ i, 0 ≤ c i)
  (hc1 : ∑ i, c i = 1)
  (v : ι' → ι → ℝ) (z : ι → ℝ) (hz : ∀ i, 0 < z i) :
  symm_mean z (∑ i, c i • v i) ≤ ∑ i, c i * symm_mean z (v i) :=
begin
  simp_rw [symm_mean_def, mul_sum, sum_apply, pi.smul_apply, smul_eq_mul],
  rw sum_comm,
  apply sum_le_sum,
  intros σ _,
  calc  ∏ i, z i ^ ∑ j, c j * v j (σ i)
      = ∏ i, ∏ j, z i ^ (c j * v j (σ i)) :
          prod_congr rfl $ λ i _, real.rpow_sum_of_pos (hz _) _ _
  ... = ∏ i, ∏ j, (z i ^ v j (σ i)) ^ c j :
          prod_congr rfl $ λ i _, prod_congr rfl $ λ j _,
            by rw mul_comm; exact real.rpow_mul (hz _).le _ _
  ... = ∏ j, (∏ i, z i ^ v j (σ i)) ^ c j :
          by rw prod_comm; apply prod_congr rfl; intros j _;
            rw real.prod_pow;
            intros;
            exact (real.rpow_pos_of_pos (hz _) _).le
  ... ≤ ∑ j, c j * ∏ i, z i ^ v j (σ i) :
          real.geom_mean_le_arith_mean_weighted _ c _ (λ _ _, hc0 _) hc1 $
            λ _ _, prod_nonneg $ λ _ _, (real.rpow_pos_of_pos (hz _) _).le
end

/-- **Muirhead's Inequality** -/
theorem majorize.symm_mean_le_symm_mean {p q : ι → ℝ} (hpq : majorize q p)
  (z : ι → ℝ) (hz : ∀ i, 0 < z i) :
  symm_mean z q ≤ symm_mean z p :=
begin
  obtain ⟨M, hM, hM'⟩ := hpq.exists_doubly_stochastic,
  rcases hM.mem_convex_hull' with ⟨w, hw0, hw1, hMw⟩,
  rw [show q = matrix.mul_vec.add_monoid_hom_left p M, from hM', hMw, map_sum],
  rw [matrix.mul_vec.add_monoid_hom_left, add_monoid_hom.coe_mk],
  simp_rw [matrix.smul_mul_vec_assoc],
  convert symm_mean_right_sum_le w hw0 hw1 _ z hz,
  have : ∀ σ : ι ≃ ι, σ.to_pequiv.to_matrix.mul_vec p = p ∘ σ,
  { intro σ,
    ext i,
    rw [function.comp_app, matrix.mul_vec, matrix.dot_product],
    simp_rw [pequiv.equiv_to_pequiv_to_matrix, matrix.one_apply, boole_mul],
    rw [sum_ite_eq, if_pos (mem_univ _)] },
  simp_rw [this, symm_mean_equiv_right],
  rw [← sum_mul, hw1, one_mul]
end


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.calculus.deriv
import linear_algebra.affine_space.slope

/-!
# Slope of a differentiable function

Given a function `f : 𝕜 → E` from a nondiscrete normed field to a normed space over this field,
`dslope f a b` is defined as `slope f a b = (b - a)⁻¹ • (f b - f a)` for `a ≠ b` and as `deriv f a`
for `a = b`.

In this file we define `dslope` and prove some basic lemmas about its continuity and
differentiability.
-/

open_locale classical topological_space filter
open function set filter

variables {𝕜 E : Type*} [nondiscrete_normed_field 𝕜] [normed_group E] [normed_space 𝕜 E]

/-- `dslope f a b` is defined as `slope f a b = (b - a)⁻¹ • (f b - f a)` for `a ≠ b` and
`deriv f a` for `a = b`. -/
noncomputable def dslope (f : 𝕜 → E) (a : 𝕜) : 𝕜 → E := update (slope f a) a (deriv f a)

@[simp] lemma dslope_same (f : 𝕜 → E) (a : 𝕜) : dslope f a a = deriv f a := update_same _ _ _

variables {f : 𝕜 → E} {a b : 𝕜} {s : set 𝕜}

lemma dslope_of_ne (f : 𝕜 → E) (h : b ≠ a) : dslope f a b = slope f a b :=
update_noteq h _ _

lemma eq_on_dslope_slope (f : 𝕜 → E) (a : 𝕜) : eq_on (dslope f a) (slope f a) {a}ᶜ :=
λ b, dslope_of_ne f

lemma dslope_eventually_eq_slope_of_ne (f : 𝕜 → E) (h : b ≠ a) : dslope f a =ᶠ[𝓝 b] slope f a :=
(eq_on_dslope_slope f a).eventually_eq_of_mem (is_open_ne.mem_nhds h)

lemma dslope_eventually_eq_slope_punctured_nhds (f : 𝕜 → E) : dslope f a =ᶠ[𝓝[≠] a] slope f a :=
(eq_on_dslope_slope f a).eventually_eq_of_mem self_mem_nhds_within

@[simp] lemma sub_smul_dslope (f : 𝕜 → E) (a b : 𝕜) : (b - a) • dslope f a b = f b - f a :=
by rcases eq_or_ne b a with rfl | hne; simp [dslope_of_ne, *]

lemma dslope_sub_smul_of_ne (f : 𝕜 → E) (h : b ≠ a) : dslope (λ x, (x - a) • f x) a b = f b :=
by rw [dslope_of_ne _ h, slope_sub_smul _ h.symm]

lemma eq_on_dslope_sub_smul (f : 𝕜 → E) (a : 𝕜) : eq_on (dslope (λ x, (x - a) • f x) a) f {a}ᶜ :=
λ b, dslope_sub_smul_of_ne f

lemma dslope_sub_smul [decidable_eq 𝕜] (f : 𝕜 → E) (a : 𝕜) :
  dslope (λ x, (x - a) • f x) a = update f a (deriv (λ x, (x - a) • f x) a) :=
eq_update_iff.2 ⟨dslope_same _ _, eq_on_dslope_sub_smul f a⟩

@[simp] lemma continuous_at_dslope_same : continuous_at (dslope f a) a ↔ differentiable_at 𝕜 f a :=
by simp only [dslope, continuous_at_update_same, ← has_deriv_at_deriv_iff,
  has_deriv_at_iff_tendsto_slope]

lemma continuous_within_at.of_dslope (h : continuous_within_at (dslope f a) s b) :
  continuous_within_at f s b :=
have continuous_within_at (λ x, (x - a) • dslope f a x + f a) s b,
  from ((continuous_within_at_id.sub continuous_within_at_const).smul h).add
    continuous_within_at_const,
by simpa only [sub_smul_dslope, sub_add_cancel] using this

lemma continuous_at.of_dslope (h : continuous_at (dslope f a) b) : continuous_at f b :=
(continuous_within_at_univ _ _).1 h.continuous_within_at.of_dslope

lemma continuous_on.of_dslope (h : continuous_on (dslope f a) s) : continuous_on f s :=
λ x hx, (h x hx).of_dslope

lemma continuous_within_at_dslope_of_ne (h : b ≠ a) :
  continuous_within_at (dslope f a) s b ↔ continuous_within_at f s b :=
begin
  refine ⟨continuous_within_at.of_dslope, λ hc, _⟩,
  simp only [dslope, continuous_within_at_update_of_ne h],
  exact ((continuous_within_at_id.sub continuous_within_at_const).inv₀
      (sub_ne_zero.2 h)).smul (hc.sub continuous_within_at_const)
end

lemma continuous_at_dslope_of_ne (h : b ≠ a) : continuous_at (dslope f a) b ↔ continuous_at f b :=
by simp only [← continuous_within_at_univ, continuous_within_at_dslope_of_ne h]

lemma continuous_on_dslope (h : s ∈ 𝓝 a) :
  continuous_on (dslope f a) s ↔ continuous_on f s ∧ differentiable_at 𝕜 f a :=
begin
  refine ⟨λ hc, ⟨hc.of_dslope, continuous_at_dslope_same.1 $ hc.continuous_at h⟩, _⟩,
  rintro ⟨hc, hd⟩ x hx,
  rcases eq_or_ne x a with rfl | hne,
  exacts [(continuous_at_dslope_same.2 hd).continuous_within_at,
    (continuous_within_at_dslope_of_ne hne).2 (hc x hx)]
end

lemma differentiable_within_at.of_dslope (h : differentiable_within_at 𝕜 (dslope f a) s b) :
  differentiable_within_at 𝕜 f s b :=
by simpa only [id, sub_smul_dslope f a, sub_add_cancel]
  using ((differentiable_within_at_id.sub_const a).smul h).add_const (f a)

lemma differentiable_at.of_dslope (h : differentiable_at 𝕜 (dslope f a) b) :
  differentiable_at 𝕜 f b :=
differentiable_within_at_univ.1 h.differentiable_within_at.of_dslope

lemma differentiable_on.of_dslope (h : differentiable_on 𝕜 (dslope f a) s) :
  differentiable_on 𝕜 f s :=
λ x hx, (h x hx).of_dslope

lemma differentiable_within_at_dslope_of_ne (h : b ≠ a) :
  differentiable_within_at 𝕜 (dslope f a) s b ↔ differentiable_within_at 𝕜 f s b :=
begin
  refine ⟨differentiable_within_at.of_dslope, λ hd, _⟩,
  refine (((differentiable_within_at_id.sub_const a).inv
    (sub_ne_zero.2 h)).smul (hd.sub_const (f a))).congr_of_eventually_eq _ (dslope_of_ne _ h),
  refine (eq_on_dslope_slope _ _).eventually_eq_of_mem _,
  exact mem_nhds_within_of_mem_nhds (is_open_ne.mem_nhds h)
end

lemma differentiable_on_dslope_of_nmem (h : a ∉ s) :
  differentiable_on 𝕜 (dslope f a) s ↔ differentiable_on 𝕜 f s :=
forall_congr $ λ x, forall_congr $ λ hx, differentiable_within_at_dslope_of_ne $
  ne_of_mem_of_not_mem hx h

lemma differentiable_at_dslope_of_ne (h : b ≠ a) :
  differentiable_at 𝕜 (dslope f a) b ↔ differentiable_at 𝕜 f b :=
by simp only [← differentiable_within_at_univ,
  differentiable_within_at_dslope_of_ne h]


-- Estudante: Lucas Emanuel Resck Domingues

open set

variable U : Type
variables A B : set U

lemma eq_of_subset_of_subset {U : Type} {A B : set U} (h1 : A ⊆ B) (h2 : B ⊆ A): A = B := sorry

lemma first {U : Type} {A B : set U}: powerset (A ∩ B) ⊆ powerset A ∩ powerset B :=
    assume X,
    show X ∈ powerset (A ∩ B) → X ∈ powerset A ∩ powerset B, from
        assume h1 : X ∈ powerset (A ∩ B),
            have h2 : ∀ x, x ∈ X → x ∈ A ∩ B, from h1,
            have h3 : ∀ x, x ∈ X → x ∈ A, from
                (assume x,
                    assume h4 : x ∈ X,
                    show x ∈ A, from (h2 x h4).left),
            have h4 : X ∈ powerset A, from h3,
            have h5 : ∀ x, x ∈ X → x ∈ B, from
                (assume x,
                    assume h6 : x ∈ X,
                    show x ∈ B, from (h2 x h6).right),
            have h6 : X ∈ powerset B, from h5,
        show X ∈ powerset A ∩ powerset B, from and.intro h4 h6

lemma second {U : Type} {A B : set U}: powerset A ∩ powerset B ⊆ powerset (A ∩ B) :=
    assume X,
        assume h1 : X ∈ powerset A ∩ powerset B,
            have h2 : ∀ x, x ∈ X → x ∈ A, from h1.left,
            have h3 : ∀ x, x ∈ X → x ∈ B, from h1.right,
            have h4 : ∀ x, x ∈ X → x ∈ A ∩ B, from
                (assume x,
                    assume h5 : x ∈ X,
                        have h6 : x ∈ A, from h2 x h5,
                        have h7 : x ∈ B, from h3 x h5,
                    show x ∈ A ∩ B, from and.intro h6 h7),
        show X ∈ powerset (A ∩ B), from h4

theorem exercise : powerset (A ∩ B) = powerset A ∩ powerset B :=
    eq_of_subset_of_subset
        first
        second


/-
Copyright (c) 2019 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Benjamin Davidson
-/
import analysis.special_functions.integrals
/-!
# Pi

This file contains lemmas which establish bounds on or approximations of `real.pi`. Notably, these
include `pi_gt_sqrt_two_add_series` and `pi_lt_sqrt_two_add_series`, which bound `π` using series;
numerical bounds on `π` such as `pi_gt_314`and `pi_lt_315` (more precise versions are given, too);
and exact (infinite) formulas involving `π`, such as `tendsto_sum_pi_div_four`, Leibniz's
series for `π`, and `tendsto_prod_pi_div_two`, the Wallis product for `π`.
-/

open_locale real
namespace real

lemma pi_gt_sqrt_two_add_series (n : ℕ) : 2 ^ (n+1) * sqrt (2 - sqrt_two_add_series 0 n) < π :=
begin
  have : sqrt (2 - sqrt_two_add_series 0 n) / 2 * 2 ^ (n+2) < π,
  { rw [← lt_div_iff, ←sin_pi_over_two_pow_succ], apply sin_lt, apply div_pos pi_pos,
    all_goals { apply pow_pos, norm_num } },
  apply lt_of_le_of_lt (le_of_eq _) this,
  rw [pow_succ _ (n+1), ←mul_assoc, div_mul_cancel, mul_comm], norm_num
end

lemma pi_lt_sqrt_two_add_series (n : ℕ) :
  π < 2 ^ (n+1) * sqrt (2 - sqrt_two_add_series 0 n) + 1 / 4 ^ n :=
begin
  have : π < (sqrt (2 - sqrt_two_add_series 0 n) / 2 + 1 / (2 ^ n) ^ 3 / 4) * 2 ^ (n+2),
  { rw [← div_lt_iff, ← sin_pi_over_two_pow_succ],
    refine lt_of_lt_of_le (lt_add_of_sub_right_lt (sin_gt_sub_cube _ _)) _,
    { apply div_pos pi_pos, apply pow_pos, norm_num },
    { rw div_le_iff',
      { refine le_trans pi_le_four _,
        simp only [show ((4 : ℝ) = 2 ^ 2), by norm_num, mul_one],
        apply pow_le_pow, norm_num, apply le_add_of_nonneg_left, apply nat.zero_le },
        { apply pow_pos, norm_num }},
    apply add_le_add_left, rw div_le_div_right,
    rw [le_div_iff, ←mul_pow],
    refine le_trans _ (le_of_eq (one_pow 3)), apply pow_le_pow_of_le_left,
    { apply le_of_lt, apply mul_pos, apply div_pos pi_pos, apply pow_pos, norm_num, apply pow_pos,
      norm_num },
    rw ← le_div_iff,
    refine le_trans ((div_le_div_right _).mpr pi_le_four) _, apply pow_pos, norm_num,
    rw [pow_succ, pow_succ, ←mul_assoc, ←div_div_eq_div_mul],
    convert le_refl _,
    all_goals { repeat {apply pow_pos}, norm_num }},
  apply lt_of_lt_of_le this (le_of_eq _), rw [add_mul], congr' 1,
  { rw [pow_succ _ (n+1), ←mul_assoc, div_mul_cancel, mul_comm], norm_num },
  rw [pow_succ, ←pow_mul, mul_comm n 2, pow_mul, show (2 : ℝ) ^ 2 = 4, by norm_num, pow_succ,
      pow_succ, ←mul_assoc (2 : ℝ), show (2 : ℝ) * 2 = 4, by norm_num, ←mul_assoc, div_mul_cancel,
      mul_comm ((2 : ℝ) ^ n), ←div_div_eq_div_mul, div_mul_cancel],
  apply pow_ne_zero, norm_num, norm_num
end

/-- From an upper bound on `sqrt_two_add_series 0 n = 2 cos (π / 2 ^ (n+1))` of the form
`sqrt_two_add_series 0 n ≤ 2 - (a / 2 ^ (n + 1)) ^ 2)`, one can deduce the lower bound `a < π`
thanks to basic trigonometric inequalities as expressed in `pi_gt_sqrt_two_add_series`. -/
theorem pi_lower_bound_start (n : ℕ) {a}
  (h : sqrt_two_add_series ((0:ℕ) / (1:ℕ)) n ≤ 2 - (a / 2 ^ (n + 1)) ^ 2) : a < π :=
begin
  refine lt_of_le_of_lt _ (pi_gt_sqrt_two_add_series n), rw [mul_comm],
  refine (div_le_iff (pow_pos (by norm_num) _ : (0 : ℝ) < _)).mp (le_sqrt_of_sq_le _),
  rwa [le_sub, show (0:ℝ) = (0:ℕ)/(1:ℕ), by rw [nat.cast_zero, zero_div]],
end

lemma sqrt_two_add_series_step_up (c d : ℕ) {a b n : ℕ} {z : ℝ}
  (hz : sqrt_two_add_series (c/d) n ≤ z) (hb : 0 < b) (hd : 0 < d)
  (h : (2 * b + a) * d ^ 2 ≤ c ^ 2 * b) : sqrt_two_add_series (a/b) (n+1) ≤ z :=
begin
  refine le_trans _ hz, rw sqrt_two_add_series_succ, apply sqrt_two_add_series_monotone_left,
  have hb' : 0 < (b:ℝ) := nat.cast_pos.2 hb,
  have hd' : 0 < (d:ℝ) := nat.cast_pos.2 hd,
  rw [sqrt_le_left (div_nonneg c.cast_nonneg d.cast_nonneg), div_pow,
    add_div_eq_mul_add_div _ _ (ne_of_gt hb'), div_le_div_iff hb' (pow_pos hd' _)],
  exact_mod_cast h
end

/-- Create a proof of `a < π` for a fixed rational number `a`, given a witness, which is a
sequence of rational numbers `sqrt 2 < r 1 < r 2 < ... < r n < 2` satisfying the property that
`sqrt (2 + r i) ≤ r(i+1)`, where `r 0 = 0` and `sqrt (2 - r n) ≥ a/2^(n+1)`. -/
meta def pi_lower_bound (l : list ℚ) : tactic unit :=
do let n := l.length,
  tactic.apply `(@pi_lower_bound_start %%(reflect n)),
  l.mmap' (λ r, do
    let a := r.num.to_nat, let b := r.denom,
    (() <$ tactic.apply `(@sqrt_two_add_series_step_up %%(reflect a) %%(reflect b)));
    [tactic.skip, `[norm_num1], `[norm_num1], `[norm_num1]]),
  `[simp only [sqrt_two_add_series, nat.cast_bit0, nat.cast_bit1, nat.cast_one, nat.cast_zero]],
  `[norm_num1]

/-- From a lower bound on `sqrt_two_add_series 0 n = 2 cos (π / 2 ^ (n+1))` of the form
`2 - ((a - 1 / 4 ^ n) / 2 ^ (n + 1)) ^ 2 ≤ sqrt_two_add_series 0 n`, one can deduce the upper bound
`π < a` thanks to basic trigonometric formulas as expressed in `pi_lt_sqrt_two_add_series`. -/
theorem pi_upper_bound_start (n : ℕ) {a}
  (h : 2 - ((a - 1 / 4 ^ n) / 2 ^ (n + 1)) ^ 2 ≤ sqrt_two_add_series ((0:ℕ) / (1:ℕ)) n)
  (h₂ : 1 / 4 ^ n ≤ a) : π < a :=
begin
  refine lt_of_lt_of_le (pi_lt_sqrt_two_add_series n) _,
  rw [← le_sub_iff_add_le, ← le_div_iff', sqrt_le_left, sub_le],
  { rwa [nat.cast_zero, zero_div] at h },
  { exact div_nonneg (sub_nonneg.2 h₂) (pow_nonneg (le_of_lt zero_lt_two) _) },
  { exact pow_pos zero_lt_two _ }
end

lemma sqrt_two_add_series_step_down (a b : ℕ) {c d n : ℕ} {z : ℝ}
  (hz : z ≤ sqrt_two_add_series (a/b) n) (hb : 0 < b) (hd : 0 < d)
  (h : a ^ 2 * d ≤ (2 * d + c) * b ^ 2) : z ≤ sqrt_two_add_series (c/d) (n+1) :=
begin
  apply le_trans hz, rw sqrt_two_add_series_succ, apply sqrt_two_add_series_monotone_left,
  apply le_sqrt_of_sq_le,
  have hb' : 0 < (b:ℝ) := nat.cast_pos.2 hb,
  have hd' : 0 < (d:ℝ) := nat.cast_pos.2 hd,
  rw [div_pow, add_div_eq_mul_add_div _ _ (ne_of_gt hd'), div_le_div_iff (pow_pos hb' _) hd'],
  exact_mod_cast h
end

/-- Create a proof of `π < a` for a fixed rational number `a`, given a witness, which is a
sequence of rational numbers `sqrt 2 < r 1 < r 2 < ... < r n < 2` satisfying the property that
`sqrt (2 + r i) ≥ r(i+1)`, where `r 0 = 0` and `sqrt (2 - r n) ≥ (a - 1/4^n) / 2^(n+1)`. -/
meta def pi_upper_bound (l : list ℚ) : tactic unit :=
do let n := l.length,
  (() <$ tactic.apply `(@pi_upper_bound_start %%(reflect n))); [pure (), `[norm_num1]],
  l.mmap' (λ r, do
    let a := r.num.to_nat, let b := r.denom,
    (() <$ tactic.apply `(@sqrt_two_add_series_step_down %%(reflect a) %%(reflect b)));
    [pure (), `[norm_num1], `[norm_num1], `[norm_num1]]),
  `[simp only [sqrt_two_add_series, nat.cast_bit0, nat.cast_bit1, nat.cast_one, nat.cast_zero]],
  `[norm_num]

lemma pi_gt_three : 3 < π := by pi_lower_bound [23/16]

lemma pi_gt_314 : 3.14 < π := by pi_lower_bound [99/70, 874/473, 1940/989, 1447/727]

lemma pi_lt_315 : π < 3.15 := by pi_upper_bound [140/99, 279/151, 51/26, 412/207]

lemma pi_gt_31415 : 3.1415 < π := by pi_lower_bound [
  11482/8119, 5401/2923, 2348/1197, 11367/5711, 25705/12868, 23235/11621]

lemma pi_lt_31416 : π < 3.1416 := by pi_upper_bound [
  4756/3363, 101211/54775, 505534/257719, 83289/41846,
  411278/205887, 438142/219137, 451504/225769, 265603/132804, 849938/424971]

lemma pi_gt_3141592 : 3.141592 < π := by pi_lower_bound [
  11482/8119, 7792/4217, 54055/27557, 949247/476920, 3310126/1657059,
  2635492/1318143, 1580265/790192, 1221775/610899, 3612247/1806132, 849943/424972]

lemma pi_lt_3141593 : π < 3.141593 := by pi_upper_bound [
  27720/19601, 56935/30813, 49359/25163, 258754/130003, 113599/56868, 1101994/551163,
  8671537/4336095, 3877807/1938940, 52483813/26242030, 56946167/28473117, 23798415/11899211]

/-! ### Leibniz's Series for Pi -/

open filter set
open_locale classical big_operators topological_space
local notation `|`x`|` := abs x

/-- This theorem establishes Leibniz's series for `π`: The alternating sum of the reciprocals of the
  odd numbers is `π/4`. Note that this is a conditionally rather than absolutely convergent series.
  The main tool that this proof uses is the Mean Value Theorem (specifically avoiding the
  Fundamental Theorem of Calculus).

  Intuitively, the theorem holds because Leibniz's series is the Taylor series of `arctan x`
  centered about `0` and evaluated at the value `x = 1`. Therefore, much of this proof consists of
  reasoning about a function
    `f := arctan x - ∑ i in finset.range k, (-(1:ℝ))^i * x^(2*i+1) / (2*i+1)`,
  the difference between `arctan` and the `k`-th partial sum of its Taylor series. Some ingenuity is
  required due to the fact that the Taylor series is not absolutely convergent at `x = 1`.

  This proof requires a bound on `f 1`, the key idea being that `f 1` can be split as the sum of
  `f 1 - f u` and `f u`, where `u` is a sequence of values in [0,1], carefully chosen such that
  each of these two terms can be controlled (in different ways).

  We begin the proof by (1) introducing that sequence `u` and then proving that another sequence
  constructed from `u` tends to `0` at `+∞`. After (2) converting the limit in our goal to an
  inequality, we (3) introduce the auxiliary function `f` defined above. Next, we (4) compute the
  derivative of `f`, denoted by `f'`, first generally and then on each of two subintervals of [0,1].
  We then (5) prove a bound for `f'`, again both generally as well as on each of the two
  subintervals. Finally, we (6) apply the Mean Value Theorem twice, obtaining bounds on `f 1 - f u`
  and `f u - f 0` from the bounds on `f'` (note that `f 0 = 0`). -/
theorem tendsto_sum_pi_div_four :
  tendsto (λ k, ∑ i in finset.range k, ((-(1:ℝ))^i / (2*i+1))) at_top (𝓝 (π/4)) :=
begin
  rw [tendsto_iff_norm_tendsto_zero, ← tendsto_zero_iff_norm_tendsto_zero],
  -- (1) We introduce a useful sequence `u` of values in [0,1], then prove that another sequence
  --     constructed from `u` tends to `0` at `+∞`
  let u := λ k : ℕ, (k:nnreal) ^ (-1 / (2 * (k:ℝ) + 1)),
  have H : tendsto (λ k : ℕ, (1:ℝ) - (u k) + (u k) ^ (2 * (k:ℝ) + 1)) at_top (𝓝 0),
  { convert (((tendsto_rpow_div_mul_add (-1) 2 1 $ by norm_num).neg.const_add 1).add
      tendsto_inv_at_top_zero).comp tendsto_coe_nat_at_top_at_top,
    { ext k,
      simp only [nnreal.coe_nat_cast, function.comp_app, nnreal.coe_rpow],
      rw [← rpow_mul (nat.cast_nonneg k) ((-1)/(2*(k:ℝ)+1)) (2*(k:ℝ)+1),
          @div_mul_cancel _ _ _ (2*(k:ℝ)+1) (by { norm_cast, linarith }), rpow_neg_one k],
      ring },
    { simp } },
  -- (2) We convert the limit in our goal to an inequality
  refine squeeze_zero_norm _ H,
  intro k,
  -- Since `k` is now fixed, we henceforth denote `u k` as `U`
  let U := u k,
  -- (3) We introduce an auxiliary function `f`
  let b := λ (i:ℕ) x, (-(1:ℝ))^i * x^(2*i+1) / (2*i+1),
  let f := λ x, arctan x - (∑ i in finset.range k, b i x),
  suffices f_bound : |f 1 - f 0| ≤ (1:ℝ) - U + U ^ (2 * (k:ℝ) + 1),
  { rw ← norm_neg,
    convert f_bound,
    simp only [f], simp [b] },
  -- We show that `U` is indeed in [0,1]
  have hU1 : (U:ℝ) ≤ 1,
  { by_cases hk : k = 0,
    { simpa only [U, hk] using zero_rpow_le_one _ },
    { exact rpow_le_one_of_one_le_of_nonpos (by { norm_cast, exact nat.succ_le_iff.mpr
        (nat.pos_of_ne_zero hk) }) (le_of_lt (@div_neg_of_neg_of_pos _ _ (-(1:ℝ)) (2*k+1)
          (by norm_num) (by { norm_cast, linarith }))) } },
  have hU2 := nnreal.coe_nonneg U,
  -- (4) We compute the derivative of `f`, denoted by `f'`
  let f' := λ x : ℝ, (-x^2) ^ k / (1 + x^2),
  have has_deriv_at_f : ∀ x, has_deriv_at f (f' x) x,
  { intro x,
    have has_deriv_at_b : ∀ i ∈ finset.range k, (has_deriv_at (b i) ((-x^2)^i) x),
    { intros i hi,
      convert has_deriv_at.const_mul ((-1:ℝ)^i / (2*i+1)) (@has_deriv_at.pow _ _ _ _ _ (2*i+1)
        (has_deriv_at_id x)),
      { ext y,
        simp only [b, id.def],
        ring },
      { simp only [nat.add_succ_sub_one, add_zero, mul_one, id.def, nat.cast_bit0, nat.cast_add,
                  nat.cast_one, nat.cast_mul],
        rw [← mul_assoc, @div_mul_cancel _ _ _ (2*(i:ℝ)+1) (by { norm_cast, linarith }),
            pow_mul x 2 i, ← mul_pow (-1) (x^2) i],
        ring_nf } },
    convert (has_deriv_at_arctan x).sub (has_deriv_at.sum has_deriv_at_b),
    have g_sum := @geom_sum_eq _ _ (-x^2) (by linarith [neg_nonpos.mpr (sq_nonneg x)]) k,
    simp only [geom_sum, f'] at g_sum ⊢,
    rw [g_sum, ← neg_add' (x^2) 1, add_comm (x^2) 1, sub_eq_add_neg, neg_div', neg_div_neg_eq],
    ring },
  have hderiv1 : ∀ x ∈ Icc (U:ℝ) 1, has_deriv_within_at f (f' x) (Icc (U:ℝ) 1) x :=
    λ x hx, (has_deriv_at_f x).has_deriv_within_at,
  have hderiv2 : ∀ x ∈ Icc 0 (U:ℝ), has_deriv_within_at f (f' x) (Icc 0 (U:ℝ)) x :=
    λ x hx, (has_deriv_at_f x).has_deriv_within_at,
  -- (5) We prove a general bound for `f'` and then more precise bounds on each of two subintervals
  have f'_bound : ∀ x ∈ Icc (-1:ℝ) 1, |f' x| ≤ |x|^(2*k),
  { intros x hx,
    rw [abs_div, is_absolute_value.abv_pow abs (-x^2) k, abs_neg, is_absolute_value.abv_pow abs x 2,
        tactic.ring_exp.pow_e_pf_exp rfl rfl, @abs_of_pos _ _ (1+x^2) (by nlinarith)],
    convert @div_le_div_of_le_left _ _ _ (1+x^2) 1 (pow_nonneg (abs_nonneg x) (2*k)) (by norm_num)
      (by nlinarith),
    simp },
  have hbound1 : ∀ x ∈ Ico (U:ℝ) 1, |f' x| ≤ 1,
  { rintros x ⟨hx_left, hx_right⟩,
    have hincr := pow_le_pow_of_le_left (le_trans hU2 hx_left) (le_of_lt hx_right) (2*k),
    rw [one_pow (2*k), ← abs_of_nonneg (le_trans hU2 hx_left)] at hincr,
    rw ← abs_of_nonneg (le_trans hU2 hx_left) at hx_right,
    linarith [f'_bound x (mem_Icc.mpr (abs_le.mp (le_of_lt hx_right)))] },
  have hbound2 : ∀ x ∈ Ico 0 (U:ℝ), |f' x| ≤ U ^ (2*k),
  { rintros x ⟨hx_left, hx_right⟩,
    have hincr := pow_le_pow_of_le_left hx_left (le_of_lt hx_right) (2*k),
    rw ← abs_of_nonneg hx_left at hincr hx_right,
    rw ← abs_of_nonneg hU2 at hU1 hx_right,
    linarith [f'_bound x (mem_Icc.mpr (abs_le.mp (le_trans (le_of_lt hx_right) hU1)))] },
  -- (6) We twice apply the Mean Value Theorem to obtain bounds on `f` from the bounds on `f'`
  have mvt1 :=
    norm_image_sub_le_of_norm_deriv_le_segment' hderiv1 hbound1 _ (right_mem_Icc.mpr hU1),
  have mvt2 :=
    norm_image_sub_le_of_norm_deriv_le_segment' hderiv2 hbound2 _ (right_mem_Icc.mpr hU2),
  -- The following algebra is enough to complete the proof
  calc |f 1 - f 0| = |(f 1 - f U) + (f U - f 0)| : by ring_nf
               ... ≤ 1 * (1-U) + U^(2*k) * (U - 0) : le_trans (abs_add (f 1 - f U) (f U - f 0))
                                                      (add_le_add mvt1 mvt2)
               ... = 1 - U + U^(2*k) * U : by ring
               ... = 1 - (u k) + (u k)^(2*(k:ℝ)+1) : by { rw [← pow_succ' (U:ℝ) (2*k)], norm_cast },
end

/-! ### The Wallis Product for Pi -/

open finset interval_integral

lemma integral_sin_pow_div_tendsto_one :
  tendsto (λ k, (∫ x in 0..π, sin x ^ (2 * k + 1)) / ∫ x in 0..π, sin x ^ (2 * k)) at_top (𝓝 1) :=
begin
  have h₃ : ∀ n, (∫ x in 0..π, sin x ^ (2 * n + 1)) / ∫ x in 0..π, sin x ^ (2 * n) ≤ 1 :=
    λ n, (div_le_one (integral_sin_pow_pos _)).mpr (integral_sin_pow_antimono _),
  have h₄ :
    ∀ n, (∫ x in 0..π, sin x ^ (2 * n + 1)) / ∫ x in 0..π, sin x ^ (2 * n) ≥ 2 * n / (2 * n + 1),
  { rintro ⟨n⟩,
    { have : 0 ≤ (1 + 1) / π, exact div_nonneg (by norm_num) pi_pos.le,
      simp [this] },
    calc (∫ x in 0..π, sin x ^ (2 * n.succ + 1)) / ∫ x in 0..π, sin x ^ (2 * n.succ) ≥
      (∫ x in 0..π, sin x ^ (2 * n.succ + 1)) / ∫ x in 0..π, sin x ^ (2 * n + 1) :
      by { refine div_le_div (integral_sin_pow_pos _).le (le_refl _) (integral_sin_pow_pos _) _,
        convert integral_sin_pow_antimono (2 * n + 1) using 1 }
    ... = 2 * ↑(n.succ) / (2 * ↑(n.succ) + 1) :
      by { rw div_eq_iff (integral_sin_pow_pos (2 * n + 1)).ne',
           convert integral_sin_pow (2 * n + 1), simp with field_simps, norm_cast } },
  refine tendsto_of_tendsto_of_tendsto_of_le_of_le _ _ (λ n, (h₄ n).le) (λ n, (h₃ n)),
  { refine metric.tendsto_at_top.mpr (λ ε hε, ⟨nat_ceil (1 / ε), λ n hn, _⟩),
    have h : (2:ℝ) * n / (2 * n + 1) - 1 = -1 / (2 * n + 1),
    { conv_lhs { congr, skip, rw ← @div_self _ _ ((2:ℝ) * n + 1) (by { norm_cast, linarith }), },
      rw [← sub_div, ← sub_sub, sub_self, zero_sub] },
    have hpos : (0:ℝ) < 2 * n + 1, { norm_cast, norm_num },
    rw [dist_eq, h, abs_div, abs_neg, abs_one, abs_of_pos hpos, one_div_lt hpos hε],
    calc 1 / ε ≤ nat_ceil (1 / ε) : le_nat_ceil _
          ... ≤ n : by exact_mod_cast hn.le
          ... < 2 * n + 1 : by { norm_cast, linarith } },
  { exact tendsto_const_nhds },
end

/-- This theorem establishes the Wallis Product for `π`. Our proof is largely about analyzing
  the behavior of the ratio of the integral of `sin x ^ n` as `n → ∞`.
  See: https://en.wikipedia.org/wiki/Wallis_product

  The proof can be broken down into two pieces.
  (Pieces involving general properties of the integral of `sin x ^n` can be found
  in `analysis.special_functions.integrals`.) First, we use integration by parts to obtain a
  recursive formula for `∫ x in 0..π, sin x ^ (n + 2)` in terms of `∫ x in 0..π, sin x ^ n`.
  From this we can obtain closed form products of `∫ x in 0..π, sin x ^ (2 * n)` and
  `∫ x in 0..π, sin x ^ (2 * n + 1)` via induction. Next, we study the behavior of the ratio
  `∫ (x : ℝ) in 0..π, sin x ^ (2 * k + 1)) / ∫ (x : ℝ) in 0..π, sin x ^ (2 * k)` and prove that
  it converges to one using the squeeze theorem. The final product for `π` is obtained after some
  algebraic manipulation. -/
theorem tendsto_prod_pi_div_two :
  tendsto (λ k, ∏ i in range k,
    (((2:ℝ) * i + 2) / (2 * i + 1)) * ((2 * i + 2) / (2 * i + 3))) at_top (𝓝 (π/2)) :=
begin
  suffices h : tendsto (λ k, 2 / π  * ∏ i in range k,
    (((2:ℝ) * i + 2) / (2 * i + 1)) * ((2 * i + 2) / (2 * i + 3))) at_top (𝓝 1),
  { have := tendsto.const_mul (π / 2) h,
    have h : π / 2 ≠ 0, norm_num [pi_ne_zero],
    simp only [← mul_assoc, ← @inv_div _ _ π 2, mul_inv_cancel h, one_mul, mul_one] at this,
    exact this },
  have h : (λ (k : ℕ), (2:ℝ) / π * ∏ (i : ℕ) in range k,
    ((2 * i + 2) / (2 * i + 1)) * ((2 * i + 2) / (2 * i + 3))) =
  λ k, (2 * ∏ i in range k,
    (2 * i + 2) / (2 * i + 3)) / (π * ∏ (i : ℕ) in range k, (2 * i + 1) / (2 * i + 2)),
  { funext,
    have h : ∏ (i : ℕ) in range k, ((2:ℝ) * ↑i + 2) / (2 * ↑i + 1) =
      1 / (∏ (i : ℕ) in range k, (2 * ↑i + 1) / (2 * ↑i + 2)),
    { rw [one_div, ← finset.prod_inv_distrib'],
      refine prod_congr rfl (λ x hx, _),
      field_simp },
    rw [prod_mul_distrib, h],
    field_simp },
  simp only [h, ← integral_sin_pow_even, ← integral_sin_pow_odd],
  exact integral_sin_pow_div_tendsto_one,
end

end real


/-
Copyright (c) 2020 Thomas Browning. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning
-/

import algebra.gcd_monoid.multiset
import combinatorics.partition
import data.list.rotate
import group_theory.perm.cycle.basic
import ring_theory.int.basic
import tactic.linarith

/-!
# Cycle Types

In this file we define the cycle type of a permutation.

## Main definitions

- `σ.cycle_type` where `σ` is a permutation of a `fintype`
- `σ.partition` where `σ` is a permutation of a `fintype`

## Main results

- `sum_cycle_type` : The sum of `σ.cycle_type` equals `σ.support.card`
- `lcm_cycle_type` : The lcm of `σ.cycle_type` equals `order_of σ`
- `is_conj_iff_cycle_type_eq` : Two permutations are conjugate if and only if they have the same
  cycle type.
- `exists_prime_order_of_dvd_card`: For every prime `p` dividing the order of a finite group `G`
  there exists an element of order `p` in `G`. This is known as Cauchy's theorem.
-/

namespace equiv.perm
open equiv list multiset

variables {α : Type*} [fintype α]

section cycle_type

variables [decidable_eq α]

/-- The cycle type of a permutation -/
def cycle_type (σ : perm α) : multiset ℕ :=
σ.cycle_factors_finset.1.map (finset.card ∘ support)

lemma cycle_type_def (σ : perm α) :
  σ.cycle_type = σ.cycle_factors_finset.1.map (finset.card ∘ support) := rfl

lemma cycle_type_eq' {σ : perm α} (s : finset (perm α))
  (h1 : ∀ f : perm α, f ∈ s → f.is_cycle) (h2 : (s : set (perm α)).pairwise disjoint)
  (h0 : s.noncomm_prod id (h2.imp $ λ _ _, disjoint.commute) = σ) :
  σ.cycle_type = s.1.map (finset.card ∘ support) :=
begin
  rw cycle_type_def,
  congr,
  rw cycle_factors_finset_eq_finset,
  exact ⟨h1, h2, h0⟩
end

lemma cycle_type_eq {σ : perm α} (l : list (perm α)) (h0 : l.prod = σ)
  (h1 : ∀ σ : perm α, σ ∈ l → σ.is_cycle) (h2 : l.pairwise disjoint) :
  σ.cycle_type = l.map (finset.card ∘ support) :=
begin
  have hl : l.nodup := nodup_of_pairwise_disjoint_cycles h1 h2,
  rw cycle_type_eq' l.to_finset,
  { simp [list.dedup_eq_self.mpr hl] },
  { simpa using h1 },
  { simpa [hl] using h0 },
  { simpa [list.dedup_eq_self.mpr hl] using h2.forall disjoint.symmetric }
end

lemma cycle_type_one : (1 : perm α).cycle_type = 0 :=
cycle_type_eq [] rfl (λ _, false.elim) pairwise.nil

lemma cycle_type_eq_zero {σ : perm α} : σ.cycle_type = 0 ↔ σ = 1 :=
by simp [cycle_type_def, cycle_factors_finset_eq_empty_iff]

lemma card_cycle_type_eq_zero {σ : perm α} : σ.cycle_type.card = 0 ↔ σ = 1 :=
by rw [card_eq_zero, cycle_type_eq_zero]

lemma two_le_of_mem_cycle_type {σ : perm α} {n : ℕ} (h : n ∈ σ.cycle_type) : 2 ≤ n :=
begin
  simp only [cycle_type_def, ←finset.mem_def, function.comp_app, multiset.mem_map,
    mem_cycle_factors_finset_iff] at h,
  obtain ⟨_, ⟨hc, -⟩, rfl⟩ := h,
  exact hc.two_le_card_support
end

lemma one_lt_of_mem_cycle_type {σ : perm α} {n : ℕ} (h : n ∈ σ.cycle_type) : 1 < n :=
two_le_of_mem_cycle_type h

lemma is_cycle.cycle_type {σ : perm α} (hσ : is_cycle σ) : σ.cycle_type = [σ.support.card] :=
cycle_type_eq [σ] (mul_one σ) (λ τ hτ, (congr_arg is_cycle (list.mem_singleton.mp hτ)).mpr hσ)
  (pairwise_singleton disjoint σ)

lemma card_cycle_type_eq_one {σ : perm α} : σ.cycle_type.card = 1 ↔ σ.is_cycle :=
begin
  rw card_eq_one,
  simp_rw [cycle_type_def, multiset.map_eq_singleton, ←finset.singleton_val,
           finset.val_inj, cycle_factors_finset_eq_singleton_iff],
  split,
  { rintro ⟨_, _, ⟨h, -⟩, -⟩,
    exact h },
  { intro h,
    use [σ.support.card, σ],
    simp [h] }
end

lemma disjoint.cycle_type {σ τ : perm α} (h : disjoint σ τ) :
  (σ * τ).cycle_type = σ.cycle_type + τ.cycle_type :=
begin
  rw [cycle_type_def, cycle_type_def, cycle_type_def, h.cycle_factors_finset_mul_eq_union,
      ←multiset.map_add, finset.union_val, multiset.add_eq_union_iff_disjoint.mpr _],
  exact finset.disjoint_val.2 h.disjoint_cycle_factors_finset
end

lemma cycle_type_inv (σ : perm α) : σ⁻¹.cycle_type = σ.cycle_type :=
cycle_induction_on (λ τ : perm α, τ⁻¹.cycle_type = τ.cycle_type) σ rfl
  (λ σ hσ, by rw [hσ.cycle_type, hσ.inv.cycle_type, support_inv])
  (λ σ τ hστ hc hσ hτ, by rw [mul_inv_rev, hστ.cycle_type, ←hσ, ←hτ, add_comm,
    disjoint.cycle_type (λ x, or.imp (λ h : τ x = x, inv_eq_iff_eq.mpr h.symm)
    (λ h : σ x = x, inv_eq_iff_eq.mpr h.symm) (hστ x).symm)])

lemma cycle_type_conj {σ τ : perm α} : (τ * σ * τ⁻¹).cycle_type = σ.cycle_type :=
begin
  revert τ,
  apply cycle_induction_on _ σ,
  { intro,
    simp },
  { intros σ hσ τ,
    rw [hσ.cycle_type, hσ.conj.cycle_type, card_support_conj] },
  { intros σ τ hd hc hσ hτ π,
    rw [← conj_mul, hd.cycle_type, disjoint.cycle_type, hσ, hτ],
    intro a,
    apply (hd (π⁻¹ a)).imp _ _;
    { intro h, rw [perm.mul_apply, perm.mul_apply, h, apply_inv_self] } }
end

lemma sum_cycle_type (σ : perm α) : σ.cycle_type.sum = σ.support.card :=
cycle_induction_on (λ τ : perm α, τ.cycle_type.sum = τ.support.card) σ
  (by rw [cycle_type_one, sum_zero, support_one, finset.card_empty])
  (λ σ hσ, by rw [hσ.cycle_type, coe_sum, list.sum_singleton])
  (λ σ τ hστ hc hσ hτ, by rw [hστ.cycle_type, sum_add, hσ, hτ, hστ.card_support_mul])

lemma sign_of_cycle_type' (σ : perm α) :
  sign σ = (σ.cycle_type.map (λ n, -(-1 : ℤˣ) ^ n)).prod :=
cycle_induction_on (λ τ : perm α, sign τ = (τ.cycle_type.map (λ n, -(-1 : ℤˣ) ^ n)).prod) σ
  (by rw [sign_one, cycle_type_one, multiset.map_zero, prod_zero])
  (λ σ hσ, by rw [hσ.sign, hσ.cycle_type, coe_map, coe_prod,
    list.map_singleton, list.prod_singleton])
  (λ σ τ hστ hc hσ hτ, by rw [sign_mul, hσ, hτ, hστ.cycle_type, multiset.map_add, prod_add])

lemma sign_of_cycle_type (f : perm α) :
  sign f = (-1 : ℤˣ)^(f.cycle_type.sum + f.cycle_type.card) :=
cycle_induction_on
  (λ f : perm α, sign f = (-1 : ℤˣ)^(f.cycle_type.sum + f.cycle_type.card))
  f
  ( -- base_one
    by rw [equiv.perm.cycle_type_one, sign_one, multiset.sum_zero, multiset.card_zero, pow_zero] )
  ( -- base_cycles
    λ f hf,
      by rw [equiv.perm.is_cycle.cycle_type hf, hf.sign,
      coe_sum, list.sum_cons, sum_nil, add_zero, coe_card, length_singleton,
      pow_add, pow_one, mul_comm, neg_mul, one_mul] )
  ( -- induction_disjoint
    λ f g hfg hf Pf Pg,
    by rw [equiv.perm.disjoint.cycle_type hfg,
      multiset.sum_add, multiset.card_add,← add_assoc,
      add_comm f.cycle_type.sum g.cycle_type.sum,
      add_assoc g.cycle_type.sum _ _,
      add_comm g.cycle_type.sum _,
      add_assoc, pow_add,
      ← Pf, ← Pg,
      equiv.perm.sign_mul])

lemma lcm_cycle_type (σ : perm α) : σ.cycle_type.lcm = order_of σ :=
cycle_induction_on (λ τ : perm α, τ.cycle_type.lcm = order_of τ) σ
  (by rw [cycle_type_one, lcm_zero, order_of_one])
  (λ σ hσ, by rw [hσ.cycle_type, coe_singleton, lcm_singleton, hσ.order_of,
    normalize_eq])
  (λ σ τ hστ hc hσ hτ, by rw [hστ.cycle_type, lcm_add, lcm_eq_nat_lcm, hστ.order_of, hσ, hτ])

lemma dvd_of_mem_cycle_type {σ : perm α} {n : ℕ} (h : n ∈ σ.cycle_type) : n ∣ order_of σ :=
begin
  rw ← lcm_cycle_type,
  exact dvd_lcm h,
end

lemma order_of_cycle_of_dvd_order_of (f : perm α) (x : α) :
  order_of (cycle_of f x) ∣ order_of f :=
begin
  by_cases hx : f x = x,
  { rw ←cycle_of_eq_one_iff at hx,
    simp [hx] },
  { refine dvd_of_mem_cycle_type _,
    rw [cycle_type, multiset.mem_map],
    refine ⟨f.cycle_of x, _, _⟩,
    { rwa [←finset.mem_def, cycle_of_mem_cycle_factors_finset_iff, mem_support] },
    { simp [(is_cycle_cycle_of _ hx).order_of] } }
end

lemma two_dvd_card_support {σ : perm α} (hσ : σ ^ 2 = 1) : 2 ∣ σ.support.card :=
(congr_arg (has_dvd.dvd 2) σ.sum_cycle_type).mp
  (multiset.dvd_sum (λ n hn, by rw le_antisymm (nat.le_of_dvd zero_lt_two $
  (dvd_of_mem_cycle_type hn).trans $ order_of_dvd_of_pow_eq_one hσ) (two_le_of_mem_cycle_type hn)))

lemma cycle_type_prime_order {σ : perm α} (hσ : (order_of σ).prime) :
  ∃ n : ℕ, σ.cycle_type = replicate (n + 1) (order_of σ) :=
begin
  rw eq_replicate_of_mem (λ n hn, or_iff_not_imp_left.mp
    (hσ.eq_one_or_self_of_dvd n (dvd_of_mem_cycle_type hn)) (one_lt_of_mem_cycle_type hn).ne'),
  use σ.cycle_type.card - 1,
  rw tsub_add_cancel_of_le,
  rw [nat.succ_le_iff, pos_iff_ne_zero, ne, card_cycle_type_eq_zero],
  intro H,
  rw [H, order_of_one] at hσ,
  exact hσ.ne_one rfl,
end

lemma is_cycle_of_prime_order {σ : perm α} (h1 : (order_of σ).prime)
  (h2 : σ.support.card < 2 * (order_of σ)) : σ.is_cycle :=
begin
  obtain ⟨n, hn⟩ := cycle_type_prime_order h1,
  rw [←σ.sum_cycle_type, hn, multiset.sum_replicate, nsmul_eq_mul, nat.cast_id, mul_lt_mul_right
      (order_of_pos σ), nat.succ_lt_succ_iff, nat.lt_succ_iff, le_zero_iff] at h2,
  rw [←card_cycle_type_eq_one, hn, card_replicate, h2],
end

lemma cycle_type_le_of_mem_cycle_factors_finset {f g : perm α}
  (hf : f ∈ g.cycle_factors_finset) :
  f.cycle_type ≤ g.cycle_type :=
begin
  rw mem_cycle_factors_finset_iff at hf,
  rw [cycle_type_def, cycle_type_def, hf.left.cycle_factors_finset_eq_singleton],
  refine map_le_map _,
  simpa [←finset.mem_def, mem_cycle_factors_finset_iff] using hf
end

lemma cycle_type_mul_mem_cycle_factors_finset_eq_sub {f g : perm α}
  (hf : f ∈ g.cycle_factors_finset) :
  (g * f⁻¹).cycle_type = g.cycle_type - f.cycle_type :=
begin
  suffices : (g * f⁻¹).cycle_type + f.cycle_type = g.cycle_type - f.cycle_type + f.cycle_type,
  { rw tsub_add_cancel_of_le (cycle_type_le_of_mem_cycle_factors_finset hf) at this,
    simp [←this] },
  simp [←(disjoint_mul_inv_of_mem_cycle_factors_finset hf).cycle_type,
    tsub_add_cancel_of_le (cycle_type_le_of_mem_cycle_factors_finset hf)]
end

theorem is_conj_of_cycle_type_eq {σ τ : perm α} (h : cycle_type σ = cycle_type τ) : is_conj σ τ :=
begin
  revert τ,
  apply cycle_induction_on _ σ,
  { intros τ h,
    rw [cycle_type_one, eq_comm, cycle_type_eq_zero] at h,
    rw h },
  { intros σ hσ τ hστ,
    have hτ := card_cycle_type_eq_one.2 hσ,
    rw [hστ, card_cycle_type_eq_one] at hτ,
    apply hσ.is_conj hτ,
    rw [hσ.cycle_type, hτ.cycle_type, coe_eq_coe, singleton_perm] at hστ,
    simp only [and_true, eq_self_iff_true] at hστ,
    exact hστ },
  { intros σ τ hστ hσ h1 h2 π hπ,
    rw [hστ.cycle_type] at hπ,
    { have h : σ.support.card ∈ map (finset.card ∘ perm.support) π.cycle_factors_finset.val,
      { simp [←cycle_type_def, ←hπ, hσ.cycle_type] },
      obtain ⟨σ', hσ'l, hσ'⟩ := multiset.mem_map.mp h,
      have key : is_conj (σ' * (π * σ'⁻¹)) π,
      { rw is_conj_iff,
        use σ'⁻¹,
        simp [mul_assoc] },
      refine is_conj.trans _ key,
      have hs : σ.cycle_type = σ'.cycle_type,
      { rw [←finset.mem_def, mem_cycle_factors_finset_iff] at hσ'l,
        rw [hσ.cycle_type, ←hσ', hσ'l.left.cycle_type] },
      refine hστ.is_conj_mul (h1 hs) (h2 _) _,
      { rw [cycle_type_mul_mem_cycle_factors_finset_eq_sub, ←hπ, add_comm, hs,
            add_tsub_cancel_right],
        rwa finset.mem_def },
      { exact (disjoint_mul_inv_of_mem_cycle_factors_finset hσ'l).symm } } }
end

theorem is_conj_iff_cycle_type_eq {σ τ : perm α} :
  is_conj σ τ ↔ σ.cycle_type = τ.cycle_type :=
⟨λ h, begin
  obtain ⟨π, rfl⟩ := is_conj_iff.1 h,
  rw cycle_type_conj,
end, is_conj_of_cycle_type_eq⟩

@[simp] lemma cycle_type_extend_domain {β : Type*} [fintype β] [decidable_eq β]
  {p : β → Prop} [decidable_pred p] (f : α ≃ subtype p) {g : perm α} :
  cycle_type (g.extend_domain f) = cycle_type g :=
begin
  apply cycle_induction_on _ g,
  { rw [extend_domain_one, cycle_type_one, cycle_type_one] },
  { intros σ hσ,
    rw [(hσ.extend_domain f).cycle_type, hσ.cycle_type, card_support_extend_domain] },
  { intros σ τ hd hc hσ hτ,
    rw [hd.cycle_type, ← extend_domain_mul, (hd.extend_domain f).cycle_type, hσ, hτ] }
end

lemma cycle_type_of_subtype {p : α → Prop} [decidable_pred p] {g : perm (subtype p)}:
  cycle_type (g.of_subtype) = cycle_type g := cycle_type_extend_domain (equiv.refl (subtype p))

lemma mem_cycle_type_iff {n : ℕ} {σ : perm α} :
  n ∈ cycle_type σ ↔ ∃ c τ : perm α, σ = c * τ ∧ disjoint c τ ∧ is_cycle c ∧ c.support.card = n :=
begin
  split,
  { intro h,
    obtain ⟨l, rfl, hlc, hld⟩ := trunc_cycle_factors σ,
    rw cycle_type_eq _ rfl hlc hld at h,
    obtain ⟨c, cl, rfl⟩ := list.exists_of_mem_map h,
    rw (list.perm_cons_erase cl).pairwise_iff (λ _ _ hd, _) at hld,
    swap, { exact hd.symm },
    refine ⟨c, (l.erase c).prod, _, _, hlc _ cl, rfl⟩,
    { rw [← list.prod_cons,
        (list.perm_cons_erase cl).symm.prod_eq' (hld.imp (λ _ _, disjoint.commute))] },
    { exact disjoint_prod_right _ (λ g, list.rel_of_pairwise_cons hld) } },
  { rintros ⟨c, t, rfl, hd, hc, rfl⟩,
    simp [hd.cycle_type, hc.cycle_type] }
end

lemma le_card_support_of_mem_cycle_type {n : ℕ} {σ : perm α} (h : n ∈ cycle_type σ) :
  n ≤ σ.support.card :=
(le_sum_of_mem h).trans (le_of_eq σ.sum_cycle_type)

lemma cycle_type_of_card_le_mem_cycle_type_add_two {n : ℕ} {g : perm α}
  (hn2 : fintype.card α < n + 2) (hng : n ∈ g.cycle_type) :
  g.cycle_type = {n} :=
begin
  obtain ⟨c, g', rfl, hd, hc, rfl⟩ := mem_cycle_type_iff.1 hng,
  by_cases g'1 : g' = 1,
  { rw [hd.cycle_type, hc.cycle_type, coe_singleton, g'1, cycle_type_one, add_zero] },
  contrapose! hn2,
  apply le_trans _ (c * g').support.card_le_univ,
  rw [hd.card_support_mul],
  exact add_le_add_left (two_le_card_support_of_ne_one g'1) _,
end

end cycle_type

lemma card_compl_support_modeq [decidable_eq α] {p n : ℕ} [hp : fact p.prime] {σ : perm α}
  (hσ : σ ^ p ^ n = 1) : σ.supportᶜ.card ≡ fintype.card α [MOD p] :=
begin
  rw [nat.modeq_iff_dvd' σ.supportᶜ.card_le_univ, ←finset.card_compl, compl_compl],
  refine (congr_arg _ σ.sum_cycle_type).mp (multiset.dvd_sum (λ k hk, _)),
  obtain ⟨m, -, hm⟩ := (nat.dvd_prime_pow hp.out).mp (order_of_dvd_of_pow_eq_one hσ),
  obtain ⟨l, -, rfl⟩ := (nat.dvd_prime_pow hp.out).mp
    ((congr_arg _ hm).mp (dvd_of_mem_cycle_type hk)),
  exact dvd_pow_self _ (λ h, (one_lt_of_mem_cycle_type hk).ne $ by rw [h, pow_zero]),
end

lemma exists_fixed_point_of_prime {p n : ℕ} [hp : fact p.prime] (hα : ¬ p ∣ fintype.card α)
  {σ : perm α} (hσ : σ ^ p ^ n = 1) : ∃ a : α, σ a = a :=
begin
  classical,
  contrapose! hα,
  simp_rw ← mem_support at hα,
  exact nat.modeq_zero_iff_dvd.mp ((congr_arg _ (finset.card_eq_zero.mpr (compl_eq_bot.mpr
    (finset.eq_univ_iff_forall.mpr hα)))).mp (card_compl_support_modeq hσ).symm),
end

lemma exists_fixed_point_of_prime' {p n : ℕ} [hp : fact p.prime] (hα : p ∣ fintype.card α)
  {σ : perm α} (hσ : σ ^ p ^ n = 1) {a : α} (ha : σ a = a) : ∃ b : α, σ b = b ∧ b ≠ a :=
begin
  classical,
  have h : ∀ b : α, b ∈ σ.supportᶜ ↔ σ b = b :=
  λ b, by rw [finset.mem_compl, mem_support, not_not],
  obtain ⟨b, hb1, hb2⟩ := finset.exists_ne_of_one_lt_card (lt_of_lt_of_le hp.out.one_lt
    (nat.le_of_dvd (finset.card_pos.mpr ⟨a, (h a).mpr ha⟩) (nat.modeq_zero_iff_dvd.mp
    ((card_compl_support_modeq hσ).trans (nat.modeq_zero_iff_dvd.mpr hα))))) a,
  exact ⟨b, (h b).mp hb1, hb2⟩,
end

lemma is_cycle_of_prime_order' {σ : perm α} (h1 : (order_of σ).prime)
  (h2 : fintype.card α < 2 * (order_of σ)) : σ.is_cycle :=
begin
  classical,
  exact is_cycle_of_prime_order h1 (lt_of_le_of_lt σ.support.card_le_univ h2),
end

section cauchy

variables (G : Type*) [group G] (n : ℕ)

/-- The type of vectors with terms from `G`, length `n`, and product equal to `1:G`. -/
def vectors_prod_eq_one : set (vector G n) :=
{v | v.to_list.prod = 1}

namespace vectors_prod_eq_one

lemma mem_iff {n : ℕ} (v : vector G n) :
v ∈ vectors_prod_eq_one G n ↔ v.to_list.prod = 1 := iff.rfl

lemma zero_eq : vectors_prod_eq_one G 0 = {vector.nil} :=
set.eq_singleton_iff_unique_mem.mpr ⟨eq.refl (1 : G), λ v hv, v.eq_nil⟩

lemma one_eq : vectors_prod_eq_one G 1 = {vector.nil.cons 1} :=
begin
  simp_rw [set.eq_singleton_iff_unique_mem, mem_iff,
    vector.to_list_singleton, list.prod_singleton, vector.head_cons],
  exact ⟨rfl, λ v hv, v.cons_head_tail.symm.trans (congr_arg2 vector.cons hv v.tail.eq_nil)⟩,
end

instance zero_unique : unique (vectors_prod_eq_one G 0) :=
by { rw zero_eq, exact set.unique_singleton vector.nil }

instance one_unique : unique (vectors_prod_eq_one G 1) :=
by { rw one_eq, exact set.unique_singleton (vector.nil.cons 1) }

/-- Given a vector `v` of length `n`, make a vector of length `n + 1` whose product is `1`,
by appending the inverse of the product of `v`. -/
@[simps] def vector_equiv : vector G n ≃ vectors_prod_eq_one G (n + 1) :=
{ to_fun := λ v, ⟨v.to_list.prod⁻¹ ::ᵥ v,
    by rw [mem_iff, vector.to_list_cons, list.prod_cons, inv_mul_self]⟩,
  inv_fun := λ v, v.1.tail,
  left_inv := λ v, v.tail_cons v.to_list.prod⁻¹,
  right_inv := λ v, subtype.ext ((congr_arg2 vector.cons (eq_inv_of_mul_eq_one_left (by
  { rw [←list.prod_cons, ←vector.to_list_cons, v.1.cons_head_tail],
    exact v.2 })).symm rfl).trans v.1.cons_head_tail) }

/-- Given a vector `v` of length `n` whose product is 1, make a vector of length `n - 1`,
by deleting the last entry of `v`. -/
def equiv_vector : vectors_prod_eq_one G n ≃ vector G (n - 1) :=
((vector_equiv G (n - 1)).trans (if hn : n = 0 then (show vectors_prod_eq_one G (n - 1 + 1) ≃
  vectors_prod_eq_one G n, by { rw hn, apply equiv_of_unique })
  else by rw tsub_add_cancel_of_le (nat.pos_of_ne_zero hn).nat_succ_le)).symm

instance [fintype G] : fintype (vectors_prod_eq_one G n) :=
fintype.of_equiv (vector G (n - 1)) (equiv_vector G n).symm

lemma card [fintype G] :
  fintype.card (vectors_prod_eq_one G n) = fintype.card G ^ (n - 1) :=
(fintype.card_congr (equiv_vector G n)).trans (card_vector (n - 1))

variables {G n} {g : G} (v : vectors_prod_eq_one G n) (j k : ℕ)

/-- Rotate a vector whose product is 1. -/
def rotate : vectors_prod_eq_one G n :=
⟨⟨_, (v.1.1.length_rotate k).trans v.1.2⟩, list.prod_rotate_eq_one_of_prod_eq_one v.2 k⟩

lemma rotate_zero : rotate v 0 = v :=
subtype.ext (subtype.ext v.1.1.rotate_zero)

lemma rotate_rotate : rotate (rotate v j) k = rotate v (j + k) :=
subtype.ext (subtype.ext (v.1.1.rotate_rotate j k))

lemma rotate_length : rotate v n = v :=
subtype.ext (subtype.ext ((congr_arg _ v.1.2.symm).trans v.1.1.rotate_length))

end vectors_prod_eq_one

/-- For every prime `p` dividing the order of a finite group `G` there exists an element of order
`p` in `G`. This is known as Cauchy's theorem. -/
lemma _root_.exists_prime_order_of_dvd_card {G : Type*} [group G] [fintype G] (p : ℕ)
  [hp : fact p.prime] (hdvd : p ∣ fintype.card G) : ∃ x : G, order_of x = p :=
begin
  have hp' : p - 1 ≠ 0 := mt tsub_eq_zero_iff_le.mp (not_le_of_lt hp.out.one_lt),
  have Scard := calc p ∣ fintype.card G ^ (p - 1) : hdvd.trans (dvd_pow (dvd_refl _) hp')
  ... = fintype.card (vectors_prod_eq_one G p) : (vectors_prod_eq_one.card G p).symm,
  let f : ℕ → vectors_prod_eq_one G p → vectors_prod_eq_one G p :=
  λ k v, vectors_prod_eq_one.rotate v k,
  have hf1 : ∀ v, f 0 v = v := vectors_prod_eq_one.rotate_zero,
  have hf2 : ∀ j k v, f k (f j v) = f (j + k) v :=
  λ j k v, vectors_prod_eq_one.rotate_rotate v j k,
  have hf3 : ∀ v, f p v = v := vectors_prod_eq_one.rotate_length,
  let σ := equiv.mk (f 1) (f (p - 1))
    (λ s, by rw [hf2, add_tsub_cancel_of_le hp.out.one_lt.le, hf3])
    (λ s, by rw [hf2, tsub_add_cancel_of_le hp.out.one_lt.le, hf3]),
  have hσ : ∀ k v, (σ ^ k) v = f k v :=
  λ k v, nat.rec (hf1 v).symm (λ k hk, eq.trans (by exact congr_arg σ hk) (hf2 k 1 v)) k,
  replace hσ : σ ^ (p ^ 1) = 1 := perm.ext (λ v, by rw [pow_one, hσ, hf3, one_apply]),
  let v₀ : vectors_prod_eq_one G p :=
    ⟨vector.replicate p 1, (list.prod_replicate p 1).trans (one_pow p)⟩,
  have hv₀ : σ v₀ = v₀ := subtype.ext (subtype.ext (list.rotate_replicate (1 : G) p 1)),
  obtain ⟨v, hv1, hv2⟩ := exists_fixed_point_of_prime' Scard hσ hv₀,
  refine exists_imp_exists (λ g hg, order_of_eq_prime _ (λ hg', hv2 _))
    (list.rotate_one_eq_self_iff_eq_replicate.mp (subtype.ext_iff.mp (subtype.ext_iff.mp hv1))),
  { rw [←list.prod_replicate, ←v.1.2, ←hg, (show v.val.val.prod = 1, from v.2)] },
  { rw [subtype.ext_iff_val, subtype.ext_iff_val, hg, hg', v.1.2],
    refl },
end

/-- For every prime `p` dividing the order of a finite additive group `G` there exists an element of
order `p` in `G`. This is the additive version of Cauchy's theorem. -/
lemma _root_.exists_prime_add_order_of_dvd_card {G : Type*} [add_group G] [fintype G] (p : ℕ)
  [hp : fact p.prime] (hdvd : p ∣ fintype.card G) : ∃ x : G, add_order_of x = p :=
@exists_prime_order_of_dvd_card (multiplicative G) _ _ _ _ hdvd

attribute [to_additive exists_prime_add_order_of_dvd_card] exists_prime_order_of_dvd_card

end cauchy

lemma subgroup_eq_top_of_swap_mem [decidable_eq α] {H : subgroup (perm α)}
  [d : decidable_pred (∈ H)] {τ : perm α} (h0 : (fintype.card α).prime)
  (h1 : fintype.card α ∣ fintype.card H) (h2 : τ ∈ H) (h3 : is_swap τ) :
  H = ⊤ :=
begin
  haveI : fact (fintype.card α).prime := ⟨h0⟩,
  obtain ⟨σ, hσ⟩ := exists_prime_order_of_dvd_card (fintype.card α) h1,
  have hσ1 : order_of (σ : perm α) = fintype.card α := (order_of_subgroup σ).trans hσ,
  have hσ2 : is_cycle ↑σ := is_cycle_of_prime_order'' h0 hσ1,
  have hσ3 : (σ : perm α).support = ⊤ :=
    finset.eq_univ_of_card (σ : perm α).support (hσ2.order_of.symm.trans hσ1),
  have hσ4 : subgroup.closure {↑σ, τ} = ⊤ := closure_prime_cycle_swap h0 hσ2 hσ3 h3,
  rw [eq_top_iff, ←hσ4, subgroup.closure_le, set.insert_subset, set.singleton_subset_iff],
  exact ⟨subtype.mem σ, h2⟩,
end

section partition

variables [decidable_eq α]

/-- The partition corresponding to a permutation -/
def partition (σ : perm α) : (fintype.card α).partition :=
{ parts := σ.cycle_type + replicate (fintype.card α - σ.support.card) 1,
  parts_pos := λ n hn,
  begin
    cases mem_add.mp hn with hn hn,
    { exact zero_lt_one.trans (one_lt_of_mem_cycle_type hn) },
    { exact lt_of_lt_of_le zero_lt_one (ge_of_eq (multiset.eq_of_mem_replicate hn)) },
  end,
  parts_sum := by rw [sum_add, sum_cycle_type, multiset.sum_replicate, nsmul_eq_mul,
    nat.cast_id, mul_one, add_tsub_cancel_of_le σ.support.card_le_univ] }

lemma parts_partition {σ : perm α} :
  σ.partition.parts = σ.cycle_type + replicate (fintype.card α - σ.support.card) 1 := rfl

lemma filter_parts_partition_eq_cycle_type {σ : perm α} :
  (partition σ).parts.filter (λ n, 2 ≤ n) = σ.cycle_type :=
begin
  rw [parts_partition, filter_add, multiset.filter_eq_self.2 (λ _, two_le_of_mem_cycle_type),
    multiset.filter_eq_nil.2 (λ a h, _), add_zero],
  rw multiset.eq_of_mem_replicate h,
  dec_trivial
end

lemma partition_eq_of_is_conj {σ τ : perm α} :
  is_conj σ τ ↔ σ.partition = τ.partition :=
begin
  rw [is_conj_iff_cycle_type_eq],
  refine ⟨λ h, _, λ h, _⟩,
  { rw [nat.partition.ext_iff, parts_partition, parts_partition,
      ← sum_cycle_type, ← sum_cycle_type, h] },
  { rw [← filter_parts_partition_eq_cycle_type, ← filter_parts_partition_eq_cycle_type, h] }
end

end partition

/-!
### 3-cycles
-/

/-- A three-cycle is a cycle of length 3. -/
def is_three_cycle [decidable_eq α] (σ : perm α) : Prop := σ.cycle_type = {3}

namespace is_three_cycle

variables [decidable_eq α] {σ : perm α}

lemma cycle_type (h : is_three_cycle σ) : σ.cycle_type = {3} := h

lemma card_support (h : is_three_cycle σ) : σ.support.card = 3 :=
by rw [←sum_cycle_type, h.cycle_type, multiset.sum_singleton]

lemma _root_.card_support_eq_three_iff : σ.support.card = 3 ↔ σ.is_three_cycle :=
begin
  refine ⟨λ h, _, is_three_cycle.card_support⟩,
  by_cases h0 : σ.cycle_type = 0,
  { rw [←sum_cycle_type, h0, sum_zero] at h,
    exact (ne_of_lt zero_lt_three h).elim },
  obtain ⟨n, hn⟩ := exists_mem_of_ne_zero h0,
  by_cases h1 : σ.cycle_type.erase n = 0,
  { rw [←sum_cycle_type, ←cons_erase hn, h1, cons_zero, multiset.sum_singleton] at h,
    rw [is_three_cycle, ←cons_erase hn, h1, h, ←cons_zero] },
  obtain ⟨m, hm⟩ := exists_mem_of_ne_zero h1,
  rw [←sum_cycle_type, ←cons_erase hn, ←cons_erase hm, multiset.sum_cons, multiset.sum_cons] at h,
  -- TODO: linarith [...] should solve this directly
  have : ∀ {k}, 2 ≤ m → 2 ≤ n → n + (m + k) = 3 → false, { intros, linarith },
  cases this (two_le_of_mem_cycle_type (mem_of_mem_erase hm)) (two_le_of_mem_cycle_type hn) h,
end

lemma is_cycle (h : is_three_cycle σ) : is_cycle σ :=
by rw [←card_cycle_type_eq_one, h.cycle_type, card_singleton]

lemma sign (h : is_three_cycle σ) : sign σ = 1 :=
begin
  rw [equiv.perm.sign_of_cycle_type, h.cycle_type],
  refl,
end

lemma inv {f : perm α} (h : is_three_cycle f) : is_three_cycle (f⁻¹) :=
by rwa [is_three_cycle, cycle_type_inv]

@[simp] lemma inv_iff {f : perm α} : is_three_cycle (f⁻¹) ↔ is_three_cycle f :=
⟨by { rw ← inv_inv f, apply inv }, inv⟩

lemma order_of {g : perm α} (ht : is_three_cycle g) :
  order_of g = 3 :=
by rw [←lcm_cycle_type, ht.cycle_type, multiset.lcm_singleton, normalize_eq]

lemma is_three_cycle_sq {g : perm α} (ht : is_three_cycle g) :
  is_three_cycle (g * g) :=
begin
  rw [←pow_two, ←card_support_eq_three_iff, support_pow_coprime, ht.card_support],
  rw [ht.order_of, nat.coprime_iff_gcd_eq_one],
  norm_num,
end

end is_three_cycle

section
variable [decidable_eq α]

lemma is_three_cycle_swap_mul_swap_same
  {a b c : α} (ab : a ≠ b) (ac : a ≠ c) (bc : b ≠ c) :
  is_three_cycle (swap a b * swap a c) :=
begin
  suffices h : support (swap a b * swap a c) = {a, b, c},
  { rw [←card_support_eq_three_iff, h],
    simp [ab, ac, bc] },
  apply le_antisymm ((support_mul_le _ _).trans (λ x, _)) (λ x hx, _),
  { simp [ab, ac, bc] },
  { simp only [finset.mem_insert, finset.mem_singleton] at hx,
    rw mem_support,
    simp only [perm.coe_mul, function.comp_app, ne.def],
    obtain rfl | rfl | rfl := hx,
    { rw [swap_apply_left, swap_apply_of_ne_of_ne ac.symm bc.symm],
      exact ac.symm },
    { rw [swap_apply_of_ne_of_ne ab.symm bc, swap_apply_right],
      exact ab },
    { rw [swap_apply_right, swap_apply_left],
      exact bc } }
end

open subgroup

lemma swap_mul_swap_same_mem_closure_three_cycles
  {a b c : α} (ab : a ≠ b) (ac : a ≠ c) :
  (swap a b * swap a c) ∈ closure {σ : perm α | is_three_cycle σ } :=
begin
  by_cases bc : b = c,
  { subst bc,
    simp [one_mem] },
  exact subset_closure (is_three_cycle_swap_mul_swap_same ab ac bc)
end

lemma is_swap.mul_mem_closure_three_cycles {σ τ : perm α}
  (hσ : is_swap σ) (hτ : is_swap τ) :
  σ * τ ∈ closure {σ : perm α | is_three_cycle σ } :=
begin
  obtain ⟨a, b, ab, rfl⟩ := hσ,
  obtain ⟨c, d, cd, rfl⟩ := hτ,
  by_cases ac : a = c,
  { subst ac,
    exact swap_mul_swap_same_mem_closure_three_cycles ab cd },
  have h' : swap a b * swap c d = swap a b * swap a c * (swap c a * swap c d),
  { simp [swap_comm c a, mul_assoc] },
  rw h',
  exact mul_mem (swap_mul_swap_same_mem_closure_three_cycles ab ac)
    (swap_mul_swap_same_mem_closure_three_cycles (ne.symm ac) cd),
end

end

end equiv.perm


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura

Various multiplicative and additive structures. Partially modeled on Isabelle's library.
-/

import logic.eq data.unit data.sigma data.prod
import algebra.binary algebra.priority

open binary

variable {A : Type}

/- semigroup -/

attribute inv [light 3]
attribute neg [light 3]

structure semigroup [class] (A : Type) extends has_mul A :=
(mul_assoc : ∀a b c, mul (mul a b) c = mul a (mul b c))

-- We add pattern hints to the following lemma because we want it to be used in both directions
-- at inst_simp strategy.
theorem mul.assoc [simp] [semigroup A] (a b c : A) : (: a * b * c :) = (: a * (b * c) :) :=
!semigroup.mul_assoc

structure comm_semigroup [class] (A : Type) extends semigroup A :=
(mul_comm : ∀a b, mul a b = mul b a)

theorem mul.comm [simp] [comm_semigroup A] (a b : A) : a * b = b * a :=
!comm_semigroup.mul_comm

theorem mul.left_comm [simp] [comm_semigroup A] (a b c : A) : a * (b * c) = b * (a * c) :=
binary.left_comm (@mul.comm A _) (@mul.assoc A _) a b c

theorem mul.right_comm [comm_semigroup A] (a b c : A) : (a * b) * c = (a * c) * b :=
by simp

structure left_cancel_semigroup [class] (A : Type) extends semigroup A :=
(mul_left_cancel : ∀a b c, mul a b = mul a c → b = c)

theorem mul.left_cancel [left_cancel_semigroup A] {a b c : A} : a * b = a * c → b = c :=
!left_cancel_semigroup.mul_left_cancel

abbreviation eq_of_mul_eq_mul_left' := @mul.left_cancel

structure right_cancel_semigroup [class] (A : Type) extends semigroup A :=
(mul_right_cancel : ∀a b c, mul a b = mul c b → a = c)

theorem mul.right_cancel [right_cancel_semigroup A] {a b c : A} : a * b = c * b → a = c :=
!right_cancel_semigroup.mul_right_cancel

abbreviation eq_of_mul_eq_mul_right' := @mul.right_cancel

/- additive semigroup -/

structure add_semigroup [class] (A : Type) extends has_add A :=
(add_assoc : ∀a b c, add (add a b) c = add a (add b c))

theorem add.assoc [simp] [add_semigroup A] (a b c : A) : (: a + b + c :) = (: a + (b + c) :) :=
!add_semigroup.add_assoc

structure add_comm_semigroup [class] (A : Type) extends add_semigroup A :=
(add_comm : ∀a b, add a b = add b a)

theorem add.comm [simp] [add_comm_semigroup A] (a b : A) : a + b = b + a :=
!add_comm_semigroup.add_comm

theorem add.left_comm [simp] [add_comm_semigroup A] (a b c : A) : a + (b + c) = b + (a + c) :=
binary.left_comm (@add.comm A _) (@add.assoc A _) a b c

theorem add.right_comm [add_comm_semigroup A] (a b c : A) : (a + b) + c = (a + c) + b :=
by simp

structure add_left_cancel_semigroup [class] (A : Type) extends add_semigroup A :=
(add_left_cancel : ∀a b c, add a b = add a c → b = c)

theorem add.left_cancel [add_left_cancel_semigroup A] {a b c : A} : a + b = a + c → b = c :=
!add_left_cancel_semigroup.add_left_cancel

abbreviation eq_of_add_eq_add_left := @add.left_cancel

structure add_right_cancel_semigroup [class] (A : Type) extends add_semigroup A :=
(add_right_cancel : ∀a b c, add a b = add c b → a = c)

theorem add.right_cancel [add_right_cancel_semigroup A] {a b c : A} : a + b = c + b → a = c :=
!add_right_cancel_semigroup.add_right_cancel

abbreviation eq_of_add_eq_add_right := @add.right_cancel

/- monoid -/

structure monoid [class] (A : Type) extends semigroup A, has_one A :=
(one_mul : ∀a, mul one a = a) (mul_one : ∀a, mul a one = a)

theorem one_mul [simp] [monoid A] (a : A) : 1 * a = a := !monoid.one_mul

theorem mul_one [simp] [monoid A] (a : A) : a * 1 = a := !monoid.mul_one

structure comm_monoid [class] (A : Type) extends monoid A, comm_semigroup A

/- additive monoid -/

structure add_monoid [class] (A : Type) extends add_semigroup A, has_zero A :=
(zero_add : ∀a, add zero a = a) (add_zero : ∀a, add a zero = a)

theorem zero_add [simp] [add_monoid A] (a : A) : 0 + a = a := !add_monoid.zero_add

theorem add_zero [simp] [add_monoid A] (a : A) : a + 0 = a := !add_monoid.add_zero

structure add_comm_monoid [class] (A : Type) extends add_monoid A, add_comm_semigroup A

definition add_monoid.to_monoid {A : Type} [add_monoid A] : monoid A :=
⦃ monoid,
  mul         := add_monoid.add,
  mul_assoc   := add_monoid.add_assoc,
  one         := add_monoid.zero A,
  mul_one     := add_monoid.add_zero,
  one_mul     := add_monoid.zero_add
⦄

definition add_comm_monoid.to_comm_monoid {A : Type} [add_comm_monoid A] : comm_monoid A :=
⦃ comm_monoid,
  add_monoid.to_monoid,
  mul_comm    := add_comm_monoid.add_comm
⦄

definition monoid.to_add_monoid {A : Type} [s : monoid A] : add_monoid A :=
⦃ add_monoid,
  add         := monoid.mul,
  add_assoc   := monoid.mul_assoc,
  zero        := monoid.one A,
  add_zero    := monoid.mul_one,
  zero_add    := monoid.one_mul
⦄

definition comm_monoid.to_add_comm_monoid {A : Type} [s : comm_monoid A] : add_comm_monoid A :=
⦃ add_comm_monoid,
  monoid.to_add_monoid,
  add_comm    := comm_monoid.mul_comm
⦄

section add_comm_monoid
  variables [add_comm_monoid A]

  theorem add_comm_three  (a b c : A) : a + b + c = c + b + a :=
  by simp

  theorem add.comm4 : ∀ (n m k l : A), n + m + (k + l) = n + k + (m + l) :=
  by simp
end add_comm_monoid

/- group -/

structure group [class] (A : Type) extends monoid A, has_inv A :=
(mul_left_inv : ∀a, mul (inv a) a = one)

-- Note: with more work, we could derive the axiom one_mul

section group
  variable [group A]

  theorem mul.left_inv [simp] (a : A) : a⁻¹ * a = 1 := !group.mul_left_inv

  theorem inv_mul_cancel_left [simp] (a b : A) : a⁻¹ * (a * b) = b :=
  by rewrite [-mul.assoc, mul.left_inv, one_mul]

  theorem inv_mul_cancel_right [simp] (a b : A) : a * b⁻¹ * b = a :=
  by simp

  theorem inv_eq_of_mul_eq_one {a b : A} (H : a * b = 1) : a⁻¹ = b :=
  have a⁻¹ * 1 = b, by inst_simp,
  by inst_simp

  theorem one_inv [simp] : 1⁻¹ = (1 : A) :=
  inv_eq_of_mul_eq_one (one_mul 1)

  theorem inv_inv [simp] (a : A) : (a⁻¹)⁻¹ = a :=
  inv_eq_of_mul_eq_one (mul.left_inv a)

  variable (A)
  theorem left_inverse_inv : function.left_inverse (λ a : A, a⁻¹) (λ a, a⁻¹) :=
  take a, inv_inv a
  variable {A}

  theorem inv.inj {a b : A} (H : a⁻¹ = b⁻¹) : a = b :=
  have a = a⁻¹⁻¹, by simp_nohyps,
  by inst_simp

  theorem inv_eq_inv_iff_eq (a b : A) : a⁻¹ = b⁻¹ ↔ a = b :=
  iff.intro (assume H, inv.inj H) (by simp)

  theorem inv_eq_one_iff_eq_one (a : A) : a⁻¹ = 1 ↔ a = 1 :=
  have a⁻¹ = 1⁻¹ ↔ a = 1, from inv_eq_inv_iff_eq a 1,
  by simp

  theorem eq_one_of_inv_eq_one (a : A) : a⁻¹ = 1 → a = 1 :=
  iff.mp !inv_eq_one_iff_eq_one

  theorem eq_inv_of_eq_inv {a b : A} (H : a = b⁻¹) : b = a⁻¹ :=
  by simp

  theorem eq_inv_iff_eq_inv (a b : A) : a = b⁻¹ ↔ b = a⁻¹ :=
  iff.intro !eq_inv_of_eq_inv !eq_inv_of_eq_inv

  theorem eq_inv_of_mul_eq_one {a b : A} (H : a * b = 1) : a = b⁻¹ :=
  have a⁻¹ = b, from inv_eq_of_mul_eq_one H,
  by inst_simp

  theorem mul.right_inv [simp] (a : A) : a * a⁻¹ = 1 :=
  have a = a⁻¹⁻¹, by simp,
  by inst_simp

  theorem mul_inv_cancel_left [simp] (a b : A) : a * (a⁻¹ * b) = b :=
  by inst_simp

  theorem mul_inv_cancel_right [simp] (a b : A) : a * b * b⁻¹ = a :=
  by inst_simp

  theorem mul_inv [simp] (a b : A) : (a * b)⁻¹ = b⁻¹ * a⁻¹ :=
  inv_eq_of_mul_eq_one (by inst_simp)

  theorem eq_of_mul_inv_eq_one {a b : A} (H : a * b⁻¹ = 1) : a = b :=
  have a⁻¹ * 1 = a⁻¹, by inst_simp,
  by inst_simp

  theorem eq_mul_inv_of_mul_eq {a b c : A} (H : a * c = b) : a = b * c⁻¹ :=
  by simp

  theorem eq_inv_mul_of_mul_eq {a b c : A} (H : b * a = c) : a = b⁻¹ * c :=
  by simp

  theorem inv_mul_eq_of_eq_mul {a b c : A} (H : b = a * c) : a⁻¹ * b = c :=
  by simp

  theorem mul_inv_eq_of_eq_mul {a b c : A} (H : a = c * b) : a * b⁻¹ = c :=
  by simp

  theorem eq_mul_of_mul_inv_eq {a b c : A} (H : a * c⁻¹ = b) : a = b * c :=
  by simp

  theorem eq_mul_of_inv_mul_eq {a b c : A} (H : b⁻¹ * a = c) : a = b * c :=
  by simp

  theorem mul_eq_of_eq_inv_mul {a b c : A} (H : b = a⁻¹ * c) : a * b = c :=
  by simp

  theorem mul_eq_of_eq_mul_inv {a b c : A} (H : a = c * b⁻¹) : a * b = c :=
  by simp

  theorem mul_eq_iff_eq_inv_mul (a b c : A) : a * b = c ↔ b = a⁻¹ * c :=
  iff.intro eq_inv_mul_of_mul_eq mul_eq_of_eq_inv_mul

  theorem mul_eq_iff_eq_mul_inv (a b c : A) : a * b = c ↔ a = c * b⁻¹ :=
  iff.intro eq_mul_inv_of_mul_eq mul_eq_of_eq_mul_inv

  theorem mul_left_cancel {a b c : A} (H : a * b = a * c) : b = c :=
  have a⁻¹ * (a * b) = b, by inst_simp,
  by inst_simp

  theorem mul_right_cancel {a b c : A} (H : a * b = c * b) : a = c :=
  have a * b * b⁻¹ = a, by inst_simp,
  by inst_simp

  theorem mul_eq_one_of_mul_eq_one {a b : A} (H : b * a = 1) : a * b = 1 :=
  by rewrite [-inv_eq_of_mul_eq_one H, mul.left_inv]

  theorem mul_eq_one_iff_mul_eq_one (a b : A) : a * b = 1 ↔ b * a = 1 :=
  iff.intro !mul_eq_one_of_mul_eq_one !mul_eq_one_of_mul_eq_one

  definition conj_by (g a : A) := g * a * g⁻¹
  definition is_conjugate (a b : A) := ∃ x, conj_by x b = a

  local infixl ` ~ ` := is_conjugate
  local infixr ` ∘c `:55 := conj_by

  local attribute conj_by [reducible]

  lemma conj_compose [simp] (f g a : A) : f ∘c g ∘c a = f*g ∘c a :=
  by inst_simp

  lemma conj_id [simp] (a : A) : 1 ∘c a = a :=
  by inst_simp

  lemma conj_one [simp] (g : A) : g ∘c 1 = 1 :=
  by inst_simp

  lemma conj_inv_cancel [simp] (g : A) : ∀ a, g⁻¹ ∘c g ∘c a = a :=
  by inst_simp

  lemma conj_inv [simp] (g : A) : ∀ a, (g ∘c a)⁻¹ = g ∘c a⁻¹ :=
  by inst_simp

  lemma is_conj.refl (a : A) : a ~ a := exists.intro 1 (conj_id a)

  lemma is_conj.symm (a b : A) : a ~ b → b ~ a :=
  assume Pab, obtain x (Pconj : x ∘c b = a), from Pab,
  have Pxinv : x⁻¹ ∘c x ∘c b = x⁻¹ ∘c a,   by simp,
  exists.intro x⁻¹ (by simp)

  lemma is_conj.trans (a b c : A) : a ~ b → b ~ c → a ~ c :=
  assume Pab, assume Pbc,
  obtain x (Px : x ∘c b = a), from Pab,
  obtain y (Py : y ∘c c = b), from Pbc,
  exists.intro (x*y) (by inst_simp)

end group

definition group.to_left_cancel_semigroup [trans_instance] [s : group A] :
    left_cancel_semigroup A :=
⦃ left_cancel_semigroup, s,
  mul_left_cancel := @mul_left_cancel A s ⦄

definition group.to_right_cancel_semigroup [trans_instance] [s : group A] :
    right_cancel_semigroup A :=
⦃ right_cancel_semigroup, s,
  mul_right_cancel := @mul_right_cancel A s ⦄

structure comm_group [class] (A : Type) extends group A, comm_monoid A

/- additive group -/

structure add_group [class] (A : Type) extends add_monoid A, has_neg A :=
(add_left_inv : ∀a, add (neg a) a = zero)

definition add_group.to_group {A : Type} [add_group A] : group A :=
⦃ group, add_monoid.to_monoid,
  mul_left_inv := add_group.add_left_inv ⦄

definition group.to_add_group {A : Type} [s : group A] : add_group A :=
⦃ add_group, monoid.to_add_monoid,
  add_left_inv := group.mul_left_inv ⦄

section add_group
  variables [s : add_group A]
  include s

  theorem add.left_inv [simp] (a : A) : -a + a = 0 := !add_group.add_left_inv

  theorem neg_add_cancel_left [simp] (a b : A) : -a + (a + b) = b :=
  calc -a + (a + b) = (-a + a) + b : by rewrite add.assoc
               ...  = b            : by simp

  theorem neg_add_cancel_right [simp] (a b : A) : a + -b + b = a :=
  by simp

  theorem neg_eq_of_add_eq_zero {a b : A} (H : a + b = 0) : -a = b :=
  have -a + 0 = b, by inst_simp,
  by inst_simp

  theorem neg_zero [simp] : -0 = (0 : A) := neg_eq_of_add_eq_zero (zero_add 0)

  theorem neg_neg [simp] (a : A) : -(-a) = a := neg_eq_of_add_eq_zero (add.left_inv a)

  variable (A)
  theorem left_inverse_neg : function.left_inverse (λ a : A, - a) (λ a, - a) :=
  take a, neg_neg a
  variable {A}

  theorem eq_neg_of_add_eq_zero {a b : A} (H : a + b = 0) : a = -b :=
  have -a = b, from neg_eq_of_add_eq_zero H,
  by inst_simp

  theorem neg.inj {a b : A} (H : -a = -b) : a = b :=
  have a = -(-a), by simp_nohyps,
  by inst_simp

  theorem neg_eq_neg_iff_eq (a b : A) : -a = -b ↔ a = b :=
  iff.intro (assume H, neg.inj H) (by simp)

  theorem eq_of_neg_eq_neg {a b : A} : -a = -b → a = b :=
  iff.mp !neg_eq_neg_iff_eq

  theorem neg_eq_zero_iff_eq_zero (a : A) : -a = 0 ↔ a = 0 :=
  have -a = -0 ↔ a = 0, from neg_eq_neg_iff_eq a 0,
  by simp

  theorem eq_zero_of_neg_eq_zero {a : A} : -a = 0 → a = 0 :=
  iff.mp !neg_eq_zero_iff_eq_zero

  theorem eq_neg_of_eq_neg {a b : A} (H : a = -b) : b = -a :=
  by simp

  theorem eq_neg_iff_eq_neg (a b : A) : a = -b ↔ b = -a :=
  iff.intro !eq_neg_of_eq_neg !eq_neg_of_eq_neg

  theorem add.right_inv [simp] (a : A) : a + -a = 0 :=
  have a = -(-a), by simp,
  by inst_simp

  theorem add_neg_cancel_left [simp] (a b : A) : a + (-a + b) = b :=
  by inst_simp

  theorem add_neg_cancel_right [simp] (a b : A) : a + b + -b = a :=
  by simp

  theorem neg_add_rev [simp] (a b : A) : -(a + b) = -b + -a :=
  neg_eq_of_add_eq_zero (by simp)

  -- TODO: delete these in favor of sub rules?
  theorem eq_add_neg_of_add_eq {a b c : A} (H : a + c = b) : a = b + -c :=
  by simp

  theorem eq_neg_add_of_add_eq {a b c : A} (H : b + a = c) : a = -b + c :=
  by simp

  theorem neg_add_eq_of_eq_add {a b c : A} (H : b = a + c) : -a + b = c :=
  by simp

  theorem add_neg_eq_of_eq_add {a b c : A} (H : a = c + b) : a + -b = c :=
  by simp

  theorem eq_add_of_add_neg_eq {a b c : A} (H : a + -c = b) : a = b + c :=
  by simp

  theorem eq_add_of_neg_add_eq {a b c : A} (H : -b + a = c) : a = b + c :=
  by simp

  theorem add_eq_of_eq_neg_add {a b c : A} (H : b = -a + c) : a + b = c :=
  by simp

  theorem add_eq_of_eq_add_neg {a b c : A} (H : a = c + -b) : a + b = c :=
  by simp

  theorem add_eq_iff_eq_neg_add (a b c : A) : a + b = c ↔ b = -a + c :=
  iff.intro eq_neg_add_of_add_eq add_eq_of_eq_neg_add

  theorem add_eq_iff_eq_add_neg (a b c : A) : a + b = c ↔ a = c + -b :=
  iff.intro eq_add_neg_of_add_eq add_eq_of_eq_add_neg

  theorem add_left_cancel {a b c : A} (H : a + b = a + c) : b = c :=
  have -a + (a + b) = b, by inst_simp,
  by inst_simp

  theorem add_right_cancel {a b c : A} (H : a + b = c + b) : a = c :=
  have a + b + -b = a, by inst_simp,
  by inst_simp

  definition add_group.to_add_left_cancel_semigroup [trans_instance] :
    add_left_cancel_semigroup A :=
  ⦃ add_left_cancel_semigroup, s,
    add_left_cancel := @add_left_cancel A s ⦄

  definition add_group.to_add_right_cancel_semigroup [trans_instance] :
    add_right_cancel_semigroup A :=
  ⦃ add_right_cancel_semigroup, s,
    add_right_cancel := @add_right_cancel A s ⦄

  theorem add_neg_eq_neg_add_rev {a b : A} : a + -b = -(b + -a) :=
  by simp

  theorem ne_add_of_ne_zero_right (a : A) {b : A} (H : b ≠ 0) : a ≠ b + a :=
    begin
      intro Heq,
      apply H,
      rewrite [-zero_add a at Heq{1}],
      let Heq' := eq_of_add_eq_add_right Heq,
      apply eq.symm Heq'
    end

  theorem ne_add_of_ne_zero_left (a : A) {b : A} (H : b ≠ 0) : a ≠ a + b :=
    begin
      intro Heq,
      apply H,
      rewrite [-add_zero a at Heq{1}],
      let Heq' := eq_of_add_eq_add_left Heq,
      apply eq.symm Heq'
    end

  /- sub -/

  -- TODO: derive corresponding facts for div in a field
  protected definition algebra.sub [reducible] (a b : A) : A := a + -b

  definition add_group_has_sub [instance] : has_sub A :=
  has_sub.mk algebra.sub

  theorem sub_eq_add_neg [simp] (a b : A) : a - b = a + -b := rfl

  theorem sub_self (a : A) : a - a = 0 := !add.right_inv

  theorem sub_add_cancel (a b : A) : a - b + b = a := !neg_add_cancel_right

  theorem add_sub_cancel (a b : A) : a + b - b = a := !add_neg_cancel_right

  theorem add_sub_assoc (a b c : A) : a + b - c = a + (b - c) :=
    by rewrite [sub_eq_add_neg, add.assoc, -sub_eq_add_neg]

  theorem eq_of_sub_eq_zero {a b : A} (H : a - b = 0) : a = b :=
  have -a + 0 = -a, by inst_simp,
  by inst_simp

  theorem eq_iff_sub_eq_zero (a b : A) : a = b ↔ a - b = 0 :=
  iff.intro (assume H, eq.subst H !sub_self) (assume H, eq_of_sub_eq_zero H)

  theorem zero_sub (a : A) : 0 - a = -a := !zero_add

  theorem sub_zero (a : A) : a - 0 = a :=
  by simp

  theorem sub_ne_zero_of_ne {a b : A} (H : a ≠ b) : a - b ≠ 0 :=
    begin
      intro Hab,
      apply H,
      apply eq_of_sub_eq_zero Hab
    end

  theorem sub_neg_eq_add (a b : A) : a - (-b) = a + b :=
  by simp

  theorem neg_sub (a b : A) : -(a - b) = b - a :=
  neg_eq_of_add_eq_zero (by inst_simp)

  theorem add_sub (a b c : A) : a + (b - c) = a + b - c :=
  by simp

  theorem sub_add_eq_sub_sub_swap (a b c : A) : a - (b + c) = a - c - b :=
  by inst_simp

  theorem sub_eq_iff_eq_add (a b c : A) : a - b = c ↔ a = c + b :=
  iff.intro (assume H, eq_add_of_add_neg_eq H) (assume H, add_neg_eq_of_eq_add H)

  theorem eq_sub_iff_add_eq (a b c : A) : a = b - c ↔ a + c = b :=
  iff.intro (assume H, add_eq_of_eq_add_neg H) (assume H, eq_add_neg_of_add_eq H)

  theorem eq_iff_eq_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a = b ↔ c = d :=
  calc
    a = b ↔ a - b = 0   : eq_iff_sub_eq_zero
      ... = (c - d = 0) : H
      ... ↔ c = d       : iff.symm (eq_iff_sub_eq_zero c d)

  theorem eq_sub_of_add_eq {a b c : A} (H : a + c = b) : a = b - c :=
  by simp

  theorem sub_eq_of_eq_add {a b c : A} (H : a = c + b) : a - b = c :=
  by simp

  theorem eq_add_of_sub_eq {a b c : A} (H : a - c = b) : a = b + c :=
  by simp

  theorem add_eq_of_eq_sub {a b c : A} (H : a = c - b) : a + b = c :=
  by simp

  theorem left_inverse_sub_add_left (c : A) : function.left_inverse (λ x, x - c) (λ x, x + c) :=
  take x, add_sub_cancel x c

  theorem left_inverse_add_left_sub (c : A) : function.left_inverse (λ x, x + c) (λ x, x - c) :=
  take x, sub_add_cancel x c

  theorem left_inverse_add_right_neg_add (c : A) :
      function.left_inverse (λ x, c + x) (λ x, - c + x) :=
  take x, add_neg_cancel_left c x

  theorem left_inverse_neg_add_add_right (c : A) :
      function.left_inverse (λ x, - c + x) (λ x, c + x) :=
  take x, neg_add_cancel_left c x
end add_group

structure add_comm_group [class] (A : Type) extends add_group A, add_comm_monoid A

definition add_comm_group.to_comm_group (A : Type) [s : add_comm_group A] : comm_group A :=
⦃ comm_group, add_group.to_group,
  mul_comm := add_comm_group.add_comm ⦄

definition comm_group.to_add_comm_group (A : Type) [s : comm_group A] : add_comm_group A :=
⦃ add_comm_group, group.to_add_group,
  add_comm := comm_group.mul_comm ⦄

section add_comm_group
  variable [s : add_comm_group A]
  include s

  theorem sub_add_eq_sub_sub (a b c : A) : a - (b + c) = a - b - c :=
  by simp

  theorem neg_add_eq_sub (a b : A) : -a + b = b - a :=
  by simp

  theorem neg_add (a b : A) : -(a + b) = -a + -b :=
  by simp

  theorem sub_add_eq_add_sub (a b c : A) : a - b + c = a + c - b :=
  by simp

  theorem sub_sub (a b c : A) : a - b - c = a - (b + c) :=
  by simp

  theorem add_sub_add_left_eq_sub (a b c : A) : (c + a) - (c + b) = a - b :=
  by simp

  theorem eq_sub_of_add_eq' {a b c : A} (H : c + a = b) : a = b - c :=
  by simp

  theorem sub_eq_of_eq_add' {a b c : A} (H : a = b + c) : a - b = c :=
  by simp

  theorem eq_add_of_sub_eq' {a b c : A} (H : a - b = c) : a = b + c :=
  by simp

  theorem add_eq_of_eq_sub' {a b c : A} (H : b = c - a) : a + b = c :=
  by simp

  theorem sub_sub_self (a b : A) : a - (a - b) = b :=
  by simp

  theorem add_sub_comm (a b c d : A) : a + b - (c + d) = (a - c) + (b - d) :=
  by simp

  theorem sub_eq_sub_add_sub (a b c : A) : a - b = c - b + (a - c) :=
  by simp

  theorem neg_neg_sub_neg (a b : A) : - (-a - -b) = a - b :=
  by simp

end add_comm_group

definition group_of_add_group (A : Type) [G : add_group A] : group A :=
⦃group,
  mul             := has_add.add,
  mul_assoc       := add.assoc,
  one             := !has_zero.zero,
  one_mul         := zero_add,
  mul_one         := add_zero,
  inv             := has_neg.neg,
  mul_left_inv    := add.left_inv⦄

namespace norm_num
reveal add.assoc

definition add1 [has_add A] [has_one A] (a : A) : A := add a one

local attribute add1 bit0 bit1 [reducible]

theorem add_comm_four [add_comm_semigroup A] (a b : A) : a + a + (b + b) = (a + b) + (a + b) :=
by simp

theorem add_comm_middle [add_comm_semigroup A] (a b c : A) : a + b + c = a + c + b :=
by simp

theorem bit0_add_bit0 [add_comm_semigroup A] (a b : A) : bit0 a + bit0 b = bit0 (a + b) :=
by simp

theorem bit0_add_bit0_helper [add_comm_semigroup A] (a b t : A) (H : a + b = t) :
        bit0 a + bit0 b = bit0 t :=
by rewrite -H; simp

theorem bit1_add_bit0 [add_comm_semigroup A] [has_one A] (a b : A) :
        bit1 a + bit0 b = bit1 (a + b) :=
by simp

theorem bit1_add_bit0_helper [add_comm_semigroup A] [has_one A] (a b t : A)
        (H : a + b = t) : bit1 a + bit0 b = bit1 t :=
by rewrite -H; simp

theorem bit0_add_bit1 [add_comm_semigroup A] [has_one A] (a b : A) :
        bit0 a + bit1 b = bit1 (a + b) :=
by simp

theorem bit0_add_bit1_helper [add_comm_semigroup A] [has_one A] (a b t : A)
        (H : a + b = t) : bit0 a + bit1 b = bit1 t :=
by rewrite -H; simp

theorem bit1_add_bit1 [add_comm_semigroup A] [has_one A] (a b : A) :
        bit1 a + bit1 b = bit0 (add1 (a + b)) :=
by simp

theorem bit1_add_bit1_helper [add_comm_semigroup A] [has_one A] (a b t s: A)
        (H : (a + b) = t) (H2 : add1 t = s) : bit1 a + bit1 b = bit0 s :=
by inst_simp

theorem bin_add_zero [add_monoid A] (a : A) : a + zero = a :=
by simp

theorem bin_zero_add [add_monoid A] (a : A) : zero + a = a :=
by simp

theorem one_add_bit0 [add_comm_semigroup A] [has_one A] (a : A) : one + bit0 a = bit1 a :=
by simp

theorem bit0_add_one [has_add A] [has_one A] (a : A) : bit0 a + one = bit1 a :=
rfl

theorem bit1_add_one [has_add A] [has_one A] (a : A) : bit1 a + one = add1 (bit1 a) :=
rfl

theorem bit1_add_one_helper [has_add A] [has_one A] (a t : A) (H : add1 (bit1 a) = t) :
        bit1 a + one = t :=
by inst_simp

theorem one_add_bit1 [add_comm_semigroup A] [has_one A] (a : A) : one + bit1 a = add1 (bit1 a) :=
by simp

theorem one_add_bit1_helper [add_comm_semigroup A] [has_one A] (a t : A)
        (H : add1 (bit1 a) = t) : one + bit1 a = t :=
by inst_simp

theorem add1_bit0 [has_add A] [has_one A] (a : A) : add1 (bit0 a) = bit1 a :=
rfl

theorem add1_bit1 [add_comm_semigroup A] [has_one A] (a : A) :
        add1 (bit1 a) = bit0 (add1 a) :=
by simp

theorem add1_bit1_helper [add_comm_semigroup A] [has_one A] (a t : A) (H : add1 a = t) :
        add1 (bit1 a) = bit0 t :=
by inst_simp

theorem add1_one [has_add A] [has_one A] : add1 (one : A) = bit0 one :=
rfl

theorem add1_zero [add_monoid A] [has_one A] : add1 (zero : A) = one :=
by simp

theorem one_add_one [has_add A] [has_one A] : (one : A) + one = bit0 one :=
rfl

theorem subst_into_sum [has_add A] (l r tl tr t : A) (prl : l = tl) (prr : r = tr)
        (prt : tl + tr = t) : l + r = t :=
by simp

theorem neg_zero_helper [add_group A] (a : A) (H : a = 0) : - a = 0 :=
by simp

end norm_num

attribute [simp]
  zero_add add_zero one_mul mul_one
  at simplifier.unit

attribute [simp]
  neg_neg sub_eq_add_neg
  at simplifier.neg

attribute [simp]
  add.assoc add.comm add.left_comm
  mul.left_comm mul.comm mul.assoc
  at simplifier.ac