/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import algebra.char_p.basic
import data.equiv.ring
import algebra.group_with_zero.power
import algebra.iterate_hom

/-!
# The perfect closure of a field
-/

universes u v

open function

section defs

variables (R : Type u) [comm_semiring R] (p : ℕ) [fact p.prime] [char_p R p]

/-- A perfect ring is a ring of characteristic p that has p-th root. -/
class perfect_ring : Type u :=
(pth_root' : R → R)
(frobenius_pth_root' : ∀ x, frobenius R p (pth_root' x) = x)
(pth_root_frobenius' : ∀ x, pth_root' (frobenius R p x) = x)

/-- Frobenius automorphism of a perfect ring. -/
def frobenius_equiv [perfect_ring R p] : R ≃+* R :=
{ inv_fun := perfect_ring.pth_root' p,
  left_inv := perfect_ring.pth_root_frobenius',
  right_inv := perfect_ring.frobenius_pth_root',
  .. frobenius R p }

/-- `p`-th root of an element in a `perfect_ring` as a `ring_hom`. -/
def pth_root [perfect_ring R p] : R →+* R :=
(frobenius_equiv R p).symm

end defs

section

variables {R : Type u} [comm_semiring R] {S : Type v} [comm_semiring S] (f : R →* S) (g : R →+* S)
  {p : ℕ} [fact p.prime] [char_p R p] [perfect_ring R p] [char_p S p] [perfect_ring S p]

@[simp] lemma coe_frobenius_equiv : ⇑(frobenius_equiv R p) = frobenius R p := rfl

@[simp] lemma coe_frobenius_equiv_symm : ⇑(frobenius_equiv R p).symm = pth_root R p := rfl

@[simp] theorem frobenius_pth_root (x : R) : frobenius R p (pth_root R p x) = x :=
(frobenius_equiv R p).apply_symm_apply x

@[simp] theorem pth_root_pow_p (x : R) : pth_root R p x ^ p = x :=
frobenius_pth_root x

@[simp] theorem pth_root_frobenius (x : R) : pth_root R p (frobenius R p x) = x :=
(frobenius_equiv R p).symm_apply_apply x

@[simp] theorem pth_root_pow_p' (x : R) : pth_root R p (x ^ p) = x :=
pth_root_frobenius x

theorem left_inverse_pth_root_frobenius : left_inverse (pth_root R p) (frobenius R p) :=
pth_root_frobenius

theorem right_inverse_pth_root_frobenius : function.right_inverse (pth_root R p) (frobenius R p) :=
frobenius_pth_root

theorem commute_frobenius_pth_root : function.commute (frobenius R p) (pth_root R p) :=
λ x, (frobenius_pth_root x).trans (pth_root_frobenius x).symm

theorem eq_pth_root_iff {x y : R} : x = pth_root R p y ↔ frobenius R p x = y :=
(frobenius_equiv R p).to_equiv.eq_symm_apply

theorem pth_root_eq_iff {x y : R} : pth_root R p x = y ↔ x = frobenius R p y :=
(frobenius_equiv R p).to_equiv.symm_apply_eq

theorem monoid_hom.map_pth_root (x : R) : f (pth_root R p x) = pth_root S p (f x) :=
eq_pth_root_iff.2 $ by rw [← f.map_frobenius, frobenius_pth_root]

theorem monoid_hom.map_iterate_pth_root (x : R) (n : ℕ) :
  f (pth_root R p^[n] x) = (pth_root S p^[n] (f x)) :=
semiconj.iterate_right f.map_pth_root n x

theorem ring_hom.map_pth_root (x : R) :
  g (pth_root R p x) = pth_root S p (g x) :=
g.to_monoid_hom.map_pth_root x

theorem ring_hom.map_iterate_pth_root (x : R) (n : ℕ) :
  g (pth_root R p^[n] x) = (pth_root S p^[n] (g x)) :=
g.to_monoid_hom.map_iterate_pth_root x n

variables (p)
lemma injective_pow_p {x y : R} (hxy : x ^ p = y ^ p) : x = y :=
left_inverse_pth_root_frobenius.injective hxy

end

section

variables (K : Type u) [comm_ring K] (p : ℕ) [fact p.prime] [char_p K p]

/-- `perfect_closure K p` is the quotient by this relation. -/
@[mk_iff] inductive perfect_closure.r : (ℕ × K) → (ℕ × K) → Prop
| intro : ∀ n x, perfect_closure.r (n, x) (n+1, frobenius K p x)

/-- The perfect closure is the smallest extension that makes frobenius surjective. -/
def perfect_closure : Type u := quot (perfect_closure.r K p)

end

namespace perfect_closure

variables (K : Type u)

section ring

variables [comm_ring K] (p : ℕ) [fact p.prime] [char_p K p]

/-- Constructor for `perfect_closure`. -/
def mk (x : ℕ × K) : perfect_closure K p := quot.mk (r K p) x

@[simp] lemma quot_mk_eq_mk (x : ℕ × K) :
  (quot.mk (r K p) x : perfect_closure K p) = mk K p x := rfl

variables {K p}

/-- Lift a function `ℕ × K → L` to a function on `perfect_closure K p`. -/
@[elab_as_eliminator]
def lift_on {L : Type*} (x : perfect_closure K p) (f : ℕ × K → L)
  (hf : ∀ x y, r K p x y → f x = f y) : L :=
quot.lift_on x f hf

@[simp] lemma lift_on_mk {L : Sort*} (f : ℕ × K → L)
  (hf : ∀ x y, r K p x y → f x = f y) (x : ℕ × K) :
  (mk K p x).lift_on f hf = f x :=
rfl

@[elab_as_eliminator]
lemma induction_on (x : perfect_closure K p) {q : perfect_closure K p → Prop}
  (h : ∀ x, q (mk K p x)) : q x :=
quot.induction_on x h

variables (K p)

private lemma mul_aux_left (x1 x2 y : ℕ × K) (H : r K p x1 x2) :
  mk K p (x1.1 + y.1, ((frobenius K p)^[y.1] x1.2) * ((frobenius K p)^[x1.1] y.2)) =
  mk K p (x2.1 + y.1, ((frobenius K p)^[y.1] x2.2) * ((frobenius K p)^[x2.1] y.2)) :=
match x1, x2, H with
| _, _, r.intro n x := quot.sound $ by rw [← iterate_succ_apply, iterate_succ',
    iterate_succ', ← frobenius_mul, nat.succ_add]; apply r.intro
end

private lemma mul_aux_right (x y1 y2 : ℕ × K) (H : r K p y1 y2) :
  mk K p (x.1 + y1.1, ((frobenius K p)^[y1.1] x.2) * ((frobenius K p)^[x.1] y1.2)) =
  mk K p (x.1 + y2.1, ((frobenius K p)^[y2.1] x.2) * ((frobenius K p)^[x.1] y2.2)) :=
match y1, y2, H with
| _, _, r.intro n y := quot.sound $ by rw [← iterate_succ_apply, iterate_succ',
    iterate_succ', ← frobenius_mul]; apply r.intro
end

instance : has_mul (perfect_closure K p) :=
⟨quot.lift (λ x:ℕ×K, quot.lift (λ y:ℕ×K, mk K p
    (x.1 + y.1, ((frobenius K p)^[y.1] x.2) * ((frobenius K p)^[x.1] y.2))) (mul_aux_right K p x))
  (λ x1 x2 (H : r K p x1 x2), funext $ λ e, quot.induction_on e $ λ y,
mul_aux_left K p x1 x2 y H)⟩

@[simp] lemma mk_mul_mk (x y : ℕ × K) :
  mk K p x * mk K p y = mk K p
    (x.1 + y.1, ((frobenius K p)^[y.1] x.2) * ((frobenius K p)^[x.1] y.2)) :=
rfl

instance : comm_monoid (perfect_closure K p) :=
{ mul_assoc := λ e f g, quot.induction_on e $ λ ⟨m, x⟩, quot.induction_on f $ λ ⟨n, y⟩,
    quot.induction_on g $ λ ⟨s, z⟩, congr_arg (quot.mk _) $
    by simp only [add_assoc, mul_assoc, ring_hom.iterate_map_mul,
      ← iterate_add_apply, add_comm, add_left_comm],
  one := mk K p (0, 1),
  one_mul := λ e, quot.induction_on e (λ ⟨n, x⟩, congr_arg (quot.mk _) $
    by simp only [ring_hom.iterate_map_one, iterate_zero_apply, one_mul, zero_add]),
  mul_one := λ e, quot.induction_on e (λ ⟨n, x⟩, congr_arg (quot.mk _) $
    by simp only [ring_hom.iterate_map_one, iterate_zero_apply, mul_one, add_zero]),
  mul_comm := λ e f, quot.induction_on e (λ ⟨m, x⟩, quot.induction_on f (λ ⟨n, y⟩,
    congr_arg (quot.mk _) $ by simp only [add_comm, mul_comm])),
  .. (infer_instance : has_mul (perfect_closure K p)) }

lemma one_def : (1 : perfect_closure K p) = mk K p (0, 1) := rfl

instance : inhabited (perfect_closure K p) := ⟨1⟩

private lemma add_aux_left (x1 x2 y : ℕ × K) (H : r K p x1 x2) :
  mk K p (x1.1 + y.1, ((frobenius K p)^[y.1] x1.2) + ((frobenius K p)^[x1.1] y.2)) =
  mk K p (x2.1 + y.1, ((frobenius K p)^[y.1] x2.2) + ((frobenius K p)^[x2.1] y.2)) :=
match x1, x2, H with
| _, _, r.intro n x := quot.sound $ by rw [← iterate_succ_apply, iterate_succ',
    iterate_succ', ← frobenius_add, nat.succ_add]; apply r.intro
end

private lemma add_aux_right (x y1 y2 : ℕ × K) (H : r K p y1 y2) :
  mk K p (x.1 + y1.1, ((frobenius K p)^[y1.1] x.2) + ((frobenius K p)^[x.1] y1.2)) =
  mk K p (x.1 + y2.1, ((frobenius K p)^[y2.1] x.2) + ((frobenius K p)^[x.1] y2.2)) :=
match y1, y2, H with
| _, _, r.intro n y := quot.sound $ by rw [← iterate_succ_apply, iterate_succ',
    iterate_succ', ← frobenius_add]; apply r.intro
end

instance : has_add (perfect_closure K p) :=
⟨quot.lift (λ x:ℕ×K, quot.lift (λ y:ℕ×K, mk K p
    (x.1 + y.1, ((frobenius K p)^[y.1] x.2) + ((frobenius K p)^[x.1] y.2))) (add_aux_right K p x))
  (λ x1 x2 (H : r K p x1 x2), funext $ λ e, quot.induction_on e $ λ y,
add_aux_left K p x1 x2 y H)⟩

@[simp] lemma mk_add_mk (x y : ℕ × K) :
  mk K p x + mk K p y =
    mk K p (x.1 + y.1, ((frobenius K p)^[y.1] x.2) + ((frobenius K p)^[x.1] y.2)) := rfl

instance : has_neg (perfect_closure K p) :=
⟨quot.lift (λ x:ℕ×K, mk K p (x.1, -x.2)) (λ x y (H : r K p x y), match x, y, H with
| _, _, r.intro n x := quot.sound $ by rw ← frobenius_neg; apply r.intro
end)⟩

@[simp] lemma neg_mk (x : ℕ × K) : - mk K p x = mk K p (x.1, -x.2) := rfl

instance : has_zero (perfect_closure K p) := ⟨mk K p (0, 0)⟩

lemma zero_def : (0 : perfect_closure K p) = mk K p (0, 0) := rfl

theorem mk_zero (n : ℕ) : mk K p (n, 0) = 0 :=
by induction n with n ih; [refl, rw ← ih]; symmetry; apply quot.sound;
have := r.intro n (0:K); rwa [frobenius_zero K p] at this

theorem r.sound (m n : ℕ) (x y : K) (H : frobenius K p^[m] x = y) :
  mk K p (n, x) = mk K p (m + n, y) :=
by subst H; induction m with m ih; [simp only [zero_add, iterate_zero_apply],
  rw [ih, nat.succ_add, iterate_succ']]; apply quot.sound; apply r.intro

instance : comm_ring (perfect_closure K p) :=
{ add_assoc := λ e f g, quot.induction_on e $ λ ⟨m, x⟩, quot.induction_on f $ λ ⟨n, y⟩,
    quot.induction_on g $ λ ⟨s, z⟩, congr_arg (quot.mk _) $
    by simp only [add_assoc, ring_hom.iterate_map_add,
      ← iterate_add_apply, add_comm, add_left_comm],
  zero := 0,
  zero_add := λ e, quot.induction_on e (λ ⟨n, x⟩, congr_arg (quot.mk _) $
    by simp only [ring_hom.iterate_map_zero, iterate_zero_apply, zero_add]),
  add_zero := λ e, quot.induction_on e (λ ⟨n, x⟩, congr_arg (quot.mk _) $
    by simp only [ring_hom.iterate_map_zero, iterate_zero_apply, add_zero]),
  sub_eq_add_neg := λ a b, rfl,
  add_left_neg := λ e, by exact quot.induction_on e (λ ⟨n, x⟩,
    by simp only [quot_mk_eq_mk, neg_mk, mk_add_mk,
      ring_hom.iterate_map_neg, add_left_neg, mk_zero]),
  add_comm := λ e f, quot.induction_on e (λ ⟨m, x⟩, quot.induction_on f (λ ⟨n, y⟩,
    congr_arg (quot.mk _) $ by simp only [add_comm])),
  left_distrib := λ e f g, quot.induction_on e $ λ ⟨m, x⟩, quot.induction_on f $ λ ⟨n, y⟩,
    quot.induction_on g $ λ ⟨s, z⟩, show quot.mk _ _ = quot.mk _ _,
    by simp only [add_assoc, add_comm, add_left_comm]; apply r.sound;
    simp only [ring_hom.iterate_map_mul, ring_hom.iterate_map_add,
      ← iterate_add_apply, mul_add, add_comm, add_left_comm],
  right_distrib := λ e f g, quot.induction_on e $ λ ⟨m, x⟩, quot.induction_on f $ λ ⟨n, y⟩,
    quot.induction_on g $ λ ⟨s, z⟩, show quot.mk _ _ = quot.mk _ _,
    by simp only [add_assoc, add_comm _ s, add_left_comm _ s]; apply r.sound;
    simp only [ring_hom.iterate_map_mul, ring_hom.iterate_map_add,
      ← iterate_add_apply, add_mul, add_comm, add_left_comm],
  .. (infer_instance : has_add (perfect_closure K p)),
  .. (infer_instance : has_neg (perfect_closure K p)),
  .. (infer_instance : comm_monoid (perfect_closure K p)) }

theorem eq_iff' (x y : ℕ × K) : mk K p x = mk K p y ↔
    ∃ z, (frobenius K p^[y.1 + z] x.2) = (frobenius K p^[x.1 + z] y.2) :=
begin
  split,
  { intro H,
    replace H := quot.exact _ H,
    induction H,
    case eqv_gen.rel : x y H
    { cases H with n x, exact ⟨0, rfl⟩ },
    case eqv_gen.refl : H
    { exact ⟨0, rfl⟩ },
    case eqv_gen.symm : x y H ih
    { cases ih with w ih, exact ⟨w, ih.symm⟩ },
    case eqv_gen.trans : x y z H1 H2 ih1 ih2
    { cases ih1 with z1 ih1,
      cases ih2 with z2 ih2,
      existsi z2+(y.1+z1),
      rw [← add_assoc, iterate_add_apply, ih1],
      rw [← iterate_add_apply, add_comm, iterate_add_apply, ih2],
      rw [← iterate_add_apply],
      simp only [add_comm, add_left_comm] } },
  intro H,
  cases x with m x,
  cases y with n y,
  cases H with z H, dsimp only at H,
  rw [r.sound K p (n+z) m x _ rfl, r.sound K p (m+z) n y _ rfl, H],
  rw [add_assoc, add_comm, add_comm z]
end

theorem nat_cast (n x : ℕ) : (x : perfect_closure K p) = mk K p (n, x) :=
begin
  induction n with n ih,
  { induction x with x ih, {refl},
    rw [nat.cast_succ, nat.cast_succ, ih], refl },
  rw ih, apply quot.sound,
  conv {congr, skip, skip, rw ← frobenius_nat_cast K p x},
  apply r.intro
end

theorem int_cast (x : ℤ) : (x : perfect_closure K p) = mk K p (0, x) :=
by induction x; simp only [int.cast_of_nat, int.cast_neg_succ_of_nat, nat_cast K p 0]; refl

instance : char_p (perfect_closure K p) p :=
begin
  constructor, intro x, rw ← char_p.cast_eq_zero_iff K,
  rw [← nat.cast_zero, nat_cast_eq_iff, nat.cast_zero]
end

theorem frobenius_mk (x : ℕ × K) :
  (frobenius (perfect_closure K p) p : perfect_closure K p → perfect_closure K p)
    (mk K p x) = mk _ _ (x.1, x.2^p) :=
begin
  simp only [frobenius_def], cases x with n x, dsimp only,
  suffices : ∀ p':ℕ, mk K p (n, x) ^ p' = mk K p (n, x ^ p'),
  { apply this },
  intro p, induction p with p ih,
  case nat.zero { apply r.sound, rw [(frobenius _ _).iterate_map_one, pow_zero] },
  case nat.succ {
    rw [pow_succ, ih],
    symmetry,
    apply r.sound,
    simp only [pow_succ, (frobenius _ _).iterate_map_mul]
  }
end

/-- Embedding of `K` into `perfect_closure K p` -/
def of : K →+* perfect_closure K p :=
{ to_fun := λ x, mk _ _ (0, x),
  map_one' := rfl,
  map_mul' := λ x y, rfl,
  map_zero' := rfl,
  map_add' := λ x y, rfl }

lemma of_apply (x : K) : of K p x = mk _ _ (0, x) := rfl

end ring

theorem eq_iff [integral_domain K] (p : ℕ) [fact p.prime] [char_p K p]
  (x y : ℕ × K) : quot.mk (r K p) x = quot.mk (r K p) y ↔
    (frobenius K p^[y.1] x.2) = (frobenius K p^[x.1] y.2) :=
(eq_iff' K p x y).trans ⟨λ ⟨z, H⟩, (frobenius_inj K p).iterate z $
  by simpa only [add_comm, iterate_add] using H,
λ H, ⟨0, H⟩⟩

section field

variables [field K] (p : ℕ) [fact p.prime] [char_p K p]

instance : has_inv (perfect_closure K p) :=
⟨quot.lift (λ x:ℕ×K, quot.mk (r K p) (x.1, x.2⁻¹)) (λ x y (H : r K p x y), match x, y, H with
| _, _, r.intro n x := quot.sound $ by { simp only [frobenius_def], rw ← inv_pow', apply r.intro }
end)⟩

instance : field (perfect_closure K p) :=
{ exists_pair_ne := ⟨0, 1, λ H, zero_ne_one ((eq_iff _ _ _ _).1 H)⟩,
  mul_inv_cancel := λ e, induction_on e $ λ ⟨m, x⟩ H,
    have _ := mt (eq_iff _ _ _ _).2 H, (eq_iff _ _ _ _).2
      (by simp only [(frobenius _ _).iterate_map_one, (frobenius K p).iterate_map_zero,
        iterate_zero_apply, ← (frobenius _ p).iterate_map_mul] at this ⊢;
        rw [mul_inv_cancel this, (frobenius _ _).iterate_map_one]),
  inv_zero := congr_arg (quot.mk (r K p)) (by rw [inv_zero]),
  .. (infer_instance : has_inv (perfect_closure K p)),
  .. (infer_instance : comm_ring (perfect_closure K p)) }

instance : perfect_ring (perfect_closure K p) p :=
{ pth_root' := λ e, lift_on e (λ x, mk K p (x.1 + 1, x.2)) (λ x y H,
    match x, y, H with
    | _, _, r.intro n x := quot.sound (r.intro _ _)
    end),
  frobenius_pth_root' := λ e, induction_on e (λ ⟨n, x⟩,
    by { simp only [lift_on_mk, frobenius_mk], exact (quot.sound $ r.intro _ _).symm }),
  pth_root_frobenius' := λ e, induction_on e (λ ⟨n, x⟩,
    by { simp only [lift_on_mk, frobenius_mk], exact (quot.sound $ r.intro _ _).symm }) }

theorem eq_pth_root (x : ℕ × K) :
  mk K p x = (pth_root (perfect_closure K p) p^[x.1] (of K p x.2)) :=
begin
  rcases x with ⟨m, x⟩,
  induction m with m ih, {refl},
  rw [iterate_succ_apply', ← ih]; refl
end

/-- Given a field `K` of characteristic `p` and a perfect ring `L` of the same characteristic,
any homomorphism `K →+* L` can be lifted to `perfect_closure K p`. -/
def lift (L : Type v) [comm_semiring L] [char_p L p] [perfect_ring L p] :
  (K →+* L) ≃ (perfect_closure K p →+* L) :=
begin
  have := left_inverse_pth_root_frobenius.iterate,
  refine_struct { .. },
  field to_fun { intro f,
    refine_struct { .. },
    field to_fun { refine λ e, lift_on e (λ x, pth_root L p^[x.1] (f x.2)) _,
      rintro a b ⟨n⟩,
      simp only [f.map_frobenius, iterate_succ_apply, pth_root_frobenius] },
    field map_one' { exact f.map_one },
    field map_zero' { exact f.map_zero },
    field map_mul' { rintro ⟨x⟩ ⟨y⟩,
      simp only [quot_mk_eq_mk, lift_on_mk, mk_mul_mk, ring_hom.map_iterate_frobenius,
        ring_hom.iterate_map_mul, ring_hom.map_mul],
      rw [iterate_add_apply, this _ _, add_comm, iterate_add_apply, this _ _] },
    field map_add' { rintro ⟨x⟩ ⟨y⟩,
      simp only [quot_mk_eq_mk, lift_on_mk, mk_add_mk, ring_hom.map_iterate_frobenius,
        ring_hom.iterate_map_add, ring_hom.map_add],
      rw [iterate_add_apply, this _ _, add_comm x.1, iterate_add_apply, this _ _] } },
  field inv_fun { exact λ f, f.comp (of K p) },
  field left_inv { intro f, ext x, refl },
  field right_inv { intro f, ext ⟨x⟩,
    simp only [ring_hom.coe_mk, quot_mk_eq_mk, ring_hom.comp_apply, lift_on_mk],
    rw [eq_pth_root, ring_hom.map_iterate_pth_root] }
end

end field

end perfect_closure


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jens Wagemaker
-/
import algebra.divisibility
import algebra.group_power.lemmas
import algebra.invertible
import order.atoms

/-!
# Associated, prime, and irreducible elements.
-/

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

section prime
variables [comm_monoid_with_zero α]

/-- prime element of a `comm_monoid_with_zero` -/
def prime (p : α) : Prop :=
p ≠ 0 ∧ ¬ is_unit p ∧ (∀a b, p ∣ a * b → p ∣ a ∨ p ∣ b)

namespace prime
variables {p : α} (hp : prime p)
include hp

lemma ne_zero : p ≠ 0 :=
hp.1

lemma not_unit : ¬ is_unit p :=
hp.2.1

lemma not_dvd_one : ¬ p ∣ 1 :=
mt (is_unit_of_dvd_one _) hp.not_unit

lemma ne_one : p ≠ 1 :=
λ h, hp.2.1 (h.symm ▸ is_unit_one)

lemma dvd_or_dvd (hp : prime p) {a b : α} (h : p ∣ a * b) :
  p ∣ a ∨ p ∣ b :=
hp.2.2 a b h

lemma dvd_of_dvd_pow (hp : prime p) {a : α} {n : ℕ} (h : p ∣ a^n) :
  p ∣ a :=
begin
  induction n with n ih,
  { rw pow_zero at h,
    have := is_unit_of_dvd_one _ h,
    have := not_unit hp,
    contradiction },
  rw pow_succ at h,
  cases dvd_or_dvd hp h with dvd_a dvd_pow,
  { assumption },
  exact ih dvd_pow
end

end prime

@[simp] lemma not_prime_zero : ¬ prime (0 : α) :=
λ h, h.ne_zero rfl

@[simp] lemma not_prime_one : ¬ prime (1 : α) :=
λ h, h.not_unit is_unit_one

section map
variables [comm_monoid_with_zero β] {F : Type*} {G : Type*}
  [monoid_with_zero_hom_class F α β] [mul_hom_class G β α] (f : F) (g : G) {p : α}

lemma comap_prime (hinv : ∀ a, g (f a : β) = a) (hp : prime (f p)) : prime p :=
⟨ λ h, hp.1 $ by simp [h],  λ h, hp.2.1 $ h.map f,  λ a b h, by
  { refine (hp.2.2 (f a) (f b) $ by { convert map_dvd f h, simp }).imp _ _;
    { intro h, convert ← map_dvd g h; apply hinv } } ⟩

lemma mul_equiv.prime_iff (e : α ≃* β) : prime p ↔ prime (e p) :=
⟨ λ h, comap_prime e.symm e (λ a, by simp) $ (e.symm_apply_apply p).substr h,
  comap_prime e e.symm (λ a, by simp) ⟩

end map

end prime

lemma prime.left_dvd_or_dvd_right_of_dvd_mul [cancel_comm_monoid_with_zero α] {p : α}
  (hp : prime p) {a b : α} : a ∣ p * b → p ∣ a ∨ a ∣ b :=
begin
  rintro ⟨c, hc⟩,
  rcases hp.2.2 a c (hc ▸ dvd_mul_right _ _) with h | ⟨x, rfl⟩,
  { exact or.inl h },
  { rw [mul_left_comm, mul_right_inj' hp.ne_zero] at hc,
    exact or.inr (hc.symm ▸ dvd_mul_right _ _) }
end

lemma prime.pow_dvd_of_dvd_mul_left
  [cancel_comm_monoid_with_zero α]
  {p a b : α} (hp : prime p) (n : ℕ) (h : ¬p ∣ a) (h' : p ^ n ∣ a * b) : p ^ n ∣ b :=
begin
  induction n with n ih,
  { rw pow_zero, exact one_dvd b },
  { obtain ⟨c, rfl⟩ := ih (dvd_trans (pow_dvd_pow p n.le_succ) h'),
    rw pow_succ',
    apply mul_dvd_mul_left _ ((hp.dvd_or_dvd _).resolve_left h),
    rwa [←mul_dvd_mul_iff_left (pow_ne_zero n hp.ne_zero), ←pow_succ', mul_left_comm] }
end

lemma prime.pow_dvd_of_dvd_mul_right
  [cancel_comm_monoid_with_zero α]
  {p a b : α} (hp : prime p) (n : ℕ) (h : ¬p ∣ b) (h' : p ^ n ∣ a * b) : p ^ n ∣ a :=
by { rw [mul_comm] at h', exact hp.pow_dvd_of_dvd_mul_left n h h' }

lemma prime.dvd_of_pow_dvd_pow_mul_pow_of_square_not_dvd [cancel_comm_monoid_with_zero α]
  {p a b : α} {n : ℕ} (hp : prime p) (hpow : p ^ n.succ ∣ a ^ n.succ * b ^ n)
  (hb : ¬ p ^ 2 ∣ b) : p ∣ a :=
begin
  -- Suppose `p ∣ b`, write `b = p * x` and `hy : a ^ n.succ * b ^ n = p ^ n.succ * y`.
  cases (hp.dvd_or_dvd ((dvd_pow_self p (nat.succ_ne_zero n)).trans hpow)) with H hbdiv,
  { exact hp.dvd_of_dvd_pow H },
  obtain ⟨x, rfl⟩ := hp.dvd_of_dvd_pow hbdiv,
  obtain ⟨y, hy⟩ := hpow,
  -- Then we can divide out a common factor of `p ^ n` from the equation `hy`.
  have : a ^ n.succ * x ^ n = p * y,
  { refine mul_left_cancel₀ (pow_ne_zero n hp.ne_zero) _,
    rw [← mul_assoc _ p, ← pow_succ', ← hy, mul_pow, ← mul_assoc (a ^ n.succ),
      mul_comm _ (p ^ n), mul_assoc] },
  -- So `p ∣ a` (and we're done) or `p ∣ x`, which can't be the case since it implies `p^2 ∣ b`.
  refine hp.dvd_of_dvd_pow ((hp.dvd_or_dvd ⟨_, this⟩).resolve_right (λ hdvdx, hb _)),
  obtain ⟨z, rfl⟩ := hp.dvd_of_dvd_pow hdvdx,
  rw [pow_two, ← mul_assoc],
  exact dvd_mul_right _ _,
end

/-- `irreducible p` states that `p` is non-unit and only factors into units.

We explicitly avoid stating that `p` is non-zero, this would require a semiring. Assuming only a
monoid allows us to reuse irreducible for associated elements.
-/
class irreducible [monoid α] (p : α) : Prop :=
(not_unit' : ¬ is_unit p)
(is_unit_or_is_unit' : ∀a b, p = a * b → is_unit a ∨ is_unit b)

namespace irreducible

lemma not_unit [monoid α] {p : α} (hp : irreducible p) : ¬ is_unit p :=
hp.1

lemma not_dvd_one [comm_monoid α] {p : α} (hp : irreducible p) : ¬ p ∣ 1 :=
mt (is_unit_of_dvd_one _) hp.not_unit

lemma is_unit_or_is_unit [monoid α] {p : α} (hp : irreducible p) {a b : α} (h : p = a * b) :
  is_unit a ∨ is_unit b :=
irreducible.is_unit_or_is_unit' a b h

end irreducible

lemma irreducible_iff [monoid α] {p : α} :
  irreducible p ↔ ¬ is_unit p ∧ ∀a b, p = a * b → is_unit a ∨ is_unit b :=
⟨λ h, ⟨h.1, h.2⟩, λ h, ⟨h.1, h.2⟩⟩

@[simp] theorem not_irreducible_one [monoid α] : ¬ irreducible (1 : α) :=
by simp [irreducible_iff]

theorem irreducible.ne_one [monoid α] : ∀ {p:α}, irreducible p → p ≠ 1
| _ hp rfl := not_irreducible_one hp

@[simp] theorem not_irreducible_zero [monoid_with_zero α] : ¬ irreducible (0 : α)
| ⟨hn0, h⟩ := have is_unit (0:α) ∨ is_unit (0:α), from h 0 0 ((mul_zero 0).symm),
  this.elim hn0 hn0

theorem irreducible.ne_zero [monoid_with_zero α] : ∀ {p:α}, irreducible p → p ≠ 0
| _ hp rfl := not_irreducible_zero hp

theorem of_irreducible_mul {α} [monoid α] {x y : α} :
  irreducible (x * y) → is_unit x ∨ is_unit y
| ⟨_, h⟩ := h _ _ rfl

theorem of_irreducible_pow {α} [monoid α] {x : α} {n : ℕ} (hn : n ≠ 1) :
  irreducible (x ^ n) → is_unit x :=
begin
  obtain hn|hn := hn.lt_or_lt,
  { simp only [nat.lt_one_iff.mp hn, forall_false_left, not_irreducible_one, pow_zero] },
  intro h,
  obtain ⟨k, rfl⟩ := nat.exists_eq_add_of_lt hn,
  rw [pow_succ, add_comm] at h,
  exact (or_iff_left_of_imp ((is_unit_pos_pow_iff (nat.succ_pos _)).mp)).mp (of_irreducible_mul h)
end

theorem irreducible_or_factor {α} [monoid α] (x : α) (h : ¬ is_unit x) :
  irreducible x ∨ ∃ a b, ¬ is_unit a ∧ ¬ is_unit b ∧ a * b = x :=
begin
  haveI := classical.dec,
  refine or_iff_not_imp_right.2 (λ H, _),
  simp [h, irreducible_iff] at H ⊢,
  refine λ a b h, classical.by_contradiction $ λ o, _,
  simp [not_or_distrib] at o,
  exact H _ o.1 _ o.2 h.symm
end

protected lemma prime.irreducible [cancel_comm_monoid_with_zero α] {p : α} (hp : prime p) :
  irreducible p :=
⟨hp.not_unit, λ a b hab,
  (show a * b ∣ a ∨ a * b ∣ b, from hab ▸ hp.dvd_or_dvd (hab ▸ dvd_rfl)).elim
    (λ ⟨x, hx⟩, or.inr (is_unit_iff_dvd_one.2
      ⟨x, mul_right_cancel₀ (show a ≠ 0, from λ h, by simp [*, prime] at *)
        $ by conv {to_lhs, rw hx}; simp [mul_comm, mul_assoc, mul_left_comm]⟩))
    (λ ⟨x, hx⟩, or.inl (is_unit_iff_dvd_one.2
      ⟨x, mul_right_cancel₀ (show b ≠ 0, from λ h, by simp [*, prime] at *)
        $ by conv {to_lhs, rw hx}; simp [mul_comm, mul_assoc, mul_left_comm]⟩))⟩

lemma succ_dvd_or_succ_dvd_of_succ_sum_dvd_mul [cancel_comm_monoid_with_zero α]
  {p : α} (hp : prime p) {a b : α} {k l : ℕ} :
  p ^ k ∣ a → p ^ l ∣ b → p ^ ((k + l) + 1) ∣ a * b → p ^ (k + 1) ∣ a ∨ p ^ (l + 1) ∣ b :=
λ ⟨x, hx⟩ ⟨y, hy⟩ ⟨z, hz⟩,
have h : p ^ (k + l) * (x * y) = p ^ (k + l) * (p * z),
  by simpa [mul_comm, pow_add, hx, hy, mul_assoc, mul_left_comm] using hz,
have hp0: p ^ (k + l) ≠ 0, from pow_ne_zero _ hp.ne_zero,
have hpd : p ∣ x * y, from ⟨z, by rwa [mul_right_inj' hp0] at h⟩,
(hp.dvd_or_dvd hpd).elim
  (λ ⟨d, hd⟩, or.inl ⟨d, by simp [*, pow_succ, mul_comm, mul_left_comm, mul_assoc]⟩)
  (λ ⟨d, hd⟩, or.inr ⟨d, by simp [*, pow_succ, mul_comm, mul_left_comm, mul_assoc]⟩)

/-- If `p` and `q` are irreducible, then `p ∣ q` implies `q ∣ p`. -/
lemma irreducible.dvd_symm [monoid α] {p q : α}
  (hp : irreducible p) (hq : irreducible q) : p ∣ q → q ∣ p :=
begin
  unfreezingI { rintros ⟨q', rfl⟩ },
  rw is_unit.mul_right_dvd (or.resolve_left (of_irreducible_mul hq) hp.not_unit),
end

lemma irreducible.dvd_comm [monoid α] {p q : α}
  (hp : irreducible p) (hq : irreducible q) : p ∣ q ↔ q ∣ p :=
⟨hp.dvd_symm hq, hq.dvd_symm hp⟩

section
variables [monoid α]

lemma irreducible_units_mul (a : αˣ) (b : α) : irreducible (↑a * b) ↔ irreducible b :=
begin
  simp only [irreducible_iff, units.is_unit_units_mul, and.congr_right_iff],
  refine λ hu, ⟨λ h A B HAB, _, λ h A B HAB, _⟩,
  { rw [←a.is_unit_units_mul],
    apply h,
    rw [mul_assoc, ←HAB] },
  { rw [←(a⁻¹).is_unit_units_mul],
    apply h,
    rw [mul_assoc, ←HAB, units.inv_mul_cancel_left] },
end

lemma irreducible_is_unit_mul {a b : α} (h : is_unit a) : irreducible (a * b) ↔ irreducible b :=
let ⟨a, ha⟩ := h in ha ▸ irreducible_units_mul a b

lemma irreducible_mul_units (a : αˣ) (b : α) : irreducible (b * ↑a) ↔ irreducible b :=
begin
  simp only [irreducible_iff, units.is_unit_mul_units, and.congr_right_iff],
  refine λ hu, ⟨λ h A B HAB, _, λ h A B HAB, _⟩,
  { rw [←units.is_unit_mul_units B a],
    apply h,
    rw [←mul_assoc, ←HAB] },
  { rw [←units.is_unit_mul_units B a⁻¹],
    apply h,
    rw [←mul_assoc, ←HAB, units.mul_inv_cancel_right] },
end

lemma irreducible_mul_is_unit {a b : α} (h : is_unit a) : irreducible (b * a) ↔ irreducible b :=
let ⟨a, ha⟩ := h in ha ▸ irreducible_mul_units a b

lemma irreducible_mul_iff {a b : α} :
  irreducible (a * b) ↔ (irreducible a ∧ is_unit b) ∨ (irreducible b ∧ is_unit a) :=
begin
  split,
  { refine λ h, or.imp (λ h', ⟨_, h'⟩) (λ h', ⟨_, h'⟩) (h.is_unit_or_is_unit rfl).symm,
    { rwa [irreducible_mul_is_unit h'] at h },
    { rwa [irreducible_is_unit_mul h'] at h } },
  { rintros (⟨ha, hb⟩|⟨hb, ha⟩),
    { rwa [irreducible_mul_is_unit hb] },
    { rwa [irreducible_is_unit_mul ha] } },
end

end

lemma pow_not_prime [cancel_comm_monoid_with_zero α] {x : α} {n : ℕ} (hn : n ≠ 1) :
  ¬ prime (x ^ n) :=
λ hp, hp.not_unit $ is_unit.pow _ $ of_irreducible_pow hn $ hp.irreducible

/-- Two elements of a `monoid` are `associated` if one of them is another one
multiplied by a unit on the right. -/
def associated [monoid α] (x y : α) : Prop := ∃u:αˣ, x * u = y

local infix ` ~ᵤ ` : 50 := associated

namespace associated

@[refl] protected theorem refl [monoid α] (x : α) : x ~ᵤ x := ⟨1, by simp⟩

@[symm] protected theorem symm [monoid α] : ∀{x y : α}, x ~ᵤ y → y ~ᵤ x
| x _ ⟨u, rfl⟩ := ⟨u⁻¹, by rw [mul_assoc, units.mul_inv, mul_one]⟩

@[trans] protected theorem trans [monoid α] : ∀{x y z : α}, x ~ᵤ y → y ~ᵤ z → x ~ᵤ z
| x _ _ ⟨u, rfl⟩ ⟨v, rfl⟩ := ⟨u * v, by rw [units.coe_mul, mul_assoc]⟩

/-- The setoid of the relation `x ~ᵤ y` iff there is a unit `u` such that `x * u = y` -/
protected def setoid (α : Type*) [monoid α] : setoid α :=
{ r := associated, iseqv := ⟨associated.refl, λa b, associated.symm, λa b c, associated.trans⟩ }

end associated

local attribute [instance] associated.setoid

theorem unit_associated_one [monoid α] {u : αˣ} : (u : α) ~ᵤ 1 := ⟨u⁻¹, units.mul_inv u⟩

theorem associated_one_iff_is_unit [monoid α] {a : α} : (a : α) ~ᵤ 1 ↔ is_unit a :=
iff.intro
  (assume h, let ⟨c, h⟩ := h.symm in h ▸ ⟨c, (one_mul _).symm⟩)
  (assume ⟨c, h⟩, associated.symm ⟨c, by simp [h]⟩)

theorem associated_zero_iff_eq_zero [monoid_with_zero α] (a : α) : a ~ᵤ 0 ↔ a = 0 :=
iff.intro
  (assume h, let ⟨u, h⟩ := h.symm in by simpa using h.symm)
  (assume h, h ▸ associated.refl a)

theorem associated_one_of_mul_eq_one [comm_monoid α] {a : α} (b : α) (hab : a * b = 1) : a ~ᵤ 1 :=
show (units.mk_of_mul_eq_one a b hab : α) ~ᵤ 1, from unit_associated_one

theorem associated_one_of_associated_mul_one [comm_monoid α] {a b : α} :
  a * b ~ᵤ 1 → a ~ᵤ 1
| ⟨u, h⟩ := associated_one_of_mul_eq_one (b * u) $ by simpa [mul_assoc] using h

lemma associated_mul_unit_left {β : Type*} [monoid β] (a u : β) (hu : is_unit u) :
  associated (a * u) a :=
let ⟨u', hu⟩ := hu in ⟨u'⁻¹, hu ▸ units.mul_inv_cancel_right _ _⟩

lemma associated_unit_mul_left {β : Type*} [comm_monoid β] (a u : β) (hu : is_unit u) :
  associated (u * a) a :=
begin
  rw mul_comm,
  exact associated_mul_unit_left _ _ hu
end

lemma associated_mul_unit_right {β : Type*} [monoid β] (a u : β) (hu : is_unit u) :
  associated a (a * u) :=
(associated_mul_unit_left a u hu).symm

lemma associated_unit_mul_right {β : Type*} [comm_monoid β] (a u : β) (hu : is_unit u) :
  associated a (u * a) :=
(associated_unit_mul_left a u hu).symm

lemma associated.mul_mul [comm_monoid α] {a₁ a₂ b₁ b₂ : α} :
  a₁ ~ᵤ b₁ → a₂ ~ᵤ b₂ → (a₁ * a₂) ~ᵤ (b₁ * b₂)
| ⟨c₁, h₁⟩ ⟨c₂, h₂⟩ := ⟨c₁ * c₂, by simp [h₁.symm, h₂.symm, mul_assoc, mul_comm, mul_left_comm]⟩

lemma associated.mul_left [comm_monoid α] (a : α) {b c : α} (h : b ~ᵤ c) :
  (a * b) ~ᵤ (a * c) :=
(associated.refl a).mul_mul h

lemma associated.mul_right [comm_monoid α] {a b : α} (h : a ~ᵤ b) (c : α) :
  (a * c) ~ᵤ (b * c) :=
h.mul_mul (associated.refl c)

lemma associated.pow_pow [comm_monoid α] {a b : α} {n : ℕ} (h : a ~ᵤ b) :
  a ^ n ~ᵤ b ^ n :=
begin
  induction n with n ih, { simp [h] },
  convert h.mul_mul ih;
    rw pow_succ
end

protected lemma associated.dvd [monoid α] {a b : α} : a ~ᵤ b → a ∣ b := λ ⟨u, hu⟩, ⟨u, hu.symm⟩

protected lemma associated.dvd_dvd [monoid α] {a b : α} (h : a ~ᵤ b) : a ∣ b ∧ b ∣ a :=
⟨h.dvd, h.symm.dvd⟩

theorem associated_of_dvd_dvd [cancel_monoid_with_zero α]
  {a b : α} (hab : a ∣ b) (hba : b ∣ a) : a ~ᵤ b :=
begin
  rcases hab with ⟨c, rfl⟩,
  rcases hba with ⟨d, a_eq⟩,
  by_cases ha0 : a = 0,
  { simp [*] at * },
  have hac0 : a * c ≠ 0,
  { intro con, rw [con, zero_mul] at a_eq, apply ha0 a_eq, },
  have : a * (c * d) =  a * 1 := by rw [← mul_assoc, ← a_eq, mul_one],
  have hcd : (c * d) = 1, from mul_left_cancel₀ ha0 this,
  have : a * c * (d * c) = a * c * 1 := by rw [← mul_assoc, ← a_eq, mul_one],
  have hdc : d * c = 1, from mul_left_cancel₀ hac0 this,
  exact ⟨⟨c, d, hcd, hdc⟩, rfl⟩
end

theorem dvd_dvd_iff_associated [cancel_monoid_with_zero α] {a b : α} : a ∣ b ∧ b ∣ a ↔ a ~ᵤ b :=
⟨λ ⟨h1, h2⟩, associated_of_dvd_dvd h1 h2, associated.dvd_dvd⟩

instance [cancel_monoid_with_zero α] [decidable_rel ((∣) : α → α → Prop)] :
  decidable_rel ((~ᵤ) : α → α → Prop) :=
λ a b, decidable_of_iff _ dvd_dvd_iff_associated

lemma associated.dvd_iff_dvd_left [monoid α] {a b c : α} (h : a ~ᵤ b) : a ∣ c ↔ b ∣ c :=
let ⟨u, hu⟩ := h in hu ▸ units.mul_right_dvd.symm

lemma associated.dvd_iff_dvd_right [monoid α] {a b c : α} (h : b ~ᵤ c) : a ∣ b ↔ a ∣ c :=
let ⟨u, hu⟩ := h in hu ▸ units.dvd_mul_right.symm

lemma associated.eq_zero_iff [monoid_with_zero α] {a b : α} (h : a ~ᵤ b) : a = 0 ↔ b = 0 :=
⟨λ ha, let ⟨u, hu⟩ := h in by simp [hu.symm, ha],
  λ hb, let ⟨u, hu⟩ := h.symm in by simp [hu.symm, hb]⟩

lemma associated.ne_zero_iff [monoid_with_zero α] {a b : α} (h : a ~ᵤ b) : a ≠ 0 ↔ b ≠ 0 :=
not_congr h.eq_zero_iff

protected lemma associated.prime [comm_monoid_with_zero α] {p q : α} (h : p ~ᵤ q) (hp : prime p) :
  prime q :=
⟨h.ne_zero_iff.1 hp.ne_zero,
  let ⟨u, hu⟩ := h in
    ⟨λ ⟨v, hv⟩, hp.not_unit ⟨v * u⁻¹, by simp [hv, hu.symm]⟩,
      hu ▸ by { simp [units.mul_right_dvd], intros a b, exact hp.dvd_or_dvd }⟩⟩

lemma irreducible.associated_of_dvd [cancel_monoid_with_zero α] {p q : α}
  (p_irr : irreducible p) (q_irr : irreducible q) (dvd : p ∣ q) : associated p q :=
associated_of_dvd_dvd dvd (p_irr.dvd_symm q_irr dvd)

lemma irreducible.dvd_irreducible_iff_associated [cancel_monoid_with_zero α]
  {p q : α} (pp : irreducible p) (qp : irreducible q) :
  p ∣ q ↔ associated p q :=
⟨irreducible.associated_of_dvd pp qp, associated.dvd⟩

lemma prime.associated_of_dvd [cancel_comm_monoid_with_zero α] {p q : α}
  (p_prime : prime p) (q_prime : prime q) (dvd : p ∣ q) : associated p q :=
p_prime.irreducible.associated_of_dvd q_prime.irreducible dvd

theorem prime.dvd_prime_iff_associated [cancel_comm_monoid_with_zero α]
  {p q : α} (pp : prime p) (qp : prime q) :
  p ∣ q ↔ associated p q :=
pp.irreducible.dvd_irreducible_iff_associated qp.irreducible
lemma associated.prime_iff [comm_monoid_with_zero α] {p q : α}
  (h : p ~ᵤ q) : prime p ↔ prime q :=
⟨h.prime, h.symm.prime⟩

protected lemma associated.is_unit [monoid α] {a b : α} (h :  a ~ᵤ b) : is_unit a → is_unit b :=
let ⟨u, hu⟩ := h in λ ⟨v, hv⟩, ⟨v * u, by simp [hv, hu.symm]⟩

lemma associated.is_unit_iff [monoid α] {a b : α} (h :  a ~ᵤ b) : is_unit a ↔ is_unit b :=
⟨h.is_unit, h.symm.is_unit⟩

protected lemma associated.irreducible [monoid α] {p q : α} (h : p ~ᵤ q)
  (hp : irreducible p) : irreducible q :=
⟨mt h.symm.is_unit hp.1,
  let ⟨u, hu⟩ := h in λ a b hab,
  have hpab : p = a * (b * (u⁻¹ : αˣ)),
    from calc p = (p * u) * (u ⁻¹ : αˣ) : by simp
      ... = _ : by rw hu; simp [hab, mul_assoc],
  (hp.is_unit_or_is_unit hpab).elim or.inl (λ ⟨v, hv⟩, or.inr ⟨v * u, by simp [hv]⟩)⟩

protected lemma associated.irreducible_iff [monoid α] {p q : α} (h : p ~ᵤ q) :
  irreducible p ↔ irreducible q :=
⟨h.irreducible, h.symm.irreducible⟩

lemma associated.of_mul_left [cancel_comm_monoid_with_zero α] {a b c d : α}
  (h : a * b ~ᵤ c * d) (h₁ : a ~ᵤ c) (ha : a ≠ 0) : b ~ᵤ d :=
let ⟨u, hu⟩ := h in let ⟨v, hv⟩ := associated.symm h₁ in
⟨u * (v : αˣ), mul_left_cancel₀ ha
  begin
    rw [← hv, mul_assoc c (v : α) d, mul_left_comm c, ← hu],
    simp [hv.symm, mul_assoc, mul_comm, mul_left_comm]
  end⟩

lemma associated.of_mul_right [cancel_comm_monoid_with_zero α] {a b c d : α} :
  a * b ~ᵤ c * d → b ~ᵤ d → b ≠ 0 → a ~ᵤ c :=
by rw [mul_comm a, mul_comm c]; exact associated.of_mul_left

lemma associated.of_pow_associated_of_prime [cancel_comm_monoid_with_zero α] {p₁ p₂ : α}
  {k₁ k₂ : ℕ} (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₁ : 0 < k₁) (h : p₁ ^ k₁ ~ᵤ p₂ ^ k₂) :
  p₁ ~ᵤ p₂ :=
begin
  have : p₁ ∣ p₂ ^ k₂,
  { rw ←h.dvd_iff_dvd_right,
    apply dvd_pow_self _ hk₁.ne' },
  rw ←hp₁.dvd_prime_iff_associated hp₂,
  exact hp₁.dvd_of_dvd_pow this,
end

lemma associated.of_pow_associated_of_prime' [cancel_comm_monoid_with_zero α] {p₁ p₂ : α}
  {k₁ k₂ : ℕ} (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₂ : 0 < k₂) (h : p₁ ^ k₁ ~ᵤ p₂ ^ k₂) :
  p₁ ~ᵤ p₂ :=
(h.symm.of_pow_associated_of_prime hp₂ hp₁ hk₂).symm

section unique_units
variables [monoid α] [unique αˣ]

lemma units_eq_one (u : αˣ) : u = 1 := subsingleton.elim u 1

theorem associated_iff_eq {x y : α} : x ~ᵤ y ↔ x = y :=
begin
  split,
  { rintro ⟨c, rfl⟩, rw [units_eq_one c, units.coe_one, mul_one] },
  { rintro rfl, refl },
end

theorem associated_eq_eq : (associated : α → α → Prop) = eq :=
by { ext, rw associated_iff_eq }

lemma prime_dvd_prime_iff_eq
  {M : Type*} [cancel_comm_monoid_with_zero M] [unique Mˣ] {p q : M} (pp : prime p) (qp : prime q) :
  p ∣ q ↔ p = q :=
by rw [pp.dvd_prime_iff_associated qp, ←associated_eq_eq]

end unique_units

/-- The quotient of a monoid by the `associated` relation. Two elements `x` and `y`
  are associated iff there is a unit `u` such that `x * u = y`. There is a natural
  monoid structure on `associates α`. -/
def associates (α : Type*) [monoid α] : Type* :=
quotient (associated.setoid α)

namespace associates
open associated

/-- The canonical quotient map from a monoid `α` into the `associates` of `α` -/
protected def mk {α : Type*} [monoid α] (a : α) : associates α :=
⟦ a ⟧

instance [monoid α] : inhabited (associates α) := ⟨⟦1⟧⟩

theorem mk_eq_mk_iff_associated [monoid α] {a b : α} :
  associates.mk a = associates.mk b ↔ a ~ᵤ b :=
iff.intro quotient.exact quot.sound

theorem quotient_mk_eq_mk [monoid α] (a : α) : ⟦ a ⟧ = associates.mk a := rfl

theorem quot_mk_eq_mk [monoid α] (a : α) : quot.mk setoid.r a = associates.mk a := rfl

theorem forall_associated [monoid α] {p : associates α → Prop} :
  (∀a, p a) ↔ (∀a, p (associates.mk a)) :=
iff.intro
  (assume h a, h _)
  (assume h a, quotient.induction_on a h)

theorem mk_surjective [monoid α] : function.surjective (@associates.mk α _) :=
forall_associated.2 (λ a, ⟨a, rfl⟩)

instance [monoid α] : has_one (associates α) := ⟨⟦ 1 ⟧⟩

@[simp] lemma mk_one [monoid α] : associates.mk (1 : α) = 1 := rfl

theorem one_eq_mk_one [monoid α] : (1 : associates α) = associates.mk 1 := rfl

instance [monoid α] : has_bot (associates α) := ⟨1⟩

lemma bot_eq_one [monoid α] : (⊥ : associates α) = 1 := rfl

lemma exists_rep [monoid α] (a : associates α) : ∃ a0 : α, associates.mk a0 = a :=
quot.exists_rep a

instance [monoid α] [subsingleton α] : unique (associates α) :=
{ default := 1,
  uniq := λ a, by { apply quotient.rec_on_subsingleton₂, intros a b, congr } }

lemma mk_injective [monoid α] [unique (units α)] : function.injective (@associates.mk α _) :=
λ a b h, associated_iff_eq.mp (associates.mk_eq_mk_iff_associated.mp h)

section comm_monoid
variable [comm_monoid α]

instance : has_mul (associates α) :=
⟨λa' b', quotient.lift_on₂ a' b' (λa b, ⟦ a * b ⟧) $
  assume a₁ a₂ b₁ b₂ ⟨c₁, h₁⟩ ⟨c₂, h₂⟩,
  quotient.sound $ ⟨c₁ * c₂, by simp [h₁.symm, h₂.symm, mul_assoc, mul_comm, mul_left_comm]⟩⟩

theorem mk_mul_mk {x y : α} : associates.mk x * associates.mk y = associates.mk (x * y) :=
rfl

instance : comm_monoid (associates α) :=
{ one       := 1,
  mul       := (*),
  mul_one   := assume a', quotient.induction_on a' $
    assume a, show ⟦a * 1⟧ = ⟦ a ⟧, by simp,
  one_mul   := assume a', quotient.induction_on a' $
    assume a, show ⟦1 * a⟧ = ⟦ a ⟧, by simp,
  mul_assoc := assume a' b' c', quotient.induction_on₃ a' b' c' $
    assume a b c, show ⟦a * b * c⟧ = ⟦a * (b * c)⟧, by rw [mul_assoc],
  mul_comm  := assume a' b', quotient.induction_on₂ a' b' $
    assume a b, show ⟦a * b⟧ = ⟦b * a⟧, by rw [mul_comm] }

instance : preorder (associates α) :=
{ le := has_dvd.dvd,
  le_refl := dvd_refl,
  le_trans := λ a b c, dvd_trans}

/-- `associates.mk` as a `monoid_hom`. -/
protected def mk_monoid_hom : α →* (associates α) := ⟨associates.mk, mk_one, λ x y, mk_mul_mk⟩

@[simp] lemma mk_monoid_hom_apply (a : α) : associates.mk_monoid_hom a = associates.mk a := rfl

lemma associated_map_mk {f : associates α →* α}
  (hinv : function.right_inverse f associates.mk) (a : α) :
  a ~ᵤ f (associates.mk a) :=
associates.mk_eq_mk_iff_associated.1 (hinv (associates.mk a)).symm

lemma mk_pow (a : α) (n : ℕ) : associates.mk (a ^ n) = (associates.mk a) ^ n :=
by induction n; simp [*, pow_succ, associates.mk_mul_mk.symm]

lemma dvd_eq_le : ((∣) : associates α → associates α → Prop) = (≤) := rfl

theorem mul_eq_one_iff {x y : associates α} : x * y = 1 ↔ (x = 1 ∧ y = 1) :=
iff.intro
  (quotient.induction_on₂ x y $ assume a b h,
    have a * b ~ᵤ 1, from quotient.exact h,
    ⟨quotient.sound $ associated_one_of_associated_mul_one this,
      quotient.sound $ associated_one_of_associated_mul_one $ by rwa [mul_comm] at this⟩)
  (by simp {contextual := tt})

theorem units_eq_one (u : (associates α)ˣ) : u = 1 :=
units.ext (mul_eq_one_iff.1 u.val_inv).1

instance unique_units : unique ((associates α)ˣ) :=
{ default := 1, uniq := associates.units_eq_one }

theorem coe_unit_eq_one (u : (associates α)ˣ): (u : associates α) = 1 :=
by simp

theorem is_unit_iff_eq_one (a : associates α) : is_unit a ↔ a = 1 :=
iff.intro
  (assume ⟨u, h⟩, h ▸ coe_unit_eq_one _)
  (assume h, h.symm ▸ is_unit_one)

lemma is_unit_iff_eq_bot {a : associates α} : is_unit a ↔ a = ⊥ :=
by rw [associates.is_unit_iff_eq_one, bot_eq_one]

theorem is_unit_mk {a : α} : is_unit (associates.mk a) ↔ is_unit a :=
calc is_unit (associates.mk a) ↔ a ~ᵤ 1 :
    by rw [is_unit_iff_eq_one, one_eq_mk_one, mk_eq_mk_iff_associated]
  ... ↔ is_unit a : associated_one_iff_is_unit

section order

theorem mul_mono {a b c d : associates α} (h₁ : a ≤ b) (h₂ : c ≤ d) :
  a * c ≤ b * d :=
let ⟨x, hx⟩ := h₁, ⟨y, hy⟩ := h₂ in
⟨x * y, by simp [hx, hy, mul_comm, mul_assoc, mul_left_comm]⟩

theorem one_le {a : associates α} : 1 ≤ a :=
dvd.intro _ (one_mul a)

theorem le_mul_right {a b : associates α} : a ≤ a * b := ⟨b, rfl⟩

theorem le_mul_left {a b : associates α} : a ≤ b * a :=
by rw [mul_comm]; exact le_mul_right

instance : order_bot (associates α) :=
{ bot := 1,
  bot_le := assume a, one_le }

end order

theorem dvd_of_mk_le_mk {a b : α} : associates.mk a ≤ associates.mk b → a ∣ b
| ⟨c', hc'⟩ := (quotient.induction_on c' $ assume c hc,
    let ⟨d, hd⟩ := (quotient.exact hc).symm in
    ⟨(↑d) * c,
      calc b = (a * c) * ↑d : hd.symm
        ... = a * (↑d * c) : by ac_refl⟩) hc'

theorem mk_le_mk_of_dvd {a b : α} : a ∣ b → associates.mk a ≤ associates.mk b :=
assume ⟨c, hc⟩, ⟨associates.mk c, by simp [hc]; refl⟩

theorem mk_le_mk_iff_dvd_iff {a b : α} : associates.mk a ≤ associates.mk b ↔ a ∣ b :=
iff.intro dvd_of_mk_le_mk mk_le_mk_of_dvd

theorem mk_dvd_mk {a b : α} : associates.mk a ∣ associates.mk b ↔ a ∣ b :=
iff.intro dvd_of_mk_le_mk mk_le_mk_of_dvd

end comm_monoid

instance [has_zero α] [monoid α] : has_zero (associates α) := ⟨⟦ 0 ⟧⟩
instance [has_zero α] [monoid α] : has_top (associates α) := ⟨0⟩

section monoid_with_zero
variables [monoid_with_zero α]

@[simp] theorem mk_eq_zero {a : α} : associates.mk a = 0 ↔ a = 0 :=
⟨assume h, (associated_zero_iff_eq_zero a).1 $ quotient.exact h, assume h, h.symm ▸ rfl⟩

theorem mk_ne_zero {a : α} : associates.mk a ≠ 0 ↔ a ≠ 0 :=
not_congr mk_eq_zero

instance [nontrivial α] : nontrivial (associates α) :=
⟨⟨0, 1,
assume h,
have (0 : α) ~ᵤ 1, from quotient.exact h,
have (0 : α) = 1, from ((associated_zero_iff_eq_zero 1).1 this.symm).symm,
zero_ne_one this⟩⟩

lemma exists_non_zero_rep {a : associates α} : a ≠ 0 → ∃ a0 : α, a0 ≠ 0 ∧ associates.mk a0 = a :=
quotient.induction_on a (λ b nz, ⟨b, mt (congr_arg quotient.mk) nz, rfl⟩)

end monoid_with_zero

section comm_monoid_with_zero

variables [comm_monoid_with_zero α]

instance : comm_monoid_with_zero (associates α) :=
{ zero_mul := by { rintro ⟨a⟩, show associates.mk (0 * a) = associates.mk 0, rw [zero_mul] },
  mul_zero := by { rintro ⟨a⟩, show associates.mk (a * 0) = associates.mk 0, rw [mul_zero] },
  .. associates.comm_monoid, .. associates.has_zero }

instance : order_top (associates α) :=
{ top := 0,
  le_top := assume a, ⟨0, (mul_zero a).symm⟩ }

instance : bounded_order (associates α) :=
{ .. associates.order_top,
  .. associates.order_bot }

instance [decidable_rel ((∣) : α → α → Prop)] :
  decidable_rel ((∣) : associates α → associates α → Prop) :=
λ a b, quotient.rec_on_subsingleton₂ a b (λ a b, decidable_of_iff' _ mk_dvd_mk)

lemma prime.le_or_le {p : associates α} (hp : prime p) {a b : associates α} (h : p ≤ a * b) :
  p ≤ a ∨ p ≤ b :=
hp.2.2 a b h

lemma prime_mk (p : α) : prime (associates.mk p) ↔ _root_.prime p :=
begin
  rw [prime, _root_.prime, forall_associated],
  transitivity,
  { apply and_congr, refl,
    apply and_congr, refl,
    apply forall_congr, assume a,
    exact forall_associated },
  apply and_congr mk_ne_zero,
  apply and_congr,
  { rw [is_unit_mk], },
  refine forall₂_congr (λ a b, _),
  rw [mk_mul_mk, mk_dvd_mk, mk_dvd_mk, mk_dvd_mk],
end

theorem irreducible_mk (a : α) : irreducible (associates.mk a) ↔ irreducible a :=
begin
  simp only [irreducible_iff, is_unit_mk],
  apply and_congr iff.rfl,
  split,
  { rintro h x y rfl,
    simpa [is_unit_mk] using h (associates.mk x) (associates.mk y) rfl },
  { intros h x y,
    refine quotient.induction_on₂ x y (assume x y a_eq, _),
    rcases quotient.exact a_eq.symm with ⟨u, a_eq⟩,
    rw mul_assoc at a_eq,
    show is_unit (associates.mk x) ∨ is_unit (associates.mk y),
    simpa [is_unit_mk] using h _ _ a_eq.symm }
end

theorem mk_dvd_not_unit_mk_iff {a b : α} :
  dvd_not_unit (associates.mk a) (associates.mk b) ↔
  dvd_not_unit a b :=
begin
  rw [dvd_not_unit, dvd_not_unit, mk_ne_zero],
  apply and_congr_right, intro ane0,
  split,
  { contrapose!, rw forall_associated,
    intros h x hx hbax,
    rw [mk_mul_mk, mk_eq_mk_iff_associated] at hbax,
    cases hbax with u hu,
    apply h (x * ↑u⁻¹),
    { rw is_unit_mk at hx,
      rw associated.is_unit_iff,
      apply hx,
      use u,
      simp, },
    simp [← mul_assoc, ← hu] },
  { rintro ⟨x, ⟨hx, rfl⟩⟩,
    use associates.mk x,
    simp [is_unit_mk, mk_mul_mk, hx], }
end

theorem dvd_not_unit_of_lt {a b : associates α} (hlt : a < b) :
  dvd_not_unit a b :=
begin
  split, { rintro rfl, apply not_lt_of_le _ hlt, apply dvd_zero },
  rcases hlt with ⟨⟨x, rfl⟩, ndvd⟩,
  refine ⟨x, _, rfl⟩,
  contrapose! ndvd,
  rcases ndvd with ⟨u, rfl⟩,
  simp,
end

theorem irreducible_iff_prime_iff :
  (∀ a : α, irreducible a ↔ prime a) ↔ (∀ a : (associates α), irreducible a ↔ prime a) :=
begin
  rw forall_associated, split;
  intros h a; have ha := h a; rw irreducible_mk at *; rw prime_mk at *; exact ha,
end

end comm_monoid_with_zero

section cancel_comm_monoid_with_zero
variable [cancel_comm_monoid_with_zero α]

instance : partial_order (associates α) :=
{ le_antisymm := λ a' b', quotient.induction_on₂ a' b' (λ a b hab hba,
  quot.sound $ associated_of_dvd_dvd (dvd_of_mk_le_mk hab) (dvd_of_mk_le_mk hba))
  .. associates.preorder }

instance : ordered_comm_monoid (associates α) :=
{ mul_le_mul_left := λ a b ⟨d, hd⟩ c, hd.symm ▸ mul_assoc c a d ▸ le_mul_right,
  ..associates.comm_monoid,
  ..associates.partial_order}

instance : no_zero_divisors (associates α) :=
⟨λ x y,
  (quotient.induction_on₂ x y $ assume a b h,
    have a * b = 0, from (associated_zero_iff_eq_zero _).1 (quotient.exact h),
    have a = 0 ∨ b = 0, from mul_eq_zero.1 this,
    this.imp (assume h, h.symm ▸ rfl) (assume h, h.symm ▸ rfl))⟩

lemma eq_of_mul_eq_mul_left :
  ∀(a b c : associates α), a ≠ 0 → a * b = a * c → b = c :=
begin
  rintros ⟨a⟩ ⟨b⟩ ⟨c⟩ ha h,
  rcases quotient.exact' h with ⟨u, hu⟩,
  have hu : a * (b * ↑u) = a * c, { rwa [← mul_assoc] },
  exact quotient.sound' ⟨u, mul_left_cancel₀ (mk_ne_zero.1 ha) hu⟩
end

lemma eq_of_mul_eq_mul_right :
  ∀(a b c : associates α), b ≠ 0 → a * b = c * b → a = c :=
λ a b c bne0, (mul_comm b a) ▸ (mul_comm b c) ▸ (eq_of_mul_eq_mul_left b a c bne0)

lemma le_of_mul_le_mul_left (a b c : associates α) (ha : a ≠ 0) :
  a * b ≤ a * c → b ≤ c
| ⟨d, hd⟩ := ⟨d, eq_of_mul_eq_mul_left a _ _ ha $ by rwa ← mul_assoc⟩

lemma one_or_eq_of_le_of_prime :
  ∀(p m : associates α), prime p → m ≤ p → (m = 1 ∨ m = p)
| _ m ⟨hp0, hp1, h⟩ ⟨d, rfl⟩ :=
match h m d dvd_rfl with
| or.inl h := classical.by_cases (assume : m = 0, by simp [this]) $
  assume : m ≠ 0,
  have m * d ≤ m * 1, by simpa using h,
  have d ≤ 1, from associates.le_of_mul_le_mul_left m d 1 ‹m ≠ 0› this,
  have d = 1, from bot_unique this,
  by simp [this]
| or.inr h := classical.by_cases (assume : d = 0, by simp [this] at hp0; contradiction) $
  assume : d ≠ 0,
  have d * m ≤ d * 1, by simpa [mul_comm] using h,
  or.inl $ bot_unique $ associates.le_of_mul_le_mul_left d m 1 ‹d ≠ 0› this
end

instance : cancel_comm_monoid_with_zero (associates α) :=
{ mul_left_cancel_of_ne_zero := eq_of_mul_eq_mul_left,
  mul_right_cancel_of_ne_zero := eq_of_mul_eq_mul_right,
  .. (infer_instance : comm_monoid_with_zero (associates α)) }

instance : canonically_ordered_monoid (associates α) :=
{ le_iff_exists_mul := λ a b, iff.rfl,
  ..associates.cancel_comm_monoid_with_zero,
  ..associates.bounded_order,
  ..associates.ordered_comm_monoid}

theorem dvd_not_unit_iff_lt {a b : associates α} :
  dvd_not_unit a b ↔ a < b :=
dvd_and_not_dvd_iff.symm

end cancel_comm_monoid_with_zero

end associates

section comm_monoid_with_zero

lemma dvd_not_unit.is_unit_of_irreducible_right [comm_monoid_with_zero α] {p q : α}
  (h : dvd_not_unit p q) (hq : irreducible q) : is_unit p :=
begin
  obtain ⟨hp', x, hx, hx'⟩ := h,
  exact or.resolve_right ((irreducible_iff.1 hq).right p x hx') hx
end

lemma not_irreducible_of_not_unit_dvd_not_unit [comm_monoid_with_zero α] {p q : α}
  (hp : ¬is_unit p) (h : dvd_not_unit p q) : ¬ irreducible q :=
mt h.is_unit_of_irreducible_right hp

lemma dvd_not_unit.not_unit [comm_monoid_with_zero α] {p q : α}
  (hp : dvd_not_unit p q) : ¬ is_unit q :=
begin
  obtain ⟨-, x, hx, rfl⟩ := hp,
  exact λ hc, hx (is_unit_iff_dvd_one.mpr (dvd_of_mul_left_dvd (is_unit_iff_dvd_one.mp hc))),
end

lemma dvd_not_unit_of_dvd_not_unit_associated [comm_monoid_with_zero α]
  [nontrivial α] {p q r : α} (h : dvd_not_unit p q) (h' : associated q r) : dvd_not_unit p r :=
begin
  obtain ⟨u, rfl⟩ := associated.symm h',
  obtain ⟨hp, x, hx⟩ := h,
  refine ⟨hp, x * ↑(u⁻¹), dvd_not_unit.not_unit ⟨u⁻¹.ne_zero, x, hx.left, mul_comm _ _⟩, _⟩,
  rw [← mul_assoc, ← hx.right, mul_assoc, units.mul_inv, mul_one]
end

end comm_monoid_with_zero

section cancel_comm_monoid_with_zero

lemma is_unit_of_associated_mul [cancel_comm_monoid_with_zero α]
  {p b : α} (h : associated (p * b) p) (hp : p ≠ 0) : is_unit b :=
begin
  cases h with a ha,
  refine is_unit_of_mul_eq_one b a ((mul_right_inj' hp).mp _),
  rwa [← mul_assoc, mul_one],
end

lemma associates.is_atom_iff [cancel_comm_monoid_with_zero α] {p : associates α} (h₁ : p ≠ 0) :
  is_atom p ↔ irreducible p :=
⟨λ hp, ⟨by simpa only [associates.is_unit_iff_eq_one] using hp.1,
        λ a b h, (eq_bot_or_eq_of_le_atom hp ⟨_, h⟩).cases_on
          (λ ha, or.inl (a.is_unit_iff_eq_one.mpr ha))
          (λ ha, or.inr (show is_unit b, by {rw ha at h, apply is_unit_of_associated_mul
          (show associated (p * b) p, by conv_rhs {rw h}) h₁ }))⟩,
 λ hp, ⟨by simpa only [associates.is_unit_iff_eq_one, associates.bot_eq_one] using hp.1,
        λ b ⟨⟨a, hab⟩, hb⟩, (hp.is_unit_or_is_unit hab).cases_on
          (λ hb, show b = ⊥, by rwa [associates.is_unit_iff_eq_one, ← associates.bot_eq_one] at hb)
          (λ ha, absurd (show p ∣ b, from ⟨(ha.unit⁻¹ : units _), by simp [hab]; rw mul_assoc;
            rw is_unit.mul_coe_inv ha; rw mul_one⟩) hb)⟩⟩

lemma dvd_not_unit.not_associated [cancel_comm_monoid_with_zero α] {p q : α}
  (h : dvd_not_unit p q) : ¬ associated p q :=
begin
  rintro ⟨a, rfl⟩,
  obtain ⟨hp, x, hx, hx'⟩ := h,
  rcases (mul_right_inj' hp).mp hx' with rfl,
  exact hx a.is_unit,
end

lemma dvd_not_unit.ne [cancel_comm_monoid_with_zero α] {p q : α}
  (h : dvd_not_unit p q) : p ≠ q :=
begin
  by_contra hcontra,
  obtain ⟨hp, x, hx', hx''⟩ := h,
  conv_lhs at hx'' {rw [← hcontra, ← mul_one p]},
  rw (mul_left_cancel₀ hp hx'').symm at hx',
  exact hx' is_unit_one,
end

lemma pow_injective_of_not_unit [cancel_comm_monoid_with_zero α] {q : α}
  (hq : ¬ is_unit q) (hq' : q ≠ 0): function.injective (λ (n : ℕ), q^n) :=
begin
  refine injective_of_lt_imp_ne (λ n m h, dvd_not_unit.ne ⟨pow_ne_zero n hq', q^(m - n), _, _⟩),
  { exact not_is_unit_of_not_is_unit_dvd hq (dvd_pow (dvd_refl _) (nat.sub_pos_of_lt h).ne') },
  { exact (pow_mul_pow_sub q h.le).symm  }
end

lemma dvd_prime_pow [cancel_comm_monoid_with_zero α] {p q : α} (hp : prime p) (n : ℕ) :
  q ∣ p^n ↔ ∃ i ≤ n, associated q (p ^ i) :=
begin
  induction n with n ih generalizing q,
  { simp [← is_unit_iff_dvd_one, associated_one_iff_is_unit] },
  refine ⟨λ h, _, λ ⟨i, hi, hq⟩, hq.dvd.trans (pow_dvd_pow p hi)⟩,
  rw pow_succ at h,
  rcases hp.left_dvd_or_dvd_right_of_dvd_mul h with (⟨q, rfl⟩ | hno),
  { rw [mul_dvd_mul_iff_left hp.ne_zero, ih] at h,
    rcases h with ⟨i, hi, hq⟩,
    refine ⟨i + 1, nat.succ_le_succ hi, (hq.mul_left p).trans _⟩,
    rw pow_succ },
  { obtain ⟨i, hi, hq⟩ := ih.mp hno,
    exact ⟨i, hi.trans n.le_succ, hq⟩ }
end

end cancel_comm_monoid_with_zero


import category_theory.basic
import misc.matrix

universes v u

/-
  defn enough graph theory for category theory purposes.
-/

structure graph :=
(vertex_set : Type u)
(edge_set :  Π v₁ v₂ : vertex_set, Type v)

namespace graph

inductive path {Γ : graph.{v u}} : Γ.vertex_set → Γ.vertex_set → Type (max v u)
| empty : Π v : Γ.vertex_set, path v v
| step  : Π {v₁ v₂ v₃ : Γ.vertex_set}, Γ.edge_set v₂ v₃ → path v₁ v₂ → path v₁ v₃

def concat {Γ : graph.{v u}} : Π {v₁ v₂ v₃ : Γ.vertex_set}, path v₂ v₃ → path v₁ v₂
  → path v₁ v₃
| v₁ v₂ .(v₂) (path.empty .(v₂)) p  := p
| v₁ v₂   v₃  (path.step e p₁)   p₂ := path.step e (concat p₁ p₂)

def path_cat (Γ : graph.{v u}) : Type u := Γ.vertex_set

open category

instance path_category (Γ : graph.{v u}) : category.{max v u} (path_cat Γ) :=
{
  Mor := λ v₁ v₂ : path_cat Γ,  path v₁ v₂,
  comp := λ v₁ v₂ v₃ f₁ f₂, concat f₁ f₂,
  idₘ := λ v, path.empty v,
  comp_assoc :=
    begin
      intros v₁ v₂ v₃ v₄ p₁ p₂ p₃,
      induction p₃ with v v₁ v₂ v e p ind,
      simp[concat],
      simp[concat],
      split,
      refl,
      rw ind p₂,
    end,
  id_comp_right :=
    begin
      intros v₁ v₂ p,
      induction p,
      refl,
      simp[concat],
      split,
      refl,
      rw p_ih,
    end,
  id_comp_left := λ _ _ _,rfl,
}

theorem path_cat_id {Γ :graph.{v u} }: ∀ v : path_cat Γ , path.empty v = idₘ v := λ _, rfl

theorem path_cat_step_comp {Γ :graph.{v u} } {v₁ v₂ v₃ v₄: path_cat Γ}
  : ∀ (e : Γ.edge_set v₃ v₄) (p : Mor v₂ v₃) (p': Mor v₁ v₂),
  ((path.step e p) ∘ₘ p' :Mor v₁ v₄) = path.step e (p ∘ₘ p') := λ _ _ _, rfl

structure graph_mor (Γ₁ Γ₂ : graph.{v u}) : Type (max v u) :=
(vertex_map : Γ₁.vertex_set → Γ₂.vertex_set)
(edge_map : Π {v₁ v₂ : Γ₁.vertex_set},
  Γ₁.edge_set v₁ v₂ → Γ₂.edge_set (vertex_map v₁) (vertex_map v₂))

def id_graph_mor (Γ : graph.{v u}) : graph_mor Γ Γ :=
{
  vertex_map := id,
  edge_map := λ _ _,id,
}

def graph_mor_comp {Γ₁ Γ₂ Γ₃  : graph.{v u}} (φ₁ : graph_mor Γ₂ Γ₃) (φ₂ : graph_mor Γ₁ Γ₂) : graph_mor Γ₁ Γ₃ :=
{
  vertex_map := φ₁.vertex_map ∘ φ₂.vertex_map,
  edge_map   := λ _ _ e, φ₁.edge_map (φ₂.edge_map e),
}

instance graph_category : category.{(max v u)} graph.{v u} :=
{
  Mor := graph_mor,
  idₘ := id_graph_mor,
  comp := λ Γ₁ Γ₂ Γ₃, graph_mor_comp,
  comp_assoc :=
    begin
      intros Γ₁ Γ₂ Γ₃ Γ₄ φ₁ φ₂ φ₃,
      cases φ₁,
      cases φ₂,
      cases φ₃,
      simp [graph_mor_comp],
    end,
  id_comp_right :=
    begin
      intros Γ₁ Γ₂ φ,
      cases φ,
      simp[id_graph_mor,graph_mor_comp],
    end,
  id_comp_left :=
    begin
      intros Γ₁ Γ₂ φ,
      cases φ,
      simp[id_graph_mor,graph_mor_comp],
    end,
}

def image_path {Γ₁ Γ₂ : graph.{v u}} (φ : Mor Γ₁ Γ₂): Π {v₁ v₂ : Γ₁.vertex_set} (p : path v₁ v₂),
  path (φ.vertex_map v₁) (φ.vertex_map v₂)
| v .(v) (path.empty .(v)) := path.empty (φ.vertex_map v)
| v₁ v₂ (path.step e p)    := path.step (φ.edge_map e) (image_path p)

theorem image_path_id {Γ : graph.{v u}} {v₁ v₂ : Γ.vertex_set} (p : path v₁ v₂)
  : image_path (idₘ Γ) p = p :=
begin
  induction p,
  refl,
  simp[image_path,p_ih],
  split,
  refl,
  split,
  refl,
  refl,
end

def category_to_graph (C : Type u) [category.{v} C] : graph.{v u} :=
{
  vertex_set := C,
  edge_set := Mor,
}

def path_to_mor {C : Type u} [category.{v} C] : Π {v₁ v₂ : C}
  (p : @path (category_to_graph C) v₁ v₂), Mor (v₁:C) (v₂: C)
| v .(v) (path.empty .(v)) := idₘ v
| v₁ v₂ (path.step e p)    := e ∘ₘ (path_to_mor p)

def shape {Γ : graph.{v u}} {C : Type u} [category.{v} C] (φ : Mor Γ (category_to_graph C))
  : path_cat Γ +→ C :=
{
  map := φ.vertex_map,
  fmap := λ _ _ p, path_to_mor (image_path φ p),
  fmap_prevs_id :=
    begin
      intro v,
      split,
    end,
  fmap_prevs_comp :=
    begin
      intros v₁ v₂ v₃ p₁ p₂,
      induction p₁ with v ,
      simp[path_to_mor,image_path, path_cat_id,id_comp_left],
      simp[← path_cat_id,image_path,path_to_mor,id_comp_left],
      simp[image_path,path_to_mor,p₁_ih,path_cat_step_comp],
      rw comp_assoc,
    end,
}

def matrix_to_graph {n : ℕ} (M : matrix ℕ n n) : graph.{v u} :=
{
  vertex_set := index n,
  edge_set := λ i₁ i₂, index (M.entry i₁ i₂),
}

end graph


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

import linear_algebra.exterior_algebra.basic
import linear_algebra.clifford_algebra.basic

/-!
Tests that the ring instances for `free_algebra` and derived quotient types actually work.

There is some discussion about this in
https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/algebra.2Esemiring_to_ring.20breaks.20semimodule.20typeclass.20lookup/near/212580241

In essence, the use of `attribute [irreducible] the_type` was breaking instance resolution on that
type.
-/

variables {S : Type*} {M : Type*}

section free

variables [comm_ring S]

example : (1 : free_algebra S M) - (1 : free_algebra S M) = 0 := by rw sub_self

end free

section exterior

variables [comm_ring S] [add_comm_group M] [module S M]

example : (1 : exterior_algebra S M) - (1 : exterior_algebra S M) = 0 := by rw sub_self

end exterior

section clifford

variables [comm_ring S] [add_comm_group M] [module S M] (Q : quadratic_form S M)

example : (1 : clifford_algebra Q) - (1 : clifford_algebra Q) = 0 := by rw sub_self

end clifford


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

import linear_algebra.bilinear_form
import linear_algebra.matrix.charpoly.coeff
import linear_algebra.determinant
import linear_algebra.vandermonde
import linear_algebra.trace
import field_theory.is_alg_closed.algebraic_closure
import field_theory.primitive_element
import ring_theory.power_basis

/-!
# Trace for (finite) ring extensions.

Suppose we have an `R`-algebra `S` with a finite basis. For each `s : S`,
the trace of the linear map given by multiplying by `s` gives information about
the roots of the minimal polynomial of `s` over `R`.

## Implementation notes

Typically, the trace is defined specifically for finite field extensions.
The definition is as general as possible and the assumption that we have
fields or that the extension is finite is added to the lemmas as needed.

We only define the trace for left multiplication (`algebra.left_mul_matrix`,
i.e. `algebra.lmul_left`).
For now, the definitions assume `S` is commutative, so the choice doesn't matter anyway.

## References

 * https://en.wikipedia.org/wiki/Field_trace

-/

universes u v w

variables {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
variables [algebra R S] [algebra R T]
variables {K L : Type*} [field K] [field L] [algebra K L]
variables {ι : Type w} [fintype ι]

open finite_dimensional
open linear_map
open matrix

open_locale big_operators
open_locale matrix

namespace algebra

variables (b : basis ι R S)

variables (R S)

/-- The trace of an element `s` of an `R`-algebra is the trace of `(*) s`,
as an `R`-linear map. -/
noncomputable def trace : S →ₗ[R] R :=
(linear_map.trace R S).comp (lmul R S).to_linear_map

variables {S}

-- Not a `simp` lemma since there are more interesting ways to rewrite `trace R S x`,
-- for example `trace_trace`
lemma trace_apply (x) : trace R S x = linear_map.trace R S (lmul R S x) := rfl

lemma trace_eq_zero_of_not_exists_basis
  (h : ¬ ∃ (s : finset S), nonempty (basis s R S)) : trace R S = 0 :=
by { ext s, simp [trace_apply, linear_map.trace, h] }

include b

variables {R}

-- Can't be a `simp` lemma because it depends on a choice of basis
lemma trace_eq_matrix_trace [decidable_eq ι] (b : basis ι R S) (s : S) :
  trace R S s = matrix.trace _ R _ (algebra.left_mul_matrix b s) :=
by rw [trace_apply, linear_map.trace_eq_matrix_trace _ b, to_matrix_lmul_eq]

/-- If `x` is in the base field `K`, then the trace is `[L : K] * x`. -/
lemma trace_algebra_map_of_basis (x : R) :
  trace R S (algebra_map R S x) = fintype.card ι • x :=
begin
  haveI := classical.dec_eq ι,
  rw [trace_apply, linear_map.trace_eq_matrix_trace R b, trace_diag],
  convert finset.sum_const _,
  ext i,
  simp,
end
omit b

/-- If `x` is in the base field `K`, then the trace is `[L : K] * x`.

(If `L` is not finite-dimensional over `K`, then `trace` and `finrank` return `0`.)
-/
@[simp]
lemma trace_algebra_map (x : K) : trace K L (algebra_map K L x) = finrank K L • x :=
begin
  by_cases H : ∃ (s : finset L), nonempty (basis s K L),
  { rw [trace_algebra_map_of_basis H.some_spec.some, finrank_eq_card_basis H.some_spec.some] },
  { simp [trace_eq_zero_of_not_exists_basis K H, finrank_eq_zero_of_not_exists_basis_finset H] }
end

lemma trace_trace_of_basis [algebra S T] [is_scalar_tower R S T]
  {ι κ : Type*} [fintype ι] [fintype κ]
  (b : basis ι R S) (c : basis κ S T) (x : T) :
  trace R S (trace S T x) = trace R T x :=
begin
  haveI := classical.dec_eq ι,
  haveI := classical.dec_eq κ,
  rw [trace_eq_matrix_trace (b.smul c), trace_eq_matrix_trace b, trace_eq_matrix_trace c,
      matrix.trace_apply, matrix.trace_apply, matrix.trace_apply,
      ← finset.univ_product_univ, finset.sum_product],
  refine finset.sum_congr rfl (λ i _, _),
  simp only [alg_hom.map_sum, smul_left_mul_matrix, finset.sum_apply,
      -- The unifier is not smart enough to apply this one by itself:
      finset.sum_apply i _ (λ y, left_mul_matrix b (left_mul_matrix c x y y))]
end

lemma trace_comp_trace_of_basis [algebra S T] [is_scalar_tower R S T]
  {ι κ : Type*} [fintype ι] [fintype κ]
  (b : basis ι R S) (c : basis κ S T) :
  (trace R S).comp ((trace S T).restrict_scalars R) = trace R T :=
by { ext, rw [linear_map.comp_apply, linear_map.restrict_scalars_apply, trace_trace_of_basis b c] }

@[simp]
lemma trace_trace [algebra K T] [algebra L T] [is_scalar_tower K L T]
  [finite_dimensional K L] [finite_dimensional L T] (x : T) :
  trace K L (trace L T x) = trace K T x :=
trace_trace_of_basis (basis.of_vector_space K L) (basis.of_vector_space L T) x

@[simp]
lemma trace_comp_trace [algebra K T] [algebra L T] [is_scalar_tower K L T]
  [finite_dimensional K L] [finite_dimensional L T] :
  (trace K L).comp ((trace L T).restrict_scalars K) = trace K T :=
by { ext, rw [linear_map.comp_apply, linear_map.restrict_scalars_apply, trace_trace] }

section trace_form

variables (R S)

/-- The `trace_form` maps `x y : S` to the trace of `x * y`.
It is a symmetric bilinear form and is nondegenerate if the extension is separable. -/
noncomputable def trace_form : bilin_form R S :=
(linear_map.compr₂ (lmul R S).to_linear_map (trace R S)).to_bilin

variables {S}

-- This is a nicer lemma than the one produced by `@[simps] def trace_form`.
@[simp] lemma trace_form_apply (x y : S) : trace_form R S x y = trace R S (x * y) := rfl

lemma trace_form_is_symm : (trace_form R S).is_symm :=
λ x y, congr_arg (trace R S) (mul_comm _ _)

lemma trace_form_to_matrix_power_basis (h : power_basis R S) :
  bilin_form.to_matrix h.basis (trace_form R S) = λ i j, (trace R S (h.gen ^ (i + j : ℕ))) :=
by { ext, rw [trace_form_to_matrix, pow_add, h.basis_eq_pow, h.basis_eq_pow] }

end trace_form

end algebra

section eq_sum_roots

open algebra polynomial

variables {F : Type*} [field F]
variables [algebra K S] [algebra K F]

lemma power_basis.trace_gen_eq_sum_roots [nontrivial S] (pb : power_basis K S)
  (hf : (minpoly K pb.gen).splits (algebra_map K F)) :
  algebra_map K F (trace K S pb.gen) =
    ((minpoly K pb.gen).map (algebra_map K F)).roots.sum :=
begin
  have d_pos : 0 < pb.dim := power_basis.dim_pos pb,
  have d_pos' : 0 < (minpoly K pb.gen).nat_degree, { simpa },
  haveI : nonempty (fin pb.dim) := ⟨⟨0, d_pos⟩⟩,
  -- Write the LHS as the `d-1`'th coefficient of `minpoly K pb.gen`
  rw [trace_eq_matrix_trace pb.basis, trace_eq_neg_charpoly_coeff, charpoly_left_mul_matrix,
      ring_hom.map_neg, ← pb.nat_degree_minpoly, fintype.card_fin,
      ← next_coeff_of_pos_nat_degree _ d_pos',
      ← next_coeff_map (algebra_map K F).injective],
  -- Rewrite `minpoly K pb.gen` as a product over the roots.
  conv_lhs { rw eq_prod_roots_of_splits hf },
  rw [monic.next_coeff_mul, next_coeff_C_eq_zero, zero_add, monic.next_coeff_multiset_prod],
  -- And conclude both sides are the same.
  simp_rw [next_coeff_X_sub_C, multiset.sum_map_neg, neg_neg],
  -- Now we deal with the side conditions.
  { intros, apply monic_X_sub_C },
  { convert monic_one, simp [(minpoly.monic pb.is_integral_gen).leading_coeff] },
  { apply monic_multiset_prod_of_monic,
    intros, apply monic_X_sub_C },
end

namespace intermediate_field.adjoin_simple

open intermediate_field

lemma trace_gen_eq_zero {x : L} (hx : ¬ is_integral K x) :
  algebra.trace K K⟮x⟯ (adjoin_simple.gen K x) = 0 :=
begin
  rw [trace_eq_zero_of_not_exists_basis, linear_map.zero_apply],
  contrapose! hx,
  obtain ⟨s, ⟨b⟩⟩ := hx,
  refine is_integral_of_mem_of_fg (K⟮x⟯).to_subalgebra _ x _,
  { exact (submodule.fg_iff_finite_dimensional _).mpr (finite_dimensional.of_finset_basis b) },
  { exact subset_adjoin K _ (set.mem_singleton x) }
end

lemma trace_gen_eq_sum_roots (x : L)
  (hf : (minpoly K x).splits (algebra_map K F)) :
  algebra_map K F (trace K K⟮x⟯ (adjoin_simple.gen K x)) =
    ((minpoly K x).map (algebra_map K F)).roots.sum :=
begin
  have injKKx : function.injective (algebra_map K K⟮x⟯) := ring_hom.injective _,
  have injKxL : function.injective (algebra_map K⟮x⟯ L) := ring_hom.injective _,
  by_cases hx : is_integral K x, swap,
  { simp [minpoly.eq_zero hx, trace_gen_eq_zero hx], },
  have hx' : is_integral K (adjoin_simple.gen K x),
  { rwa [← is_integral_algebra_map_iff injKxL, adjoin_simple.algebra_map_gen],
    apply_instance },
  rw [← adjoin.power_basis_gen hx, (adjoin.power_basis hx).trace_gen_eq_sum_roots];
    rw [adjoin.power_basis_gen hx, minpoly.eq_of_algebra_map_eq injKxL hx'];
    try { simp only [adjoin_simple.algebra_map_gen _ _] },
  exact hf
end

end intermediate_field.adjoin_simple

open intermediate_field

variables (K)

lemma trace_eq_trace_adjoin [finite_dimensional K L] (x : L) :
  algebra.trace K L x = finrank K⟮x⟯ L • trace K K⟮x⟯ (adjoin_simple.gen K x) :=
begin
  rw ← @trace_trace _ _ K K⟮x⟯ _ _ _ _ _ _ _ _ x,
  conv in x { rw ← intermediate_field.adjoin_simple.algebra_map_gen K x },
  rw [trace_algebra_map, linear_map.map_smul_of_tower],
end

variables {K}

lemma trace_eq_sum_roots [finite_dimensional K L]
  {x : L} (hF : (minpoly K x).splits (algebra_map K F)) :
  algebra_map K F (algebra.trace K L x) =
    finrank K⟮x⟯ L • ((minpoly K x).map (algebra_map K _)).roots.sum :=
by rw [trace_eq_trace_adjoin K x, algebra.smul_def, ring_hom.map_mul, ← algebra.smul_def,
    intermediate_field.adjoin_simple.trace_gen_eq_sum_roots _ hF, is_scalar_tower.algebra_map_smul]

end eq_sum_roots

variables {F : Type*} [field F]
variables [algebra R L] [algebra L F] [algebra R F] [is_scalar_tower R L F]

open polynomial

lemma algebra.is_integral_trace [finite_dimensional L F] {x : F} (hx : _root_.is_integral R x) :
  _root_.is_integral R (algebra.trace L F x) :=
begin
  have hx' : _root_.is_integral L x := is_integral_of_is_scalar_tower _ hx,
  rw [← is_integral_algebra_map_iff (algebra_map L (algebraic_closure F)).injective,
      trace_eq_sum_roots],
  { refine (is_integral.multiset_sum _).nsmul _,
    intros y hy,
    rw mem_roots_map (minpoly.ne_zero hx') at hy,
    use [minpoly R x, minpoly.monic hx],
    rw ← aeval_def at ⊢ hy,
    exact minpoly.aeval_of_is_scalar_tower R x y hy },
  { apply is_alg_closed.splits_codomain },
  { apply_instance }
end

section eq_sum_embeddings

variables [algebra K F] [is_scalar_tower K L F]

open algebra intermediate_field

variables (F) (E : Type*) [field E] [algebra K E]

lemma trace_eq_sum_embeddings_gen
  (pb : power_basis K L)
  (hE : (minpoly K pb.gen).splits (algebra_map K E)) (hfx : (minpoly K pb.gen).separable) :
  algebra_map K E (algebra.trace K L pb.gen) =
    (@@finset.univ (power_basis.alg_hom.fintype pb)).sum (λ σ, σ pb.gen) :=
begin
  letI := classical.dec_eq E,
  rw [pb.trace_gen_eq_sum_roots hE, fintype.sum_equiv pb.lift_equiv', finset.sum_mem_multiset,
      finset.sum_eq_multiset_sum, multiset.to_finset_val,
      multiset.erase_dup_eq_self.mpr _, multiset.map_id],
  { exact nodup_roots ((separable_map _).mpr hfx) },
  { intro x, refl },
  { intro σ, rw [power_basis.lift_equiv'_apply_coe, id.def] }
end

variables [is_alg_closed E]

lemma sum_embeddings_eq_finrank_mul [finite_dimensional K F] [is_separable K F]
  (pb : power_basis K L) :
  ∑ σ : F →ₐ[K] E, σ (algebra_map L F pb.gen) =
    finrank L F • (@@finset.univ (power_basis.alg_hom.fintype pb)).sum
      (λ σ : L →ₐ[K] E, σ pb.gen) :=
begin
  haveI : finite_dimensional L F := finite_dimensional.right K L F,
  haveI : is_separable L F := is_separable_tower_top_of_is_separable K L F,
  letI : fintype (L →ₐ[K] E) := power_basis.alg_hom.fintype pb,
  letI : ∀ (f : L →ₐ[K] E), fintype (@@alg_hom L F E _ _ _ _ f.to_ring_hom.to_algebra) :=
    _, -- will be solved by unification
  rw [fintype.sum_equiv alg_hom_equiv_sigma (λ (σ : F →ₐ[K] E), _) (λ σ, σ.1 pb.gen),
      ← finset.univ_sigma_univ, finset.sum_sigma, ← finset.sum_nsmul],
  refine finset.sum_congr rfl (λ σ _, _),
  { letI : algebra L E := σ.to_ring_hom.to_algebra,
    simp only [finset.sum_const, finset.card_univ],
    rw alg_hom.card L F E },
  { intros σ,
    simp only [alg_hom_equiv_sigma, equiv.coe_fn_mk, alg_hom.restrict_domain, alg_hom.comp_apply,
         is_scalar_tower.coe_to_alg_hom'] }
end

lemma trace_eq_sum_embeddings [finite_dimensional K L] [is_separable K L]
  {x : L} : algebra_map K E (algebra.trace K L x) = ∑ σ : L →ₐ[K] E, σ x :=
begin
  have hx := is_separable.is_integral K x,
  rw [trace_eq_trace_adjoin K x, algebra.smul_def, ring_hom.map_mul, ← adjoin.power_basis_gen hx,
      trace_eq_sum_embeddings_gen E (adjoin.power_basis hx) (is_alg_closed.splits_codomain _),
      ← algebra.smul_def, algebra_map_smul],
  { exact (sum_embeddings_eq_finrank_mul L E (adjoin.power_basis hx)).symm },
  { haveI := is_separable_tower_bot_of_is_separable K K⟮x⟯ L,
    exact is_separable.separable K _ }
end

end eq_sum_embeddings

section det_ne_zero

open algebra

variables (pb : power_basis K L)

lemma det_trace_form_ne_zero' [is_separable K L] :
  det (bilin_form.to_matrix pb.basis (trace_form K L)) ≠ 0 :=
begin
  suffices : algebra_map K (algebraic_closure L)
    (det (bilin_form.to_matrix pb.basis (trace_form K L))) ≠ 0,
  { refine mt (λ ht, _) this,
    rw [ht, ring_hom.map_zero] },
  haveI : finite_dimensional K L := pb.finite_dimensional,
  let e : (L →ₐ[K] algebraic_closure L) ≃ fin pb.dim := fintype.equiv_fin_of_card_eq _,
  let M : matrix (fin pb.dim) (fin pb.dim) (algebraic_closure L) :=
    vandermonde (λ i, e.symm i pb.gen),
  calc algebra_map K (algebraic_closure _) (bilin_form.to_matrix pb.basis (trace_form K L)).det
      = det ((algebra_map K _).map_matrix $
              bilin_form.to_matrix pb.basis (trace_form K L)) : ring_hom.map_det _ _
  ... = det (Mᵀ ⬝ M) : _
  ... = det M * det M : by rw [det_mul, det_transpose]
  ... ≠ 0 : mt mul_self_eq_zero.mp _,
  { refine congr_arg det _, ext i j,
    rw [vandermonde_transpose_mul_vandermonde, ring_hom.map_matrix_apply, matrix.map_apply,
        bilin_form.to_matrix_apply, pb.basis_eq_pow, pb.basis_eq_pow, trace_form_apply,
        ← pow_add, trace_eq_sum_embeddings (algebraic_closure L), fintype.sum_equiv e],
    intros σ,
    rw [e.symm_apply_apply, σ.map_pow] },
  { simp only [det_vandermonde, finset.prod_eq_zero_iff, not_exists, sub_eq_zero],
    intros i _ j hij h,
    exact (finset.mem_filter.mp hij).2.ne' (e.symm.injective $ pb.alg_hom_ext h) },
  { rw [alg_hom.card, pb.finrank] }
end

lemma det_trace_form_ne_zero [is_separable K L] [decidable_eq ι] (b : basis ι K L) :
  det (bilin_form.to_matrix b (trace_form K L)) ≠ 0 :=
begin
  haveI : finite_dimensional K L := finite_dimensional.of_fintype_basis b,
  let pb : power_basis K L := field.power_basis_of_finite_of_separable _ _,
  rw [← bilin_form.to_matrix_mul_basis_to_matrix pb.basis b,
      ← det_comm' (pb.basis.to_matrix_mul_to_matrix_flip b) _,
      ← matrix.mul_assoc, det_mul],
  swap, { apply basis.to_matrix_mul_to_matrix_flip },
  refine mul_ne_zero
    (is_unit_of_mul_eq_one _ ((b.to_matrix pb.basis)ᵀ ⬝ b.to_matrix pb.basis).det _).ne_zero
    (det_trace_form_ne_zero' pb),
  calc (pb.basis.to_matrix b ⬝ (pb.basis.to_matrix b)ᵀ).det *
      ((b.to_matrix pb.basis)ᵀ ⬝ b.to_matrix pb.basis).det
      = (pb.basis.to_matrix b ⬝ (b.to_matrix pb.basis ⬝ pb.basis.to_matrix b)ᵀ ⬝
        b.to_matrix pb.basis).det
      : by simp only [← det_mul, matrix.mul_assoc, matrix.transpose_mul]
  ... = 1 : by simp only [basis.to_matrix_mul_to_matrix_flip, matrix.transpose_one,
                          matrix.mul_one, matrix.det_one]
end

variables (K L)

theorem trace_form_nondegenerate [finite_dimensional K L] [is_separable K L] :
  (trace_form K L).nondegenerate :=
bilin_form.nondegenerate_of_det_ne_zero (trace_form K L) _
  (det_trace_form_ne_zero (finite_dimensional.fin_basis K L))

end det_ne_zero


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

Adjoining roots of polynomials
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.field_division
import Mathlib.ring_theory.adjoin
import Mathlib.ring_theory.principal_ideal_domain
import Mathlib.linear_algebra.finite_dimensional
import Mathlib.PostPort

universes u v u_1 u_2 w

namespace Mathlib

/-!
# Adjoining roots of polynomials

This file defines the commutative ring `adjoin_root f`, the ring R[X]/(f) obtained from a
commutative ring `R` and a polynomial `f : R[X]`. If furthermore `R` is a field and `f` is
irreducible, the field structure on `adjoin_root f` is constructed.

## Main definitions and results

The main definitions are in the `adjoin_root` namespace.

*  `mk f : polynomial R →+* adjoin_root f`, the natural ring homomorphism.

*  `of f : R →+* adjoin_root f`, the natural ring homomorphism.

* `root f : adjoin_root f`, the image of X in R[X]/(f).

* `lift (i : R →+* S) (x : S) (h : f.eval₂ i x = 0) : (adjoin_root f) →+* S`, the ring
  homomorphism from R[X]/(f) to S extending `i : R →+* S` and sending `X` to `x`.

* `lift_hom (x : S) (hfx : aeval x f = 0) : adjoin_root f →ₐ[R] S`, the algebra
  homomorphism from R[X]/(f) to S extending `algebra_map R S` and sending `X` to `x`

* `equiv : (adjoin_root f →ₐ[F] E) ≃ {x // x ∈ (f.map (algebra_map F E)).roots}` a
  bijection between algebra homomorphisms from `adjoin_root` and roots of `f` in `S`

-/

/-- Adjoin a root of a polynomial `f` to a commutative ring `R`. We define the new ring
as the quotient of `R` by the principal ideal of `f`. -/
def adjoin_root {R : Type u} [comm_ring R] (f : polynomial R) :=
  ideal.quotient (ideal.span (singleton f))

namespace adjoin_root

protected instance comm_ring {R : Type u} [comm_ring R] (f : polynomial R) : comm_ring (adjoin_root f) :=
  ideal.quotient.comm_ring (ideal.span (singleton f))

protected instance inhabited {R : Type u} [comm_ring R] (f : polynomial R) : Inhabited (adjoin_root f) :=
  { default := 0 }

protected instance decidable_eq {R : Type u} [comm_ring R] (f : polynomial R) : DecidableEq (adjoin_root f) :=
  classical.dec_eq (adjoin_root f)

/-- Ring homomorphism from `R[x]` to `adjoin_root f` sending `X` to the `root`. -/
def mk {R : Type u} [comm_ring R] (f : polynomial R) : polynomial R →+* adjoin_root f :=
  ideal.quotient.mk (ideal.span (singleton f))

theorem induction_on {R : Type u} [comm_ring R] (f : polynomial R) {C : adjoin_root f → Prop} (x : adjoin_root f) (ih : ∀ (p : polynomial R), C (coe_fn (mk f) p)) : C x :=
  quotient.induction_on' x ih

/-- Embedding of the original ring `R` into `adjoin_root f`. -/
def of {R : Type u} [comm_ring R] (f : polynomial R) : R →+* adjoin_root f :=
  ring_hom.comp (mk f) (ring_hom.of ⇑polynomial.C)

protected instance algebra {R : Type u} [comm_ring R] (f : polynomial R) : algebra R (adjoin_root f) :=
  ring_hom.to_algebra (of f)

@[simp] theorem algebra_map_eq {R : Type u} [comm_ring R] (f : polynomial R) : algebra_map R (adjoin_root f) = of f :=
  rfl

/-- The adjoined root. -/
def root {R : Type u} [comm_ring R] (f : polynomial R) : adjoin_root f :=
  coe_fn (mk f) polynomial.X

protected instance adjoin_root.has_coe_t {R : Type u} [comm_ring R] {f : polynomial R} : has_coe_t R (adjoin_root f) :=
  has_coe_t.mk ⇑(of f)

@[simp] theorem mk_self {R : Type u} [comm_ring R] {f : polynomial R} : coe_fn (mk f) f = 0 := sorry

@[simp] theorem mk_C {R : Type u} [comm_ring R] {f : polynomial R} (x : R) : coe_fn (mk f) (coe_fn polynomial.C x) = ↑x :=
  rfl

@[simp] theorem mk_X {R : Type u} [comm_ring R] {f : polynomial R} : coe_fn (mk f) polynomial.X = root f :=
  rfl

@[simp] theorem aeval_eq {R : Type u} [comm_ring R] {f : polynomial R} (p : polynomial R) : coe_fn (polynomial.aeval (root f)) p = coe_fn (mk f) p := sorry

theorem adjoin_root_eq_top {R : Type u} [comm_ring R] {f : polynomial R} : algebra.adjoin R (singleton (root f)) = ⊤ := sorry

@[simp] theorem eval₂_root {R : Type u} [comm_ring R] (f : polynomial R) : polynomial.eval₂ (of f) (root f) f = 0 := sorry

theorem is_root_root {R : Type u} [comm_ring R] (f : polynomial R) : polynomial.is_root (polynomial.map (of f) f) (root f) := sorry

/-- Lift a ring homomorphism `i : R →+* S` to `adjoin_root f →+* S`. -/
def lift {R : Type u} {S : Type v} [comm_ring R] {f : polynomial R} [comm_ring S] (i : R →+* S) (x : S) (h : polynomial.eval₂ i x f = 0) : adjoin_root f →+* S :=
  ideal.quotient.lift (ideal.span (singleton f)) (polynomial.eval₂_ring_hom i x) sorry

@[simp] theorem lift_mk {R : Type u} {S : Type v} [comm_ring R] {f : polynomial R} [comm_ring S] {i : R →+* S} {a : S} {h : polynomial.eval₂ i a f = 0} {g : polynomial R} : coe_fn (lift i a h) (coe_fn (mk f) g) = polynomial.eval₂ i a g :=
  ideal.quotient.lift_mk (ideal.span (singleton f)) (polynomial.eval₂_ring_hom i a) (lift._proof_1 i a h)

@[simp] theorem lift_root {R : Type u} {S : Type v} [comm_ring R] {f : polynomial R} [comm_ring S] {i : R →+* S} {a : S} {h : polynomial.eval₂ i a f = 0} : coe_fn (lift i a h) (root f) = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn (lift i a h) (root f) = a)) (root.equations._eqn_1 f)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn (lift i a h) (coe_fn (mk f) polynomial.X) = a)) lift_mk))
      (eq.mpr (id (Eq._oldrec (Eq.refl (polynomial.eval₂ i a polynomial.X = a)) (polynomial.eval₂_X i a))) (Eq.refl a)))

@[simp] theorem lift_of {R : Type u} {S : Type v} [comm_ring R] {f : polynomial R} [comm_ring S] {i : R →+* S} {a : S} {h : polynomial.eval₂ i a f = 0} {x : R} : coe_fn (lift i a h) ↑x = coe_fn i x := sorry

@[simp] theorem lift_comp_of {R : Type u} {S : Type v} [comm_ring R] {f : polynomial R} [comm_ring S] {i : R →+* S} {a : S} {h : polynomial.eval₂ i a f = 0} : ring_hom.comp (lift i a h) (of f) = i :=
  ring_hom.ext fun (_x : R) => lift_of

/-- Produce an algebra homomorphism `adjoin_root f →ₐ[R] S` sending `root f` to
a root of `f` in `S`. -/
def lift_hom {R : Type u} {S : Type v} [comm_ring R] (f : polynomial R) [comm_ring S] [algebra R S] (x : S) (hfx : coe_fn (polynomial.aeval x) f = 0) : alg_hom R (adjoin_root f) S :=
  alg_hom.mk (ring_hom.to_fun (lift (algebra_map R S) x hfx)) sorry sorry sorry sorry sorry

@[simp] theorem coe_lift_hom {R : Type u} {S : Type v} [comm_ring R] (f : polynomial R) [comm_ring S] [algebra R S] (x : S) (hfx : coe_fn (polynomial.aeval x) f = 0) : ↑(lift_hom f x hfx) = lift (algebra_map R S) x hfx :=
  rfl

@[simp] theorem aeval_alg_hom_eq_zero {R : Type u} {S : Type v} [comm_ring R] (f : polynomial R) [comm_ring S] [algebra R S] (ϕ : alg_hom R (adjoin_root f) S) : coe_fn (polynomial.aeval (coe_fn ϕ (root f))) f = 0 := sorry

@[simp] theorem lift_hom_eq_alg_hom {R : Type u} {S : Type v} [comm_ring R] [comm_ring S] [algebra R S] (f : polynomial R) (ϕ : alg_hom R (adjoin_root f) S) : lift_hom f (coe_fn ϕ (root f)) (aeval_alg_hom_eq_zero f ϕ) = ϕ := sorry

/-- If `E` is a field extension of `F` and `f` is a polynomial over `F` then the set
of maps from `F[x]/(f)` into `E` is in bijection with the set of roots of `f` in `E`. -/
def equiv (F : Type u_1) (E : Type u_2) [field F] [field E] [algebra F E] (f : polynomial F) (hf : f ≠ 0) : alg_hom F (adjoin_root f) E ≃ Subtype fun (x : E) => x ∈ polynomial.roots (polynomial.map (algebra_map F E) f) :=
  equiv.mk (fun (ϕ : alg_hom F (adjoin_root f) E) => { val := coe_fn ϕ (root f), property := sorry })
    (fun (x : Subtype fun (x : E) => x ∈ polynomial.roots (polynomial.map (algebra_map F E) f)) => lift_hom f ↑x sorry)
    sorry sorry

protected instance is_maximal_span {K : Type w} [field K] {f : polynomial K} [irreducible f] : ideal.is_maximal (ideal.span (singleton f)) :=
  principal_ideal_ring.is_maximal_of_irreducible _inst_2

protected instance field {K : Type w} [field K] {f : polynomial K} [irreducible f] : field (adjoin_root f) :=
  field.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub sorry sorry comm_ring.mul sorry
    comm_ring.one sorry sorry sorry sorry sorry field.inv sorry sorry sorry

theorem coe_injective {K : Type w} [field K] {f : polynomial K} [irreducible f] : function.injective coe :=
  ring_hom.injective (of f)

theorem mul_div_root_cancel {K : Type w} [field K] (f : polynomial K) [irreducible f] : (polynomial.X - coe_fn polynomial.C (root f)) *
    (polynomial.map (of f) f / (polynomial.X - coe_fn polynomial.C (root f))) =
  polynomial.map (of f) f :=
  iff.mpr polynomial.mul_div_eq_iff_is_root (is_root_root f)


import algebra.group.basic algebra.group.defs
import data.finset.card data.finset.basic data.set.function
import combinatorics.simple_graph.basic combinatorics.pigeonhole
import logic.function.basic logic.equiv.basic logic.equiv.defs
import Latin_line
open function

def is_latin1 {len : ℕ} (f : (fin len) → (fin len)) : Prop := injective f

def is_normal1 {len : ℕ} (f : (fin len) → (fin len)) : Prop := f = id

theorem latin1_maps_to {len : ℕ} {f : (fin len) → (fin len)} (H : is_latin1 f) :
  (finset.image f finset.univ) = finset.univ :=
begin
  have image_sub_domain : (finset.image f finset.univ) ⊆ finset.univ := (finset.image f finset.univ).subset_univ,
  cases has_subset.subset.eq_or_ssubset image_sub_domain with image_eq_domain image_ssub_domain;
  clear image_sub_domain,
  exact image_eq_domain,

  exfalso,
  have maps_to : set.maps_to f (coe finset.univ) (coe (finset.image f finset.univ)),
  {
    intros a ha,
    rw finset.mem_coe at ha,
    rw finset.mem_coe,
    rw finset.mem_image,
    use a,
    exact ⟨ ha, rfl ⟩,
  },

  have card_image_ssub_domain := finset.card_lt_card image_ssub_domain,
  have := finset.exists_ne_map_eq_of_card_lt_of_maps_to card_image_ssub_domain maps_to,
  rcases this with ⟨ a, a_ext, b, b_ext, a_neq_b, H1 ⟩,
  exact a_neq_b (H H1),
end

lemma surj_of_latin1 {len : ℕ} {f : (fin len) → (fin len)} (H : is_latin1 f) : surjective f :=
begin
  intros i,
  have i_in_image : i ∈ finset.univ := finset.mem_univ i,
  rw ← latin1_maps_to H at i_in_image,
  rw finset.mem_image at i_in_image,
  rcases i_in_image with ⟨ j, j_in_univ, j_maps_to_i ⟩,
  exact ⟨ j, j_maps_to_i ⟩,
end

theorem bij_of_latin1 {len : ℕ} {f : (fin len) → (fin len)} (H : is_latin1 f) : bijective f :=
⟨ H, surj_of_latin1 H ⟩

-----------------------------------------------------------------------------------------------------

structure latin1_hom {len : ℕ} : Type :=
  (to_fun : ((fin len) → (fin len)) → ((fin len) → (fin len)))
  (map_latin1 : ∀ f : (fin len) → (fin len), is_latin1 f → is_latin1 (to_fun f))

def perm_hom_latin1 {len : ℕ} {g : (fin len) → (fin len)} (g_inj : injective g) : latin1_hom :=
{
  to_fun :=
    begin
      intro f,
      exact g ∘ f,
    end,

  map_latin1 :=
    begin
      intros f f_inj,
      unfold is_latin1,
      rw injective.of_comp_iff,
      exact f_inj,
      exact g_inj,
    end,
}

noncomputable def transpose_hom_latin1 {len : ℕ} : latin1_hom :=
{
  to_fun :=
    begin
      intro f,

    end,
}

-- lemma latin1_canbe_permuted {len : ℕ} {f : (fin len) → (fin len)} (H : is_latin1 f) {g : (fin len) → (fin len)} (g_inj : injective g) :
--   is_latin1 (g ∘ f) :=
-- begin
--   unfold is_latin1,
--   rw injective.of_comp_iff,
--   exact H,
--   exact g_inj,
-- end

-- theorem latin1_iff_permuted {len : ℕ} {f : (fin len) → (fin len)} {g : (fin len) → (fin len)} (g_inj : injective g):
--   is_latin1 f ↔ is_latin1 (g ∘ f) :=
-- begin
--   split,

--   intro f_inj,
--   exact latin1_canbe_permuted f_inj g_inj,

--   intros gf_inj,
--   unfold is_latin1 at gf_inj,
--   rw injective.of_comp_iff g_inj f at gf_inj,
--   exact gf_inj,
-- end

-- theorem latin1_canbe_transposed {len : ℕ} {f : (fin len) → (fin len)} (H : is_latin1 f) :
-- ∃ g : (fin len) → (fin len), right_inverse g f ∧ left_inverse g f ∧ is_latin1 g :=
-- begin
--   choose g hg using function.bijective_iff_has_inverse.1 (bij_of_latin1 H),
--   use g,
--   refine ⟨ hg.2, hg.1, _ ⟩,
--   exact left_inverse.injective (function.right_inverse.left_inverse hg.2),
-- end

-- theorem latin1_iff_transposed {len : ℕ} {f : (fin len) → (fin len)} :
--   is_latin1 f ↔ ∃ g : (fin len) → (fin len), right_inverse g f ∧ left_inverse g f ∧ is_latin1 g :=
-- begin
--   split,
--   {
--     intro f_inj,
--     exact latin1_canbe_transposed f_inj,
--   },
--   {
--     intros gf_inj,
--     rcases gf_inj with ⟨ g, g_right_inv, g_left_inv, g_inj ⟩,
--     unfold is_latin1,
--     unfold is_latin1 at g_inj,
--     exact left_inverse.injective g_left_inv,
--   },
-- end

theorem latin1_canbe_normal1ised {len : ℕ} {f : (fin len) → (fin len)} (H : is_latin1 f) :
  ∃ g : (fin len) → (fin len), injective g ∧ is_latin1 (g ∘ f) ∧ is_normal1 (g ∘ f) :=
begin
  choose g hg using function.bijective_iff_has_inverse.1 (bij_of_latin1 H),
  use g,
  have g_inj : injective g := left_inverse.injective (function.right_inverse.left_inverse hg.2),
  refine ⟨ g_inj, latin1_canbe_permuted H g_inj, left_inverse.id hg.1 ⟩,
end


import number_theory.basic

/-! # IMO 2014 N4 -/

namespace IMOSL
namespace IMO2014N4

open set function

/-- If `k` is even and `k % m = 1`, then `k / m` is odd. -/
private lemma even_div_odd_one_mod {k m : ℕ} (h : even k) (h0 : k % m = 1) : odd (k / m) :=
  by rw [← nat.div_add_mod k m, nat.even_add, h0, iff_false_right nat.not_even_one,
    ← nat.odd_iff_not_even, nat.odd_mul] at h; exact h.2

/-- Final solution -/
theorem final_solution {n : ℕ} (h : 1 < n) : {k : ℕ | odd (n ^ k / k)}.infinite :=
begin
  suffices : ∃ f : ℕ → ℕ, injective f ∧ ∀ k : ℕ, odd (n ^ f k / f k),
    rcases this with ⟨f, h0, h1⟩; exact infinite_of_injective_forall_mem h0 h1,
  cases n.even_or_odd with h0 h0, rotate,

  ---- Case 1: `n > 1` is odd. Choose `f(k) = n^k`.
  { refine ⟨has_pow.pow n, nat.pow_right_injective h, λ k, _⟩,
    rw nat.pow_div (le_of_lt (nat.lt_pow_self h k)) (lt_trans one_pos h),
    exact h0.pow },

  rw [nat.lt_iff_add_one_le, ← bit0, le_iff_lt_or_eq] at h,
  rcases h with h | rfl,

  ---- Case 2: `n > 2` is even. Choose `f(k) = (n - 1) ^ (k + 1)`
  { -- Injectivity
    refine ⟨λ k, (n - 1) ^ k.succ, λ x y h1, _, λ k, _⟩,
    rw ← nat.succ_inj'; exact nat.pow_right_injective (nat.le_pred_of_lt h) h1,

    -- The main work
    obtain ⟨n, rfl⟩ := nat.exists_eq_succ_of_ne_zero (ne_zero_of_lt h),
    rw nat.succ_lt_succ_iff at h,
    rw [nat.succ_eq_add_one, nat.add_sub_cancel],
    refine even_div_odd_one_mod (nat.even_pow.mpr ⟨h0, pow_ne_zero _ (ne_zero_of_lt h)⟩) _,
    nth_rewrite 1 ← nat.mod_eq_of_lt (one_lt_pow h k.succ_ne_zero),
    rw [eq_comm, ← nat.modeq, nat.modeq_iff_dvd, nat.cast_one,
        int.coe_nat_pow, int.coe_nat_pow, nat.cast_add_one],
    nth_rewrite 1 ← one_pow (n ^ k.succ),
    refine dvd_trans (pow_dvd_pow _ k.succ.le_succ) (dvd_sub_pow_of_dvd_sub _ k.succ),
    rw add_sub_cancel },

  ---- Case 3: `n = 2`. Choose `f(k) = 3 ⬝ 4 ^ (k + 1)`
  { -- Injectivity
    clear h0; refine ⟨λ k, 2 ^ (2 * k.succ) * 3, λ x y h, _, λ k, _⟩,
    rw [mul_eq_mul_right_iff, or_iff_left (three_ne_zero : 3 ≠ 0)] at h,
    rw [← nat.succ_inj', ← mul_right_inj' (two_ne_zero : 2 ≠ 0)],
    exact nat.pow_right_injective (le_refl 2) h,

    -- The main work
    have h : 1 < 3 := by norm_num,
    have h0 : 2 * k.succ < 2 ^ (2 * k.succ) * 3 :=
      lt_trans (nat.lt_pow_self one_lt_two _) (lt_mul_of_one_lt_right (pow_pos two_pos _) h),
    rw lt_iff_exists_add at h0; rcases h0 with ⟨c, h1, h0⟩,
    rw [← nat.div_div_eq_div_mul, h0, nat.pow_div le_self_add two_pos, nat.add_sub_cancel_left],
    refine even_div_odd_one_mod (nat.even_pow.mpr ⟨even_two, ne_of_gt h1⟩) _,
    replace h1 : 2 ∣ 2 ^ (2 * nat.succ k) * 3 :=
      dvd_mul_of_dvd_left (dvd_pow_self 2 (mul_ne_zero two_ne_zero k.succ_ne_zero)) 3,
    rw [h0, ← nat.dvd_add_iff_right ⟨k.succ, rfl⟩] at h1,
    clear h0 k; rcases h1 with ⟨d, rfl⟩,
    rw [pow_mul, nat.pow_mod]; norm_num }
end

end IMO2014N4
end IMOSL


/-
Copyright (c) 2019 Jan-David Salchow. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jan-David Salchow

The space of bounded linear maps

Define the set of bounded linear maps between normed spaces and show basic facts about it. In
particular

(*) define a set L(E,F) of bounded linear maps between k normed spaces,
(*) show that L(E,F) is a vector subspace of E → F,
(*) define the 'operator norm' on L(E,F) and show that it induces the structure of a normed space
    on L(E,F).
-/
import algebra.module
import analysis.normed_space.bounded_linear_maps

variables {k : Type*}
variables {E : Type*} {F : Type*}

-- Define the subspace of bounded linear maps, introduce the notation L(E,F) for the set of bounded linear maps.
section bounded_linear_maps

variables [hnfk : normed_field k] [normed_space k E] [normed_space k F]
include hnfk

def bounded_linear_maps : subspace k (E → F) :=
{ carrier := {A : E → F | is_bounded_linear_map k A},
  zero := is_bounded_linear_map.zero,
  add := assume A B, is_bounded_linear_map.add,
  smul := assume c A, is_bounded_linear_map.smul c }

local notation `L(` E `,` F `)` := @bounded_linear_maps k E F _ _ _

/-- Coerce bounded linear maps to functions. -/
instance bounded_linear_maps.to_fun : has_coe_to_fun $ L(E,F) :=
{F :=  λ _, (E → F), coe := (λ f, f.val)}

@[extensionality] theorem ext {A B : L(E,F)} (H : ∀ x, A x = B x) : A = B :=
set_coe.ext $ funext H

/-- Bounded linear maps are ... bounded -/
lemma exists_bound (A : L(E,F)) : ∃ c, c > 0 ∧ ∀ x : E, ∥A x∥ ≤ c * ∥x∥ := A.property.bound

/-- Bounded linear maps are conveniently bounded on the unit ball. -/
lemma exists_bound' (A : L(E,F)) : ∃ c, c > 0 ∧ ∀ x : E, ∥x∥ ≤ 1 → ∥A x∥ ≤ c :=
let ⟨c, _, H⟩ := exists_bound A in
exists.intro c ⟨‹c > 0›,
  assume x _,
  calc ∥A x∥ ≤ c * ∥x∥ : H x
        ... ≤ c * 1 : (mul_le_mul_left ‹c > 0›).mpr ‹∥x∥ ≤ 1›
        ... = c : mul_one c⟩

end bounded_linear_maps

/-
Now define the operator norm. We only do this for normed spaces over ℝ, since we need a
scalar multiplication with reals to prove that ∥A x∥ ≤ ∥A∥ * ∥x∥. It would be enough to
have a vector space over a normed field k with a real scalar multiplication and certain
compatibility conditions.

The main task is to show that the operator norm is definite, homogeneous, and satisfies the
triangle inequality. This is done after a few preliminary lemmas necessary to deal with cSup.
-/
section operator_norm

variables [normed_space ℝ E] [normed_space ℝ F]
open lattice set

local notation `L(` E `,` F `)` := @bounded_linear_maps ℝ E F _ _ _

noncomputable def to_linear_map (A : L(E, F)) : linear_map _ E F :=
{to_fun := A.val, ..A.property}

/-- The operator norm of a bounded linear map A : E → F is the sup of
    the set ∥A x∥ with ∥x∥ ≤ 1. If E = {0} we set ∥A∥ = 0. -/
noncomputable def operator_norm (A : L(E, F)) : ℝ :=
Sup (image (λ x, ∥A x∥) {x | ∥x∥ ≤ 1})

noncomputable instance bounded_linear_maps.to_has_norm : has_norm L(E,F) :=
{norm := operator_norm}

lemma norm_of_unit_ball_bdd_above (A : L(E,F)) : bdd_above (image (norm ∘ A) {x | ∥x∥ ≤ 1}) :=
let ⟨c, _, H⟩ := (exists_bound' A : ∃ c, c > 0 ∧ ∀ x : E, ∥x∥ ≤ 1 → ∥A x∥ ≤ c) in
bdd_above.mk c
  (assume r ⟨x, (_ : ∥x∥ ≤ 1), (_ : ∥A x∥ = r)⟩,
    show r ≤ c, from
      calc r = ∥A x∥ : eq.symm ‹∥A x∥ = r›
         ... ≤ c : H x ‹∥x∥ ≤ 1›)

lemma zero_in_im_ball (A : L(E,F)) : (0:ℝ) ∈ {r : ℝ | ∃ (x : E), ∥x∥ ≤ 1 ∧ ∥A x∥ = r} :=
have A 0 = 0, from (to_linear_map A).map_zero,
exists.intro (0:E) $ and.intro (by rw[norm_zero]; exact zero_le_one) (by rw[‹A 0 = 0›]; simp)

lemma operator_norm_nonneg (A : L(E,F)) : 0 ≤ ∥A∥ :=
have (0:ℝ) ∈ _, from zero_in_im_ball A,
show 0 ≤ Sup (image (norm ∘ A) {x | ∥x∥ ≤ 1}), from
let ⟨c, _, H⟩ := (exists_bound' A : ∃ c, c > 0 ∧ ∀ x : E, ∥x∥ ≤ 1 → ∥A x∥ ≤ c) in
le_cSup (norm_of_unit_ball_bdd_above A) ‹(0:ℝ) ∈ _›

lemma bounded_by_operator_norm_on_unit_vector (A : L(E, F)) {x : E} (_ : ∥x∥ = 1) : ∥A x∥ ≤ ∥A∥ :=
show ∥A x∥ ≤ Sup (image (norm ∘ A) {x | ∥x∥ ≤ 1}), from
let ⟨c, _, _⟩ := (exists_bound A : ∃ c, c > 0 ∧ ∀ x : E, ∥ A x ∥ ≤ c * ∥ x ∥) in
have ∥A x∥ ∈ (image (norm ∘ A) {x | ∥x∥ ≤ 1}), from mem_image_of_mem _ $ le_of_eq ‹∥x∥ = 1›,
le_cSup (norm_of_unit_ball_bdd_above A) ‹∥A x∥ ∈ _›

set_option class.instance_max_depth 34

/-- This is the fundamental property of the operator norm: ∥A x∥ ≤ ∥A∥ * ∥x∥. -/
theorem bounded_by_operator_norm {A : L(E,F)} {x : E} : ∥A x∥ ≤ ∥A∥ * ∥x∥ :=
have A 0 = 0, from (to_linear_map A).map_zero,
classical.by_cases
  (assume : x = (0:E),
    show ∥A x∥ ≤ ∥A∥ * ∥x∥, by rw[‹x = 0›, ‹A 0 = 0›, norm_zero, norm_zero, mul_zero]; exact le_refl 0)
  (assume : x ≠ (0:E),
    have ∥x∥ ≠ 0, from ne_of_gt $ (norm_pos_iff x).mpr ‹x ≠ 0›,
    have ∥∥x∥⁻¹∥ = ∥x∥⁻¹, from abs_of_nonneg $ inv_nonneg.mpr $ norm_nonneg x,
    have ∥∥x∥⁻¹•x∥ = 1, begin rw[norm_smul, ‹∥∥x∥⁻¹∥ = ∥x∥⁻¹›], exact inv_mul_cancel ‹∥x∥ ≠ 0› end,
    calc ∥A x∥ = (∥x∥ * ∥x∥⁻¹) * ∥A x∥ : by rw[mul_inv_cancel ‹∥x∥ ≠ 0›]; ring
          ... = ∥∥x∥⁻¹∥ * ∥A x∥ * ∥x∥  : by rw[‹∥∥x∥⁻¹∥ = ∥x∥⁻¹›]; ring
          ... = ∥∥x∥⁻¹• A x ∥ * ∥x∥    : by rw[←normed_space.norm_smul ∥x∥⁻¹ (A x)]
          ... = ∥A (∥x∥⁻¹• x)∥ * ∥x∥   : by {
                                          change  ∥∥x∥⁻¹ • A.val x∥ * ∥x∥ = ∥A.val (∥x∥⁻¹ • x)∥ * ∥x∥,
                                          rw A.property.smul}
          ... ≤ ∥A∥ * ∥x∥              : (mul_le_mul_right ((norm_pos_iff x).mpr ‹x ≠ 0›)).mpr
                                          (bounded_by_operator_norm_on_unit_vector A ‹∥∥x∥⁻¹•x∥ = 1›))

lemma bounded_by_operator_norm_on_unit_ball (A : L(E, F)) {x : E} (_ : ∥x∥ ≤ 1) : ∥A x∥ ≤ ∥A∥ :=
calc ∥A x∥ ≤ ∥A∥ * ∥x∥ : bounded_by_operator_norm
        ... ≤ ∥A∥ * 1 : mul_le_mul_of_nonneg_left ‹∥x∥ ≤ 1› (operator_norm_nonneg A)
        ... = ∥A∥ : mul_one ∥A∥

lemma operator_norm_bounded_by {A : L(E,F)} (c : nnreal) :
  (∀ x : E, ∥x∥ ≤ 1 → ∥A x∥ ≤ (c:ℝ)) → ∥A∥ ≤ c :=
assume H : ∀ x : E, ∥x∥ ≤ 1 → ∥A x∥ ≤ c,
suffices Sup (image (norm ∘ A) {x | ∥x∥ ≤ 1}) ≤ c, by assumption,
cSup_le (set.ne_empty_of_mem $ zero_in_im_ball A)
  (show ∀ (r : ℝ), r ∈ (image (norm ∘ A) {x | ∥x∥ ≤ 1}) → r ≤ c, from
    assume r ⟨x, _, _⟩,
      calc r = ∥A x∥ : eq.symm ‹_›
         ... ≤ c : H x ‹_›)

theorem operator_norm_triangle (A : L(E,F)) (B : L(E,F)) : ∥A + B∥ ≤ ∥A∥ + ∥B∥ :=
operator_norm_bounded_by (⟨∥A∥, operator_norm_nonneg A⟩ + ⟨∥B∥, operator_norm_nonneg B⟩)
  (assume x _, by exact
    calc ∥(A + B) x∥ = ∥A x + B x∥ : by refl
                ... ≤ ∥A x∥ + ∥B x∥ : by exact norm_triangle _ _
                ... ≤ ∥A∥ + ∥B∥ : by exact add_le_add (bounded_by_operator_norm_on_unit_ball A ‹_›)
                                            (bounded_by_operator_norm_on_unit_ball B ‹_›))

theorem operator_norm_zero_iff (A : L(E,F)) : ∥A∥ = 0 ↔ A = 0 :=
have A 0 = 0, from (to_linear_map A).map_zero,
iff.intro
  (assume : ∥A∥ = 0,
    suffices ∀ x, A x = 0, from ext this,
    assume x,
      have ∥A x∥ ≤ 0, from
        calc ∥A x∥ ≤ ∥A∥ * ∥x∥ : bounded_by_operator_norm
              ... = 0 : by rw[‹∥A∥ = 0›]; ring,
      (norm_le_zero_iff (A x)).mp this)
  (assume : A = 0,
    let M := {r : ℝ | ∃ (x : E), ∥x∥ ≤ 1 ∧ ∥A x∥ = r} in
    -- note that we have M = (image (norm ∘ A) {x | ∥x∥ ≤ 1}), from rfl
    suffices Sup M = 0, by assumption,
    suffices M = {0}, by rw[this]; exact cSup_singleton 0,
    (set.ext_iff M {0}).mpr $ assume r, iff.intro
      (assume : ∃ (x : E), ∥x∥ ≤ 1 ∧ ∥A x∥ = r,
        let ⟨x, _, _⟩ := this in
          have h : ∥(0:F)∥ = r, by rwa[‹A=0›] at *,
          by finish)
      (assume : r ∈ {0},
        have r = 0, from set.eq_of_mem_singleton this,
        exists.intro (0:E) $ ⟨by rw[norm_zero]; exact zero_le_one, by rw[this, ‹A 0 = 0›]; simp⟩))

theorem operator_norm_homogeneous (c : ℝ) (A : L(E, F)) : ∥c • A∥ = ∥c∥ * ∥A∥ :=
-- ∥c • A∥ is the supremum of the image of the map x ↦ ∥c • A x∥ on the unit ball in E
-- we show that this is the same as ∥c∥ * ∥A∥ by showing 1) and 2):
-- 1) ∥c∥ * ∥A∥ is an upper bound for the image of x ↦ ∥c • A x∥ on the unit ball
-- 2) any w < ∥c∥ * ∥A∥ is not an upper bound (this is equivalent to showing that every upper bound is ≥ ∥c∥ * ∥A∥)
suffices (∀ a ∈ _, a ≤ ∥c∥ * ∥A∥) ∧ (∀ (ub : ℝ), (∀ a ∈ _, a ≤ ub) → ∥c∥ * ∥A∥ ≤ ub), from
  cSup_intro' (show _ ≠ ∅, from set.ne_empty_of_mem $ zero_in_im_ball _) this.1 this.2,
and.intro
  (show ∀ a ∈ image (λ x, ∥(c • A) x∥) {x : E | ∥x∥ ≤ 1}, a ≤ ∥c∥ * ∥A∥, from
    assume a (hₐ : ∃ (x : E), ∥x∥ ≤ 1 ∧ ∥(c • A) x∥ = a),
      let ⟨x, _, _⟩ := hₐ in
        calc a = ∥c • A x∥    : eq.symm ‹_›
           ... = ∥c∥ * ∥A x∥   : by rw[←norm_smul c (A x)]; refl
           ... ≤ ∥c∥ * ∥A∥     : mul_le_mul_of_nonneg_left
                                   (bounded_by_operator_norm_on_unit_ball A ‹∥x∥ ≤ 1›)
                                   (norm_nonneg c))
  (show ∀ (ub : ℝ), (∀ a ∈ image (λ (x : E), ∥(c • A) x∥) {x : E | ∥x∥ ≤ 1}, a ≤ ub) → ∥c∥ * ∥A∥ ≤ ub, from
    assume u u_is_ub,
      classical.by_cases
        (assume : c = 0,
          calc ∥c∥ * ∥A∥ = 0 : by rw[‹c=0›, norm_zero, zero_mul]
                    ... ≤ u : u_is_ub (0:ℝ) $ zero_in_im_ball _)
        (assume : c ≠ 0,
          have ∥c∥ ≠ 0, from ne_of_gt $ (norm_pos_iff c).mpr ‹c ≠ 0›,
          have bla : u = ∥c∥ * (∥c∥⁻¹ * u), by rw[←mul_assoc, mul_inv_cancel ‹∥c∥ ≠ 0›, one_mul],
          suffices ∥A∥ ≤ ∥c∥⁻¹ * u, from
            have u = ∥c∥ * (∥c∥⁻¹ * u), by rw[←mul_assoc, mul_inv_cancel ‹∥c∥ ≠ 0›, one_mul],
            by rw[this]; exact mul_le_mul_of_nonneg_left ‹_› (norm_nonneg c),
          cSup_le
            (set.ne_empty_of_mem $ zero_in_im_ball _)
            (assume n (H : ∃ (x : E), ∥x∥ ≤ 1 ∧ ∥A x∥ = n),
              let ⟨x, _, _⟩ := H in
              calc n = ∥A x∥             : eq.symm ‹∥A x∥ = n›
                 ... = ∥c∥⁻¹ * ∥c • A x∥ : by rw[norm_smul, ←mul_assoc, inv_mul_cancel ‹∥c∥ ≠ 0›, one_mul]
                 ... ≤ ∥c∥⁻¹ * u         : mul_le_mul_of_nonneg_left (u_is_ub ∥c • A x∥ ⟨x, ‹∥x∥ ≤ 1›, rfl⟩) $
                                                                     inv_nonneg.mpr $ norm_nonneg c)))

/-- Expose L(E,F) equipped with the operator norm as normed space. -/
noncomputable instance bounded_linear_maps.to_normed_space : normed_space ℝ L(E,F) :=
normed_space.of_core ℝ L(E,F) {
  norm_eq_zero_iff := operator_norm_zero_iff,
  norm_smul := operator_norm_homogeneous,
  triangle := operator_norm_triangle
}

end operator_norm