/-
Copyright (c) 2019 Chris Hughes All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import analysis.special_functions.pow
import field_theory.is_alg_closed.basic
import topology.algebra.polynomial

/-!
# The fundamental theorem of algebra

This file proves that every nonconstant complex polynomial has a root.

As a consequence, the complex numbers are algebraically closed.
-/

open complex polynomial metric filter is_absolute_value set
open_locale classical

namespace complex

/- The following proof uses the method given at
<https://ncatlab.org/nlab/show/fundamental+theorem+of+algebra#classical_fta_via_advanced_calculus>
-/
/-- **Fundamental theorem of algebra**: every non constant complex polynomial
  has a root -/
lemma exists_root {f : polynomial ℂ} (hf : 0 < degree f) : ∃ z : ℂ, is_root f z :=
let ⟨z₀, hz₀⟩ := f.exists_forall_norm_le in
exists.intro z₀ $ classical.by_contradiction $ λ hf0,
have hfX : f - C (f.eval z₀) ≠ 0,
  from mt sub_eq_zero.1 (λ h, not_le_of_gt hf (h.symm ▸ degree_C_le)),
let n := root_multiplicity z₀ (f - C (f.eval z₀)) in
let g := (f - C (f.eval z₀)) /ₘ ((X - C z₀) ^ n) in
have hg0 : g.eval z₀ ≠ 0, from eval_div_by_monic_pow_root_multiplicity_ne_zero _ hfX,
have hg : g * (X - C z₀) ^ n = f - C (f.eval z₀),
  from div_by_monic_mul_pow_root_multiplicity_eq _ _,
have hn0 : 0 < n, from nat.pos_of_ne_zero $ λ hn0, by simpa [g, hn0] using hg0,
let ⟨δ', hδ'₁, hδ'₂⟩ := continuous_iff.1 (polynomial.continuous g) z₀
  ((g.eval z₀).abs) (complex.abs_pos.2 hg0) in
let δ := min (min (δ' / 2) 1) (((f.eval z₀).abs / (g.eval z₀).abs) / 2) in
have hf0' : 0 < (f.eval z₀).abs, from complex.abs_pos.2 hf0,
have hg0' : 0 < abs (eval z₀ g), from complex.abs_pos.2 hg0,
have hfg0 : 0 < (f.eval z₀).abs / abs (eval z₀ g), from div_pos hf0' hg0',
have hδ0 : 0 < δ, from lt_min (lt_min (half_pos hδ'₁) (by norm_num)) (half_pos hfg0),
have hδ : ∀ z : ℂ, abs (z - z₀) = δ → abs (g.eval z - g.eval z₀) < (g.eval z₀).abs,
  from λ z hz, hδ'₂ z (by rw [complex.dist_eq, hz];
    exact ((min_le_left _ _).trans (min_le_left _ _)).trans_lt (half_lt_self hδ'₁)),
have hδ1 : δ ≤ 1, from le_trans (min_le_left _ _) (min_le_right _ _),
let F : polynomial ℂ := C (f.eval z₀) + C (g.eval z₀) * (X - C z₀) ^ n in
let z' := (-f.eval z₀ * (g.eval z₀).abs * δ ^ n /
  ((f.eval z₀).abs * g.eval z₀)) ^ (n⁻¹ : ℂ) + z₀ in
have hF₁ : F.eval z' = f.eval z₀ - f.eval z₀ * (g.eval z₀).abs * δ ^ n / (f.eval z₀).abs,
  by simp only [F, cpow_nat_inv_pow _ hn0, div_eq_mul_inv, eval_pow, mul_assoc,
      mul_comm (g.eval z₀), mul_left_comm (g.eval z₀), mul_left_comm (g.eval z₀)⁻¹, mul_inv₀,
      inv_mul_cancel hg0, eval_C, eval_add, eval_neg, sub_eq_add_neg, eval_mul, eval_X,
      add_neg_cancel_right, neg_mul_eq_neg_mul_symm, mul_one, div_eq_mul_inv];
    simp only [mul_comm, mul_left_comm, mul_assoc],
have hδs : (g.eval z₀).abs * δ ^ n / (f.eval z₀).abs < 1,
  from (div_lt_one hf0').2 $ (lt_div_iff' hg0').1 $
  calc δ ^ n ≤ δ ^ 1 : pow_le_pow_of_le_one (le_of_lt hδ0) hδ1 hn0
         ... = δ : pow_one _
         ... ≤ ((f.eval z₀).abs / (g.eval z₀).abs) / 2 : min_le_right _ _
         ... < _ : half_lt_self (div_pos hf0' hg0'),
have hF₂ : (F.eval z').abs = (f.eval z₀).abs - (g.eval z₀).abs * δ ^ n,
  from calc (F.eval z').abs = (f.eval z₀ - f.eval z₀ * (g.eval z₀).abs
    * δ ^ n / (f.eval z₀).abs).abs : congr_arg abs hF₁
  ... = abs (f.eval z₀) * complex.abs (1 - (g.eval z₀).abs * δ ^ n /
      (f.eval z₀).abs : ℝ) : by rw [← complex.abs_mul];
        exact congr_arg complex.abs
          (by simp [mul_add, add_mul, mul_assoc, div_eq_mul_inv, sub_eq_add_neg])
  ... = _ : by rw [complex.abs_of_nonneg (sub_nonneg.2 (le_of_lt hδs)),
      mul_sub, mul_div_cancel' _ (ne.symm (ne_of_lt hf0')), mul_one],
have hef0 : abs (eval z₀ g) * (eval z₀ f).abs ≠ 0,
  from mul_ne_zero (mt complex.abs_eq_zero.1 hg0) (mt complex.abs_eq_zero.1 hf0),
have hz'z₀ : abs (z' - z₀) = δ,
  by simp [z', mul_assoc, mul_left_comm _ (_ ^ n), mul_comm _ (_ ^ n),
    mul_comm (eval z₀ f).abs, _root_.mul_div_cancel _ hef0, of_real_mul,
    neg_mul_eq_neg_mul_symm, neg_div, is_absolute_value.abv_pow complex.abs,
    complex.abs_of_nonneg (le_of_lt hδ0), real.pow_nat_rpow_nat_inv (le_of_lt hδ0) hn0],
have hF₃ : (f.eval z' - F.eval z').abs < (g.eval z₀).abs * δ ^ n,
  from calc (f.eval z' - F.eval z').abs
      = (g.eval z' - g.eval z₀).abs * (z' - z₀).abs ^ n :
        by rw [← eq_sub_iff_add_eq.1 hg, ← is_absolute_value.abv_pow complex.abs,
            ← complex.abs_mul, sub_mul];
          simp [F, eval_pow, eval_add, eval_mul, eval_sub, eval_C, eval_X, eval_neg, add_sub_cancel,
                sub_eq_add_neg, add_assoc]
  ... = (g.eval z' - g.eval z₀).abs * δ ^ n : by rw hz'z₀
  ... < _ : (mul_lt_mul_right (pow_pos hδ0 _)).2 (hδ _ hz'z₀),
lt_irrefl (f.eval z₀).abs $
  calc (f.eval z₀).abs ≤ (f.eval z').abs : hz₀ _
    ... = (F.eval z' + (f.eval z' - F.eval z')).abs : by simp
    ... ≤ (F.eval z').abs + (f.eval z' - F.eval z').abs : complex.abs_add _ _
    ... < (f.eval z₀).abs - (g.eval z₀).abs * δ ^ n + (g.eval z₀).abs * δ ^ n :
      add_lt_add_of_le_of_lt (by rw hF₂) hF₃
    ... = (f.eval z₀).abs : sub_add_cancel _ _

instance is_alg_closed : is_alg_closed ℂ :=
is_alg_closed.of_exists_root _ $ λ p _ hp, complex.exists_root $ degree_pos_of_irreducible hp

end complex


import euclid.axioms data.set tactic.interactive
open classical
namespace Euclidean_plane
variables {point : Type} [Euclidean_plane point]

local attribute [instance] prop_decidable

--Conclusions from the first 5 axioms
theorem eqd.refl (a b : point) : eqd a b a b :=
eqd_trans (eqd_refl b a) (eqd_refl b a)

theorem eqd.symm {a b c d : point} : eqd a b c d → eqd c d a b :=
λ h, eqd_trans h (eqd.refl a b)

theorem eqd.trans {a b c d e f: point} : eqd a b c d → eqd c d e f → eqd a b e f :=
assume h h1,
eqd_trans h.symm h1

theorem two4 {a b c d : point} : eqd a b c d → eqd b a c d := assume h, eqd_trans (eqd_refl a b) h

theorem two5 {a b c d : point} : eqd a b c d → eqd a b d c := assume h, eqd.trans h (eqd_refl c d)

theorem eqd.flip {a b c d : point} : eqd a b c d → eqd b a d c := assume h, two4 (two5 h)

instance point_setoid : setoid (point × point) :=
{ r := λ ⟨a,b⟩ ⟨c,d⟩, eqd a b c d,
  iseqv := ⟨ λ ⟨a,b⟩, eqd.refl a b, λ ⟨a,b⟩ ⟨c,d⟩, eqd.symm, λ ⟨a,b⟩ ⟨c,d⟩ ⟨e,f⟩, eqd.trans⟩
}

definition distance_values (point : Type) [Euclidean_plane point] :=
quotient (@Euclidean_plane.point_setoid point _)

theorem refl_dist (a b : point) : (a,b) ≈ (b,a) := eqd_refl a b

theorem two7 {a b c d : point} : eqd a b c d → a ≠ b → c ≠ d :=
begin
intros h h1 h2,
subst d,
exact h1 (id_eqd h)
end

theorem two8 (a b : point) : eqd a a b b :=
let ⟨x, h⟩ := seg_cons a b b b in
have a = x, from id_eqd h.2,
by rw ←this at h; exact h.2

def afs (a b c d a' b' c' d' : point) : Prop := B a b c ∧ B a' b' c' ∧ eqd a b a' b'
∧ eqd b c b' c' ∧ eqd a d a' d' ∧ eqd b d b' d'

theorem afive_seg {a b c d a' b' c' d' : point} : afs a b c d a' b' c' d' →
a ≠ b → eqd c d c' d' :=
λ h h1, five_seg h1 h.1 h.2.1 h.2.2.1 h.2.2.2.1 h.2.2.2.2.1 h.2.2.2.2.2

theorem two11 {a b c a' b' c' : point} : B a b c → B a' b' c' → eqd a b a' b'
→ eqd b c b' c' → eqd a c a' c' :=
begin
intros,
have : afs a b c a a' b' c' a',
  repeat {split}; try {assumption},
  exact two8 _ _,
  exact a_3.flip,
cases em (a = b),
  have : eqd a' b' a a,
    apply eqd.symm,
    rw ←h at a_3,
    assumption,
  have : a' = b',
    apply id_eqd,
    assumption,
  rw ←h at a_4,
  rw ←this at a_4,
  assumption,
apply eqd.flip,
apply afive_seg this,
  assumption
end

theorem two12 (a b c q : point) : q ≠ a → ∃! x, B q a x ∧ eqd a x b c :=
begin
intro h,
cases seg_cons a b c q with x h1,
existsi x,
split,
  assumption,
intros y hy,
cases h1 with h2 h3,
cases hy with h4 h5,
by_contradiction h_1,
have h6 : eqd a x a y,
  exact eqd.trans h3 h5.symm,
have h7 : eqd q x q y,
  apply two11 h2 h4,
    exact eqd.refl _ _,
  assumption,
have : afs q a x x q a x y,
  repeat {split}; try {assumption},
    exact eqd.refl _ _,
  exact eqd.refl _ _,
have : eqd x x x y,
  apply afive_seg this h,
have : x = y,
  exact id_eqd this.symm,
have : y = x,
  exact eq.symm this,
contradiction
end

-- Properties of B

theorem three1 (a b : point) : B a b b :=
begin
cases seg_cons b b b a with x h,
have : b = x,
  exact id_eqd h.2,
rw ←this at h,
exact h.1
end

theorem B.symm {a b c : point} : B a b c → B c b a :=
begin
intro h,
cases pasch h (three1 b c) with x hx,
have : b = x,
  exact bet_same hx.1,
rw ←this at hx,
exact hx.2
end

theorem three2 (a b c : point) : B a b c ↔ B c b a :=
begin
split,
  exact B.symm,
intro h,
exact h.symm
end

theorem three3 (a b : point) : B a a b :=
begin
exact (three1 b a).symm
end

theorem three4 {a b c: point} : B a b c → B b a c → a = b :=
begin
intros h h1,
cases pasch h h1 with x hx,
have : a = x,
  exact bet_same hx.2,
have : b = x,
  exact bet_same hx.1,
simp *
end

theorem three5a {a b c d : point} : B a b d → B b c d → B a b c:=
begin
intros h h1,
cases pasch h h1 with x hx,
have : b = x,
  exact bet_same hx.1,
rw ←this at hx,
exact hx.2.symm,
end

theorem three6a {a b c d : point} : B a b c → B a c d → B b c d :=
begin
intros h h1,
exact (three5a h1.symm h.symm).symm
end

theorem three7a {a b c d : point} : B a b c → B b c d → b ≠ c
→ B a c d :=
begin
intros h h1 h2,
cases seg_cons c c d a with x hx,
have : B b c x,
  exact three6a h hx.1,
cases two12 c c d b h2 with y hy,
have : x = y,
  apply hy.2,
  split,
    exact this, exact hx.2,
have : d = y,
  apply hy.2,
  split,
    exact h1, exact eqd.refl c d,
have : x = d,
  simp *,
rw this at hx,
exact hx.1
end

theorem three5b {a b c d : point} : B a b d → B b c d → B a c d :=
begin
intros h h1,
cases em (b = c),
  rwa h_1 at h,
exact three7a (three5a h h1) h1 h_1
end

theorem three6b {a b c d : point} : B a b c → B a c d → B a b d :=
begin
intros h h1,
cases em (c = b),
  rwa h_1 at h1,
exact (three7a (three6a h h1).symm h.symm h_1).symm
end

theorem three7b {a b c d : point} : B a b c → B b c d → b ≠ c
→ B a b d :=
begin
intros h h1 h2,
have h3 : B a c d,
  exact three7a h h1 h2,
exact (three5b h3.symm h.symm).symm
end

theorem three13 : ∃ (x y : point), x ≠ y :=
begin
refine ⟨P1, P2, _⟩,
intro h,
apply (two_dim point).1,
rw h,
exact three3 P2 P3
end

theorem three14 (a b : point) : ∃ c, B a b c ∧ b ≠ c :=
let ⟨(x : point), y, hp⟩ := three13 in
begin
cases seg_cons b x y a with c h,
cases h with h1 h2,
have : b ≠ c,
  intro hq,
  have : eqd x y b b,
    apply eqd.symm,
    rwa ←hq at h2,
  exact hp (id_eqd this) ,
constructor, exact ⟨h1, this⟩
end

theorem three17 {a b c a' b' p : point} : B a b c → B a' b' c
→ B a p a' → ∃ q, B p q c ∧ B b q b' :=
begin
intros h1 h2 h3,
cases pasch h3 h2.symm with x h4,
cases pasch h1.symm h4.2 with y h5,
have : B p y c,
  exact three5b h4.1 h5.2,
constructor, exact ⟨this, h5.1⟩
end

-- cong + col

def ifs (a b c d a' b' c' d' : point) : Prop := B a b c ∧ B a' b' c' ∧ eqd a c a' c'
∧ eqd b c b' c' ∧ eqd a d a' d' ∧ eqd c d c' d'

theorem four2 {a b c d a' b' c' d' : point} : ifs a b c d a' b' c' d' → eqd b d b' d' :=
begin
intro h,
cases h with h h1,
cases h1 with h1 h2,
cases h2 with h2 h3,
cases h3 with h3 h4,
cases h4 with h4 h5,
cases em (a = c),
  have : a' = c',
    have : eqd c c a' c',
      rwa h_1 at h2,
    exact id_eqd this.symm,
  have h6 : c = b,
    apply bet_same,
    rwa h_1 at h,
  have h7 : b' = c',
    have : eqd b b b' c',
      rwa h6 at h3,
    exact id_eqd this.symm,
  rw [h6, ←h7] at h5,
  exact h5,
cases three14 a c with e he,
cases seg_cons c' c e a' with e' he',
have : afs a c e d a' c' e' d',
  repeat {split};
    try{assumption},
    exact he.1,
    exact he'.1,
  exact he'.2.symm,
have : eqd e d e' d',
  exact afive_seg this h_1,
have : afs e c b d e' c' b' d',
  repeat {split};
    try{assumption},
    exact (three6a h he.1).symm,
    exact (three6a h1 he'.1).symm,
    exact he'.2.symm.flip,
  exact h3.flip,
exact afive_seg this he.2.symm
end

theorem four3 {a b c a' b' c' : point} : B a b c → B a' b' c' → eqd a c a' c'
→ eqd b c b' c' → eqd a b a' b' :=
begin
intros h h1 h2 h3,
  have : ifs a b c a a' b' c' a',
  repeat {split};
    try{assumption},
    exact two8 a a',
  exact h2.flip,
exact (four2 this).flip
end

def cong (a b c a' b' c' : point) : Prop := eqd a b a' b' ∧ eqd b c b' c' ∧ eqd a c a' c'

@[simp] theorem cong.refl (a b c : point) : cong a b c a b c :=
begin
repeat {split};
exact eqd.refl _ _
end

theorem cong.symm {a b c a' b' c' : point} : cong a b c a' b' c' → cong a' b' c' a b c :=
begin
intro h,
split,
  exact h.1.symm,
split,
  exact h.2.1.symm,
exact h.2.2.symm
end

theorem cong.trans {a b c a' b' c' a'' b'' c'' : point} : cong a b c a' b' c' → cong a' b' c' a'' b'' c'' → cong a b c a'' b'' c'' :=
begin
intros h h1,
split,
  exact eqd.trans h.1 h1.1,
split,
  exact eqd.trans h.2.1 h1.2.1,
exact eqd.trans h.2.2 h1.2.2
end

lemma four4 {a b c a' b' c' : point} : cong a b c a' b' c' → cong a c b a' c' b' ∧ cong b a c b' a' c' ∧
cong b c a b' c' a' ∧ cong c a b c' a' b' ∧ cong c b a c' b' a' :=
λ h, ⟨⟨h.2.2, h.2.1.flip, h.1⟩, ⟨h.1.flip, h.2.2, h.2.1⟩, ⟨h.2.1, h.2.2.flip, h.1.flip⟩,
⟨h.2.2.flip, h.1, h.2.1.flip⟩, ⟨h.2.1.flip, h.1.flip, h.2.2.flip⟩⟩

theorem four5 {a b c a' c' : point} : B a b c → eqd a c a' c'
→ ∃ b', B a' b' c' ∧ cong a b c a' b' c' :=
begin
intros h h1,
cases three14 c' a' with d' hd,
cases seg_cons a' a b d' with b' hb,
cases seg_cons b' b c d' with c'' hc,
have h2 : B a' b' c'' ∧ B d' a' c'',
  split,
    exact three6a hb.1 hc.1,
  exact three6b hb.1 hc.1,
have h3 : eqd a' c'' a c,
  exact two11 h2.1 h hb.2 hc.2,
have h4 : c' = c'',
  apply unique_of_exists_unique (two12 a' a c d' hd.2.symm),
    split,
      exact hd.1.symm,
      exact h1.symm,
  split,
    exact h2.2,
  exact h3,
rw ←h4 at *,
existsi b',
split,
  exact h2.1,
unfold cong,
split,
  apply four3 h h2.1,
    exact h3.symm,
  exact hc.2.symm,
split,
  exact hc.2.symm,
exact h3.symm
end

theorem four6 {a b c a' b' c' : point} : B a b c → cong a b c a' b' c' → B a' b' c' :=
begin
intros h h1,
cases h1 with h1 h2,
cases h2 with h2 h3,
cases four5 h h3 with b'' hb,
cases hb with hb hb1,
cases hb1 with hb1 hb2,
cases hb2 with hb2 hb3,
have : ifs a' b'' c' b'' a' b'' c' b',
  repeat {split};
    try {assumption},
    exact eqd.trans hb3.symm h3,
    exact eqd.refl _ _,
    exact eqd.trans hb1.symm h1,
    have : eqd b'' c' b' c',
      exact eqd.trans hb2.symm h2,
    exact this.flip,
have : b'' = b',
  have h4 : eqd b'' b'' b'' b',
    exact four2 this,
  exact id_eqd h4.symm,
rwa this at *
end

def col (a b c : point) : Prop := B a b c ∨ B b c a ∨ B c a b

theorem four11 {a b c : point} : col a b c → col a c b ∧ col b a c ∧ col b c a ∧ col c a b ∧ col c b a :=
begin
intro h,
cases h with h1 h2,
have : B c b a, exact h1.symm,
repeat {split}; unfold col;
  simp *,
cases h2 with h2 h3,
have : B a c b, exact h2.symm,
  repeat {split};unfold col;
  simp *,
have : B b a c, exact h3.symm,
repeat {split};unfold col;
  simp *
end

theorem four10 {a b c : point} : ¬col a b c → ¬col a c b ∧ ¬col b a c ∧ ¬col b c a ∧ ¬col c a b ∧ ¬col c b a :=
begin
intro h,
split,
  intro h_1,
  exact h (four11 h_1).1,
split,
  intro h_1,
  exact h (four11 h_1).2.1,
split,
  intro h_1,
  exact h (four11 h_1).2.2.2.1,
split,
  intro h_1,
  exact h (four11 h_1).2.2.1,
intro h_1,
exact h (four11 h_1).2.2.2.2
end

theorem four12 (a b : point) : col a a b :=
begin
unfold col,
left, exact three3 a b
end

theorem four13 {a b c a' b' c' : point} : col a b c → cong a b c a' b' c' → col a' b' c' :=
begin
intros h h1,
unfold col,
cases h,
  have : B a' b' c', exact four6 h h1,
  simp *,
cases h,
  have : B b' c' a', exact four6 h (four4 h1).2.2.1,
  simp *,
have : B c' a' b', exact four6 h (four4 h1).2.2.2.1,
  simp *,
end

theorem four14 {a b c a' b' : point} : col a b c → eqd a b a' b' → ∃ c', cong a b c a' b' c' :=
begin
intros h1 h,
cases h1 with h1 h2,
cases seg_cons b' b c a' with c' hc,
  existsi c',
  unfold cong,
  split,
    exact h,
  split,
    exact hc.2.symm,
  exact two11 h1 hc.1 h hc.2.symm,
cases h2 with h2 h3,
  cases four5 h2 h.flip with c' hc,
  constructor, exact (four4 hc.2).2.2.2.1,
cases seg_cons a' a c b' with c' hc,
existsi c',
unfold cong,
split,
  exact h,
split,
  exact two11 h3.symm hc.1 h.flip hc.2.symm,
exact hc.2.symm
end

def fs (a b c d a' b' c' d' : point) : Prop := col a b c ∧ cong a b c a' b' c' ∧
eqd a d a' d' ∧ eqd b d b' d'

theorem four16 {a b c d a' b' c' d' : point} : fs a b c d a' b' c' d' → a ≠ b → eqd c d c' d' :=
begin
intros h1 h,
cases h1 with h1 h2,
cases h2 with h2 h3,
cases h3 with h3 h4,
cases h1 with ha hbc,
  exact five_seg h ha (four6 ha h2) h2.1 h2.2.1 h3 h4,
cases hbc with hb hc,
  have : ifs b c a d b' c' a' d',
    repeat {split};
      try {assumption},
        exact four6 hb (four4 h2).2.2.1,
      exact h2.1.flip,
    exact h2.2.2.flip,
  exact four2 this,
rw three2 at hc,
have : cong b a c b' a' c',
  unfold cong,
  split,
    exact h2.1.flip,
  split,
    exact h2.2.2,
  exact h2.2.1,
exact five_seg h.symm hc (four6 hc this) h2.1.flip h2.2.2 h4 h3
end

theorem four17 {a b c p q : point} : a ≠ b → col a b c → eqd a p a q → eqd b p b q → eqd c p c q :=
begin
intros h h1 h2 h3,
have : fs a b c p a b c q,
  unfold fs,
  repeat {split}; try {assumption};
  exact eqd.refl _ _,
exact four16 this h
end

theorem four18 {a b c c' : point} : a ≠ b → col a b c → eqd a c a c' → eqd b c b c' → c = c':=
begin
intros h h3 h1 h2,
have : eqd c c c c',
  exact four17 h h3 h1 h2,
exact id_eqd this.symm
end

theorem four19 {a b c b' : point} : B a b c → eqd a b a b' → eqd b c b' c → b = b' :=
begin
intros h h1 h2,
cases em (a = c) with h3 h4,
  rw ←h3 at *,
  have : a = b, exact bet_same h,
  rw this at *,
  exact id_eqd h1.symm,
have : col a c b,
  right, left,
  exact h.symm,
exact four18 h4 this h1 h2.flip
end

-- Ordering collinear points & Comparing distances

theorem five1 {a b c d : point} : a ≠ b → B a b c → B a b d → B a c d ∨ B a d c :=
begin
intros h h1 h2,
cases em (c = d),
  left, rw h_1 at *, exact three1 a d,
cases seg_cons d d c a with c' hc,
cases seg_cons c c d a with d' hd,
cases seg_cons c' c b d with b' ha,
cases seg_cons d' d b c with b'' hb,
have h_2 : d ≠ c',
  intro h_2,
  rw ←h_2 at hc,
  have : c = d,
    exact id_eqd hc.2.symm.flip,
  contradiction,
have h_3 : d' ≠ c,
  intro h_3,
  rw h_3 at hd,
  have : c = d,
    exact id_eqd hd.2.symm,
  contradiction,
have h3 : B b d c',
  exact three6a h2 hc.1,
have h4 : eqd b c' b'' c,
  exact two11 h3 hb.1.symm hb.2.symm.flip (eqd.trans hc.2 hd.2.symm.flip),
have h5 : B b c' b',
  exact three7a h3 ha.1 h_2,
have h_4 : B b c d',
  exact three6a h1 hd.1,
have h6 : B b'' c b,
  exact three7a hb.1.symm h_4.symm h_3,
have h7 : eqd b b' b'' b,
  exact two11 h5 h6 h4 ha.2,
have h_5 : B a b b',
  have : B a d b',
    exact three7b hc.1 ha.1 h_2,
  exact three6b h2 this,
have h_6 : B a b b'',
  have : B a c b'',
    exact three7b hd.1 hb.1 h_3.symm,
  exact three6b h1 this,
have h8 : b' = b'',
  apply unique_of_exists_unique (two12 b b b' a h),
    split,
      exact h_5,
    exact eqd.refl b b',
  split,
    exact h_6,
  exact two4 h7.symm,
rw ←h8 at *,
have h9 : afs b c d' c' b' c' d c,
  repeat {split}; try {assumption},
    exact ha.1.symm,
    exact ha.2.symm.flip,
    exact eqd.trans hd.2 hc.2.symm.flip,
  exact two5 (eqd.refl c c'),
cases em (b = c),
  left,
  rw ←h_7, exact h2,
have h10 : eqd c d c' d',
  exact (afive_seg h9 h_7).symm.flip,
cases pasch hd.1.symm hc.1.symm with e he,
have h11 : ifs d e d' c d e d' c',
  repeat {split}; try {assumption},
    exact he.2,
    exact he.2,
    exact eqd.refl d d',
    exact eqd.refl e d',
    exact hc.2.symm,
  exact eqd.trans hd.2.flip h10.flip,
have h12 : ifs c e c' d c e c' d',
  repeat {split}; try {assumption},
    exact he.1,
    exact he.1,
    exact eqd.refl c c',
    exact eqd.refl e c',
    exact hd.2.symm,
  exact eqd.trans hc.2.flip h10,
have h_8 : eqd e c e c',
  exact four2 h11,
have h_9 : eqd e d e d',
  exact four2 h12,
cases em (c = c'),
  rw ←h_10 at hc,
  right, exact hc.1,
cases seg_cons c c d' c' with p hp,
cases seg_cons c c e d' with r hr,
cases seg_cons r r p p with q hq,
have h13 : afs d' c r p p c e d',
  repeat {split},
    exact hr.1,
    exact three5a hp.1.symm he.1,
    exact hp.2.symm.flip,
    exact hr.2,
    exact two4 (eqd.refl p d'),
  exact hp.2,
have h_11 : eqd r p e d',
  exact afive_seg h13 h_3,
have h_12 : eqd r q e d,
  exact eqd.trans hq.2 (eqd.trans h_11 h_9.symm),
have h14 : afs d' e d c p r q c,
  repeat {split},
    exact he.2.symm,
    exact hq.1,
    exact h_11.symm.flip,
    exact h_12.symm,
    exact hp.2.symm.flip,
  exact hr.2.symm.flip,
have h_13 : eqd d' d p q,
  exact two11 he.2.symm hq.1 h_11.symm.flip h_12.symm,
cases em (d' = e),
  rw ←h_14 at *,
  have : d' = d,
    exact id_eqd h_9,
  rw this at *,
  left, exact hd.1,
have h_15 : eqd c q c d,
  exact (afive_seg h14 h_14).symm.flip,
have h15 : eqd c p c q,
  exact eqd.trans hp.2 (eqd.trans hd.2 h_15.symm),
have h_16 : r ≠ c,
  intro hrc,
  rw hrc at *,
  have : c = e,
    exact id_eqd hr.2.symm,
  rw ←this at *,
  have : c = c',
    exact id_eqd h_8.symm,
  exact h_10 this,
have h16 : col r c d',
  left, exact hr.1.symm,
have h_17 : eqd d' p d' q,
  exact four17 h_16 h16 hq.2.symm h15,
have h17 : col c d' b,
  right, right, exact h_4,
have h18 : col c d' b',
  left, exact hb.1,
have h_18 : eqd b p b q,
  exact four17 h_3.symm h17 h15 h_17,
have h_19 : eqd b' p b' q,
  exact four17 h_3.symm h18 h15 h_17,
have h19 : col b b' c',
  right, left, exact h5.symm,
have h_20 : b ≠ b',
  intro hbb,
  rw ←hbb at *,
  have : b = c,
    exact bet_same h6,
  exact h_7 this,
have h_21 : eqd c' p c' q,
  exact four17 h_20 h19 h_18 h_19,
have h20 : col c' c p,
  left, exact hp.1,
have h_22 : eqd p p p q,
  exact four17 (ne.symm h_10) h20 h_21 h15,
have h21 : p = q,
  exact id_eqd h_22.symm,
rw h21 at *,
have : d' = d,
  exact id_eqd h_13,
rw this at *,
left,
exact hd.1
end

theorem five2 {a b c d : point} : a ≠ b → B a b c → B a b d → B b c d ∨ B b d c :=
begin
intros h h1 h2,
cases five1 h h1 h2,
  left,
  exact three6a h1 h_1,
right,
exact three6a h2 h_1
end

theorem five3 {a b c d : point} : B a b d → B a c d → B a b c ∨ B a c b :=
begin
intros h h1,
cases three14 d a with p hp,
have h2 : B p a b,
  exact three5a hp.1.symm h,
have h3 : B p a c,
  exact three5a hp.1.symm h1,
cases five1 hp.2.symm h2 h3 with hb hc,
  left,
  exact three6a h2 hb,
right,
exact three6a h3 hc
end

theorem five4 {a b c d : point} : a ≠ b → col a b c → col a b d → col a c d :=
begin
intros h h1 h2,
cases h1,
  cases h2,
    cases five1 h h1 h2,
      left,
      assumption,
    right, left,
    exact h_1.symm,
  cases h2,
    right, left,
    exact (three6b h2.symm h1).symm,
  right, right,
  exact three7b h2 h1 h,
cases h1,
  cases h2,
    left,
    exact three6b h1.symm h2,
  cases h2,
    cases five3 h1.symm h2.symm,
      left,
      assumption,
    right, left,
    exact h_1.symm,
  right, right,
  exact three5a h2 h1.symm,
cases h2,
  right, right,
  exact (three7b h1 h2 h).symm,
cases h2,
  right, right,
  exact three6a h2 h1.symm,
cases five2 h.symm h1.symm h2.symm,
  left,
  assumption,
right, left,
exact h_1.symm
end

def distle (a b c d : point) : Prop := ∃ y, B c y d ∧ eqd a b c y

theorem five5 {a b c d : point} : distle a b c d ↔ ∃ x, B a b x ∧ eqd a x c d :=
begin
split,
  intro h,
  cases h with y hy,
  have : col c y d,
    left,
    exact hy.1,
  cases four14 this hy.2.symm with x hx,
  constructor,
    split,
    exact four6 hy.1 hx,
    exact hx.2.2.symm,
intro h,
cases h with x hx,
unfold distle,
have : col a x b,
  right, left,
  exact hx.1.symm,
cases four14 this hx.2 with y hy,
constructor,
  split,
    exact (four6 hx.1.symm (four4 hy).2.2.1).symm,
exact hy.2.2
end

theorem five6 {a b c d a' b' c' d' : point} : distle a b c d → eqd a b a' b' →
eqd c d c' d' → distle a' b' c' d' :=
begin
intros h h1 h2,
cases h with x hx,
cases four5 hx.1 h2 with y hy,
constructor,
  split,
  exact hy.1,
exact eqd.trans h1.symm (eqd.trans hx.2 hy.2.1)
end

theorem distle.refl (a b : point) : distle a b a b :=
begin
constructor,
  split,
    exact three1 a b,
exact eqd.refl a b
end

theorem distle.trans {a b c d e f : point} : distle a b c d → distle c d e f → distle a b e f :=
begin
intros h h1,
cases h with x hx,
cases h1 with y hy,
cases four5 hx.1 hy.2 with z hz,
constructor,
  split,
    exact three6b hz.1 hy.1,
exact eqd.trans hx.2 hz.2.1
end

theorem distle.flip {a b c d : point} : distle a b c d → distle b a d c :=
λ h, five6 h (two5 (eqd.refl a b)) (two5 (eqd.refl c d))

theorem five9 {a b c d : point} : distle a b c d → distle c d a b → eqd a b c d :=
begin
intros h h1,
cases h1 with x hx,
cases five5.mp h with z hz,
cases three14 b a with p hp,
cases hp with h1 h2,
rw three2 at h1,
cases em (a = b),
  rw h_1 at *,
  have : b = x,
    exact bet_same hx.1,
  rw this at *,
  exact hx.2.symm,
have h2 : p ≠ a,
  exact h2.symm,
have : x = z,
  apply unique_of_exists_unique (two12 a c d p h2),
    split,
    exact three5a h1 hx.1,
    exact hx.2.symm,
  split,
    exact three7b h1 hz.1 h_1,
  exact hz.2,
rw this at *,
have : b = z,
  exact three4 hx.1.symm hz.1.symm,
rw this at *,
exact hz.2
end

theorem five10 (a b c d : point) : distle a b c d ∨ distle c d a b :=
begin
cases three14 b a with p hp,
cases seg_cons a c d p with x hx,
cases five1 hp.2.symm hp.1.symm hx.1,
  have : B a b x,
    exact three6a hp.1.symm h,
  left,
  apply five5.mpr,
  constructor,
    split,
      exact this,
  exact hx.2,
  have : B a x b,
    exact three6a hx.1 h,
  right,
  constructor,
    split,
      exact this,
  exact hx.2.symm
end

theorem five11 (a b c : point) : distle a a b c :=
begin
cases five10 a a b c with h,
  assumption,
cases h with x hx,
have : a = x ,
  exact bet_same hx.1,
rw this at *,
have : b = c,
  exact id_eqd hx.2,
rw this at *,
existsi c,
split,
  exact three1 c c,
exact hx.2.symm
end

theorem five12 {a b c : point} : col a b c → (B a b c ↔ distle a b a c ∧ distle b c a c) :=
begin
intro h,
split,
  intro h1,
  split,
    constructor,
      split,
        exact h1,
    exact eqd.refl a b,
    have h2 : distle c b c a,
      constructor,
        split,
          exact h1.symm,
    exact eqd.refl c b,
  apply five6 h2,
    exact two5 (eqd.refl c b),
  exact two5 (eqd.refl c a),
intro h1,
cases h1 with h1 h2,
cases h1 with x hx,
have : distle c b c a,
  exact five6 h2 (two5 (eqd.refl b c)) (two5 (eqd.refl a c)),
cases this with y hy,
cases h with h,
  assumption,
cases h with h3 h4,
  rw three2 at h3,
  cases three14 b a with p hp,
  have : B p a c,
    exact three5a hp.1.symm h3,
  have : B p a x,
    exact three5a this hx.1,
  have : b = x,
    apply unique_of_exists_unique (two12 a a b p hp.2.symm),
      split,
        exact hp.1.symm,
      exact eqd.refl a b,
    split,
      exact this,
    exact hx.2.symm,
  rw ←this at *,
  exact hx.1,
rw three2 at h4,
cases three14 b c with q hq,
have : B q c a,
  exact three5a hq.1.symm h4.symm,
have : B q c y,
  exact three5a this hy.1,
 have : b = y,
  apply unique_of_exists_unique (two12 c c b q hq.2.symm),
    split,
      exact hq.1.symm,
    exact eqd.refl c b,
  split,
    exact this,
  exact hy.2.symm,
rw ←this at *,
exact hy.1.symm
end

def distlt (a b c d : point) : Prop := distle a b c d ∧ ¬eqd a b c d

theorem five13 {a b c d : point} : distlt a b c d → ∃ y, B c y d ∧ eqd a b c y ∧ y ≠ d :=
begin
rintros ⟨h, h1⟩,
cases h with y hy,
refine ⟨y, hy.1, hy.2, _⟩,
intro h_1,
subst y,
exact h1 hy.2
end

theorem five14 {a b c d a' b' c' d' : point} : distlt a b c d → eqd a b a' b' →
eqd c d c' d' → distlt a' b' c' d' :=
λ h h1 h2, ⟨five6 h.1 h1 h2, λ h_1, h.2 (h1.trans (h_1.trans h2.symm))⟩

theorem distlt.trans {a b c d e f : point} : distlt a b c d → distlt c d e f → distlt a b e f :=
λ h h1, ⟨h.1.trans h1.1, λ h_1, h.2 (five9 h.1 (five6 h1.1 (eqd.refl c d) h_1.symm))⟩

theorem distlt.flip {a b c d : point} : distlt a b c d → distlt b a d c :=
λ h, ⟨h.1.flip, λ h_1, h.2 h_1.flip⟩

theorem five15 {a b c d : point} : distlt a b c d → distlt c d a b → false :=
λ h h1, (h.trans h1).2 (eqd.refl a b)

theorem dist_lt_or_eq_of_le {a b c d : point} : distle a b c d → distlt a b c d ∨ eqd a b c d :=
begin
intro h,
cases em (eqd a b c d),
  exact or.inr h_1,
exact or.inl ⟨h, h_1⟩
end

theorem dist_lt_iff_not_le {a b c d : point} : distlt a b c d ↔ ¬distle c d a b :=
begin
split,
  intros h h1,
  exact h.2 (five9 h.1 h1),
intro h,
split,
  have h1 := five10 a b c d,
  simp [h] at h1,
  exact h1,
intro h1,
exact h (five6 (distle.refl a b) h1 (eqd.refl a b))
end

theorem dist_le_iff_not_lt {a b c d : point} : distle a b c d ↔ ¬distlt c d a b :=
begin
split,
  intros h h1,
  exact dist_lt_iff_not_le.1 h1 h,
intro h,
by_contradiction h_1,
exact h (dist_lt_iff_not_le.2 h_1)
end

theorem dist_total (a b c d : point) : distlt a b c d ∨ eqd a b c d ∨ distlt c d a b :=
begin
cases em (distle a b c d),
  cases dist_lt_or_eq_of_le h;
  simp *,
simp [dist_lt_iff_not_le.2 h]
end

-- Rays and Lines

def sided (p a b : point) : Prop := a ≠ p ∧ b ≠ p ∧ (B p a b ∨ B p b a)

theorem six1 {a b p : point} : col a p b → B a p b ∨ sided p a b :=
begin
intro h,
cases em (B a p b),
  exact or.inl h_1,
unfold col at h,
simp * at *,
rw [three2 b a p] at h,
refine ⟨_, _, h.symm⟩;
intro h_1;
subst p,
  exact h_1 (three3 a b),
exact h_1 (three1 a b)
end

theorem six2 {a b c p : point} : a ≠ p → b ≠ p → c ≠ p → B a p c → (B b p c ↔ sided p a b) :=
begin
intros h h1 h2 h3,
split,
  intro h4,
    unfold sided; repeat {split}; try {assumption},
  exact five2 h2 h3.symm h4.symm,
intro h4,
cases h4 with h h1,
cases h1 with h1 ha,
cases ha with ha hb,
  exact three7a ha.symm h3 h,
exact three6a hb.symm h3
end

theorem six3 {a b p : point} : sided p a b ↔ a ≠ p ∧ b ≠ p ∧ ∃ c, c ≠ p ∧ B a p c ∧ B b p c :=
begin
split,
  intro h,
  cases h with h h1,
  cases h1 with h1 h2,
  split, exact h,
    split, exact h1,
    cases three14 a p with c hc,
    constructor, split,
      exact hc.2.symm,
  split, exact hc.1,
  cases h2,
    exact three7a h2.symm hc.1 h,
  exact three6a h2.symm hc.1,
intro h,
cases h with h h1,
cases h1 with h1 h2,
split, exact h,
split, exact h1,
cases h2 with c h2,
exact five2 h2.1 h2.2.1.symm h2.2.2.symm
end

theorem six4 {a b p : point} : sided p a b ↔ col a p b ∧ ¬B a p b :=
begin
split,
  rintros ⟨h, h1, h2⟩,
  cases h2 with ha hb,
    split,
      unfold col,
      simp [ha.symm],
    intro h2,
    exact h (three4 h2 ha),
  split,
    unfold col,
    simp [hb],
  intro h2,
  exact h1 (three4 h2.symm hb),
rintros ⟨h, h1⟩,
split,
  intro h1,
  subst p,
  exact h1 (three3 a b),
split,
  intro h1,
  subst p,
  exact h1 (three1 a b),
unfold col at h,
simp [h1] at h,
rw [three2 b a p] at h,
exact h.symm
end

theorem six5 {a p : point} : a ≠ p → sided p a a :=
begin
intro h,
apply six4.2,
split,
  right, left,
  exact three1 p a,
intro h1,
exact h (bet_same h1)
end

theorem six6 {a b c d : point} : B a b c → sided b c d → B a b d :=
begin
intros h h1,
cases h1.2.2,
  exact three7b h h_1 h1.1.symm,
exact three5a h h_1
end

theorem six7 {a b p : point} : B p a b → a ≠ p → sided p a b :=
begin
intros h h1,
refine ⟨h1, _, or.inl h⟩,
intro h_1,
subst h_1,
exact h1.symm (bet_same h)
end

theorem sided.symm {a b p : point} : sided p a b → sided p b a :=
begin
intro h,
cases six3.1 h with h h1,
cases h1 with h1 h2,
cases h2 with c hc,
apply six3.2,
split, exact h1,
split, exact h,
constructor,
  split,
    exact hc.1,
split,
  exact hc.2.2,
exact hc.2.1
end

theorem sided.trans {a b c p : point} : sided p a b → sided p b c → sided p a c :=
begin
intros h1 h,
cases six3.1 h1 with h1 h2,
cases h2 with h2 h3,
cases h3 with q hq,
have h3 : c ≠ p,
  exact h.2.1,
have : B c p q,
  exact (six2 h2 h3 hq.1 hq.2.2).2 h,
exact (six2 h1 h3 hq.1 hq.2.1).1 this
end

theorem six6a {a b c d : point} : sided a b c → B b d c → sided a b d :=
begin
intros h h1,
cases h.2.2,
  exact six7 (three5a h_1 h1) h.1,
exact h.trans (six7 (three5a h_1 h1.symm) h.2.1)
end

theorem six7a {a b c p : point} : B p a b → sided p a c → sided p b c :=
begin
intros h h1,
apply sided.trans _ h1,
exact (six7 h h1.1).symm
end

theorem six8 {a b c p q : point} : sided b p a → sided b q c → B a b c → B p b q :=
begin
intros h h1 h2,
have h3 : B p b c,
  cases h.2.2,
    exact three6a h_1.symm h2,
  exact three7a h_1.symm h2 h.2.1,
cases h1.2.2,
  exact three5a h3 h_1,
exact three7b h3 h_1 h1.2.1.symm
end

def ray (p a : point) : set point := {x | sided p a x}

def hline (k : set point) : Prop := ∃ p a, a ≠ p ∧ k = ray p a

theorem six11 {a b c r : point} : r ≠ a → b ≠ c → ∃! x, sided a x r ∧ eqd a x b c :=
begin
intros h h1,
cases three14 r a with p hp,
cases seg_cons a b c p with x hx,
have h2 : x ≠ a,
  intro ha,
  rw ha at hx,
  have : b = c,
    exact id_eqd hx.2.symm,
  contradiction,
have h3 : sided a x r,
  split,
    exact h2,
  split,
    exact h,
  exact five2 hp.2.symm hx.1 hp.1.symm,
apply exists_unique.intro,
  exact ⟨h3, hx.2⟩,
intros y hy,
have : B p a y,
  exact ((six2 h2 hy.1.1 hp.2.symm hx.1.symm).2 (sided.trans h3 hy.1.symm)).symm,
apply unique_of_exists_unique (two12 a b c p hp.2.symm),
  exact ⟨this, hy.2⟩,
exact hx
end

theorem six11a {p a b : point} : sided p a b → eqd p a p b → a = b :=
λ h h1, unique_of_exists_unique (six11 h.1 h.1.symm) ⟨(six5 h.1), eqd.refl p a⟩ ⟨h.symm, h1.symm⟩

theorem six12 {a b p : point} : sided p a b → (distle p a p b ↔ B p a b) :=
begin
intro h1,
have hp : sided p a b, exact h1,
split,
  intro h,
  cases h1 with h1 h2,
  cases h2 with h2 h3,
  cases h3,
    exact h3,
  have : col p b a,
    left, exact h3,
  have : distle p b p a,
    exact ((five12 this).1 h3).1,
  have : eqd p a p b,
    exact five9 h this,
  cases three14 a p with q hq,
  have h4 : B q p b,
    exact ((six2 h1 h2 hq.2.symm hq.1).2 hp).symm,
  have : a = b,
    apply unique_of_exists_unique (two12 p p a q hq.2.symm),
      split,
        exact hq.1.symm,
      exact eqd.refl p a,
    split,
      exact h4,
    exact this.symm,
  rw this,
  exact three1 p b,
intro h,
unfold distle,
existsi a,
split,
  exact h,
exact eqd.refl p a
end
end Euclidean_plane


-- here we define a presheaf of types on a basis of a top space;
-- sections only defined on a basis
-- restriction maps are just from basis elt to basis elt
--

import analysis.topology.topological_space
universe u

structure presheaf_of_types_on_basis {X : Type u} [TX : topological_space X] {B : set (set X)}
  (HB : topological_space.is_topological_basis B) :=
(F : Π {U : set X}, U ∈ B → Type u)
(res : ∀ {U V : set X} (BU : U ∈ B) (BV : V ∈ B) (H : V ⊆ U),
  (F BU) → (F BV))
(Hid : ∀ (U : set X) (BU : U ∈ B), (res BU BU (set.subset.refl U)) = id)
(Hcomp : ∀ (U V W : set X) (BU : U ∈ B) (BV : V ∈ B) (BW : W ∈ B)
  (HUV : V ⊆ U) (HVW : W ⊆ V),
  (res BU BW (set.subset.trans HVW HUV)) = (res BV BW HVW) ∘ (res BU BV HUV) )

@[simp] lemma presheaf_of_types_on_basis.Hcomp' {X : Type u} [TX : topological_space X] {B : set (set X)}
  {HB : topological_space.is_topological_basis B} (FPTB : presheaf_of_types_on_basis HB) :
∀ {U V W : set X} (BU : U ∈ B) (BV : V ∈ B) (BW : W ∈ B)
  (HUV : V ⊆ U) (HVW : W ⊆ V) (s : FPTB.F BU),
  (FPTB.res BU BW (set.subset.trans HVW HUV)) s =
    (FPTB.res BV BW HVW) ((FPTB.res BU BV HUV) s) := begin
    intros U V W BU BV BW HUV HVW s,
      show _ = ((FPTB.res BV BW HVW) ∘ (FPTB.res BU BV HUV)) s,
      rw FPTB.Hcomp,
    end

structure morphism_of_presheaves_of_types_on_basis {X : Type u} [TX : topological_space X]
  {B : set (set X)} {HB : topological_space.is_topological_basis B}
  (FPT : presheaf_of_types_on_basis HB)
  (GPT : presheaf_of_types_on_basis HB)
  :=
(morphism : ∀ {U} (HU : U ∈ B), (FPT.F HU) → GPT.F HU)
(commutes : ∀ {U V} (HU : U ∈ B) (HV : V ∈ B) (Hsub : V ⊆ U),
  (GPT.res HU HV Hsub) ∘ (morphism HU) = (morphism HV) ∘ (FPT.res HU HV Hsub))

definition composition_of_morphism_of_presheaves_of_types_on_basis
{X : Type u} [TX : topological_space X]
  {B : set (set X)} {HB : topological_space.is_topological_basis B}
  {FPT : presheaf_of_types_on_basis HB}
  {GPT : presheaf_of_types_on_basis HB}
  {HPT : presheaf_of_types_on_basis HB}
  (phi : morphism_of_presheaves_of_types_on_basis FPT GPT)
  (psi : morphism_of_presheaves_of_types_on_basis GPT HPT)
  : morphism_of_presheaves_of_types_on_basis FPT HPT :=
{
  morphism := λ U HU, (psi.morphism HU) ∘ (phi.morphism HU),
  commutes := λ U V HU HV Hsub,
  by rw [←function.comp.assoc,psi.commutes,function.comp.assoc,phi.commutes],
}

definition is_identity_morphism_of_presheaves_of_types_on_basis {X : Type u} [TX : topological_space X]
  {B : set (set X)} {HB : topological_space.is_topological_basis B}
  {FPT : presheaf_of_types_on_basis HB} (phi : morphism_of_presheaves_of_types_on_basis FPT FPT)
  : Prop :=
  ∀ U : set X, ∀ HU : U ∈ B, phi.morphism HU = id

definition is_isomorphism_of_presheaves_of_types_on_basis
{X : Type u} [TX : topological_space X]
  {B : set (set X)} {HB : topological_space.is_topological_basis B}
  {FPT : presheaf_of_types_on_basis HB}
  {GPT : presheaf_of_types_on_basis HB}
  (phi : morphism_of_presheaves_of_types_on_basis FPT GPT) : Prop :=
  ∃ psi :  morphism_of_presheaves_of_types_on_basis GPT FPT,
  is_identity_morphism_of_presheaves_of_types_on_basis (composition_of_morphism_of_presheaves_of_types_on_basis phi psi)
  ∧ is_identity_morphism_of_presheaves_of_types_on_basis (composition_of_morphism_of_presheaves_of_types_on_basis psi phi)


/- Ordering for functions which have a finite number of possible arguments. -/

import data.fin data.fintype

namespace fin
namespace pi
variables {n : ℕ} {β : fin n → Type*}

private def le_worker [∀ a, has_le (β a)] [∀ a, has_lt (β a)] (f g : Π a, β a) : ∀ a, a < n → Prop
| nat.zero p := f ⟨ nat.zero, p ⟩ ≤ g ⟨ nat.zero, p ⟩
| (nat.succ a) p :=
  let f' := f ⟨ nat.succ a, p ⟩ in
  let g' := g ⟨ nat.succ a, p ⟩ in
  f' < g' ∨ (f' = g' ∧ le_worker a (nat.lt_of_succ_lt p) )

/-- f ≤ g is effectively the same as list.map f [0..n] ≤ list.map g [0..n] -/
protected def le [∀ a, has_le (β a)] [∀ a, has_lt (β a)] (f g : Π a, β a) : Prop :=
  match n, rfl : ∀ (n' : ℕ), n = n' → _ with
  | nat.zero, _ := true
  | nat.succ a, r := le_worker f g a (symm r ▸ nat.lt_succ_self a)
  end

instance [∀ a, has_le (β a)] [∀ a, has_lt (β a)] : has_le (Π (a : fin n), β a)
  := ⟨ pi.le ⟩

private theorem le_refl_worker [∀ a, preorder (β a)] (f : Π a, β a)
  : ∀ a p, le_worker f f a p := λ n p, begin
  induction n; simp [le_worker],
  case nat.succ : a ih { from or.inr (ih _) }
end

protected theorem le_refl [∀ a, preorder (β a)] (f : Π a, β a) : pi.le f f := begin
  tactic.unfreeze_local_instances,
  cases n,

  case nat.zero { unfold pi.le },
  case nat.succ : a { unfold pi.le, from le_refl_worker f _ _ }
end

private theorem le_trans_worker [∀ a, preorder (β a)] (f g h : Π a, β a)
  : ∀ a p, le_worker f g a p → le_worker g h a p → le_worker f h a p
| nat.zero _ fg gf := le_trans fg gf
| (nat.succ x) p fg gh :=
  match fg, gh with
  | or.inl fg, or.inl gh := or.inl (lt_trans fg gh)
  | or.inl fg, or.inr ⟨ gh, _ ⟩ := or.inl (gh ▸ fg)
  | or.inr ⟨ fg, _ ⟩, or.inl gh := or.inl (symm fg ▸ gh)
  | or.inr ⟨ fg', ihl ⟩, or.inr ⟨ gh', ihr ⟩ := or.inr $
    by { simp [fg', gh'], from le_trans_worker _ _ ihl ihr }
  end

protected theorem le_trans [∀ a, preorder (β a)] (f g h : Π a, β a)
  : pi.le f g → pi.le g h → pi.le f h := λ fg gh, begin
  tactic.unfreeze_local_instances,
  cases n,

  case nat.zero { unfold pi.le },
  case nat.succ : a {
    unfold pi.le at fg gh ⊢,
    from le_trans_worker f g h _ _ fg gh
  }
end

instance [∀ a, preorder (β a)] : preorder (Π (a : fin n), β a)
  := { le := pi.le, le_refl := pi.le_refl, le_trans := pi.le_trans }

private theorem le_antisymm_worker [∀ a, partial_order (β a)] (f g : Π a, β a)
  : Π a p, le_worker f g a p → le_worker g f a p
  → ∀ x (H : x ≤ a), f ⟨ x, nat.lt_of_le_of_lt H p ⟩ = g ⟨ x, nat.lt_of_le_of_lt H p ⟩
| nat.zero p fg gf ._ (nat.less_than_or_equal.refl 0) := le_antisymm fg gf
| (nat.succ a) p (or.inl lt) (or.inl lt') _ _ := false.elim (lt_asymm lt lt')
| (nat.succ a) p (or.inl lt) (or.inr ⟨ eq, _ ⟩) _ _ := false.elim (ne_of_lt lt (symm eq))
| (nat.succ a) p (or.inr ⟨ eq, _ ⟩) (or.inl lt) _ _ := false.elim (ne_of_lt lt (symm eq))
| (nat.succ a) p (or.inr ⟨ eq, ihl ⟩) (or.inr ⟨ _, ihr ⟩) x (nat.less_than_or_equal.refl n) := eq
| (nat.succ a) p (or.inr ⟨ eq, ihl ⟩) (or.inr ⟨ _, ihr ⟩) x (nat.less_than_or_equal.step le)
  := le_antisymm_worker a _ ihl ihr x le

protected theorem le_antisymm [∀ a, partial_order (β a)] (f g : Π a, β a)
  : f ≤ g → g ≤ f → f = g := λ fg gf, begin
    tactic.unfreeze_local_instances,
    cases n,

    case nat.zero { from funext (λ ⟨ _, lt ⟩, match lt with end) },
    case nat.succ : a {
      from funext
        (λ ⟨ x, lt ⟩, le_antisymm_worker f g a _ fg gf x (nat.le_of_lt_succ lt))
    }
  end

instance [∀ a, partial_order (β a)] : partial_order (Π (a : fin n), β a)
  := { le_antisymm := pi.le_antisymm, ..pi.preorder }

private def le_decidable_worker
  [∀ a, has_le (β a)] [∀ a, has_lt (β a)] [∀ a, decidable_eq (β a)]
  [∀ a, @decidable_rel (β a) (<)] [∀ a, @decidable_rel (β a) (≤)]
  (f g : Π a, β a) : Π (a : ℕ) (p : a < n), decidable (le_worker f g a p)
| nat.zero _ := by { unfold le_worker, by apply_instance }
| (nat.succ a) p := @or.decidable _ _ _ (@and.decidable _ _ _ (le_decidable_worker a _))

/-- A decision procedure for f ≤ g -/
protected def le_decidable
  [∀ a, has_le (β a)] [∀ a, has_lt (β a)] [∀ a, decidable_eq (β a)]
  [∀ a, @decidable_rel (β a) (<)] [∀ a, @decidable_rel (β a) (≤)]
  (f g : Π a, β a) : decidable (f ≤ g) := begin
    tactic.unfreeze_local_instances,
    cases n,

    case nat.zero { from decidable.true },
    case nat.succ : a { from le_decidable_worker f g a _ }
end

instance decidable_le
  [∀ a, has_le (β a)] [∀ a, has_lt (β a)] [∀ a, decidable_eq (β a)]
  [∀ a, @decidable_rel (β a) (<)] [∀ a, @decidable_rel (β a) (≤)]
  : @decidable_rel (Π (a : fin n), β a) (≤)
  := pi.le_decidable

private theorem le_total_worker [∀ a, linear_order (β a)] (f g : Π a, β a)
  : ∀ a p, le_worker f g a p ∨ le_worker g f a p
| nat.zero p := le_total (f ⟨ 0, p ⟩) (g ⟨ 0, p ⟩)
| (nat.succ a) p := by {
  cases (le_total (f ⟨ _, p ⟩) (g ⟨ _, p ⟩)),
  case or.inl : f_le_g {
    cases lt_or_eq_of_le f_le_g,
    -- f _ < g _ : Trivial: build inl
    case or.inl : f_lt_g { from or.inl (or.inl f_lt_g) },
    -- f _ = g _ : Recurse: build inr
    case or.inr : f_eq_g {
      from or.imp (λ h, or.inr ⟨ f_eq_g, h ⟩) (λ h, or.inr ⟨ symm f_eq_g, h ⟩)
                  (le_total_worker a _)
    }
  },
  case or.inr : g_le_f {
    -- As above, but flipped.
    cases lt_or_eq_of_le g_le_f,
    case or.inl : g_lt_f { from or.inr (or.inl g_lt_f) },
    case or.inr : g_eq_f {
      from or.imp (λ h, or.inr ⟨ symm g_eq_f, h ⟩) (λ h, or.inr ⟨ g_eq_f, h ⟩)
                  (le_total_worker a _)
    }
  }
 }

protected theorem le_total [∀ a, linear_order (β a)] (f g : Π a, β a) : f ≤ g ∨ g ≤ f := begin
  tactic.unfreeze_local_instances,
  cases n,

  case nat.zero { from or.inl true.intro },
  case nat.succ : a { from le_total_worker f g a _ }
end

instance [∀ a, linear_order (β a)] : linear_order (Π (a : fin n), β a)
  := { le_total := pi.le_total, ..pi.partial_order }

instance [∀ a, decidable_linear_order (β a)] : decidable_linear_order (Π (a : fin n), β a)
  := { decidable_le := pi.decidable_le,
       decidable_eq := fintype.decidable_pi_fintype,
       ..pi.linear_order }

end pi
end fin

#lint -


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.locally_finite

/-!
# Intervals as multisets

This file provides basic results about all the `multiset.Ixx`, which are defined in
`order.locally_finite`.
-/

variables {α : Type*}

namespace multiset
section preorder
variables [preorder α] [locally_finite_order α] {a b c : α}

lemma nodup_Icc : (Icc a b).nodup := finset.nodup _
lemma nodup_Ico : (Ico a b).nodup := finset.nodup _
lemma nodup_Ioc : (Ioc a b).nodup := finset.nodup _
lemma nodup_Ioo : (Ioo a b).nodup := finset.nodup _

@[simp] lemma Icc_eq_zero_iff : Icc a b = 0 ↔ ¬a ≤ b :=
by rw [Icc, finset.val_eq_zero, finset.Icc_eq_empty_iff]

@[simp] lemma Ico_eq_zero_iff : Ico a b = 0 ↔ ¬a < b :=
by rw [Ico, finset.val_eq_zero, finset.Ico_eq_empty_iff]

@[simp] lemma Ioc_eq_zero_iff : Ioc a b = 0 ↔ ¬a < b :=
by rw [Ioc, finset.val_eq_zero, finset.Ioc_eq_empty_iff]

@[simp] lemma Ioo_eq_zero_iff [densely_ordered α] : Ioo a b = 0 ↔ ¬a < b :=
by rw [Ioo, finset.val_eq_zero, finset.Ioo_eq_empty_iff]

alias Icc_eq_zero_iff ↔ _ multiset.Icc_eq_zero
alias Ico_eq_zero_iff ↔ _ multiset.Ico_eq_zero
alias Ioc_eq_zero_iff ↔ _ multiset.Ioc_eq_zero

@[simp] lemma Ioo_eq_zero (h : ¬a < b) : Ioo a b = 0 :=
eq_zero_iff_forall_not_mem.2 $ λ x hx, h ((mem_Ioo.1 hx).1.trans (mem_Ioo.1 hx).2)

@[simp] lemma Icc_eq_zero_of_lt (h : b < a) : Icc a b = 0 := Icc_eq_zero h.not_le
@[simp] lemma Ico_eq_zero_of_le (h : b ≤ a) : Ico a b = 0 := Ico_eq_zero h.not_lt
@[simp] lemma Ioc_eq_zero_of_le (h : b ≤ a) : Ioc a b = 0 := Ioc_eq_zero h.not_lt
@[simp] lemma Ioo_eq_zero_of_le (h : b ≤ a) : Ioo a b = 0 := Ioo_eq_zero h.not_lt

variables (a)

@[simp] lemma Ico_self : Ico a a = 0 := by rw [Ico, finset.Ico_self, finset.empty_val]
@[simp] lemma Ioc_self : Ioc a a = 0 := by rw [Ioc, finset.Ioc_self, finset.empty_val]
@[simp] lemma Ioo_self : Ioo a a = 0 := by rw [Ioo, finset.Ioo_self, finset.empty_val]

variables {a b c}

lemma left_mem_Icc : a ∈ Icc a b ↔ a ≤ b := finset.left_mem_Icc
lemma left_mem_Ico : a ∈ Ico a b ↔ a < b := finset.left_mem_Ico
lemma right_mem_Icc : b ∈ Icc a b ↔ a ≤ b := finset.right_mem_Icc
lemma right_mem_Ioc : b ∈ Ioc a b ↔ a < b := finset.right_mem_Ioc

@[simp] lemma left_not_mem_Ioc : a ∉ Ioc a b := finset.left_not_mem_Ioc
@[simp] lemma left_not_mem_Ioo : a ∉ Ioo a b := finset.left_not_mem_Ioo
@[simp] lemma right_not_mem_Ico : b ∉ Ico a b := finset.right_not_mem_Ico
@[simp] lemma right_not_mem_Ioo : b ∉ Ioo a b := finset.right_not_mem_Ioo

lemma Ico_filter_lt_of_le_left [decidable_pred (< c)] (hca : c ≤ a) :
  (Ico a b).filter (λ x, x < c) = ∅ :=
by { rw [Ico, ←finset.filter_val, finset.Ico_filter_lt_of_le_left hca], refl }

lemma Ico_filter_lt_of_right_le [decidable_pred (< c)] (hbc : b ≤ c) :
  (Ico a b).filter (λ x, x < c) = Ico a b :=
by rw [Ico, ←finset.filter_val, finset.Ico_filter_lt_of_right_le hbc]

lemma Ico_filter_lt_of_le_right [decidable_pred (< c)] (hcb : c ≤ b) :
  (Ico a b).filter (λ x, x < c) = Ico a c :=
by { rw [Ico, ←finset.filter_val, finset.Ico_filter_lt_of_le_right hcb], refl }

lemma Ico_filter_le_of_le_left [decidable_pred ((≤) c)] (hca : c ≤ a) :
  (Ico a b).filter (λ x, c ≤ x) = Ico a b :=
by rw [Ico, ←finset.filter_val, finset.Ico_filter_le_of_le_left hca]

lemma Ico_filter_le_of_right_le [decidable_pred ((≤) b)] :
  (Ico a b).filter (λ x, b ≤ x) = ∅ :=
by { rw [Ico, ←finset.filter_val, finset.Ico_filter_le_of_right_le], refl }

lemma Ico_filter_le_of_left_le [decidable_pred ((≤) c)] (hac : a ≤ c) :
  (Ico a b).filter (λ x, c ≤ x) = Ico c b :=
by { rw [Ico, ←finset.filter_val, finset.Ico_filter_le_of_left_le hac], refl }

end preorder

section partial_order
variables [partial_order α] [locally_finite_order α] {a b : α}

@[simp] lemma Icc_self (a : α) : Icc a a = {a} := by rw [Icc, finset.Icc_self, finset.singleton_val]

lemma Ico_cons_right (h : a ≤ b) : b ::ₘ (Ico a b) = Icc a b :=
by { classical,
  rw [Ico, ←finset.insert_val_of_not_mem right_not_mem_Ico, finset.Ico_insert_right h], refl }

lemma Ioo_cons_left (h : a < b) : a ::ₘ (Ioo a b) = Ico a b :=
by { classical,
  rw [Ioo, ←finset.insert_val_of_not_mem left_not_mem_Ioo, finset.Ioo_insert_left h], refl }

lemma Ico_disjoint_Ico {a b c d : α} (h : b ≤ c) : (Ico a b).disjoint (Ico c d) :=
λ x hab hbc, by { rw mem_Ico at hab hbc, exact hab.2.not_le (h.trans hbc.1) }

@[simp] lemma Ico_inter_Ico_of_le [decidable_eq α] {a b c d : α} (h : b ≤ c) :
  Ico a b ∩ Ico c d = 0 :=
multiset.inter_eq_zero_iff_disjoint.2 $ Ico_disjoint_Ico h

lemma Ico_filter_le_left {a b : α} [decidable_pred (≤ a)] (hab : a < b) :
  (Ico a b).filter (λ x, x ≤ a) = {a} :=
by { rw [Ico, ←finset.filter_val, finset.Ico_filter_le_left hab], refl }

end partial_order

section linear_order
variables [linear_order α] [locally_finite_order α] {a b c d : α}

lemma Ico_add_Ico_eq_Ico {a b c : α} (hab : a ≤ b) (hbc : b ≤ c) :
  Ico a b + Ico b c = Ico a c :=
by rw [add_eq_union_iff_disjoint.2 (Ico_disjoint_Ico le_rfl), Ico, Ico, Ico, ←finset.union_val,
  finset.Ico_union_Ico_eq_Ico hab hbc]

lemma Ico_inter_Ico : Ico a b ∩ Ico c d = Ico (max a c) (min b d) :=
by rw [Ico, Ico, Ico, ←finset.inter_val, finset.Ico_inter_Ico]

@[simp] lemma Ico_filter_lt (a b c : α) : (Ico a b).filter (λ x, x < c) = Ico a (min b c) :=
by rw [Ico, Ico, ←finset.filter_val, finset.Ico_filter_lt]

@[simp] lemma Ico_filter_le (a b c : α) : (Ico a b).filter (λ x, c ≤ x) = Ico (max a c) b :=
by rw [Ico, Ico, ←finset.filter_val, finset.Ico_filter_le]

@[simp] lemma Ico_sub_Ico_left (a b c : α) : Ico a b - Ico a c = Ico (max a c) b :=
by rw [Ico, Ico, Ico, ←finset.sdiff_val, finset.Ico_diff_Ico_left]

@[simp] lemma Ico_sub_Ico_right (a b c : α) : Ico a b - Ico c b = Ico a (min b c) :=
by rw [Ico, Ico, Ico, ←finset.sdiff_val, finset.Ico_diff_Ico_right]

end linear_order

section ordered_cancel_add_comm_monoid
variables [ordered_cancel_add_comm_monoid α] [has_exists_add_of_le α] [locally_finite_order α]

lemma map_add_left_Icc (a b c : α) : (Icc a b).map ((+) c) = Icc (c + a) (c + b) :=
by { classical, rw [Icc, Icc, ←finset.image_add_left_Icc, finset.image_val,
    (multiset.nodup_map (add_right_injective c) $ finset.nodup _).erase_dup] }

lemma map_add_left_Ico (a b c : α) : (Ico a b).map ((+) c) = Ico (c + a) (c + b) :=
by { classical, rw [Ico, Ico, ←finset.image_add_left_Ico, finset.image_val,
    (multiset.nodup_map (add_right_injective c) $ finset.nodup _).erase_dup] }

lemma map_add_left_Ioc (a b c : α) : (Ioc a b).map ((+) c) = Ioc (c + a) (c + b) :=
by { classical, rw [Ioc, Ioc, ←finset.image_add_left_Ioc, finset.image_val,
    (multiset.nodup_map (add_right_injective c) $ finset.nodup _).erase_dup] }

lemma map_add_left_Ioo (a b c : α) : (Ioo a b).map ((+) c) = Ioo (c + a) (c + b) :=
by { classical, rw [Ioo, Ioo, ←finset.image_add_left_Ioo, finset.image_val,
    (multiset.nodup_map (add_right_injective c) $ finset.nodup _).erase_dup] }

lemma map_add_right_Icc (a b c : α) : (Icc a b).map (λ x, x + c) = Icc (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact map_add_left_Icc _ _ _ }

lemma map_add_right_Ico (a b c : α) : (Ico a b).map (λ x, x + c) = Ico (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact map_add_left_Ico _ _ _ }

lemma map_add_right_Ioc (a b c : α) : (Ioc a b).map (λ x, x + c) = Ioc (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact map_add_left_Ioc _ _ _ }

lemma map_add_right_Ioo (a b c : α) : (Ioo a b).map (λ x, x + c) = Ioo (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact map_add_left_Ioo _ _ _ }

end ordered_cancel_add_comm_monoid
end multiset


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import measure_theory.measure.lebesgue
import number_theory.liouville.residual
import number_theory.liouville.liouville_with
import analysis.p_series

/-!
# Volume of the set of Liouville numbers

In this file we prove that the set of Liouville numbers with exponent (irrationality measure)
strictly greater than two is a set of Lebesuge measure zero, see
`volume_Union_set_of_liouville_with`.

Since this set is a residual set, we show that the filters `residual` and `volume.ae` are disjoint.
These filters correspond to two common notions of genericity on `ℝ`: residual sets and sets of full
measure. The fact that the filters are disjoint means that two mutually exclusive properties can be
“generic” at the same time (in the sense of different “genericity” filters).

## Tags

Liouville number, Lebesgue measure, residual, generic property
-/

open_locale filter big_operators ennreal topology nnreal
open filter set metric measure_theory real

lemma set_of_liouville_with_subset_aux :
  {x : ℝ | ∃ p > 2, liouville_with p x} ⊆
    ⋃ m : ℤ, (λ x : ℝ, x + m) ⁻¹' (⋃ n > (0 : ℕ),
      {x : ℝ | ∃ᶠ b : ℕ in at_top, ∃ a ∈ finset.Icc (0 : ℤ) b,
        |x - (a : ℤ) / b| < 1 / b ^ (2 + 1 / n : ℝ)}) :=
begin
  rintro x ⟨p, hp, hxp⟩,
  rcases exists_nat_one_div_lt (sub_pos.2 hp) with ⟨n, hn⟩,
  rw lt_sub_iff_add_lt' at hn,
  suffices : ∀ y : ℝ, liouville_with p y → y ∈ Ico (0 : ℝ) 1 →
    ∃ᶠ b : ℕ in at_top, ∃ a ∈ finset.Icc (0 : ℤ) b, |y - a / b| < 1 / b ^ (2 + 1 / (n + 1 : ℕ) : ℝ),
  { simp only [mem_Union, mem_preimage],
    have hx : x + ↑(-⌊x⌋) ∈ Ico (0 : ℝ) 1,
    { simp only [int.floor_le, int.lt_floor_add_one, add_neg_lt_iff_le_add', zero_add, and_self,
        mem_Ico, int.cast_neg, le_add_neg_iff_add_le] },
    refine ⟨-⌊x⌋, n + 1, n.succ_pos, this _ (hxp.add_int _) hx⟩ },
  clear hxp x, intros x hxp hx01,
  refine ((hxp.frequently_lt_rpow_neg hn).and_eventually (eventually_ge_at_top 1)).mono _,
  rintro b ⟨⟨a, hne, hlt⟩, hb⟩,
  rw [rpow_neg b.cast_nonneg, ← one_div, ← nat.cast_succ] at hlt,
  refine ⟨a, _, hlt⟩,
  replace hb : (1 : ℝ) ≤ b, from nat.one_le_cast.2 hb,
  have hb0 : (0 : ℝ) < b := zero_lt_one.trans_le hb,
  replace hlt : |x - a / b| < 1 / b,
  { refine hlt.trans_le (one_div_le_one_div_of_le hb0 _),
    calc (b : ℝ) = b ^ (1 : ℝ) : (rpow_one _).symm
    ... ≤ b ^ (2 + 1 / (n + 1 : ℕ) : ℝ) : rpow_le_rpow_of_exponent_le hb (one_le_two.trans _),
    simpa using n.cast_add_one_pos.le },
  rw [sub_div' _ _ _ hb0.ne', abs_div, abs_of_pos hb0, div_lt_div_right hb0,
    abs_sub_lt_iff, sub_lt_iff_lt_add, sub_lt_iff_lt_add, ← sub_lt_iff_lt_add'] at hlt,
  rw [finset.mem_Icc, ← int.lt_add_one_iff, ← int.lt_add_one_iff, ← neg_lt_iff_pos_add, add_comm,
    ← @int.cast_lt ℝ, ← @int.cast_lt ℝ], push_cast,
  refine ⟨lt_of_le_of_lt _ hlt.1, hlt.2.trans_le _⟩,
  { simp only [mul_nonneg hx01.left b.cast_nonneg, neg_le_sub_iff_le_add, le_add_iff_nonneg_left] },
  { rw [add_le_add_iff_left],
    calc x * b ≤ 1 * b : mul_le_mul_of_nonneg_right hx01.2.le hb0.le
    ... = b : one_mul b }
end

/-- The set of numbers satisfying the Liouville condition with some exponent `p > 2` has Lebesgue
measure zero. -/
@[simp] lemma volume_Union_set_of_liouville_with :
  volume (⋃ (p : ℝ) (hp : 2 < p), {x : ℝ | liouville_with p x}) = 0 :=
begin
  simp only [← set_of_exists],
  refine measure_mono_null set_of_liouville_with_subset_aux _,
  rw measure_Union_null_iff, intro m, rw measure_preimage_add_right, clear m,
  refine (measure_bUnion_null_iff $ to_countable _).2 (λ n (hn : 1 ≤ n), _),
  generalize hr : (2 + 1 / n : ℝ) = r,
  replace hr : 2 < r, by simp [← hr, zero_lt_one.trans_le hn], clear hn n,
  refine measure_set_of_frequently_eq_zero _,
  simp only [set_of_exists, ← real.dist_eq, ← mem_ball, set_of_mem_eq],
  set B : ℤ → ℕ → set ℝ := λ a b, ball (a / b) (1 / b ^ r),
  have hB : ∀ a b, volume (B a b) = ↑(2 / b ^ r : ℝ≥0),
  { intros a b,
    rw [real.volume_ball, mul_one_div, ← nnreal.coe_two, ← nnreal.coe_nat_cast, ← nnreal.coe_rpow,
      ← nnreal.coe_div, ennreal.of_real_coe_nnreal] },
  have : ∀ b : ℕ, volume (⋃ a ∈ finset.Icc (0 : ℤ) b, B a b) ≤ (2 * (b ^ (1 - r) + b ^ (-r)) : ℝ≥0),
  { intro b,
    calc volume (⋃ a ∈ finset.Icc (0 : ℤ) b, B a b)
        ≤ ∑ a in finset.Icc (0 : ℤ) b, volume (B a b) : measure_bUnion_finset_le _ _
    ... = ((b + 1) * (2 / b ^ r) : ℝ≥0) :
      by simp only [hB, int.card_Icc, finset.sum_const, nsmul_eq_mul, sub_zero,
        ← int.coe_nat_succ, int.to_nat_coe_nat, ← nat.cast_succ, ennreal.coe_mul, ennreal.coe_nat]
    ... = _ : _,
    have : 1 - r ≠ 0, by linarith,
    rw [ennreal.coe_eq_coe],
    simp [add_mul, div_eq_mul_inv, nnreal.rpow_neg, nnreal.rpow_sub' _ this, mul_add,
      mul_left_comm] },
  refine ne_top_of_le_ne_top (ennreal.tsum_coe_ne_top_iff_summable.2 _)
    (ennreal.tsum_le_tsum this),
  refine (summable.add _ _).mul_left _; simp only [nnreal.summable_rpow]; linarith
end

lemma ae_not_liouville_with : ∀ᵐ x, ∀ p > (2 : ℝ), ¬liouville_with p x :=
by simpa only [ae_iff, not_forall, not_not, set_of_exists]
  using volume_Union_set_of_liouville_with

lemma ae_not_liouville : ∀ᵐ x, ¬liouville x :=
ae_not_liouville_with.mono $ λ x h₁ h₂, h₁ 3 (by norm_num) (h₂.liouville_with 3)

/-- The set of Liouville numbers has Lebesgue measure zero. -/
@[simp] lemma volume_set_of_liouville : volume {x : ℝ | liouville x} = 0 :=
by simpa only [ae_iff, not_not] using ae_not_liouville

/-- The filters `residual ℝ` and `volume.ae` are disjoint. This means that there exists a residual
set of Lebesgue measure zero (e.g., the set of Liouville numbers). -/
lemma real.disjoint_residual_ae : disjoint (residual ℝ) volume.ae :=
disjoint_of_disjoint_of_mem disjoint_compl_right eventually_residual_liouville ae_not_liouville


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import ring_theory.int.basic
import ring_theory.localization.integral

/-!
# Gauss's Lemma

Gauss's Lemma is one of a few results pertaining to irreducibility of primitive polynomials.

## Main Results
 - `polynomial.is_primitive.irreducible_iff_irreducible_map_fraction_map`:
  A primitive polynomial is irreducible iff it is irreducible in a fraction field.
 - `polynomial.is_primitive.int.irreducible_iff_irreducible_map_cast`:
  A primitive polynomial over `ℤ` is irreducible iff it is irreducible over `ℚ`.
 - `polynomial.is_primitive.dvd_iff_fraction_map_dvd_fraction_map`:
  Two primitive polynomials divide each other iff they do in a fraction field.
 - `polynomial.is_primitive.int.dvd_iff_map_cast_dvd_map_cast`:
  Two primitive polynomials over `ℤ` divide each other if they do in `ℚ`.

-/

open_locale non_zero_divisors polynomial

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

namespace polynomial
section normalized_gcd_monoid
variable [normalized_gcd_monoid R]

section
variables {S : Type*} [comm_ring S] [is_domain S] {φ : R →+* S} (hinj : function.injective φ)
variables {f : R[X]} (hf : f.is_primitive)
include hinj hf

lemma is_primitive.is_unit_iff_is_unit_map_of_injective :
  is_unit f ↔ is_unit (map φ f) :=
begin
  refine ⟨(map_ring_hom φ).is_unit_map, λ h, _⟩,
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  have hdeg := degree_C u.ne_zero,
  rw [hu, degree_map_eq_of_injective hinj] at hdeg,
  rw [eq_C_of_degree_eq_zero hdeg, is_primitive_iff_content_eq_one,
      content_C, normalize_eq_one] at hf,
  rwa [eq_C_of_degree_eq_zero hdeg, is_unit_C],
end

lemma is_primitive.irreducible_of_irreducible_map_of_injective (h_irr : irreducible (map φ f)) :
  irreducible f :=
begin
  refine ⟨λ h, h_irr.not_unit (is_unit.map (map_ring_hom φ) h), _⟩,
  intros a b h,
  rcases h_irr.is_unit_or_is_unit (by rw [h, map_mul]) with hu | hu,
  { left,
    rwa (hf.is_primitive_of_dvd (dvd.intro _ h.symm)).is_unit_iff_is_unit_map_of_injective hinj },
  right,
  rwa (hf.is_primitive_of_dvd (dvd.intro_left _ h.symm)).is_unit_iff_is_unit_map_of_injective hinj
end

end

section fraction_map
variables {K : Type*} [field K] [algebra R K] [is_fraction_ring R K]

lemma is_primitive.is_unit_iff_is_unit_map {p : R[X]} (hp : p.is_primitive) :
  is_unit p ↔ is_unit (p.map (algebra_map R K)) :=
hp.is_unit_iff_is_unit_map_of_injective (is_fraction_ring.injective _ _)

open is_localization

lemma is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part
  {p : K[X]} (h0 : p ≠ 0) (h : is_unit (integer_normalization R⁰ p).prim_part) :
  is_unit p :=
begin
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := integer_normalization_map_to_map R⁰ p,
  rw [subtype.coe_mk, algebra.smul_def, algebra_map_apply] at hc,
  apply is_unit_of_mul_is_unit_right,
  rw [← hc, (integer_normalization R⁰ p).eq_C_content_mul_prim_part, ← hu,
    ← ring_hom.map_mul, is_unit_iff],
  refine ⟨algebra_map R K ((integer_normalization R⁰ p).content * ↑u),
    is_unit_iff_ne_zero.2 (λ con, _), by simp⟩,
  replace con := (algebra_map R K).injective_iff.1 (is_fraction_ring.injective _ _) _ con,
  rw [mul_eq_zero, content_eq_zero_iff, is_fraction_ring.integer_normalization_eq_zero_iff] at con,
  rcases con with con | con,
  { apply h0 con },
  { apply units.ne_zero _ con },
end

/-- **Gauss's Lemma** states that a primitive polynomial is irreducible iff it is irreducible in the
  fraction field. -/
theorem is_primitive.irreducible_iff_irreducible_map_fraction_map
  {p : R[X]} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map (algebra_map R K)) :=
begin
  refine ⟨λ hi, ⟨λ h, hi.not_unit (hp.is_unit_iff_is_unit_map.2 h), λ a b hab, _⟩,
    hp.irreducible_of_irreducible_map_of_injective (is_fraction_ring.injective _ _)⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := integer_normalization_map_to_map R⁰ a,
  obtain ⟨⟨d, d0⟩, hd⟩ := integer_normalization_map_to_map R⁰ b,
  rw [algebra.smul_def, algebra_map_apply, subtype.coe_mk] at hc hd,
  rw mem_non_zero_divisors_iff_ne_zero at c0 d0,
  have hcd0 : c * d ≠ 0 := mul_ne_zero c0 d0,
  rw [ne.def, ← C_eq_zero] at hcd0,
  have h1 : C c * C d * p = integer_normalization R⁰ a * integer_normalization R⁰ b,
  { apply map_injective (algebra_map R K) (is_fraction_ring.injective _ _) _,
    rw [map_mul, map_mul, map_mul, hc, hd, map_C, map_C, hab],
    ring },
  obtain ⟨u, hu⟩ : associated (c * d) (content (integer_normalization R⁰ a) *
            content (integer_normalization R⁰ b)),
  { rw [← dvd_dvd_iff_associated, ← normalize_eq_normalize_iff, normalize.map_mul,
        normalize.map_mul, normalize_content, normalize_content,
        ← mul_one (normalize c * normalize d), ← hp.content_eq_one, ← content_C, ← content_C,
        ← content_mul, ← content_mul, ← content_mul, h1] },
  rw [← ring_hom.map_mul, eq_comm,
    (integer_normalization R⁰ a).eq_C_content_mul_prim_part,
    (integer_normalization R⁰ b).eq_C_content_mul_prim_part, mul_assoc,
    mul_comm _ (C _ * _), ← mul_assoc, ← mul_assoc, ← ring_hom.map_mul, ← hu, ring_hom.map_mul,
    mul_assoc, mul_assoc, ← mul_assoc (C ↑u)] at h1,
  have h0 : (a ≠ 0) ∧ (b ≠ 0),
  { classical,
    rw [ne.def, ne.def, ← decidable.not_or_iff_and_not, ← mul_eq_zero, ← hab],
    intro con,
    apply hp.ne_zero (map_injective (algebra_map R K) (is_fraction_ring.injective _ _) _),
    simp [con] },
  rcases hi.is_unit_or_is_unit (mul_left_cancel₀ hcd0 h1).symm with h | h,
  { right,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part h0.2
      (is_unit_of_mul_is_unit_right h) },
  { left,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part h0.1 h },
end

lemma is_primitive.dvd_of_fraction_map_dvd_fraction_map {p q : R[X]}
  (hp : p.is_primitive) (hq : q.is_primitive)
  (h_dvd : p.map (algebra_map R K) ∣ q.map (algebra_map R K)) : p ∣ q :=
begin
  rcases h_dvd with ⟨r, hr⟩,
  obtain ⟨⟨s, s0⟩, hs⟩ := integer_normalization_map_to_map R⁰ r,
  rw [subtype.coe_mk, algebra.smul_def, algebra_map_apply] at hs,
  have h : p ∣ q * C s,
  { use (integer_normalization R⁰ r),
    apply map_injective (algebra_map R K) (is_fraction_ring.injective _ _),
    rw [map_mul, map_mul, hs, hr, mul_assoc, mul_comm r],
    simp },
  rw [← hp.dvd_prim_part_iff_dvd, prim_part_mul, hq.prim_part_eq,
      associated.dvd_iff_dvd_right] at h,
  { exact h },
  { symmetry,
    rcases is_unit_prim_part_C s with ⟨u, hu⟩,
    use u,
    rw hu },
  iterate 2 { apply mul_ne_zero hq.ne_zero,
    rw [ne.def, C_eq_zero],
    contrapose! s0,
    simp [s0, mem_non_zero_divisors_iff_ne_zero] }
end

variables (K)

lemma is_primitive.dvd_iff_fraction_map_dvd_fraction_map {p q : R[X]}
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map (algebra_map R K) ∣ q.map (algebra_map R K)) :=
⟨λ ⟨a,b⟩, ⟨a.map (algebra_map R K), b.symm ▸ map_mul (algebra_map R K)⟩,
  λ h, hp.dvd_of_fraction_map_dvd_fraction_map hq h⟩

end fraction_map

/-- **Gauss's Lemma** for `ℤ` states that a primitive integer polynomial is irreducible iff it is
  irreducible over `ℚ`. -/
theorem is_primitive.int.irreducible_iff_irreducible_map_cast
  {p : ℤ[X]} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map (int.cast_ring_hom ℚ)) :=
hp.irreducible_iff_irreducible_map_fraction_map

lemma is_primitive.int.dvd_iff_map_cast_dvd_map_cast (p q : ℤ[X])
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map (int.cast_ring_hom ℚ) ∣ q.map (int.cast_ring_hom ℚ)) :=
hp.dvd_iff_fraction_map_dvd_fraction_map ℚ hq

end normalized_gcd_monoid
end polynomial


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

! This file was ported from Lean 3 source module ring_theory.rees_algebra
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.FiniteType

/-!

# Rees algebra

The Rees algebra of an ideal `I` is the subalgebra `R[It]` of `R[t]` defined as `R[It] = ⨁ₙ Iⁿ tⁿ`.
This is used to prove the Artin-Rees lemma, and will potentially enable us to calculate some
blowup in the future.

## Main definition

- `rees_algebra` : The Rees algebra of an ideal `I`, defined as a subalgebra of `R[X]`.
- `adjoin_monomial_eq_rees_algebra` : The Rees algebra is generated by the degree one elements.
- `rees_algebra.fg` : The Rees algebra of a f.g. ideal is of finite type. In particular, this
implies that the rees algebra over a noetherian ring is still noetherian.

-/

universe u v

variable {R M : Type u} [CommRing R] [AddCommGroup M] [Module R M] (I : Ideal R)

open Polynomial

open Polynomial BigOperators

/-- The Rees algebra of an ideal `I`, defined as the subalgebra of `R[X]` whose `i`-th coefficient
falls in `I ^ i`. -/
def reesAlgebra : Subalgebra R R[X]
    where
  carrier := { f | ∀ i, f.coeff i ∈ I ^ i }
  mul_mem' f g hf hg i := by
    rw [coeff_mul]
    apply Ideal.sum_mem
    rintro ⟨j, k⟩ e
    rw [← finset.nat.mem_antidiagonal.mp e, pow_add]
    exact Ideal.mul_mem_mul (hf j) (hg k)
  one_mem' i := by
    rw [coeff_one]
    split_ifs
    · subst h
      simp
    · simp
  add_mem' f g hf hg i := by
    rw [coeff_add]
    exact Ideal.add_mem _ (hf i) (hg i)
  zero_mem' i := Ideal.zero_mem _
  algebraMap_mem' r i := by
    rw [algebra_map_apply, coeff_C]
    split_ifs
    · subst h
      simp
    · simp
#align rees_algebra reesAlgebra

theorem mem_reesAlgebra_iff (f : R[X]) : f ∈ reesAlgebra I ↔ ∀ i, f.coeff i ∈ I ^ i :=
  Iff.rfl
#align mem_rees_algebra_iff mem_reesAlgebra_iff

theorem mem_reesAlgebra_iff_support (f : R[X]) :
    f ∈ reesAlgebra I ↔ ∀ i ∈ f.support, f.coeff i ∈ I ^ i :=
  by
  apply forall_congr'
  intro a
  rw [mem_support_iff, Iff.comm, imp_iff_right_iff, Ne.def, ← imp_iff_not_or]
  exact fun e => e.symm ▸ (I ^ a).zero_mem
#align mem_rees_algebra_iff_support mem_reesAlgebra_iff_support

theorem reesAlgebra.monomial_mem {I : Ideal R} {i : ℕ} {r : R} :
    monomial i r ∈ reesAlgebra I ↔ r ∈ I ^ i := by
  simp (config := { contextual := true }) [mem_reesAlgebra_iff_support, coeff_monomial, ←
    imp_iff_not_or]
#align rees_algebra.monomial_mem reesAlgebra.monomial_mem

theorem monomial_mem_adjoin_monomial {I : Ideal R} {n : ℕ} {r : R} (hr : r ∈ I ^ n) :
    monomial n r ∈ Algebra.adjoin R (Submodule.map (monomial 1 : R →ₗ[R] R[X]) I : Set R[X]) :=
  by
  induction' n with n hn generalizing r
  · exact Subalgebra.algebraMap_mem _ _
  · rw [pow_succ] at hr
    apply Submodule.smul_induction_on hr
    · intro r hr s hs
      rw [Nat.succ_eq_one_add, smul_eq_mul, ← monomial_mul_monomial]
      exact Subalgebra.mul_mem _ (Algebra.subset_adjoin (Set.mem_image_of_mem _ hr)) (hn hs)
    · intro x y hx hy
      rw [monomial_add]
      exact Subalgebra.add_mem _ hx hy
#align monomial_mem_adjoin_monomial monomial_mem_adjoin_monomial

theorem adjoin_monomial_eq_reesAlgebra :
    Algebra.adjoin R (Submodule.map (monomial 1 : R →ₗ[R] R[X]) I : Set R[X]) = reesAlgebra I :=
  by
  apply le_antisymm
  · apply Algebra.adjoin_le _
    rintro _ ⟨r, hr, rfl⟩
    exact rees_algebra.monomial_mem.mpr (by rwa [pow_one])
  · intro p hp
    rw [p.as_sum_support]
    apply Subalgebra.sum_mem _ _
    rintro i -
    exact monomial_mem_adjoin_monomial (hp i)
#align adjoin_monomial_eq_rees_algebra adjoin_monomial_eq_reesAlgebra

variable {I}

theorem reesAlgebra.fg (hI : I.Fg) : (reesAlgebra I).Fg := by
  classical
    obtain ⟨s, hs⟩ := hI
    rw [← adjoin_monomial_eq_reesAlgebra, ← hs]
    use s.image (monomial 1)
    rw [Finset.coe_image]
    change
      _ =
        Algebra.adjoin R
          (Submodule.map (monomial 1 : R →ₗ[R] R[X]) (Submodule.span R ↑s) : Set R[X])
    rw [Submodule.map_span, Algebra.adjoin_span]
#align rees_algebra.fg reesAlgebra.fg

instance [IsNoetherianRing R] : Algebra.FiniteType R (reesAlgebra I) :=
  ⟨(reesAlgebra I).fg_top.mpr (reesAlgebra.fg <| IsNoetherian.noetherian I)⟩

instance [IsNoetherianRing R] : IsNoetherianRing (reesAlgebra I) :=
  Algebra.FiniteType.isNoetherianRing R _


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.group_ring_action
import ring_theory.subsemiring.basic

/-! # Pointwise instances on `subsemiring`s

This file provides the action `subsemiring.pointwise_mul_action` which matches the action of
`mul_action_set`.

This actions is available in the `pointwise` locale.

## Implementation notes

This file is almost identical to `group_theory/submonoid/pointwise.lean`. Where possible, try to
keep them in sync.
-/

open set

variables {M R : Type*}

namespace subsemiring

section monoid
variables [monoid M] [semiring R] [mul_semiring_action M R]

/-- The action on a subsemiring corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_mul_action : mul_action M (subsemiring R) :=
{ smul := λ a S, S.map (mul_semiring_action.to_ring_hom _ _ a),
  one_smul := λ S,
    (congr_arg (λ f, S.map f) (ring_hom.ext $ by exact one_smul M)).trans S.map_id,
  mul_smul := λ a₁ a₂ S,
    (congr_arg (λ f, S.map f) (ring_hom.ext $ by exact mul_smul _ _)).trans (S.map_map _ _).symm }

localized "attribute [instance] subsemiring.pointwise_mul_action" in pointwise
open_locale pointwise

lemma pointwise_smul_def {a : M} (S : subsemiring R) :
  a • S = S.map (mul_semiring_action.to_ring_hom _ _ a) := rfl

@[simp] lemma coe_pointwise_smul (m : M) (S : subsemiring R) : ↑(m • S) = m • (S : set R) := rfl

@[simp] lemma pointwise_smul_to_add_submonoid (m : M) (S : subsemiring R) :
  (m • S).to_add_submonoid = m • S.to_add_submonoid := rfl

lemma smul_mem_pointwise_smul (m : M) (r : R) (S : subsemiring R) : r ∈ S → m • r ∈ m • S :=
(set.smul_mem_smul_set : _ → _ ∈ m • (S : set R))

lemma mem_smul_pointwise_iff_exists (m : M) (r : R) (S : subsemiring R) :
  r ∈ m • S ↔ ∃ (s : R), s ∈ S ∧ m • s = r :=
(set.mem_smul_set : r ∈ m • (S : set R) ↔ _)

instance pointwise_central_scalar [mul_semiring_action Mᵐᵒᵖ R] [is_central_scalar M R] :
  is_central_scalar M (subsemiring R) :=
⟨λ a S, congr_arg (λ f, S.map f) $ ring_hom.ext $ by exact op_smul_eq_smul _⟩

end monoid

section group
variables [group M] [semiring R] [mul_semiring_action M R]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff {a : M} {S : subsemiring R} {x : R} :
  a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff

lemma mem_pointwise_smul_iff_inv_smul_mem {a : M} {S : subsemiring R} {x : R} :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem

lemma mem_inv_pointwise_smul_iff {a : M} {S : subsemiring R} {x : R} : x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff

@[simp] lemma pointwise_smul_le_pointwise_smul_iff {a : M} {S T : subsemiring R} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff

lemma pointwise_smul_subset_iff {a : M} {S T : subsemiring R} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff

lemma subset_pointwise_smul_iff {a : M} {S T : subsemiring R} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff

/-! TODO: add `equiv_smul` like we have for subgroup. -/

end group

section group_with_zero
variables [group_with_zero M] [semiring R] [mul_semiring_action M R]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) (S : subsemiring R)
  (x : R) : a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff₀ ha (S : set R) x

lemma mem_pointwise_smul_iff_inv_smul_mem₀ {a : M} (ha : a ≠ 0) (S : subsemiring R) (x : R) :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem₀ ha (S : set R) x

lemma mem_inv_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) (S : subsemiring R) (x : R) :
  x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff₀ ha (S : set R) x

@[simp] lemma pointwise_smul_le_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) {S T : subsemiring R} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff₀ ha

lemma pointwise_smul_le_iff₀ {a : M} (ha : a ≠ 0) {S T : subsemiring R} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff₀ ha

lemma le_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) {S T : subsemiring R} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff₀ ha

end group_with_zero

end subsemiring


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.hom.group
import logic.equiv.defs
import data.finite.defs
/-!
# Type tags that turn additive structures into multiplicative, and vice versa

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

We define two type tags:

* `additive α`: turns any multiplicative structure on `α` into the corresponding
  additive structure on `additive α`;
* `multiplicative α`: turns any additive structure on `α` into the corresponding
  multiplicative structure on `multiplicative α`.

We also define instances `additive.*` and `multiplicative.*` that actually transfer the structures.

## See also

This file is similar to `order.synonym`.
-/

universes u v
variables {α : Type u} {β : Type v}

/-- If `α` carries some multiplicative structure, then `additive α` carries the corresponding
additive structure. -/
def additive (α : Type*) := α
/-- If `α` carries some additive structure, then `multiplicative α` carries the corresponding
multiplicative structure. -/
def multiplicative (α : Type*) := α

namespace additive

/-- Reinterpret `x : α` as an element of `additive α`. -/
def of_mul : α ≃ additive α := ⟨λ x, x, λ x, x, λ x, rfl, λ x, rfl⟩

/-- Reinterpret `x : additive α` as an element of `α`. -/
def to_mul : additive α ≃ α := of_mul.symm

@[simp] lemma of_mul_symm_eq : (@of_mul α).symm = to_mul := rfl

@[simp] lemma to_mul_symm_eq : (@to_mul α).symm = of_mul := rfl

end additive

namespace multiplicative

/-- Reinterpret `x : α` as an element of `multiplicative α`. -/
def of_add : α ≃ multiplicative α := ⟨λ x, x, λ x, x, λ x, rfl, λ x, rfl⟩

/-- Reinterpret `x : multiplicative α` as an element of `α`. -/
def to_add : multiplicative α ≃ α := of_add.symm

@[simp] lemma of_add_symm_eq : (@of_add α).symm = to_add := rfl

@[simp]

end multiplicative

@[simp] lemma to_add_of_add (x : α) : (multiplicative.of_add x).to_add = x := rfl
@[simp] lemma of_add_to_add (x : multiplicative α) : multiplicative.of_add x.to_add = x := rfl

@[simp] lemma to_mul_of_mul (x : α) : (additive.of_mul x).to_mul = x := rfl
@[simp] lemma of_mul_to_mul (x : additive α) : additive.of_mul x.to_mul = x := rfl

instance [inhabited α] : inhabited (additive α) := ⟨additive.of_mul default⟩
instance [inhabited α] : inhabited (multiplicative α) := ⟨multiplicative.of_add default⟩

instance [finite α] : finite (additive α) := finite.of_equiv α (by refl)
instance [finite α] : finite (multiplicative α) := finite.of_equiv α (by refl)

instance [infinite α] : infinite (additive α) := by tauto
instance [infinite α] : infinite (multiplicative α) := by tauto

instance [nontrivial α] : nontrivial (additive α) :=
additive.of_mul.injective.nontrivial

instance [nontrivial α] : nontrivial (multiplicative α) :=
multiplicative.of_add.injective.nontrivial

instance additive.has_add [has_mul α] : has_add (additive α) :=
{ add := λ x y, additive.of_mul (x.to_mul * y.to_mul) }

instance [has_add α] : has_mul (multiplicative α) :=
{ mul := λ x y, multiplicative.of_add (x.to_add + y.to_add) }

@[simp] lemma of_add_add [has_add α] (x y : α) :
  multiplicative.of_add (x + y) = multiplicative.of_add x * multiplicative.of_add y :=
rfl

@[simp] lemma to_add_mul [has_add α] (x y : multiplicative α) :
  (x * y).to_add = x.to_add + y.to_add :=
rfl

@[simp] lemma of_mul_mul [has_mul α] (x y : α) :
  additive.of_mul (x * y) = additive.of_mul x + additive.of_mul y :=
rfl

@[simp] lemma to_mul_add [has_mul α] (x y : additive α) :
  (x + y).to_mul = x.to_mul * y.to_mul :=
rfl

instance [semigroup α] : add_semigroup (additive α) :=
{ add_assoc := @mul_assoc α _,
  ..additive.has_add }

instance [add_semigroup α] : semigroup (multiplicative α) :=
{ mul_assoc := @add_assoc α _,
  ..multiplicative.has_mul }

instance [comm_semigroup α] : add_comm_semigroup (additive α) :=
{ add_comm := @mul_comm _ _,
  ..additive.add_semigroup }

instance [add_comm_semigroup α] : comm_semigroup (multiplicative α) :=
{ mul_comm := @add_comm _ _,
  ..multiplicative.semigroup }

instance [has_mul α] [is_left_cancel_mul α] : is_left_cancel_add (additive α) :=
{ add_left_cancel := @mul_left_cancel α _ _ }

instance [has_add α] [is_left_cancel_add α] : is_left_cancel_mul (multiplicative α) :=
{ mul_left_cancel := @add_left_cancel α _ _ }

instance [has_mul α] [is_right_cancel_mul α] : is_right_cancel_add (additive α) :=
{ add_right_cancel := @mul_right_cancel α _ _ }

instance [has_add α] [is_right_cancel_add α] : is_right_cancel_mul (multiplicative α) :=
{ mul_right_cancel := @add_right_cancel α _ _ }

instance [has_mul α] [is_cancel_mul α] : is_cancel_add (additive α) :=
{ ..additive.is_left_cancel_add, ..additive.is_right_cancel_add }

instance [has_add α] [is_cancel_add α] : is_cancel_mul (multiplicative α) :=
{ ..multiplicative.is_left_cancel_mul, ..multiplicative.is_right_cancel_mul }

instance [left_cancel_semigroup α] : add_left_cancel_semigroup (additive α) :=
{ ..additive.add_semigroup, ..additive.is_left_cancel_add }

instance [add_left_cancel_semigroup α] : left_cancel_semigroup (multiplicative α) :=
{ ..multiplicative.semigroup, ..multiplicative.is_left_cancel_mul }

instance [right_cancel_semigroup α] : add_right_cancel_semigroup (additive α) :=
{ ..additive.add_semigroup, ..additive.is_right_cancel_add }

instance [add_right_cancel_semigroup α] : right_cancel_semigroup (multiplicative α) :=
{ ..multiplicative.semigroup, ..multiplicative.is_right_cancel_mul }

instance [has_one α] : has_zero (additive α) := ⟨additive.of_mul 1⟩

@[simp] lemma of_mul_one [has_one α] : @additive.of_mul α 1 = 0 := rfl

@[simp] lemma of_mul_eq_zero {A : Type*} [has_one A] {x : A} :
  additive.of_mul x = 0 ↔ x = 1 := iff.rfl

@[simp] lemma to_mul_zero [has_one α] : (0 : additive α).to_mul = 1 := rfl

instance [has_zero α] : has_one (multiplicative α) := ⟨multiplicative.of_add 0⟩

@[simp] lemma of_add_zero [has_zero α] : @multiplicative.of_add α 0 = 1 := rfl

@[simp] lemma of_add_eq_one {A : Type*} [has_zero A] {x : A} :
  multiplicative.of_add x = 1 ↔ x = 0 := iff.rfl

@[simp] lemma to_add_one [has_zero α] : (1 : multiplicative α).to_add = 0 := rfl

instance [mul_one_class α] : add_zero_class (additive α) :=
{ zero     := 0,
  add      := (+),
  zero_add := one_mul,
  add_zero := mul_one }

instance [add_zero_class α] : mul_one_class (multiplicative α) :=
{ one     := 1,
  mul     := (*),
  one_mul := zero_add,
  mul_one := add_zero }

instance [h : monoid α] : add_monoid (additive α) :=
{ zero     := 0,
  add      := (+),
  nsmul    := @monoid.npow α h,
  nsmul_zero' := monoid.npow_zero',
  nsmul_succ' := monoid.npow_succ',
  ..additive.add_zero_class,
  ..additive.add_semigroup }

instance [h : add_monoid α] : monoid (multiplicative α) :=
{ one     := 1,
  mul     := (*),
  npow   := @add_monoid.nsmul α h,
  npow_zero' := add_monoid.nsmul_zero',
  npow_succ' := add_monoid.nsmul_succ',
  ..multiplicative.mul_one_class,
  ..multiplicative.semigroup }

instance [left_cancel_monoid α] : add_left_cancel_monoid (additive α) :=
{ zero := 0, add := (+), .. additive.add_monoid, .. additive.add_left_cancel_semigroup }

instance [add_left_cancel_monoid α] : left_cancel_monoid (multiplicative α) :=
{ one := 1, mul := (*), .. multiplicative.monoid, .. multiplicative.left_cancel_semigroup }

instance [right_cancel_monoid α] : add_right_cancel_monoid (additive α) :=
{ zero := 0, add := (+), .. additive.add_monoid, .. additive.add_right_cancel_semigroup }

instance [add_right_cancel_monoid α] : right_cancel_monoid (multiplicative α) :=
{ one := 1, mul := (*), .. multiplicative.monoid, .. multiplicative.right_cancel_semigroup }

instance [comm_monoid α] : add_comm_monoid (additive α) :=
{ zero := 0, add := (+), .. additive.add_monoid, .. additive.add_comm_semigroup }

instance [add_comm_monoid α] : comm_monoid (multiplicative α) :=
{ one := 1, mul := (*), ..multiplicative.monoid, .. multiplicative.comm_semigroup }

instance [has_inv α] : has_neg (additive α) := ⟨λ x, multiplicative.of_add x.to_mul⁻¹⟩

@[simp] lemma of_mul_inv [has_inv α] (x : α) : additive.of_mul x⁻¹ = -(additive.of_mul x) := rfl

@[simp] lemma to_mul_neg [has_inv α] (x : additive α) : (-x).to_mul = x.to_mul⁻¹ := rfl

instance [has_neg α] : has_inv (multiplicative α) := ⟨λ x, additive.of_mul (-x.to_add)⟩

@[simp] lemma of_add_neg [has_neg α] (x : α) :
  multiplicative.of_add (-x) = (multiplicative.of_add x)⁻¹ := rfl

@[simp] lemma to_add_inv [has_neg α] (x : multiplicative α) :
  (x⁻¹).to_add = -x.to_add := rfl

instance additive.has_sub [has_div α] : has_sub (additive α) :=
{ sub := λ x y, additive.of_mul (x.to_mul / y.to_mul) }

instance multiplicative.has_div [has_sub α] : has_div (multiplicative α) :=
{ div := λ x y, multiplicative.of_add (x.to_add - y.to_add) }

@[simp] lemma of_add_sub [has_sub α] (x y : α) :
  multiplicative.of_add (x - y) = multiplicative.of_add x / multiplicative.of_add y :=
rfl

@[simp] lemma to_add_div [has_sub α] (x y : multiplicative α) :
  (x / y).to_add = x.to_add - y.to_add :=
rfl

@[simp] lemma of_mul_div [has_div α] (x y : α) :
  additive.of_mul (x / y) = additive.of_mul x - additive.of_mul y :=
rfl

@[simp] lemma to_mul_sub [has_div α] (x y : additive α) :
  (x - y).to_mul = x.to_mul / y.to_mul :=
rfl

instance [has_involutive_inv α] : has_involutive_neg (additive α) :=
{ neg_neg := @inv_inv _ _,
  ..additive.has_neg }

instance [has_involutive_neg α] : has_involutive_inv (multiplicative α) :=
{ inv_inv := @neg_neg _ _,
  ..multiplicative.has_inv }

instance [div_inv_monoid α] : sub_neg_monoid (additive α) :=
{ sub_eq_add_neg := @div_eq_mul_inv α _,
  zsmul := @div_inv_monoid.zpow α _,
  zsmul_zero' := div_inv_monoid.zpow_zero',
  zsmul_succ' := div_inv_monoid.zpow_succ',
  zsmul_neg' := div_inv_monoid.zpow_neg',
  .. additive.has_neg, .. additive.has_sub, .. additive.add_monoid }

instance [sub_neg_monoid α] : div_inv_monoid (multiplicative α) :=
{ div_eq_mul_inv := @sub_eq_add_neg α _,
  zpow := @sub_neg_monoid.zsmul α _,
  zpow_zero' := sub_neg_monoid.zsmul_zero',
  zpow_succ' := sub_neg_monoid.zsmul_succ',
  zpow_neg' := sub_neg_monoid.zsmul_neg',
  .. multiplicative.has_inv, .. multiplicative.has_div, .. multiplicative.monoid }

instance [division_monoid α] : subtraction_monoid (additive α) :=
{ neg_add_rev := @mul_inv_rev _ _,
  neg_eq_of_add := @inv_eq_of_mul_eq_one_right _ _,
  .. additive.sub_neg_monoid, .. additive.has_involutive_neg }

instance [subtraction_monoid α] : division_monoid (multiplicative α) :=
{ mul_inv_rev := @neg_add_rev _ _,
  inv_eq_of_mul := @neg_eq_of_add_eq_zero_right _ _,
  .. multiplicative.div_inv_monoid, .. multiplicative.has_involutive_inv }

instance [division_comm_monoid α] : subtraction_comm_monoid (additive α) :=
{ .. additive.subtraction_monoid, .. additive.add_comm_semigroup }

instance [subtraction_comm_monoid α] : division_comm_monoid (multiplicative α) :=
{ .. multiplicative.division_monoid, .. multiplicative.comm_semigroup }

instance [group α] : add_group (additive α) :=
{ add_left_neg := @mul_left_inv α _,
  .. additive.sub_neg_monoid }

instance [add_group α] : group (multiplicative α) :=
{ mul_left_inv := @add_left_neg α _,
  .. multiplicative.div_inv_monoid }

instance [comm_group α] : add_comm_group (additive α) :=
{ .. additive.add_group, .. additive.add_comm_monoid }

instance [add_comm_group α] : comm_group (multiplicative α) :=
{ .. multiplicative.group, .. multiplicative.comm_monoid }

open multiplicative (of_add)
open additive (of_mul)

/-- Reinterpret `α →+ β` as `multiplicative α →* multiplicative β`. -/
@[simps] def add_monoid_hom.to_multiplicative [add_zero_class α] [add_zero_class β] :
  (α →+ β) ≃ (multiplicative α →* multiplicative β) :=
{ to_fun := λ f, ⟨λ a, of_add (f a.to_add), f.2, f.3⟩,
  inv_fun := λ f, ⟨λ a, (f (of_add a)).to_add, f.2, f.3⟩,
  left_inv := λ x, by { ext, refl, },
  right_inv := λ x, by { ext, refl, } }

/-- Reinterpret `α →* β` as `additive α →+ additive β`. -/
@[simps] def monoid_hom.to_additive [mul_one_class α] [mul_one_class β] :
  (α →* β) ≃ (additive α →+ additive β) :=
{ to_fun := λ f, ⟨λ a, of_mul (f a.to_mul), f.2, f.3⟩,
  inv_fun := λ f, ⟨λ a, (f (of_mul a)).to_mul, f.2, f.3⟩,
  left_inv := λ x, by { ext, refl, },
  right_inv := λ x, by { ext, refl, } }

/-- Reinterpret `additive α →+ β` as `α →* multiplicative β`. -/
@[simps] def add_monoid_hom.to_multiplicative' [mul_one_class α] [add_zero_class β] :
  (additive α →+ β) ≃ (α →* multiplicative β) :=
{ to_fun := λ f, ⟨λ a, of_add (f (of_mul a)), f.2, f.3⟩,
  inv_fun := λ f, ⟨λ a, (f a.to_mul).to_add, f.2, f.3⟩,
  left_inv := λ x, by { ext, refl, },
  right_inv := λ x, by { ext, refl, } }

/-- Reinterpret `α →* multiplicative β` as `additive α →+ β`. -/
@[simps] def monoid_hom.to_additive' [mul_one_class α] [add_zero_class β] :
  (α →* multiplicative β) ≃ (additive α →+ β) :=
add_monoid_hom.to_multiplicative'.symm

/-- Reinterpret `α →+ additive β` as `multiplicative α →* β`. -/
@[simps] def add_monoid_hom.to_multiplicative'' [add_zero_class α] [mul_one_class β] :
  (α →+ additive β) ≃ (multiplicative α →* β) :=
{ to_fun := λ f, ⟨λ a, (f a.to_add).to_mul, f.2, f.3⟩,
  inv_fun := λ f, ⟨λ a, of_mul (f (of_add a)), f.2, f.3⟩,
  left_inv := λ x, by { ext, refl, },
  right_inv := λ x, by { ext, refl, } }

/-- Reinterpret `multiplicative α →* β` as `α →+ additive β`. -/
@[simps] def monoid_hom.to_additive'' [add_zero_class α] [mul_one_class β] :
  (multiplicative α →* β) ≃ (α →+ additive β) :=
add_monoid_hom.to_multiplicative''.symm

/-- If `α` has some multiplicative structure and coerces to a function,
then `additive α` should also coerce to the same function.

This allows `additive` to be used on bundled function types with a multiplicative structure, which
is often used for composition, without affecting the behavior of the function itself.
-/
instance additive.has_coe_to_fun {α : Type*} {β : α → Sort*} [has_coe_to_fun α β] :
  has_coe_to_fun (additive α) (λ a, β a.to_mul) :=
⟨λ a, coe_fn a.to_mul⟩

/-- If `α` has some additive structure and coerces to a function,
then `multiplicative α` should also coerce to the same function.

This allows `multiplicative` to be used on bundled function types with an additive structure, which
is often used for composition, without affecting the behavior of the function itself.
-/
instance multiplicative.has_coe_to_fun {α : Type*} {β : α → Sort*} [has_coe_to_fun α β] :
  has_coe_to_fun (multiplicative α) (λ a, β a.to_add) :=
⟨λ a, coe_fn a.to_add⟩


import data.pnat.basic data.nat.periodic

/-! # IMO 2009 A3 (P5) -/

namespace IMOSL
namespace IMO2009A3

open function

section extra_lemmas

private lemma exists_sup_fn_fin (f : ℕ → ℕ) (c : ℕ) : ∃ K : ℕ, ∀ n : ℕ, n < c → f n ≤ K :=
begin
  induction c with c h,
  exact ⟨0, λ n h, by exfalso; exact nat.not_lt_zero n h⟩,
  cases h with K h,
  refine ⟨max K (f c), λ n h0, _⟩,
  rw [nat.lt_succ_iff, le_iff_eq_or_lt] at h0,
  rcases h0 with rfl | h0,
  exacts [le_max_right K (f n), le_trans (h n h0) (le_max_left K (f c))]
end

private lemma pnat_to_nat_prop {P : ℕ+ → Prop} : (∀ n : ℕ+, P n) ↔ (∀ n : ℕ, P n.succ_pnat) :=
  ⟨λ h n, h n.succ_pnat, λ h n, by rw ← pnat.succ_pnat_nat_pred n; exact h _⟩

private lemma pnat_to_nat_prop2 {P : ℕ+ → ℕ+ → Prop} :
  (∀ m n : ℕ+, P m n) ↔ (∀ m n : ℕ, P m.succ_pnat n.succ_pnat) :=
  by rw pnat_to_nat_prop; refine forall_congr (λ m, _); rw pnat_to_nat_prop

private lemma succ_pnat_add_succ_pnat (m n : ℕ) :
  m.succ_pnat + n.succ_pnat = (m + n).succ_pnat + 1 :=
  by rw [← pnat.coe_inj, pnat.add_coe, pnat.add_coe, nat.succ_pnat_coe, nat.succ_pnat_coe,
         nat.succ_pnat_coe, nat.add_succ, nat.succ_add, positive.coe_one]

private lemma pnat_add_sub_cancel (m n : ℕ+) : m + n - n = m :=
  by rw [← add_right_inj n, pnat.add_sub_of_lt (n.lt_add_left m), add_comm]

end extra_lemmas

/-- Final solution, `nat` version -/
theorem final_solution_nat (f : ℕ → ℕ) :
  ((∀ x y : ℕ, f (y + f x) ≤ f y + x)
    ∧ (∀ x y : ℕ, x ≤ f y + f (y + f x))
    ∧ (∀ x y : ℕ, f y ≤ f (y + f x) + x))
      ↔ f = λ x, x :=
begin
  ---- First, the easier direction: `←`
  symmetry; split,
  { rintros rfl,
    refine ⟨λ x y, by rw add_comm, λ x y, _, λ x y, _⟩,
    rw ← add_assoc; exact le_add_self,
    rw add_assoc; exact le_self_add },

  ---- For the harder case, first prove that `f(0) = 0`
  rintros ⟨h, h0, h1⟩,
  replace h1 : f 0 = 0 :=
  begin
    contrapose! h0; rw ← zero_lt_iff at h0,
    obtain ⟨K, h2⟩ := exists_sup_fn_fin f (f 0),
    refine ⟨K + K + 1, 0, nat.lt_succ_of_le (add_le_add (h2 0 h0) _)⟩,
    rw [zero_add, ← periodic.map_mod_nat (λ y, le_antisymm (h 0 y) (h1 0 y))],
    exact h2 _ (nat.mod_lt (f (K + K + 1)) h0)
  end,

  ---- Now get `f(f(x)) = x` for all `x`
  replace h0 : ∀ x : ℕ, f (f x) = x :=
  begin
    intros x; apply le_antisymm,
    replace h := h x 0,
    rwa [h1, zero_add, zero_add] at h,
    replace h0 := h0 x 0,
    rwa [h1, zero_add, zero_add] at h0
  end,

  ---- Get `f(x + f(1)) ≤ f(x) + 1` and then `f(1) = 1`
  replace h := h 1,
  have h2 : f 1 = 1 :=
  begin
    suffices : ∀ n : ℕ, f (n * f 1) = n,
      replace this := congr_arg f (this (f 1));
        rwa [h0, h0, nat.mul_eq_one_iff, and_self] at this,
    intros n; induction n using nat.strong_induction_on with n n_ih; cases n,
    rw [zero_mul, h1],
    replace h := h (n * f 1),
    rw [n_ih n n.lt_succ_self, ← add_one_mul, le_iff_eq_or_lt, nat.lt_succ_iff] at h,
    revert h; refine (or_iff_left_of_imp (λ h, _)).mp,
    replace n_ih := congr_arg f (n_ih _ (lt_of_le_of_lt h n.lt_succ_self)),
    rw [h0, h0, mul_eq_mul_right_iff] at n_ih,
    revert n_ih; refine (or_iff_left _).mp,
    rw ← h1; apply_fun f,
    rw [h0, h0]; exact one_ne_zero
  end,

  ---- Finish
  funext x; induction x using nat.strong_induction_on with x x_ih; cases x,
  exact h1,
  replace h := h x,
  rw [h2, x_ih x x.lt_succ_self, le_iff_eq_or_lt, nat.lt_succ_iff] at h,
  revert h; refine (or_iff_left_of_imp (λ h, _)).mp,
  replace x_ih := congr_arg f (x_ih _ (lt_of_le_of_lt h x.lt_succ_self)),
  rwa [h0, h0] at x_ih
end

/-- Final solution, `pnat` version -/
theorem final_solution_pnat (f : ℕ+ → ℕ+) :
  ((∀ x y : ℕ+, f (y + f x - 1) < f y + x)
    ∧ (∀ x y : ℕ+, x < f y + f (y + f x - 1))
    ∧ (∀ x y : ℕ+, f y < f (y + f x - 1) + x))
      ↔ f = λ x, x :=
begin
  obtain ⟨g, rfl⟩ : ∃ g : ℕ → ℕ, f = λ x, (g x.nat_pred).succ_pnat :=
    ⟨λ x, (f x.succ_pnat).nat_pred,
      funext (λ x, by rw [pnat.succ_pnat_nat_pred, pnat.succ_pnat_nat_pred])⟩,
  simp_rw [pnat_to_nat_prop2, funext_iff, pnat_to_nat_prop, nat.nat_pred_succ_pnat,
           nat.succ_pnat_inj, ← funext_iff, succ_pnat_add_succ_pnat, pnat_add_sub_cancel,
           nat.nat_pred_succ_pnat, pnat.lt_add_one_iff, nat.succ_pnat_le_succ_pnat],
  exact final_solution_nat g
end

end IMO2009A3
end IMOSL