import order.zorn
noncomputable theory
local attribute [instance] classical.prop_decidable

class is_ideal {R : Type*} [comm_ring R] (J : set R) : Prop :=
(zero : (0:R) ∈ J)
(add  : ∀ {x y}, x ∈ J → y ∈ J → x + y ∈ J)
(mul : ∀ r x : R, x ∈ J → r * x ∈ J)

structure is_proper_ideal {R : Type*} [comm_ring R] (J : set R)
  extends is_ideal J : Prop :=
(one_not_in : ¬ ((1:R) ∈ J) )

lemma is_proper_iff_not_univ {R : Type*} [comm_ring R] (J : set R) (HJI : is_ideal J) :
is_proper_ideal J ↔ J ≠ set.univ :=
begin
  split,
  { intros H HJu,
    cases H with _ H_one_not_in,
    apply H_one_not_in,
    rw HJu,
    rw set.univ_def,
    trivial },
  { intro H,
    constructor,
    { exact HJI },
    intro H1in,
    apply H,
    apply funext,
    intro r,
    show (J r = true),
    rw eq_true,
    rw ←(mul_one r),
    apply is_ideal.mul,
    exact H1in
  }
end

--⟨λ H HJu,is_proper_ideal.one_not_in J (show (1:R) ∈ J,by simp [set.univ 1,HJu]),_⟩

class is_prime_ideal {R : Type*} [comm_ring R] (P : set R)
  extends is_proper_ideal P : Prop :=
(is_prime : ∀ x y : R, x * y ∈ P →
 x ∈ P ∨ y ∈ P)

class is_maximal_ideal {R : Type*} [comm_ring R] (m : set R)
  extends is_proper_ideal m : Prop :=
(is_maximal : ∀ J : set R, (is_proper_ideal J) → m ⊆ J → J = m)

/-- increasing union of ideals is an ideal --/
lemma union_of_ideals {R : Type*} [comm_ring R] {γ : Type*} [inhabited γ] [decidable_linear_order γ]
  (Ix : γ → set R) (IxI : ∀ x : γ, is_ideal (Ix x))
  (I_inc : ∀ {x y : γ}, x ≤ y → Ix x ⊆ Ix y)
  : is_ideal {r : R | ∃ x : γ, r ∈ Ix x} :=
begin
constructor,
{ show (0:R) ∈ {r : R | ∃ x : γ, r ∈ Ix x},
  let x := inhabited.default γ,
  existsi x,
  exact (IxI x).zero },
{ -- additivity
  intros r s Hr Hs,
  cases Hr with x Hx,
  cases Hs with y Hy,
  let z := max x y,
  have rIz : r ∈ Ix z := I_inc (le_max_left x y) Hx,
  have sIz : s ∈ Ix z := I_inc (le_max_right x y) Hy,
  existsi z,
  exact is_ideal.add rIz sIz,
},
{ -- external mult
intros r j Hj,
cases Hj with x Hx,
existsi x,
exact is_ideal.mul r j Hx,
}
end

--set_option pp.all true
lemma union_of_proper_ideals {R : Type*} [comm_ring R] {γ : Type*} [decidable_linear_order γ] (Iγ : inhabited γ)
  (Ix : γ → set R) (IxI : ∀ x : γ, is_proper_ideal (Ix x))
  (I_inc : ∀ {x y : γ}, x ≤ y → Ix x ⊆ Ix y)
  : is_proper_ideal {r : R | ∃ x : γ, r ∈ Ix x} :=
begin
  constructor,
  { show is_ideal {r : R | ∃ x : γ, r ∈ Ix x},
    exact union_of_ideals Ix (λ x, (IxI x).to_is_ideal) @I_inc },
  { show (1:R) ∉ {r : R | ∃ x : γ, r ∈ Ix x},
    intro H,cases H with x Hx, revert Hx,
    exact (IxI x).one_not_in }
end

--#print zorn.chain
--set_option pp.all true
#check dite
#check or.inl
#check @rfl
--set_option pp.all true

#check is_proper_iff_not_univ
--is_proper_iff_not_univ : ∀ (J : set ?M_1), is_ideal J → (is_proper_ideal J ↔ J ≠ set.univ)

lemma proper_ideal_of_non_zero_ring {R : Type*} [comm_ring R] (H : ∃ r : R, r ≠ 0) : is_proper_ideal ({0}:set R) :=
begin
  let J := ({0}:set R),
  have H2 : is_ideal J :=
  { zero := set.mem_singleton _,
    add := λ x y, match x, y with .(0), .(0), or.inl (@rfl _ 0), or.inl (@rfl _ 0) := or.inl (add_zero 0) end,
    mul := λ r x, match r, x with _, _, or.inl rfl := or.inl (mul_zero _) end,--∀ (r x : R), x ∈ {0} → r * x ∈ {0}
  },
  have H3 : J ≠ set.univ,
  { assume H4,
    cases H with r Hr,
    apply Hr,
    have H5 : r ∈ J := by simp [H4],
    cases H5,
      exact H5,
    exact false.elim H5
  },
  suffices H_one_not_in : ¬ ((1:R) ∈ J),
    exact {one_not_in := H_one_not_in,..H2},
  refine is_proper_ideal.one_not_in _,

  exact {
  one_not_in := is_proper_ideal.one_not_in _,--J ((is_proper_iff_not_univ J H2).2 _),
  ..H2},
  apply (is_proper_iff_not_univ J H2).2,
  exact H3
end

#check proper_ideal_of_non_zero_ring
--proper_ideal_of_non_zero_ring : (∃ (r : ?M_1), r ≠ 0) → is_proper_ideal {0}

/-- a non-zero ring has a maximal ideal-/
lemma stacks_tag_00E0_2 {R : Type*} [comm_ring R] :
  (∃ r : R, r ≠ 0) → (∃ m : set R, is_maximal_ideal m) :=
begin
  let P := {I : set R // is_proper_ideal I},
  let PP : partial_order P :=
  { le := (λ P Q, P.val ⊆ Q.val),
    le_refl := λ a, set.subset.refl a.val,
    le_trans := λ a b c Hab Hbc, set.subset.trans Hab Hbc,
    le_antisymm := λ a b Hab Hba, subtype.eq (set.subset.antisymm Hab Hba)
  },
  intro HR_nonzero,
  have Hzero_proper : is_proper_ideal ({0}:set R) := proper_ideal_of_non_zero_ring HR_nonzero,
  suffices : ∃ (m : P), ∀ (a : P), m ≤ a → a = m,
  { cases this with m Hm,
    existsi m.val,
    constructor,
    { exact m.property},
    intros J HJ H3,
    rw ←(Hm ⟨J,HJ⟩ H3) },
  apply @zorn.zorn_partial_order P PP,
  intros c Hc,
  cases classical.em (c = ∅) with Hnon Hemp,
  { existsi (⟨({0}:set R),Hzero_proper⟩ : P),
    intros H1 H2,
    apply false.elim _,
    rw Hnon at H2,
    exact H2,
  },
  cases classical.em (∃ J : P, J ∈ c) with HJ HnJ,
  tactic.swap,
  apply false.elim,
  apply Hemp,
  funext J,
  rw [set.empty_def],
  show c J = false,
  cases classical.em (c J),
  { apply false.elim _,
    apply HnJ,
    existsi J,
    exact h,
  },
  { exact eq_false_intro h},
  cases HJ with J1 HJ1,
  let c_subtype := {I : P // c I},
  let H_par_c : partial_order c_subtype :=
  { le := λ P Q, P.val.val ⊆ Q.val.val,
    le_refl := λ a, set.subset.refl a.val.val,
    le_trans := λ a b c Hab Hbc, set.subset.trans Hab Hbc,
    le_antisymm := λ a b Hab Hba, subtype.eq (subtype.eq (set.subset.antisymm Hab Hba))
  },
  let H_lin_c : decidable_linear_order c_subtype,
  refine { ..H_par_c,.. },
  { intros a b,
    cases classical.em (a=b) with Hab Hnab,
    { left, exact le_of_eq Hab},
    have H1 := Hc a.val a.property b.val b.property,
    have H2 : a.val ≠ b.val := λ H, Hnab (subtype.eq H),
    have H3 := H1 H2,
    exact H3,
  },
  { apply_instance},
  let ub_val : set R := set.Union (λ (I : { I : P // c I}), (I.val).val),
  let ub_prop := @union_of_proper_ideals _ _ { I : P // c I} _ _ (λ I : { I : P // c I},I.val.val) _ _,
  existsi (⟨_,ub_prop⟩:P),
  { intros a Ha,
    show a.val ⊆ {r : R | ∃ (x : {I // c I}), r ∈ (x.val).val},
    intros y Hy,
    existsi (⟨a,Ha⟩:{I // c I}),
    exact Hy,
  },
  { constructor,
  exact ⟨J1,HJ1⟩,
  },
  { intro x,
    suffices : is_proper_ideal (x.val.val),
    by simp [this],
    exact (x.val).property,
  },
  intros I J HI_le_J,
  exact HI_le_J
end

--def quotient_ring (R : Type*) [comm_ring R] (I : set R) [is_ideal I] : Type* := quot (λ (x y : R), x-y ∈ I)

--instance quotient_ring_is_add_comm_group (R : Type*) [comm_ring R] (I : set R) [is_ideal I] : add_comm_group (quotient_ring R I) :=

def Spec (R : Type*) [comm_ring R] : set (set R) := {I : set R | is_prime_ideal I}

lemma stacks_tag_00E0_1 {R : Type*} [comm_ring R] : Spec R = ∅ ↔ ∀ r : R, r = 0 :=
begin
  split,
  {

  }
end


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

/-!
# Some facts about finite rings
-/

open_locale classical

lemma card_units_lt (M₀ : Type*) [monoid_with_zero M₀] [nontrivial M₀] [fintype M₀] :
  fintype.card M₀ˣ < fintype.card M₀ :=
fintype.card_lt_of_injective_of_not_mem (coe : M₀ˣ → M₀) units.ext not_is_unit_zero


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import data.polynomial.inductions
import data.polynomial.monic
import ring_theory.multiplicity

/-!
# Division of univariate polynomials

The main defs are `div_by_monic` and `mod_by_monic`.
The compatibility between these is given by `mod_by_monic_add_div`.
We also define `root_multiplicity`.
-/

noncomputable theory
open_locale classical big_operators polynomial

open finset
namespace polynomial
universes u v w z
variables {R : Type u} {S : Type v} {T : Type w} {A : Type z} {a b : R} {n : ℕ}

section comm_semiring
variables [comm_semiring R]

theorem X_dvd_iff {α : Type u} [comm_semiring α] {f : α[X]} : X ∣ f ↔ f.coeff 0 = 0 :=
⟨λ ⟨g, hfg⟩, by rw [hfg, mul_comm, coeff_mul_X_zero],
λ hf, ⟨f.div_X, by rw [mul_comm, ← add_zero (f.div_X * X), ← C_0, ← hf, div_X_mul_X_add]⟩⟩

end comm_semiring

section comm_semiring

variables [comm_semiring R] {p q : R[X]}

lemma multiplicity_finite_of_degree_pos_of_monic (hp : (0 : with_bot ℕ) < degree p)
  (hmp : monic p) (hq : q ≠ 0) : multiplicity.finite p q :=
have zn0 : (0 : R) ≠ 1, by haveI := nontrivial.of_polynomial_ne hq; exact zero_ne_one,
⟨nat_degree q, λ ⟨r, hr⟩,
  have hp0 : p ≠ 0, from λ hp0, by simp [hp0] at hp; contradiction,
  have hr0 : r ≠ 0, from λ hr0, by simp * at *,
  have hpn1 : leading_coeff p ^ (nat_degree q + 1) = 1,
    by simp [show _ = _, from hmp],
  have hpn0' : leading_coeff p ^ (nat_degree q + 1) ≠ 0,
    from hpn1.symm ▸ zn0.symm,
  have hpnr0 : leading_coeff (p ^ (nat_degree q + 1)) * leading_coeff r ≠ 0,
    by simp only [leading_coeff_pow' hpn0', leading_coeff_eq_zero, hpn1,
      one_pow, one_mul, ne.def, hr0]; simp,
  have hnp : 0 < nat_degree p,
    by rw [← with_bot.coe_lt_coe, ← degree_eq_nat_degree hp0];
    exact hp,
  begin
    have := congr_arg nat_degree hr,
    rw [nat_degree_mul' hpnr0,  nat_degree_pow' hpn0', add_mul, add_assoc] at this,
    exact ne_of_lt (lt_add_of_le_of_pos (le_mul_of_one_le_right (nat.zero_le _) hnp)
      (add_pos_of_pos_of_nonneg (by rwa one_mul) (nat.zero_le _))) this
  end⟩

end comm_semiring

section ring
variables [ring R] {p q : R[X]}

lemma div_wf_lemma (h : degree q ≤ degree p ∧ p ≠ 0) (hq : monic q) :
  degree (p - C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q) < degree p :=
have hp : leading_coeff p ≠ 0 := mt leading_coeff_eq_zero.1 h.2,
  have hq0 : q ≠ 0 := hq.ne_zero_of_polynomial_ne h.2,
  have hlt : nat_degree q ≤ nat_degree p := with_bot.coe_le_coe.1
    (by rw [← degree_eq_nat_degree h.2, ← degree_eq_nat_degree hq0];
    exact h.1),
  degree_sub_lt
  (by rw [hq.degree_mul, degree_C_mul_X_pow _ hp, degree_eq_nat_degree h.2,
      degree_eq_nat_degree hq0, ← with_bot.coe_add, tsub_add_cancel_of_le hlt])
  h.2
  (by rw [leading_coeff_mul_monic hq, leading_coeff_mul_X_pow, leading_coeff_C])

/-- See `div_by_monic`. -/
noncomputable def div_mod_by_monic_aux : Π (p : R[X]) {q : R[X]},
  monic q → R[X] × R[X]
| p := λ q hq, if h : degree q ≤ degree p ∧ p ≠ 0 then
  let z := C (leading_coeff p) * X^(nat_degree p - nat_degree q)  in
  have wf : _ := div_wf_lemma h hq,
  let dm := div_mod_by_monic_aux (p - z * q) hq in
  ⟨z + dm.1, dm.2⟩
  else ⟨0, p⟩
using_well_founded {dec_tac := tactic.assumption}

/-- `div_by_monic` gives the quotient of `p` by a monic polynomial `q`. -/
def div_by_monic (p q : R[X]) : R[X] :=
if hq : monic q then (div_mod_by_monic_aux p hq).1 else 0

/-- `mod_by_monic` gives the remainder of `p` by a monic polynomial `q`. -/
def mod_by_monic (p q : R[X]) : R[X] :=
if hq : monic q then (div_mod_by_monic_aux p hq).2 else p

infixl  ` /ₘ ` : 70 := div_by_monic

infixl ` %ₘ ` : 70 := mod_by_monic

lemma degree_mod_by_monic_lt [nontrivial R] : ∀ (p : R[X]) {q : R[X]}
  (hq : monic q), degree (p %ₘ q) < degree q
| p := λ q hq,
if h : degree q ≤ degree p ∧ p ≠ 0 then
  have wf : _ := div_wf_lemma ⟨h.1, h.2⟩ hq,
  have degree ((p - C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q) %ₘ q) < degree q :=
      degree_mod_by_monic_lt (p - C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q)
      hq,
  begin
    unfold mod_by_monic at this ⊢,
    unfold div_mod_by_monic_aux,
    rw dif_pos hq at this ⊢,
    rw if_pos h,
    exact this
  end
else
  or.cases_on (not_and_distrib.1 h) begin
    unfold mod_by_monic div_mod_by_monic_aux,
    rw [dif_pos hq, if_neg h],
    exact lt_of_not_ge,
  end
  begin
    assume hp,
    unfold mod_by_monic div_mod_by_monic_aux,
    rw [dif_pos hq, if_neg h, not_not.1 hp],
    exact lt_of_le_of_ne bot_le
      (ne.symm (mt degree_eq_bot.1 hq.ne_zero)),
  end
using_well_founded {dec_tac := tactic.assumption}

@[simp] lemma zero_mod_by_monic (p : R[X]) : 0 %ₘ p = 0 :=
begin
  unfold mod_by_monic div_mod_by_monic_aux,
  by_cases hp : monic p,
  { rw [dif_pos hp, if_neg (mt and.right (not_not_intro rfl))] },
  { rw [dif_neg hp] }
end

@[simp] lemma zero_div_by_monic (p : R[X]) : 0 /ₘ p = 0 :=
begin
  unfold div_by_monic div_mod_by_monic_aux,
  by_cases hp : monic p,
  { rw [dif_pos hp, if_neg (mt and.right (not_not_intro rfl))] },
  { rw [dif_neg hp] }
end

@[simp] lemma mod_by_monic_zero (p : R[X]) : p %ₘ 0 = p :=
if h : monic (0 : R[X]) then (subsingleton_of_monic_zero h).1 _ _ else
by unfold mod_by_monic div_mod_by_monic_aux; rw dif_neg h

@[simp] lemma div_by_monic_zero (p : R[X]) : p /ₘ 0 = 0 :=
if h : monic (0 : R[X]) then (subsingleton_of_monic_zero h).1 _ _ else
by unfold div_by_monic div_mod_by_monic_aux; rw dif_neg h

lemma div_by_monic_eq_of_not_monic (p : R[X]) (hq : ¬monic q) : p /ₘ q = 0 := dif_neg hq

lemma mod_by_monic_eq_of_not_monic (p : R[X]) (hq : ¬monic q) : p %ₘ q = p := dif_neg hq

lemma mod_by_monic_eq_self_iff [nontrivial R] (hq : monic q) : p %ₘ q = p ↔ degree p < degree q :=
⟨λ h, h ▸ degree_mod_by_monic_lt _ hq,
λ h, have ¬ degree q ≤ degree p := not_le_of_gt h,
  by unfold mod_by_monic div_mod_by_monic_aux; rw [dif_pos hq, if_neg (mt and.left this)]⟩

theorem degree_mod_by_monic_le (p : R[X]) {q : R[X]}
  (hq : monic q) : degree (p %ₘ q) ≤ degree q :=
by { nontriviality R, exact (degree_mod_by_monic_lt _ hq).le }

end ring

section comm_ring
variables [comm_ring R] {p q : R[X]}

lemma mod_by_monic_eq_sub_mul_div : ∀ (p : R[X]) {q : R[X]} (hq : monic q),
  p %ₘ q = p - q * (p /ₘ q)
| p := λ q hq,
  if h : degree q ≤ degree p ∧ p ≠ 0 then
    have wf : _ := div_wf_lemma h hq,
    have ih : _ := mod_by_monic_eq_sub_mul_div
      (p - C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q) hq,
    begin
      unfold mod_by_monic div_by_monic div_mod_by_monic_aux,
      rw [dif_pos hq, if_pos h],
      rw [mod_by_monic, dif_pos hq] at ih,
      refine ih.trans _,
      unfold div_by_monic,
      rw [dif_pos hq, dif_pos hq, if_pos h, mul_add, sub_add_eq_sub_sub, mul_comm]
    end
  else
    begin
      unfold mod_by_monic div_by_monic div_mod_by_monic_aux,
      rw [dif_pos hq, if_neg h, dif_pos hq, if_neg h, mul_zero, sub_zero]
    end
using_well_founded {dec_tac := tactic.assumption}

lemma mod_by_monic_add_div (p : R[X]) {q : R[X]} (hq : monic q) :
  p %ₘ q + q * (p /ₘ q) = p := eq_sub_iff_add_eq.1 (mod_by_monic_eq_sub_mul_div p hq)

lemma div_by_monic_eq_zero_iff [nontrivial R] (hq : monic q) : p /ₘ q = 0 ↔ degree p < degree q :=
⟨λ h, by have := mod_by_monic_add_div p hq;
  rwa [h, mul_zero, add_zero, mod_by_monic_eq_self_iff hq] at this,
λ h, have ¬ degree q ≤ degree p := not_le_of_gt h,
  by unfold div_by_monic div_mod_by_monic_aux; rw [dif_pos hq, if_neg (mt and.left this)]⟩

lemma degree_add_div_by_monic (hq : monic q) (h : degree q ≤ degree p) :
  degree q + degree (p /ₘ q) = degree p :=
begin
  nontriviality R,
  have hdiv0 : p /ₘ q ≠ 0 := by rwa [(≠), div_by_monic_eq_zero_iff hq, not_lt],
  have hlc : leading_coeff q * leading_coeff (p /ₘ q) ≠ 0 :=
    by rwa [monic.def.1 hq, one_mul, (≠), leading_coeff_eq_zero],
  have hmod : degree (p %ₘ q) < degree (q * (p /ₘ q)) :=
    calc degree (p %ₘ q) < degree q : degree_mod_by_monic_lt _ hq
    ... ≤ _ : by rw [degree_mul' hlc, degree_eq_nat_degree hq.ne_zero,
        degree_eq_nat_degree hdiv0, ← with_bot.coe_add, with_bot.coe_le_coe];
      exact nat.le_add_right _ _,
  calc degree q + degree (p /ₘ q) = degree (q * (p /ₘ q)) : eq.symm (degree_mul' hlc)
  ... = degree (p %ₘ q + q * (p /ₘ q)) : (degree_add_eq_right_of_degree_lt hmod).symm
  ... = _ : congr_arg _ (mod_by_monic_add_div _ hq)
end

lemma degree_div_by_monic_le (p q : R[X]) : degree (p /ₘ q) ≤ degree p :=
if hp0 : p = 0 then by simp only [hp0, zero_div_by_monic, le_refl]
else if hq : monic q then
  if h : degree q ≤ degree p
  then by haveI := nontrivial.of_polynomial_ne hp0;
    rw [← degree_add_div_by_monic hq h, degree_eq_nat_degree hq.ne_zero,
      degree_eq_nat_degree (mt (div_by_monic_eq_zero_iff hq).1 (not_lt.2 h))];
    exact with_bot.coe_le_coe.2 (nat.le_add_left _ _)
  else
    by unfold div_by_monic div_mod_by_monic_aux;
      simp only [dif_pos hq, h, false_and, if_false, degree_zero, bot_le]
else (div_by_monic_eq_of_not_monic p hq).symm ▸ bot_le

lemma degree_div_by_monic_lt (p : R[X]) {q : R[X]} (hq : monic q)
  (hp0 : p ≠ 0) (h0q : 0 < degree q) : degree (p /ₘ q) < degree p :=
if hpq : degree p < degree q
then begin
  haveI := nontrivial.of_polynomial_ne hp0,
  rw [(div_by_monic_eq_zero_iff hq).2 hpq, degree_eq_nat_degree hp0],
  exact with_bot.bot_lt_coe _
end
else begin
  haveI := nontrivial.of_polynomial_ne hp0,
  rw [← degree_add_div_by_monic hq (not_lt.1 hpq), degree_eq_nat_degree hq.ne_zero,
        degree_eq_nat_degree (mt (div_by_monic_eq_zero_iff hq).1 hpq)],
  exact with_bot.coe_lt_coe.2 (nat.lt_add_of_pos_left
    (with_bot.coe_lt_coe.1 $ (degree_eq_nat_degree hq.ne_zero) ▸ h0q))
end

theorem nat_degree_div_by_monic {R : Type u} [comm_ring R] (f : R[X]) {g : R[X]}
  (hg : g.monic) : nat_degree (f /ₘ g) = nat_degree f - nat_degree g :=
begin
  nontriviality R,
  by_cases hfg : f /ₘ g = 0,
  { rw [hfg, nat_degree_zero], rw div_by_monic_eq_zero_iff hg at hfg,
    rw tsub_eq_zero_iff_le.mpr (nat_degree_le_nat_degree $ le_of_lt hfg) },
  have hgf := hfg, rw div_by_monic_eq_zero_iff hg at hgf, push_neg at hgf,
  have := degree_add_div_by_monic hg hgf,
  have hf : f ≠ 0, { intro hf, apply hfg, rw [hf, zero_div_by_monic] },
  rw [degree_eq_nat_degree hf, degree_eq_nat_degree hg.ne_zero, degree_eq_nat_degree hfg,
      ← with_bot.coe_add, with_bot.coe_eq_coe] at this,
  rw [← this, add_tsub_cancel_left]
end

lemma div_mod_by_monic_unique {f g} (q r : R[X]) (hg : monic g)
  (h : r + g * q = f ∧ degree r < degree g) : f /ₘ g = q ∧ f %ₘ g = r :=
begin
  nontriviality R,
  have h₁ : r - f %ₘ g = -g * (q - f /ₘ g),
    from eq_of_sub_eq_zero
      (by rw [← sub_eq_zero_of_eq (h.1.trans (mod_by_monic_add_div f hg).symm)];
        simp [mul_add, mul_comm, sub_eq_add_neg, add_comm, add_left_comm, add_assoc]),
  have h₂ : degree (r - f %ₘ g) = degree (g * (q - f /ₘ g)),
    by simp [h₁],
  have h₄ : degree (r - f %ₘ g) < degree g,
    from calc degree (r - f %ₘ g) ≤ max (degree r) (degree (f %ₘ g)) :
      degree_sub_le _ _
    ... < degree g : max_lt_iff.2 ⟨h.2, degree_mod_by_monic_lt _ hg⟩,
  have h₅ : q - (f /ₘ g) = 0,
    from by_contradiction
      (λ hqf, not_le_of_gt h₄ $
        calc degree g ≤ degree g + degree (q - f /ₘ g) :
          by erw [degree_eq_nat_degree hg.ne_zero, degree_eq_nat_degree hqf,
              with_bot.coe_le_coe];
            exact nat.le_add_right _ _
        ... = degree (r - f %ₘ g) :
          by rw [h₂, degree_mul']; simpa [monic.def.1 hg]),
  exact ⟨eq.symm $ eq_of_sub_eq_zero h₅,
    eq.symm $ eq_of_sub_eq_zero $ by simpa [h₅] using h₁⟩
end

lemma map_mod_div_by_monic [comm_ring S] (f : R →+* S) (hq : monic q) :
  (p /ₘ q).map f = p.map f /ₘ q.map f ∧ (p %ₘ q).map f = p.map f %ₘ q.map f :=
begin
  nontriviality S,
  haveI : nontrivial R := f.domain_nontrivial,
  have : map f p /ₘ map f q = map f (p /ₘ q) ∧ map f p %ₘ map f q = map f (p %ₘ q),
  { exact (div_mod_by_monic_unique ((p /ₘ q).map f) _ (hq.map f)
      ⟨eq.symm $ by rw [← map_mul, ← map_add, mod_by_monic_add_div _ hq],
      calc _ ≤ degree (p %ₘ q) : degree_map_le _ _
      ... < degree q : degree_mod_by_monic_lt _ hq
      ... = _ : eq.symm $ degree_map_eq_of_leading_coeff_ne_zero _
        (by rw [monic.def.1 hq, f.map_one]; exact one_ne_zero)⟩) },
  exact ⟨this.1.symm, this.2.symm⟩
end

lemma map_div_by_monic [comm_ring S] (f : R →+* S) (hq : monic q) :
  (p /ₘ q).map f = p.map f /ₘ q.map f :=
(map_mod_div_by_monic f hq).1

lemma map_mod_by_monic [comm_ring S] (f : R →+* S) (hq : monic q) :
  (p %ₘ q).map f = p.map f %ₘ q.map f :=
(map_mod_div_by_monic f hq).2

lemma dvd_iff_mod_by_monic_eq_zero (hq : monic q) : p %ₘ q = 0 ↔ q ∣ p :=
⟨λ h, by rw [← mod_by_monic_add_div p hq, h, zero_add];
  exact dvd_mul_right _ _,
λ h, begin
  nontriviality R,
  obtain ⟨r, hr⟩ := exists_eq_mul_right_of_dvd h,
  by_contradiction hpq0,
  have hmod : p %ₘ q = q * (r - p /ₘ q),
  { rw [mod_by_monic_eq_sub_mul_div _ hq, mul_sub, ← hr] },
  have : degree (q * (r - p /ₘ q)) < degree q :=
    hmod ▸ degree_mod_by_monic_lt _ hq,
  have hrpq0 : leading_coeff (r - p /ₘ q) ≠ 0 :=
    λ h, hpq0 $ leading_coeff_eq_zero.1
      (by rw [hmod, leading_coeff_eq_zero.1 h, mul_zero, leading_coeff_zero]),
  have hlc : leading_coeff q * leading_coeff (r - p /ₘ q) ≠ 0 :=
    by rwa [monic.def.1 hq, one_mul],
  rw [degree_mul' hlc, degree_eq_nat_degree hq.ne_zero,
      degree_eq_nat_degree (mt leading_coeff_eq_zero.2 hrpq0)] at this,
    exact not_lt_of_ge (nat.le_add_right _ _) (with_bot.some_lt_some.1 this)
end⟩

theorem map_dvd_map [comm_ring S] (f : R →+* S) (hf : function.injective f) {x y : R[X]}
  (hx : x.monic) : x.map f ∣ y.map f ↔ x ∣ y :=
begin
  rw [← dvd_iff_mod_by_monic_eq_zero hx, ← dvd_iff_mod_by_monic_eq_zero (hx.map f),
    ← map_mod_by_monic f hx],
  exact ⟨λ H, map_injective f hf $ by rw [H, map_zero],
  λ H, by rw [H, map_zero]⟩
end

@[simp] lemma mod_by_monic_one (p : R[X]) : p %ₘ 1 = 0 :=
(dvd_iff_mod_by_monic_eq_zero (by convert monic_one)).2 (one_dvd _)

@[simp] lemma div_by_monic_one (p : R[X]) : p /ₘ 1 = p :=
by conv_rhs { rw [← mod_by_monic_add_div p monic_one] }; simp

@[simp] lemma mod_by_monic_X_sub_C_eq_C_eval (p : R[X]) (a : R) :
  p %ₘ (X - C a) = C (p.eval a) :=
begin
  nontriviality R,
  have h : (p %ₘ (X - C a)).eval a = p.eval a,
  { rw [mod_by_monic_eq_sub_mul_div _ (monic_X_sub_C a), eval_sub, eval_mul,
        eval_sub, eval_X, eval_C, sub_self, zero_mul, sub_zero] },
  have : degree (p %ₘ (X - C a)) < 1 :=
    degree_X_sub_C a ▸ degree_mod_by_monic_lt p (monic_X_sub_C a),
  have : degree (p %ₘ (X - C a)) ≤ 0,
  { cases (degree (p %ₘ (X - C a))),
    { exact bot_le },
    { exact with_bot.some_le_some.2 (nat.le_of_lt_succ (with_bot.some_lt_some.1 this)) } },
  rw [eq_C_of_degree_le_zero this, eval_C] at h,
  rw [eq_C_of_degree_le_zero this, h]
end

lemma mul_div_by_monic_eq_iff_is_root : (X - C a) * (p /ₘ (X - C a)) = p ↔ is_root p a :=
⟨λ h, by rw [← h, is_root.def, eval_mul, eval_sub, eval_X, eval_C, sub_self, zero_mul],
λ h : p.eval a = 0,
  by conv {to_rhs, rw ← mod_by_monic_add_div p (monic_X_sub_C a)};
    rw [mod_by_monic_X_sub_C_eq_C_eval, h, C_0, zero_add]⟩

lemma dvd_iff_is_root : (X - C a) ∣ p ↔ is_root p a :=
⟨λ h, by rwa [← dvd_iff_mod_by_monic_eq_zero (monic_X_sub_C _),
    mod_by_monic_X_sub_C_eq_C_eval, ← C_0, C_inj] at h,
  λ h, ⟨(p /ₘ (X - C a)), by rw mul_div_by_monic_eq_iff_is_root.2 h⟩⟩

lemma mod_by_monic_X (p : R[X]) : p %ₘ X = C (p.eval 0) :=
by rw [← mod_by_monic_X_sub_C_eq_C_eval, C_0, sub_zero]

lemma eval₂_mod_by_monic_eq_self_of_root [comm_ring S] {f : R →+* S}
  {p q : R[X]} (hq : q.monic) {x : S} (hx : q.eval₂ f x = 0) :
  (p %ₘ q).eval₂ f x = p.eval₂ f x :=
by rw [mod_by_monic_eq_sub_mul_div p hq, eval₂_sub, eval₂_mul, hx, zero_mul, sub_zero]

lemma sum_fin [add_comm_monoid S] (f : ℕ → R → S) (hf : ∀ i, f i 0 = 0)
  {n : ℕ} (hn : p.degree < n) :
  ∑ (i : fin n), f i (p.coeff i) = p.sum f :=
begin
  by_cases hp : p = 0,
  { rw [hp, sum_zero_index, finset.sum_eq_zero], intros i _, exact hf i },
  rw [degree_eq_nat_degree hp, with_bot.coe_lt_coe] at hn,
  calc  ∑ (i : fin n), f i (p.coeff i)
      = ∑ i in finset.range n, f i (p.coeff i) : fin.sum_univ_eq_sum_range (λ i, f i (p.coeff i)) _
  ... = ∑ i in p.support, f i (p.coeff i) : (finset.sum_subset
    (supp_subset_range_nat_degree_succ.trans (finset.range_subset.mpr hn))
    (λ i _ hi, show f i (p.coeff i) = 0, by rw [not_mem_support_iff.mp hi, hf])).symm
  ... = p.sum f : p.sum_def _
end

lemma sum_mod_by_monic_coeff (hq : q.monic) {n : ℕ} (hn : q.degree ≤ n) :
  ∑ (i : fin n), monomial i ((p %ₘ q).coeff i) = p %ₘ q :=
begin
  nontriviality R,
  exact (sum_fin (λ i c, monomial i c) (by simp)
    ((degree_mod_by_monic_lt _ hq).trans_le hn)).trans
    (sum_monomial_eq _)
end

lemma sub_dvd_eval_sub (a b : R) (p : R[X]) : a - b ∣ p.eval a - p.eval b :=
begin
  suffices : X - C b ∣ p - C (p.eval b),
  { simpa only [coe_eval_ring_hom, eval_sub, eval_X, eval_C] using (eval_ring_hom a).map_dvd this },
  simp [dvd_iff_is_root]
end

variable (R)

lemma not_is_field : ¬ is_field R[X] :=
begin
  nontriviality R,
  rw ring.not_is_field_iff_exists_ideal_bot_lt_and_lt_top,
  use ideal.span {polynomial.X},
  split,
  { rw [bot_lt_iff_ne_bot, ne.def, ideal.span_singleton_eq_bot],
    exact polynomial.X_ne_zero, },
  { rw [lt_top_iff_ne_top, ne.def, ideal.eq_top_iff_one, ideal.mem_span_singleton,
      polynomial.X_dvd_iff, polynomial.coeff_one_zero],
    exact one_ne_zero, }
end

variable {R}

section multiplicity
/-- An algorithm for deciding polynomial divisibility.
The algorithm is "compute `p %ₘ q` and compare to `0`". `
See `polynomial.mod_by_monic` for the algorithm that computes `%ₘ`.
 -/
def decidable_dvd_monic (p : R[X]) (hq : monic q) : decidable (q ∣ p) :=
decidable_of_iff (p %ₘ q = 0) (dvd_iff_mod_by_monic_eq_zero hq)

open_locale classical

lemma multiplicity_X_sub_C_finite (a : R) (h0 : p ≠ 0) :
  multiplicity.finite (X - C a) p :=
begin
  haveI := nontrivial.of_polynomial_ne h0,
  refine multiplicity_finite_of_degree_pos_of_monic _ (monic_X_sub_C _) h0,
  rw degree_X_sub_C,
  dec_trivial,
end

/-- The largest power of `X - C a` which divides `p`.
This is computable via the divisibility algorithm `decidable_dvd_monic`. -/
def root_multiplicity (a : R) (p : R[X]) : ℕ :=
if h0 : p = 0 then 0
else let I : decidable_pred (λ n : ℕ, ¬(X - C a) ^ (n + 1) ∣ p) :=
  λ n, @not.decidable _ (decidable_dvd_monic p ((monic_X_sub_C a).pow (n + 1))) in
by exactI nat.find (multiplicity_X_sub_C_finite a h0)

lemma root_multiplicity_eq_multiplicity (p : R[X]) (a : R) :
  root_multiplicity a p = if h0 : p = 0 then 0 else
  (multiplicity (X - C a) p).get (multiplicity_X_sub_C_finite a h0) :=
by simp [multiplicity, root_multiplicity, part.dom];
  congr; funext; congr

@[simp] lemma root_multiplicity_zero {x : R} : root_multiplicity x 0 = 0 := dif_pos rfl

lemma root_multiplicity_eq_zero {p : R[X]} {x : R} (h : ¬ is_root p x) :
  root_multiplicity x p = 0 :=
begin
  rw root_multiplicity_eq_multiplicity,
  split_ifs, { refl },
  rw [← enat.coe_inj, enat.coe_get, multiplicity.multiplicity_eq_zero_of_not_dvd, nat.cast_zero],
  intro hdvd,
  exact h (dvd_iff_is_root.mp hdvd)
end

lemma root_multiplicity_pos {p : R[X]} (hp : p ≠ 0) {x : R} :
  0 < root_multiplicity x p ↔ is_root p x :=
begin
  rw [← dvd_iff_is_root, root_multiplicity_eq_multiplicity, dif_neg hp,
      ← enat.coe_lt_coe, enat.coe_get],
  exact multiplicity.dvd_iff_multiplicity_pos
end

@[simp] lemma root_multiplicity_C (r a : R) : root_multiplicity a (C r) = 0 :=
begin
  rcases eq_or_ne r 0 with rfl|hr,
  { simp },
  { exact root_multiplicity_eq_zero (not_is_root_C _ _ hr) }
end

lemma pow_root_multiplicity_dvd (p : R[X]) (a : R) :
  (X - C a) ^ root_multiplicity a p ∣ p :=
if h : p = 0 then by simp [h]
else by rw [root_multiplicity_eq_multiplicity, dif_neg h];
  exact multiplicity.pow_multiplicity_dvd _

lemma div_by_monic_mul_pow_root_multiplicity_eq
  (p : R[X]) (a : R) :
  p /ₘ ((X - C a) ^ root_multiplicity a p) *
  (X - C a) ^ root_multiplicity a p = p :=
have monic ((X - C a) ^ root_multiplicity a p),
  from (monic_X_sub_C _).pow _,
by conv_rhs { rw [← mod_by_monic_add_div p this,
    (dvd_iff_mod_by_monic_eq_zero this).2 (pow_root_multiplicity_dvd _ _)] };
  simp [mul_comm]

lemma eval_div_by_monic_pow_root_multiplicity_ne_zero
  {p : R[X]} (a : R) (hp : p ≠ 0) :
  eval a (p /ₘ ((X - C a) ^ root_multiplicity a p)) ≠ 0 :=
begin
  haveI : nontrivial R := nontrivial.of_polynomial_ne hp,
  rw [ne.def, ← is_root.def, ← dvd_iff_is_root],
  rintros ⟨q, hq⟩,
  have := div_by_monic_mul_pow_root_multiplicity_eq p a,
  rw [mul_comm, hq, ← mul_assoc, ← pow_succ',
    root_multiplicity_eq_multiplicity, dif_neg hp] at this,
  exact multiplicity.is_greatest'
    (multiplicity_finite_of_degree_pos_of_monic
    (show (0 : with_bot ℕ) < degree (X - C a),
      by rw degree_X_sub_C; exact dec_trivial) (monic_X_sub_C _) hp)
    (nat.lt_succ_self _) (dvd_of_mul_right_eq _ this)
end

end multiplicity
end comm_ring

end polynomial


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.metric_space.isometry
import Mathlib.topology.instances.ennreal
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Hausdorff distance

The Hausdorff distance on subsets of a metric (or emetric) space.

Given two subsets `s` and `t` of a metric space, their Hausdorff distance is the smallest `d`
such that any point `s` is within `d` of a point in `t`, and conversely. This quantity
is often infinite (think of `s` bounded and `t` unbounded), and therefore better
expressed in the setting of emetric spaces.

## Main definitions

This files introduces:
* `inf_edist x s`, the infimum edistance of a point `x` to a set `s` in an emetric space
* `Hausdorff_edist s t`, the Hausdorff edistance of two sets in an emetric space
* Versions of these notions on metric spaces, called respectively `inf_dist` and
`Hausdorff_dist`.
-/

namespace emetric

/-! ### Distance of a point to a set as a function into `ennreal`. -/

/-- The minimal edistance of a point to a set -/
def inf_edist {α : Type u} [emetric_space α] (x : α) (s : set α) : ennreal :=
  Inf (edist x '' s)

@[simp] theorem inf_edist_empty {α : Type u} [emetric_space α] {x : α} : inf_edist x ∅ = ⊤ := sorry

/-- The edist to a union is the minimum of the edists -/
@[simp] theorem inf_edist_union {α : Type u} [emetric_space α] {x : α} {s : set α} {t : set α} : inf_edist x (s ∪ t) = inf_edist x s ⊓ inf_edist x t := sorry

/-- The edist to a singleton is the edistance to the single point of this singleton -/
@[simp] theorem inf_edist_singleton {α : Type u} [emetric_space α] {x : α} {y : α} : inf_edist x (singleton y) = edist x y := sorry

/-- The edist to a set is bounded above by the edist to any of its points -/
theorem inf_edist_le_edist_of_mem {α : Type u} [emetric_space α] {x : α} {y : α} {s : set α} (h : y ∈ s) : inf_edist x s ≤ edist x y :=
  Inf_le (iff.mpr (set.mem_image (edist x) s (edist x y)) (Exists.intro y { left := h, right := Eq.refl (edist x y) }))

/-- If a point `x` belongs to `s`, then its edist to `s` vanishes -/
theorem inf_edist_zero_of_mem {α : Type u} [emetric_space α] {x : α} {s : set α} (h : x ∈ s) : inf_edist x s = 0 :=
  iff.mp nonpos_iff_eq_zero (edist_self x ▸ inf_edist_le_edist_of_mem h)

/-- The edist is monotonous with respect to inclusion -/
theorem inf_edist_le_inf_edist_of_subset {α : Type u} [emetric_space α] {x : α} {s : set α} {t : set α} (h : s ⊆ t) : inf_edist x t ≤ inf_edist x s :=
  Inf_le_Inf (set.image_subset (edist x) h)

/-- If the edist to a set is `< r`, there exists a point in the set at edistance `< r` -/
theorem exists_edist_lt_of_inf_edist_lt {α : Type u} [emetric_space α] {x : α} {s : set α} {r : ennreal} (h : inf_edist x s < r) : ∃ (y : α), ∃ (H : y ∈ s), edist x y < r := sorry

/-- The edist of `x` to `s` is bounded by the sum of the edist of `y` to `s` and
the edist from `x` to `y` -/
theorem inf_edist_le_inf_edist_add_edist {α : Type u} [emetric_space α] {x : α} {y : α} {s : set α} : inf_edist x s ≤ inf_edist y s + edist x y := sorry

/-- The edist to a set depends continuously on the point -/
theorem continuous_inf_edist {α : Type u} [emetric_space α] {s : set α} : continuous fun (x : α) => inf_edist x s := sorry

/-- The edist to a set and to its closure coincide -/
theorem inf_edist_closure {α : Type u} [emetric_space α] {x : α} {s : set α} : inf_edist x (closure s) = inf_edist x s := sorry

/-- A point belongs to the closure of `s` iff its infimum edistance to this set vanishes -/
theorem mem_closure_iff_inf_edist_zero {α : Type u} [emetric_space α] {x : α} {s : set α} : x ∈ closure s ↔ inf_edist x s = 0 := sorry

/-- Given a closed set `s`, a point belongs to `s` iff its infimum edistance to this set vanishes -/
theorem mem_iff_ind_edist_zero_of_closed {α : Type u} [emetric_space α] {x : α} {s : set α} (h : is_closed s) : x ∈ s ↔ inf_edist x s = 0 := sorry

/-- The infimum edistance is invariant under isometries -/
theorem inf_edist_image {α : Type u} {β : Type v} [emetric_space α] [emetric_space β] {x : α} {t : set α} {Φ : α → β} (hΦ : isometry Φ) : inf_edist (Φ x) (Φ '' t) = inf_edist x t := sorry

/-! ### The Hausdorff distance as a function into `ennreal`. -/

/-- The Hausdorff edistance between two sets is the smallest `r` such that each set
is contained in the `r`-neighborhood of the other one -/
def Hausdorff_edist {α : Type u} [emetric_space α] (s : set α) (t : set α) : ennreal :=
  Sup ((fun (x : α) => inf_edist x t) '' s) ⊔ Sup ((fun (x : α) => inf_edist x s) '' t)

theorem Hausdorff_edist_def {α : Type u} [emetric_space α] (s : set α) (t : set α) : Hausdorff_edist s t = Sup ((fun (x : α) => inf_edist x t) '' s) ⊔ Sup ((fun (x : α) => inf_edist x s) '' t) :=
  rfl

/-- The Hausdorff edistance of a set to itself vanishes -/
@[simp] theorem Hausdorff_edist_self {α : Type u} [emetric_space α] {s : set α} : Hausdorff_edist s s = 0 := sorry

/-- The Haudorff edistances of `s` to `t` and of `t` to `s` coincide -/
theorem Hausdorff_edist_comm {α : Type u} [emetric_space α] {s : set α} {t : set α} : Hausdorff_edist s t = Hausdorff_edist t s := sorry

/-- Bounding the Hausdorff edistance by bounding the edistance of any point
in each set to the other set -/
theorem Hausdorff_edist_le_of_inf_edist {α : Type u} [emetric_space α] {s : set α} {t : set α} {r : ennreal} (H1 : ∀ (x : α), x ∈ s → inf_edist x t ≤ r) (H2 : ∀ (x : α), x ∈ t → inf_edist x s ≤ r) : Hausdorff_edist s t ≤ r := sorry

/-- Bounding the Hausdorff edistance by exhibiting, for any point in each set,
another point in the other set at controlled distance -/
theorem Hausdorff_edist_le_of_mem_edist {α : Type u} [emetric_space α] {s : set α} {t : set α} {r : ennreal} (H1 : ∀ (x : α) (H : x ∈ s), ∃ (y : α), ∃ (H : y ∈ t), edist x y ≤ r) (H2 : ∀ (x : α) (H : x ∈ t), ∃ (y : α), ∃ (H : y ∈ s), edist x y ≤ r) : Hausdorff_edist s t ≤ r := sorry

/-- The distance to a set is controlled by the Hausdorff distance -/
theorem inf_edist_le_Hausdorff_edist_of_mem {α : Type u} [emetric_space α] {x : α} {s : set α} {t : set α} (h : x ∈ s) : inf_edist x t ≤ Hausdorff_edist s t :=
  eq.mpr (id (Eq._oldrec (Eq.refl (inf_edist x t ≤ Hausdorff_edist s t)) (Hausdorff_edist_def s t)))
    (le_trans (le_Sup (set.mem_image_of_mem (fun (x : α) => inf_edist x t) h)) le_sup_left)

/-- If the Hausdorff distance is `<r`, then any point in one of the sets has
a corresponding point at distance `<r` in the other set -/
theorem exists_edist_lt_of_Hausdorff_edist_lt {α : Type u} [emetric_space α] {x : α} {s : set α} {t : set α} {r : ennreal} (h : x ∈ s) (H : Hausdorff_edist s t < r) : ∃ (y : α), ∃ (H : y ∈ t), edist x y < r :=
  exists_edist_lt_of_inf_edist_lt
    (lt_of_le_of_lt (le_trans (le_Sup (set.mem_image_of_mem (fun (x : α) => inf_edist x t) h)) le_sup_left)
      (eq.mp (Eq._oldrec (Eq.refl (Hausdorff_edist s t < r)) (Hausdorff_edist_def s t)) H))

/-- The distance from `x` to `s` or `t` is controlled in terms of the Hausdorff distance
between `s` and `t` -/
theorem inf_edist_le_inf_edist_add_Hausdorff_edist {α : Type u} [emetric_space α] {x : α} {s : set α} {t : set α} : inf_edist x t ≤ inf_edist x s + Hausdorff_edist s t := sorry

/-- The Hausdorff edistance is invariant under eisometries -/
theorem Hausdorff_edist_image {α : Type u} {β : Type v} [emetric_space α] [emetric_space β] {s : set α} {t : set α} {Φ : α → β} (h : isometry Φ) : Hausdorff_edist (Φ '' s) (Φ '' t) = Hausdorff_edist s t := sorry

/-- The Hausdorff distance is controlled by the diameter of the union -/
theorem Hausdorff_edist_le_ediam {α : Type u} [emetric_space α] {s : set α} {t : set α} (hs : set.nonempty s) (ht : set.nonempty t) : Hausdorff_edist s t ≤ diam (s ∪ t) := sorry

/-- The Hausdorff distance satisfies the triangular inequality -/
theorem Hausdorff_edist_triangle {α : Type u} [emetric_space α] {s : set α} {t : set α} {u : set α} : Hausdorff_edist s u ≤ Hausdorff_edist s t + Hausdorff_edist t u := sorry

/-- The Hausdorff edistance between a set and its closure vanishes -/
@[simp] theorem Hausdorff_edist_self_closure {α : Type u} [emetric_space α] {s : set α} : Hausdorff_edist s (closure s) = 0 := sorry

/-- Replacing a set by its closure does not change the Hausdorff edistance. -/
@[simp] theorem Hausdorff_edist_closure₁ {α : Type u} [emetric_space α] {s : set α} {t : set α} : Hausdorff_edist (closure s) t = Hausdorff_edist s t := sorry

/-- Replacing a set by its closure does not change the Hausdorff edistance. -/
@[simp] theorem Hausdorff_edist_closure₂ {α : Type u} [emetric_space α] {s : set α} {t : set α} : Hausdorff_edist s (closure t) = Hausdorff_edist s t := sorry

/-- The Hausdorff edistance between sets or their closures is the same -/
@[simp] theorem Hausdorff_edist_closure {α : Type u} [emetric_space α] {s : set α} {t : set α} : Hausdorff_edist (closure s) (closure t) = Hausdorff_edist s t := sorry

/-- Two sets are at zero Hausdorff edistance if and only if they have the same closure -/
theorem Hausdorff_edist_zero_iff_closure_eq_closure {α : Type u} [emetric_space α] {s : set α} {t : set α} : Hausdorff_edist s t = 0 ↔ closure s = closure t := sorry

/-- Two closed sets are at zero Hausdorff edistance if and only if they coincide -/
theorem Hausdorff_edist_zero_iff_eq_of_closed {α : Type u} [emetric_space α] {s : set α} {t : set α} (hs : is_closed s) (ht : is_closed t) : Hausdorff_edist s t = 0 ↔ s = t := sorry

/-- The Haudorff edistance to the empty set is infinite -/
theorem Hausdorff_edist_empty {α : Type u} [emetric_space α] {s : set α} (ne : set.nonempty s) : Hausdorff_edist s ∅ = ⊤ := sorry

/-- If a set is at finite Hausdorff edistance of a nonempty set, it is nonempty -/
theorem nonempty_of_Hausdorff_edist_ne_top {α : Type u} [emetric_space α] {s : set α} {t : set α} (hs : set.nonempty s) (fin : Hausdorff_edist s t ≠ ⊤) : set.nonempty t :=
  or.elim (set.eq_empty_or_nonempty t) (fun (ht : t = ∅) => false.elim (fin (Eq.symm ht ▸ Hausdorff_edist_empty hs))) id

theorem empty_or_nonempty_of_Hausdorff_edist_ne_top {α : Type u} [emetric_space α] {s : set α} {t : set α} (fin : Hausdorff_edist s t ≠ ⊤) : s = ∅ ∧ t = ∅ ∨ set.nonempty s ∧ set.nonempty t := sorry

/-! Now, we turn to the same notions in metric spaces. To avoid the difficulties related to
`Inf` and `Sup` on `ℝ` (which is only conditionally complete), we use the notions in `ennreal`
formulated in terms of the edistance, and coerce them to `ℝ`.
Then their properties follow readily from the corresponding properties in `ennreal`,
modulo some tedious rewriting of inequalities from one to the other. -/

namespace metric

/-! ### Distance of a point to a set as a function into `ℝ`. -/

/-- The minimal distance of a point to a set -/
def Mathlib.metric.inf_dist {α : Type u} [metric_space α] (x : α) (s : set α) : ℝ :=
  ennreal.to_real (inf_edist x s)

/-- the minimal distance is always nonnegative -/
theorem Mathlib.metric.inf_dist_nonneg {α : Type u} [metric_space α] {s : set α} {x : α} : 0 ≤ metric.inf_dist x s := sorry

/-- the minimal distance to the empty set is 0 (if you want to have the more reasonable
value ∞ instead, use `inf_edist`, which takes values in ennreal) -/
@[simp] theorem Mathlib.metric.inf_dist_empty {α : Type u} [metric_space α] {x : α} : metric.inf_dist x ∅ = 0 := sorry

/-- In a metric space, the minimal edistance to a nonempty set is finite -/
theorem Mathlib.metric.inf_edist_ne_top {α : Type u} [metric_space α] {s : set α} {x : α} (h : set.nonempty s) : inf_edist x s ≠ ⊤ := sorry

/-- The minimal distance of a point to a set containing it vanishes -/
theorem Mathlib.metric.inf_dist_zero_of_mem {α : Type u} [metric_space α] {s : set α} {x : α} (h : x ∈ s) : metric.inf_dist x s = 0 := sorry

/-- The minimal distance to a singleton is the distance to the unique point in this singleton -/
@[simp] theorem Mathlib.metric.inf_dist_singleton {α : Type u} [metric_space α] {x : α} {y : α} : metric.inf_dist x (singleton y) = dist x y := sorry

/-- The minimal distance to a set is bounded by the distance to any point in this set -/
theorem Mathlib.metric.inf_dist_le_dist_of_mem {α : Type u} [metric_space α] {s : set α} {x : α} {y : α} (h : y ∈ s) : metric.inf_dist x s ≤ dist x y := sorry

/-- The minimal distance is monotonous with respect to inclusion -/
theorem Mathlib.metric.inf_dist_le_inf_dist_of_subset {α : Type u} [metric_space α] {s : set α} {t : set α} {x : α} (h : s ⊆ t) (hs : set.nonempty s) : metric.inf_dist x t ≤ metric.inf_dist x s := sorry

/-- If the minimal distance to a set is `<r`, there exists a point in this set at distance `<r` -/
theorem Mathlib.metric.exists_dist_lt_of_inf_dist_lt {α : Type u} [metric_space α] {s : set α} {x : α} {r : ℝ} (h : metric.inf_dist x s < r) (hs : set.nonempty s) : ∃ (y : α), ∃ (H : y ∈ s), dist x y < r := sorry

/-- The minimal distance from `x` to `s` is bounded by the distance from `y` to `s`, modulo
the distance between `x` and `y` -/
theorem Mathlib.metric.inf_dist_le_inf_dist_add_dist {α : Type u} [metric_space α] {s : set α} {x : α} {y : α} : metric.inf_dist x s ≤ metric.inf_dist y s + dist x y := sorry

/-- The minimal distance to a set is Lipschitz in point with constant 1 -/
theorem Mathlib.metric.lipschitz_inf_dist_pt {α : Type u} [metric_space α] (s : set α) : lipschitz_with 1 fun (x : α) => metric.inf_dist x s :=
  lipschitz_with.of_le_add fun (x y : α) => metric.inf_dist_le_inf_dist_add_dist

/-- The minimal distance to a set is uniformly continuous in point -/
theorem Mathlib.metric.uniform_continuous_inf_dist_pt {α : Type u} [metric_space α] (s : set α) : uniform_continuous fun (x : α) => metric.inf_dist x s :=
  lipschitz_with.uniform_continuous (metric.lipschitz_inf_dist_pt s)

/-- The minimal distance to a set is continuous in point -/
theorem Mathlib.metric.continuous_inf_dist_pt {α : Type u} [metric_space α] (s : set α) : continuous fun (x : α) => metric.inf_dist x s :=
  uniform_continuous.continuous (metric.uniform_continuous_inf_dist_pt s)

/-- The minimal distance to a set and its closure coincide -/
theorem Mathlib.metric.inf_dist_eq_closure {α : Type u} [metric_space α] {s : set α} {x : α} : metric.inf_dist x (closure s) = metric.inf_dist x s := sorry

/-- A point belongs to the closure of `s` iff its infimum distance to this set vanishes -/
theorem Mathlib.metric.mem_closure_iff_inf_dist_zero {α : Type u} [metric_space α] {s : set α} {x : α} (h : set.nonempty s) : x ∈ closure s ↔ metric.inf_dist x s = 0 := sorry

/-- Given a closed set `s`, a point belongs to `s` iff its infimum distance to this set vanishes -/
theorem Mathlib.metric.mem_iff_inf_dist_zero_of_closed {α : Type u} [metric_space α] {s : set α} {x : α} (h : is_closed s) (hs : set.nonempty s) : x ∈ s ↔ metric.inf_dist x s = 0 :=
  eq.mp (Eq._oldrec (Eq.refl (x ∈ closure s ↔ metric.inf_dist x s = 0)) (is_closed.closure_eq h))
    (metric.mem_closure_iff_inf_dist_zero hs)

/-- The infimum distance is invariant under isometries -/
theorem Mathlib.metric.inf_dist_image {α : Type u} {β : Type v} [metric_space α] [metric_space β] {t : set α} {x : α} {Φ : α → β} (hΦ : isometry Φ) : metric.inf_dist (Φ x) (Φ '' t) = metric.inf_dist x t := sorry

/-! ### Distance of a point to a set as a function into `ℝ≥0`. -/

/-- The minimal distance of a point to a set as a `ℝ≥0` -/
def Mathlib.metric.inf_nndist {α : Type u} [metric_space α] (x : α) (s : set α) : nnreal :=
  ennreal.to_nnreal (inf_edist x s)

@[simp] theorem Mathlib.metric.coe_inf_nndist {α : Type u} [metric_space α] {s : set α} {x : α} : ↑(metric.inf_nndist x s) = metric.inf_dist x s :=
  rfl

/-- The minimal distance to a set (as `ℝ≥0`) is Lipschitz in point with constant 1 -/
theorem Mathlib.metric.lipschitz_inf_nndist_pt {α : Type u} [metric_space α] (s : set α) : lipschitz_with 1 fun (x : α) => metric.inf_nndist x s :=
  lipschitz_with.of_le_add fun (x y : α) => metric.inf_dist_le_inf_dist_add_dist

/-- The minimal distance to a set (as `ℝ≥0`) is uniformly continuous in point -/
theorem Mathlib.metric.uniform_continuous_inf_nndist_pt {α : Type u} [metric_space α] (s : set α) : uniform_continuous fun (x : α) => metric.inf_nndist x s :=
  lipschitz_with.uniform_continuous (metric.lipschitz_inf_nndist_pt s)

/-- The minimal distance to a set (as `ℝ≥0`) is continuous in point -/
theorem Mathlib.metric.continuous_inf_nndist_pt {α : Type u} [metric_space α] (s : set α) : continuous fun (x : α) => metric.inf_nndist x s :=
  uniform_continuous.continuous (metric.uniform_continuous_inf_nndist_pt s)

/-! ### The Hausdorff distance as a function into `ℝ`. -/

/-- The Hausdorff distance between two sets is the smallest nonnegative `r` such that each set is
included in the `r`-neighborhood of the other. If there is no such `r`, it is defined to
be `0`, arbitrarily -/
def Mathlib.metric.Hausdorff_dist {α : Type u} [metric_space α] (s : set α) (t : set α) : ℝ :=
  ennreal.to_real (Hausdorff_edist s t)

/-- The Hausdorff distance is nonnegative -/
theorem Mathlib.metric.Hausdorff_dist_nonneg {α : Type u} [metric_space α] {s : set α} {t : set α} : 0 ≤ metric.Hausdorff_dist s t := sorry

/-- If two sets are nonempty and bounded in a metric space, they are at finite Hausdorff
edistance. -/
theorem Mathlib.metric.Hausdorff_edist_ne_top_of_nonempty_of_bounded {α : Type u} [metric_space α] {s : set α} {t : set α} (hs : set.nonempty s) (ht : set.nonempty t) (bs : metric.bounded s) (bt : metric.bounded t) : Hausdorff_edist s t ≠ ⊤ := sorry

/-- The Hausdorff distance between a set and itself is zero -/
@[simp] theorem Mathlib.metric.Hausdorff_dist_self_zero {α : Type u} [metric_space α] {s : set α} : metric.Hausdorff_dist s s = 0 := sorry

/-- The Hausdorff distance from `s` to `t` and from `t` to `s` coincide -/
theorem Mathlib.metric.Hausdorff_dist_comm {α : Type u} [metric_space α] {s : set α} {t : set α} : metric.Hausdorff_dist s t = metric.Hausdorff_dist t s := sorry

/-- The Hausdorff distance to the empty set vanishes (if you want to have the more reasonable
value ∞ instead, use `Hausdorff_edist`, which takes values in ennreal) -/
@[simp] theorem Mathlib.metric.Hausdorff_dist_empty {α : Type u} [metric_space α] {s : set α} : metric.Hausdorff_dist s ∅ = 0 := sorry

/-- The Hausdorff distance to the empty set vanishes (if you want to have the more reasonable
value ∞ instead, use `Hausdorff_edist`, which takes values in ennreal) -/
@[simp] theorem Mathlib.metric.Hausdorff_dist_empty' {α : Type u} [metric_space α] {s : set α} : metric.Hausdorff_dist ∅ s = 0 := sorry

/-- Bounding the Hausdorff distance by bounding the distance of any point
in each set to the other set -/
theorem Mathlib.metric.Hausdorff_dist_le_of_inf_dist {α : Type u} [metric_space α] {s : set α} {t : set α} {r : ℝ} (hr : 0 ≤ r) (H1 : ∀ (x : α), x ∈ s → metric.inf_dist x t ≤ r) (H2 : ∀ (x : α), x ∈ t → metric.inf_dist x s ≤ r) : metric.Hausdorff_dist s t ≤ r := sorry

/-- Bounding the Hausdorff distance by exhibiting, for any point in each set,
another point in the other set at controlled distance -/
theorem Mathlib.metric.Hausdorff_dist_le_of_mem_dist {α : Type u} [metric_space α] {s : set α} {t : set α} {r : ℝ} (hr : 0 ≤ r) (H1 : ∀ (x : α) (H : x ∈ s), ∃ (y : α), ∃ (H : y ∈ t), dist x y ≤ r) (H2 : ∀ (x : α) (H : x ∈ t), ∃ (y : α), ∃ (H : y ∈ s), dist x y ≤ r) : metric.Hausdorff_dist s t ≤ r := sorry

/-- The Hausdorff distance is controlled by the diameter of the union -/
theorem Mathlib.metric.Hausdorff_dist_le_diam {α : Type u} [metric_space α] {s : set α} {t : set α} (hs : set.nonempty s) (bs : metric.bounded s) (ht : set.nonempty t) (bt : metric.bounded t) : metric.Hausdorff_dist s t ≤ metric.diam (s ∪ t) := sorry

/-- The distance to a set is controlled by the Hausdorff distance -/
theorem Mathlib.metric.inf_dist_le_Hausdorff_dist_of_mem {α : Type u} [metric_space α] {s : set α} {t : set α} {x : α} (hx : x ∈ s) (fin : Hausdorff_edist s t ≠ ⊤) : metric.inf_dist x t ≤ metric.Hausdorff_dist s t := sorry

/-- If the Hausdorff distance is `<r`, then any point in one of the sets is at distance
`<r` of a point in the other set -/
theorem Mathlib.metric.exists_dist_lt_of_Hausdorff_dist_lt {α : Type u} [metric_space α] {s : set α} {t : set α} {x : α} {r : ℝ} (h : x ∈ s) (H : metric.Hausdorff_dist s t < r) (fin : Hausdorff_edist s t ≠ ⊤) : ∃ (y : α), ∃ (H : y ∈ t), dist x y < r := sorry

/-- If the Hausdorff distance is `<r`, then any point in one of the sets is at distance
`<r` of a point in the other set -/
theorem Mathlib.metric.exists_dist_lt_of_Hausdorff_dist_lt' {α : Type u} [metric_space α] {s : set α} {t : set α} {y : α} {r : ℝ} (h : y ∈ t) (H : metric.Hausdorff_dist s t < r) (fin : Hausdorff_edist s t ≠ ⊤) : ∃ (x : α), ∃ (H : x ∈ s), dist x y < r := sorry

/-- The infimum distance to `s` and `t` are the same, up to the Hausdorff distance
between `s` and `t` -/
theorem Mathlib.metric.inf_dist_le_inf_dist_add_Hausdorff_dist {α : Type u} [metric_space α] {s : set α} {t : set α} {x : α} (fin : Hausdorff_edist s t ≠ ⊤) : metric.inf_dist x t ≤ metric.inf_dist x s + metric.Hausdorff_dist s t := sorry

/-- The Hausdorff distance is invariant under isometries -/
theorem Mathlib.metric.Hausdorff_dist_image {α : Type u} {β : Type v} [metric_space α] [metric_space β] {s : set α} {t : set α} {Φ : α → β} (h : isometry Φ) : metric.Hausdorff_dist (Φ '' s) (Φ '' t) = metric.Hausdorff_dist s t := sorry

/-- The Hausdorff distance satisfies the triangular inequality -/
theorem Mathlib.metric.Hausdorff_dist_triangle {α : Type u} [metric_space α] {s : set α} {t : set α} {u : set α} (fin : Hausdorff_edist s t ≠ ⊤) : metric.Hausdorff_dist s u ≤ metric.Hausdorff_dist s t + metric.Hausdorff_dist t u := sorry

/-- The Hausdorff distance satisfies the triangular inequality -/
theorem Mathlib.metric.Hausdorff_dist_triangle' {α : Type u} [metric_space α] {s : set α} {t : set α} {u : set α} (fin : Hausdorff_edist t u ≠ ⊤) : metric.Hausdorff_dist s u ≤ metric.Hausdorff_dist s t + metric.Hausdorff_dist t u := sorry

/-- The Hausdorff distance between a set and its closure vanish -/
@[simp] theorem Mathlib.metric.Hausdorff_dist_self_closure {α : Type u} [metric_space α] {s : set α} : metric.Hausdorff_dist s (closure s) = 0 := sorry

/-- Replacing a set by its closure does not change the Hausdorff distance. -/
@[simp] theorem Mathlib.metric.Hausdorff_dist_closure₁ {α : Type u} [metric_space α] {s : set α} {t : set α} : metric.Hausdorff_dist (closure s) t = metric.Hausdorff_dist s t := sorry

/-- Replacing a set by its closure does not change the Hausdorff distance. -/
@[simp] theorem Mathlib.metric.Hausdorff_dist_closure₂ {α : Type u} [metric_space α] {s : set α} {t : set α} : metric.Hausdorff_dist s (closure t) = metric.Hausdorff_dist s t := sorry

/-- The Hausdorff distance between two sets and their closures coincide -/
@[simp] theorem Mathlib.metric.Hausdorff_dist_closure {α : Type u} [metric_space α] {s : set α} {t : set α} : metric.Hausdorff_dist (closure s) (closure t) = metric.Hausdorff_dist s t := sorry

/-- Two sets are at zero Hausdorff distance if and only if they have the same closures -/
theorem Mathlib.metric.Hausdorff_dist_zero_iff_closure_eq_closure {α : Type u} [metric_space α] {s : set α} {t : set α} (fin : Hausdorff_edist s t ≠ ⊤) : metric.Hausdorff_dist s t = 0 ↔ closure s = closure t := sorry

/-- Two closed sets are at zero Hausdorff distance if and only if they coincide -/
theorem Mathlib.metric.Hausdorff_dist_zero_iff_eq_of_closed {α : Type u} [metric_space α] {s : set α} {t : set α} (hs : is_closed s) (ht : is_closed t) (fin : Hausdorff_edist s t ≠ ⊤) : metric.Hausdorff_dist s t = 0 ↔ s = t := sorry


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

import number_theory.bernoulli_polynomials
import analysis.special_functions.integrals
import measure_theory.integral.interval_integral
import analysis.fourier.add_circle
import analysis.p_series

/-!
# Critical values of the Riemann zeta function

In this file we prove formulae for the critical values of `ζ(s)`, and more generally of Hurwitz
zeta functions, in terms of Bernoulli polynomials.

## Main results:

* `has_sum_zeta_nat`: the final formula for zeta values,
  $$\zeta(2k) = \frac{(-1)^{(k + 1)} 2 ^ {2k - 1} \pi^{2k} B_{2 k}}{(2 k)!}.$$
* `has_sum_zeta_two` and `has_sum_zeta_four`: special cases given explicitly.
* `has_sum_one_div_nat_pow_mul_cos`: a formula for the sum `∑ (n : ℕ), cos (2 π i n x) / n ^ k` as
  an explicit multiple of `Bₖ(x)`, for any `x ∈ [0, 1]` and `k ≥ 2` even.
* `has_sum_one_div_nat_pow_mul_sin`: a formula for the sum `∑ (n : ℕ), sin (2 π i n x) / n ^ k` as
  an explicit multiple of `Bₖ(x)`, for any `x ∈ [0, 1]` and `k ≥ 3` odd.
-/

noncomputable theory
open_locale nat real interval
open complex measure_theory set interval_integral

local notation `𝕌` := unit_add_circle
local attribute [instance] real.fact_zero_lt_one

section bernoulli_fun_props
/-! Simple properties of the Bernoulli polynomial, as a function `ℝ → ℝ`. -/

/-- The function `x ↦ Bₖ(x) : ℝ → ℝ`. -/
def bernoulli_fun (k : ℕ) (x : ℝ) : ℝ :=
(polynomial.map (algebra_map ℚ ℝ) (polynomial.bernoulli k)).eval x

lemma bernoulli_fun_eval_zero (k : ℕ) : bernoulli_fun k 0 = bernoulli k :=
by rw [bernoulli_fun, polynomial.eval_zero_map, polynomial.bernoulli_eval_zero, eq_rat_cast]

lemma bernoulli_fun_endpoints_eq_of_ne_one {k : ℕ} (hk : k ≠ 1) :
  bernoulli_fun k 1 = bernoulli_fun k 0 :=
by rw [bernoulli_fun_eval_zero, bernoulli_fun, polynomial.eval_one_map,
  polynomial.bernoulli_eval_one, bernoulli_eq_bernoulli'_of_ne_one hk, eq_rat_cast]

lemma bernoulli_fun_eval_one (k : ℕ) : bernoulli_fun k 1 = bernoulli_fun k 0 + ite (k = 1) 1 0 :=
begin
  rw [bernoulli_fun, bernoulli_fun_eval_zero, polynomial.eval_one_map,
    polynomial.bernoulli_eval_one],
  split_ifs,
  { rw [h, bernoulli_one, bernoulli'_one, eq_rat_cast],
    push_cast, ring },
  { rw [bernoulli_eq_bernoulli'_of_ne_one h, add_zero, eq_rat_cast], }
end

lemma has_deriv_at_bernoulli_fun (k : ℕ) (x : ℝ) :
  has_deriv_at (bernoulli_fun k) (k * bernoulli_fun (k - 1) x) x :=
begin
  convert ((polynomial.bernoulli k).map $ algebra_map ℚ ℝ).has_deriv_at x using 1,
  simp only [bernoulli_fun, polynomial.derivative_map, polynomial.derivative_bernoulli k,
    polynomial.map_mul, polynomial.map_nat_cast, polynomial.eval_mul, polynomial.eval_nat_cast],
end

lemma antideriv_bernoulli_fun (k : ℕ) (x : ℝ) :
  has_deriv_at (λ x, (bernoulli_fun (k + 1) x) / (k + 1)) (bernoulli_fun k x) x :=
begin
  convert (has_deriv_at_bernoulli_fun (k + 1) x).div_const _,
  field_simp [nat.cast_add_one_ne_zero k],
  ring,
end

lemma integral_bernoulli_fun_eq_zero {k : ℕ} (hk : k ≠ 0) :
  ∫ (x : ℝ) in 0..1, bernoulli_fun k x = 0 :=
begin
  rw integral_eq_sub_of_has_deriv_at (λ x hx, antideriv_bernoulli_fun k x)
    ((polynomial.continuous _).interval_integrable _ _),
  dsimp only,
  rw bernoulli_fun_eval_one,
  split_ifs,
  { exfalso, exact hk (nat.succ_inj'.mp h), }, { simp },
end

end bernoulli_fun_props

section bernoulli_fourier_coeffs
/-! Compute the Fourier coefficients of the Bernoulli functions via integration by parts. -/

/-- The `n`-th Fourier coefficient of the `k`-th Bernoulli function on the interval `[0, 1]`. -/
def bernoulli_fourier_coeff (k : ℕ) (n : ℤ) : ℂ :=
fourier_coeff_on zero_lt_one (λ x, bernoulli_fun k x) n

/-- Recurrence relation (in `k`) for the `n`-th Fourier coefficient of `Bₖ`. -/
lemma bernoulli_fourier_coeff_recurrence (k : ℕ) {n : ℤ} (hn : n ≠ 0) :
  bernoulli_fourier_coeff k n = 1 / ((-2) * π * I * n) *
  (ite (k = 1) 1 0 - k * bernoulli_fourier_coeff (k - 1) n) :=
begin
  unfold bernoulli_fourier_coeff,
  rw [fourier_coeff_on_of_has_deriv_at zero_lt_one
    hn (λ x hx, (has_deriv_at_bernoulli_fun k x).of_real_comp)
    ((continuous_of_real.comp $ continuous_const.mul
      $ polynomial.continuous _).interval_integrable _ _)],
  dsimp only,
  simp_rw [of_real_one, of_real_zero, sub_zero, one_mul],
  rw [quotient_add_group.coe_zero, fourier_eval_zero, one_mul,
    ←of_real_sub, bernoulli_fun_eval_one, add_sub_cancel'],
  congr' 2,
  { split_ifs, all_goals { simp only [of_real_one, of_real_zero, one_mul]}, },
  { simp_rw [of_real_mul, of_real_nat_cast, fourier_coeff_on.const_mul] },
end

/-- The Fourier coefficients of `B₀(x) = 1`. -/
lemma bernoulli_zero_fourier_coeff {n : ℤ} (hn : n ≠ 0) : bernoulli_fourier_coeff 0 n = 0 :=
by simpa using bernoulli_fourier_coeff_recurrence 0 hn

/-- The `0`-th Fourier coefficient of `Bₖ(x)`. -/
lemma bernoulli_fourier_coeff_zero {k : ℕ} (hk : k ≠ 0) : bernoulli_fourier_coeff k 0 = 0 :=
by simp_rw [bernoulli_fourier_coeff, fourier_coeff_on_eq_integral, neg_zero, fourier_zero, sub_zero,
  div_one, one_smul, interval_integral.integral_of_real, integral_bernoulli_fun_eq_zero hk,
  of_real_zero]

lemma bernoulli_fourier_coeff_eq {k : ℕ} (hk : k ≠ 0) (n : ℤ) :
  bernoulli_fourier_coeff k n = - k! / (2 * π * I * n) ^ k :=
begin
  rcases eq_or_ne n 0 with rfl|hn,
  { rw [bernoulli_fourier_coeff_zero hk, int.cast_zero, mul_zero,
    zero_pow' _ hk, div_zero] },
  refine nat.le_induction _ (λ k hk h'k, _) k (nat.one_le_iff_ne_zero.mpr hk),
  { rw bernoulli_fourier_coeff_recurrence 1 hn,
    simp only [nat.cast_one, tsub_self, neg_mul, one_mul, eq_self_iff_true, if_true,
      nat.factorial_one, pow_one, inv_I, mul_neg],
    rw [bernoulli_zero_fourier_coeff hn, sub_zero, mul_one, div_neg, neg_div], },
  { rw [bernoulli_fourier_coeff_recurrence (k + 1) hn, nat.add_sub_cancel k 1],
    split_ifs,
    { exfalso, exact (ne_of_gt (nat.lt_succ_iff.mpr hk)) h,},
    { rw [h'k, nat.factorial_succ, zero_sub, nat.cast_mul, pow_add, pow_one, neg_div,
        mul_neg, mul_neg, mul_neg, neg_neg, neg_mul, neg_mul, neg_mul, div_neg],
      field_simp [int.cast_ne_zero.mpr hn, I_ne_zero],
      ring_nf, } }
end

end bernoulli_fourier_coeffs

section bernoulli_periodized
/-! In this section we use the above evaluations of the Fourier coefficients of Bernoulli
polynomials, together with the theorem `has_pointwise_sum_fourier_series_of_summable` from Fourier
theory, to obtain an explicit formula for `∑ (n:ℤ), 1 / n ^ k * fourier n x`. -/

/-- The Bernoulli polynomial, extended from `[0, 1)` to the unit circle. -/
def periodized_bernoulli (k : ℕ) : 𝕌 → ℝ := add_circle.lift_Ico 1 0 (bernoulli_fun k)

lemma periodized_bernoulli.continuous {k : ℕ} (hk : k ≠ 1) : continuous (periodized_bernoulli k) :=
add_circle.lift_Ico_zero_continuous
  (by exact_mod_cast (bernoulli_fun_endpoints_eq_of_ne_one hk).symm)
  (polynomial.continuous _).continuous_on

lemma fourier_coeff_bernoulli_eq {k : ℕ} (hk : k ≠ 0) (n : ℤ) :
  fourier_coeff (coe ∘ periodized_bernoulli k : 𝕌 → ℂ) n = -k! / (2 * π * I * n) ^ k :=
begin
  have : (coe ∘ periodized_bernoulli k : 𝕌 → ℂ) = add_circle.lift_Ico 1 0 (coe ∘ bernoulli_fun k),
  { ext1 x, refl },
  rw [this, fourier_coeff_lift_Ico_eq],
  simpa only [zero_add] using bernoulli_fourier_coeff_eq hk n,
end

lemma summable_bernoulli_fourier {k : ℕ} (hk : 2 ≤ k) :
  summable (λ n, -k! / (2 * π * I * n) ^ k : ℤ → ℂ) :=
begin
  have : ∀ (n : ℤ), -(k! : ℂ) / (2 * π * I * n) ^ k
    = (-k! / (2 * π * I) ^ k) * (1 / n ^ k),
  { intro n, rw [mul_one_div, div_div, ←mul_pow], },
  simp_rw this,
  apply summable.mul_left,
  rw ←summable_norm_iff,
  have : (λ (x : ℤ), ‖1 / (x:ℂ) ^ k‖) = (λ (x : ℤ), |1 / (x:ℝ) ^ k|),
  { ext1 x,
    rw [norm_eq_abs, ←complex.abs_of_real],
    congr' 1,
    norm_cast },
  simp_rw this,
  rw [summable_abs_iff],
  exact real.summable_one_div_int_pow.mpr (one_lt_two.trans_le hk),
end

lemma has_sum_one_div_pow_mul_fourier_mul_bernoulli_fun {k : ℕ} (hk : 2 ≤ k)
  {x : ℝ} (hx : x ∈ Icc (0:ℝ) 1) :
  has_sum (λ n:ℤ, 1 / (n:ℂ) ^ k * fourier n (x : 𝕌)) (-(2 * π * I) ^ k / k! * bernoulli_fun k x) :=
begin
  -- first show it suffices to prove result for `Ico 0 1`
  suffices : ∀ {y : ℝ}, y ∈ Ico (0:ℝ) 1 → has_sum _ _,
  { rw [←Ico_insert_right (zero_le_one' ℝ), mem_insert_iff, or.comm] at hx,
    rcases hx with hx | rfl,
    { exact this hx },
    { convert this (left_mem_Ico.mpr zero_lt_one) using 1,
      { rw [add_circle.coe_period, quotient_add_group.coe_zero], },
      { rw bernoulli_fun_endpoints_eq_of_ne_one (by linarith : k ≠ 1) } } },
  intros y hy,
  let B : C(𝕌, ℂ) := continuous_map.mk (coe ∘ periodized_bernoulli k)
    (continuous_of_real.comp (periodized_bernoulli.continuous (by linarith))),
  have step1 : ∀ (n:ℤ), fourier_coeff B n = -k! / (2 * π * I * n) ^ k,
  { rw continuous_map.coe_mk, exact fourier_coeff_bernoulli_eq (by linarith : k ≠ 0) },
  have step2 := has_pointwise_sum_fourier_series_of_summable ((summable_bernoulli_fourier hk).congr
    (λ n, (step1 n).symm)) y,
  simp_rw step1 at step2,
  convert step2.mul_left ((-(2 * ↑π * I) ^ k) / (k! : ℂ)) using 2,
  ext1 n,
  rw [smul_eq_mul, ←mul_assoc, mul_div, mul_neg, div_mul_cancel, neg_neg, mul_pow _ ↑n, ←div_div,
    div_self],
  { rw [ne.def, pow_eq_zero_iff', not_and_distrib],
    exact or.inl two_pi_I_ne_zero, },
  { exact nat.cast_ne_zero.mpr (nat.factorial_ne_zero _), },
  { rw [continuous_map.coe_mk, function.comp_app, of_real_inj,
      periodized_bernoulli, add_circle.lift_Ico_coe_apply (by rwa zero_add)] },
end

end bernoulli_periodized

section cleanup
/- This section is just reformulating the results in a nicer form. -/

lemma has_sum_one_div_nat_pow_mul_fourier {k : ℕ} (hk : 2 ≤ k) {x : ℝ} (hx : x ∈ Icc (0:ℝ) 1) :
  has_sum (λ n:ℕ, 1 / (n:ℂ) ^ k * (fourier n (x : 𝕌) + (-1) ^ k * fourier (-n) (x : 𝕌)))
  (-(2 * π * I) ^ k / k! * bernoulli_fun k x) :=
begin
  convert (has_sum_one_div_pow_mul_fourier_mul_bernoulli_fun hk hx).sum_nat_of_sum_int,
  { ext1 n,
    rw [int.cast_neg, mul_add, ←mul_assoc],
    conv_rhs { rw [neg_eq_neg_one_mul, mul_pow, ←div_div] },
    congr' 2,
    rw [div_mul_eq_mul_div₀, one_mul],
    congr' 1,
    rw [eq_div_iff, ←mul_pow, ←neg_eq_neg_one_mul, neg_neg, one_pow],
    apply pow_ne_zero, rw neg_ne_zero, exact one_ne_zero, },
  { rw [int.cast_zero, zero_pow (by linarith : 0 < k), div_zero, zero_mul, add_zero] },
end

lemma has_sum_one_div_nat_pow_mul_cos {k : ℕ} (hk : k ≠ 0) {x : ℝ} (hx : x ∈ Icc (0:ℝ) 1) :
  has_sum (λ n:ℕ, 1 / (n:ℝ) ^ (2 * k) * real.cos (2 * π * n * x))
  ((-1) ^ (k + 1) * (2 * π) ^ (2 * k) / 2 / (2 * k)! *
  (polynomial.map (algebra_map ℚ ℝ) (polynomial.bernoulli (2 * k))).eval x) :=
begin
  have : has_sum (λ n:ℕ, 1 / (n:ℂ) ^ (2 * k) * (fourier n (x : 𝕌) + fourier (-n) (x : 𝕌)))
  ((-1) ^ (k + 1) * (2 * π) ^ (2 * k) / (2 * k)! * bernoulli_fun (2 * k) x),
  { convert (has_sum_one_div_nat_pow_mul_fourier
      (by linarith [nat.one_le_iff_ne_zero.mpr hk] : 2 ≤ 2 * k) hx),
    { ext1 n,
      rw [pow_mul (-1 : ℂ),neg_one_sq, one_pow, one_mul], },
    { rw [pow_add, pow_one],
      conv_rhs { rw [mul_pow], congr, congr, skip, rw [pow_mul, I_sq] },
      ring, } },
  convert ((has_sum_iff _ _).mp (this.div_const 2)).1,
  { ext1 n,
    convert (of_real_re _).symm,
    rw of_real_mul,rw ←mul_div, congr,
    { rw [of_real_div, of_real_one, of_real_pow], refl, },
    { rw [of_real_cos, of_real_mul, fourier_coe_apply, fourier_coe_apply, cos, of_real_one, div_one,
        div_one, of_real_mul, of_real_mul, of_real_bit0, of_real_one, int.cast_neg,
        int.cast_coe_nat, of_real_nat_cast],
      congr' 3,
      { ring }, { ring }, }, },
  { convert (of_real_re _).symm,
    rw [of_real_mul, of_real_div, of_real_div, of_real_mul, of_real_pow, of_real_pow, of_real_neg,
      of_real_nat_cast, of_real_mul, of_real_bit0, of_real_one],
    ring },
end

lemma has_sum_one_div_nat_pow_mul_sin {k : ℕ} (hk : k ≠ 0) {x : ℝ} (hx : x ∈ Icc (0:ℝ) 1) :
  has_sum (λ n:ℕ, 1 / (n:ℝ) ^ (2 * k + 1) * real.sin (2 * π * n * x))
  ((-1) ^ (k + 1) * (2 * π) ^ (2 * k + 1) / 2 / (2 * k + 1)! *
  (polynomial.map (algebra_map ℚ ℝ) (polynomial.bernoulli (2 * k + 1))).eval x) :=
begin
  have : has_sum (λ n:ℕ, 1 / (n:ℂ) ^ (2 * k + 1) * (fourier n (x : 𝕌) - fourier (-n) (x : 𝕌)))
  ((-1)^(k + 1) * I * (2 * π)^(2 * k + 1) / (2 * k + 1)! * bernoulli_fun (2 * k + 1) x),
  { convert (has_sum_one_div_nat_pow_mul_fourier
    (by linarith [nat.one_le_iff_ne_zero.mpr hk] : 2 ≤ 2 * k + 1) hx),
    { ext1 n,
      rw [pow_add (-1: ℂ), pow_mul (-1 : ℂ), neg_one_sq, one_pow, one_mul, pow_one,
        ←neg_eq_neg_one_mul, ←sub_eq_add_neg], },
    { rw [pow_add, pow_one],
      conv_rhs { rw [mul_pow], congr, congr, skip, rw [pow_add, pow_one, pow_mul, I_sq] },
      ring, }, },
  convert ((has_sum_iff _ _).mp (this.div_const (2 * I))).1,
  { ext1 n,
    convert (of_real_re _).symm,
    rw of_real_mul,rw ←mul_div, congr,
    { rw [of_real_div, of_real_one, of_real_pow], refl, },
    { rw [of_real_sin, of_real_mul, fourier_coe_apply, fourier_coe_apply, sin, of_real_one, div_one,
        div_one, of_real_mul, of_real_mul, of_real_bit0, of_real_one, int.cast_neg,
        int.cast_coe_nat, of_real_nat_cast, ←div_div, div_I, div_mul_eq_mul_div₀, ←neg_div,
        ←neg_mul, neg_sub],
      congr' 4,
      { ring, }, { ring }, }, },
  { convert (of_real_re _).symm,
    rw [of_real_mul, of_real_div, of_real_div, of_real_mul, of_real_pow, of_real_pow, of_real_neg,
      of_real_nat_cast, of_real_mul, of_real_bit0, of_real_one,
      ←div_div, div_I, div_mul_eq_mul_div₀],
    have : ∀ (α β γ δ : ℂ), α * I * β / γ * δ * I = I ^ 2 * α * β / γ * δ := by { intros, ring },
    rw [this, I_sq],
    ring, },
end

lemma has_sum_zeta_nat {k : ℕ} (hk : k ≠ 0) : has_sum (λ n:ℕ, 1 / (n:ℝ) ^ (2 * k))
  ((-1) ^ (k + 1) * 2 ^ (2 * k - 1) * π ^ (2 * k) * bernoulli (2 * k) / (2 * k)!) :=
begin
  convert has_sum_one_div_nat_pow_mul_cos hk (left_mem_Icc.mpr zero_le_one),
  { ext1 n, rw [mul_zero, real.cos_zero, mul_one], },
  rw [polynomial.eval_zero_map, polynomial.bernoulli_eval_zero, eq_rat_cast],
  have : (2:ℝ) ^ (2 * k - 1) = (2:ℝ) ^ (2 * k) / 2,
  { rw eq_div_iff (two_ne_zero' ℝ),
    conv_lhs { congr, skip, rw ←pow_one (2:ℝ) },
    rw [←pow_add, nat.sub_add_cancel],
    linarith [nat.one_le_iff_ne_zero.mpr hk], },
  rw [this, mul_pow],
  ring,
end

end cleanup

section examples

lemma has_sum_zeta_two : has_sum (λ n:ℕ, 1 / (n : ℝ) ^ 2) (π ^ 2 / 6) :=
begin
  convert has_sum_zeta_nat one_ne_zero using 1, rw mul_one,
  rw [bernoulli_eq_bernoulli'_of_ne_one (by dec_trivial : 2 ≠ 1), bernoulli'_two],
  norm_num, field_simp, ring,
end

lemma has_sum_zeta_four : has_sum (λ n:ℕ, 1 / (n : ℝ) ^ 4) (π ^ 4 / 90) :=
begin
  convert has_sum_zeta_nat two_ne_zero using 1, norm_num,
  rw [bernoulli_eq_bernoulli'_of_ne_one, bernoulli'_four],
  norm_num, field_simp, ring, dec_trivial,
end

lemma polynomial.bernoulli_three_eval_one_quarter :
  (polynomial.bernoulli 3).eval (1 / 4) = 3 / 64 :=
begin
  simp_rw [polynomial.bernoulli, finset.sum_range_succ, polynomial.eval_add,
    polynomial.eval_monomial],
  rw [finset.sum_range_zero, polynomial.eval_zero, zero_add, bernoulli_one],
  rw [bernoulli_eq_bernoulli'_of_ne_one zero_ne_one, bernoulli'_zero,
      bernoulli_eq_bernoulli'_of_ne_one (by dec_trivial : 2 ≠ 1), bernoulli'_two,
      bernoulli_eq_bernoulli'_of_ne_one (by dec_trivial : 3 ≠ 1), bernoulli'_three],
  norm_num,
end

/-- Explicit formula for `L(χ, 3)`, where `χ` is the unique nontrivial Dirichlet character modulo 4.
-/
lemma has_sum_L_function_mod_four_eval_three :
  has_sum (λ n:ℕ, (1 / (n:ℝ) ^ 3 * real.sin (π * n / 2))) (π ^ 3 / 32) :=
begin
  convert has_sum_one_div_nat_pow_mul_sin one_ne_zero (_ : 1 / 4 ∈ Icc (0:ℝ) 1),
  { ext1 n,
    norm_num,
    left,
    congr' 1,
    ring, },
  { have : (1 / 4 : ℝ) = (algebra_map ℚ ℝ) (1 / 4 : ℚ), by norm_num,
    rw [this, mul_pow, polynomial.eval_map, polynomial.eval₂_at_apply,
      (by dec_trivial : 2 * 1 + 1 = 3), polynomial.bernoulli_three_eval_one_quarter],
    norm_num, field_simp, ring },
  { rw mem_Icc, split, linarith, linarith, },
end

end examples


import computability.turing_machine
import computability.tm_computable
import tactic
import data.fintype.basic
import data.fintype.card
import data.pi
import data.nat.pow
import data.nat.log

open_locale big_operators

-- set_option pp.implicit true

/-
  This file contains theorems about Turing machines (in the TM2 model) with space restrictions

  # Definitions
    * `bounded_stacks` A finite type consisting of |K| stacks, each of at most size M
    * `bounded_cfg` A finite type representing a configuration whose stacks are bounded by M
                      (i.e. using `bounded_stacks`)
    * `bounded_cfg' M c` Given M : ℕ and c : cfg, does c take up O(M) space
      (more preciesely, it simply checks if every stack has at most M elements)
    * `bounded_cfg_to_cfg` a bijection between the finite type `bounded_cfg`
                            and cfg's satisfying `bounded_cfg'`

  # Theorems
    * `bounded_stacks_size` Given M, gives an upper bound
                            for the number of possible configurations of `bounded_stacks M`
    * `cfg_space_upper_bound_finitely_many` Gives an upper bound of the form O(2^(O(M)))
                            for the number of possible configurations satisfying bounded_cfg'.
-/

/-
  Here we just list some useful generic lemmas that are used in the file
-/

-- A wrapper for multiset.sum_le_card_nsmul for finite types instead of sets
-- (Simplifying `map` each time is a little annoying)
lemma sum_bound {α : Type} [fintype α] (f : α → ℕ) (b : ℕ) (f_bound: ∀a : α, f a ≤ b)
  : ∑ a : α, f a ≤ (fintype.card α) * b := begin
    have : ∑ a : α, f a = (multiset.map f finset.univ.val).sum := by refl,
    rw this,
    have : fintype.card α = (multiset.map f finset.univ.val).card := by {
      rw multiset.card_map f finset.univ.val, refl,
    },
    rw this,
    apply multiset.sum_le_card_nsmul,
    finish,
end

-- A wrapper for multiset.prod_le_of_forall_le for finite types instead of sets
lemma prod_bound {α : Type*} [fintype α] (f : α → ℕ) (b : ℕ) (f_bound: ∀a : α, f a ≤ b)
  : ∏ a : α, f a ≤ b ^ (fintype.card α) := begin
    have : ∏ a : α, f a  = (multiset.map f finset.univ.val).prod := by refl,
    rw this,
    have : fintype.card α = (multiset.map f finset.univ.val).card := by {
      rw (multiset.card_map f finset.univ.val), refl,
    },
    rw this,
    apply multiset.prod_le_of_forall_le,
    finish,
end

-- A little bit annoying since 0^0 > 0^1, so pow isn't monotonic; this abstracts away the casework
lemma pow_le_pow_plus_one { a b c d : ℕ } (a_le_b : a ≤ b) (c_le_d : c ≤ d) : (a^c ≤ b^d + 1) :=
begin
  have h : a^c ≤ b^c := nat.pow_le_pow_of_le_left a_le_b c,
  have h' : b^c ≤ b^d + 1 := begin
    cases b with b',
    {
      exact calc 0^c ≤ 1 : by { rw zero_pow_eq, split_ifs, repeat { simp }, }
                ...  ≤ 0^d + 1 : by { simp },
    },
    {
      exact calc b'.succ^c ≤ b'.succ^d : by { apply nat.pow_le_pow_of_le_right, simp, assumption, }
                      ...  ≤ b'.succ^d + 1 : by { simp },
    },
  end,
  exact le_trans h h',
end

lemma vector.heq {α : Type*} {m n : ℕ} {v1 : vector α m} {v2 : vector α n}
  (leq : v1.to_list = v2.to_list) (H : m = n) : v1 == v2 :=
begin
  subst H,
  rw heq_iff_eq,
  exact vector.eq v1 v2 leq,
end

section prelim_definitions

/-
  In this section, we fix a language for our TM2, i.e.
  a fixed index set for the stacks K, type of stack elements Γ, type of function labels Λ
  and variables σ
-/
parameters {K : Type*} [decidable_eq K] [fintype K]
parameters (Γ : K → Type*) [Π k, fintype (Γ k)] -- Type of stack elements
parameters (Λ : Type*) [fintype Λ] -- Type of function labels
parameters (σ : Type*) [fintype σ] -- Type of variable settings

open turing

def cfg := @TM2.cfg K _ Γ Λ σ
-- Aliases for all the methods of `cfg`
def cfg.l := @TM2.cfg.l
def cfg.var := @TM2.cfg.var
def cfg.stk : cfg → ∀ k : K, list (Γ k) := TM2.cfg.stk
def cfg.mk := @TM2.cfg.mk
def cfg.mk.inj := @TM2.cfg.mk.inj

@[reducible] def stacks := Π k : K, list (Γ k)

-- Extensionality for TM2 configurations
-- There should definitely be a better way to do this
theorem cfg_eq : ∀(c1 c2 : cfg), (cfg.l c1 = cfg.l c2) → (cfg.var c1 = cfg.var c2)
   → (cfg.stk c1 = cfg.stk c2) → c1 = c2
  | ⟨l, var, stk⟩ ⟨l', var', stk'⟩ rf rf' rf'' :=
  begin
    have l_eq : l = l' := by exact rf,
    rw l_eq,
    have var_eq : var = var' := by exact rf',
    rw var_eq,
    have stk_eq : stk = stk' := by exact rf'',
    rw stk_eq,
  end

section bounded_space
/-
  Fix an upper bound M for the maximum stack size of any stack.
-/
parameters (M : ℕ) -- max stack size

-- These `reducible`s are necessary to get infer_instance to work
@[reducible] def bounded_stacks : Type* := Π k : K, Σ n : fin M, vector (Γ k) n

@[reducible] def bounded_cfg := (option Λ) × σ × bounded_stacks

-- The proposition that c : cfg is bounded by M
@[reducible] def bounded_cfg' (c : cfg) := ∀k : K, (cfg.stk c k).length < M

/-
  Converts a bounded_stacks type to the ordinary stacks type
-/
def bounded_stacks_to_stacks (b_stk : bounded_stacks) : stacks := λk : K, (b_stk k).2.to_list

lemma bounded_stacks_to_stacks_preserves_bound (b_stk : bounded_stacks)
  : (∀k : K, list.length (bounded_stacks_to_stacks b_stk k) < M) :=
begin
  intro k,
  -- Unfold the definition
  suffices : ((vector.to_list (b_stk k).2).length < M), { exact this, },
  rw vector.to_list_length (b_stk k).2,
  exact fin.is_lt (b_stk k).1,
end

lemma bounded_stacks_to_stacks.inj : function.injective bounded_stacks_to_stacks :=
begin
  intros x y h,
  apply funext,
  intro k,
  have eq_snd_lst : (x k).2.to_list = (y k).2.to_list :=
  begin
    apply @congr_fun _ _ (bounded_stacks_to_stacks x) (bounded_stacks_to_stacks y),
    assumption,
  end,
  have x_k_eq_y_k_fst : ↑(x k).1 = ↑(y k).1 :=
  begin
    have eq_len : (x k).2.to_list.length = (y k).2.to_list.length := by rw eq_snd_lst,
    repeat {rw vector.to_list_length at eq_len},
    assumption,
  end,
  have x_k_eq_y_k_snd : (x k).2 == (y k).2 := vector.heq eq_snd_lst x_k_eq_y_k_fst,
  exact sigma.ext (fin.ext x_k_eq_y_k_fst) x_k_eq_y_k_snd,
end

lemma bounded_stacks_to_stacks.sur (stk : stacks) (bound : ∀k : K, (stk k).length < M)
  : (∃b : bounded_stacks, bounded_stacks_to_stacks b = stk) :=
begin
  use λ k : K, ⟨
    (⟨(stk k).length, bound k⟩ : fin M),
    (⟨stk k, rfl⟩ : vector (Γ k) (stk k).length)
  ⟩,
  refl,
end

/-
  Converts a bounded_cfg type to the ordinary cfg type
-/
def bounded_cfg_to_cfg (bc : bounded_cfg) := cfg.mk bc.1 bc.2.1 (bounded_stacks_to_stacks bc.2.2)
lemma bounded_cfg_to_cfg_preserves_bound (bc : bounded_cfg)
  : (bounded_cfg' (bounded_cfg_to_cfg bc)) :=
begin
  intro k,
  have : bounded_cfg_to_cfg bc = cfg.mk bc.1 bc.2.1 (bounded_stacks_to_stacks bc.2.2) := by refl,
  rw this,
  have : (∀l : (option Λ), ∀v : σ, ∀stk : stacks, cfg.stk (cfg.mk l v stk) = stk) :=
    by { intros, refl, },
  rw this,
  apply bounded_stacks_to_stacks_preserves_bound,
end

lemma bounded_cfg_to_cfg.inj : function.injective bounded_cfg_to_cfg :=
begin
  intros x y h,
  suffices : x.1 = y.1 ∧ x.2.1 = y.2.1 ∧ x.2.2 = y.2.2,
  repeat { apply prod.ext },
  repeat { tauto },
  have h' := cfg.mk.inj h,
  repeat { split },
  repeat { tauto },
  apply bounded_stacks_to_stacks.inj,
  tauto,
end

lemma bounded_cfgs_to_cfgs.sur (c : cfg) (bound : bounded_cfg' c)
 : ∃c' : bounded_cfg, (bounded_cfg_to_cfg c') = c :=
begin
  cases (bounded_stacks_to_stacks.sur (cfg.stk c) bound) with bstk bstk_h,
  use (cfg.l c, cfg.var c, bstk),
  have : bounded_cfg_to_cfg (cfg.l c, cfg.var c, bstk)
       = cfg.mk (cfg.l c) (cfg.var c) (bounded_stacks_to_stacks bstk) := by refl,
  rw bstk_h at this,
  rw this,
  apply cfg_eq,
  repeat {refl},
end

-- The maximum alphabet size
def max_alphabet_size : ℕ := (finset.fold max 0 (λ k : K, fintype.card (Γ k)) (@finset.univ K _))

lemma max_alphabet_max : ∀k : K, fintype.card (Γ k) ≤ max_alphabet_size :=
begin
  intro k,
  have : (max_alphabet_size = (finset.fold max 0 (λ k : K, fintype.card (Γ k))
      (@finset.univ K _))) := by refl,
  rw this,
  rw finset.le_fold_max,
  right,
  use k,
  split,
  { exact finset.mem_univ k },
  { exact rfl.ge },
end

def num_tapes : ℕ := fintype.card K

def C : ℕ := 2 * num_tapes * nat.clog 2 (max_alphabet_size + 2)
def K_val : ℕ := 2^num_tapes

-- Give an upper bound on the number of bounded stacks
-- of the form O(2^O(M)) (notice `C` and `K_val` don't depend on `M`)
theorem bounded_stacks_size : fintype.card bounded_stacks ≤ K_val * 2^(C*M) :=
begin
  simp,

  -- Get an upper bound for the thing inside the sum
  have ub : ∀ k : K, ∀ m : fin M, (fintype.card (Γ k)) ^ ↑m ≤ max_alphabet_size ^ M + 1 :=
  begin
    intros k m,
    apply pow_le_pow_plus_one,
    { exact max_alphabet_max k, },
    { exact le_of_lt (fin.is_lt m), },
  end,

  -- Upper bound of the sum
  have ub_sum : ∀ k : K, (∑ (m : fin M), (fintype.card (Γ k))^(↑m : ℕ)
                            ≤ M * (max_alphabet_size ^ M + 1)) :=
  begin
    intro k,
    have M_eq_n_lt_M : M = fintype.card (fin M) := (fintype.card_fin M).symm,
    have h := sum_bound (λ m : fin M, (fintype.card (Γ k))^(↑m : ℕ)) (max_alphabet_size ^ M + 1) _,
    {
      rw ← M_eq_n_lt_M at h,
      exact h,
    },
    exact ub k,
  end,

  -- More useful upper bound for the sum
  have ub_sum' : ∀ k : K, (∑ (m : fin M), (fintype.card (Γ k))^(↑m : ℕ) ≤
                            2 * (max_alphabet_size + 2) ^ (2*M)) :=
  begin
    intro k,
    exact calc (∑ (m : fin M), (fintype.card (Γ k))^(↑m : ℕ))
        ≤ M * (max_alphabet_size^M + 1) : ub_sum k
    ... = M * max_alphabet_size^M + M : by { rw left_distrib _ _ _, simp, }
    ... ≤ M * (max_alphabet_size + 2)^M + M : by { simp, apply mul_le_mul_left',
                                                  apply nat.pow_le_pow_of_le_left, simp, }
    ... ≤ 2^M * (max_alphabet_size + 2)^M + M : by { simp, exact le_of_lt (nat.lt_two_pow M), }
    ... ≤ (max_alphabet_size + 2)^M * (max_alphabet_size + 2)^M + M : by {
                                            simp, apply nat.pow_le_pow_of_le_left, simp, }
    ... = (max_alphabet_size + 2)^(2 * M) + M : by { ring_exp, }
    ... ≤ (max_alphabet_size + 2)^(2*M) + 2^M : by { simp, exact le_of_lt (nat.lt_two_pow M), }
    ... ≤ (max_alphabet_size + 2)^(2*M) + (2^M)^2 : by { simp, nlinarith, }
    ... = (max_alphabet_size + 2)^(2*M) + 2^(2*M) : by { ring_exp, }
    ... ≤ (max_alphabet_size + 2)^(2*M) + (max_alphabet_size + 2)^(2*M) : by {
                                            simp, apply nat.pow_le_pow_of_le_left, simp, }
    ... = 2 * (max_alphabet_size + 2)^(2*M) : by { ring, },
  end,

  -- Upper bound of product
  exact calc
      ∏ k : K, ∑ (m : fin M), (fintype.card (Γ k))^(↑m : ℕ)
        ≤ (2 * (max_alphabet_size + 2) ^ (2*M))^num_tapes : by { apply prod_bound, exact ub_sum',}
    ... = 2^num_tapes * (max_alphabet_size + 2) ^ (2 * M * num_tapes) : by { rw mul_pow, simp,
                                                                            left, rw ← pow_mul, }
    ... ≤ 2^num_tapes * (2^(nat.clog 2 (max_alphabet_size + 2))) ^ (2 * M * num_tapes) : by {
      simp, apply nat.pow_le_pow_of_le_left,
      have : 1 < 2 := by simp,
      rw nat.le_pow_iff_clog_le this,
    }
    ... = 2^num_tapes * 2^(2 * num_tapes * nat.clog 2 (max_alphabet_size + 2) * M) : by ring_exp
    ... = K_val * 2^(C * M) : by refl,
end

-- Bounded (standard) cfgs, which are isomorphic to bounded_cfg, except
-- that the latter is a finite type
def all_bounded_cfgs : finset cfg :=
      finset.map ⟨bounded_cfg_to_cfg, bounded_cfg_to_cfg.inj⟩ finset.univ

lemma all_bounded_configs_iff_bounded : ∀c : cfg, c ∈ all_bounded_cfgs ↔ bounded_cfg' c :=
begin
  have all_bounded_cfgs_def
    : all_bounded_cfgs = finset.map ⟨bounded_cfg_to_cfg, bounded_cfg_to_cfg.inj⟩ finset.univ := rfl,
  rw all_bounded_cfgs_def,
  intro c,
  split,
  {
    simp,
    intros l var stk h_bounded,
    rw ← h_bounded,
    exact bounded_cfg_to_cfg_preserves_bound (l, var, stk),
  },
  {
    intro h_bounded,
    simp,
    have b_exists := bounded_cfgs_to_cfgs.sur c h_bounded,
    cases b_exists with bc bch,
    use bc.1, use bc.2.1, use bc.2.2,
    exact bch,
  },
end

lemma all_bounded_cfgs_size_eq_bounded_cfgs : all_bounded_cfgs.card = fintype.card bounded_cfg :=
begin
  have all_bounded_cfgs_def
    : all_bounded_cfgs = finset.map ⟨bounded_cfg_to_cfg, bounded_cfg_to_cfg.inj⟩ finset.univ := rfl,
  rw all_bounded_cfgs_def,
  simp only [finset.card_map],
  refl,
end

end bounded_space

/-
Given an upper bound M on the space of a configuartion,
it must be one of finitely many configurations, which we collect in f.
There are only O(2^O(M)) such possible configurations, so |f| <= O(2^O(M))
-/
theorem cfg_space_upper_bound_finitely_many : ∃ C K_val : ℕ, ∀M : ℕ,
    (all_bounded_cfgs M).card ≤ K_val * 2^(C * M):=
begin
  use C,
  use (fintype.card (option Λ)) * (fintype.card σ) * K_val,
  intro M,
  rw all_bounded_cfgs_size_eq_bounded_cfgs M,
  repeat {rw fintype.card_prod},
  rw fintype.card_option,
  exact calc
    (fintype.card Λ + 1) * (fintype.card σ * fintype.card (bounded_stacks M))
      =  (fintype.card Λ + 1) * (fintype.card σ * fintype.card (bounded_stacks M)) : by ring
  ... ≤ (fintype.card Λ + 1) * (fintype.card σ * (K_val * 2 ^ (C * M))) :
    nat.mul_le_mul_left (fintype.card Λ + 1) (nat.mul_le_mul_left (fintype.card σ) (bounded_stacks_size M))
  ... = (fintype.card Λ + 1) * fintype.card σ * K_val * 2 ^ (C * M) : by ring,
end

end prelim_definitions

-- TM2 with finite alphabet
structure fin_tm2' extends turing.fin_tm2 :=
  [Γ_fin: ∀k : K, fintype (Γ k)]

#check @turing.TM2.cfg.mk

section tm_definitions
parameter (tm : fin_tm2')

def cfg' := @turing.TM2.cfg tm.K _ tm.Γ tm.Λ tm.σ
def cfg'.mk := @turing.TM2.cfg.mk tm.K _ tm.Γ tm.Λ tm.σ

def option_cfg_bounded (M : ℕ) :  option cfg' → Prop
  | none      := true
  | (some c') := @bounded_cfg' tm.K tm.K_decidable_eq tm.K_fin tm.Γ
                             tm.Γ_fin tm.Λ tm.Λ_fin tm.σ tm.σ_fin M c'

structure evals_to_in_space (f : cfg' → option cfg') (a : cfg') (b : option cfg') (m : ℕ)
  extends turing.evals_to f a b :=
  (bounded_memory : ∀n ≤ [steps], (option_cfg_bounded m ((flip bind f)^[steps] a)))

-- TODO: evals_to_in_space M --> evals_to_in_time O(2^O(M))
-- (hence we can prove L ⊆ P and PSPACE ⊆ EXP)

-- TODO: evals_to_in_time M --> evals_to_in_space M
-- (hence P ⊆ PSPACE)

end tm_definitions


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import data.fintype.powerset

/-!
# Erdős–Szekeres theorem

This file proves Theorem 73 from the [100 Theorems List](https://www.cs.ru.nl/~freek/100/), also
known as the Erdős–Szekeres theorem: given a sequence of more than `r * s` distinct
values, there is an increasing sequence of length longer than `r` or a decreasing sequence of length
longer than `s`.

We use the proof outlined at
https://en.wikipedia.org/wiki/Erdos-Szekeres_theorem#Pigeonhole_principle.

## Tags

sequences, increasing, decreasing, Ramsey, Erdos-Szekeres, Erdős–Szekeres, Erdős-Szekeres
-/

variables {α : Type*} [linear_order α] {β : Type*}

open function finset
open_locale classical

/--
**Erdős–Szekeres Theorem**: Given a sequence of more than `r * s` distinct values, there is an
increasing sequence of length longer than `r` or a decreasing sequence of length longer than `s`.

Proof idea:
We label each value in the sequence with two numbers specifying the longest increasing
subsequence ending there, and the longest decreasing subsequence ending there.
We then show the pair of labels must be unique. Now if there is no increasing sequence longer than
`r` and no decreasing sequence longer than `s`, then there are at most `r * s` possible labels,
which is a contradiction if there are more than `r * s` elements.
-/
theorem erdos_szekeres {r s n : ℕ} {f : fin n → α} (hn : r * s < n) (hf : injective f) :
  (∃ (t : finset (fin n)), r < t.card ∧ strict_mono_on f ↑t) ∨
  (∃ (t : finset (fin n)), s < t.card ∧ strict_anti_on f ↑t) :=
begin
  -- Given an index `i`, produce the set of increasing (resp., decreasing) subsequences which ends
  -- at `i`.
  let inc_sequences_ending_in : fin n → finset (finset (fin n)) :=
    λ i, univ.powerset.filter (λ t, finset.max t = i ∧ strict_mono_on f ↑t),
  let dec_sequences_ending_in : fin n → finset (finset (fin n)) :=
    λ i, univ.powerset.filter (λ t, finset.max t = i ∧ strict_anti_on f ↑t),
  -- The singleton sequence is in both of the above collections.
  -- (This is useful to show that the maximum length subsequence is at least 1, and that the set
  -- of subsequences is nonempty.)
  have inc_i : ∀ i, {i} ∈ inc_sequences_ending_in i := λ i, by simp [strict_mono_on],
  have dec_i : ∀ i, {i} ∈ dec_sequences_ending_in i := λ i, by simp [strict_anti_on],
  -- Define the pair of labels: at index `i`, the pair is the maximum length of an increasing
  -- subsequence ending at `i`, paired with the maximum length of a decreasing subsequence ending
  -- at `i`.
  -- We call these labels `(a_i, b_i)`.
  let ab : fin n → ℕ × ℕ,
  { intro i,
    apply (max' ((inc_sequences_ending_in i).image card) (nonempty.image ⟨{i}, inc_i i⟩ _),
           max' ((dec_sequences_ending_in i).image card) (nonempty.image ⟨{i}, dec_i i⟩ _)) },
  -- It now suffices to show that one of the labels is 'big' somewhere. In particular, if the
  -- first in the pair is more than `r` somewhere, then we have an increasing subsequence in our
  -- set, and if the second is more than `s` somewhere, then we have a decreasing subsequence.
  rsuffices ⟨i, hi⟩ : ∃ i, r < (ab i).1 ∨ s < (ab i).2,
  { apply or.imp _ _ hi,
    work_on_goal 1 { have : (ab i).1 ∈ _ := max'_mem _ _ },
    work_on_goal 2 { have : (ab i).2 ∈ _ := max'_mem _ _ },
    all_goals
    { intro hi,
      rw mem_image at this,
      obtain ⟨t, ht₁, ht₂⟩ := this,
      refine ⟨t, by rwa ht₂, _⟩,
      rw mem_filter at ht₁,
      apply ht₁.2.2 } },
  -- Show first that the pair of labels is unique.
  have : injective ab,
  { apply injective_of_lt_imp_ne,
    intros i j k q,
    injection q with q₁ q₂,
    -- We have two cases: `f i < f j` or `f j < f i`.
    -- In the former we'll show `a_i < a_j`, and in the latter we'll show `b_i < b_j`.
    cases lt_or_gt_of_ne (λ _, ne_of_lt ‹i < j› (hf ‹f i = f j›)),
    work_on_goal 1 { apply ne_of_lt _ q₁, have : (ab i).1 ∈ _ := max'_mem _ _ },
    work_on_goal 2 { apply ne_of_lt _ q₂, have : (ab i).2 ∈ _ := max'_mem _ _ },
    all_goals
    { -- Reduce to showing there is a subsequence of length `a_i + 1` which ends at `j`.
      rw nat.lt_iff_add_one_le,
      apply le_max',
      rw mem_image at this ⊢,
      -- In particular we take the subsequence `t` of length `a_i` which ends at `i`, by definition
      -- of `a_i`
      rcases this with ⟨t, ht₁, ht₂⟩,
      rw mem_filter at ht₁,
      -- Ensure `t` ends at `i`.
      have : t.max = i,
        simp [ht₁.2.1],
      -- Now our new subsequence is given by adding `j` at the end of `t`.
      refine ⟨insert j t, _, _⟩,
      -- First make sure it's valid, i.e., that this subsequence ends at `j` and is increasing
      { rw mem_filter,
        refine ⟨_, _, _⟩,
        { rw mem_powerset, apply subset_univ },
        -- It ends at `j` since `i < j`.
        { convert max_insert,
          rw [ht₁.2.1, max_eq_left],
          apply with_bot.coe_le_coe.mpr (le_of_lt ‹i < j›) },
        -- To show it's increasing (i.e., `f` is monotone increasing on `t.insert j`), we do cases
        -- on what the possibilities could be - either in `t` or equals `j`.
        simp only [strict_mono_on, strict_anti_on, coe_insert, set.mem_insert_iff,
          mem_coe],
        -- Most of the cases are just bashes.
        rintros x ⟨rfl | _⟩ y ⟨rfl | _⟩ _,
        { apply (irrefl _ ‹j < j›).elim },
        { exfalso,
          apply not_le_of_lt (trans ‹i < j› ‹j < y›) (le_max_of_eq ‹y ∈ t› ‹t.max = i›) },
        { apply lt_of_le_of_lt _ ‹f i < f j› <|> apply lt_of_lt_of_le ‹f j < f i› _,
          rcases lt_or_eq_of_le (le_max_of_eq ‹x ∈ t› ‹t.max = i›) with _ | rfl,
          { apply le_of_lt (ht₁.2.2 ‹x ∈ t› (mem_of_max ‹t.max = i›) ‹x < i›) },
          { refl } },
        { apply ht₁.2.2 ‹x ∈ t› ‹y ∈ t› ‹x < y› } },
      -- Finally show that this new subsequence is one longer than the old one.
      { rw [card_insert_of_not_mem, ht₂],
        intro _,
        apply not_le_of_lt ‹i < j› (le_max_of_eq ‹j ∈ t› ‹t.max = i›) } } },
      -- Finished both goals!
  -- Now that we have uniqueness of each label, it remains to do some counting to finish off.
  -- Suppose all the labels are small.
  by_contra q,
  push_neg at q,
  -- Then the labels `(a_i, b_i)` all fit in the following set: `{ (x,y) | 1 ≤ x ≤ r, 1 ≤ y ≤ s }`
  let ran : finset (ℕ × ℕ) := (range r).image nat.succ ×ˢ (range s).image nat.succ,
  -- which we prove here.
  have : image ab univ ⊆ ran,
  -- First some logical shuffling
  { rintro ⟨x₁, x₂⟩,
    simp only [mem_image, exists_prop, mem_range, mem_univ, mem_product, true_and, prod.mk.inj_iff],
    rintros ⟨i, rfl, rfl⟩,
    specialize q i,
    -- Show `1 ≤ a_i` and `1 ≤ b_i`, which is easy from the fact that `{i}` is a increasing and
    -- decreasing subsequence which we did right near the top.
    have z : 1 ≤ (ab i).1 ∧ 1 ≤ (ab i).2,
    { split;
      { apply le_max',
        rw mem_image,
        refine ⟨{i}, by solve_by_elim, card_singleton i⟩ } },
    refine ⟨_, _⟩,
    -- Need to get `a_i ≤ r`, here phrased as: there is some `a < r` with `a+1 = a_i`.
    { refine ⟨(ab i).1 - 1, _, nat.succ_pred_eq_of_pos z.1⟩,
      rw tsub_lt_iff_right z.1,
      apply nat.lt_succ_of_le q.1 },
    { refine ⟨(ab i).2 - 1, _, nat.succ_pred_eq_of_pos z.2⟩,
      rw tsub_lt_iff_right z.2,
      apply nat.lt_succ_of_le q.2 } },
  -- To get our contradiction, it suffices to prove `n ≤ r * s`
  apply not_le_of_lt hn,
  -- Which follows from considering the cardinalities of the subset above, since `ab` is injective.
  simpa [nat.succ_injective, card_image_of_injective, ‹injective ab›] using card_le_of_subset this,
end