/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Robert Y. Lewis
-/
import data.real.cau_seq

/-!
# Cauchy completion

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

This file generalizes the Cauchy completion of `(ℚ, abs)` to the completion of a ring
with absolute value.
-/

namespace cau_seq.completion
open cau_seq

section
variables {α : Type*} [linear_ordered_field α]
variables {β : Type*} [ring β] (abv : β → α) [is_absolute_value abv]

/-- The Cauchy completion of a ring with absolute value. -/
def Cauchy := @quotient (cau_seq _ abv) cau_seq.equiv

variables {abv}

/-- The map from Cauchy sequences into the Cauchy completion. -/
def mk : cau_seq _ abv → Cauchy abv := quotient.mk

@[simp] theorem mk_eq_mk (f) : @eq (Cauchy abv) ⟦f⟧ (mk f) := rfl

theorem mk_eq {f g : cau_seq _ abv} : mk f = mk g ↔ f ≈ g := quotient.eq

/-- The map from the original ring into the Cauchy completion. -/
def of_rat (x : β) : Cauchy abv := mk (const abv x)

instance : has_zero (Cauchy abv) := ⟨of_rat 0⟩
instance : has_one (Cauchy abv) := ⟨of_rat 1⟩
instance : inhabited (Cauchy abv) := ⟨0⟩

theorem of_rat_zero : (of_rat 0 : Cauchy abv) = 0 := rfl
theorem of_rat_one : (of_rat 1 : Cauchy abv) = 1 := rfl

@[simp] theorem mk_eq_zero {f : cau_seq _ abv} : mk f = 0 ↔ lim_zero f :=
by have : mk f = 0 ↔ lim_zero (f - 0) := quotient.eq;
   rwa sub_zero at this

instance : has_add (Cauchy abv) :=
⟨quotient.map₂ (+) $ λ f₁ g₁ hf f₂ g₂ hg, add_equiv_add hf hg⟩

@[simp] theorem mk_add (f g : cau_seq β abv) : mk f + mk g = mk (f + g) := rfl

instance : has_neg (Cauchy abv) :=
⟨quotient.map has_neg.neg $ λ f₁ f₂ hf, neg_equiv_neg hf⟩

@[simp] theorem mk_neg (f : cau_seq β abv) : -mk f = mk (-f) := rfl

instance : has_mul (Cauchy abv) :=
⟨quotient.map₂ (*) $ λ f₁ g₁ hf f₂ g₂ hg, mul_equiv_mul hf hg⟩

@[simp] theorem mk_mul (f g : cau_seq β abv) : mk f * mk g = mk (f * g) := rfl

instance : has_sub (Cauchy abv) :=
⟨quotient.map₂ has_sub.sub $ λ f₁ g₁ hf f₂ g₂ hg, sub_equiv_sub hf hg⟩

@[simp] theorem mk_sub (f g : cau_seq β abv) : mk f - mk g = mk (f - g) := rfl

instance {γ : Type*} [has_smul γ β] [is_scalar_tower γ β β] : has_smul γ (Cauchy abv) :=
⟨λ c, quotient.map ((•) c) $ λ f₁ g₁ hf, smul_equiv_smul _ hf⟩

@[simp] theorem mk_smul  {γ : Type*} [has_smul γ β] [is_scalar_tower γ β β] (c : γ)
  (f : cau_seq β abv) :
  c • mk f = mk (c • f) := rfl

instance : has_pow (Cauchy abv) ℕ :=
⟨λ x n, quotient.map (^ n) (λ f₁ g₁ hf, pow_equiv_pow hf _) x⟩

@[simp] theorem mk_pow (n : ℕ) (f : cau_seq β abv) : mk f ^ n = mk (f ^ n) := rfl

instance : has_nat_cast (Cauchy abv) := ⟨λ n, mk n⟩
instance : has_int_cast (Cauchy abv) := ⟨λ n, mk n⟩

@[simp] theorem of_rat_nat_cast (n : ℕ) : (of_rat n : Cauchy abv) = n := rfl
@[simp] theorem of_rat_int_cast (z : ℤ) : (of_rat z : Cauchy abv) = z := rfl

theorem of_rat_add (x y : β) : of_rat (x + y) = (of_rat x + of_rat y : Cauchy abv) :=
congr_arg mk (const_add _ _)

theorem of_rat_neg (x : β) : of_rat (-x) = (-of_rat x : Cauchy abv) :=
congr_arg mk (const_neg _)

theorem of_rat_mul (x y : β) : of_rat (x * y) = (of_rat x * of_rat y : Cauchy abv) :=
congr_arg mk (const_mul _ _)

private lemma zero_def : 0 = (mk 0 : Cauchy abv) := rfl

private lemma one_def : 1 = (mk 1 : Cauchy abv) := rfl

instance : ring (Cauchy abv) :=
function.surjective.ring mk (surjective_quotient_mk _)
  zero_def.symm one_def.symm (λ _ _, (mk_add _ _).symm) (λ _ _, (mk_mul _ _).symm)
  (λ _, (mk_neg _).symm) (λ _ _, (mk_sub _ _).symm)
  (λ _ _, (mk_smul _ _).symm) (λ _ _, (mk_smul _ _).symm)
  (λ _ _, (mk_pow _ _).symm) (λ _, rfl) (λ _, rfl)

/-- `cau_seq.completion.of_rat` as a `ring_hom`  -/
@[simps]
def of_rat_ring_hom : β →+* Cauchy abv :=
{ to_fun := of_rat,
  map_zero' := of_rat_zero,
  map_one' := of_rat_one,
  map_add' := of_rat_add,
  map_mul' := of_rat_mul, }

theorem of_rat_sub (x y : β) : of_rat (x - y) = (of_rat x - of_rat y : Cauchy abv) :=
congr_arg mk (const_sub _ _)

end

section
variables {α : Type*} [linear_ordered_field α]
variables {β : Type*} [comm_ring β] {abv : β → α} [is_absolute_value abv]

instance : comm_ring (Cauchy abv) :=
function.surjective.comm_ring mk (surjective_quotient_mk _)
  zero_def.symm one_def.symm (λ _ _, (mk_add _ _).symm) (λ _ _, (mk_mul _ _).symm)
  (λ _, (mk_neg _).symm) (λ _ _, (mk_sub _ _).symm)
  (λ _ _, (mk_smul _ _).symm) (λ _ _, (mk_smul _ _).symm)
  (λ _ _, (mk_pow _ _).symm) (λ _, rfl) (λ _, rfl)

end

open_locale classical
section

variables {α : Type*} [linear_ordered_field α]
variables {β : Type*} [division_ring β] {abv : β → α} [is_absolute_value abv]

instance : has_rat_cast (Cauchy abv) := ⟨λ q, of_rat q⟩

@[simp] theorem of_rat_rat_cast (q : ℚ) : of_rat (↑q : β) = (q : Cauchy abv) := rfl

noncomputable instance : has_inv (Cauchy abv) :=
⟨λ x, quotient.lift_on x
  (λ f, mk $ if h : lim_zero f then 0 else inv f h) $
λ f g fg, begin
  have := lim_zero_congr fg,
  by_cases hf : lim_zero f,
  { simp [hf, this.1 hf, setoid.refl] },
  { have hg := mt this.2 hf, simp [hf, hg],
    have If : mk (inv f hf) * mk f = 1 := mk_eq.2 (inv_mul_cancel hf),
    have Ig : mk (inv g hg) * mk g = 1 := mk_eq.2 (inv_mul_cancel hg),
    have Ig' : mk g * mk (inv g hg) = 1 := mk_eq.2 (mul_inv_cancel hg),
    rw [mk_eq.2 fg, ← Ig] at If,
    rw [← mul_one (mk (inv f hf)), ← Ig', ← mul_assoc, If,
        mul_assoc, Ig', mul_one] }
end⟩

@[simp] theorem inv_zero : (0 : Cauchy abv)⁻¹ = 0 :=
congr_arg mk $ by rw dif_pos; [refl, exact zero_lim_zero]

@[simp] theorem inv_mk {f} (hf) : (@mk α _ β _ abv _ f)⁻¹ = mk (inv f hf) :=
congr_arg mk $ by rw dif_neg

lemma cau_seq_zero_ne_one : ¬ (0 : cau_seq _ abv) ≈ 1 := λ h,
have lim_zero (1 - 0), from setoid.symm h,
have lim_zero 1, by simpa,
one_ne_zero $ const_lim_zero.1 this

lemma zero_ne_one : (0 : Cauchy abv) ≠ 1 :=
λ h, cau_seq_zero_ne_one $ mk_eq.1 h

protected theorem inv_mul_cancel {x : Cauchy abv} : x ≠ 0 → x⁻¹ * x = 1 :=
quotient.induction_on x $ λ f hf, begin
  simp at hf, simp [hf],
  exact quotient.sound (cau_seq.inv_mul_cancel hf)
end

protected theorem mul_inv_cancel {x : Cauchy abv} : x ≠ 0 → x * x⁻¹ = 1 :=
quotient.induction_on x $ λ f hf, begin
  simp at hf, simp [hf],
  exact quotient.sound (cau_seq.mul_inv_cancel hf)
end

theorem of_rat_inv (x : β) : of_rat (x⁻¹) = ((of_rat x)⁻¹ : Cauchy abv) :=
congr_arg mk $ by split_ifs with h; [simp [const_lim_zero.1 h], refl]

/-- The Cauchy completion forms a division ring. -/
noncomputable instance : division_ring (Cauchy abv) :=
{ inv              := has_inv.inv,
  mul_inv_cancel   := λ x, cau_seq.completion.mul_inv_cancel,
  exists_pair_ne   := ⟨0, 1, zero_ne_one⟩,
  inv_zero         := inv_zero,
  rat_cast := λ q, of_rat q,
  rat_cast_mk := λ n d hd hnd,
    by rw [rat.cast_mk', of_rat_mul, of_rat_int_cast, of_rat_inv, of_rat_nat_cast],
  .. Cauchy.ring }

theorem of_rat_div (x y : β) : of_rat (x / y) = (of_rat x / of_rat y : Cauchy abv) :=
by simp only [div_eq_mul_inv, of_rat_inv, of_rat_mul]

/-- Show the first 10 items of a representative of this equivalence class of cauchy sequences.

The representative chosen is the one passed in the VM to `quot.mk`, so two cauchy sequences
converging to the same number may be printed differently.
-/
meta instance [has_repr β] : has_repr (Cauchy abv) :=
{ repr := λ r,
  let N := 10, seq := r.unquot in
    "(sorry /- " ++ (", ".intercalate $ (list.range N).map $ repr ∘ seq) ++ ", ... -/)" }

end

section
variables {α : Type*} [linear_ordered_field α]
variables {β : Type*} [field β] {abv : β → α} [is_absolute_value abv]

/-- The Cauchy completion forms a field. -/
noncomputable instance : field (Cauchy abv) :=
{ .. Cauchy.division_ring,
  .. Cauchy.comm_ring }

end

end cau_seq.completion

variables {α : Type*} [linear_ordered_field α]
namespace cau_seq
section

variables (β : Type*) [ring β] (abv : β → α) [is_absolute_value abv]

/-- A class stating that a ring with an absolute value is complete, i.e. every Cauchy
sequence has a limit. -/
class is_complete : Prop :=
(is_complete : ∀ s : cau_seq β abv, ∃ b : β, s ≈ const abv b)
end

section

variables {β : Type*} [ring β] {abv : β → α} [is_absolute_value abv]
variable [is_complete β abv]

lemma complete : ∀ s : cau_seq β abv, ∃ b : β, s ≈ const abv b :=
is_complete.is_complete

/-- The limit of a Cauchy sequence in a complete ring. Chosen non-computably. -/
noncomputable def lim (s : cau_seq β abv) : β :=
classical.some (complete s)

lemma equiv_lim (s : cau_seq β abv) : s ≈ const abv (lim s) :=
classical.some_spec (complete s)

lemma eq_lim_of_const_equiv {f : cau_seq β abv} {x : β} (h : cau_seq.const abv x ≈ f) : x = lim f :=
const_equiv.mp $ setoid.trans h $ equiv_lim f

lemma lim_eq_of_equiv_const {f : cau_seq β abv} {x : β} (h : f ≈ cau_seq.const abv x) : lim f = x :=
(eq_lim_of_const_equiv $ setoid.symm h).symm

lemma lim_eq_lim_of_equiv {f g : cau_seq β abv} (h : f ≈ g) : lim f = lim g :=
lim_eq_of_equiv_const $ setoid.trans h $ equiv_lim g

@[simp] lemma lim_const (x : β) : lim (const abv x) = x :=
lim_eq_of_equiv_const $ setoid.refl _

lemma lim_add (f g : cau_seq β abv) : lim f + lim g = lim (f + g) :=
eq_lim_of_const_equiv $ show lim_zero (const abv (lim f + lim g) - (f + g)),
  by rw [const_add, add_sub_add_comm];
  exact add_lim_zero (setoid.symm (equiv_lim f)) (setoid.symm (equiv_lim g))

lemma lim_mul_lim (f g : cau_seq β abv) : lim f * lim g = lim (f * g) :=
eq_lim_of_const_equiv $ show lim_zero (const abv (lim f * lim g) - f * g),
  from have h : const abv (lim f * lim g) - f * g = (const abv (lim f) - f) * g
      + const abv (lim f) * (const abv (lim g) - g) :=
    by simp [const_mul (lim f), mul_add, add_mul, sub_eq_add_neg, add_comm, add_left_comm],
  by rw h; exact add_lim_zero (mul_lim_zero_left _ (setoid.symm (equiv_lim _)))
    (mul_lim_zero_right _ (setoid.symm (equiv_lim _)))

lemma lim_mul (f : cau_seq β abv) (x : β) : lim f * x = lim (f * const abv x) :=
by rw [← lim_mul_lim, lim_const]

lemma lim_neg (f : cau_seq β abv) : lim (-f) = -lim f :=
lim_eq_of_equiv_const (show lim_zero (-f - const abv (-lim f)),
  by rw [const_neg, sub_neg_eq_add, add_comm, ← sub_eq_add_neg];
  exact setoid.symm (equiv_lim f))

lemma lim_eq_zero_iff (f : cau_seq β abv) : lim f = 0 ↔ lim_zero f :=
⟨assume h,
  by have hf := equiv_lim f;
  rw h at hf;
  exact (lim_zero_congr hf).mpr (const_lim_zero.mpr rfl),
assume h,
  have h₁ : f = (f - const abv 0) := ext (λ n, by simp [sub_apply, const_apply]),
  by rw h₁ at h; exact lim_eq_of_equiv_const h ⟩

end

section
variables {β : Type*} [field β] {abv : β → α} [is_absolute_value abv] [is_complete β abv]

lemma lim_inv {f : cau_seq β abv} (hf : ¬ lim_zero f) : lim (inv f hf) = (lim f)⁻¹ :=
have hl : lim f ≠ 0 := by rwa ← lim_eq_zero_iff at hf,
lim_eq_of_equiv_const $ show lim_zero (inv f hf - const abv (lim f)⁻¹),
  from have h₁ : ∀ (g f : cau_seq β abv) (hf : ¬ lim_zero f), lim_zero (g - f * inv f hf * g) :=
    λ g f hf, by rw [← one_mul g, ← mul_assoc, ← sub_mul, mul_one, mul_comm, mul_comm f];
    exact mul_lim_zero_right _ (setoid.symm (cau_seq.inv_mul_cancel _)),
  have h₂ : lim_zero ((inv f hf - const abv (lim f)⁻¹) - (const abv (lim f) - f) *
      (inv f hf * const abv (lim f)⁻¹)) :=
    by rw [sub_mul, ← sub_add, sub_sub, sub_add_eq_sub_sub, sub_right_comm, sub_add];
    exact show lim_zero (inv f hf - const abv (lim f) * (inv f hf * const abv (lim f)⁻¹)
      - (const abv (lim f)⁻¹ - f * (inv f hf * const abv (lim f)⁻¹))),
    from sub_lim_zero
      (by rw [← mul_assoc, mul_right_comm, const_inv hl]; exact h₁ _ _ _)
      (by rw [← mul_assoc]; exact h₁ _ _ _),
  (lim_zero_congr h₂).mpr $ mul_lim_zero_left _ (setoid.symm (equiv_lim f))

end

section
variables [is_complete α abs]

lemma lim_le {f : cau_seq α abs} {x : α}
  (h : f ≤ cau_seq.const abs x) : lim f ≤ x :=
cau_seq.const_le.1 $ cau_seq.le_of_eq_of_le (setoid.symm (equiv_lim f)) h

lemma le_lim {f : cau_seq α abs} {x : α}
  (h : cau_seq.const abs x ≤ f) : x ≤ lim f :=
cau_seq.const_le.1 $ cau_seq.le_of_le_of_eq h (equiv_lim f)

lemma lt_lim {f : cau_seq α abs} {x : α}
  (h : cau_seq.const abs x < f) : x < lim f :=
cau_seq.const_lt.1 $ cau_seq.lt_of_lt_of_eq h (equiv_lim f)

lemma lim_lt {f : cau_seq α abs} {x : α}
  (h : f < cau_seq.const abs x) : lim f < x :=
cau_seq.const_lt.1 $ cau_seq.lt_of_eq_of_lt (setoid.symm (equiv_lim f)) h

end
end cau_seq


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import data.set.Union_lift
import topology.subset_properties
import topology.tactic
import topology.algebra.ordered.proj_Icc

/-!
# Continuous bundled map

In this file we define the type `continuous_map` of continuous bundled maps.
-/

/-- Bundled continuous maps. -/
@[protect_proj]
structure continuous_map (α : Type*) (β : Type*)
[topological_space α] [topological_space β] :=
(to_fun             : α → β)
(continuous_to_fun  : continuous to_fun . tactic.interactive.continuity')

notation `C(` α `, ` β `)` := continuous_map α β

namespace continuous_map

attribute [continuity] continuous_map.continuous_to_fun

variables {α : Type*} {β : Type*} {γ : Type*}
variables [topological_space α] [topological_space β] [topological_space γ]

instance : has_coe_to_fun (C(α, β)) (λ _, α → β) := ⟨continuous_map.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : C(α, β)} : f.to_fun = (f : α → β) := rfl

variables {α β} {f g : continuous_map α β}

@[continuity] protected lemma continuous (f : C(α, β)) : continuous f := f.continuous_to_fun
@[continuity] lemma continuous_set_coe (s : set C(α, β)) (f : s) : continuous f :=
by { cases f, rw @coe_fn_coe_base', continuity }

protected lemma continuous_at (f : C(α, β)) (x : α) : continuous_at f x :=
f.continuous.continuous_at

protected lemma continuous_within_at (f : C(α, β)) (s : set α) (x : α) :
  continuous_within_at f s x :=
f.continuous.continuous_within_at

protected lemma congr_fun {f g : C(α, β)} (H : f = g) (x : α) : f x = g x := H ▸ rfl
protected lemma congr_arg (f : C(α, β)) {x y : α} (h : x = y) : f x = f y := h ▸ rfl

@[ext]

lemma ext_iff : f = g ↔ ∀ x, f x = g x :=
⟨continuous_map.congr_fun, ext⟩

instance [inhabited β] : inhabited C(α, β) :=
⟨{ to_fun := λ _, default _, }⟩

lemma coe_inj ⦃f g : C(α, β)⦄ (h : (f : α → β) = g) : f = g :=
by cases f; cases g; cases h; refl

@[simp] lemma coe_mk (f : α → β) (h : continuous f) :
  ⇑(⟨f, h⟩ : continuous_map α β) = f := rfl

section
variables (α β)

/--
The continuous functions from `α` to `β` are the same as the plain functions when `α` is discrete.
-/
@[simps]
def equiv_fn_of_discrete [discrete_topology α] : C(α, β) ≃ (α → β) :=
⟨(λ f, f), (λ f, ⟨f, continuous_of_discrete_topology⟩),
  λ f, by { ext, refl, }, λ f, by { ext, refl, }⟩

end

/-- The identity as a continuous map. -/
def id : C(α, α) := ⟨id⟩

@[simp] lemma id_coe : (id : α → α) = _root_.id := rfl
lemma id_apply (a : α) : id a = a := rfl

/-- The composition of continuous maps, as a continuous map. -/
def comp (f : C(β, γ)) (g : C(α, β)) : C(α, γ) := ⟨f ∘ g⟩

@[simp] lemma comp_coe (f : C(β, γ)) (g : C(α, β)) : (comp f g : α → γ) = f ∘ g := rfl
lemma comp_apply (f : C(β, γ)) (g : C(α, β)) (a : α) : comp f g a = f (g a) := rfl

/-- Constant map as a continuous map -/
def const (b : β) : C(α, β) := ⟨λ x, b⟩

@[simp] lemma const_coe (b : β) : (const b : α → β) = (λ x, b) := rfl
lemma const_apply (b : β) (a : α) : const b a = b := rfl

instance [nonempty α] [nontrivial β] : nontrivial C(α, β) :=
{ exists_pair_ne := begin
    obtain ⟨b₁, b₂, hb⟩ := exists_pair_ne β,
    refine ⟨const b₁, const b₂, _⟩,
    contrapose! hb,
    inhabit α,
    change const b₁ (default α) = const b₂ (default α),
    simp [hb]
  end }

section
variables [linear_ordered_add_comm_group β] [order_topology β]

/-- The pointwise absolute value of a continuous function as a continuous function. -/
def abs (f : C(α, β)) : C(α, β) :=
{ to_fun := λ x, |f x|, }

@[priority 100] -- see Note [lower instance priority]
instance : has_abs C(α, β) := ⟨λf, abs f⟩

@[simp] lemma abs_apply (f : C(α, β)) (x : α) : |f| x = |f x| :=
rfl

end

/-!
We now set up the partial order and lattice structure (given by pointwise min and max)
on continuous functions.
-/
section lattice

instance partial_order [partial_order β] :
  partial_order C(α, β) :=
partial_order.lift (λ f, f.to_fun) (by tidy)

lemma le_def [partial_order β] {f g : C(α, β)} : f ≤ g ↔ ∀ a, f a ≤ g a :=
pi.le_def

lemma lt_def [partial_order β] {f g : C(α, β)} :
  f < g ↔ (∀ a, f a ≤ g a) ∧ (∃ a, f a < g a) :=
pi.lt_def

instance has_sup [linear_order β] [order_closed_topology β] : has_sup C(α, β) :=
{ sup := λ f g, { to_fun := λ a, max (f a) (g a), } }

@[simp, norm_cast] lemma sup_coe [linear_order β] [order_closed_topology β] (f g : C(α, β)) :
  ((f ⊔ g : C(α, β)) : α → β) = (f ⊔ g : α → β) :=
rfl

@[simp] lemma sup_apply [linear_order β] [order_closed_topology β] (f g : C(α, β)) (a : α) :
  (f ⊔ g) a = max (f a) (g a) :=
rfl

instance [linear_order β] [order_closed_topology β] : semilattice_sup C(α, β) :=
{ le_sup_left := λ f g, le_def.mpr (by simp [le_refl]),
  le_sup_right := λ f g, le_def.mpr (by simp [le_refl]),
  sup_le := λ f₁ f₂ g w₁ w₂, le_def.mpr (λ a, by simp [le_def.mp w₁ a, le_def.mp w₂ a]),
  ..continuous_map.partial_order,
  ..continuous_map.has_sup, }

instance has_inf [linear_order β] [order_closed_topology β] : has_inf C(α, β) :=
{ inf := λ f g, { to_fun := λ a, min (f a) (g a), } }

@[simp, norm_cast] lemma inf_coe [linear_order β] [order_closed_topology β] (f g : C(α, β)) :
  ((f ⊓ g : C(α, β)) : α → β) = (f ⊓ g : α → β) :=
rfl

@[simp] lemma inf_apply [linear_order β] [order_closed_topology β] (f g : C(α, β)) (a : α) :
  (f ⊓ g) a = min (f a) (g a) :=
rfl

instance [linear_order β] [order_closed_topology β] : semilattice_inf C(α, β) :=
{ inf_le_left := λ f g, le_def.mpr (by simp [le_refl]),
  inf_le_right := λ f g, le_def.mpr (by simp [le_refl]),
  le_inf := λ f₁ f₂ g w₁ w₂, le_def.mpr (λ a, by simp [le_def.mp w₁ a, le_def.mp w₂ a]),
  ..continuous_map.partial_order,
  ..continuous_map.has_inf, }

instance [linear_order β] [order_closed_topology β] : lattice C(α, β) :=
{ ..continuous_map.semilattice_inf,
  ..continuous_map.semilattice_sup }

-- TODO transfer this lattice structure to `bounded_continuous_function`

section sup'
variables [linear_order γ] [order_closed_topology γ]

lemma sup'_apply {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) (b : β) :
  s.sup' H f b = s.sup' H (λ a, f a b) :=
finset.comp_sup'_eq_sup'_comp H (λ f : C(β, γ), f b) (λ i j, rfl)

@[simp, norm_cast]
lemma sup'_coe {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) :
  ((s.sup' H f : C(β, γ)) : ι → β) = s.sup' H (λ a, (f a : β → γ)) :=
by { ext, simp [sup'_apply], }

end sup'

section inf'
variables [linear_order γ] [order_closed_topology γ]

lemma inf'_apply {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) (b : β) :
  s.inf' H f b = s.inf' H (λ a, f a b) :=
@sup'_apply _ (order_dual γ) _ _ _ _ _ _ H f b

@[simp, norm_cast]
lemma inf'_coe {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) :
  ((s.inf' H f : C(β, γ)) : ι → β) = s.inf' H (λ a, (f a : β → γ)) :=
@sup'_coe _ (order_dual γ) _ _ _ _ _ _ H f

end inf'

end lattice

section prod

variables {α₁ α₂ β₁ β₂ : Type*}

/-- Given two continuous maps `f` and `g`, this is the continuous map `x ↦ (f x, g x)`. -/
def prod_mk {α β₁ β₂ : Type*} [topological_space α] [topological_space β₁]
  [topological_space β₂] (f : C(α, β₁)) (g : C(α, β₂)) :
  C(α, β₁ × β₂) :=
{ to_fun := (λ x, (f x, g x)),
  continuous_to_fun := continuous.prod_mk f.continuous g.continuous }

/-- Given two continuous maps `f` and `g`, this is the continuous map `(x, y) ↦ (f x, g y)`. -/
def prod_map {α₁ α₂ β₁ β₂ : Type*} [topological_space α₁] [topological_space α₂]
  [topological_space β₁] [topological_space β₂] (f : C(α₁, α₂)) (g : C(β₁, β₂)) :
  C(α₁ × β₁, α₂ × β₂) :=
{ to_fun := prod.map f g,
  continuous_to_fun := continuous.prod_map f.continuous g.continuous }

end prod

section restrict

variables (s : set α)

/-- The restriction of a continuous function `α → β` to a subset `s` of `α`. -/
def restrict (f : C(α, β)) : C(s, β) := ⟨f ∘ coe⟩

@[simp] lemma coe_restrict (f : C(α, β)) : ⇑(f.restrict s) = f ∘ coe := rfl

end restrict

section extend

variables [linear_order α] [order_topology α] {a b : α} (h : a ≤ b)

/--
Extend a continuous function `f : C(set.Icc a b, β)` to a function `f : C(α, β)`.
-/
def Icc_extend (f : C(set.Icc a b, β)) : C(α, β) := ⟨set.Icc_extend h f⟩

@[simp] lemma coe_Icc_extend (f : C(set.Icc a b, β)) :
  ((Icc_extend h f : C(α, β)) : α → β) = set.Icc_extend h f := rfl

end extend

section gluing

variables {ι : Type*}
  (S : ι → set α)
  (φ : Π i : ι, C(S i, β))
  (hφ : ∀ i j (x : α) (hxi : x ∈ S i) (hxj : x ∈ S j), φ i ⟨x, hxi⟩ = φ j ⟨x, hxj⟩)
  (hS : ∀ x : α, ∃ i, S i ∈ nhds x)

include hφ hS

/-- A family `φ i` of continuous maps `C(S i, β)`, where the domains `S i` contain a neighbourhood
of each point in `α` and the functions `φ i` agree pairwise on intersections, can be glued to
construct a continuous map in `C(α, β)`. -/
noncomputable def lift_cover : C(α, β) :=
begin
  have H : (⋃ i, S i) = set.univ,
  { rw set.eq_univ_iff_forall,
    intros x,
    rw set.mem_Union,
    obtain ⟨i, hi⟩ := hS x,
    exact ⟨i, mem_of_mem_nhds hi⟩ },
  refine ⟨set.lift_cover S (λ i, φ i) hφ H, continuous_subtype_nhds_cover hS _⟩,
  intros i,
  convert (φ i).continuous,
  ext x,
  exact set.lift_cover_coe x,
end

variables {S φ hφ hS}

@[simp] lemma lift_cover_coe {i : ι} (x : S i) : lift_cover S φ hφ hS x = φ i x :=
set.lift_cover_coe _

@[simp] lemma lift_cover_restrict {i : ι} : (lift_cover S φ hφ hS).restrict (S i) = φ i :=
ext $ lift_cover_coe

omit hφ hS

variables (A : set (set α))
  (F : Π (s : set α) (hi : s ∈ A), C(s, β))
  (hF : ∀ s (hs : s ∈ A) t (ht : t ∈ A) (x : α) (hxi : x ∈ s) (hxj : x ∈ t),
    F s hs ⟨x, hxi⟩ = F t ht ⟨x, hxj⟩)
  (hA : ∀ x : α, ∃ i ∈ A, i ∈ nhds x)

include hF hA

/-- A family `F s` of continuous maps `C(s, β)`, where (1) the domains `s` are taken from a set `A`
of sets in `α` which contain a neighbourhood of each point in `α` and (2) the functions `F s` agree
pairwise on intersections, can be glued to construct a continuous map in `C(α, β)`. -/
noncomputable def lift_cover' : C(α, β) :=
begin
  let S : A → set α := coe,
  let F : Π i : A, C(i, β) := λ i, F i i.prop,
  refine lift_cover S F (λ i j, hF i i.prop j j.prop) _,
  intros x,
  obtain ⟨s, hs, hsx⟩ := hA x,
  exact ⟨⟨s, hs⟩, hsx⟩
end

variables {A F hF hA}

@[simp] lemma lift_cover_coe' {s : set α} {hs : s ∈ A} (x : s) :
  lift_cover' A F hF hA x = F s hs x :=
let x' : (coe : A → set α) ⟨s, hs⟩ := x in lift_cover_coe x'

@[simp] lemma lift_cover_restrict' {s : set α} {hs : s ∈ A} :
  (lift_cover' A F hF hA).restrict s = F s hs :=
ext $ lift_cover_coe'

end gluing

end continuous_map

/--
The forward direction of a homeomorphism, as a bundled continuous map.
-/
@[simps]
def homeomorph.to_continuous_map {α β : Type*} [topological_space α] [topological_space β]
  (e : α ≃ₜ β) : C(α, β) := ⟨e⟩


/-
Copyright (c) 2020 Paul van Wamelen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul van Wamelen
-/
import algebra.field.basic
import ring_theory.int.basic
import algebra.group_with_zero.power
import tactic.ring
import tactic.ring_exp
import tactic.field_simp
import data.zmod.basic

/-!
# Pythagorean Triples

The main result is the classification of Pythagorean triples. The final result is for general
Pythagorean triples. It follows from the more interesting relatively prime case. We use the
"rational parametrization of the circle" method for the proof. The parametrization maps the point
`(x / z, y / z)` to the slope of the line through `(-1 , 0)` and `(x / z, y / z)`. This quickly
shows that `(x / z, y / z) = (2 * m * n / (m ^ 2 + n ^ 2), (m ^ 2 - n ^ 2) / (m ^ 2 + n ^ 2))` where
`m / n` is the slope. In order to identify numerators and denominators we now need results showing
that these are coprime. This is easy except for the prime 2. In order to deal with that we have to
analyze the parity of `x`, `y`, `m` and `n` and eliminate all the impossible cases. This takes up
the bulk of the proof below.
-/

lemma sq_ne_two_fin_zmod_four (z : zmod 4) : z * z ≠ 2 :=
begin
  change fin 4 at z,
  fin_cases z; norm_num [fin.ext_iff, fin.coe_bit0, fin.coe_bit1]
end

lemma int.sq_ne_two_mod_four (z : ℤ) : (z * z) % 4 ≠ 2 :=
suffices ¬ (z * z) % (4 : ℕ) = 2 % (4 : ℕ), by norm_num at this,
begin
  rw ← zmod.int_coe_eq_int_coe_iff',
  simpa using sq_ne_two_fin_zmod_four _
end

noncomputable theory
open_locale classical

/-- Three integers `x`, `y`, and `z` form a Pythagorean triple if `x * x + y * y = z * z`. -/
def pythagorean_triple (x y z : ℤ) : Prop := x * x + y * y = z * z

/-- Pythagorean triples are interchangable, i.e `x * x + y * y = y * y + x * x = z * z`.
This comes from additive commutativity. -/
lemma pythagorean_triple_comm {x y z : ℤ} :
 (pythagorean_triple x y z) ↔ (pythagorean_triple y x z) :=
by { delta pythagorean_triple, rw add_comm }

/-- The zeroth Pythagorean triple is all zeros. -/
lemma pythagorean_triple.zero : pythagorean_triple 0 0 0 :=
by simp only [pythagorean_triple, zero_mul, zero_add]

namespace pythagorean_triple

variables {x y z : ℤ} (h : pythagorean_triple x y z)

include h

lemma eq : x * x + y * y = z * z := h

@[symm]
lemma symm :
  pythagorean_triple y x z :=
by rwa [pythagorean_triple_comm]

/-- A triple is still a triple if you multiply `x`, `y` and `z`
by a constant `k`. -/
lemma mul (k : ℤ) : pythagorean_triple (k * x) (k * y) (k * z) :=
calc (k * x) * (k * x) + (k * y) * (k * y)
      = k ^ 2 * (x * x + y * y) : by ring
  ... = k ^ 2 * (z * z)         : by rw h.eq
  ... = (k * z) * (k * z)       : by ring

omit h

/-- `(k*x, k*y, k*z)` is a Pythagorean triple if and only if
`(x, y, z)` is also a triple. -/
lemma mul_iff (k : ℤ) (hk : k ≠ 0) :
  pythagorean_triple (k * x) (k * y) (k * z) ↔ pythagorean_triple x y z :=
begin
  refine ⟨_, λ h, h.mul k⟩,
  simp only [pythagorean_triple],
  intro h,
  rw ← mul_left_inj' (mul_ne_zero hk hk),
  convert h using 1; ring,
end

include h

/-- A Pythagorean triple `x, y, z` is “classified” if there exist integers `k, m, n` such that
either
 * `x = k * (m ^ 2 - n ^ 2)` and `y = k * (2 * m * n)`, or
 * `x = k * (2 * m * n)` and `y = k * (m ^ 2 - n ^ 2)`. -/
@[nolint unused_arguments] def is_classified := ∃ (k m n : ℤ),
  ((x = k * (m ^ 2 - n ^ 2) ∧ y = k * (2 * m * n))
    ∨ (x = k * (2 * m * n) ∧ y = k * (m ^ 2 - n ^ 2)))
  ∧ int.gcd m n = 1

/-- A primitive pythogorean triple `x, y, z` is a pythagorean triple with `x` and `y` coprime.
 Such a triple is “primitively classified” if there exist coprime integers `m, n` such that either
 * `x = m ^ 2 - n ^ 2` and `y = 2 * m * n`, or
 * `x = 2 * m * n` and `y = m ^ 2 - n ^ 2`.
-/
@[nolint unused_arguments] def is_primitive_classified := ∃ (m n : ℤ),
  ((x = m ^ 2 - n ^ 2 ∧ y = 2 * m * n)
    ∨ (x = 2 * m * n ∧ y = m ^ 2 - n ^ 2))
  ∧ int.gcd m n = 1
  ∧ ((m % 2 = 0 ∧ n % 2 = 1) ∨ (m % 2 = 1 ∧ n % 2 = 0))

lemma mul_is_classified (k : ℤ) (hc : h.is_classified) : (h.mul k).is_classified :=
begin
  obtain ⟨l, m, n, ⟨⟨rfl, rfl⟩ | ⟨rfl, rfl⟩, co⟩⟩ := hc,
  { use [k * l, m, n], apply and.intro _ co, left, split; ring },
  { use [k * l, m, n], apply and.intro _ co, right, split; ring },
end

lemma even_odd_of_coprime (hc : int.gcd x y = 1) :
  (x % 2 = 0 ∧ y % 2 = 1) ∨ (x % 2 = 1 ∧ y % 2 = 0) :=
begin
  cases int.mod_two_eq_zero_or_one x with hx hx;
    cases int.mod_two_eq_zero_or_one y with hy hy,
  { -- x even, y even
    exfalso,
    apply nat.not_coprime_of_dvd_of_dvd (dec_trivial : 1 < 2) _ _ hc,
    { apply int.dvd_nat_abs_of_of_nat_dvd, apply int.dvd_of_mod_eq_zero hx },
    { apply int.dvd_nat_abs_of_of_nat_dvd, apply int.dvd_of_mod_eq_zero hy } },
  { left, exact ⟨hx, hy⟩ },  -- x even, y odd
  { right, exact ⟨hx, hy⟩ }, -- x odd, y even
  { -- x odd, y odd
    exfalso,
    obtain ⟨x0, y0, rfl, rfl⟩ : ∃ x0 y0, x = x0* 2 + 1 ∧ y = y0 * 2 + 1,
    { cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hx) with x0 hx2,
      cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hy) with y0 hy2,
      rw sub_eq_iff_eq_add at hx2 hy2, exact ⟨x0, y0, hx2, hy2⟩ },
    apply int.sq_ne_two_mod_four z,
    rw show z * z = 4 * (x0 * x0 + x0 + y0 * y0 + y0) + 2, by { rw ← h.eq, ring },
    norm_num [int.add_mod] }
end

lemma gcd_dvd : (int.gcd x y : ℤ) ∣ z :=
begin
  by_cases h0 : int.gcd x y = 0,
  { have hx : x = 0, { apply int.nat_abs_eq_zero.mp, apply nat.eq_zero_of_gcd_eq_zero_left h0 },
    have hy : y = 0, { apply int.nat_abs_eq_zero.mp, apply nat.eq_zero_of_gcd_eq_zero_right h0 },
    have hz : z = 0,
    { simpa only [pythagorean_triple, hx, hy, add_zero, zero_eq_mul, mul_zero, or_self] using h },
    simp only [hz, dvd_zero], },
  obtain ⟨k, x0, y0, k0, h2, rfl, rfl⟩ :
    ∃ (k : ℕ) x0 y0, 0 < k ∧ int.gcd x0 y0 = 1 ∧ x = x0 * k ∧ y = y0 * k :=
    int.exists_gcd_one' (nat.pos_of_ne_zero h0),
  rw [int.gcd_mul_right, h2, int.nat_abs_of_nat, one_mul],
  rw [← int.pow_dvd_pow_iff (dec_trivial : 0 < 2), sq z, ← h.eq],
  rw (by ring : x0 * k * (x0 * k) + y0 * k * (y0 * k) = k ^ 2 * (x0 * x0 + y0 * y0)),
  exact dvd_mul_right _ _
end

lemma normalize : pythagorean_triple (x / int.gcd x y) (y / int.gcd x y) (z / int.gcd x y) :=
begin
  by_cases h0 : int.gcd x y = 0,
  { have hx : x = 0, { apply int.nat_abs_eq_zero.mp, apply nat.eq_zero_of_gcd_eq_zero_left h0 },
    have hy : y = 0, { apply int.nat_abs_eq_zero.mp, apply nat.eq_zero_of_gcd_eq_zero_right h0 },
    have hz : z = 0,
    { simpa only [pythagorean_triple, hx, hy, add_zero, zero_eq_mul, mul_zero, or_self] using h },
    simp only [hx, hy, hz, int.zero_div], exact zero },
  rcases h.gcd_dvd with ⟨z0, rfl⟩,
  obtain ⟨k, x0, y0, k0, h2, rfl, rfl⟩ :
    ∃ (k : ℕ) x0 y0, 0 < k ∧ int.gcd x0 y0 = 1 ∧ x = x0 * k ∧ y = y0 * k :=
    int.exists_gcd_one' (nat.pos_of_ne_zero h0),
  have hk : (k : ℤ) ≠ 0, { norm_cast, rwa pos_iff_ne_zero at k0 },
  rw [int.gcd_mul_right, h2, int.nat_abs_of_nat, one_mul] at h ⊢,
  rw [mul_comm x0, mul_comm y0, mul_iff k hk] at h,
  rwa [int.mul_div_cancel _ hk, int.mul_div_cancel _ hk, int.mul_div_cancel_left _ hk],
end

lemma is_classified_of_is_primitive_classified (hp : h.is_primitive_classified) :
  h.is_classified :=
begin
  obtain ⟨m, n, H⟩ := hp,
  use [1, m, n],
  rcases H with ⟨t, co, pp⟩,
  rw [one_mul, one_mul],
  exact ⟨t, co⟩,
end

lemma is_classified_of_normalize_is_primitive_classified
  (hc : h.normalize.is_primitive_classified) : h.is_classified :=
begin
  convert h.normalize.mul_is_classified (int.gcd x y)
    (is_classified_of_is_primitive_classified h.normalize hc);
  rw int.mul_div_cancel',
  { exact int.gcd_dvd_left x y },
  { exact int.gcd_dvd_right x y },
  { exact h.gcd_dvd }
end

lemma ne_zero_of_coprime (hc : int.gcd x y = 1) : z ≠ 0 :=
begin
  suffices : 0 < z * z, { rintro rfl, norm_num at this },
  rw [← h.eq, ← sq, ← sq],
  have hc' : int.gcd x y ≠ 0, { rw hc, exact one_ne_zero },
  cases int.ne_zero_of_gcd hc' with hxz hyz,
  { apply lt_add_of_pos_of_le (sq_pos_of_ne_zero x hxz) (sq_nonneg y) },
  { apply lt_add_of_le_of_pos (sq_nonneg x) (sq_pos_of_ne_zero y hyz) }
end

lemma is_primitive_classified_of_coprime_of_zero_left (hc : int.gcd x y = 1) (hx : x = 0) :
  h.is_primitive_classified :=
begin
  subst x,
  change nat.gcd 0 (int.nat_abs y) = 1 at hc,
  rw [nat.gcd_zero_left (int.nat_abs y)] at hc,
  cases int.nat_abs_eq y with hy hy,
  { use [1, 0], rw [hy, hc, int.gcd_zero_right], norm_num },
  { use [0, 1], rw [hy, hc, int.gcd_zero_left], norm_num }
end

lemma coprime_of_coprime (hc : int.gcd x y = 1) : int.gcd y z = 1 :=
begin
  by_contradiction H,
  obtain ⟨p, hp, hpy, hpz⟩ := nat.prime.not_coprime_iff_dvd.mp H,
  apply hp.not_dvd_one,
  rw [← hc],
  apply nat.dvd_gcd (int.prime.dvd_nat_abs_of_coe_dvd_sq hp _ _) hpy,
  rw [sq, eq_sub_of_add_eq h],
  rw [← int.coe_nat_dvd_left] at hpy hpz,
  exact dvd_sub ((hpz).mul_right _) ((hpy).mul_right _),
end

end pythagorean_triple

section circle_equiv_gen
/-!
### A parametrization of the unit circle

For the classification of pythogorean triples, we will use a parametrization of the unit circle.
-/

variables {K : Type*} [field K]

/--  A parameterization of the unit circle that is useful for classifying Pythagorean triples.
 (To be applied in the case where `K = ℚ`.) -/
def circle_equiv_gen (hk : ∀ x : K, 1 + x^2 ≠ 0) :
  K ≃ {p : K × K // p.1^2 + p.2^2 = 1 ∧ p.2 ≠ -1} :=
{ to_fun := λ x, ⟨⟨2 * x / (1 + x^2), (1 - x^2) / (1 + x^2)⟩,
    by { field_simp [hk x, div_pow], ring },
    begin
      simp only [ne.def, div_eq_iff (hk x), ←neg_mul_eq_neg_mul, one_mul, neg_add,
        sub_eq_add_neg, add_left_inj],
      simpa only [eq_neg_iff_add_eq_zero, one_pow] using hk 1,
    end⟩,
  inv_fun := λ p, (p : K × K).1 / ((p : K × K).2 + 1),
  left_inv := λ x,
  begin
    have h2 : (1 + 1 : K) = 2 := rfl,
    have h3 : (2 : K) ≠ 0, { convert hk 1, rw [one_pow 2, h2] },
    field_simp [hk x, h2, add_assoc, add_comm, add_sub_cancel'_right, mul_comm],
  end,
  right_inv := λ ⟨⟨x, y⟩, hxy, hy⟩,
  begin
    change x ^ 2 + y ^ 2 = 1 at hxy,
    have h2 : y + 1 ≠ 0, { apply mt eq_neg_of_add_eq_zero, exact hy },
    have h3 : (y + 1) ^ 2 + x ^ 2 = 2 * (y + 1),
    { rw [(add_neg_eq_iff_eq_add.mpr hxy.symm).symm], ring },
    have h4 : (2 : K) ≠ 0, { convert hk 1, rw one_pow 2, refl },
    simp only [prod.mk.inj_iff, subtype.mk_eq_mk],
    split,
    { field_simp [h3], ring },
    { field_simp [h3], rw [← add_neg_eq_iff_eq_add.mpr hxy.symm], ring }
  end }

@[simp] lemma circle_equiv_apply (hk : ∀ x : K, 1 + x^2 ≠ 0) (x : K) :
  (circle_equiv_gen hk x : K × K) = ⟨2 * x / (1 + x^2), (1 - x^2) / (1 + x^2)⟩ := rfl

@[simp] lemma circle_equiv_symm_apply (hk : ∀ x : K, 1 + x^2 ≠ 0)
  (v : {p : K × K // p.1^2 + p.2^2 = 1 ∧ p.2 ≠ -1}) :
  (circle_equiv_gen hk).symm v = (v : K × K).1 / ((v : K × K).2 + 1) := rfl

end circle_equiv_gen

private lemma coprime_sq_sub_sq_add_of_even_odd {m n : ℤ} (h : int.gcd m n = 1)
  (hm : m % 2 = 0) (hn : n % 2 = 1) :
  int.gcd (m ^ 2 - n ^ 2) (m ^ 2 + n ^ 2) = 1 :=
begin
  by_contradiction H,
  obtain ⟨p, hp, hp1, hp2⟩ := nat.prime.not_coprime_iff_dvd.mp H,
  rw ← int.coe_nat_dvd_left at hp1 hp2,
  have h2m : (p : ℤ) ∣ 2 * m ^ 2, { convert dvd_add hp2 hp1, ring },
  have h2n : (p : ℤ) ∣ 2 * n ^ 2, { convert dvd_sub hp2 hp1, ring },
  have hmc : p = 2 ∨ p ∣ int.nat_abs m :=
    prime_two_or_dvd_of_dvd_two_mul_pow_self_two hp h2m,
  have hnc : p = 2 ∨ p ∣ int.nat_abs n :=
    prime_two_or_dvd_of_dvd_two_mul_pow_self_two hp h2n,
  by_cases h2 : p = 2,
  { have h3 : (m ^ 2 + n ^ 2) % 2 = 1, { norm_num [sq, int.add_mod, int.mul_mod, hm, hn] },
    have h4 : (m ^ 2 + n ^ 2) % 2 = 0, { apply int.mod_eq_zero_of_dvd, rwa h2 at hp2 },
    rw h4 at h3, exact zero_ne_one h3 },
  { apply hp.not_dvd_one,
    rw ← h,
    exact nat.dvd_gcd (or.resolve_left hmc h2) (or.resolve_left hnc h2), }
end

private lemma coprime_sq_sub_sq_add_of_odd_even {m n : ℤ} (h : int.gcd m n = 1)
  (hm : m % 2 = 1) (hn : n % 2 = 0):
  int.gcd (m ^ 2 - n ^ 2) (m ^ 2 + n ^ 2) = 1 :=
begin
  rw [int.gcd, ← int.nat_abs_neg (m ^ 2 - n ^ 2)],
  rw [(by ring : -(m ^ 2 - n ^ 2) = n ^ 2 - m ^ 2), add_comm],
  apply coprime_sq_sub_sq_add_of_even_odd _ hn hm, rwa [int.gcd_comm],
end

private lemma coprime_sq_sub_mul_of_even_odd {m n : ℤ} (h : int.gcd m n = 1)
  (hm : m % 2 = 0) (hn : n % 2 = 1) :
  int.gcd (m ^ 2 - n ^ 2) (2 * m * n) = 1 :=
begin
  by_contradiction H,
  obtain ⟨p, hp, hp1, hp2⟩ := nat.prime.not_coprime_iff_dvd.mp H,
  rw ← int.coe_nat_dvd_left at hp1 hp2,
  have hnp : ¬ (p : ℤ) ∣ int.gcd m n,
  { rw h, norm_cast, exact mt nat.dvd_one.mp (nat.prime.ne_one hp) },
  cases int.prime.dvd_mul hp hp2 with hp2m hpn,
  { rw int.nat_abs_mul at hp2m,
    cases (nat.prime.dvd_mul hp).mp hp2m with hp2 hpm,
    { have hp2' : p = 2 := (nat.le_of_dvd zero_lt_two hp2).antisymm hp.two_le,
      revert hp1, rw hp2',
      apply mt int.mod_eq_zero_of_dvd,
      norm_num [sq, int.sub_mod, int.mul_mod, hm, hn] },
    apply mt (int.dvd_gcd (int.coe_nat_dvd_left.mpr hpm)) hnp,
    apply (or_self _).mp, apply int.prime.dvd_mul' hp,
    rw (by ring : n * n = - (m ^ 2 - n ^ 2) + m * m),
    apply dvd_add (dvd_neg_of_dvd hp1),
    exact dvd_mul_of_dvd_left (int.coe_nat_dvd_left.mpr hpm) m },
  rw int.gcd_comm at hnp,
  apply mt (int.dvd_gcd (int.coe_nat_dvd_left.mpr hpn)) hnp,
  apply (or_self _).mp, apply int.prime.dvd_mul' hp,
  rw (by ring : m * m = (m ^ 2 - n ^ 2) + n * n),
  apply dvd_add hp1,
  exact (int.coe_nat_dvd_left.mpr hpn).mul_right n
end

private lemma coprime_sq_sub_mul_of_odd_even {m n : ℤ} (h : int.gcd m n = 1)
  (hm : m % 2 = 1) (hn : n % 2 = 0) :
  int.gcd (m ^ 2 - n ^ 2) (2 * m * n) = 1 :=
begin
  rw [int.gcd, ← int.nat_abs_neg (m ^ 2 - n ^ 2)],
  rw [(by ring : 2 * m * n = 2 * n * m), (by ring : -(m ^ 2 - n ^ 2) = n ^ 2 - m ^ 2)],
  apply coprime_sq_sub_mul_of_even_odd _ hn hm, rwa [int.gcd_comm]
end

private lemma coprime_sq_sub_mul {m n : ℤ} (h : int.gcd m n = 1)
  (hmn : (m % 2 = 0 ∧ n % 2 = 1) ∨ (m % 2 = 1 ∧ n % 2 = 0)) :
  int.gcd (m ^ 2 - n ^ 2) (2 * m * n) = 1 :=
begin
  cases hmn with h1 h2,
  { exact coprime_sq_sub_mul_of_even_odd h h1.left h1.right },
  { exact coprime_sq_sub_mul_of_odd_even h h2.left h2.right }
end

private lemma coprime_sq_sub_sq_sum_of_odd_odd {m n : ℤ} (h : int.gcd m n = 1)
  (hm : m % 2 = 1) (hn : n % 2 = 1) :
  2 ∣ m ^ 2 + n ^ 2
  ∧ 2 ∣ m ^ 2 - n ^ 2
  ∧ ((m ^ 2 - n ^ 2) / 2) % 2 = 0
  ∧ int.gcd ((m ^ 2 - n ^ 2) / 2) ((m ^ 2 + n ^ 2) / 2) = 1 :=
begin
  cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hm) with m0 hm2,
  cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hn) with n0 hn2,
  rw sub_eq_iff_eq_add at hm2 hn2, subst m, subst n,
  have h1 : (m0 * 2 + 1) ^ 2 + (n0 * 2 + 1) ^ 2 = 2 * (2 * (m0 ^ 2 + n0 ^ 2 + m0 + n0) + 1),
  by ring_exp,
  have h2 : (m0 * 2 + 1) ^ 2 - (n0 * 2 + 1) ^ 2 = 2 * (2 * (m0 ^ 2 - n0 ^ 2 + m0 - n0)),
  by ring_exp,
  have h3 : ((m0 * 2 + 1) ^ 2 - (n0 * 2 + 1) ^ 2) / 2 % 2 = 0,
  { rw [h2, int.mul_div_cancel_left, int.mul_mod_right], exact dec_trivial },
  refine ⟨⟨_, h1⟩, ⟨_, h2⟩, h3, _⟩,
  have h20 : (2:ℤ) ≠ 0 := dec_trivial,
  rw [h1, h2, int.mul_div_cancel_left _ h20, int.mul_div_cancel_left _ h20],
  by_contra h4,
  obtain ⟨p, hp, hp1, hp2⟩ := nat.prime.not_coprime_iff_dvd.mp h4,
  apply hp.not_dvd_one,
  rw ← h,
  rw ← int.coe_nat_dvd_left at hp1 hp2,
  apply nat.dvd_gcd,
  { apply int.prime.dvd_nat_abs_of_coe_dvd_sq hp,
    convert dvd_add hp1 hp2, ring_exp },
  { apply int.prime.dvd_nat_abs_of_coe_dvd_sq hp,
    convert dvd_sub hp2 hp1, ring_exp },
end

namespace pythagorean_triple

variables {x y z : ℤ} (h : pythagorean_triple x y z)

include h

theorem is_primitive_classified_of_coprime_of_odd_of_pos
  (hc : int.gcd x y = 1) (hyo : y % 2 = 1) (hzpos : 0 < z) :
  h.is_primitive_classified :=
begin
  by_cases h0 : x = 0, { exact h.is_primitive_classified_of_coprime_of_zero_left hc h0 },
  let v := (x : ℚ) / z,
  let w := (y : ℚ) / z,
  have hz : z ≠ 0, apply ne_of_gt hzpos,
  have hq : v ^ 2 + w ^ 2 = 1,
  { field_simp [hz, sq], norm_cast, exact h },
  have hvz : v ≠ 0, { field_simp [hz], exact h0 },
  have hw1 : w ≠ -1,
  { contrapose! hvz with hw1,
    rw [hw1, neg_sq, one_pow, add_left_eq_self] at hq,
    exact pow_eq_zero hq, },
  have hQ : ∀ x : ℚ, 1 + x^2 ≠ 0,
  { intro q, apply ne_of_gt, exact lt_add_of_pos_of_le zero_lt_one (sq_nonneg q) },
  have hp : (⟨v, w⟩ : ℚ × ℚ) ∈ {p : ℚ × ℚ | p.1^2 + p.2^2 = 1 ∧ p.2 ≠ -1} := ⟨hq, hw1⟩,
  let q := (circle_equiv_gen hQ).symm ⟨⟨v, w⟩, hp⟩,
  have ht4 : v = 2 * q / (1 + q ^ 2) ∧ w = (1 - q ^ 2) / (1 + q ^ 2),
  { apply prod.mk.inj,
    have := ((circle_equiv_gen hQ).apply_symm_apply ⟨⟨v, w⟩, hp⟩).symm,
    exact congr_arg subtype.val this, },
  let m := (q.denom : ℤ),
  let n := q.num,
  have hm0 : m ≠ 0, { norm_cast, apply rat.denom_ne_zero q },
  have hq2 : q = n / m := (rat.num_div_denom q).symm,
  have hm2n2 : 0 < m ^ 2 + n ^ 2,
  { apply lt_add_of_pos_of_le _ (sq_nonneg n),
    exact lt_of_le_of_ne (sq_nonneg m) (ne.symm (pow_ne_zero 2 hm0)) },
  have hw2 : w = (m ^ 2 - n ^ 2) / (m ^ 2 + n ^ 2),
  { rw [ht4.2, hq2], field_simp [hm2n2, rat.denom_ne_zero q, -rat.num_div_denom] },
  have hm2n20 : (m : ℚ) ^ 2 + (n : ℚ) ^ 2 ≠ 0,
  { norm_cast, simpa only [int.coe_nat_pow] using ne_of_gt hm2n2 },
  have hv2 : v = 2 * m * n / (m ^ 2 + n ^ 2),
  { apply eq.symm, apply (div_eq_iff hm2n20).mpr, rw [ht4.1], field_simp [hQ q],
    rw [hq2] {occs := occurrences.pos [2, 3]},
    field_simp [rat.denom_ne_zero q, -rat.num_div_denom],
    ring },
  have hnmcp : int.gcd n m = 1 := q.cop,
  have hmncp : int.gcd m n = 1, { rw int.gcd_comm, exact hnmcp },
  cases int.mod_two_eq_zero_or_one m with hm2 hm2;
    cases int.mod_two_eq_zero_or_one n with hn2 hn2,
  { -- m even, n even
    exfalso,
    have h1 : 2 ∣ (int.gcd n m : ℤ),
    { exact int.dvd_gcd (int.dvd_of_mod_eq_zero hn2) (int.dvd_of_mod_eq_zero hm2) },
    rw hnmcp at h1, revert h1, norm_num },
  { -- m even, n odd
    apply h.is_primitive_classified_aux hc hzpos hm2n2 hv2 hw2 _ hmncp,
    { apply or.intro_left, exact and.intro hm2 hn2 },
    { apply coprime_sq_sub_sq_add_of_even_odd hmncp hm2 hn2 } },
  { -- m odd, n even
    apply h.is_primitive_classified_aux hc hzpos hm2n2 hv2 hw2 _ hmncp,
    { apply or.intro_right, exact and.intro hm2 hn2 },
    apply coprime_sq_sub_sq_add_of_odd_even hmncp hm2 hn2 },
  { -- m odd, n odd
    exfalso,
    have h1 : 2 ∣ m ^ 2 + n ^ 2 ∧ 2 ∣ m ^ 2 - n ^ 2
      ∧ ((m ^ 2 - n ^ 2) / 2) % 2 = 0 ∧ int.gcd ((m ^ 2 - n ^ 2) / 2) ((m ^ 2 + n ^ 2) / 2) = 1,
    { exact coprime_sq_sub_sq_sum_of_odd_odd hmncp hm2 hn2 },
    have h2 : y = (m ^ 2 - n ^ 2) / 2 ∧ z = (m ^ 2 + n ^ 2) / 2,
    { apply rat.div_int_inj hzpos _ (h.coprime_of_coprime hc) h1.2.2.2,
      { show w = _, rw [←rat.mk_eq_div, ←(rat.div_mk_div_cancel_left (by norm_num : (2 : ℤ) ≠ 0))],
        rw [int.div_mul_cancel h1.1, int.div_mul_cancel h1.2.1, hw2], norm_cast },
      { apply (mul_lt_mul_right (by norm_num : 0 < (2 : ℤ))).mp,
        rw [int.div_mul_cancel h1.1, zero_mul], exact hm2n2 } },
    rw [h2.1, h1.2.2.1] at hyo,
    revert hyo,
    norm_num }
end

theorem is_primitive_classified_of_coprime_of_pos (hc : int.gcd x y = 1) (hzpos : 0 < z):
  h.is_primitive_classified :=
begin
  cases h.even_odd_of_coprime hc with h1 h2,
  { exact (h.is_primitive_classified_of_coprime_of_odd_of_pos hc h1.right hzpos) },
  rw int.gcd_comm at hc,
  obtain ⟨m, n, H⟩ := (h.symm.is_primitive_classified_of_coprime_of_odd_of_pos hc h2.left hzpos),
  use [m, n], tauto
end

theorem is_primitive_classified_of_coprime (hc : int.gcd x y = 1) : h.is_primitive_classified :=
begin
  by_cases hz : 0 < z,
  { exact h.is_primitive_classified_of_coprime_of_pos hc hz },
  have h' : pythagorean_triple x y (-z),
  { simpa [pythagorean_triple, neg_mul_neg] using h.eq, },
  apply h'.is_primitive_classified_of_coprime_of_pos hc,
  apply lt_of_le_of_ne _ (h'.ne_zero_of_coprime hc).symm,
  exact le_neg.mp (not_lt.mp hz)
end

theorem classified : h.is_classified :=
begin
  by_cases h0 : int.gcd x y = 0,
  { have hx : x = 0, { apply int.nat_abs_eq_zero.mp, apply nat.eq_zero_of_gcd_eq_zero_left h0 },
    have hy : y = 0, { apply int.nat_abs_eq_zero.mp, apply nat.eq_zero_of_gcd_eq_zero_right h0 },
    use [0, 1, 0], norm_num [hx, hy], },
  apply h.is_classified_of_normalize_is_primitive_classified,
  apply h.normalize.is_primitive_classified_of_coprime,
  apply int.gcd_div_gcd_div_gcd (nat.pos_of_ne_zero h0),
end

omit h

theorem coprime_classification :
  pythagorean_triple x y z ∧ int.gcd x y = 1 ↔
  ∃ m n, ((x = m ^ 2 - n ^ 2 ∧ y = 2 * m * n) ∨
            (x = 2 * m * n ∧ y = m ^ 2 - n ^ 2))
          ∧ (z = m ^ 2 + n ^ 2 ∨ z = - (m ^ 2 + n ^ 2))
          ∧ int.gcd m n = 1
          ∧ ((m % 2 = 0 ∧ n % 2 = 1) ∨ (m % 2 = 1 ∧ n % 2 = 0)) :=
begin
  split,
  { intro h,
    obtain ⟨m, n, H⟩ := h.left.is_primitive_classified_of_coprime h.right,
    use [m, n],
    rcases H with ⟨⟨rfl, rfl⟩ | ⟨rfl, rfl⟩, co, pp⟩,
    { refine ⟨or.inl ⟨rfl, rfl⟩, _, co, pp⟩,
      have : z ^ 2 = (m ^ 2 + n ^ 2) ^ 2,
      { rw [sq, ← h.left.eq], ring },
      simpa using eq_or_eq_neg_of_sq_eq_sq _ _ this },
    { refine ⟨or.inr ⟨rfl, rfl⟩, _, co, pp⟩,
      have : z ^ 2 = (m ^ 2 + n ^ 2) ^ 2,
      { rw [sq, ← h.left.eq], ring },
      simpa using eq_or_eq_neg_of_sq_eq_sq _ _ this } },
  { delta pythagorean_triple,
    rintro ⟨m, n, ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩, rfl | rfl, co, pp⟩;
    { split, { ring }, exact coprime_sq_sub_mul co pp }
    <|>
    { split, { ring }, rw int.gcd_comm, exact coprime_sq_sub_mul co pp } }
end

/-- by assuming `x` is odd and `z` is positive we get a slightly more precise classification of
the pythagorean triple `x ^ 2 + y ^ 2 = z ^ 2`-/
theorem coprime_classification' {x y z : ℤ} (h : pythagorean_triple x y z)
  (h_coprime : int.gcd x y = 1) (h_parity : x % 2 = 1) (h_pos : 0 < z) :
  ∃ m n,  x = m ^ 2 - n ^ 2
        ∧ y = 2 * m * n
        ∧ z = m ^ 2 + n ^ 2
        ∧ int.gcd m n = 1
        ∧ ((m % 2 = 0 ∧ n % 2 = 1) ∨ (m % 2 = 1 ∧ n % 2 = 0))
        ∧ 0 ≤ m :=
begin
  obtain ⟨m, n, ht1, ht2, ht3, ht4⟩ :=
    pythagorean_triple.coprime_classification.mp (and.intro h h_coprime),
  cases le_or_lt 0 m with hm hm,
  { use [m, n],
    cases ht1 with h_odd h_even,
    { apply and.intro h_odd.1,
      apply and.intro h_odd.2,
      cases ht2 with h_pos h_neg,
      { apply and.intro h_pos (and.intro ht3 (and.intro ht4 hm)) },
      { exfalso, revert h_pos, rw h_neg,
        exact imp_false.mpr (not_lt.mpr (neg_nonpos.mpr (add_nonneg (sq_nonneg m)
          (sq_nonneg n)))) } },
    exfalso,
    rcases h_even with ⟨rfl, -⟩,
    rw [mul_assoc, int.mul_mod_right] at h_parity,
    exact zero_ne_one h_parity },
  { use [-m, -n],
    cases ht1 with h_odd h_even,
    { rw [neg_sq m],
      rw [neg_sq n],
      apply and.intro h_odd.1,
      split, { rw h_odd.2, ring },
      cases ht2 with h_pos h_neg,
      { apply and.intro h_pos,
        split,
        { delta int.gcd, rw [int.nat_abs_neg, int.nat_abs_neg], exact ht3 },
        { rw [int.neg_mod_two, int.neg_mod_two],
          apply and.intro ht4, linarith } },
      { exfalso, revert h_pos, rw h_neg,
        exact imp_false.mpr (not_lt.mpr (neg_nonpos.mpr (add_nonneg (sq_nonneg m)
          (sq_nonneg n)))) } },
    exfalso,
    rcases h_even with ⟨rfl, -⟩,
    rw [mul_assoc, int.mul_mod_right] at h_parity,
    exact zero_ne_one h_parity }
end

/-- **Formula for Pythagorean Triples** -/
theorem classification :
  pythagorean_triple x y z ↔
  ∃ k m n, ((x = k * (m ^ 2 - n ^ 2) ∧ y = k * (2 * m * n)) ∨
            (x = k * (2 * m * n) ∧ y = k * (m ^ 2 - n ^ 2)))
          ∧ (z = k * (m ^ 2 + n ^ 2) ∨ z = - k * (m ^ 2 + n ^ 2)) :=
begin
  split,
  { intro h,
    obtain ⟨k, m, n, H⟩ := h.classified,
    use [k, m, n],
    rcases H with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩,
    { refine ⟨or.inl ⟨rfl, rfl⟩, _⟩,
      have : z ^ 2 = (k * (m ^ 2 + n ^ 2)) ^ 2,
      { rw [sq, ← h.eq], ring },
      simpa using eq_or_eq_neg_of_sq_eq_sq _ _ this },
    { refine ⟨or.inr ⟨rfl, rfl⟩, _⟩,
      have : z ^ 2 = (k * (m ^ 2 + n ^ 2)) ^ 2,
      { rw [sq, ← h.eq], ring },
      simpa using eq_or_eq_neg_of_sq_eq_sq _ _ this } },
  { rintro ⟨k, m, n, ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩, rfl | rfl⟩;
    delta pythagorean_triple; ring }
end

end pythagorean_triple


import LeanCodePrompts.TacticExtraction

theorem Nat.add_assoc' : ∀ a b c : Nat, a + b + c = a + (b + c) := by
  intro a
  intro b
  intro c
  apply Eq.symm
  apply Eq.symm
  rw [Nat.add_assoc]

theorem Nat.eq_self : ∀ n : Nat, n = n := by
  intro n
  cases n
  · rfl
  · simp

theorem add_zero_add : ∀ n : Nat, m + (0 + n + 0) = n + m := by
  simp [Nat.add_comm]


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Calle Sönne, Adam Topaz
-/
import topology.separation
import topology.subset_properties
import topology.locally_constant.basic

/-!

# Discrete quotients of a topological space.

This file defines the type of discrete quotients of a topological space,
denoted `discrete_quotient X`. To avoid quantifying over types, we model such
quotients as setoids whose equivalence classes are clopen.

## Definitions
1. `discrete_quotient X` is the type of discrete quotients of `X`.
  It is endowed with a coercion to `Type`, which is defined as the
  quotient associated to the setoid in question, and each such quotient
  is endowed with the discrete topology.
2. Given `S : discrete_quotient X`, the projection `X → S` is denoted
  `S.proj`.
3. When `X` is compact and `S : discrete_quotient X`, the space `S` is
  endowed with a `fintype` instance.

## Order structure
The type `discrete_quotient X` is endowed with an instance of a `semilattice_inf` with `order_top`.
The partial ordering `A ≤ B` mathematically means that `B.proj` factors through `A.proj`.
The top element `⊤` is the trivial quotient, meaning that every element of `X` is collapsed
to a point. Given `h : A ≤ B`, the map `A → B` is `discrete_quotient.of_le h`.
Whenever `X` is discrete, the type `discrete_quotient X` is also endowed with an instance of a
`semilattice_inf` with `order_bot`, where the bot element `⊥` is `X` itself.

Given `f : X → Y` and `h : continuous f`, we define a predicate `le_comap h A B` for
`A : discrete_quotient X` and `B : discrete_quotient Y`, asserting that `f` descends to `A → B`.
If `cond : le_comap h A B`, the function `A → B` is obtained by `discrete_quotient.map cond`.

## Theorems
The two main results proved in this file are:
1. `discrete_quotient.eq_of_proj_eq` which states that when `X` is compact, t2 and totally
  disconnected, any two elements of `X` agree if their projections in `Q` agree for all
  `Q : discrete_quotient X`.
2. `discrete_quotient.exists_of_compat` which states that when `X` is compact, then any
  system of elements of `Q` as `Q : discrete_quotient X` varies, which is compatible with
  respect to `discrete_quotient.of_le`, must arise from some element of `X`.

## Remarks
The constructions in this file will be used to show that any profinite space is a limit
of finite discrete spaces.
-/

variables (X : Type*) [topological_space X]

/-- The type of discrete quotients of a topological space. -/
@[ext]
structure discrete_quotient :=
(rel : X → X → Prop)
(equiv : equivalence rel)
(clopen : ∀ x, is_clopen (set_of (rel x)))

namespace discrete_quotient

variables {X} (S : discrete_quotient X)

/-- Construct a discrete quotient from a clopen set. -/
def of_clopen {A : set X} (h : is_clopen A) : discrete_quotient X :=
{ rel := λ x y, x ∈ A ∧ y ∈ A ∨ x ∉ A ∧ y ∉ A,
  equiv := ⟨by tauto!, by tauto!, by tauto!⟩,
  clopen := begin
    intros x,
    by_cases hx : x ∈ A,
    { apply is_clopen.union,
      { convert h,
        ext,
        exact ⟨λ i, i.2, λ i, ⟨hx,i⟩⟩ },
      { convert is_clopen_empty,
        tidy } },
    { apply is_clopen.union,
      { convert is_clopen_empty,
        tidy },
      { convert is_clopen.compl h,
        ext,
        exact ⟨λ i, i.2, λ i, ⟨hx, i⟩⟩ } },
  end }

/-- The setoid whose quotient yields the discrete quotient. -/
def setoid : setoid X := ⟨S.rel, S.equiv⟩

instance : has_coe_to_sort (discrete_quotient X) Type* :=
⟨λ S, quotient S.setoid⟩

instance : topological_space S := ⊥

/-- The projection from `X` to the given discrete quotient. -/
def proj : X → S := quotient.mk'

lemma proj_surjective : function.surjective S.proj := quotient.surjective_quotient_mk'

lemma fiber_eq (x : X) : S.proj ⁻¹' {S.proj x} = set_of (S.rel x) :=
begin
  ext1 y,
  simp only [set.mem_preimage, set.mem_singleton_iff, quotient.eq',
    discrete_quotient.proj.equations._eqn_1, set.mem_set_of_eq],
  exact ⟨λ h, S.symm _ _ h, λ h, S.symm _ _ h⟩,
end

lemma proj_is_locally_constant : is_locally_constant S.proj :=
begin
   rw (is_locally_constant.tfae S.proj).out 0 3,
   intros x,
   rcases S.proj_surjective x with ⟨x,rfl⟩,
   simp [fiber_eq, (S.clopen x).1],
end

lemma proj_continuous : continuous S.proj :=
is_locally_constant.continuous $ proj_is_locally_constant _

lemma fiber_closed (A : set S) : is_closed (S.proj ⁻¹' A) :=
is_closed.preimage S.proj_continuous ⟨trivial⟩

lemma fiber_open (A : set S) : is_open (S.proj ⁻¹' A) :=
is_open.preimage S.proj_continuous trivial

lemma fiber_clopen (A : set S) : is_clopen (S.proj ⁻¹' A) := ⟨fiber_open _ _, fiber_closed _ _⟩

instance : partial_order (discrete_quotient X) :=
{ le := λ A B, ∀ x y : X, A.rel x y → B.rel x y,
  le_refl := λ a, by tauto,
  le_trans := λ a b c h1 h2, by tauto,
  le_antisymm := λ a b h1 h2, by { ext, tauto } }

instance : order_top (discrete_quotient X) :=
{ top := ⟨λ a b, true, ⟨by tauto, by tauto, by tauto⟩, λ _, is_clopen_univ⟩,
  le_top := λ a, by tauto }

instance : semilattice_inf (discrete_quotient X) :=
{ inf := λ A B,
  { rel := λ x y, A.rel x y ∧ B.rel x y,
    equiv := ⟨λ a, ⟨A.refl _,B.refl _⟩, λ a b h, ⟨A.symm _ _ h.1, B.symm _ _ h.2⟩,
      λ a b c h1 h2, ⟨A.trans _ _ _ h1.1 h2.1, B.trans _ _ _ h1.2 h2.2⟩⟩,
    clopen := λ x, is_clopen.inter (A.clopen _) (B.clopen _) },
  inf_le_left := λ a b, by tauto,
  inf_le_right := λ a b, by tauto,
  le_inf := λ a b c h1 h2, by tauto,
  ..discrete_quotient.partial_order }

instance : inhabited (discrete_quotient X) := ⟨⊤⟩

section comap

variables {Y : Type*} [topological_space Y] {f : Y → X} (cont : continuous f)

/-- Comap a discrete quotient along a continuous map. -/
def comap : discrete_quotient Y :=
{ rel := λ a b, S.rel (f a) (f b),
  equiv := ⟨λ a, S.refl _, λ a b h, S.symm _ _ h, λ a b c h1 h2, S.trans _ _ _ h1 h2⟩,
  clopen := λ y, ⟨is_open.preimage cont (S.clopen _).1, is_closed.preimage cont (S.clopen _).2⟩ }

@[simp]
lemma comap_id : S.comap (continuous_id : continuous (id : X → X)) = S := by { ext, refl }

@[simp]
lemma comap_comp {Z : Type*} [topological_space Z] {g : Z → Y} (cont' : continuous g) :
  S.comap (continuous.comp cont cont') = (S.comap cont).comap cont' := by { ext, refl }

lemma comap_mono {A B : discrete_quotient X} (h : A ≤ B) : A.comap cont ≤ B.comap cont :=
by tauto

end comap

section of_le

/-- The map induced by a refinement of a discrete quotient. -/
def of_le {A B : discrete_quotient X} (h : A ≤ B) : A → B :=
λ a, quotient.lift_on' a (λ x, B.proj x) (λ a b i, quotient.sound' (h _ _ i))

@[simp]
lemma of_le_refl {A : discrete_quotient X} : of_le (le_refl A) = id := by { ext ⟨⟩, refl }

lemma of_le_refl_apply {A : discrete_quotient X} (a : A) : of_le (le_refl A) a = a := by simp

@[simp]
lemma of_le_comp {A B C : discrete_quotient X} (h1 : A ≤ B) (h2 : B ≤ C) :
  of_le (le_trans h1 h2) = of_le h2 ∘ of_le h1 := by { ext ⟨⟩, refl }

lemma of_le_comp_apply {A B C : discrete_quotient X} (h1 : A ≤ B) (h2 : B ≤ C) (a : A) :
  of_le (le_trans h1 h2) a = of_le h2 (of_le h1 a) := by simp

lemma of_le_continuous {A B : discrete_quotient X} (h : A ≤ B) :
  continuous (of_le h) := continuous_of_discrete_topology

@[simp]
lemma of_le_proj {A B : discrete_quotient X} (h : A ≤ B) :
  of_le h ∘ A.proj = B.proj := by { ext, exact quotient.sound' (B.refl _) }

@[simp]
lemma of_le_proj_apply {A B : discrete_quotient X} (h : A ≤ B) (x : X) :
  of_le h (A.proj x) = B.proj x := by { change (of_le h ∘ A.proj) x = _, simp }

end of_le

/--
When X is discrete, there is a `order_bot` instance on `discrete_quotient X`
-/
instance [discrete_topology X] : order_bot (discrete_quotient X) :=
{ bot :=
  { rel := (=),
    equiv := eq_equivalence,
    clopen := λ x, is_clopen_discrete _ },
  bot_le := by { rintro S a b (h : a = b), rw h, exact S.refl _ } }

lemma proj_bot_injective [discrete_topology X] :
  function.injective (⊥ : discrete_quotient X).proj := λ a b h, quotient.exact' h

lemma proj_bot_bijective [discrete_topology X] :
  function.bijective (⊥ : discrete_quotient X).proj := ⟨proj_bot_injective, proj_surjective _⟩

section map

variables {Y : Type*} [topological_space Y] {f : Y → X}
  (cont : continuous f) (A : discrete_quotient Y) (B : discrete_quotient X)

/--
Given `cont : continuous f`, `le_comap cont A B` is defined as `A ≤ B.comap f`.
Mathematically this means that `f` descends to a morphism `A → B`.
-/
def le_comap : Prop := A ≤ B.comap cont

variables {cont A B}

lemma le_comap_id (A : discrete_quotient X) : le_comap continuous_id A A := by tauto

lemma le_comap_comp {Z : Type*} [topological_space Z] {g : Z → Y} {cont' : continuous g}
  {C : discrete_quotient Z} : le_comap cont' C A → le_comap cont A B →
  le_comap (continuous.comp cont cont') C B := by tauto

lemma le_comap_trans {C : discrete_quotient X} :
  le_comap cont A B → B ≤ C → le_comap cont A C := λ h1 h2, le_trans h1 $ comap_mono _ h2

/-- Map a discrete quotient along a continuous map. -/
def map (cond : le_comap cont A B) : A → B := quotient.map' f cond

lemma map_continuous (cond : le_comap cont A B) : continuous (map cond) :=
continuous_of_discrete_topology

@[simp]
lemma map_proj (cond : le_comap cont A B) : map cond ∘ A.proj = B.proj ∘ f := rfl

@[simp]
lemma map_proj_apply (cond : le_comap cont A B) (y : Y) : map cond (A.proj y) = B.proj (f y) := rfl

@[simp]
lemma map_id : map (le_comap_id A) = id := by { ext ⟨⟩, refl }

@[simp]
lemma map_comp {Z : Type*} [topological_space Z] {g : Z → Y} {cont' : continuous g}
  {C : discrete_quotient Z} (h1 : le_comap cont' C A) (h2 : le_comap cont A B) :
  map (le_comap_comp h1 h2) = map h2 ∘ map h1 := by { ext ⟨⟩, refl }

@[simp]
lemma of_le_map {C : discrete_quotient X} (cond : le_comap cont A B) (h : B ≤ C) :
   map (le_comap_trans cond h) = of_le h ∘ map cond := by { ext ⟨⟩, refl }

@[simp]
lemma of_le_map_apply {C : discrete_quotient X} (cond : le_comap cont A B) (h : B ≤ C) (a : A) :
  map (le_comap_trans cond h) a = of_le h (map cond a) := by { rcases a, refl }

@[simp]
lemma map_of_le {C : discrete_quotient Y} (cond : le_comap cont A B) (h : C ≤ A) :
   map (le_trans h cond) = map cond ∘ of_le h := by { ext ⟨⟩, refl }

@[simp]
lemma map_of_le_apply {C : discrete_quotient Y} (cond : le_comap cont A B) (h : C ≤ A) (c : C) :
  map (le_trans h cond) c = map cond (of_le h c) := by { rcases c, refl }

end map

lemma eq_of_proj_eq [t2_space X] [compact_space X] [disc : totally_disconnected_space X]
  {x y : X} : (∀ Q : discrete_quotient X, Q.proj x = Q.proj y) → x = y :=
begin
  intro h,
  change x ∈ ({y} : set X),
  rw totally_disconnected_space_iff_connected_component_singleton at disc,
  rw [← disc y, connected_component_eq_Inter_clopen],
  rintros U ⟨⟨U, hU1, hU2⟩, rfl⟩,
  replace h : _ ∨ _ := quotient.exact' (h (of_clopen hU1)),
  tauto,
end

lemma fiber_le_of_le {A B : discrete_quotient X} (h : A ≤ B) (a : A) :
  A.proj ⁻¹' {a} ≤ B.proj ⁻¹' {of_le h a} :=
begin
  induction a,
  erw [fiber_eq, fiber_eq],
  tidy,
end

lemma exists_of_compat [compact_space X] (Qs : Π (Q : discrete_quotient X), Q)
  (compat : ∀ (A B : discrete_quotient X) (h : A ≤ B), of_le h (Qs _) = Qs _) :
  ∃ x : X, ∀ Q : discrete_quotient X, Q.proj x = Qs _ :=
begin
  obtain ⟨x,hx⟩ := is_compact.nonempty_Inter_of_directed_nonempty_compact_closed
    (λ (Q : discrete_quotient X), Q.proj ⁻¹' {Qs _}) (λ A B, _) (λ i, _)
    (λ i,  (fiber_closed _ _).is_compact) (λ i, fiber_closed _ _),
  { refine ⟨x, λ Q, _⟩,
    specialize hx _ ⟨Q,rfl⟩,
    dsimp at hx,
    rcases proj_surjective _ (Qs Q) with ⟨y,hy⟩,
    rw ← hy at *,
    rw fiber_eq at hx,
    exact quotient.sound' (Q.symm y x hx) },
  { refine ⟨A ⊓ B, λ a ha, _, λ a ha, _⟩,
    { dsimp only,
      erw ← compat (A ⊓ B) A inf_le_left,
      exact fiber_le_of_le _ _ ha },
    { dsimp only,
      erw ← compat (A ⊓ B) B inf_le_right,
      exact fiber_le_of_le _ _ ha } },
  { obtain ⟨x,hx⟩ := i.proj_surjective (Qs i),
    refine ⟨x,_⟩,
    dsimp only,
    rw [← hx, fiber_eq],
    apply i.refl },
end

noncomputable instance [compact_space X] : fintype S :=
begin
  have cond : is_compact (⊤ : set X) := compact_univ,
  rw is_compact_iff_finite_subcover at cond,
  have h := @cond S (λ s, S.proj ⁻¹' {s}) (λ s, fiber_open _ _)
    (λ x hx, ⟨S.proj ⁻¹' {S.proj x}, ⟨S.proj x, rfl⟩, rfl⟩),
  let T := classical.some h,
  have hT := classical.some_spec h,
  refine ⟨T,λ s, _⟩,
  rcases S.proj_surjective s with ⟨x,rfl⟩,
  rcases hT (by tauto : x ∈ ⊤) with ⟨j, ⟨j,rfl⟩, h1, ⟨hj, rfl⟩, h2⟩,
  dsimp only at h2,
  suffices : S.proj x = j, by rwa this,
  rcases j with ⟨j⟩,
  apply quotient.sound',
  erw fiber_eq at h2,
  exact S.symm _ _ h2
end

end discrete_quotient

namespace locally_constant

variables {X} {α : Type*} (f : locally_constant X α)

/-- Any locally constant function induces a discrete quotient. -/
def discrete_quotient : discrete_quotient X :=
{ rel := λ a b, f b = f a,
  equiv := ⟨by tauto, by tauto, λ a b c h1 h2, by rw [h2, h1]⟩,
  clopen := λ x, f.is_locally_constant.is_clopen_fiber _ }

/-- The function from the discrete quotient associated to a locally constant function. -/
def lift : f.discrete_quotient → α := λ a, quotient.lift_on' a f (λ a b h, h.symm)

lemma lift_is_locally_constant : _root_.is_locally_constant f.lift := λ A, trivial

/-- A locally constant version of `locally_constant.lift`. -/
def locally_constant_lift : locally_constant f.discrete_quotient α :=
⟨f.lift, f.lift_is_locally_constant⟩

@[simp]
lemma lift_eq_coe : f.lift = f.locally_constant_lift := rfl

@[simp]
lemma factors : f.locally_constant_lift ∘ f.discrete_quotient.proj = f := by { ext, refl }

end locally_constant


lemma zero_mul (m : mynat) : 0 * m = 0 :=
begin
induction m with a ha,
rw mul_zero,
refl,
rw mul_succ,
rw ha,
simp,
end


import data.nat.parity number_theory.arithmetic_function data.zmod.basic

/-! # IMO 2009 N2 -/

namespace IMOSL
namespace IMO2008N2

open nat.arithmetic_function function

/-- Final solution, part 1 -/
theorem final_solution_part1 (N : ℕ) :
  ∃ a b : ℕ, a ≠ b ∧ (∀ k : ℕ, k < N → even (card_factors ((a + k) * (b + k)))) :=
begin
  let f : ℕ → (fin N) → (zmod 2) := λ (a : ℕ) (k : fin N), card_factors (a + k),
  have h : ¬injective f := not_injective_infinite_finite f,
  simp only [injective, not_forall] at h,
  rcases h with ⟨a, b, h, h0⟩,
  refine ⟨a, b, h0, λ n h1, _⟩,
  replace h := congr_fun h ⟨n, h1⟩,
  dsimp only [f] at h; clear f,
  rw [fin.coe_mk, zmod.nat_coe_eq_nat_coe_iff'] at h,
  cases eq_or_ne (a + n) 0 with h2 h2,
  rw [h2, zero_mul, nat.arithmetic_function.map_zero]; exact even_zero,
  cases eq_or_ne (b + n) 0 with h3 h3,
  rw [h3, mul_zero, nat.arithmetic_function.map_zero]; exact even_zero,
  rw [card_factors_mul h2 h3, nat.even_add, nat.even_iff, nat.even_iff, h]
end

/-- Final solution, part 2 -/
theorem final_solution_part2 :
  ∀ {a b : ℕ}, (∀ k : ℕ, even (card_factors ((a + k) * (b + k)))) → a = b :=
begin
  ---- Use suffices since WLOG seems to be a bit slow
  suffices : ∀ {a b : ℕ}, (∀ k : ℕ, even (card_factors ((a + k) * (b + k)))) → a ≤ b → a = b,
  { intros a b h,
    cases le_total a b with h0 h0,
    exact this h h0,
    refine (this (λ k, _) h0).symm,
    rw mul_comm; exact h k },
  intros a b h h0,
  rw le_iff_exists_add at h0; rcases h0 with ⟨c, rfl⟩,
  by_contra h0; rw [self_eq_add_right, ← ne.def, ← zero_lt_iff] at h0,

  ---- Reduce to `Ω(k) ≡ Ω(k + 1) (mod 2)` for all `k ≥ a`
  suffices : ∀ k : ℕ, a ≤ k → (even (card_factors k) ↔ even (card_factors a)),
  { rcases a.exists_infinite_primes with ⟨p, h1, h2⟩,
    replace h0 := this p h1,
    rw [card_factors_apply_prime h2, ← this (p ^ 2), card_factors_apply_prime_pow h2] at h0,
    simp only [false_iff, not_true, even_two, nat.not_even_one] at h0; exact h0,
    rw sq; exact le_trans h1 (nat.le_mul_self p) },
  suffices : ∀ k : ℕ, a ≤ k → (even (card_factors k) ↔ even (card_factors (k + 1))),
  { refine (λ k, nat.le_induction (by refl) _ k),
    intros n h1 h2; rw [← this n h1, h2] },

  ---- Finishing
  intros k h1,
  rcases k.eq_zero_or_pos with rfl | h2,
  rw [nat.arithmetic_function.map_zero, zero_add, card_factors_one],
  replace h1 : a ≤ k * c := le_trans h1 ((le_mul_iff_one_le_right h2).mpr h0),
  rw le_iff_exists_add at h1; cases h1 with m h1,
  replace h := h m,
  rw zero_lt_iff at h0 h2,
  rw [add_right_comm, ← h1, ← add_one_mul, mul_mul_mul_comm, card_factors_mul,
      nat.even_add, card_factors_mul h2 k.succ_ne_zero, nat.even_add] at h,
  rw [h, card_factors_mul h0 h0, nat.even_add],
  exacts [mul_ne_zero h2 k.succ_ne_zero, mul_ne_zero h0 h0]
end

end IMO2008N2
end IMOSL


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

/-!
# Power basis

This file defines a structure `power_basis R S`, giving a basis of the
`R`-algebra `S` as a finite list of powers `1, x, ..., x^n`.
For example, if `x` is algebraic over a ring/field, adjoining `x`
gives a `power_basis` structure generated by `x`.

## Definitions

* `power_basis R A`: a structure containing an `x` and an `n` such that
`1, x, ..., x^n` is a basis for the `R`-algebra `A` (viewed as an `R`-module).

* `finrank (hf : f ≠ 0) : finite_dimensional.finrank K (adjoin_root f) = f.nat_degree`,
  the dimension of `adjoin_root f` equals the degree of `f`

* `power_basis.lift (pb : power_basis R S)`: if `y : S'` satisfies the same
  equations as `pb.gen`, this is the map `S →ₐ[R] S'` sending `pb.gen` to `y`

* `power_basis.equiv`: if two power bases satisfy the same equations, they are
  equivalent as algebras

## Implementation notes

Throughout this file, `R`, `S`, ... are `comm_ring`s, `A`, `B`, ... are
`integral_domain`s and `K`, `L`, ... are `field`s.
`S` is an `R`-algebra, `B` is an `A`-algebra, `L` is a `K`-algebra.

## Tags

power basis, powerbasis

-/

open polynomial

variables {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
variables [algebra R S] [algebra S T] [algebra R T] [is_scalar_tower R S T]
variables {A B : Type*} [integral_domain A] [integral_domain B] [algebra A B]
variables {K L : Type*} [field K] [field L] [algebra K L]

/-- `pb : power_basis R S` states that `1, pb.gen, ..., pb.gen ^ (pb.dim - 1)`
is a basis for the `R`-algebra `S` (viewed as `R`-module).

This is a structure, not a class, since the same algebra can have many power bases.
For the common case where `S` is defined by adjoining an integral element to `R`,
the canonical power basis is given by `{algebra,intermediate_field}.adjoin.power_basis`.
-/
@[nolint has_inhabited_instance]
structure power_basis (R S : Type*) [comm_ring R] [ring S] [algebra R S] :=
(gen : S)
(dim : ℕ)
(is_basis : is_basis R (λ (i : fin dim), gen ^ (i : ℕ)))

namespace power_basis

/-- Cannot be an instance because `power_basis` cannot be a class. -/
lemma finite_dimensional [algebra K S] (pb : power_basis K S) : finite_dimensional K S :=
finite_dimensional.of_fintype_basis pb.is_basis

lemma finrank [algebra K S] (pb : power_basis K S) : finite_dimensional.finrank K S = pb.dim :=
by rw [finite_dimensional.finrank_eq_card_basis pb.is_basis, fintype.card_fin]

/-- TODO: this mixes `polynomial` and `finsupp`, we should hide this behind a
new function `polynomial.of_finsupp`. -/
lemma polynomial.mem_supported_range {f : polynomial R} {d : ℕ} :
  (f : finsupp ℕ R) ∈ finsupp.supported R R (↑(finset.range d) : set ℕ) ↔ f.degree < d :=
by { simp_rw [finsupp.mem_supported', finset.mem_coe, finset.mem_range, not_lt,
              degree_lt_iff_coeff_zero],
     refl }

lemma mem_span_pow' {x y : S} {d : ℕ} :
  y ∈ submodule.span R (set.range (λ (i : fin d), x ^ (i : ℕ))) ↔
    ∃ f : polynomial R, f.degree < d ∧ y = aeval x f :=
begin
  have : set.range (λ (i : fin d), x ^ (i : ℕ)) = (λ (i : ℕ), x ^ i) '' ↑(finset.range d),
  { ext n,
    simp_rw [set.mem_range, set.mem_image, finset.mem_coe, finset.mem_range],
    exact ⟨λ ⟨⟨i, hi⟩, hy⟩, ⟨i, hi, hy⟩, λ ⟨i, hi, hy⟩, ⟨⟨i, hi⟩, hy⟩⟩ },
  rw [this, finsupp.mem_span_iff_total],
  -- In the next line we use that `polynomial R := finsupp ℕ R`.
  -- It would be nice to have a function `polynomial.of_finsupp`.
  apply exists_congr,
  rintro (f : polynomial R),
  simp only [exists_prop, polynomial.mem_supported_range, eq_comm],
  apply and_congr iff.rfl,
  split;
  { rintro rfl;
    rw [finsupp.total_apply, aeval_def, eval₂_eq_sum, eq_comm],
    apply finset.sum_congr rfl,
    rintro i -,
    simp only [algebra.smul_def] }
end

lemma mem_span_pow {x y : S} {d : ℕ} (hd : d ≠ 0) :
  y ∈ submodule.span R (set.range (λ (i : fin d), x ^ (i : ℕ))) ↔
    ∃ f : polynomial R, f.nat_degree < d ∧ y = aeval x f :=
begin
  rw mem_span_pow',
  split;
  { rintros ⟨f, h, hy⟩,
    refine ⟨f, _, hy⟩,
    by_cases hf : f = 0,
    { simp only [hf, nat_degree_zero, degree_zero] at h ⊢,
      exact lt_of_le_of_ne (nat.zero_le d) hd.symm <|> exact with_bot.bot_lt_some d },
    simpa only [degree_eq_nat_degree hf, with_bot.coe_lt_coe] using h },
end

lemma dim_ne_zero [nontrivial S] (pb : power_basis R S) : pb.dim ≠ 0 :=
λ h, one_ne_zero $
show (1 : S) = 0,
by { rw [← pb.is_basis.total_repr 1, finsupp.total_apply, finsupp.sum_fintype],
     { refine finset.sum_eq_zero (λ x hx, _),
       cases x with x x_lt,
       rw h at x_lt,
       cases x_lt },
     { simp } }

lemma exists_eq_aeval [nontrivial S] (pb : power_basis R S) (y : S) :
  ∃ f : polynomial R, f.nat_degree < pb.dim ∧ y = aeval pb.gen f :=
(mem_span_pow pb.dim_ne_zero).mp (pb.is_basis.mem_span y)

section minpoly

open_locale big_operators

variable [algebra A S]

/-- `pb.minpoly_gen` is a minimal polynomial for `pb.gen`.

If `A` is not a field, it might not necessarily be *the* minimal polynomial,
however `nat_degree_minpoly` shows its degree is indeed minimal.
-/
noncomputable def minpoly_gen (pb : power_basis A S) : polynomial A :=
X ^ pb.dim -
  ∑ (i : fin pb.dim), C (pb.is_basis.repr (pb.gen ^ pb.dim) i) * X ^ (i : ℕ)

@[simp]
lemma nat_degree_minpoly_gen (pb : power_basis A S) :
  nat_degree (minpoly_gen pb) = pb.dim :=
begin
  unfold minpoly_gen,
  apply nat_degree_eq_of_degree_eq_some,
  rw degree_sub_eq_left_of_degree_lt; rw degree_X_pow,
  apply degree_sum_fin_lt
end

lemma minpoly_gen_monic (pb : power_basis A S) : monic (minpoly_gen pb) :=
begin
  apply monic_sub_of_left (monic_pow (monic_X) _),
  rw degree_X_pow,
  exact degree_sum_fin_lt _
end

@[simp]
lemma aeval_minpoly_gen (pb : power_basis A S) : aeval pb.gen (minpoly_gen pb) = 0 :=
begin
  simp_rw [minpoly_gen, alg_hom.map_sub, alg_hom.map_sum, alg_hom.map_mul, alg_hom.map_pow,
           aeval_C, ← algebra.smul_def, aeval_X],
  refine sub_eq_zero.mpr ((pb.is_basis.total_repr (pb.gen ^ pb.dim)).symm.trans _),
  rw [finsupp.total_apply, finsupp.sum_fintype],
  intro i, rw zero_smul
end

lemma is_integral_gen (pb : power_basis A S) : is_integral A pb.gen :=
⟨minpoly_gen pb, minpoly_gen_monic pb, aeval_minpoly_gen pb⟩

lemma dim_le_nat_degree_of_root (h : power_basis A S) {p : polynomial A}
  (ne_zero : p ≠ 0) (root : aeval h.gen p = 0) :
  h.dim ≤ p.nat_degree :=
begin
  refine le_of_not_lt (λ hlt, ne_zero _),
  let p_coeff : fin (h.dim) → A := λ i, p.coeff i,
  suffices : ∀ i, p_coeff i = 0,
  { ext i,
    by_cases hi : i < h.dim,
    { exact this ⟨i, hi⟩ },
    exact coeff_eq_zero_of_nat_degree_lt (lt_of_lt_of_le hlt (le_of_not_gt hi)) },
  intro i,
  refine linear_independent_iff'.mp h.is_basis.1 finset.univ _ _ i (finset.mem_univ _),
  rw aeval_eq_sum_range' hlt at root,
  rw finset.sum_fin_eq_sum_range,
  convert root,
  ext i,
  split_ifs with hi,
  { refl },
  { rw [coeff_eq_zero_of_nat_degree_lt (lt_of_lt_of_le hlt (le_of_not_gt hi)),
        zero_smul] }
end

@[simp]
lemma nat_degree_minpoly (pb : power_basis A S) :
  (minpoly A pb.gen).nat_degree = pb.dim :=
begin
  refine le_antisymm _
    (dim_le_nat_degree_of_root pb (minpoly.ne_zero pb.is_integral_gen) (minpoly.aeval _ _)),
  rw ← nat_degree_minpoly_gen,
  apply nat_degree_le_of_degree_le,
  rw ← degree_eq_nat_degree (minpoly_gen_monic pb).ne_zero,
  exact minpoly.min _ _ (minpoly_gen_monic pb) (aeval_minpoly_gen pb)
end

end minpoly

section equiv

variables [algebra A S] {S' : Type*} [comm_ring S'] [algebra A S']

lemma nat_degree_lt_nat_degree {p q : polynomial R} (hp : p ≠ 0) (hpq : p.degree < q.degree) :
  p.nat_degree < q.nat_degree :=
begin
  by_cases hq : q = 0, { rw [hq, degree_zero] at hpq, have := not_lt_bot hpq, contradiction },
  rwa [degree_eq_nat_degree hp, degree_eq_nat_degree hq, with_bot.coe_lt_coe] at hpq
end

lemma constr_pow_aeval (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) (f : polynomial A) :
  pb.is_basis.constr (λ i, y ^ (i : ℕ)) (aeval pb.gen f) = aeval y f :=
begin
  rw [← aeval_mod_by_monic_eq_self_of_root (minpoly.monic pb.is_integral_gen) (minpoly.aeval _ _),
      ← @aeval_mod_by_monic_eq_self_of_root _ _ _ _ _ f _ (minpoly.monic pb.is_integral_gen) y hy],
  by_cases hf : f %ₘ minpoly A pb.gen = 0,
  { simp only [hf, alg_hom.map_zero, linear_map.map_zero] },
  have : (f %ₘ minpoly A pb.gen).nat_degree < pb.dim,
  { rw ← pb.nat_degree_minpoly,
    apply nat_degree_lt_nat_degree hf,
    exact degree_mod_by_monic_lt _ (minpoly.monic pb.is_integral_gen)
      (minpoly.ne_zero pb.is_integral_gen) },
  rw [aeval_eq_sum_range' this, aeval_eq_sum_range' this, linear_map.map_sum],
  refine finset.sum_congr rfl (λ i (hi : i ∈ finset.range pb.dim), _),
  rw finset.mem_range at hi,
  rw linear_map.map_smul,
  congr,
  exact @constr_basis _ _ _ _ _ _ _ _ _ _ _ (⟨i, hi⟩ : fin pb.dim) pb.is_basis,
end

lemma constr_pow_gen (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) :
  pb.is_basis.constr (λ i, y ^ (i : ℕ)) pb.gen = y :=
by { convert pb.constr_pow_aeval hy X; rw aeval_X }

lemma constr_pow_algebra_map (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) (x : A) :
  pb.is_basis.constr (λ i, y ^ (i : ℕ)) (algebra_map A S x) = algebra_map A S' x :=
by { convert pb.constr_pow_aeval hy (C x); rw aeval_C }

lemma constr_pow_mul [nontrivial S] (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) (x x' : S) :
  pb.is_basis.constr (λ i, y ^ (i : ℕ)) (x * x') =
    pb.is_basis.constr (λ i, y ^ (i : ℕ)) x * pb.is_basis.constr (λ i, y ^ (i : ℕ)) x' :=
begin
  obtain ⟨f, hf, rfl⟩ := pb.exists_eq_aeval x,
  obtain ⟨g, hg, rfl⟩ := pb.exists_eq_aeval x',
  simp only [← aeval_mul, pb.constr_pow_aeval hy]
end

/-- `pb.lift y hy` is the algebra map sending `pb.gen` to `y`,
where `hy` states the higher powers of `y` are the same as the higher powers of `pb.gen`. -/
noncomputable def lift [nontrivial S] (pb : power_basis A S) (y : S')
  (hy : aeval y (minpoly A pb.gen) = 0) :
  S →ₐ[A] S' :=
{ map_one' := by { convert pb.constr_pow_algebra_map hy 1 using 2; rw ring_hom.map_one },
  map_zero' := by { convert pb.constr_pow_algebra_map hy 0 using 2; rw ring_hom.map_zero },
  map_mul' := pb.constr_pow_mul hy,
  commutes' := pb.constr_pow_algebra_map hy,
  .. pb.is_basis.constr (λ i, y ^ (i : ℕ)) }

@[simp] lemma lift_gen [nontrivial S] (pb : power_basis A S) (y : S')
  (hy : aeval y (minpoly A pb.gen) = 0) :
  pb.lift y hy pb.gen = y :=
pb.constr_pow_gen hy

@[simp] lemma lift_aeval [nontrivial S] (pb : power_basis A S) (y : S')
  (hy : aeval y (minpoly A pb.gen) = 0) (f : polynomial A) :
  pb.lift y hy (aeval pb.gen f) = aeval y f :=
pb.constr_pow_aeval hy f

/-- `pb.equiv pb' h` is an equivalence of algebras with the same power basis. -/
noncomputable def equiv [nontrivial S] [nontrivial S']
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen) :
  S ≃ₐ[A] S' :=
alg_equiv.of_alg_hom
  (pb.lift pb'.gen (h.symm ▸ minpoly.aeval A pb'.gen))
  (pb'.lift pb.gen (h ▸ minpoly.aeval A pb.gen))
  (by { ext x, obtain ⟨f, hf, rfl⟩ := pb'.exists_eq_aeval x, simp })
  (by { ext x, obtain ⟨f, hf, rfl⟩ := pb.exists_eq_aeval x, simp })

@[simp]
lemma equiv_aeval [nontrivial S] [nontrivial S']
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen)
  (f : polynomial A) :
  pb.equiv pb' h (aeval pb.gen f) = aeval pb'.gen f :=
pb.lift_aeval _ (h.symm ▸ minpoly.aeval A _) _

@[simp]
lemma equiv_gen [nontrivial S] [nontrivial S']
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen) :
  pb.equiv pb' h pb.gen = pb'.gen :=
pb.lift_gen _ (h.symm ▸ minpoly.aeval A _)

local attribute [irreducible] power_basis.lift

@[simp]
lemma equiv_symm [nontrivial S] [nontrivial S']
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen) :
  (pb.equiv pb' h).symm = pb'.equiv pb h.symm :=
rfl

end equiv

end power_basis

open power_basis

/-- Useful lemma to show `x` generates a power basis:
the powers of `x` less than the degree of `x`'s minimal polynomial are linear independent. -/
lemma is_integral.linear_independent_pow [algebra K S] {x : S} (hx : is_integral K x) :
  linear_independent K (λ (i : fin (minpoly K x).nat_degree), x ^ (i : ℕ)) :=
begin
  rw linear_independent_iff,
  intros p hp,
  let f : polynomial K := p.sum (λ i, monomial i),
  have f_def : ∀ (i : fin _), f.coeff i = p i,
  { intro i,
    -- TODO: how can we avoid unfolding here?
    change (p.sum (λ i pi, finsupp.single i pi) : ℕ →₀ K) i = p i,
    simp_rw [finsupp.sum_apply, finsupp.single_apply, finsupp.sum],
    rw [finset.sum_eq_single, if_pos rfl],
    { intros b _ hb,
      rw if_neg (mt (λ h, _) hb),
      exact fin.coe_injective h },
    { intro hi,
      split_ifs; { exact finsupp.not_mem_support_iff.mp hi } } },
  have f_def' : ∀ i, f.coeff i = if hi : i < _ then p ⟨i, hi⟩ else 0,
  { intro i,
    split_ifs with hi,
    { exact f_def ⟨i, hi⟩ },
    -- TODO: how can we avoid unfolding here?
    change (p.sum (λ i pi, finsupp.single i pi) : ℕ →₀ K) i = 0,
    simp_rw [finsupp.sum_apply, finsupp.single_apply, finsupp.sum],
    apply finset.sum_eq_zero,
    rintro ⟨j, hj⟩ -,
    apply if_neg (mt _ hi),
    rintro rfl,
    exact hj },
  suffices : f = 0,
  { ext i, rw [← f_def, this, coeff_zero, finsupp.zero_apply] },
  contrapose hp with hf,
  intro h,
  have : (minpoly K x).degree ≤ f.degree,
  { apply minpoly.degree_le_of_ne_zero K x hf,
    convert h,
    rw [finsupp.total_apply, aeval_def, eval₂_eq_sum, finsupp.sum_sum_index],
    { apply finset.sum_congr rfl,
      rintro i -,
      simp only [algebra.smul_def, monomial, finsupp.lsingle_apply, zero_mul, ring_hom.map_zero,
        finsupp.sum_single_index] },
    { intro, simp only [ring_hom.map_zero, zero_mul] },
    { intros, simp only [ring_hom.map_add, add_mul] } },
  have : ¬ (minpoly K x).degree ≤ f.degree,
  { apply not_le_of_lt,
    rw [degree_eq_nat_degree (minpoly.ne_zero hx), degree_lt_iff_coeff_zero],
    intros i hi,
    rw [f_def' i, dif_neg],
    exact hi.not_lt },
  contradiction
end

lemma is_integral.mem_span_pow [nontrivial R] {x y : S} (hx : is_integral R x)
  (hy : ∃ f : polynomial R, y = aeval x f) :
  y ∈ submodule.span R (set.range (λ (i : fin (minpoly R x).nat_degree),
    x ^ (i : ℕ))) :=
begin
  obtain ⟨f, rfl⟩ := hy,
  apply mem_span_pow'.mpr _,
  have := minpoly.monic hx,
  refine ⟨f.mod_by_monic (minpoly R x),
      lt_of_lt_of_le (degree_mod_by_monic_lt _ this (ne_zero_of_monic this)) degree_le_nat_degree,
      _⟩,
  conv_lhs { rw ← mod_by_monic_add_div f this },
  simp only [add_zero, zero_mul, minpoly.aeval, aeval_add, alg_hom.map_mul]
end


import linear_algebra.span
import ring_theory.ideal.operations
import ring_theory.finiteness
import dimension_theory.support
import ring_theory.localization.ideal
import ring_theory.ideal.minimal_prime

/-!

## Todo

Generalize this to non-commutative settings once there are annihilator for non-commutative rings.

-/

variables {R : Type*} [comm_ring R] (I J : ideal R) (M : Type*) [add_comm_group M] [module R M]

def is_associated_prime : Prop :=
I.is_prime ∧ ∃ x : M, I = (R ∙ x).annihilator

variables (R)

def associated_primes : set (ideal R) := { I | is_associated_prime I M }

variables {I M R} (h : is_associated_prime I M)
variables {M' : Type*} [add_comm_group M'] [module R M'] (f : M →ₗ[R] M')

lemma is_associated_prime.is_prime : I.is_prime := h.1

lemma is_associated_prime.map_injective (h : is_associated_prime I M) (hf : function.injective f) :
  is_associated_prime I M' :=
begin
  obtain ⟨x, rfl⟩ := h.2,
  refine ⟨h.1, ⟨f x, _⟩⟩,
  ext r,
  rw [submodule.mem_annihilator_span_singleton, submodule.mem_annihilator_span_singleton,
    ← map_smul, ← f.map_zero, hf.eq_iff],
end

lemma is_associated_prime.iff_of_equiv (l : M ≃ₗ[R] M') :
  is_associated_prime I M ↔ is_associated_prime I M' :=
⟨λ h, h.map_injective l l.injective, λ h, h.map_injective l.symm l.symm.injective⟩

lemma not_is_associated_prime_of_subsingleton [subsingleton M] : ¬ is_associated_prime I M :=
begin
  rintro ⟨hI, x, hx⟩,
  apply hI.ne_top,
  rwa [subsingleton.elim x 0, submodule.span_singleton_eq_bot.mpr rfl,
    submodule.annihilator_bot] at hx
end

variable (R)

lemma exists_le_is_associated_prime_of_is_noetherian_ring [H : is_noetherian_ring R]
  (x : M) (hx : x ≠ 0) :
  ∃ P : ideal R, is_associated_prime P M ∧ (R ∙ x).annihilator ≤ P :=
begin
  have : (R ∙ x).annihilator ≠ ⊤,
  { rwa [ne.def, ideal.eq_top_iff_one, submodule.mem_annihilator_span_singleton, one_smul] },
  obtain ⟨P, ⟨l, h₁, y, rfl⟩, h₃⟩ := set_has_maximal_iff_noetherian.mpr H
    ({ P | (R ∙ x).annihilator ≤ P ∧ P ≠ ⊤ ∧ ∃ y : M, P = (R ∙ y).annihilator })
    ⟨(R ∙ x).annihilator, rfl.le, this, x, rfl⟩,
  refine ⟨_, ⟨⟨h₁, _⟩, y, rfl⟩, l⟩,
  intros a b hab,
  rw or_iff_not_imp_left,
  intro ha,
  rw submodule.mem_annihilator_span_singleton at ha hab,
  have H₁ : (R ∙ y).annihilator ≤ (R ∙ a • y).annihilator,
  { intros c hc,
    rw submodule.mem_annihilator_span_singleton at hc ⊢,
    rw [smul_comm, hc, smul_zero] },
  have H₂ : (submodule.span R {a • y}).annihilator ≠ ⊤,
  { rwa [ne.def, submodule.annihilator_eq_top_iff, submodule.span_singleton_eq_bot] },
  rwa [← h₃ (R ∙ a • y).annihilator ⟨l.trans H₁, H₂, _, rfl⟩ H₁,
    submodule.mem_annihilator_span_singleton, smul_comm, smul_smul]
end

variable {R}

lemma mem_associate_primes : I ∈ associated_primes R M ↔ is_associated_prime I M := iff.rfl

lemma associated_primes_le_of_injective (hf : function.injective f) :
  associated_primes R M ⊆ associated_primes R M' :=
λ I h, h.map_injective f hf

lemma linear_equiv.associated_primes_eq (l : M ≃ₗ[R] M') :
  associated_primes R M = associated_primes R M' :=
le_antisymm (associated_primes_le_of_injective l l.injective)
  (associated_primes_le_of_injective l.symm l.symm.injective)

lemma associated_primes_of_subsingleton [subsingleton M] : associated_primes R M = ∅ :=
begin
  ext, simp only [set.mem_empty_iff_false, iff_false], apply not_is_associated_prime_of_subsingleton
end

variables (R M)

lemma associated_primes_nonempty [is_noetherian_ring R] [nontrivial M] :
  (associated_primes R M).nonempty :=
begin
  obtain ⟨x, hx⟩ := exists_ne (0 : M),
  obtain ⟨P, hP, _⟩ := exists_le_is_associated_prime_of_is_noetherian_ring R x hx,
  exact ⟨P, hP⟩,
end

lemma associated_primes_subset_support :
  associated_primes R M ⊆ module.support R M :=
begin
  rintros _ ⟨h, x, rfl⟩,
  refine ⟨h, ⟨⟨localized_module.mk 0 1, localized_module.mk x 1, _⟩⟩⟩,
  simp_rw [ne.def, localized_module.mk_eq, not_exists, one_smul, smul_zero],
  rintros ⟨a, ha : a ∉ (R ∙ x).annihilator⟩ e,
  rw submodule.mem_annihilator_span_singleton at ha,
  exact ha e,
end

variables {R M}

lemma module.mem_support_if_exists_associated_primes [hR : is_noetherian_ring R]
  {I : ideal R} [I.is_prime] :
  I ∈ module.support R M ↔ ∃ J ∈ associated_primes R M, J ≤ I :=
begin
  split,
  { intro hI,
    haveI := hI.some,
    haveI : nontrivial _ := hI.some_spec,
    haveI hR' : is_noetherian_ring (localization I.prime_compl),
    { rw [is_noetherian_ring_iff, is_noetherian_iff_well_founded] at hR ⊢,
      exact order_embedding.well_founded
        (is_localization.order_embedding I.prime_compl $ localization I.prime_compl).dual hR },
    obtain ⟨p, hp, x, hx⟩ := associated_primes_nonempty
      (localization I.prime_compl) (localized_module I.prime_compl M),
    obtain ⟨⟨m, s⟩, rfl : localized_module.mk m s = x⟩ := quotient.exists_rep x,
    resetI,
    let q := p.comap (algebra_map R $ localization I.prime_compl),
    obtain ⟨S, hS⟩ := (hR.1 : _) q,
    have hq : ∀ x, x ∈ q ↔ ∃ y : I.prime_compl, y • x • m = 0,
    { simp_rw [ideal.mem_comap, hx, submodule.mem_annihilator_span_singleton, algebra_map_smul,
        ← localized_module.zero_mk (1 : I.prime_compl), localized_module.smul'_mk,
        localized_module.mk_eq, one_smul, smul_zero, @eq_comm M 0],
      exact λ _, iff.rfl },
    have : ∀ t : S, ∃ y : I.prime_compl, y • (t : R) • m = 0,
    { simp_rw [← hq, ← hS], intro t, apply submodule.subset_span, exact t.2 },
    choose u hu,
    suffices : (R ∙ finset.univ.prod u • m).annihilator = q,
    { refine ⟨_, ⟨ideal.is_prime.comap _, _, this.symm⟩, set.disjoint_compl_left_iff_subset.mp _⟩,
      exact ((is_localization.is_prime_iff_is_prime_disjoint I.prime_compl _ _).mp hp).2  },
    ext a,
    rw [submodule.mem_annihilator_span_singleton, smul_comm a],
    swap, { apply_instance },
    split,
    { intro e, rw hq, exact ⟨_, e⟩ },
    { rintros ha,
      rw ← hS at ha,
      apply submodule.span_induction ha; clear ha a,
      { intros x hx,
        obtain ⟨y, hy⟩ : u ⟨x, hx⟩ ∣ finset.univ.prod u :=
          finset.dvd_prod_of_mem _ (finset.mem_univ _),
        rw [hy, mul_comm, mul_smul],
        convert smul_zero y,
        exact hu ⟨x, hx⟩ },
      { rw [zero_smul, smul_zero] },
      { intros x y ex ey, rw [add_smul, smul_add, ex, ey, add_zero] },
      { intros x y e, rw [smul_assoc, smul_comm, e, smul_zero] } } },
  { rintro ⟨J, hJ, e⟩,
    exact module.mem_support_of_le e (associated_primes_subset_support _ _ hJ) }
end
.
lemma annihilator_le_of_mem_associate_primes (I ∈ associated_primes R M) :
  (⊤ : submodule R M).annihilator ≤ I :=
begin
  obtain ⟨hI, x, rfl⟩ := H,
  exact submodule.annihilator_mono le_top,
end

lemma submodule.bot_colon (p : submodule R M) : (⊥ : submodule R M).colon p = p.annihilator :=
begin
  ext, simp [submodule.mem_colon, submodule.mem_annihilator],
end

lemma submodule.restrict_scalars_colon_top {A : Type*} [comm_ring A] [algebra R A] (I : ideal A) :
  (I.restrict_scalars R).colon ⊤ = I.comap (algebra_map R A) :=
begin
  ext,
  rw [submodule.mem_colon],
  change _ ↔ (algebra_map R A) x ∈ I,
  split,
  { intros H, rw algebra.algebra_map_eq_smul_one, exact H 1 trivial },
  { intros e a _, rw algebra.smul_def, exact I.mul_mem_right _ e }
end

lemma submodule.top_annihilator_eq_ker {A : Type*} [comm_ring A] [algebra R A] :
  (⊤ : submodule R A).annihilator = (algebra_map R A).ker :=
begin
  rw [ring_hom.ker_eq_comap_bot, ← submodule.restrict_scalars_colon_top,
    submodule.restrict_scalars_bot, submodule.bot_colon],
end

variables (R M)

lemma annihilator_minimal_primes_subset_associated_primes
  [is_noetherian_ring R] [module.finite R M] :
  (⊤ : submodule R M).annihilator.minimal_primes ⊆ associated_primes R M :=
begin
  intros I hI,
  haveI := hI.1.1,
  have : I ∈ module.support R M,
  { rw module.mem_support_iff_annihilator_le_of_fg, exact hI.1.2 },
  rw module.mem_support_if_exists_associated_primes at this,
  obtain ⟨J, hJ, e⟩ := this,
  exact (e.antisymm $ hI.2 ⟨hJ.1, annihilator_le_of_mem_associate_primes _ hJ⟩ e) ▸ hJ,
end

lemma minimal_primes_subset_associated_primes [is_noetherian_ring R] :
  I.minimal_primes ⊆ associated_primes R (R ⧸ I) :=
begin
  convert annihilator_minimal_primes_subset_associated_primes R (R ⧸ I),
  rw [submodule.top_annihilator_eq_ker],
  simp
end

lemma Inf_associated_primes_eq_Inf_support [is_noetherian_ring R] :
  Inf (associated_primes R M) = Inf (module.support R M) :=
begin
  refine le_antisymm (le_Inf _) (Inf_le_Inf (associated_primes_subset_support R M)),
  intros I hI,
  haveI := hI.some,
  obtain ⟨J, hJ, e⟩ := module.mem_support_if_exists_associated_primes.mp hI,
  exact (Inf_le hJ).trans e
end

variables {R M}

lemma mem_Inf_associated_primes_iff_locally_nilpotent [is_noetherian_ring R] {x : R} :
  x ∈ Inf (associated_primes R M) ↔ module.is_locally_nilpotent x M :=
by rw [Inf_associated_primes_eq_Inf_support R M, module.mem_Inf_support_iff_locally_nilpotent]

variables (R M)

lemma coe_Inf_associated_primes [is_noetherian_ring R] :
  (↑(Inf (associated_primes R M)) : set R) = { r : R | module.is_locally_nilpotent r M } :=
set.ext (λ x, mem_Inf_associated_primes_iff_locally_nilpotent)

lemma Inf_associated_primes_eq_annihilator_radical [is_noetherian_ring R] [module.finite R M] :
  Inf (associated_primes R M) = (⊤ : submodule R M).annihilator.radical :=
by rw [Inf_associated_primes_eq_Inf_support, module.Inf_support_eq_annihilator_radical]

section non_zero_divisors

def module.non_zero_divisors : submonoid R :=
{ carrier := λ r, ∀ m : M, r • m = 0 → m = 0,
  mul_mem' := λ r₁ r₂ h₁ h₂ m e, h₂ m (h₁ (r₂ • m) ((smul_smul r₁ r₂ m).trans e)),
  one_mem' := λ m, (one_smul _ _).symm.trans }

variables {R M}

variables {A : Type*} [comm_ring A] [algebra R A]

lemma module.mem_non_zero_divisors {r : R} :
  r ∈ module.non_zero_divisors R M ↔ ∀ m : M, r • m = 0 → m = 0 := iff.rfl

lemma module.comap_non_zero_divisors [module A M] [is_scalar_tower R A M] :
  (module.non_zero_divisors A M).comap (algebra_map R A) = module.non_zero_divisors R M :=
begin
  ext,
  rw [submonoid.mem_comap, module.mem_non_zero_divisors, module.mem_non_zero_divisors],
  simp_rw algebra_map_smul
end

lemma module.non_zero_divisors_self  :
  module.non_zero_divisors R R = non_zero_divisors R :=
begin
  ext,
  rw [module.mem_non_zero_divisors, mem_non_zero_divisors_iff],
  simp_rw [smul_eq_mul, mul_comm],
end

lemma module.non_zero_divisors_of_algebra  :
  module.non_zero_divisors R A = (non_zero_divisors A).comap (algebra_map R A) :=
begin
  rw [← module.non_zero_divisors_self, module.comap_non_zero_divisors]
end

end non_zero_divisors

lemma Union_associated_primes [is_noetherian_ring R] :
  (⋃ I ∈ associated_primes R M, ↑I : set R) = (module.non_zero_divisors R M)ᶜ :=
begin
  ext x,
  simp only [set.mem_Union, set_like.mem_coe, set.mem_compl_iff, module.mem_non_zero_divisors],
  split,
  { rintros ⟨I, ⟨hI, y, rfl⟩, h⟩ hx,
    rw submodule.mem_annihilator_span_singleton at h,
    rw [hx _ h, submodule.span_singleton_eq_bot.mpr rfl, submodule.annihilator_bot] at hI,
    exact (hI.1 : _) rfl },
  { push_neg,
    rintro ⟨m, h₁, h₂⟩,
    obtain ⟨P, h₃, h₄⟩ := exists_le_is_associated_prime_of_is_noetherian_ring R m h₂,
    refine ⟨P, h₃, h₄ (by rwa submodule.mem_annihilator_span_singleton)⟩ }
end

lemma is_associated_prime.eq_primary {R : Type*} [comm_ring R] {I J : ideal R} (hI : I.is_primary)
  (h : is_associated_prime J (R ⧸ I)) : J = I.radical :=
begin
  obtain ⟨hJ, x, e⟩ := h,
  have : x ≠ 0,
  { rintro rfl, apply hJ.1,
    rwa [submodule.span_singleton_eq_bot.mpr rfl, submodule.annihilator_bot] at e },
  obtain ⟨x, rfl⟩ := ideal.quotient.mkₐ_surjective R _ x,
  replace e : ∀ {y}, y ∈ J ↔ x * y ∈ I,
  { intro y, rw [e, submodule.mem_annihilator_span_singleton, ← map_smul, smul_eq_mul, mul_comm,
      ideal.quotient.mkₐ_eq_mk, ← ideal.quotient.mk_eq_mk, submodule.quotient.mk_eq_zero] },
  apply le_antisymm,
  { intros y hy,
    exact (hI.2 $ e.mp hy).resolve_left ((submodule.quotient.mk_eq_zero I).not.mp this) },
  { rw hJ.radical_le_iff, intros y hy, exact e.mpr (I.mul_mem_left x hy) }
end

lemma associated_primes_of_is_primary {R : Type*} [comm_ring R] [is_noetherian_ring R]
  {I : ideal R} (hI : I.is_primary) :
  associated_primes R (R ⧸ I) = {I.radical} :=
begin
  ext J,
  rw [set.mem_singleton_iff],
  refine ⟨is_associated_prime.eq_primary hI, _⟩,
  rintro rfl,
  haveI : nontrivial (R ⧸ I) := ⟨⟨(I^.quotient.mk : _) 1, (I^.quotient.mk : _) 0, _⟩⟩,
  obtain ⟨a, ha⟩ := associated_primes_nonempty R (R ⧸ I),
  exact ha.eq_primary hI ▸ ha,
  rw [ne.def, ideal.quotient.eq, sub_zero, ← ideal.eq_top_iff_one],
  exact hI.1
end
.