/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.fintype

universes u v
open equiv function fintype finset
variables {α : Type u} {β : Type v}

namespace equiv.perm

def subtype_perm (f : perm α) {p : α → Prop} (h : ∀ x, p x ↔ p (f x)) : perm {x // p x} :=
⟨λ x, ⟨f x, (h _).1 x.2⟩, λ x, ⟨f⁻¹ x, (h (f⁻¹ x)).2 $ by simpa using x.2⟩,
  λ _, by simp, λ _, by simp⟩

@[simp] lemma subtype_perm_one (p : α → Prop) (h : ∀ x, p x ↔ p ((1 : perm α) x)) : @subtype_perm α 1 p h = 1 :=
equiv.ext _ _ $ λ ⟨_, _⟩, rfl

def of_subtype {p : α → Prop} [decidable_pred p] (f : perm (subtype p)) : perm α :=
⟨λ x, if h : p x then f ⟨x, h⟩ else x, λ x, if h : p x then f⁻¹ ⟨x, h⟩ else x,
  λ x, have h : ∀ h : p x, p (f ⟨x, h⟩), from λ h, (f ⟨x, h⟩).2,
    by simp; split_ifs at *; simp * at *,
  λ x, have h : ∀ h : p x, p (f⁻¹ ⟨x, h⟩), from λ h, (f⁻¹ ⟨x, h⟩).2,
    by simp; split_ifs at *; simp * at *⟩

instance of_subtype.is_group_hom {p : α → Prop} [decidable_pred p] : is_group_hom (@of_subtype α p _) :=
⟨λ f g, equiv.ext _ _ $ λ x, begin
  rw [of_subtype, of_subtype, of_subtype],
  by_cases h : p x,
  { have h₁ : p (f (g ⟨x, h⟩)), from (f (g ⟨x, h⟩)).2,
    have h₂ : p (g ⟨x, h⟩), from (g ⟨x, h⟩).2,
    simp [h, h₁, h₂] },
  { simp [h] }
end⟩

@[simp] lemma of_subtype_one (p : α → Prop) [decidable_pred p] : @of_subtype α p _ 1 = 1 :=
is_group_hom.one of_subtype

lemma eq_inv_iff_eq {f : perm α} {x y : α} : x = f⁻¹ y ↔ f x = y :=
by conv {to_lhs, rw [← injective.eq_iff f.injective, apply_inv_self]}

lemma inv_eq_iff_eq {f : perm α} {x y : α} : f⁻¹ x = y ↔ x = f y :=
by rw [eq_comm, eq_inv_iff_eq, eq_comm]

def disjoint (f g : perm α) := ∀ x, f x = x ∨ g x = x

@[symm] lemma disjoint.symm {f g : perm α} : disjoint f g → disjoint g f :=
by simp [disjoint, or.comm]

lemma disjoint_comm {f g : perm α} : disjoint f g ↔ disjoint g f :=
⟨disjoint.symm, disjoint.symm⟩

lemma disjoint_mul_comm {f g : perm α} (h : disjoint f g) : f * g = g * f :=
equiv.ext _ _ $ λ x, (h x).elim
  (λ hf, (h (g x)).elim (λ hg, by simp [mul_apply, hf, hg])
    (λ hg, by simp [mul_apply, hf, g.injective hg]))
  (λ hg, (h (f x)).elim (λ hf, by simp [mul_apply, f.injective hf, hg])
    (λ hf, by simp [mul_apply, hf, hg]))

@[simp] lemma disjoint_one_left (f : perm α) : disjoint 1 f := λ _, or.inl rfl

@[simp] lemma disjoint_one_right (f : perm α) : disjoint f 1 := λ _, or.inr rfl

lemma disjoint_mul_left {f g h : perm α} (H1 : disjoint f h) (H2 : disjoint g h) :
  disjoint (f * g) h :=
λ x, by cases H1 x; cases H2 x; simp *

lemma disjoint_mul_right {f g h : perm α} (H1 : disjoint f g) (H2 : disjoint f h) :
  disjoint f (g * h) :=
by rw disjoint_comm; exact disjoint_mul_left H1.symm H2.symm

lemma disjoint_prod_right {f : perm α} (l : list (perm α))
  (h : ∀ g ∈ l, disjoint f g) : disjoint f l.prod :=
begin
  induction l with g l ih,
  { exact disjoint_one_right _ },
  { rw list.prod_cons;
    exact disjoint_mul_right (h _ (list.mem_cons_self _ _))
      (ih (λ g hg, h g (list.mem_cons_of_mem _ hg))) }
end

lemma disjoint_prod_perm {l₁ l₂ : list (perm α)} (hl : l₁.pairwise disjoint)
  (hp : l₁ ~ l₂) : l₁.prod = l₂.prod :=
begin
  induction hp,
  { refl },
  { rw [list.prod_cons, list.prod_cons, hp_ih (list.pairwise_cons.1 hl).2] },
  { simp [list.prod_cons, disjoint_mul_comm, (mul_assoc _ _ _).symm, *,
      list.pairwise_cons] at * },
  { rw [hp_ih_a hl, hp_ih_a_1 ((list.perm_pairwise (λ x y (h : disjoint x y), disjoint.symm h) hp_a).1 hl)] }
end

lemma of_subtype_subtype_perm {f : perm α} {p : α → Prop} [decidable_pred p] (h₁ : ∀ x, p x ↔ p (f x))
  (h₂ : ∀ x, f x ≠ x → p x) : of_subtype (subtype_perm f h₁) = f :=
equiv.ext _ _ $ λ x, begin
  rw [of_subtype, subtype_perm],
  by_cases hx : p x,
  { simp [hx] },
  { haveI := classical.prop_decidable,
    simp [hx, not_not.1 (mt (h₂ x) hx)] }
end

lemma of_subtype_apply_of_not_mem {p : α → Prop} [decidable_pred p] (f : perm (subtype p)) {x : α} (hx : ¬ p x) :
  of_subtype f x = x := dif_neg hx

lemma mem_iff_of_subtype_apply_mem {p : α → Prop} [decidable_pred p] (f : perm (subtype p)) (x : α) :
  p x ↔ p ((of_subtype f : α → α) x) :=
if h : p x then by dsimp [of_subtype]; simpa [h] using (f ⟨x, h⟩).2
else by simp [h, of_subtype_apply_of_not_mem f h]

@[simp] lemma subtype_perm_of_subtype {p : α → Prop} [decidable_pred p] (f : perm (subtype p)) :
  subtype_perm (of_subtype f) (mem_iff_of_subtype_apply_mem f) = f :=
equiv.ext _ _ $ λ ⟨x, hx⟩, by dsimp [subtype_perm, of_subtype]; simp [show p x, from hx]

lemma pow_apply_eq_self_of_apply_eq_self {f : perm α} {x : α} (hfx : f x = x) :
  ∀ n : ℕ, (f ^ n) x = x
| 0     := rfl
| (n+1) := by rw [pow_succ', mul_apply, hfx, pow_apply_eq_self_of_apply_eq_self]

lemma gpow_apply_eq_self_of_apply_eq_self {f : perm α} {x : α} (hfx : f x = x) :
  ∀ n : ℤ, (f ^ n) x = x
| (n : ℕ) := pow_apply_eq_self_of_apply_eq_self hfx n
| -[1+ n] := by rw [gpow_neg_succ, inv_eq_iff_eq, pow_apply_eq_self_of_apply_eq_self hfx]

lemma pow_apply_eq_of_apply_apply_eq_self {f : perm α} {x : α} (hffx : f (f x) = x) :
  ∀ n : ℕ, (f ^ n) x = x ∨ (f ^ n) x = f x
| 0     := or.inl rfl
| (n+1) := (pow_apply_eq_of_apply_apply_eq_self n).elim
  (λ h, or.inr (by rw [pow_succ, mul_apply, h]))
  (λ h, or.inl (by rw [pow_succ, mul_apply, h, hffx]))

lemma gpow_apply_eq_of_apply_apply_eq_self {f : perm α} {x : α} (hffx : f (f x) = x) :
  ∀ i : ℤ, (f ^ i) x = x ∨ (f ^ i) x = f x
| (n : ℕ) := pow_apply_eq_of_apply_apply_eq_self hffx n
| -[1+ n] :=
  by rw [gpow_neg_succ, inv_eq_iff_eq, ← injective.eq_iff f.injective, ← mul_apply, ← pow_succ,
    eq_comm, inv_eq_iff_eq, ← mul_apply, ← pow_succ', @eq_comm _ x, or.comm];
  exact pow_apply_eq_of_apply_apply_eq_self hffx _

variable [decidable_eq α]

def support [fintype α] (f : perm α) := univ.filter (λ x, f x ≠ x)

@[simp] lemma mem_support [fintype α] {f : perm α} {x : α} : x ∈ f.support ↔ f x ≠ x :=
by simp [support]

def is_swap (f : perm α) := ∃ x y, x ≠ y ∧ f = swap x y

lemma swap_mul_eq_mul_swap (f : perm α) (x y : α) : swap x y * f = f * swap (f⁻¹ x) (f⁻¹ y) :=
equiv.ext _ _ $ λ z, begin
  simp [mul_apply, swap_apply_def],
  split_ifs;
  simp [*, eq_inv_iff_eq] at * <|> cc
end

lemma mul_swap_eq_swap_mul (f : perm α) (x y : α) : f * swap x y = swap (f x) (f y) * f :=
by rw [swap_mul_eq_mul_swap, inv_apply_self, inv_apply_self]

@[simp] lemma swap_mul_self (i j : α) : equiv.swap i j * equiv.swap i j = 1 :=
equiv.swap_swap i j

@[simp] lemma swap_swap_apply (i j k : α) : equiv.swap i j (equiv.swap i j k) = k :=
equiv.swap_core_swap_core k i j

lemma is_swap_of_subtype {p : α → Prop} [decidable_pred p]
  {f : perm (subtype p)} (h : is_swap f) : is_swap (of_subtype f) :=
let ⟨⟨x, hx⟩, ⟨y, hy⟩, hxy⟩ := h in
⟨x, y, by simp at hxy; tauto,
  equiv.ext _ _ $ λ z, begin
    rw [hxy.2, of_subtype],
    simp [swap_apply_def],
    split_ifs;
    cc <|> simp * at *
  end⟩

lemma ne_and_ne_of_swap_mul_apply_ne_self {f : perm α} {x y : α}
  (hy : (swap x (f x) * f) y ≠ y) : f y ≠ y ∧ y ≠ x :=
begin
  simp only [swap_apply_def, mul_apply, injective.eq_iff f.injective] at *,
  by_cases h : f y = x,
  { split; intro; simp * at * },
  { split_ifs at hy; cc }
end

lemma support_swap_mul_eq [fintype α] {f : perm α} {x : α}
  (hffx : f (f x) ≠ x) : (swap x (f x) * f).support = f.support.erase x :=
have hfx : f x ≠ x, from λ hfx, by simpa [hfx] using hffx,
finset.ext.2 $ λ y,
⟨λ hy, have hy' : (swap x (f x) * f) y ≠ y, from mem_support.1 hy,
    mem_erase.2 ⟨λ hyx, by simp [hyx, mul_apply, *] at *,
    mem_support.2 $ λ hfy,
      by simp only [mul_apply, swap_apply_def, hfy] at hy';
      split_ifs at hy'; simp * at *⟩,
  λ hy, by simp only [mem_erase, mem_support, swap_apply_def, mul_apply] at *;
    intro; split_ifs at *; simp * at *⟩

lemma card_support_swap_mul [fintype α] {f : perm α} {x : α}
  (hx : f x ≠ x) : (swap x (f x) * f).support.card < f.support.card :=
finset.card_lt_card
  ⟨λ z hz, mem_support.2 (ne_and_ne_of_swap_mul_apply_ne_self (mem_support.1 hz)).1,
    λ h, absurd (h (mem_support.2 hx)) (mt mem_support.1 (by simp))⟩

def swap_factors_aux : Π (l : list α) (f : perm α), (∀ {x}, f x ≠ x → x ∈ l) →
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g}
| []       := λ f h, ⟨[], equiv.ext _ _ $ λ x, by rw [list.prod_nil];
    exact eq.symm (not_not.1 (mt h (list.not_mem_nil _))), by simp⟩
| (x :: l) := λ f h,
if hfx : x = f x
then swap_factors_aux l f
  (λ y hy, list.mem_of_ne_of_mem (λ h : y = x, by simpa [h, hfx.symm] using hy) (h hy))
else let m := swap_factors_aux l (swap x (f x) * f)
      (λ y hy, have f y ≠ y ∧ y ≠ x, from ne_and_ne_of_swap_mul_apply_ne_self hy,
        list.mem_of_ne_of_mem this.2 (h this.1)) in
  ⟨swap x (f x) :: m.1,
  by rw [list.prod_cons, m.2.1, ← mul_assoc,
    mul_def (swap x (f x)), swap_swap, ← one_def, one_mul],
  λ g hg, ((list.mem_cons_iff _ _ _).1 hg).elim (λ h, ⟨x, f x, hfx, h⟩) (m.2.2 _)⟩

/-- `swap_factors` represents a permutation as a product of a list of transpositions.
The representation is non unique and depends on the linear order structure.
For types without linear order `trunc_swap_factors` can be used -/
def swap_factors [fintype α] [decidable_linear_order α] (f : perm α) :
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
swap_factors_aux ((@univ α _).sort (≤)) f (λ _ _, (mem_sort _).2 (mem_univ _))

def trunc_swap_factors [fintype α] (f : perm α) :
  trunc {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
quotient.rec_on_subsingleton (@univ α _).1
(λ l h, trunc.mk (swap_factors_aux l f h))
(show ∀ x, f x ≠ x → x ∈ (@univ α _).1, from λ _ _, mem_univ _)

@[elab_as_eliminator] lemma swap_induction_on [fintype α] {P : perm α → Prop} (f : perm α) :
  P 1 → (∀ f x y, x ≠ y → P f → P (swap x y * f)) → P f :=
begin
  cases trunc.out (trunc_swap_factors f) with l hl,
  induction l with g l ih generalizing f,
  { simp [hl.1.symm] {contextual := tt} },
  { assume h1 hmul_swap,
    rcases hl.2 g (by simp) with ⟨x, y, hxy⟩,
    rw [← hl.1, list.prod_cons, hxy.2],
    exact hmul_swap _ _ _ hxy.1 (ih _ ⟨rfl, λ v hv, hl.2 _ (list.mem_cons_of_mem _ hv)⟩ h1 hmul_swap) }
end

lemma swap_mul_swap_mul_swap {x y z : α} (hwz: x ≠ y) (hxz : x ≠ z) :
  swap y z * swap x y * swap y z = swap z x :=
equiv.ext _ _ $ λ n, by simp only [swap_apply_def, mul_apply]; split_ifs; cc

lemma is_conj_swap {w x y z : α} (hwx : w ≠ x) (hyz : y ≠ z) : is_conj (swap w x) (swap y z) :=
have h : ∀ {y z : α}, y ≠ z → w ≠ z →
    (swap w y * swap x z) * swap w x * (swap w y * swap x z)⁻¹ = swap y z :=
  λ y z hyz hwz, by rw [mul_inv_rev, swap_inv, swap_inv, mul_assoc (swap w y),
    mul_assoc (swap w y),  ← mul_assoc _ (swap x z), swap_mul_swap_mul_swap hwx hwz,
    ← mul_assoc, swap_mul_swap_mul_swap hwz.symm hyz.symm],
if hwz : w = z
then have hwy : w ≠ y, by cc,
  ⟨swap w z * swap x y, by rw [swap_comm y z, h hyz.symm hwy]⟩
else ⟨swap w y * swap x z, h hyz hwz⟩

/-- set of all pairs (⟨a, b⟩ : Σ a : fin n, fin n) such that b < a -/
def fin_pairs_lt (n : ℕ) : finset (Σ a : fin n, fin n) :=
(univ : finset (fin n)).sigma (λ a, (range a.1).attach_fin
  (λ m hm, lt_trans (mem_range.1 hm) a.2))

lemma mem_fin_pairs_lt {n : ℕ} {a : Σ a : fin n, fin n} :
  a ∈ fin_pairs_lt n ↔ a.2 < a.1 :=
by simp [fin_pairs_lt, fin.lt_def]

def sign_aux {n : ℕ} (a : perm (fin n)) : units ℤ :=
(fin_pairs_lt n).prod (λ x, if a x.1 ≤ a x.2 then -1 else 1)

@[simp] lemma sign_aux_one (n : ℕ) : sign_aux (1 : perm (fin n)) = 1 :=
begin
  unfold sign_aux,
  conv { to_rhs, rw ← @finset.prod_const_one _ (units ℤ)
    (fin_pairs_lt n) },
  exact finset.prod_congr rfl (λ a ha, if_neg
    (not_le_of_gt (mem_fin_pairs_lt.1 ha)))
end

def sign_bij_aux {n : ℕ} (f : perm (fin n)) (a : Σ a : fin n, fin n) :
  Σ a : fin n, fin n :=
if hxa : f a.2 < f a.1 then ⟨f a.1, f a.2⟩ else ⟨f a.2, f a.1⟩

lemma sign_bij_aux_inj {n : ℕ} {f : perm (fin n)} : ∀ a b : Σ a : fin n, fin n,
   a ∈ fin_pairs_lt n → b ∈ fin_pairs_lt n →
   sign_bij_aux f a = sign_bij_aux f b → a = b :=
λ ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ha hb h, begin
  unfold sign_bij_aux at h,
  rw mem_fin_pairs_lt at *,
  have : ¬b₁ < b₂ := not_lt_of_ge (le_of_lt hb),
  split_ifs at h;
  simp [*, injective.eq_iff f.injective, sigma.mk.inj_eq] at *
end

lemma sign_bij_aux_surj {n : ℕ} {f : perm (fin n)} : ∀ a ∈ fin_pairs_lt n,
  ∃ b ∈ fin_pairs_lt n, a = sign_bij_aux f b :=
λ ⟨a₁, a₂⟩ ha,
if hxa : f⁻¹ a₂ < f⁻¹ a₁
then ⟨⟨f⁻¹ a₁, f⁻¹ a₂⟩, mem_fin_pairs_lt.2 hxa,
  by dsimp [sign_bij_aux];
    rw [apply_inv_self, apply_inv_self, dif_pos (mem_fin_pairs_lt.1 ha)]⟩
else ⟨⟨f⁻¹ a₂, f⁻¹ a₁⟩, mem_fin_pairs_lt.2 $ lt_of_le_of_ne
  (le_of_not_gt hxa) $ λ h,
    by simpa [mem_fin_pairs_lt, (f⁻¹).injective h, lt_irrefl] using ha,
  by dsimp [sign_bij_aux];
    rw [apply_inv_self, apply_inv_self,
      dif_neg (not_lt_of_ge (le_of_lt (mem_fin_pairs_lt.1 ha)))]⟩

lemma sign_bij_aux_mem {n : ℕ} {f : perm (fin n)}: ∀ a : Σ a : fin n, fin n,
  a ∈ fin_pairs_lt n → sign_bij_aux f a ∈ fin_pairs_lt n :=
λ ⟨a₁, a₂⟩ ha, begin
  unfold sign_bij_aux,
  split_ifs with h,
  { exact mem_fin_pairs_lt.2 h },
  { exact mem_fin_pairs_lt.2
    (lt_of_le_of_ne (le_of_not_gt h)
      (λ h, ne_of_lt (mem_fin_pairs_lt.1 ha) (f.injective h.symm))) }
end

@[simp] lemma sign_aux_inv {n : ℕ} (f : perm (fin n)) : sign_aux f⁻¹ = sign_aux f :=
prod_bij (λ a ha, sign_bij_aux f⁻¹ a)
sign_bij_aux_mem
(λ ⟨a, b⟩ hab, if h : f⁻¹ b < f⁻¹ a
  then by rw [sign_bij_aux, dif_pos h, if_neg (not_le_of_gt h), apply_inv_self,
    apply_inv_self, if_neg (not_le_of_gt $ mem_fin_pairs_lt.1 hab)]
  else by rw [sign_bij_aux, if_pos (le_of_not_gt h), dif_neg h, apply_inv_self,
    apply_inv_self, if_pos (le_of_lt $ mem_fin_pairs_lt.1 hab)])
sign_bij_aux_inj
sign_bij_aux_surj

lemma sign_aux_mul {n : ℕ} (f g : perm (fin n)) :
  sign_aux (f * g) = sign_aux f * sign_aux g :=
begin
  rw ← sign_aux_inv g,
  unfold sign_aux,
  rw  ← prod_mul_distrib,
  refine prod_bij (λ a ha, sign_bij_aux g a) sign_bij_aux_mem _
    sign_bij_aux_inj sign_bij_aux_surj,
  rintros ⟨a, b⟩ hab,
  rw [sign_bij_aux, mul_apply, mul_apply],
  rw mem_fin_pairs_lt at hab,
  by_cases h : g b < g a,
  { rw dif_pos h,
    simp [not_le_of_gt hab]; congr },
  { rw [dif_neg h, inv_apply_self, inv_apply_self, if_pos (le_of_lt hab)],
    by_cases h₁ : f (g b) ≤ f (g a),
    { have : f (g b) ≠ f (g a),
      { rw [ne.def, injective.eq_iff f.injective,
          injective.eq_iff g.injective];
        exact ne_of_lt hab },
      rw [if_pos h₁, if_neg (not_le_of_gt  (lt_of_le_of_ne h₁ this))],
      refl },
    { rw [if_neg h₁, if_pos (le_of_lt (lt_of_not_ge h₁))],
      refl } }
end

instance sign_aux.is_group_hom {n : ℕ} : is_group_hom (@sign_aux n) := ⟨sign_aux_mul⟩

private lemma sign_aux_swap_zero_one {n : ℕ} (hn : 2 ≤ n) :
  sign_aux (swap (⟨0, lt_of_lt_of_le dec_trivial hn⟩ : fin n)
  ⟨1, lt_of_lt_of_le dec_trivial hn⟩) = -1 :=
let zero : fin n := ⟨0, lt_of_lt_of_le dec_trivial hn⟩ in
let one : fin n := ⟨1, lt_of_lt_of_le dec_trivial hn⟩ in
have hzo : zero < one := dec_trivial,
show _ = (finset.singleton (⟨one, zero⟩ : Σ a : fin n, fin n)).prod
  (λ x : Σ a : fin n, fin n, if (equiv.swap zero one) x.1
  ≤ swap zero one x.2 then (-1 : units ℤ) else 1),
begin
  refine eq.symm (prod_subset (λ ⟨x₁, x₂⟩, by simp [mem_fin_pairs_lt, hzo] {contextual := tt})
    (λ a ha₁ ha₂, _)),
  rcases a with ⟨⟨a₁, ha₁⟩, ⟨a₂, ha₂⟩⟩,
  replace ha₁ : a₂ < a₁ := mem_fin_pairs_lt.1 ha₁,
  simp only [swap_apply_def],
  have : ¬ 1 ≤ a₂ → a₂ = 0, from λ h, nat.le_zero_iff.1 (nat.le_of_lt_succ (lt_of_not_ge h)),
  have : a₁ ≤ 1 → a₁ = 0 ∨ a₁ = 1, from nat.cases_on a₁ (λ _, or.inl rfl)
    (λ a₁, nat.cases_on a₁ (λ _, or.inr rfl) (λ _ h, absurd h dec_trivial)),
  split_ifs;
  simp [*, lt_irrefl, -not_lt, not_le.symm, -not_le, le_refl, fin.lt_def, fin.le_def, nat.zero_le,
    zero, one, iff.intro fin.veq_of_eq fin.eq_of_veq, nat.le_zero_iff] at *,
end

lemma sign_aux_swap : ∀ {n : ℕ} {x y : fin n} (hxy : x ≠ y),
  sign_aux (swap x y) = -1
| 0 := dec_trivial
| 1 := dec_trivial
| (n+2) := λ x y hxy,
have h2n : 2 ≤ n + 2 := dec_trivial,
by rw [← is_conj_iff_eq, ← sign_aux_swap_zero_one h2n];
  exact is_group_hom.is_conj _ (is_conj_swap hxy dec_trivial)

def sign_aux2 : list α → perm α → units ℤ
| []     f := 1
| (x::l) f := if x = f x then sign_aux2 l f else -sign_aux2 l (swap x (f x) * f)

lemma sign_aux_eq_sign_aux2 {n : ℕ} : ∀ (l : list α) (f : perm α) (e : α ≃ fin n)
  (h : ∀ x, f x ≠ x → x ∈ l), sign_aux ((e.symm.trans f).trans e) = sign_aux2 l f
| []     f e h := have f = 1, from equiv.ext _ _ $
  λ y, not_not.1 (mt (h y) (list.not_mem_nil _)),
by rw [this, one_def, equiv.trans_refl, equiv.symm_trans, ← one_def,
  sign_aux_one, sign_aux2]
| (x::l) f e h := begin
  rw sign_aux2,
  by_cases hfx : x = f x,
  { rw if_pos hfx,
    exact sign_aux_eq_sign_aux2 l f _ (λ y (hy : f y ≠ y), list.mem_of_ne_of_mem
      (λ h : y = x, by simpa [h, hfx.symm] using hy) (h y hy) ) },
  { have hy : ∀ y : α, (swap x (f x) * f) y ≠ y → y ∈ l,
      from λ y hy, have f y ≠ y ∧ y ≠ x, from ne_and_ne_of_swap_mul_apply_ne_self hy,
      list.mem_of_ne_of_mem this.2 (h _ this.1),
    have : (e.symm.trans (swap x (f x) * f)).trans e =
      (swap (e x) (e (f x))) * (e.symm.trans f).trans e,
      from equiv.ext _ _ (λ z, by rw ← equiv.symm_trans_swap_trans; simp [mul_def]),
    have hefx : e x ≠ e (f x), from mt (injective.eq_iff e.injective).1 hfx,
    rw [if_neg hfx, ← sign_aux_eq_sign_aux2 _ _ e hy, this, sign_aux_mul, sign_aux_swap hefx],
    simp }
end

def sign_aux3 [fintype α] (f : perm α) {s : multiset α} : (∀ x, x ∈ s) → units ℤ :=
quotient.hrec_on s (λ l h, sign_aux2 l f)
  (trunc.induction_on (equiv_fin α)
    (λ e l₁ l₂ h, function.hfunext
      (show (∀ x, x ∈ l₁) = ∀ x, x ∈ l₂, by simp [list.mem_of_perm h])
      (λ h₁ h₂ _, by rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₁ _),
        ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₂ _)])))

lemma sign_aux3_mul_and_swap [fintype α] (f g : perm α) (s : multiset α) (hs : ∀ x, x ∈ s) :
  sign_aux3 (f * g) hs = sign_aux3 f hs * sign_aux3 g hs ∧ ∀ x y, x ≠ y →
  sign_aux3 (swap x y) hs = -1 :=
let ⟨l, hl⟩ := quotient.exists_rep s in
let ⟨e, _⟩ := trunc.exists_rep (equiv_fin α) in
begin
  clear _let_match _let_match,
  subst hl,
  show sign_aux2 l (f * g) = sign_aux2 l f * sign_aux2 l g ∧
    ∀ x y, x ≠ y → sign_aux2 l (swap x y) = -1,
  have hfg : (e.symm.trans (f * g)).trans e = (e.symm.trans f).trans e * (e.symm.trans g).trans e,
    from equiv.ext _ _ (λ h, by simp [mul_apply]),
  split,
  { rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _),
      ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), hfg, sign_aux_mul] },
  { assume x y hxy,
    have hexy : e x ≠ e y, from mt (injective.eq_iff e.injective).1 hxy,
    rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), equiv.symm_trans_swap_trans, sign_aux_swap hexy] }
end

/-- `sign` of a permutation returns the signature or parity of a permutation, `1` for even
permutations, `-1` for odd permutations. It is the unique surjective group homomorphism from
`perm α` to the group with two elements.-/
def sign [fintype α] (f : perm α) := sign_aux3 f mem_univ

instance sign.is_group_hom [fintype α] : is_group_hom (@sign α _ _) :=
⟨λ f g, (sign_aux3_mul_and_swap f g _ mem_univ).1⟩

section sign

variable [fintype α]

@[simp] lemma sign_mul (f g : perm α) : sign (f * g) = sign f * sign g :=
is_group_hom.mul sign _ _

@[simp] lemma sign_one : (sign (1 : perm α)) = 1 :=
is_group_hom.one sign

@[simp] lemma sign_refl : sign (equiv.refl α) = 1 :=
is_group_hom.one sign

@[simp] lemma sign_inv (f : perm α) : sign f⁻¹ = sign f :=
by rw [is_group_hom.inv sign, int.units_inv_eq_self]; apply_instance

lemma sign_swap {x y : α} (h : x ≠ y) : sign (swap x y) = -1 :=
(sign_aux3_mul_and_swap 1 1 _ mem_univ).2 x y h

@[simp] lemma sign_swap' {x y : α} :
  (swap x y).sign = if x = y then 1 else -1 :=
if H : x = y then by simp [H, swap_self] else
by simp [sign_swap H, H]

lemma sign_eq_of_is_swap {f : perm α} (h : is_swap f) : sign f = -1 :=
let ⟨x, y, hxy⟩ := h in hxy.2.symm ▸ sign_swap hxy.1

lemma sign_symm_trans_trans [decidable_eq β] [fintype β] (f : perm α)
  (e : α ≃ β) : sign ((e.symm.trans f).trans e) = sign f :=
sign_aux3_symm_trans_trans f e mem_univ mem_univ

lemma sign_prod_list_swap {l : list (perm α)}
  (hl : ∀ g ∈ l, is_swap g) : sign l.prod = -1 ^ l.length :=
have h₁ : l.map sign = list.repeat (-1) l.length :=
  list.eq_repeat.2 ⟨by simp, λ u hu,
  let ⟨g, hg⟩ := list.mem_map.1 hu in
  hg.2 ▸ sign_eq_of_is_swap (hl _ hg.1)⟩,
by rw [← list.prod_repeat, ← h₁, ← is_group_hom.prod (@sign α _ _)]

lemma sign_surjective (hα : 1 < fintype.card α) : function.surjective (sign : perm α → units ℤ) :=
λ a, (int.units_eq_one_or a).elim
  (λ h, ⟨1, by simp [h]⟩)
  (λ h, let ⟨x⟩ := fintype.card_pos_iff.1 (lt_trans zero_lt_one hα) in
    let ⟨y, hxy⟩ := fintype.exists_ne_of_card_gt_one hα x in
    ⟨swap y x, by rw [sign_swap hxy, h]⟩ )

lemma eq_sign_of_surjective_hom {s : perm α → units ℤ}
  [is_group_hom s] (hs : surjective s) : s = sign :=
have ∀ {f}, is_swap f → s f = -1 :=
  λ f ⟨x, y, hxy, hxy'⟩, hxy'.symm ▸ by_contradiction (λ h,
    have ∀ f, is_swap f → s f = 1 := λ f ⟨a, b, hab, hab'⟩,
      by rw [← is_conj_iff_eq, ← or.resolve_right (int.units_eq_one_or _) h, hab'];
        exact is_group_hom.is_conj _ (is_conj_swap hab hxy),
  let ⟨g, hg⟩ := hs (-1) in
  let ⟨l, hl⟩ := trunc.out (trunc_swap_factors g) in
  have ∀ a ∈ l.map s, a = (1 : units ℤ) := λ a ha,
    let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸ this _ (hl.2 _ hg.1),
  have s l.prod = 1,
    by rw [is_group_hom.prod s, list.eq_repeat'.2 this, list.prod_repeat, one_pow],
  by rw [hl.1, hg] at this;
    exact absurd this dec_trivial),
funext $ λ f,
let ⟨l, hl₁, hl₂⟩ := trunc.out (trunc_swap_factors f) in
have hsl : ∀ a ∈ l.map s, a = (-1 : units ℤ) := λ a ha,
  let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸  this (hl₂ _ hg.1),
by rw [← hl₁, is_group_hom.prod s, list.eq_repeat'.2 hsl, list.length_map,
     list.prod_repeat, sign_prod_list_swap hl₂]

lemma sign_subtype_perm (f : perm α) {p : α → Prop} [decidable_pred p]
  (h₁ : ∀ x, p x ↔ p (f x)) (h₂ : ∀ x, f x ≠ x → p x) : sign (subtype_perm f h₁) = sign f :=
let l := trunc.out (trunc_swap_factors (subtype_perm f h₁)) in
have hl' : ∀ g' ∈ l.1.map of_subtype, is_swap g' :=
  λ g' hg',
  let ⟨g, hg⟩ := list.mem_map.1 hg' in
  hg.2 ▸ is_swap_of_subtype (l.2.2 _ hg.1),
have hl'₂ : (l.1.map of_subtype).prod = f,
  by rw [← is_group_hom.prod of_subtype l.1, l.2.1, of_subtype_subtype_perm _ h₂],
by conv {congr, rw ← l.2.1, skip, rw ← hl'₂};
  rw [sign_prod_list_swap l.2.2, sign_prod_list_swap hl', list.length_map]

@[simp] lemma sign_of_subtype {p : α → Prop} [decidable_pred p]
  (f : perm (subtype p)) : sign (of_subtype f) = sign f :=
have ∀ x, of_subtype f x ≠ x → p x, from λ x, not_imp_comm.1 (of_subtype_apply_of_not_mem f),
by conv {to_rhs, rw [← subtype_perm_of_subtype f, sign_subtype_perm _ _ this]}

lemma sign_eq_sign_of_equiv [decidable_eq β] [fintype β] (f : perm α) (g : perm β)
  (e : α ≃ β) (h : ∀ x, e (f x) = g (e x)) : sign f = sign g :=
have hg : g = (e.symm.trans f).trans e, from equiv.ext _ _ $ by simp [h],
by rw [hg, sign_symm_trans_trans]

lemma sign_bij [decidable_eq β] [fintype β]
  {f : perm α} {g : perm β} (i : Π x : α, f x ≠ x → β)
  (h : ∀ x hx hx', i (f x) hx' = g (i x hx))
  (hi : ∀ x₁ x₂ hx₁ hx₂, i x₁ hx₁ = i x₂ hx₂ → x₁ = x₂)
  (hg : ∀ y, g y ≠ y → ∃ x hx, i x hx = y) :
  sign f = sign g :=
calc sign f = sign (@subtype_perm _ f (λ x, f x ≠ x) (by simp)) :
  eq.symm (sign_subtype_perm _ _ (λ _, id))
... = sign (@subtype_perm _ g (λ x, g x ≠ x) (by simp)) :
  sign_eq_sign_of_equiv _ _
    (equiv.of_bijective
      (show function.bijective (λ x : {x // f x ≠ x},
        (⟨i x.1 x.2, have f (f x) ≠ f x, from mt (λ h, f.injective h) x.2,
          by rw [← h _ x.2 this]; exact mt (hi _ _ this x.2) x.2⟩ : {y // g y ≠ y})),
        from ⟨λ ⟨x, hx⟩ ⟨y, hy⟩ h, subtype.eq (hi _ _ _ _ (subtype.mk.inj h)),
          λ ⟨y, hy⟩, let ⟨x, hfx, hx⟩ := hg y hy in ⟨⟨x, hfx⟩, subtype.eq hx⟩⟩))
      (λ ⟨x, _⟩, subtype.eq (h x _ _))
... = sign g : sign_subtype_perm _ _ (λ _, id)

def is_cycle (f : perm β) := ∃ x, f x ≠ x ∧ ∀ y, f y ≠ y → ∃ i : ℤ, (f ^ i) x = y

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

lemma is_cycle_inv {f : perm β} (hf : is_cycle f) : is_cycle (f⁻¹) :=
let ⟨x, hx⟩ := hf in
⟨x, by simp [eq_inv_iff_eq, inv_eq_iff_eq, *] at *; cc,
  λ y hy, let ⟨i, hi⟩ := hx.2 y (by simp [eq_inv_iff_eq, inv_eq_iff_eq, *] at *; cc) in
    ⟨-i, by rwa [gpow_neg, inv_gpow, inv_inv]⟩⟩

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

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

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

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

lemma is_cycle_swap_mul {f : perm α} (hf : is_cycle f) {x : α}
  (hx : f x ≠ x) (hffx : f (f x) ≠ x) : is_cycle (swap x (f x) * f) :=
⟨f x, by simp only [swap_apply_def, mul_apply];
        split_ifs; simp [injective.eq_iff f.injective] at *; cc,
  λ y hy,
  let ⟨i, hi⟩ := exists_gpow_eq_of_is_cycle hf hx (ne_and_ne_of_swap_mul_apply_ne_self hy).1 in
  have hi : (f ^ (i - 1)) (f x) = y, from
    calc (f ^ (i - 1)) (f x) = (f ^ (i - 1) * f ^ (1 : ℤ)) x : by rw [gpow_one, mul_apply]
    ... =  y : by rwa [← gpow_add, sub_add_cancel],
  is_cycle_swap_mul_aux₂ (i - 1) hy hi⟩

@[simp] lemma support_swap [fintype α] {x y : α} (hxy : x ≠ y) : (swap x y).support = {x, y} :=
finset.ext.2 $ λ a, by simp [swap_apply_def]; split_ifs; cc

lemma card_support_swap [fintype α] {x y : α} (hxy : x ≠ y) : (swap x y).support.card = 2 :=
show (swap x y).support.card = finset.card ⟨x::y::0, by simp [hxy]⟩,
from congr_arg card $ by rw [support_swap hxy]; simp [*, finset.ext]; cc

lemma sign_cycle [fintype α] : ∀ {f : perm α} (hf : is_cycle f),
  sign f = -(-1 ^ f.support.card)
| f := λ hf,
let ⟨x, hx⟩ := hf in
calc sign f = sign (swap x (f x) * (swap x (f x) * f)) :
  by rw [← mul_assoc, mul_def, mul_def, swap_swap, trans_refl]
... = -(-1 ^ f.support.card) :
  if h1 : f (f x) = x
  then
    have h : swap x (f x) * f = 1,
      by conv in (f) {rw eq_swap_of_is_cycle_of_apply_apply_eq_self hf hx.1 h1 };
        simp [mul_def, one_def],
    by rw [sign_mul, sign_swap hx.1.symm, h, sign_one, eq_swap_of_is_cycle_of_apply_apply_eq_self hf hx.1 h1,
        card_support_swap hx.1.symm]; refl
  else
    have h : card (support (swap x (f x) * f)) + 1 = card (support f),
      by rw [← insert_erase (mem_support.2 hx.1), support_swap_mul_eq h1,
        card_insert_of_not_mem (not_mem_erase _ _)],
    have wf : card (support (swap x (f x) * f)) < card (support f),
      from card_support_swap_mul hx.1,
    by rw [sign_mul, sign_swap hx.1.symm, sign_cycle (is_cycle_swap_mul hf hx.1 h1), ← h];
      simp [pow_add]
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ f, f.support.card)⟩]}

end sign

end equiv.perm

lemma finset.prod_univ_perm [fintype α] [comm_monoid β] {f : α → β} (σ : perm α) :
  (univ : finset α).prod f = univ.prod (λ z, f (σ z)) :=
eq.symm $ prod_bij (λ z _, σ z) (λ _ _, mem_univ _) (λ _ _, rfl)
  (λ _ _ _ _ H, σ.injective H) (λ b _, ⟨σ⁻¹ b, mem_univ _, by simp⟩)

lemma finset.sum_univ_perm [fintype α] [add_comm_monoid β] {f : α → β} (σ : perm α) :
  (univ : finset α).sum f = univ.sum (λ z, f (σ z)) :=
@finset.prod_univ_perm _ (multiplicative β) _ _ f σ

attribute [to_additive finset.sum_univ_perm] finset.prod_univ_perm


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Tim Baumann, Stephen Morgan, Scott Morrison

import category_theory.natural_transformation

namespace category_theory

universes u₁ v₁ u₂ v₂ u₃ v₃

open nat_trans

/--
`functor.category C D` gives the category structure on functor and natural transformations between categories `C` and `D`.

Notice that if `C` and `D` are both small categories at the same universe level, this is another small category at that level.
However if `C` and `D` are both large categories at the same universe level, this is a small category at the next higher level.
-/
instance functor.category (C : Type u₁) [category.{u₁ v₁} C] (D : Type u₂) [category.{u₂ v₂} D] :
  category.{(max u₁ v₁ u₂ v₂) (max u₁ v₂)} (C ⥤ D) :=
{ hom     := λ F G, F ⟹ G,
  id      := λ F, nat_trans.id F,
  comp    := λ _ _ _ α β, α ⊟ β }

namespace functor.category

section
variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C] {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

@[simp] lemma id_app (F : C ⥤ D) (X : C) : (𝟙 F : F ⟹ F) X = 𝟙 (F X) := rfl
@[simp] lemma comp_app {F G H : C ⥤ D} (α : F ⟶ G) (β : G ⟶ H) (X : C) :
  ((α ≫ β) : F ⟹ H) X = (α : F ⟹ G) X ≫ (β : G ⟹ H) X := rfl
end

namespace nat_trans
-- This section gives two lemmas about natural transformations between functors into functor categories,
-- spelling them out in components.

variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C]
          {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
          {E : Type u₃} [ℰ : category.{u₃ v₃} E]
include 𝒞 𝒟 ℰ

lemma app_naturality {F G : C ⥤ (D ⥤ E)} (T : F ⟹ G) (X : C) {Y Z : D} (f : Y ⟶ Z) :
  ((F X).map f) ≫ ((T X) Z) = ((T X) Y) ≫ ((G X).map f) := (T X).naturality f

lemma naturality_app {F G : C ⥤ (D ⥤ E)} (T : F ⟹ G) (Z : D) {X Y : C} (f : X ⟶ Y) :
  ((F.map f) Z) ≫ ((T Y) Z) = ((T X) Z) ≫ ((G.map f) Z) := congr_fun (congr_arg app (T.naturality f)) Z

end nat_trans

end functor.category

end category_theory


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis

! This file was ported from Lean 3 source module topology.algebra.polynomial
! leanprover-community/mathlib commit 565eb991e264d0db702722b4bde52ee5173c9950
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Polynomial.AlgebraMap
import Mathlib.Data.Polynomial.Inductions
import Mathlib.Data.Polynomial.Splits
import Mathlib.RingTheory.Polynomial.Vieta
import Mathlib.Analysis.Normed.Field.Basic

/-!
# Polynomials and limits

In this file we prove the following lemmas.

* `Polynomial.continuous_eval₂: `Polynomial.eval₂` defines a continuous function.
* `Polynomial.continuous_aeval: `Polynomial.aeval` defines a continuous function;
  we also prove convenience lemmas `Polynomial.continuousAt_aeval`,
  `Polynomial.continuousWithinAt_aeval`, `Polynomial.continuousOn_aeval`.
* `Polynomial.continuous`:  `Polynomial.eval` defines a continuous functions;
  we also prove convenience lemmas `Polynomial.continuousAt`, `Polynomial.continuousWithinAt`,
  `Polynomial.continuous_on`.
* `Polynomial.tendsto_norm_atTop`: `λ x, ‖Polynomial.eval (z x) p‖` tends to infinity provided that
  `λ x, ‖z x‖` tends to infinity and `0 < degree p`;
* `Polynomial.tendsto_abv_eval₂_atTop`, `Polynomial.tendsto_abv_atTop`,
  `Polynomial.tendsto_abv_aeval_atTop`: a few versions of the previous statement for
  `is_absolute_value abv` instead of norm.

## Tags

Polynomial, continuity
-/

open IsAbsoluteValue Filter

namespace Polynomial

open Polynomial

section TopologicalSemiring

variable {R S : Type _} [Semiring R] [TopologicalSpace R] [TopologicalSemiring R] (p : R[X])

@[continuity]
protected theorem continuous_eval₂ [Semiring S] (p : S[X]) (f : S →+* R) :
    Continuous fun x => p.eval₂ f x := by
  simp only [eval₂_eq_sum, Finsupp.sum]
  exact continuous_finset_sum _ fun c _ => continuous_const.mul (continuous_pow _)
#align polynomial.continuous_eval₂ Polynomial.continuous_eval₂

@[continuity]
protected theorem continuous : Continuous fun x => p.eval x :=
  p.continuous_eval₂ _
#align polynomial.continuous Polynomial.continuous

protected theorem continuousAt {a : R} : ContinuousAt (fun x => p.eval x) a :=
  p.continuous.continuousAt
#align polynomial.continuous_at Polynomial.continuousAt

protected theorem continuousWithinAt {s a} : ContinuousWithinAt (fun x => p.eval x) s a :=
  p.continuous.continuousWithinAt
#align polynomial.continuous_within_at Polynomial.continuousWithinAt

protected theorem continuousOn {s} : ContinuousOn (fun x => p.eval x) s :=
  p.continuous.continuousOn
#align polynomial.continuous_on Polynomial.continuousOn

end TopologicalSemiring

section TopologicalAlgebra

variable {R A : Type _} [CommSemiring R] [Semiring A] [Algebra R A] [TopologicalSpace A]
  [TopologicalSemiring A] (p : R[X])

@[continuity]
protected theorem continuous_aeval : Continuous fun x : A => aeval x p :=
  p.continuous_eval₂ _
#align polynomial.continuous_aeval Polynomial.continuous_aeval

protected theorem continuousAt_aeval {a : A} : ContinuousAt (fun x : A => aeval x p) a :=
  p.continuous_aeval.continuousAt
#align polynomial.continuous_at_aeval Polynomial.continuousAt_aeval

protected theorem continuousWithinAt_aeval {s a} :
    ContinuousWithinAt (fun x : A => aeval x p) s a :=
  p.continuous_aeval.continuousWithinAt
#align polynomial.continuous_within_at_aeval Polynomial.continuousWithinAt_aeval

protected theorem continuousOn_aeval {s} : ContinuousOn (fun x : A => aeval x p) s :=
  p.continuous_aeval.continuousOn
#align polynomial.continuous_on_aeval Polynomial.continuousOn_aeval

end TopologicalAlgebra

theorem tendsto_abv_eval₂_atTop {R S k α : Type _} [Semiring R] [Ring S] [LinearOrderedField k]
    (f : R →+* S) (abv : S → k) [IsAbsoluteValue abv] (p : R[X]) (hd : 0 < degree p)
    (hf : f p.leadingCoeff ≠ 0) {l : Filter α} {z : α → S} (hz : Tendsto (abv ∘ z) l atTop) :
    Tendsto (fun x => abv (p.eval₂ f (z x))) l atTop := by
  revert hf; refine' degree_pos_induction_on p hd _ _ _ <;> clear hd p
  · rintro _ - hc
    rw [leadingCoeff_mul_X, leadingCoeff_C] at hc
    simpa [abv_mul abv] using hz.const_mul_atTop ((abv_pos abv).2 hc)
  · intro _ _ ihp hf
    rw [leadingCoeff_mul_X] at hf
    simpa [abv_mul abv] using (ihp hf).atTop_mul_atTop hz
  · intro _ a hd ihp hf
    rw [add_comm, leadingCoeff_add_of_degree_lt (degree_C_le.trans_lt hd)] at hf
    refine' tendsto_atTop_of_add_const_right (abv (-f a)) _
    refine' tendsto_atTop_mono (fun _ => abv_add abv _ _) _
    simpa using ihp hf
#align polynomial.tendsto_abv_eval₂_at_top Polynomial.tendsto_abv_eval₂_atTop

theorem tendsto_abv_atTop {R k α : Type _} [Ring R] [LinearOrderedField k] (abv : R → k)
    [IsAbsoluteValue abv] (p : R[X]) (h : 0 < degree p) {l : Filter α} {z : α → R}
    (hz : Tendsto (abv ∘ z) l atTop) : Tendsto (fun x => abv (p.eval (z x))) l atTop := by
  apply tendsto_abv_eval₂_atTop _ _ _ h _ hz
  exact (mt leadingCoeff_eq_zero.1 (ne_zero_of_degree_gt h))
#align polynomial.tendsto_abv_at_top Polynomial.tendsto_abv_atTop

theorem tendsto_abv_aeval_atTop {R A k α : Type _} [CommSemiring R] [Ring A] [Algebra R A]
    [LinearOrderedField k] (abv : A → k) [IsAbsoluteValue abv] (p : R[X]) (hd : 0 < degree p)
    (h₀ : algebraMap R A p.leadingCoeff ≠ 0) {l : Filter α} {z : α → A}
    (hz : Tendsto (abv ∘ z) l atTop) : Tendsto (fun x => abv (aeval (z x) p)) l atTop :=
  tendsto_abv_eval₂_atTop _ abv p hd h₀ hz
#align polynomial.tendsto_abv_aeval_at_top Polynomial.tendsto_abv_aeval_atTop

variable {α R : Type _} [NormedRing R] [IsAbsoluteValue (norm : R → ℝ)]

theorem tendsto_norm_atTop (p : R[X]) (h : 0 < degree p) {l : Filter α} {z : α → R}
    (hz : Tendsto (fun x => ‖z x‖) l atTop) : Tendsto (fun x => ‖p.eval (z x)‖) l atTop :=
  p.tendsto_abv_atTop norm h hz
#align polynomial.tendsto_norm_at_top Polynomial.tendsto_norm_atTop

theorem exists_forall_norm_le [ProperSpace R] (p : R[X]) : ∃ x, ∀ y, ‖p.eval x‖ ≤ ‖p.eval y‖ :=
  if hp0 : 0 < degree p then
    set_option synthInstance.etaExperiment true in -- workaround for lean4#2074
      p.continuous.norm.exists_forall_le <| p.tendsto_norm_atTop hp0 tendsto_norm_cocompact_atTop
  else ⟨p.coeff 0, by rw [eq_C_of_degree_le_zero (le_of_not_gt hp0)]; simp⟩
#align polynomial.exists_forall_norm_le Polynomial.exists_forall_norm_le

section Roots

open Polynomial NNReal

variable {F K : Type _} [CommRing F] [NormedField K]

open Multiset

theorem eq_one_of_roots_le {p : F[X]} {f : F →+* K} {B : ℝ} (hB : B < 0) (h1 : p.Monic)
    (h2 : Splits f p) (h3 : ∀ z ∈ (map f p).roots, ‖z‖ ≤ B) : p = 1 :=
  h1.natDegree_eq_zero_iff_eq_one.mp (by
    contrapose! hB
    rw [← h1.natDegree_map f, natDegree_eq_card_roots' h2] at hB
    obtain ⟨z, hz⟩ := card_pos_iff_exists_mem.mp (zero_lt_iff.mpr hB)
    exact le_trans (norm_nonneg _) (h3 z hz))
#align polynomial.eq_one_of_roots_le Polynomial.eq_one_of_roots_le

theorem coeff_le_of_roots_le {p : F[X]} {f : F →+* K} {B : ℝ} (i : ℕ) (h1 : p.Monic)
    (h2 : Splits f p) (h3 : ∀ z ∈ (map f p).roots, ‖z‖ ≤ B) :
    ‖(map f p).coeff i‖ ≤ B ^ (p.natDegree - i) * p.natDegree.choose i := by
  obtain hB | hB := lt_or_le B 0
  · rw [eq_one_of_roots_le hB h1 h2 h3, Polynomial.map_one, natDegree_one, zero_tsub, pow_zero,
      one_mul, coeff_one]
    split_ifs <;> norm_num [h]
    simp [‹0 = i›]
  rw [← h1.natDegree_map f]
  obtain hi | hi := lt_or_le (map f p).natDegree i
  · rw [coeff_eq_zero_of_natDegree_lt hi, norm_zero]
    positivity
  rw [coeff_eq_esymm_roots_of_splits ((splits_id_iff_splits f).2 h2) hi, (h1.map _).leadingCoeff,
    one_mul, norm_mul, norm_pow, norm_neg, norm_one, one_pow, one_mul]
  apply ((norm_multiset_sum_le _).trans <| sum_le_card_nsmul _ _ fun r hr => _).trans
  · rw [Multiset.map_map, card_map, card_powersetLen, ← natDegree_eq_card_roots' h2,
      Nat.choose_symm hi, mul_comm, nsmul_eq_mul]
  intro r hr
  simp_rw [Multiset.mem_map] at hr
  obtain ⟨_, ⟨s, hs, rfl⟩, rfl⟩ := hr
  rw [mem_powersetLen] at hs
  lift B to ℝ≥0 using hB
  rw [← coe_nnnorm, ← NNReal.coe_pow, NNReal.coe_le_coe, ← nnnormHom_apply, ← MonoidHom.coe_coe,
    MonoidHom.map_multiset_prod]
  refine' (prod_le_pow_card _ B fun x hx => _).trans_eq (by rw [card_map, hs.2])
  obtain ⟨z, hz, rfl⟩ := Multiset.mem_map.1 hx
  exact h3 z (mem_of_le hs.1 hz)
#align polynomial.coeff_le_of_roots_le Polynomial.coeff_le_of_roots_le

/-- The coefficients of the monic polynomials of bounded degree with bounded roots are
uniformely bounded. -/
theorem coeff_bdd_of_roots_le {B : ℝ} {d : ℕ} (f : F →+* K) {p : F[X]} (h1 : p.Monic)
    (h2 : Splits f p) (h3 : p.natDegree ≤ d) (h4 : ∀ z ∈ (map f p).roots, ‖z‖ ≤ B) (i : ℕ) :
    ‖(map f p).coeff i‖ ≤ max B 1 ^ d * d.choose (d / 2) := by
  obtain hB | hB := le_or_lt 0 B
  · apply (coeff_le_of_roots_le i h1 h2 h4).trans
    calc
      _ ≤ max B 1 ^ (p.natDegree - i) * p.natDegree.choose i :=
        mul_le_mul_of_nonneg_right (pow_le_pow_of_le_left hB (le_max_left _ _) _) (by simp)
      _ ≤ max B 1 ^ d * p.natDegree.choose i :=
        (mul_le_mul_of_nonneg_right ((pow_mono (le_max_right _ _)) (le_trans (Nat.sub_le _ _) h3))
          (by simp))
      _ ≤ max B 1 ^ d * d.choose (d / 2) :=
        mul_le_mul_of_nonneg_left
          (Nat.cast_le.mpr ((i.choose_mono h3).trans (i.choose_le_middle d))) (by simp)
  · rw [eq_one_of_roots_le hB h1 h2 h4, Polynomial.map_one, coeff_one]
    refine' _root_.trans _
      (one_le_mul_of_one_le_of_one_le (one_le_pow_of_one_le (le_max_right B 1) d) _)
    · split_ifs <;> norm_num
    · exact_mod_cast Nat.succ_le_iff.mpr (Nat.choose_pos (d.div_le_self 2))
#align polynomial.coeff_bdd_of_roots_le Polynomial.coeff_bdd_of_roots_le

end Roots

end Polynomial


import tactic

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

open set

example (h : s ⊆ t) : s ∩ u ⊆ t ∩ u :=
begin
  rw [subset_def, inter_def, inter_def],
  rw subset_def at h,
  dsimp,
  rintros x ⟨xs, xu⟩,
  exact ⟨h _ xs, xu⟩,
end

/- Alternatively, using the simp only tactic to unpack a definition -/
example (h : s ⊆ t) : s ∩ u ⊆ t ∩ u :=
begin
  simp only [subset_def, mem_inter_iff] at *,
  rintros x ⟨xs, xu⟩,
  exact ⟨h _ xs, xu⟩,
end


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

! This file was ported from Lean 3 source module number_theory.modular_forms.slash_actions
! leanprover-community/mathlib commit e65771194f9e923a70dfb49b6ca7be6e400d8b6f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Complex.UpperHalfPlane.Basic
import Mathbin.LinearAlgebra.Matrix.GeneralLinearGroup
import Mathbin.LinearAlgebra.Matrix.SpecialLinearGroup

/-!
# Slash actions

This file defines a class of slash actions, which are families of right actions of a given group
parametrized by some Type. This is modeled on the slash action of `GL_pos (fin 2) ℝ` on the space
of modular forms.
-/

open Complex UpperHalfPlane

open UpperHalfPlane

-- mathport name: «expr↑ₘ »
local prefix:1024 "↑ₘ" => @coe _ (Matrix (Fin 2) (Fin 2) _) _

-- mathport name: «expr↑ₘ[ ]»
-- like `↑ₘ`, but allows the user to specify the ring `R`. Useful to help Lean elaborate.
local notation "↑ₘ[" R "]" => @coe _ (Matrix (Fin 2) (Fin 2) R) _

-- mathport name: «exprGL( , )⁺»
local notation "GL(" n ", " R ")" "⁺" => Matrix.gLPos (Fin n) R

-- mathport name: «exprSL( , )»
local notation "SL(" n ", " R ")" => Matrix.SpecialLinearGroup (Fin n) R

/-- A general version of the slash action of the space of modular forms.-/
class SlashAction (β G α γ : Type _) [Group G] [Zero α] [SMul γ α] [Add α] where
  map : β → G → α → α
  zero_slash : ∀ (k : β) (g : G), map k g 0 = 0
  slash_one : ∀ (k : β) (a : α), map k 1 a = a
  right_action : ∀ (k : β) (g h : G) (a : α), map k h (map k g a) = map k (g * h) a
  smul_action : ∀ (k : β) (g : G) (a : α) (z : γ), map k g (z • a) = z • map k g a
  AddAction : ∀ (k : β) (g : G) (a b : α), map k g (a + b) = map k g a + map k g b
#align slash_action SlashAction

/-- Slash_action induced by a monoid homomorphism.-/
def monoidHomSlashAction {β G H α γ : Type _} [Group G] [Zero α] [SMul γ α] [Add α] [Group H]
    [SlashAction β G α γ] (h : H →* G) : SlashAction β H α γ
    where
  map k g := SlashAction.map γ k (h g)
  zero_slash k g := SlashAction.zero_slash k (h g)
  slash_one k a := by simp only [map_one, SlashAction.slash_one]
  right_action k g gg a := by simp only [map_mul, SlashAction.right_action]
  smul_action _ _ := SlashAction.smul_action _ _
  AddAction _ g _ _ := SlashAction.add_action _ (h g) _ _
#align monoid_hom_slash_action monoidHomSlashAction

namespace ModularForm

noncomputable section

/-- The weight `k` action of `GL(2, ℝ)⁺` on functions `f : ℍ → ℂ`. -/
def slash (k : ℤ) (γ : GL(2, ℝ)⁺) (f : ℍ → ℂ) (x : ℍ) : ℂ :=
  f (γ • x) * ((↑ₘγ).det : ℝ) ^ (k - 1) * UpperHalfPlane.denom γ x ^ (-k)
#align modular_form.slash ModularForm.slash

variable {Γ : Subgroup SL(2, ℤ)} {k : ℤ} (f : ℍ → ℂ)

-- mathport name: modular_form.slash
scoped notation:100 f " ∣[" k "]" γ:100 => ModularForm.slash k γ f

theorem slash_right_action (k : ℤ) (A B : GL(2, ℝ)⁺) (f : ℍ → ℂ) :
    (f ∣[k]A) ∣[k]B = f ∣[k](A * B) := by
  ext1
  simp_rw [slash, UpperHalfPlane.denom_cocycle A B x]
  have e3 : (A * B) • x = A • B • x := by convert UpperHalfPlane.mul_smul' A B x
  rw [e3]
  simp only [UpperHalfPlane.num, UpperHalfPlane.denom, of_real_mul, Subgroup.coe_mul, coe_coe,
    UpperHalfPlane.coe_smul, Units.val_mul, Matrix.mul_eq_mul, Matrix.det_mul,
    UpperHalfPlane.smulAux, UpperHalfPlane.smulAux', Subtype.coe_mk] at *
  field_simp
  have :
    (((↑(↑A : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ).det : ℂ) *
          ((↑(↑B : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ).det : ℂ)) ^
        (k - 1) =
      ((↑(↑A : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ).det : ℂ) ^ (k - 1) *
        ((↑(↑B : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ).det : ℂ) ^ (k - 1) :=
    by simp_rw [← mul_zpow]
  simp_rw [this, ← mul_assoc, ← mul_zpow]
#align modular_form.slash_right_action ModularForm.slash_right_action

@[simp]
theorem slash_add (k : ℤ) (A : GL(2, ℝ)⁺) (f g : ℍ → ℂ) : (f + g) ∣[k]A = f ∣[k]A + g ∣[k]A :=
  by
  ext1
  simp only [slash, Pi.add_apply, denom, coe_coe, zpow_neg]
  ring
#align modular_form.slash_add ModularForm.slash_add

@[simp]
theorem slash_one (k : ℤ) (f : ℍ → ℂ) : f ∣[k]1 = f :=
  funext <| by simp [slash]
#align modular_form.slash_one ModularForm.slash_one

variable {α : Type _} [SMul α ℂ] [IsScalarTower α ℂ ℂ]

@[simp]
theorem smul_slash (k : ℤ) (A : GL(2, ℝ)⁺) (f : ℍ → ℂ) (c : α) : (c • f) ∣[k]A = c • f ∣[k]A :=
  by
  simp_rw [← smul_one_smul ℂ c f, ← smul_one_smul ℂ c (f ∣[k]A)]
  ext1
  simp_rw [slash]
  simp only [slash, Algebra.id.smul_eq_mul, Matrix.GeneralLinearGroup.coe_det_apply, Pi.smul_apply,
    Subtype.val_eq_coe, coe_coe]
  ring
#align modular_form.smul_slash ModularForm.smul_slash

@[simp]
theorem neg_slash (k : ℤ) (A : GL(2, ℝ)⁺) (f : ℍ → ℂ) : (-f) ∣[k]A = -f ∣[k]A :=
  funext <| by simp [slash]
#align modular_form.neg_slash ModularForm.neg_slash

@[simp]
theorem zero_slash (k : ℤ) (A : GL(2, ℝ)⁺) : (0 : ℍ → ℂ) ∣[k]A = 0 :=
  funext fun _ => by simp only [slash, Pi.zero_apply, MulZeroClass.zero_mul]
#align modular_form.zero_slash ModularForm.zero_slash

instance : SlashAction ℤ GL(2, ℝ)⁺ (ℍ → ℂ) ℂ
    where
  map := slash
  zero_slash := zero_slash
  slash_one := slash_one
  right_action := slash_right_action
  smul_action := smul_slash
  AddAction := slash_add

instance subgroupAction (Γ : Subgroup SL(2, ℤ)) : SlashAction ℤ Γ (ℍ → ℂ) ℂ :=
  monoidHomSlashAction
    (MonoidHom.comp Matrix.SpecialLinearGroup.toGLPos
      (MonoidHom.comp (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ)) (Subgroup.subtype Γ)))
#align modular_form.subgroup_action ModularForm.subgroupAction

@[simp]
theorem subgroup_slash (Γ : Subgroup SL(2, ℤ)) (γ : Γ) :
    SlashAction.map ℂ k γ f = slash k (γ : GL(2, ℝ)⁺) f :=
  rfl
#align modular_form.subgroup_slash ModularForm.subgroup_slash

instance sLAction : SlashAction ℤ SL(2, ℤ) (ℍ → ℂ) ℂ :=
  monoidHomSlashAction
    (MonoidHom.comp Matrix.SpecialLinearGroup.toGLPos
      (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ)))
#align modular_form.SL_action ModularForm.sLAction

@[simp]
theorem SL_slash (γ : SL(2, ℤ)) : SlashAction.map ℂ k γ f = slash k (γ : GL(2, ℝ)⁺) f :=
  rfl
#align modular_form.SL_slash ModularForm.SL_slash

-- mathport name: «expr ∣[ , ]»
local notation:73 f "∣[" k:0 "," A "]" => SlashAction.map ℂ k A f

/-- The constant function 1 is invariant under any element of `SL(2, ℤ)`. -/
@[simp]
theorem is_invariant_one (A : SL(2, ℤ)) : (1 : ℍ → ℂ)∣[(0 : ℤ),A] = (1 : ℍ → ℂ) :=
  by
  have : ((↑ₘ(A : GL(2, ℝ)⁺)).det : ℝ) = 1 := by
    simp only [coe_coe, Matrix.SpecialLinearGroup.coe_gLPos_coe_GL_coe_matrix,
      Matrix.SpecialLinearGroup.det_coe]
  funext
  rw [SL_slash, slash, zero_sub, this]
  simp
#align modular_form.is_invariant_one ModularForm.is_invariant_one

/-- A function `f : ℍ → ℂ` is `slash_invariant`, of weight `k ∈ ℤ` and level `Γ`,
  if for every matrix `γ ∈ Γ` we have `f(γ • z)= (c*z+d)^k f(z)` where `γ= ![![a, b], ![c, d]]`,
  and it acts on `ℍ` via Möbius transformations. -/
theorem slash_action_eq'_iff (k : ℤ) (Γ : Subgroup SL(2, ℤ)) (f : ℍ → ℂ) (γ : Γ) (z : ℍ) :
    (f∣[k,γ]) z = f z ↔ f (γ • z) = ((↑ₘ[ℤ] γ 1 0 : ℂ) * z + (↑ₘ[ℤ] γ 1 1 : ℂ)) ^ k * f z :=
  by
  simp only [subgroup_slash, ModularForm.slash]
  convert inv_mul_eq_iff_eq_mul₀ _ using 2
  · rw [mul_comm]
    simp only [denom, coe_coe, Matrix.SpecialLinearGroup.coe_gLPos_coe_GL_coe_matrix, zpow_neg,
      Matrix.SpecialLinearGroup.det_coe, of_real_one, one_zpow, mul_one, subgroup_to_sl_moeb,
      sl_moeb]
    rfl
  · convert zpow_ne_zero k (denom_ne_zero γ z)
#align modular_form.slash_action_eq'_iff ModularForm.slash_action_eq'_iff

theorem mul_slash (k1 k2 : ℤ) (A : GL(2, ℝ)⁺) (f g : ℍ → ℂ) :
    (f * g)∣[k1 + k2,A] = ((↑ₘA).det : ℝ) • f∣[k1,A] * g∣[k2,A] :=
  by
  ext1
  simp only [SlashAction.map, slash, Matrix.GeneralLinearGroup.coe_det_apply, Subtype.val_eq_coe,
    Pi.mul_apply, Pi.smul_apply, Algebra.smul_mul_assoc, real_smul]
  set d : ℂ := ↑((↑ₘA).det : ℝ)
  have h1 : d ^ (k1 + k2 - 1) = d * d ^ (k1 - 1) * d ^ (k2 - 1) :=
    by
    have : d ≠ 0 := by
      dsimp [d]
      norm_cast
      exact Matrix.gLPos.det_ne_zero A
    rw [← zpow_one_add₀ this, ← zpow_add₀ this]
    ring
  have h22 : denom A x ^ (-(k1 + k2)) = denom A x ^ (-k1) * denom A x ^ (-k2) :=
    by
    rw [Int.neg_add, zpow_add₀]
    exact UpperHalfPlane.denom_ne_zero A x
  rw [h1, h22]
  ring
#align modular_form.mul_slash ModularForm.mul_slash

@[simp]
theorem mul_slash_SL2 (k1 k2 : ℤ) (A : SL(2, ℤ)) (f g : ℍ → ℂ) :
    (f * g)∣[k1 + k2,A] = f∣[k1,A] * g∣[k2,A] :=
  calc
    (f * g)∣[k1 + k2,(A : GL(2, ℝ)⁺)] = _ • f∣[k1,A] * g∣[k2,A] := mul_slash _ _ _ _ _
    _ = (1 : ℝ) • f∣[k1,A] * g∣[k2,A] := by simp [-Matrix.SpecialLinearGroup.coe_matrix_coe]
    _ = f∣[k1,A] * g∣[k2,A] := by simp

#align modular_form.mul_slash_SL2 ModularForm.mul_slash_SL2

theorem mul_slash_subgroup (k1 k2 : ℤ) (Γ : Subgroup SL(2, ℤ)) (A : Γ) (f g : ℍ → ℂ) :
    (f * g)∣[k1 + k2,A] = f∣[k1,A] * g∣[k2,A] :=
  mul_slash_SL2 k1 k2 A f g
#align modular_form.mul_slash_subgroup ModularForm.mul_slash_subgroup

end ModularForm


/-
Copyright (c) 2021 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import ring_theory.nakayama
import data.set_like.fintype

/-!
# Artinian rings and modules

A module satisfying these equivalent conditions is said to be an *Artinian* R-module
if every decreasing chain of submodules is eventually constant, or equivalently,
if the relation `<` on submodules is well founded.

A ring is said to be left (or right) Artinian if it is Artinian as a left (or right) module over
itself, or simply Artinian if it is both left and right Artinian.

## Main definitions

Let `R` be a ring and let `M` and `P` be `R`-modules. Let `N` be an `R`-submodule of `M`.

* `is_artinian R M` is the proposition that `M` is a Artinian `R`-module. It is a class,
  implemented as the predicate that the `<` relation on submodules is well founded.
* `is_artinian_ring R` is the proposition that `R` is a left Artinian ring.

## References

* [M. F. Atiyah and I. G. Macdonald, *Introduction to commutative algebra*][atiyah-macdonald]
* [samuel]

## Tags

Artinian, artinian, Artinian ring, Artinian module, artinian ring, artinian module

-/
open set
open_locale big_operators pointwise

/--
`is_artinian R M` is the proposition that `M` is an Artinian `R`-module,
implemented as the well-foundedness of submodule inclusion.
-/
class is_artinian (R M) [semiring R] [add_comm_monoid M] [module R M] : Prop :=
(well_founded_submodule_lt [] : well_founded ((<) : submodule R M → submodule R M → Prop))

section
variables {R M P N : Type*}

variables [ring R] [add_comm_group M] [add_comm_group P] [add_comm_group N]
variables [module R M] [module R P] [module R N]
open is_artinian
include R

theorem is_artinian_of_injective (f : M →ₗ[R] P) (h : function.injective f)
  [is_artinian R P] : is_artinian R M :=
⟨subrelation.wf
  (λ A B hAB, show A.map f < B.map f,
    from submodule.map_strict_mono_of_injective h hAB)
  (inv_image.wf (submodule.map f) (is_artinian.well_founded_submodule_lt R P))⟩

instance is_artinian_submodule' [is_artinian R M] (N : submodule R M) : is_artinian R N :=
is_artinian_of_injective N.subtype subtype.val_injective

lemma is_artinian_of_le {s t : submodule R M} [ht : is_artinian R t]
   (h : s ≤ t) : is_artinian R s :=
is_artinian_of_injective (submodule.of_le h) (submodule.of_le_injective h)

variable (M)
theorem is_artinian_of_surjective (f : M →ₗ[R] P) (hf : function.surjective f)
  [is_artinian R M] : is_artinian R P :=
⟨subrelation.wf
  (λ A B hAB, show A.comap f < B.comap f,
    from submodule.comap_strict_mono_of_surjective hf hAB)
  (inv_image.wf (submodule.comap f) (is_artinian.well_founded_submodule_lt _ _))⟩
variable {M}

theorem is_artinian_of_linear_equiv (f : M ≃ₗ[R] P)
  [is_artinian R M] : is_artinian R P :=
is_artinian_of_surjective _ f.to_linear_map f.to_equiv.surjective

theorem is_artinian_of_range_eq_ker
  [is_artinian R M] [is_artinian R P]
  (f : M →ₗ[R] N) (g : N →ₗ[R] P)
  (hf : function.injective f)
  (hg : function.surjective g)
  (h : f.range = g.ker) :
  is_artinian R N :=
⟨well_founded_lt_exact_sequence
  (is_artinian.well_founded_submodule_lt _ _)
  (is_artinian.well_founded_submodule_lt _ _)
  f.range
  (submodule.map f)
  (submodule.comap f)
  (submodule.comap g)
  (submodule.map g)
  (submodule.gci_map_comap hf)
  (submodule.gi_map_comap hg)
  (by simp [submodule.map_comap_eq, inf_comm])
  (by simp [submodule.comap_map_eq, h])⟩

instance is_artinian_prod [is_artinian R M]
  [is_artinian R P] : is_artinian R (M × P) :=
is_artinian_of_range_eq_ker
  (linear_map.inl R M P)
  (linear_map.snd R M P)
  linear_map.inl_injective
  linear_map.snd_surjective
  (linear_map.range_inl R M P)

@[priority 100]
instance is_artinian_of_finite [finite M] : is_artinian R M :=
⟨finite.well_founded_of_trans_of_irrefl _⟩

local attribute [elab_as_eliminator] finite.induction_empty_option

instance is_artinian_pi {R ι : Type*} [finite ι] : Π {M : ι → Type*} [ring R]
  [Π i, add_comm_group (M i)], by exactI Π [Π i, module R (M i)],
  by exactI Π [∀ i, is_artinian R (M i)], is_artinian R (Π i, M i) :=
finite.induction_empty_option
  (begin
    introsI α β e hα M _ _ _ _,
    exact is_artinian_of_linear_equiv
      (linear_equiv.Pi_congr_left R M e)
  end)
  (by { introsI M _ _ _ _, apply_instance })
  (begin
     introsI α _ ih M _ _ _ _,
     exact is_artinian_of_linear_equiv
        (linear_equiv.pi_option_equiv_prod R).symm,
  end)
  ι

/-- A version of `is_artinian_pi` for non-dependent functions. We need this instance because
sometimes Lean fails to apply the dependent version in non-dependent settings (e.g., it fails to
prove that `ι → ℝ` is finite dimensional over `ℝ`). -/
instance is_artinian_pi' {R ι M : Type*} [ring R] [add_comm_group M] [module R M] [finite ι]
  [is_artinian R M] : is_artinian R (ι → M) :=
is_artinian_pi

end

open is_artinian submodule function

section ring

variables {R M : Type*} [ring R] [add_comm_group M] [module R M]

theorem is_artinian_iff_well_founded :
  is_artinian R M ↔ well_founded ((<) : submodule R M → submodule R M → Prop) :=
⟨λ h, h.1, is_artinian.mk⟩

variables {R M}

lemma is_artinian.finite_of_linear_independent [nontrivial R] [is_artinian R M]
  {s : set M} (hs : linear_independent R (coe : s → M)) : s.finite :=
begin
  refine classical.by_contradiction (λ hf, (rel_embedding.well_founded_iff_no_descending_seq.1
    (well_founded_submodule_lt R M)).elim' _),
  have f : ℕ ↪ s, from set.infinite.nat_embedding s hf,
  have : ∀ n, (coe ∘ f) '' {m | n ≤ m} ⊆ s,
  { rintros n x ⟨y, hy₁, rfl⟩, exact (f y).2 },
  have : ∀ a b : ℕ, a ≤ b ↔
    span R ((coe ∘ f) '' {m | b ≤ m}) ≤ span R ((coe ∘ f) '' {m | a ≤ m}),
  { assume a b,
    rw [span_le_span_iff hs (this b) (this a),
      set.image_subset_image_iff (subtype.coe_injective.comp f.injective),
      set.subset_def],
    simp only [set.mem_set_of_eq],
    exact ⟨λ hab x, le_trans hab, λ h, (h _ le_rfl)⟩ },
  exact ⟨⟨λ n, span R ((coe ∘ f) '' {m | n ≤ m}),
      λ x y, by simp [le_antisymm_iff, (this _ _).symm] {contextual := tt}⟩,
    begin
      intros a b,
      conv_rhs { rw [gt, lt_iff_le_not_le, this, this, ← lt_iff_le_not_le] },
      simp
    end⟩
end

/-- A module is Artinian iff every nonempty set of submodules has a minimal submodule among them.
-/
theorem set_has_minimal_iff_artinian :
  (∀ a : set $ submodule R M, a.nonempty → ∃ M' ∈ a, ∀ I ∈ a, ¬ I < M') ↔ is_artinian R M :=
by rw [is_artinian_iff_well_founded, well_founded.well_founded_iff_has_min]

theorem is_artinian.set_has_minimal [is_artinian R M] (a : set $ submodule R M) (ha : a.nonempty) :
  ∃ M' ∈ a, ∀ I ∈ a, ¬ I < M' :=
set_has_minimal_iff_artinian.mpr ‹_› a ha

/-- A module is Artinian iff every decreasing chain of submodules stabilizes. -/
theorem monotone_stabilizes_iff_artinian :
  (∀ (f : ℕ →o (submodule R M)ᵒᵈ), ∃ n, ∀ m, n ≤ m → f n = f m) ↔ is_artinian R M :=
by { rw is_artinian_iff_well_founded, exact well_founded.monotone_chain_condition.symm }

namespace is_artinian

variables [is_artinian R M]

theorem monotone_stabilizes (f : ℕ →o (submodule R M)ᵒᵈ) : ∃ n, ∀ m, n ≤ m → f n = f m :=
monotone_stabilizes_iff_artinian.mpr ‹_› f

/-- If `∀ I > J, P I` implies `P J`, then `P` holds for all submodules. -/
lemma induction {P : submodule R M → Prop} (hgt : ∀ I, (∀ J < I, P J) → P I) (I : submodule R M) :
  P I :=
(well_founded_submodule_lt R M).recursion I hgt

/--
For any endomorphism of a Artinian module, there is some nontrivial iterate
with disjoint kernel and range.
-/
theorem exists_endomorphism_iterate_ker_sup_range_eq_top (f : M →ₗ[R] M) :
  ∃ n : ℕ, n ≠ 0 ∧ (f ^ n).ker ⊔ (f ^ n).range = ⊤ :=
begin
  obtain ⟨n, w⟩ := monotone_stabilizes (f.iterate_range.comp ⟨λ n, n+1, λ n m w, by linarith⟩),
  specialize w ((n + 1) + n) (by linarith),
  dsimp at w,
  refine ⟨n + 1, nat.succ_ne_zero _, _⟩,
  simp_rw [eq_top_iff', mem_sup],
  intro x,
  have : (f^(n + 1)) x ∈ (f ^ ((n + 1) + n + 1)).range,
  { rw ← w, exact mem_range_self _ },
  rcases this with ⟨y, hy⟩,
  use x - (f ^ (n+1)) y,
  split,
  { rw [linear_map.mem_ker, linear_map.map_sub, ← hy, sub_eq_zero, pow_add],
    simp [iterate_add_apply], },
  { use (f^ (n+1)) y,
    simp }
end

/-- Any injective endomorphism of an Artinian module is surjective. -/
theorem surjective_of_injective_endomorphism (f : M →ₗ[R] M) (s : injective f) : surjective f :=
begin
  obtain ⟨n, ne, w⟩ := exists_endomorphism_iterate_ker_sup_range_eq_top f,
  rw [linear_map.ker_eq_bot.mpr (linear_map.iterate_injective s n), bot_sup_eq,
    linear_map.range_eq_top] at w,
  exact linear_map.surjective_of_iterate_surjective ne w,
end

/-- Any injective endomorphism of an Artinian module is bijective. -/
theorem bijective_of_injective_endomorphism (f : M →ₗ[R] M) (s : injective f) : bijective f :=
⟨s, surjective_of_injective_endomorphism f s⟩

/--
A sequence `f` of submodules of a artinian module,
with the supremum `f (n+1)` and the infinum of `f 0`, ..., `f n` being ⊤,
is eventually ⊤.
-/
lemma disjoint_partial_infs_eventually_top (f : ℕ → submodule R M)
  (h : ∀ n, disjoint (partial_sups (order_dual.to_dual ∘ f) n) (order_dual.to_dual (f (n+1)))) :
  ∃ n : ℕ, ∀ m, n ≤ m → f m = ⊤  :=
begin
  -- A little off-by-one cleanup first:
  rsuffices ⟨n, w⟩ : ∃ n : ℕ, ∀ m, n ≤ m → order_dual.to_dual f (m+1) = ⊤,
  { use n+1,
    rintros (_|m) p,
    { cases p, },
    { apply w,
      exact nat.succ_le_succ_iff.mp p }, },

  obtain ⟨n, w⟩ := monotone_stabilizes (partial_sups (order_dual.to_dual ∘ f)),
  refine ⟨n, λ m p, _⟩,
  exact (h m).eq_bot_of_ge (sup_eq_left.1 $ (w (m + 1) $ le_add_right p).symm.trans $ w m p)
end

end is_artinian

end ring

section comm_ring

variables {R : Type*} (M : Type*) [comm_ring R] [add_comm_group M] [module R M] [is_artinian R M]

namespace is_artinian

lemma range_smul_pow_stabilizes (r : R) : ∃ n : ℕ, ∀ m, n ≤ m →
  (r^n • linear_map.id : M →ₗ[R] M).range = (r^m • linear_map.id : M →ₗ[R] M).range :=
monotone_stabilizes
⟨λ n, (r^n • linear_map.id : M →ₗ[R] M).range,
 λ n m h x ⟨y, hy⟩, ⟨r ^ (m - n) • y,
   by { dsimp at ⊢ hy, rw [←smul_assoc, smul_eq_mul, ←pow_add, ←hy, add_tsub_cancel_of_le h] }⟩⟩

variables {M}

lemma exists_pow_succ_smul_dvd (r : R) (x : M) :
  ∃ (n : ℕ) (y : M), r ^ n.succ • y = r ^ n • x :=
begin
  obtain ⟨n, hn⟩ := is_artinian.range_smul_pow_stabilizes M r,
  simp_rw [set_like.ext_iff] at hn,
  exact ⟨n, by simpa using hn n.succ n.le_succ (r ^ n • x)⟩,
end

end is_artinian

end comm_ring

-- TODO: Prove this for artinian modules
-- /--
-- If `M ⊕ N` embeds into `M`, for `M` noetherian over `R`, then `N` is trivial.
-- -/
-- universe w
-- variables {N : Type w} [add_comm_group N] [module R N]
-- noncomputable def is_noetherian.equiv_punit_of_prod_injective [is_noetherian R M]
--   (f : M × N →ₗ[R] M) (i : injective f) : N ≃ₗ[R] punit.{w+1} :=
-- begin
--   apply nonempty.some,
--   obtain ⟨n, w⟩ := is_noetherian.disjoint_partial_sups_eventually_bot (f.tailing i)
--     (f.tailings_disjoint_tailing i),
--   specialize w n (le_refl n),
--   apply nonempty.intro,
--   refine (f.tailing_linear_equiv i n).symm.trans _,
--   rw w,
--   exact submodule.bot_equiv_punit,
-- end

/-- A ring is Artinian if it is Artinian as a module over itself.

Strictly speaking, this should be called `is_left_artinian_ring` but we omit the `left_` for
convenience in the commutative case. For a right Artinian ring, use `is_artinian Rᵐᵒᵖ R`. -/
@[reducible] def is_artinian_ring (R) [ring R] := is_artinian R R

theorem is_artinian_ring_iff {R} [ring R] : is_artinian_ring R ↔ is_artinian R R :=
iff.rfl

theorem ring.is_artinian_of_zero_eq_one {R} [ring R] (h01 : (0 : R) = 1) : is_artinian_ring R :=
have _ := subsingleton_of_zero_eq_one h01, by exactI infer_instance

theorem is_artinian_of_submodule_of_artinian (R M) [ring R] [add_comm_group M] [module R M]
  (N : submodule R M) (h : is_artinian R M) : is_artinian R N :=
by apply_instance

theorem is_artinian_of_quotient_of_artinian (R) [ring R] (M) [add_comm_group M] [module R M]
  (N : submodule R M) (h : is_artinian R M) : is_artinian R (M ⧸ N) :=
is_artinian_of_surjective M (submodule.mkq N) (submodule.quotient.mk_surjective N)

/-- If `M / S / R` is a scalar tower, and `M / R` is Artinian, then `M / S` is
also Artinian. -/
theorem is_artinian_of_tower (R) {S M} [comm_ring R] [ring S]
  [add_comm_group M] [algebra R S] [module S M] [module R M] [is_scalar_tower R S M]
  (h : is_artinian R M) : is_artinian S M :=
begin
  rw is_artinian_iff_well_founded at h ⊢,
  refine (submodule.restrict_scalars_embedding R S M).well_founded h
end

theorem is_artinian_of_fg_of_artinian {R M} [ring R] [add_comm_group M] [module R M]
  (N : submodule R M) [is_artinian_ring R] (hN : N.fg) : is_artinian R N :=
let ⟨s, hs⟩ := hN in
begin
  haveI := classical.dec_eq M,
  haveI := classical.dec_eq R,
  have : ∀ x ∈ s, x ∈ N, from λ x hx, hs ▸ submodule.subset_span hx,
  refine @@is_artinian_of_surjective ((↑s : set M) → R) _ _ _ (pi.module _ _ _)
    _ _ _ is_artinian_pi,
  { fapply linear_map.mk,
    { exact λ f, ⟨∑ i in s.attach, f i • i.1, N.sum_mem (λ c _, N.smul_mem _ $ this _ c.2)⟩ },
    { intros f g, apply subtype.eq,
      change ∑ i in s.attach, (f i + g i) • _ = _,
      simp only [add_smul, finset.sum_add_distrib], refl },
    { intros c f, apply subtype.eq,
      change ∑ i in s.attach, (c • f i) • _ = _,
      simp only [smul_eq_mul, mul_smul],
      exact finset.smul_sum.symm } },
  rintro ⟨n, hn⟩, change n ∈ N at hn,
  rw [← hs, ← set.image_id ↑s, finsupp.mem_span_image_iff_total] at hn,
  rcases hn with ⟨l, hl1, hl2⟩,
  refine ⟨λ x, l x, subtype.ext _⟩,
  change ∑ i in s.attach, l i • (i : M) = n,
  rw [@finset.sum_attach M M s _ (λ i, l i • i), ← hl2,
      finsupp.total_apply, finsupp.sum, eq_comm],
  refine finset.sum_subset hl1 (λ x _ hx, _),
  rw [finsupp.not_mem_support_iff.1 hx, zero_smul]
end

lemma is_artinian_of_fg_of_artinian' {R M} [ring R] [add_comm_group M] [module R M]
  [is_artinian_ring R] (h : (⊤ : submodule R M).fg) : is_artinian R M :=
have is_artinian R (⊤ : submodule R M), from is_artinian_of_fg_of_artinian _ h,
by exactI is_artinian_of_linear_equiv (linear_equiv.of_top (⊤ : submodule R M) rfl)

/-- In a module over a artinian ring, the submodule generated by finitely many vectors is
artinian. -/
theorem is_artinian_span_of_finite (R) {M} [ring R] [add_comm_group M] [module R M]
  [is_artinian_ring R] {A : set M} (hA : A.finite) : is_artinian R (submodule.span R A) :=
is_artinian_of_fg_of_artinian _ (submodule.fg_def.mpr ⟨A, hA, rfl⟩)

theorem function.surjective.is_artinian_ring {R} [ring R] {S} [ring S] {F} [ring_hom_class F R S]
  {f : F} (hf : function.surjective f) [H : is_artinian_ring R] : is_artinian_ring S :=
begin
  rw [is_artinian_ring_iff, is_artinian_iff_well_founded] at H ⊢,
  exact (ideal.order_embedding_of_surjective f hf).well_founded H,
end

instance is_artinian_ring_range {R} [ring R] {S} [ring S] (f : R →+* S) [is_artinian_ring R] :
  is_artinian_ring f.range :=
f.range_restrict_surjective.is_artinian_ring

namespace is_artinian_ring

open is_artinian

variables {R : Type*} [comm_ring R] [is_artinian_ring R]

lemma is_nilpotent_jacobson_bot : is_nilpotent (ideal.jacobson (⊥ : ideal R)) :=
begin
  let Jac := ideal.jacobson (⊥ : ideal R),
  let f : ℕ →o (ideal R)ᵒᵈ := ⟨λ n, Jac ^ n, λ _ _ h, ideal.pow_le_pow h⟩,
  obtain ⟨n, hn⟩ : ∃ n, ∀ m, n ≤ m → Jac ^ n = Jac ^ m := is_artinian.monotone_stabilizes f,
  refine ⟨n, _⟩,
  let J : ideal R := annihilator (Jac ^ n),
  suffices : J = ⊤,
  { have hJ : J • Jac ^ n = ⊥ := annihilator_smul (Jac ^ n),
    simpa only [this, top_smul, ideal.zero_eq_bot] using hJ },
  by_contradiction hJ, change J ≠ ⊤ at hJ,
  rcases is_artinian.set_has_minimal {J' : ideal R | J < J'} ⟨⊤, hJ.lt_top⟩
    with ⟨J', hJJ' : J < J', hJ' : ∀ I, J < I → ¬ I < J'⟩,
  rcases set_like.exists_of_lt hJJ' with ⟨x, hxJ', hxJ⟩,
  obtain rfl : J ⊔ ideal.span {x} = J',
  { apply eq_of_le_of_not_lt _ (hJ' (J ⊔ ideal.span {x}) _),
    { exact (sup_le hJJ'.le (span_le.2 (singleton_subset_iff.2 hxJ'))) },
    { rw set_like.lt_iff_le_and_exists,
      exact ⟨le_sup_left, ⟨x, mem_sup_right (mem_span_singleton_self x), hxJ⟩⟩ } },
  have : J ⊔ Jac • ideal.span {x} ≤ J ⊔ ideal.span {x},
    from sup_le_sup_left (smul_le.2 (λ _ _ _, submodule.smul_mem _ _)) _,
  have : Jac * ideal.span {x} ≤ J, --Need version 4 of Nakayamas lemma on Stacks
  { classical, by_contradiction H,
    refine H (smul_sup_le_of_le_smul_of_le_jacobson_bot
      (fg_span_singleton _) le_rfl (this.eq_of_not_lt (hJ' _ _)).ge),
    exact lt_of_le_of_ne le_sup_left (λ h, H $ h.symm ▸ le_sup_right) },
  have : ideal.span {x} * Jac ^ (n + 1) ≤ ⊥,
    calc ideal.span {x} * Jac ^ (n + 1) = ideal.span {x} * Jac * Jac ^ n :
      by rw [pow_succ, ← mul_assoc]
    ... ≤ J * Jac ^ n : mul_le_mul (by rwa mul_comm) le_rfl
    ... = ⊥ : by simp [J],
  refine hxJ (mem_annihilator.2 (λ y hy, (mem_bot R).1 _)),
  refine this (mul_mem_mul (mem_span_singleton_self x) _),
  rwa [← hn (n + 1) (nat.le_succ _)]
end

section localization

variables (S : submonoid R) (L : Type*) [comm_ring L] [algebra R L] [is_localization S L]

include S

/-- Localizing an artinian ring can only reduce the amount of elements. -/
theorem localization_surjective : function.surjective (algebra_map R L) :=
begin
  intro r',
  obtain ⟨r₁, s, rfl⟩ := is_localization.mk'_surjective S r',
  obtain ⟨r₂, h⟩ : ∃ r : R, is_localization.mk' L 1 s = algebra_map R L r,
  swap, { exact ⟨r₁ * r₂, by rw [is_localization.mk'_eq_mul_mk'_one, map_mul, h]⟩ },
  obtain ⟨n, r, hr⟩ := is_artinian.exists_pow_succ_smul_dvd (s : R) (1 : R),
  use r,
  rw [smul_eq_mul, smul_eq_mul, pow_succ', mul_assoc] at hr,
  apply_fun algebra_map R L at hr,
  simp only [map_mul, ←submonoid.coe_pow] at hr,
  rw [←is_localization.mk'_one L, is_localization.mk'_eq_iff_eq, mul_one, submonoid.coe_one,
      ←(is_localization.map_units L (s ^ n)).mul_left_cancel hr, map_mul],
end

lemma localization_artinian : is_artinian_ring L :=
(localization_surjective S L).is_artinian_ring

/-- `is_artinian_ring.localization_artinian` can't be made an instance, as it would make `S` + `R`
into metavariables. However, this is safe. -/
instance : is_artinian_ring (localization S) := localization_artinian S _

end localization

end is_artinian_ring


namespace fol_04

variable A : Type
variable R : A → A → Prop

theorem fol_04 : (∃ x, ¬ R x x) → (∃ x, ∃ y, ¬ R x y) :=
assume h1: ∃ x, ¬ R x x,
exists.elim h1
  (assume t (h2: ¬ R t t),
   show ∃ (x y : A), ¬R x y, from exists.intro t
    (exists.intro t h2))

end fol_04


import linear_algebra.dual
import algebra.monoid_algebra
import ring_theory.localization
import linear_algebra.bilinear_form
import tactic.basic
import localization
/-!
# Mutations

This file defines mutations as isomorphisms between ambient fields.

A seed mutation is a combinatorial operation on a ℤ-module `N` given by a piecewise-linear
transformation on `N`. A mutation is a field isomorphism associated with a seed mutation.
It is an isomorphism on the `K` that is a field of fractions of the group algebra
of the dual module of `N`. We define mutations by the following three steps.

Step 1. We define a map `seed_mutation.monomial_to_away` that is a monoid hom
from `module.dual ℤ N` to `S`, where `S` is a localization of the group algebra of
`module.dual ℤ N` away from a non-zero element in the group algebra of `module.dual ℤ N`.
Step 2. We show that the map defined in Step 1 induces a isomorphism on `S`.
Step 3. We show that the map defined in Step 2 induces a isomorphism on `K` by using the following
general fact on localizations: a composition of localizations are equivalent to a single localization
when submonoids under these localizations satisfies appropriate inclusion conditions.

## Main definitions

* `seed_mutation (s s' : multiset N)` is a structure expressing that `μ : seed_mutatoin s s'`
  is a seed mutation with a source seed `s` and a target seed `s'`.
* `seed_mutation.field_equiv μ K` is a field isomorphism `K ≃+* K` associated with
  a seed mutation `μ`.

## Main statements

* `mutation_field_equiv_map_monomial` gives a fomula for a mutation on the monomials.
-/

open_locale classical

namespace skew_sym_bilin_form

section skew_sym_bilin_form

open bilin_form

variables {R : Type*} {M : Type*} [ring R] [add_comm_monoid M] [module R M] {B : bilin_form R M}

def is_skew_sym (B : bilin_form R M) : Prop :=
∀ (x y : M), B x y = - B y x

variable (H : is_skew_sym B)
include H

lemma skew_sym (x y : M) : B x y = - B y x := H x y

lemma is_refl : refl_bilin_form.is_refl B := λ x y H1, (H y x).symm ▸ neg_eq_zero.mpr H1

lemma ortho_sym {x y : M} : is_ortho B x y ↔ is_ortho B y x :=
refl_bilin_form.ortho_sym (is_refl H)

lemma is_alt [no_zero_divisors R] [char_zero R] : alt_bilin_form.is_alt B :=
λ n, add_self_eq_zero.mp (eq_neg_iff_add_eq_zero.mp (H n n))

@[simp]
lemma self_eq_zero  [no_zero_divisors R] [char_zero R] (x : M) : B x x = 0 := is_alt H x

@[simp]
lemma self_eq_zero_to_lin [no_zero_divisors R] [char_zero R] (x : M) : to_lin' B x x = 0 :=
self_eq_zero H x

end skew_sym_bilin_form

end skew_sym_bilin_form

class inductive is_sign (ε : ℤ) : Prop
| pos : ε = 1 → is_sign
| neg : ε = -1 → is_sign

instance one.is_sign : is_sign 1 := is_sign.pos rfl

instance neg_one.is_sign : is_sign (-1) := is_sign.neg rfl

instance neg.is_sign (ε : ℤ) [is_sign ε] : is_sign (-ε) :=
begin
  let h : is_sign ε := by apply_instance,
  refine is_sign.rec_on h (λ H, _) (λ H, _),
  repeat {any_goals { rw H <|> apply_instance <|> rw neg_neg }},
end

open skew_sym_bilin_form

class skew_symmetric_form (N : Type*) [add_comm_group N] :=
(form : bilin_form ℤ N)
(skew : is_skew_sym form)

variables {N : Type*} [add_comm_group N] [skew_symmetric_form N]

section seed_mutation

variables (s s' : multiset N) (v : N) (ε : ℤ)

open skew_symmetric_form

abbreviation B := @bilin_form.to_lin ℤ N _ _ _ form

def pl_mutation (v : N) (ε : ℤ) : N → N :=
λ n, n + (max 0 (ε * (B n v))) • v

def pl_mutation.equiv : N ≃ N :=
{ to_fun := pl_mutation v ε,
  inv_fun := pl_mutation (-v) (-ε),
  left_inv := λ n, by unfold pl_mutation; by simp only
    [ neg_mul_eq_neg_mul_symm, algebra.id.smul_eq_mul, bilin_form.to_lin_apply, linear_map.smul_apply,
      bilin_form.neg_right, mul_neg_eq_neg_mul_symm, smul_neg, linear_map.map_smul,
      linear_map.add_apply, linear_map.map_add, self_eq_zero skew,
      add_zero, add_neg_cancel_right, neg_neg, mul_zero, neg_zero],
  right_inv := λ n, by unfold pl_mutation; by simp only
    [ neg_mul_eq_neg_mul_symm, linear_map.map_neg, algebra.id.smul_eq_mul,
      bilin_form.to_lin_apply, linear_map.smul_apply, bilin_form.neg_right, mul_neg_eq_neg_mul_symm,
      linear_map.neg_apply, smul_neg, neg_neg, linear_map.map_smul, linear_map.add_apply, linear_map.map_add,
      self_eq_zero skew, add_zero, neg_add_cancel_right, eq_self_iff_true, mul_zero, neg_zero] }

lemma pl_mutation.bijective : function.bijective (pl_mutation v ε) :=
(pl_mutation.equiv v ε).bijective

@[simp] lemma pl_mutation_neg_left_id : pl_mutation (-v) (-ε) ∘ pl_mutation v ε = id :=
by ext x; apply (pl_mutation.equiv v ε).left_inv x

@[simp] lemma pl_mutation_neg_righ_id : pl_mutation v ε ∘ pl_mutation (-v) (-ε) = id :=
by ext x; apply (pl_mutation.equiv v ε).right_inv x

structure seed_mutation (s s' : multiset N) :=
(sign : ℤ)
(is_sign : is_sign sign)
(src_vect : N)
(tar_vect : N)
(src_in : src_vect ∈ s)
(tar_in : tar_vect ∈ s')
(seed_tar_src : s'.erase tar_vect = multiset.map (pl_mutation src_vect sign)  (s.erase src_vect))
(vect_tar_src : tar_vect = - src_vect)

end seed_mutation

section direction
variables {s s' : multiset N} (μ : seed_mutation s s') (v : N)

class is_mutation_direction  : Prop :=
(is_direction : ∃ k : ℤ, v = k • μ.src_vect)

lemma seed_mutation.is_direction [is_mutation_direction μ v] :
∃ k : ℤ, v = k • μ.src_vect := is_mutation_direction.is_direction

instance src_vect_is_mutation_direction :
is_mutation_direction μ μ.src_vect := by {use 1, simp}

instance tar_vect_is_mutation_direction :
is_mutation_direction μ μ.tar_vect := by {use -1, simp, exact μ.vect_tar_src}

lemma seed_mutation.tar_vect_eq_neg_src_vect {s s' : multiset N} (μ : seed_mutation s s') :
μ.tar_vect = - μ.src_vect := μ.vect_tar_src

lemma seed_mutation.src_vect_eq_neg_tar_vect {s s' : multiset N} (μ : seed_mutation s s') :
μ.src_vect = - μ.tar_vect :=
by calc μ.src_vect = - - μ.src_vect : by rw neg_neg
        ...         =   - μ.tar_vect : by rw μ.vect_tar_src

instance sign_tar_vect_is_mutation_direction : is_mutation_direction μ (μ.sign • μ.tar_vect) :=
begin
  cases μ.is_sign with h h,
  repeat { any_goals {rw h <|> simp <|> apply_instance <|> rw μ.tar_vect_eq_neg_src_vect }},
end

instance sign_src_vect_is_mutation_direction : is_mutation_direction μ (μ.sign • μ.src_vect) :=
begin
  cases μ.is_sign with h h,
  repeat { any_goals {rw h <|> simp <|> apply_instance <|> rw μ.src_vect_eq_neg_tar_vect }},
end

end direction

section seed_mutation

open skew_symmetric_form

namespace seed_mutation

@[simp] lemma form_mutation_direction_eq_zero {s s' : multiset N} (μ : seed_mutation s s')
(v w : N) [is_mutation_direction μ v] [is_mutation_direction μ w] : form v w = 0 :=
begin
  cases μ.is_direction v with k hk,
  cases μ.is_direction w with l hl,
  rw [hk, hl],
  simp only [bilin_form.smul_right, bilin_form.smul_left, mul_eq_zero, self_eq_zero skew, or_true, eq_self_iff_true],
end

@[simp] lemma form_mutation_direction_eq_zero' {s s' : multiset N} (μ : seed_mutation s s')
(v w : N) [is_mutation_direction μ v] [is_mutation_direction μ w] : B v w = 0 :=
begin
  simp only [bilin_form.to_lin_apply],
  exact form_mutation_direction_eq_zero μ v w,
end

end seed_mutation

lemma pl_mutation_eq (v : N) {w : N} (ε : ℤ) (c : ℤ) (h : w = c • v) : pl_mutation v ε w = w :=
begin
  unfold pl_mutation, rw h,
  simp only [add_right_eq_self, algebra.id.smul_eq_mul, bilin_form.to_lin_apply, linear_map.smul_apply,
    linear_map.map_smul, self_eq_zero skew, max_eq_right, eq_self_iff_true, zero_smul, mul_zero],
end

@[simp] lemma pl_mutation_eq' (v : N) (ε : ℤ) : pl_mutation v ε v = v :=
pl_mutation_eq v ε 1 (one_gsmul _).symm

def seed_mutation.symm {s s' : multiset N} (μ : seed_mutation s s') : seed_mutation s' s :=
{ sign := - μ.sign,
  is_sign := @is_sign.rec_on _ (is_sign (- μ.sign)) μ.is_sign
    (λ h, h.symm ▸ neg_one.is_sign) (λ h, h.symm ▸ one.is_sign),
  src_vect := μ.tar_vect,
  tar_vect := μ.src_vect,
  src_in := μ.tar_in,
  tar_in := μ.src_in,
  seed_tar_src :=
  begin
    let h := μ.seed_tar_src,
    rw [multiset.map_erase] at h,
    rw [h, multiset.map_erase],
    simp only [function.comp_app, multiset.map_congr, multiset.map_map],
    rw [pl_mutation_eq μ.src_vect μ.sign 1, pl_mutation_eq μ.tar_vect (-μ.sign) (-1),
      μ.tar_vect_eq_neg_src_vect],
    simp only [id.def, multiset.map_id', eq_self_iff_true, multiset.map_congr, pl_mutation_neg_left_id],
    congr,
    apply eq.symm,
    apply multiset.map_id',
    any_goals {simp only [one_gsmul, neg_smul]},
    apply μ.src_vect_eq_neg_tar_vect,
    exact function.bijective.injective (pl_mutation.bijective μ.tar_vect (-μ.sign)),
    exact function.bijective.injective (pl_mutation.bijective μ.src_vect μ.sign),
  end,
  vect_tar_src := μ.src_vect_eq_neg_tar_vect }

end seed_mutation

section function_of_vector

def ring_of_function (N : Type*) [add_comm_group N]  :=
add_monoid_algebra ℤ (module.dual ℤ N)

local attribute [reducible, inline] add_monoid_algebra ring_of_function

noncomputable instance : comm_ring (ring_of_function N) := add_monoid_algebra.comm_ring
noncomputable instance : comm_ring (module.dual ℤ N →₀ ℤ) := add_monoid_algebra.comm_ring

open skew_symmetric_form

noncomputable theory def function_of_vector (v : N) : (ring_of_function N) :=
finsupp.single 0 1 + finsupp.single (B v) 1

lemma function_of_vector_ne_zero  (v : N) : function_of_vector v ≠ 0 :=
begin
  unfold function_of_vector,
  let H := eq_or_ne (B v) 0,
  rw [ne.def] at H,
  cases H,
  rw [H, finsupp.nonzero_iff_exists],
  use 0,
  simp,
  rw finsupp.nonzero_iff_exists,
  use 0,
  simp only [finsupp.single_eq_same, pi.add_apply, finsupp.coe_add],
  have : ( 0 : module.dual ℤ N) ∉ (finsupp.single (B v) 1 : ring_of_function N).support,
  { rw [finsupp.support_single_ne_zero, finset.mem_singleton, <- ne.def, ne_comm],
      exact H,
      simp },
  rw finsupp.not_mem_support_iff at this,
  rw this,
  simp,
end

end function_of_vector

section mutation_away

local attribute [class] is_integral_domain

variables {s s' : multiset N} (μ : seed_mutation s s') (S : Type*) [integral_domain S]
[algebra (ring_of_function N) S]
[is_localization.away (function_of_vector (μ.sign • μ.src_vect)) S]

instance algebra_away : algebra (module.dual ℤ N →₀ ℤ) S := by assumption

open skew_symmetric_form

variables (ε : ℤ) [is_sign ε]

namespace seed_mutation

def away_unit : units S :=
{ val := algebra_map (ring_of_function N) S (function_of_vector (μ.sign • μ.src_vect)),
  inv := is_localization.mk' S 1 ⟨function_of_vector (μ.sign • μ.src_vect), submonoid.mem_powers _⟩,
  val_inv := by rw [is_localization.mul_mk'_eq_mk'_of_mul, mul_one, is_localization.mk'_self],
  inv_val := by rw [mul_comm, is_localization.mul_mk'_eq_mk'_of_mul, mul_one, is_localization.mk'_self] }

def monomial_to_away : multiplicative (module.dual ℤ N) →* S :=
{ to_fun := λ m,
  is_localization.mk' S
    (finsupp.single (multiplicative.to_add m) 1) (1 : submonoid.powers (function_of_vector (μ.sign • μ.src_vect)))
      * ↑((μ.away_unit S)^(ε • (-(multiplicative.to_add m) μ.src_vect))),
  map_one' :=
  begin
    simp only [mul_one, algebra.id.smul_eq_mul, gpow_zero, units.coe_one,
      to_add_one, mul_zero, linear_map.zero_apply, neg_zero],
    rw [<- add_monoid_algebra.one_def, is_localization.mk'_one, ring_hom.map_one],
  end,
  map_mul' := λ x y,
  begin
    simp only [algebra.id.smul_eq_mul, gpow_neg, mul_neg_eq_neg_mul_symm,
      neg_add_rev, linear_map.add_apply, to_add_mul],
    rw [<- one_mul (1 : ℤ), <- add_monoid_algebra.single_mul_single],
    rw [<- one_mul (1 : submonoid.powers (function_of_vector (μ.sign • μ.src_vect))),
      is_localization.mk'_mul, mul_add, gpow_add],
    simp only [mul_one, gpow_neg, mul_neg_eq_neg_mul_symm, units.coe_mul],
    ring_exp,
  end }

def to_away : ring_of_function N →+* S :=
add_monoid_algebra.lift_nc_ring_hom (int.cast_ring_hom S)
(μ.monomial_to_away S ε) (λ _ _, (commute.all _ _))

end seed_mutation

@[simp]
lemma to_away_of_function_of_mutation_direction (v : N) [is_mutation_direction μ v] :
(μ.to_away S ε) (function_of_vector v) =
  is_localization.mk' S (function_of_vector v)
      (1 : submonoid.powers (function_of_vector (μ.sign • μ.src_vect))) :=
begin
  unfold seed_mutation.to_away function_of_vector
    seed_mutation.monomial_to_away add_monoid_algebra.lift_nc_ring_hom,
  cases μ.is_direction v with k hk,
  simp only [mul_one,
    ring_hom.eq_int_cast,
    one_mul,
    bilin_form.to_lin_apply,
    ring_hom.coe_mk,
    ring_hom.map_add,
    to_add_of_add,
    int.cast_one,
    ring_hom.coe_add_monoid_hom,
    monoid_hom.coe_mk,
    add_monoid_algebra.lift_nc_single,
    of_add_zero,
    monoid_hom.map_one, μ.form_mutation_direction_eq_zero,
    algebra.id.smul_eq_mul, gpow_zero, mul_zero, neg_zero, units.coe_one, mul_one],
  rw [is_localization.mk'_one, is_localization.mk'_one, <- add_monoid_algebra.one_def],
  simp only [ring_hom.map_add, add_left_inj, ring_hom.map_one],
  refl,
end

lemma is_unit_to_away :
is_unit (μ.to_away S ε (function_of_vector (μ.sign • μ.src_vect))) :=
begin
  rw to_away_of_function_of_mutation_direction,
  rw is_localization.mk'_one,
  refine @is_localization.map_units (ring_of_function N) _ _ S _ _ _
    ⟨function_of_vector (μ.sign • μ.src_vect), submonoid.mem_powers _⟩,
end

def seed_mutation.ring_hom_away : S →+* S :=
is_localization.away.lift (function_of_vector (μ.sign • μ.src_vect)) (is_unit_to_away μ S ε)

@[simp] lemma mutation_away_map_const' :
((μ.ring_hom_away S ε).comp (algebra_map (ring_of_function N) S)).comp
  add_monoid_algebra.single_zero_ring_hom =
  (algebra_map (ring_of_function N) S ).comp add_monoid_algebra.single_zero_ring_hom :=
dec_trivial

@[simp] lemma mutation_away_map_const (b : ℤ) :
μ.ring_hom_away S ε ((algebra_map (ring_of_function N) S) (finsupp.single 0 b)) =
algebra_map (ring_of_function N) S (finsupp.single 0 b) :=
begin
  have h : finsupp.single (0 : module.dual ℤ N) b = add_monoid_algebra.single_zero_ring_hom b := by refl,
  rw h,
  repeat {rw <- ring_hom.comp_apply},
  repeat {rw <- ring_hom.coe_comp},
  rw mutation_away_map_const',
end

@[simp] lemma mutation_away_map_monomial (a : multiplicative(module.dual ℤ N)) :
(μ.ring_hom_away S ε) ((algebra_map (ring_of_function N) S) (finsupp.single a 1)) =
algebra_map (ring_of_function N) S (finsupp.single a 1)
  * ↑((μ.away_unit S) ^ (ε • (- a μ.src_vect))) :=
begin
  unfold seed_mutation.ring_hom_away is_localization.away.lift,
  rw is_localization.lift_eq,
  unfold seed_mutation.to_away add_monoid_algebra.lift_nc_ring_hom,
  dsimp,
  rw add_monoid_algebra.lift_nc_single,
  unfold seed_mutation.monomial_to_away,
  dsimp,
  rw [int.cast_one, one_mul],
  simp only [gpow_neg, units.ne_zero, or_false, mul_neg_eq_neg_mul_symm, mul_eq_mul_right_iff],
  rw is_localization.mk'_one,
  congr,
end

@[simp]
lemma mutation_away_eq_self_of_gpow_of_unit (k : ℤ) :
μ.ring_hom_away S ε ↑((μ.away_unit S) ^ k ) = ↑((μ.away_unit S) ^ k) :=
begin
  unfold seed_mutation.ring_hom_away is_localization.away.lift seed_mutation.away_unit,
  induction k,
  { dsimp,
    rw [gpow_coe_nat,  units.coe_pow, ring_hom.map_pow],
    dsimp,
    rw [is_localization.lift_eq],
    apply congr_arg (λ x : S, x ^ k),
    rw to_away_of_function_of_mutation_direction,
    rw is_localization.mk'_one },
  { rw [gpow_neg_succ_of_nat, <- inv_pow,units.coe_pow],
    rw [ring_hom.map_pow],
    apply congr_arg (λ x : S, x ^ k.succ),
    simp only [units.coe_mk, units.inv_mk],
    rw is_localization.lift_mk'_spec,
    simp only [set_like.coe_mk, to_away_of_function_of_mutation_direction, ring_hom.map_one],
    rw <- is_localization.mk'_mul,
    rw [one_mul, mul_one, is_localization.mk'_self] },
end

def seed_mutation.ring_equiv_away : S ≃+* S :=
ring_equiv.of_hom_inv (μ.ring_hom_away S ε)
(μ.ring_hom_away S (-ε))
begin
  ext x,
  have : ring_hom.id S = is_localization.lift
  (@is_localization.map_units _ _ (submonoid.powers (function_of_vector (μ.sign • μ.src_vect))) S _ _ _),
  { ext z,
    rw ring_hom.id_apply,
    rw is_localization.lift_id },
  rw this,
  rw is_localization.lift_unique,
  rw <- function.funext_iff,
  rw [<- function.comp, <- ring_hom.coe_comp, function.funext_iff,
    <- @ring_hom.ext_iff (ring_of_function N) S],
  apply add_monoid_algebra.ring_hom_ext,
  { intros a,
    repeat {rw ring_hom.coe_comp, rw function.comp},
    dsimp,
    rw [mutation_away_map_const, mutation_away_map_const] },
  { intros a,
    repeat {rw ring_hom.coe_comp, rw function.comp},
    dsimp,
    rw [mutation_away_map_monomial, ring_hom.map_mul, mutation_away_map_monomial, mul_assoc],
    simp only [gpow_neg],
    rw mutation_away_eq_self_of_gpow_of_unit,
    simp only [algebra.id.smul_eq_mul, gpow_neg, mul_neg_eq_neg_mul_symm],
    simp only [neg_mul_eq_neg_mul_symm, gpow_neg, inv_inv],
    erw units.val_inv,
    apply mul_one },
end
begin
  ext x,
  have : ring_hom.id S = is_localization.lift
  (@is_localization.map_units _ _ (submonoid.powers (function_of_vector (μ.sign • μ.src_vect))) S _ _ _),
  { ext z,
    rw ring_hom.id_apply,
    rw is_localization.lift_id },
  rw this,
  rw is_localization.lift_unique,
  rw <- function.funext_iff,
  rw [<- function.comp, <- ring_hom.coe_comp, function.funext_iff,
    <- @ring_hom.ext_iff (ring_of_function N) S],
  apply add_monoid_algebra.ring_hom_ext,
  { intros a,
    repeat {rw ring_hom.coe_comp, rw function.comp},
    dsimp,
    rw [mutation_away_map_const, mutation_away_map_const] },
  { intros a,
    repeat {rw ring_hom.coe_comp, rw function.comp},
    dsimp,
    rw [mutation_away_map_monomial, ring_hom.map_mul, mutation_away_map_monomial, mul_assoc],
    simp only [gpow_neg],
    rw mutation_away_eq_self_of_gpow_of_unit,
    simp only [algebra.id.smul_eq_mul, gpow_neg, mul_neg_eq_neg_mul_symm],
    simp only [neg_mul_eq_neg_mul_symm, gpow_neg, inv_inv],
    erw units.val_inv,
    apply mul_one },
end

end mutation_away

section mutation_frac

variables
[is_integral_domain (ring_of_function N)]
{s s' : multiset N} (μ : seed_mutation s s')
(K : Type*) [field K] [algebra (ring_of_function N) K] [is_fraction_ring (ring_of_function N) K]
(ε : ℤ) [is_sign ε]

local attribute [class] is_integral_domain

def ring_of_function.integral_domain : integral_domain (ring_of_function N) :=
is_integral_domain.to_integral_domain _ (by assumption)

local attribute [instance] ring_of_function.integral_domain

abbreviation seed_mutation.away := localization.away (function_of_vector (μ.sign • μ.src_vect))

def away.integral_domain : integral_domain μ.away :=
is_localization.integral_domain_of_le_non_zero_divisors μ.away
  (powers_le_non_zero_divisors_of_no_zero_divisors (function_of_vector_ne_zero (μ.sign • μ.src_vect)))

local attribute [instance]  away.integral_domain

def seed_mutation.algebra_of_away_frac : algebra μ.away K :=
is_localization.algebra_of_away_frac (function_of_vector_ne_zero (μ.sign • μ.src_vect)) μ.away K

local attribute[instance] seed_mutation.algebra_of_away_frac

def seed_mutation.is_fraction_of_algebra_of_away_frac :
@is_fraction_ring μ.away _ K _ (μ.algebra_of_away_frac K) :=
is_localization.is_fraction_of_algebra_of_away_frac _ μ.away K

local attribute[instance] seed_mutation.is_fraction_of_algebra_of_away_frac

private def z
{K : Type*} [field K] [algebra (ring_of_function N) K] [is_fraction_ring (ring_of_function N) K]
(m : module.dual ℤ N) := algebra_map (ring_of_function N) K (finsupp.single m 1)

def seed_mutation.field_equiv : K ≃+* K :=
is_fraction_ring.field_equiv_of_ring_equiv (μ.ring_equiv_away μ.away 1)

lemma mutation_field_equiv_map_monomial (m : module.dual ℤ N) :
μ.field_equiv K (z m)  =
z m * (1 + z (B (μ.sign • μ.src_vect))) ^ - m μ.src_vect :=
begin
  unfold z seed_mutation.field_equiv is_fraction_ring.field_equiv_of_ring_equiv seed_mutation.ring_equiv_away,
  let h_ne := function_of_vector_ne_zero (μ.sign • μ.src_vect),
  repeat {rw is_localization.eq_comp_map_of_lift_of_of_away_frac h_ne μ.away K},
  simp only [fpow_neg, linear_map.map_smul, is_localization.ring_equiv_of_ring_equiv_eq,
    mutation_away_map_monomial, algebra.id.smul_eq_mul, one_mul, gpow_neg, mul_eq_mul_left_iff, inv_inj',
    mul_neg_eq_neg_mul_symm, ring_hom.map_units_inv, ring_equiv.of_hom_inv_apply, ring_hom.map_mul],
  apply or.inl,
  unfold seed_mutation.away_unit function_of_vector,
  induction m μ.src_vect;
  simp only [ring_hom.map_add, units.coe_mk, gpow_neg_succ_of_nat, inv_inj', ring_hom.map_pow,
      ring_hom.map_units_inv, linear_map.map_smul, units.coe_pow, int.of_nat_eq_coe, gpow_coe_nat];
  rw <- add_monoid_algebra.one_def;
  simp only [ring_hom.map_one],
end

end mutation_frac


import util.classical

universes u v

namespace function

variables {α : Type u} {β : Type v}
variables [nonempty α]
variables (f : α → β)

noncomputable def inv (y : β) : α :=
ε x, f x = y

variable {f}
lemma inv_is_left_inverse_of_injective
  (H : injective f)
: left_inverse (inv f) f :=
begin
  simp [left_inverse,inv], intro,
  apply_epsilon_spec,
end

lemma inv_eq (x : α) (y : β)
  (H : injective f)
  (h : y = f x)
: inv f y = x :=
by rw [h,inv_is_left_inverse_of_injective H]

lemma injective_of_left_inverse_inv
  (h : left_inverse (inv f) f)
: injective f :=
injective_of_left_inverse h

lemma inv_is_right_inverse_of_surjective
  (H : surjective f)
: right_inverse (inv f) f :=
begin
  simp [right_inverse,left_inverse,inv], intro,
  apply_epsilon_spec,
end

end function


import HOLFloat.Common
import HOLFloat.Fixed
import HOLFloat.Float

-- This format is for IEEE
structure format' extends format where
  emin : ℤ
  emax : ℤ
deriving Repr

def is_valid_ieee_format(fmt : format') : Prop :=
    1 < fmt.r
  ∧ fmt.r % 2 = 0
  ∧ 1 < fmt.p
  ∧ fmt.emin ≤ fmt.emax

abbrev ieee_format : Type :=
  {fmt : format' // is_valid_ieee_format fmt}

def ieee_format.pnat : ieee_format → ℕ
| { val := { r := _, p := p, e := _, emin := _, emax := _ }, property := _ } => p.toNat

-- making common format
def mk_format (fmt : ieee_format) : format :=
    format.mk fmt.val.r fmt.val.p fmt.val.emin

@[simp]
theorem ieee_to_flformat {fmt : ieee_format} : is_valid_flformat (mk_format fmt) := by
  have h := fmt.prop
  apply And.intro
  case left =>
    apply h.left
  case right =>
    apply And.intro
    case left =>
      apply h.right.left
    case right =>
      apply h.right.right.left

def to_flformat (fmt : ieee_format): flformat:=
  ⟨mk_format fmt, by apply ieee_to_flformat⟩

--NOTE: is there a way to replace Coe.coe with ⟨⟩ ?
instance : Coe ieee_format fformat where
  coe fmt :=  to_fformat <| to_flformat  fmt

instance : Coe ieee_format flformat where
  coe fmt := to_flformat fmt
-- Largest ieee fp magnitude = f_max * r^(emax - p + 1)
def max_ieee (fmt : ieee_format): ℚ :=
  (fmt.val.r ^ fmt.val.p - (1 : ℚ) )* (fmt.val.r) ^ (fmt.val.emax - fmt.pnat + 1)

def ieee_threshold (fmt :ieee_format) : ℚ :=
  max_ieee fmt + fmt.val.r ^ (fmt.val.emax - fmt.pnat + 1)

def is_ieee_pinf ( fmt : ieee_format) (x : ℝ): Prop :=
  ⟨(ieee_threshold fmt)⟩ ≤ x

def is_ieee_ninf (fmt :ieee_format) (x : ℝ) : Prop :=
  x ≤ ⟨-(ieee_threshold fmt)⟩

def is_ieee (fmt :ieee_format) (x : ℝ) : Prop :=
  is_fixed (Coe.coe fmt) x
  ∨ (is_float (Coe.coe fmt) x ∧
    fmt.val.emin ≤ greatest_e (Coe.coe fmt) x ∧
    greatest_e (Coe.coe fmt) x ≤ fmt.val.emax)
  ∨ is_ieee_pinf fmt x
  ∨ is_ieee_ninf fmt x
noncomputable def ieee_exp (fmt : ieee_format)(x : ℝ) : ℤ :=
  if |x| ≤ finf (Coe.coe fmt) then
    fmt.val.emin
  else
    greatest_e (Coe.coe fmt) x

-- Rounding
--
noncomputable def ieee_round (fmt : ieee_format)(x: ℝ)(mode: roundmode): ℝ :=
  match mode with

  | roundmode.to_near =>
    if |x|  ≤ finf (Coe.coe fmt) then
      fround (Coe.coe fmt) roundmode.to_near x
    else if |x| ≤ ieee_threshold fmt then
      flround (Coe.coe fmt) roundmode.to_near x
    else
      x
  | roundmode.to_zero =>
      if |x| ≤ finf (Coe.coe fmt) then
        fround (Coe.coe fmt) roundmode.to_zero x
      else if |x| ≤  ieee_threshold fmt then
        flround (Coe.coe fmt) roundmode.to_zero x
      else if x > ieee_threshold fmt then
        max_ieee fmt
      else
        - (max_ieee fmt)
  | roundmode.to_pinf =>

      if |x|  ≤ finf (Coe.coe fmt) then
        fround (Coe.coe fmt) roundmode.to_pinf x
      else if x ≤ (- max_ieee fmt) then
        - max_ieee fmt
      else
        flround (Coe.coe fmt) roundmode.to_pinf x
  | roundmode.to_ninf =>
      if |x|  ≤ finf (Coe.coe fmt) then
        fround (Coe.coe fmt) roundmode.to_ninf x
      else if max_ieee fmt ≤ x then
        max_ieee fmt
      else
        flround (Coe.coe fmt) roundmode.to_ninf x
-- machine epsilon
def ieee_eps (fmt :ieee_format) :=
  fl_eps (Coe.coe fmt)