-- Presentation aimed for March 4, 2020
-- (prime p = 4k+1 is sum of two squares)

-- Must arrive at 10:00, MIT Lab on that day.

-- https://github.com/leanprover-community/mathlib/blob/master/docs/install/windows.md

import tactic
import algebra.group_power
import data.int.basic
--import data.zmod.quadratic_reciprocity
universe u
local attribute [instance] classical.prop_decidable

def ex1 (x y z : ℕ) : ℕ := x + y * z

def even (n : ℕ) : Prop := ∃ k, n = 2*k
def odd (n : ℕ) : Prop := ∃ k, n = 2*k+1

lemma even_or_odd (n : ℕ) : or (even n) (odd n) :=
begin
induction n with d hd,
left,
rw even,
use 0,
simp,
cases hd with p q,
rw even at p,
cases p with k p,
right,
rw odd,
use k,
rw p,
rw odd at q,
cases q with k q,
left,
rw even,
use k+1,
rw mul_add,
rw q,
refl,
end

lemma not_both_even_odd (n : ℕ) : ¬((even n) ∧ (odd n)) :=
begin
by_cases h : (even n) ∧ (odd n),
exfalso,
cases h with h1 h2,
rw even at h1,
cases h1 with k h1k,
rw odd at h2,
cases h2 with k' h2k,
rw h1k at h2k,
have hk := nat.mul_mod_right 2 k,
rw h2k at hk,
rw add_comm at hk,
have hk1 := nat.add_mul_mod_self_left 1 2 k',
have one_lt_two : 1 < 2 := by {exact nat.lt_succ_self 1},
have one_mod_two_is_one := nat.mod_eq_of_lt one_lt_two,
rw one_mod_two_is_one at hk1,
rw hk at hk1,
have zero_lt_one : 0 < 1 := by exact nat.lt_succ_self 0,
rw hk1 at zero_lt_one,
exact lt_irrefl 1 zero_lt_one,
exact h,
end

lemma even_plus_even_is_even (n m : ℕ) (h : and (even n) (even m)) : even (n+m) :=
begin
cases h with p q,
rw even at p,
cases p with k p,
rw even at q,
cases q with l q,
rw even,
use k+l,
rw mul_add,
rw p,
rw q,
end

lemma even_plus_odd_is_odd (n m : ℕ) (h : and (even n) (odd m)) : odd (n+m) :=
begin
cases h with p q,
rw even at p,
cases p with k p,
rw odd at q,
cases q with l q,
rw odd,
use k+l,
rw mul_add,
rw p,
rw q,
ring,
end

lemma odd_plus_even_is_odd (n m : ℕ) (h : and (odd n) (even m)) : odd (n+m) :=
begin
rw and_comm at h,
rw add_comm,
apply even_plus_odd_is_odd,
exact h,
end

lemma odd_plus_odd_is_even (n m : ℕ) (h : and (odd n) (odd m)) : even (n+m) :=
begin
cases h with p q,
rw odd at p,
cases p with k p,
rw odd at q,
cases q with l q,
rw even,
use k+l+1,
rw p,
rw q,
rw mul_add,
rw mul_add,
ring,
end

lemma even_minus_even_is_even (n m : ℕ) (h : (even n) ∧ (even m) ∧ (m ≤ n))
  : even (n - m) :=
begin
cases h with h1 h2,
cases h2 with h3 h4,
have deo := even_or_odd (n-m),
cases deo with deven dodd,
exact deven,
exfalso,
have sum := odd_plus_even_is_odd (n-m) m ⟨dodd, h3⟩,
have claim : n - m + m = n,
have summ := nat.le.dest h4,
cases summ with smd summ',
rw add_comm at summ',
rw (eq.symm summ'),
rw nat.add_sub_cancel,
rw claim at sum,
exact not_both_even_odd n ⟨h1, sum⟩,
end

lemma odd_minus_odd_is_even (n m : ℕ) (h : (odd n) ∧ (odd m) ∧ (m ≤ n))
  : even (n - m) :=
begin
cases h with h1 h2,
cases h2 with h3 h4,
have deo := even_or_odd (n-m),
cases deo with deven dodd,
exact deven,
exfalso,
have sum := odd_plus_odd_is_even (n-m) m ⟨dodd, h3⟩,
have claim : n - m + m = n,
have summ := nat.le.dest h4,
cases summ with smd summ',
rw add_comm at summ',
rw (eq.symm summ'),
rw nat.add_sub_cancel,
rw claim at sum,
exact not_both_even_odd n ⟨sum, h1⟩,
end

lemma even_times_nat_is_even (n m : ℕ) (h : even n) : even (n*m) :=
begin
rw even,
rw even at h,
cases h with p kp,
use m*p,
rw kp,
ring,
end

lemma nat_times_even_is_even (n m : ℕ) (h : even m) : even (n*m) :=
begin
rw mul_comm,
apply even_times_nat_is_even,
exact h,
end

lemma odd_times_odd_is_odd (n m : ℕ) (h : and (odd n) (odd m)) : odd (n*m) :=
begin
rw odd,
cases h with h1 h2,
rw odd at h1,
cases h1 with p kp,
rw odd at h2,
cases h2 with q kq,
use 2*p*q + p + q,
rw kp,
rw kq,
ring,
end

lemma even_square_is_even (n : ℕ) (h : even n) : even (n^2) :=
begin
rw nat.pow_two,
exact nat_times_even_is_even n n h,
end

lemma odd_square_is_odd (n : ℕ) (h : odd n) : odd (n^2) :=
begin
rw nat.pow_two,
exact odd_times_odd_is_odd n n ⟨h, h⟩,
end

lemma not_and_eq_or_not (p q : Prop) : ¬(p ∧ q) ↔ ¬p ∨ ¬q :=
begin
split,
intro f,
 by_cases hp : p,
  { by_cases hq : q,
    { exact (f ⟨hp, hq⟩).elim, },
    exact or.inr hq, },
  { exact or.inl hp, },
intro g,
cases g with g1 g2,
by_cases h : p ∧ q,
exfalso,
cases h with h1 h2,
exact g1(h1),
exact h,
by_cases h : p ∧ q,
exfalso,
cases h with h1 h2,
exact g2(h2),
exact h,
end

lemma not_or_eq_and_not (p q : Prop) : ¬(p ∨ q) ↔ ¬p ∧ ¬q :=
begin
split,
intro f,
by_cases hp : p,
have i := or.intro_left q hp,
exfalso,
exact f(i),
by_cases hq : q,
have i := or.intro_right p hq,
exfalso,
exact f(i),
exact ⟨hp, hq⟩,
intro f,
cases f with f1 f2,
by_cases h : p ∨ q,
cases h with h1 h2,
exfalso,
exact f1(h1),
exfalso,
exact f2(h2),
exact h,
end

lemma pos_or_zero (n : ℕ) : 0 < n ∨ n = 0 :=
begin
have tri := lt_trichotomy 0 n,
cases tri with tri1 tri2,
left,
exact tri1,
cases tri2 with tri3 tri4,
right,
exact (eq.symm tri3),
exfalso,
have nng := zero_le n,
have lt1 := lt_of_le_of_lt nng tri4,
exact lt_irrefl 0 lt1,
end

lemma mul_cancel (a b c : ℕ) (h : a*b = a*c) (p : 0 < a) : b = c :=
begin
have ltr := lt_trichotomy b c,
cases ltr with ltr' ltr1,
exfalso,
have thing := mul_lt_mul_of_pos_left ltr' p,
rw h at thing,
exact lt_irrefl (a*c) thing,
cases ltr1 with ltr2 ltr3,
exact ltr2,
exfalso,
have thing := mul_lt_mul_of_pos_left ltr3 p,
rw h at thing,
exact lt_irrefl (a*c) thing,
end

lemma int_mul_cancel (a b c : ℤ) (h : a*b = a*c) (p : 0 < a) : b = c :=
begin
have ltr := lt_trichotomy b c,
cases ltr with ltr' ltr1,
exfalso,
have thing := mul_lt_mul_of_pos_left ltr' p,
rw h at thing,
exact lt_irrefl (a*c) thing,
cases ltr1 with ltr2 ltr3,
exact ltr2,
exfalso,
have thing := mul_lt_mul_of_pos_left ltr3 p,
rw h at thing,
exact lt_irrefl (a*c) thing,
end

lemma int_mul_cancel_lt (a b c : ℤ) (h : a*b < a*c) (p : 0 < a) : b < c :=
begin
have ltr := lt_trichotomy b c,
cases ltr with ltr' ltr1,
exact ltr',
exfalso,
cases ltr1 with ltr2 ltr3,
rw ltr2 at h,
exact lt_irrefl (a*c) h,
have th := mul_lt_mul_of_pos_left ltr3 p,
exact lt_irrefl (a*b) (lt_trans h th),
end

-- I imagine that those will be important.  Now for the real deal.

def divides (n m : ℕ) : Prop := ∃ k, n*k = m
def prime' (p : ℕ) : Prop := 1 < p ∧ (∀ k, (divides k p → (k = 1 ∨ k = p)))

lemma square_eq_times_itself (a : ℤ) : a^2 = a*a :=
begin
rw pow_succ,
rw pow_succ,
rw pow_zero,
rw mul_one,
end

lemma square_eq_sq_of_nat (a : ℤ) : ∃(n:ℕ),(a^2=(n:ℤ)^2) :=
begin
have ltr := lt_trichotomy 0 a,
cases ltr with ltr1 ltr',
have thing := int.eq_coe_of_zero_le (le_of_lt ltr1),
cases thing with n th',
use n,
rw th',
cases ltr' with ltr2 ltr3,
use 0,
rw (eq.symm ltr2),
ring,
have th := int.add_lt_add_left ltr3 (-a),
rw add_zero at th,
have fill_in_hole : -a+a=0 := by ring,
rw fill_in_hole at th,
have thing := int.eq_coe_of_zero_le (le_of_lt th),
cases thing with n th',
use n,
rw (eq.symm th'),
ring,
end

lemma nonzero_square_pos (a : ℤ) (h : 0 ≠ a) : 0 < a^2 :=
begin
by_cases p : 0 < a,
rw square_eq_times_itself,
rw [←( int.mul_zero a)],
exact mul_lt_mul_of_pos_left p p,
have q := lt_trichotomy 0 a,
cases q,
exfalso,
apply p,
exact q,
cases q,
exfalso,
apply h,
exact q,
rw square_eq_times_itself,
rw [←( int.mul_zero a)],
exact mul_lt_mul_of_neg_left q q,
end

lemma square_nonneg (a : ℤ) : 0 <= a^2 :=
begin
by_cases p : a = 0,
rw p,
refl,
apply le_of_lt,
apply nonzero_square_pos,
by_cases q : 0 = a,
have r := eq.symm q,
exfalso,
apply p,
exact r,
exact q,
end

lemma LCex (a p : ℕ) (hp : 0 < p) :
  ∃(d:ℕ), 0 < d ∧ (∃(x:ℤ), (∃(y:ℤ), (x*a + y*p = d))) :=
begin
use (a*↑a+p*↑p),
split,
have q := square_nonneg(↑a),
rw square_eq_times_itself at q,
have s := nonzero_square_pos(↑p),
norm_cast,
rw square_eq_times_itself at s,
norm_cast at s,
norm_cast at q,
by_cases pz : 0 = p,
rw pz at hp,
have ir := gt_irrefl p,
exfalso,
apply ir,
exact hp,
have r1 := s(pz),
have ala := add_lt_add_left r1 (a*a),
rw add_zero at ala,
exact lt_of_le_of_lt q ala,
norm_cast,
use a,
use p,
norm_cast,
end

lemma div_alg (a b : ℕ) (hp : 0 < b) : ∃(r q : ℕ), (a = b*q+r ∧ r < b) :=
begin
induction a with d hd,
use 0,
use 0,
split,
ring,
exact hp,
cases hd with r rh,
cases rh with q qh,
cases qh with qh1 qh2,
by_cases p : nat.succ r = b,
use 0,
use q+1,
rw qh1,
split,
have p1 := eq.symm p,
rw p1,
ring,
exact hp,
have qh3 := nat.succ_le_of_lt qh2,
have tri := lt_trichotomy (nat.succ r) b,
cases tri with tri1 tri2,
use nat.succ r,
use q,rw qh1,
rw nat.add_succ,
split,
refl,
exact tri1,
cases tri2 with tri3 tri4,
exfalso,
apply p,
exact tri3,
exfalso,
have i := nat.lt_of_le_of_lt qh3 tri4,
have ir := lt_irrefl (nat.succ r),
apply ir,
exact i,
end

lemma div_alg_near_zero (a b : ℕ) (b_pos : 0 < b) (ho : odd b) :
  ∃(q:ℤ), ∃(r:ℤ), ((a:ℤ) = b*q+r ∧ 2*r < b ∧ -2*r < b) :=
begin
have div := div_alg a b b_pos,
cases div with r divr,
cases divr with q divq,
have tri := lt_trichotomy (2*r) b,
cases tri with tri1 tri2,
use q,
use r,
cases divq with divq1 divq2,
split,
norm_cast,
exact divq1,
split,
norm_cast,
exact tri1,
have claim : (-2:ℤ)*r ≤ 0,
have thing := zero_le (2*r),
have thing2 : (0 ≤ 2 * (r : ℤ)) :=
  by { norm_cast, exact thing },
have st := add_le_add_left thing2 ((-2:ℤ)*r),
rw add_zero at st,
have claim1 : (-2:ℤ) * ↑r + 2 * ↑r = 0 := by ring,
rw claim1 at st,
exact st,
have b_pos_int : (0 < (b:ℤ)) := by {norm_cast, exact b_pos},
exact lt_of_le_of_lt claim b_pos_int,
cases tri2 with tri3 tri4,
exfalso,
have claim : even b := by {rw even, use r, exact (eq.symm tri3)},
have not_both := not_both_even_odd b,
exact not_both ⟨claim, ho⟩,
use q+1,
use r-b,
cases divq with divq1 divq2,
split,
rw divq1,
push_cast,
ring,
split,
have claim : 0 < (b:ℤ) := by {norm_cast, exact b_pos},
have claim2 : (r:ℤ) < (b:ℤ) := by {norm_cast, exact divq2},
have st := add_lt_add_left claim2 (-b:ℤ),
have claim3 : -(b:ℤ) + (r:ℤ) = (r:ℤ) - (b:ℤ) := by {ring},
rw claim3 at st,
have fillinhole : -(b:ℤ) + (b:ℤ) = 0 := by {ring},
rw fillinhole at st,
have st' := mul_lt_mul_of_pos_left st (lt_trans zero_lt_one one_lt_two),
rw mul_zero at st',
exact (lt_trans st' claim),
have claim : (b:ℤ) < 2*(r:ℤ) := by {norm_cast, exact tri4},
have st := add_lt_add_left claim (b - 2*(r:ℤ)),
have claim2 : (b:ℤ) - 2*(r:ℤ) + b = (-(2:ℤ))*(r-(b:ℤ)) := by {ring},
rw claim2 at st,
have claim3 : (b:ℤ) - 2*(r:ℤ) + 2*r = b := by {ring},
rw claim3 at st,
exact st,
end

lemma abs_thing (a b : ℤ) (h1 : a < b) (h2 : -a < b) : a^2 < b^2 :=
begin
have h1' := add_lt_add_right h1 (-a),
have f1 : a + (-a) = 0 := by ring,
rw f1 at h1',
have h2' := add_lt_add_right h2 a,
have f2 : (-a) + a = 0 := by ring,
rw f2 at h2',
have thing : 0 < (b+a)*(b+(-a)) := by {exact mul_pos' h2' h1'},
have soandso : (b+a)*(b+(-a)) = b^2-a^2 := by ring,
rw soandso at thing,
have res := add_lt_add_right thing (a^2),
rw zero_add at res,
have th' : b^2-a^2+a^2 = b^2 := by ring,
rw th' at res,
exact res,
end

def isLC (a p d : ℕ) : Prop := 0 < d ∧ (∃(x:ℤ), (∃(y:ℤ), (x*a + y*p = d)))

-- The following lemmas show that the *smallest* positive integer linear
-- combination of a and b is a common divisor of a and b.

lemma bezout (a b d : ℕ) (h_pos : 0 < d)
  (h1 : ∃(x:ℤ), (∃(y:ℤ), (x*a + y*b = d)))
  (h2 : ∀(d':ℕ), (0 < d' ∧ ∃(x:ℤ), (∃(y:ℤ), (x*a + y*b = d'))) → d ≤ d') :
  divides d a :=
begin
have r1 := div_alg a d h_pos,
cases r1 with r hr,
cases hr with q hq,
cases hq with hq1 hq2,
have htr := pos_or_zero r,
cases htr with htr1 htr2,
exfalso,
have claim1 : (a:ℤ)-d*q = r,
rw hq1,
push_cast,
ring,
cases h1 with x_ex hx,
cases hx with y_ex hy,
have claim2 : (1-x_ex*q)*a + (-y_ex*q)*b = r,
rw (eq.symm claim1),
rw (eq.symm hy),
ring,
have thing := h2(r),
have EG : ∃ (x y : ℤ), x * ↑a + y * ↑b = ↑r,
use (1 - x_ex * q),
use (-y_ex * q),
exact claim2,
have concl := thing(⟨htr1, EG⟩),
have ir1 := lt_of_le_of_lt concl hq2,
have ir2 := lt_irrefl d,
exact ir2(ir1),
rw htr2 at hq1,
rw add_zero at hq1,
rw divides,
use q,
rw hq1,
end

-- The above shows that d divides a.
-- Now we apply it to show d divides both of them, without
-- rewriting the entire argument.

lemma bezout_doub (a b d : ℕ) (h_pos : 0 < d)
  (h1 : ∃(x:ℤ), (∃(y:ℤ), (x*a + y*b = d)))
  (h2 : ∀(d':ℕ), (0 < d' ∧ ∃(x:ℤ), (∃(y:ℤ), (x*a + y*b = d'))) → d ≤ d') :
  divides d a ∧ divides d b :=
begin
split,
exact bezout a b d h_pos h1 h2,
have h1_swap : ∃ (x y : ℤ), x * b + y * a = d,
cases h1 with xex h1a,
cases h1a with yex h1b,
use yex,
use xex,
rw (eq.symm h1b),
rw add_comm,
have h2_swap : ∀ (d' : ℕ), (0 < d' ∧ ∃ (x y : ℤ), x * b + y * a = d') → d ≤ d',
intro d',
intro f,
cases f with f1 f2,
have f2_swap : ∃ (x y : ℤ), x * a + y * b = d',
cases f2 with xex f2a,
cases f2a with yex f2b,
use yex,
use xex,
rw (eq.symm f2b),
rw add_comm,
have thing := h2(d'),
exact thing(⟨f1, f2_swap⟩),
exact bezout b a d h_pos h1_swap h2_swap,
end

lemma bezout1 (a p : ℕ) (hp : prime' p) (ha : ¬(divides p a)) :
  ∃(x:ℤ), (∃(y:ℤ), (x*a + y*p = 1)) :=
begin
rw prime' at hp,
cases hp with hp1 hp2,
have zero_lt_one := nat.lt_succ_self 0,
have p_pos := lt_trans zero_lt_one hp1,
have dh : ∃ (d : ℕ), 0 < d ∧ ∃ (x y : ℤ), x * ↑a + y * ↑p = ↑d := LCex a p p_pos,
let d := nat.find(dh),
have dx : 0 < d ∧ ∃ (x y : ℤ), x * ↑a + y * ↑p = ↑d := nat.find_spec dh,
have dm : ∀ d', (0 < d' ∧ ∃ (x y : ℤ), x * ↑a + y * ↑p = ↑d') → d ≤ d' := λ d', nat.find_min' dh,
cases dx with d_pos dx2,
have dividing := bezout_doub a p d d_pos dx2 dm,
cases dividing with div1 div2,
have concl := hp2(d)(div2),
cases concl with c1 c2,
cases dx2 with xex dx3,
cases dx3 with yex dx4,
use xex,
use yex,
rw c1 at dx4,
norm_cast at dx4,
exact dx4,
exfalso,
rw c2 at div1,
exact ha(div1),
end

lemma neg_one_is_square (p : ℕ) (hp : prime' p) (hm : divides 4 (p-1)) :
  ∃ x, (0 < x ∧ x < p ∧ divides p (x^2+1)) :=
begin
sorry -- when I tried to import quadratic_reciprocity, memory was overloaded
end

lemma nat_square_sep (a b : ℕ) (a_pos : 0 < a) (bound : a < b) : a^2 + 1 < b^2 :=
begin
have b_pos := lt_trans a_pos bound,
have st1 := nat.mul_lt_mul_of_pos_right bound b_pos,
have st2 := nat.mul_lt_mul_of_pos_left bound a_pos,
have st2' := nat.succ_le_of_lt st2,
have res := lt_of_le_of_lt st2' st1,
rw nat.pow_two,
rw nat.pow_two,
exact res,
end

theorem mult_sum_of_two_squares (p : ℕ) (hp : prime' p) (hm : divides 4 (p-1)) :
  ∃ m, (0 < m ∧ m < p ∧ ∃ x, ∃ y, m*p = x^2+y^2) :=
begin
have q := neg_one_is_square p hp hm,
cases q with a ka,
rw divides at ka,
cases ka with a_pos ka1,
cases ka1 with a_bound ka2,
cases ka2 with n kb,
use n,
split,
have zero_lt_one := nat.lt_succ_self 0,
have posmul := nat.mul_lt_mul_of_pos_left a_pos a_pos,
rw mul_zero at posmul,
have summing := add_lt_add_right posmul 1,
rw zero_add at summing,
have res := lt_trans zero_lt_one summing,
rw nat.pow_two at kb,
rw (eq.symm kb) at res,
have n_pos_zero := pos_or_zero n,
cases n_pos_zero with n_pos n_zero,
exact n_pos,
exfalso,
rw n_zero at res,
rw mul_zero at res,
exact lt_irrefl 0 res,
split,
have st := nat_square_sep a p a_pos a_bound,
rw (eq.symm kb) at st,
rw nat.pow_two at st,
have tri := lt_trichotomy p n,
cases tri with tri1 tri2,
exfalso,
have tri1a := nat.mul_lt_mul_of_pos_left tri1 (lt.trans a_pos a_bound),
have tri1b := lt.trans st tri1a,
exact lt_irrefl (p*n) tri1b,
cases tri2 with tri3 tri4,
exfalso,
rw tri3 at st,
exact lt_irrefl (n*n) st,
exact tri4,
use a,
use 1,
rw mul_comm,
rw kb,
ring,
end

lemma prelim (x y : ℕ) (h : x < y) :
  2 * (x ^ 2 + y ^ 2) = (y + x) ^ 2 + (y - x) ^ 2 :=
begin
apply int.coe_nat_inj,
push_cast,
rw int.coe_nat_sub (le_of_lt h),
ring,
simp,
end

lemma halving_first (n x y : ℕ) (h : x < y) (h1 : 2*n = x^2 + y^2) :
  ∃a:ℕ, ∃b:ℕ, n = a^2 + b^2 :=
begin
have zero_lt_two := lt_trans (nat.lt_succ_self 0) (nat.lt_succ_self 1),
have xeo := even_or_odd x,
have yeo := even_or_odd y,
cases xeo with x_even x_odd,
cases yeo with y_even y_odd,
have sum_even := even_plus_even_is_even y x ⟨y_even, x_even⟩,
have diff_even := even_minus_even_is_even y x ⟨y_even, x_even, le_of_lt h⟩,
rw even at sum_even,
cases sum_even with sum' sum_ev,
rw even at diff_even,
cases diff_even with diff' diff_ev,
use sum',
use diff',
have claim : 2*n = 2*(sum'^2 + diff'^2),
rw h1,
have claim' : 2*(x^2+y^2) = 4*(sum'^2+diff'^2),
have thing : 4*(sum'^2+diff'^2) = (2*sum')^2+(2*diff')^2 := by ring,
rw thing,
rw (eq.symm sum_ev),
rw (eq.symm diff_ev),
exact prelim x y h,
have thing : 4*(sum'^2+diff'^2) = 2*(2*(sum'^2+diff'^2)) := by ring,
rw thing at claim',
exact mul_cancel 2 (x^2+y^2) (2*(sum'^2+diff'^2)) claim' zero_lt_two,
exact mul_cancel 2 n (sum'^2+diff'^2) claim zero_lt_two,

exfalso,
have xsq_even := even_times_nat_is_even x x x_even,
have ysq_odd := odd_times_odd_is_odd y y ⟨y_odd, y_odd⟩,
have sum_odd := even_plus_odd_is_odd (x*x) (y*y) ⟨xsq_even, ysq_odd⟩,
rw nat.pow_two at h1,
rw nat.pow_two at h1,
have claim : even (x*x+y*y) := by {rw even, use n, rw h1},
exact not_both_even_odd (x*x+y*y) ⟨claim, sum_odd⟩,
cases yeo with y_even y_odd,

exfalso,
have xsq_odd := odd_times_odd_is_odd x x ⟨x_odd, x_odd⟩,
have ysq_even := even_times_nat_is_even y y y_even,
have sum_odd := odd_plus_even_is_odd (x*x) (y*y) ⟨xsq_odd, ysq_even⟩,
rw nat.pow_two at h1,
rw nat.pow_two at h1,
have claim : even (x*x+y*y) := by {rw even, use n, rw h1},
exact not_both_even_odd (x*x+y*y) ⟨claim, sum_odd⟩,

have sum_even := odd_plus_odd_is_even y x ⟨y_odd, x_odd⟩,
have diff_even := odd_minus_odd_is_even y x ⟨y_odd, x_odd, le_of_lt h⟩,
rw even at sum_even,
cases sum_even with sum' sum_ev,
rw even at diff_even,
cases diff_even with diff' diff_ev,
use sum',
use diff',
have claim : 2*n = 2*(sum'^2 + diff'^2),
rw h1,
have claim' : 2*(x^2+y^2) = 4*(sum'^2+diff'^2),
have thing : 4*(sum'^2+diff'^2) = (2*sum')^2+(2*diff')^2 := by ring,
rw thing,
rw (eq.symm sum_ev),
rw (eq.symm diff_ev),
exact prelim x y h,
have thing : 4*(sum'^2+diff'^2) = 2*(2*(sum'^2+diff'^2)) := by ring,
rw thing at claim',
exact mul_cancel 2 (x^2+y^2) (2*(sum'^2+diff'^2)) claim' zero_lt_two,
exact mul_cancel 2 n (sum'^2+diff'^2) claim zero_lt_two,
end

-- halving just applies halving_first several times to rid the assumption
-- of the comparison on x and y.

lemma halving (n x y : ℕ) (h1 : 2*n = x^2 + y^2) :
  ∃a:ℕ, ∃b:ℕ, n = a^2 + b^2 :=
begin
have ltr := lt_trichotomy x y,
cases ltr with ltr' ltr1,
exact halving_first n x y ltr' h1,
cases ltr1 with ltr2 ltr3,
use x,
use 0,
rw (eq.symm ltr2) at h1,
have claim : x^2 + x^2 = 2*(x^2) := by ring,
rw claim at h1,
have zero_lt_two := lt_trans (nat.lt_succ_self 0) (nat.lt_succ_self 1),
have thing := mul_cancel 2 n (x^2) h1 zero_lt_two,
rw thing,
ring,
rw add_comm at h1,
exact halving_first n y x ltr3 h1,
end

lemma ineq's (n k : ℕ) (h1 : 0 < 2*n) (h2 : 2*n < k) :
  0 < n ∧ n < k :=
begin
split,
have pz := pos_or_zero n,
cases pz with pz1 pz2,
exact pz1,
exfalso,
rw pz2 at h1,
rw mul_zero at h1,
exact lt_irrefl 0 h1,
have ltr := lt_trichotomy n k,
cases ltr with ltr' ltr1,
exact ltr',
exfalso,
cases ltr1 with ltr2 ltr3,
rw ltr2 at h2,
have claim : k ≤ 2*k,
have thing := add_le_add_left (zero_le k) k,
rw add_zero at thing,
have thing' : k + k = 2*k := by ring,
rw thing' at thing,
exact thing,
have thing := lt_of_le_of_lt claim h2,
exact lt_irrefl k thing,
have zero_lt_two : 0 < 2 := by {
  exact lt_trans (nat.lt_succ_self 0) (nat.lt_succ_self 1)
},
have thing := mul_lt_mul_of_pos_left ltr3 zero_lt_two,
have h2' := lt_trans thing h2,
have claim : k ≤ 2*k,
have thing := add_le_add_left (zero_le k) k,
rw add_zero at thing,
have thing' : k + k = 2*k := by ring,
rw thing' at thing,
exact thing,
have thing := lt_of_le_of_lt claim h2',
exact lt_irrefl k thing,
end

theorem sum_of_two_squares (p : ℕ) (hp : prime' p) (hm : divides 4 (p-1)) :
  ∃ x, ∃ y, p = x^2+y^2 :=
begin
let m := nat.find(mult_sum_of_two_squares p hp hm),
have mx : 0 < m ∧ m < p ∧ ∃ x, ∃ y, m*p = x^2+y^2 := nat.find_spec(mult_sum_of_two_squares p hp hm),
have mm : ∀ m', (0 < m' ∧ m' < p ∧ ∃ x, ∃ y, m'*p = x^2+y^2) → m ≤ m' := λ d', nat.find_min'(mult_sum_of_two_squares p hp hm),
have meo := even_or_odd m,
cases mx with mx1 mx1',
cases mx1' with mx2 mx3,
cases meo with m_even m_odd,
exfalso,
rw even at m_even,
cases m_even with m' m_ev,
cases mx3 with xex mx3',
cases mx3' with yex mx4,

rw m_ev at mx4,
rw mul_assoc at mx4,
have half := halving (m'*p) xex yex mx4,
rw m_ev at mx1,
rw m_ev at mx2,
have ineqs := ineq's m' p mx1 mx2,
cases ineqs with ineq1 ineq2,
have fact := mm m' ⟨ineq1, ineq2, half⟩,
rw m_ev at fact,
have fact2 := add_lt_add_left ineq1 m',
rw add_zero at fact2,
have ir := lt_of_le_of_lt fact fact2,
have claim : m' + m' = 2 * m' := by ring,
rw claim at ir,
exact lt_irrefl (2*m') ir,

-- Now for the case that m is odd.

by_cases is_m_one : m = 1,
rw is_m_one at mx3,
cases mx3 with xex mx3',
cases mx3' with yex mx3'',
rw one_mul at mx3'',
use xex,
use yex,
exact mx3'',

-- Now for the case that m is odd and > 1.

cases mx3 with xex mx3',
cases mx3' with yex mx4,
have xd := div_alg_near_zero xex m mx1 m_odd,
cases xd with qx xd'',
cases xd'' with x1 xd',
have yd := div_alg_near_zero yex m mx1 m_odd,
cases yd with qy yd'',
cases yd'' with y1 yd',
cases xd' with xd1 xd1',
cases xd1' with xd2 xd3,
cases yd' with yd1 yd1',
cases yd1' with yd2 yd3,

have claim : ∃(n:ℤ), (m:ℤ)*n = x1^2+y1^2,
use (p:ℤ) - (xex+x1)*qx - (yex+y1)*qy,
have thing0 : ↑m * (↑p - (↑xex + x1) * qx - (↑yex + y1) * qy)
  = (↑m * ↑p) - ↑m * (↑xex + x1) * qx - ↑m * (↑yex + y1) * qy := by ring,
rw thing0,
have thing0' : (m:ℤ)*p = (xex:ℤ)^2+yex^2 := by {norm_cast, exact mx4},
have thing1 : x1 = (xex:ℤ) - (m:ℤ)*qx := by {rw xd1, ring},
have thing2 : y1 = (yex:ℤ) - (m:ℤ)*qy := by {rw yd1, ring},
rw thing1,
rw thing2,
rw thing0',
ring,

cases claim with n cn,

have n_pos : 0 < n,
have ltr := lt_trichotomy 0 n,
cases ltr with ltr1 ltr1',
exact ltr1,
exfalso,
cases ltr1' with ltr2 ltr3,
rw (eq.symm ltr2) at cn,
rw mul_zero at cn,
have x1sq_nn := square_nonneg x1,
have y1sq_nn := square_nonneg y1,
have clema := add_le_add_right x1sq_nn (y1^2),
rw zero_add at clema,
rw (eq.symm cn) at clema,
have y1sq_zero := le_antisymm clema y1sq_nn,
have y1_zero : 0 = y1 := by {
  by_cases contr : 0 = y1,
  exact contr,
  exfalso,
  have thing := nonzero_square_pos y1 contr,
  rw y1sq_zero at thing,
  exact lt_irrefl 0 thing
},
have clema' := add_le_add_left y1sq_nn (x1^2),
rw add_zero at clema',
rw (eq.symm cn) at clema',
have x1sq_zero := le_antisymm clema' x1sq_nn,
have x1_zero : 0 = x1 := by {
  by_cases contr : 0 = x1,
  exact contr,
  exfalso,
  have thing := nonzero_square_pos x1 contr,
  rw x1sq_zero at thing,
  exact lt_irrefl 0 thing
},
rw (eq.symm x1_zero) at xd1,
rw add_zero at xd1,
rw (eq.symm y1_zero) at yd1,
rw add_zero at yd1,
have mx4' : (m:ℤ)*p = (xex:ℤ)^2 + yex^2 := by {norm_cast, exact mx4},
rw xd1 at mx4',
rw yd1 at mx4',
have mx4'' : (m:ℤ)*p = (m:ℤ)*(m*(qx^2+qy^2)) := by {rw mx4', ring},
have int_m_pos : (0:ℤ) < (m:ℤ) := by {norm_cast, exact mx1},
have thing := int_mul_cancel m p (m*(qx^2+qy^2)) mx4'' int_m_pos,
have qx_nat := square_eq_sq_of_nat qx,
cases qx_nat with qxn qx_nat',
have qy_nat := square_eq_sq_of_nat qy,
cases qy_nat with qyn qy_nat',
rw qx_nat' at thing,
rw qy_nat' at thing,
have thing' := int.coe_nat_inj thing,
have oth : divides m p := by {
  rw divides, use qxn * (qxn * 1) + qyn * (qyn * 1), exact eq.symm thing'},
rw prime' at hp,
cases hp with hp1 hp2,
have conc := hp2 m oth,
cases conc with conc1 conc2,
exact is_m_one conc1,
rw conc2 at mx2,
exact lt_irrefl p mx2,
-- FINALLY confirmed n can't be zero.
have x1sq_nn := square_nonneg x1,
have y1sq_nn := square_nonneg y1,
have clema := add_le_add_right x1sq_nn (y1^2),
rw zero_add at clema,
rw (eq.symm cn) at clema,
have clema' := le_trans y1sq_nn clema,
have mx1' : (m:ℤ) > 0 := by {norm_cast, exact mx1},
have thing := linarith.mul_neg ltr3 mx1',
exact lt_irrefl 0 (lt_of_le_of_lt clema' thing),

have n_lt_m : n < m,
have two_squared_is_four : (2:ℤ)^2 = (4:ℤ) := by ring,
have negstx : (-2)*x1=-(2*x1) := by ring,
rw negstx at xd3,
have squarerelx := abs_thing (2*x1) (m:ℤ) xd2 xd3,
rw mul_pow at squarerelx,
rw two_squared_is_four at squarerelx,
have negsty : (-2)*y1=-(2*y1) := by ring,
rw negsty at yd3,
have squarerely := abs_thing (2*y1) (m:ℤ) yd2 yd3,
rw mul_pow at squarerely,
rw two_squared_is_four at squarerely,
have cn'4 : 4*((m:ℤ)*n) = 4*(x1^2+y1^2) := by {rw cn},
rw mul_add at cn'4,
have compare := add_lt_add squarerelx squarerely,
rw (eq.symm cn'4) at compare,
have th'1 : 4*((m:ℤ)*n)=(2*(m:ℤ))*(2*n) := by ring,
rw th'1 at compare,
have th'2 : (m:ℤ)^2+m^2 = (2*(m:ℤ))*m := by ring,
rw th'2 at compare,
have thong : 0 < 2*(m:ℤ) := by {
  norm_cast,
  have mx1' := add_lt_add_left mx1 m,
  rw add_zero at mx1',
  have th : 2*m=m+m := by ring,
  rw th,
  exact (lt_trans mx1 mx1')
},
have res := int_mul_cancel_lt (2*(m:ℤ)) (2*n) (m:ℤ) compare thong,
have final : n < 2*n := by {
  have fin := add_lt_add_left n_pos n,
  rw add_zero at fin,
  have th : 2*n=n+n := by ring,
  rw th, exact fin
},
exact lt_trans final res,

-- Now we can finally carry on with the rest.
-- We just need to show n*p is a sum of two squares.
have first_divis_lemma : ∃(a:ℤ),(m:ℤ)*a=xex*x1+yex*y1,
use p - xex*qx - yex*qy,
have claim : (m:ℤ)*(p-xex*qx-yex*qy) = (m:ℤ)*p - (m:ℤ)*(xex*qx+yex*qy) := by ring,
rw claim,
have mx4' : ((m:ℤ)*p = (xex:ℤ)^2+yex^2) := by {norm_cast, exact mx4},
rw mx4',
have xd1' : x1 = (xex:ℤ)-((m:ℤ)*qx) := by {rw xd1, ring},
rw xd1',
have yd1' : y1 = (yex:ℤ)-((m:ℤ)*qy) := by {rw yd1, ring},
rw yd1',
ring,

have second_divis_lemma : ∃(b:ℤ),(m:ℤ)*b=xex*y1-yex*x1,
use (yex:ℤ)*qx - (xex:ℤ)*qy,
have xd1' : x1 = (xex:ℤ)-((m:ℤ)*qx) := by {rw xd1, ring},
rw xd1',
have yd1' : y1 = (yex:ℤ)-((m:ℤ)*qy) := by {rw yd1, ring},
rw yd1',
ring,

cases first_divis_lemma with a fdl,
cases second_divis_lemma with b sdl,
have claim1 : ((m:ℤ)^2)*(n*p) = (xex*x1+yex*y1)^2 + (xex*y1-yex*x1)^2 := by {
  have thong : ((m:ℤ)^2)*(n*p) = ((m:ℤ)*n)*((m:ℤ)*p) := by ring,
  rw thong,
  have mx4' : ((m:ℤ)*p = (xex:ℤ)^2+yex^2) := by {norm_cast, exact mx4},
  rw cn,
  rw mx4',
  ring
},
rw (eq.symm fdl) at claim1,
rw (eq.symm sdl) at claim1,
have dist : ((m:ℤ)*a)^2 + ((m:ℤ)*b)^2 = (m:ℤ)^2*(a^2+b^2) := by ring,
rw dist at claim1,
have mx1' : 0 < (m:ℤ) := by {norm_cast, exact mx1},
by_cases could_it_be : (0:ℤ) = (m:ℤ),
exfalso,
rw could_it_be at mx1',
exact lt_irrefl (m:ℤ) mx1',
have sq_pos := nonzero_square_pos (m:ℤ) could_it_be,
have res := int_mul_cancel ((m:ℤ)^2) (n*(p:ℤ)) (a^2+b^2) claim1 sq_pos,
have n_can_be_coed := int.eq_coe_of_zero_le (le_of_lt n_pos),
cases n_can_be_coed with n' nc,
have ext_claim : ∃ (x y : ℕ), n'*p = x^2+y^2 := by {
  have a_nat := square_eq_sq_of_nat a,
  cases a_nat with aex a_n,
  have b_nat := square_eq_sq_of_nat b,
  cases b_nat with bex b_n,
  use aex, use bex,
  apply int.coe_nat_inj,
  push_cast,
  rw (eq.symm a_n),
  rw (eq.symm b_n),
  rw (eq.symm nc), exact res
},
rw nc at n_pos,
have n_pos' := int.coe_nat_lt.mp n_pos,
rw nc at n_lt_m,
have n_lt_m' := int.coe_nat_lt.mp n_lt_m,
have n_lt_p := lt_trans n_lt_m' mx2,
have final_thing := mm n' ⟨n_pos', n_lt_p, ext_claim⟩,
exfalso,
exact lt_irrefl m (lt_of_le_of_lt final_thing n_lt_m'),

end


open lean
open tactic
open interactive

@[intro] lemma option_bind_some_back {α β : Type} :
  forall (o1 : option α) (o2 : α → option β) v v',
    o1 = some v →
    o2 v = some v' →
    o1 >>= o2 = some v' :=
begin
  intros,
  rw a,
  simp [bind, has_bind.bind, option.bind],
  rw a_1,
end

lemma option_bind_some {α β : Type} :
  forall (o1 : option α) (o2 : α → option β) v,
    o1 >>= o2 = some v →
    exists v', o1 = some v' ∧
      o2 v' = some v :=
begin
  intros, destruct o1 ; intros,
  unfold bind at *, subst a_1,
  dsimp [option.bind] at *,
  cases a,
  subst a_1,
  unfold bind at *,
  dsimp [option.bind] at *,
  constructor,
  split, reflexivity,
  assumption,
end

meta def simp_option (hyp_name : parse lean.parser.ident) : tactic unit :=
do h ← get_local hyp_name,
   ty ← tactic.infer_type h,
   (a :: b :: o1 :: o2 :: v :: _) ← tactic.match_expr
     ``(fun (a b : Type) (o1 : option a) (o2 : a → option b) (v : b), has_bind.bind o1 o2 = some v) ty | tactic.failed,
   n ← get_unused_name `o,
   prf ← to_expr ``(option_bind_some %%o1 %%o2 %%v %%h),
   tactic.note n none prf,
   vn ← get_unused_name `v,
   ex ← get_local n,
   cases ex [vn, n],
   conj ← get_local n,
   r ← get_unused_name `right,
   l ← get_unused_name `left,
   cases conj [l, r],
   get_local hyp_name >>= clear,
   try (get_local l >>= dsimp_hyp),
   try (get_local r >>= dsimp_hyp),
   return ()


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import order.lattice

/-!
# `max` and `min`

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

This file proves basic properties about maxima and minima on a `linear_order`.

## Tags

min, max
-/

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

attribute [simp] max_eq_left max_eq_right min_eq_left min_eq_right

section
variables [linear_order α] [linear_order β] {f : α → β} {s : set α} {a b c d : α}

-- translate from lattices to linear orders (sup → max, inf → min)
@[simp] lemma le_min_iff : c ≤ min a b ↔ c ≤ a ∧ c ≤ b := le_inf_iff
@[simp] lemma le_max_iff : a ≤ max b c ↔ a ≤ b ∨ a ≤ c := le_sup_iff
@[simp] lemma min_le_iff : min a b ≤ c ↔ a ≤ c ∨ b ≤ c := inf_le_iff
@[simp] lemma max_le_iff : max a b ≤ c ↔ a ≤ c ∧ b ≤ c := sup_le_iff
@[simp] lemma lt_min_iff : a < min b c ↔ a < b ∧ a < c := lt_inf_iff
@[simp] lemma lt_max_iff : a < max b c ↔ a < b ∨ a < c := lt_sup_iff
@[simp] lemma min_lt_iff : min a b < c ↔ a < c ∨ b < c := inf_lt_iff
@[simp] lemma max_lt_iff : max a b < c ↔ a < c ∧ b < c := sup_lt_iff
lemma max_le_max : a ≤ c → b ≤ d → max a b ≤ max c d := sup_le_sup
lemma min_le_min : a ≤ c → b ≤ d → min a b ≤ min c d := inf_le_inf
lemma le_max_of_le_left : a ≤ b → a ≤ max b c := le_sup_of_le_left
lemma le_max_of_le_right : a ≤ c → a ≤ max b c := le_sup_of_le_right
lemma lt_max_of_lt_left (h : a < b) : a < max b c := h.trans_le (le_max_left b c)
lemma lt_max_of_lt_right (h : a < c) : a < max b c := h.trans_le (le_max_right b c)
lemma min_le_of_left_le : a ≤ c → min a b ≤ c := inf_le_of_left_le
lemma min_le_of_right_le : b ≤ c → min a b ≤ c := inf_le_of_right_le
lemma min_lt_of_left_lt (h : a < c) : min a b < c := (min_le_left a b).trans_lt h
lemma min_lt_of_right_lt (h : b < c) : min a b < c := (min_le_right a b).trans_lt h
lemma max_min_distrib_left : max a (min b c) = min (max a b) (max a c) := sup_inf_left
lemma max_min_distrib_right : max (min a b) c = min (max a c) (max b c) := sup_inf_right
lemma min_max_distrib_left : min a (max b c) = max (min a b) (min a c) := inf_sup_left
lemma min_max_distrib_right : min (max a b) c = max (min a c) (min b c) := inf_sup_right
lemma min_le_max : min a b ≤ max a b := le_trans (min_le_left a b) (le_max_left a b)

@[simp] lemma min_eq_left_iff : min a b = a ↔ a ≤ b := inf_eq_left
@[simp] lemma min_eq_right_iff : min a b = b ↔ b ≤ a := inf_eq_right
@[simp] lemma max_eq_left_iff : max a b = a ↔ b ≤ a := sup_eq_left
@[simp] lemma max_eq_right_iff : max a b = b ↔ a ≤ b := sup_eq_right

/-- For elements `a` and `b` of a linear order, either `min a b = a` and `a ≤ b`,
    or `min a b = b` and `b < a`.
    Use cases on this lemma to automate linarith in inequalities -/
lemma min_cases (a b : α) : min a b = a ∧ a ≤ b ∨ min a b = b ∧ b < a :=
begin
  by_cases a ≤ b,
  { left,
    exact ⟨min_eq_left h, h⟩ },
  { right,
    exact ⟨min_eq_right (le_of_lt (not_le.mp h)), (not_le.mp h)⟩ }
end

/-- For elements `a` and `b` of a linear order, either `max a b = a` and `b ≤ a`,
    or `max a b = b` and `a < b`.
    Use cases on this lemma to automate linarith in inequalities -/
lemma max_cases (a b : α) : max a b = a ∧ b ≤ a ∨ max a b = b ∧ a < b := @min_cases αᵒᵈ _ a b

lemma min_eq_iff : min a b = c ↔ a = c ∧ a ≤ b ∨ b = c ∧ b ≤ a :=
begin
  split,
  { intro h,
    refine or.imp (λ h', _) (λ h', _) (le_total a b);
    exact ⟨by simpa [h'] using h, h'⟩ },
  { rintro (⟨rfl, h⟩|⟨rfl, h⟩);
    simp [h] }
end

lemma max_eq_iff : max a b = c ↔ a = c ∧ b ≤ a ∨ b = c ∧ a ≤ b := @min_eq_iff αᵒᵈ _ a b c

lemma min_lt_min_left_iff : min a c < min b c ↔ a < b ∧ a < c :=
by { simp_rw [lt_min_iff, min_lt_iff, or_iff_left (lt_irrefl _)],
  exact and_congr_left (λ h, or_iff_left_of_imp h.trans) }

lemma min_lt_min_right_iff : min a b < min a c ↔ b < c ∧ b < a :=
by simp_rw [min_comm a, min_lt_min_left_iff]

lemma max_lt_max_left_iff : max a c < max b c ↔ a < b ∧ c < b := @min_lt_min_left_iff αᵒᵈ _ _ _ _
lemma max_lt_max_right_iff : max a b < max a c ↔ b < c ∧ a < c := @min_lt_min_right_iff αᵒᵈ _ _ _ _

/-- An instance asserting that `max a a = a` -/
instance max_idem : is_idempotent α max := by apply_instance -- short-circuit type class inference

/-- An instance asserting that `min a a = a` -/
instance min_idem : is_idempotent α min := by apply_instance -- short-circuit type class inference

lemma min_lt_max : min a b < max a b ↔ a ≠ b := inf_lt_sup

lemma max_lt_max (h₁ : a < c) (h₂ : b < d) : max a b < max c d :=
by simp [lt_max_iff, max_lt_iff, *]

lemma min_lt_min (h₁ : a < c) (h₂ : b < d) : min a b < min c d := @max_lt_max αᵒᵈ _ _ _ _ _ h₁ h₂

theorem min_right_comm (a b c : α) : min (min a b) c = min (min a c) b :=
right_comm min min_comm min_assoc a b c

theorem max.left_comm (a b c : α) : max a (max b c) = max b (max a c) :=
left_comm max max_comm max_assoc a b c

theorem max.right_comm (a b c : α) : max (max a b) c = max (max a c) b :=
right_comm max max_comm max_assoc a b c

lemma monotone_on.map_max (hf : monotone_on f s) (ha : a ∈ s) (hb : b ∈ s) :
  f (max a b) = max (f a) (f b) :=
by cases le_total a b; simp only [max_eq_right, max_eq_left, hf ha hb, hf hb ha, h]

lemma monotone_on.map_min (hf : monotone_on f s) (ha : a ∈ s) (hb : b ∈ s) :
  f (min a b) = min (f a) (f b) :=
hf.dual.map_max ha hb

lemma antitone_on.map_max (hf : antitone_on f s) (ha : a ∈ s) (hb : b ∈ s) :
  f (max a b) = min (f a) (f b) :=
hf.dual_right.map_max ha hb

lemma antitone_on.map_min (hf : antitone_on f s) (ha : a ∈ s) (hb : b ∈ s) :
  f (min a b) = max (f a) (f b) :=
hf.dual.map_max ha hb

lemma monotone.map_max (hf : monotone f) : f (max a b) = max (f a) (f b) :=
by cases le_total a b; simp [h, hf h]

lemma monotone.map_min (hf : monotone f) : f (min a b) = min (f a) (f b) :=
hf.dual.map_max

lemma antitone.map_max (hf : antitone f) : f (max a b) = min (f a) (f b) :=
by cases le_total a b; simp [h, hf h]

lemma antitone.map_min (hf : antitone f) : f (min a b) = max (f a) (f b) :=
hf.dual.map_max

theorem min_choice (a b : α) : min a b = a ∨ min a b = b :=
by cases le_total a b; simp *

theorem max_choice (a b : α) : max a b = a ∨ max a b = b :=
@min_choice αᵒᵈ _ a b

lemma le_of_max_le_left {a b c : α} (h : max a b ≤ c) : a ≤ c :=
le_trans (le_max_left _ _) h

lemma le_of_max_le_right {a b c : α} (h : max a b ≤ c) : b ≤ c :=
le_trans (le_max_right _ _) h

lemma max_commutative : commutative (max : α → α → α) :=
max_comm

lemma max_associative : associative (max : α → α → α) :=
max_assoc

lemma max_left_commutative : left_commutative (max : α → α → α) :=
max_left_comm

lemma min_commutative : commutative (min : α → α → α) :=
min_comm

lemma min_associative : associative (min : α → α → α) :=
min_assoc

lemma min_left_commutative : left_commutative (min : α → α → α) :=
min_left_comm

end


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import algebra.order.ring
import data.nat.basic
import data.set.lattice
import order.directed
import tactic.monotonicity.basic

variables {α : Type*}

@[mono]
lemma mul_mono_nonneg {x y z : α} [ordered_semiring α]
  (h' : 0 ≤ z)
  (h : x ≤ y)
: x * z ≤ y * z :=
by apply mul_le_mul_of_nonneg_right; assumption

lemma lt_of_mul_lt_mul_neg_right {a b c : α}  [linear_ordered_ring α]
  (h : a * c < b * c) (hc : c ≤ 0) : b < a :=
have nhc : -c ≥ 0, from neg_nonneg_of_nonpos hc,
have h2 : -(b * c) < -(a * c), from neg_lt_neg h,
have h3 : b * (-c) < a * (-c), from calc
     b * (-c) = - (b * c)    : by rewrite neg_mul_eq_mul_neg
          ... < - (a * c)    : h2
          ... = a * (-c)     : by rewrite neg_mul_eq_mul_neg,
lt_of_mul_lt_mul_right h3 nhc

@[mono]
lemma mul_mono_nonpos {x y z : α} [linear_ordered_ring α]
  (h' : z ≤ 0) (h : y ≤ x) : x * z ≤ y * z :=
begin
  classical,
  by_contradiction h'',
  revert h,
  apply not_le_of_lt,
  apply lt_of_mul_lt_mul_neg_right _ h',
  apply lt_of_not_ge h''
end

@[mono]
lemma nat.sub_mono_left_strict {x y z : ℕ}
  (h' : z ≤ x)
  (h : x < y)
: x - z < y - z :=
begin
  have : z ≤ y,
  { transitivity, assumption, apply le_of_lt h, },
  apply @nat.lt_of_add_lt_add_left z,
  rw [add_tsub_cancel_of_le,add_tsub_cancel_of_le];
    solve_by_elim
end

@[mono]
lemma nat.sub_mono_right_strict {x y z : ℕ}
  (h' : x ≤ z)
  (h : y < x)
: z - x < z - y :=
begin
  have h'' : y ≤ z,
  { transitivity, apply le_of_lt h, assumption },
  apply @nat.lt_of_add_lt_add_right _ x,
  rw [tsub_add_cancel_of_le h'],
  apply @lt_of_le_of_lt _ _ _ (z - y + y),
  rw [tsub_add_cancel_of_le h''],
  apply nat.add_lt_add_left h
end

open set

attribute [mono] inter_subset_inter union_subset_union
                 sUnion_mono bUnion_mono sInter_subset_sInter bInter_mono
                 image_subset preimage_mono prod_mono monotone_prod seq_mono
                 image2_subset order_embedding.monotone
attribute [mono] upper_bounds_mono_set lower_bounds_mono_set
                 upper_bounds_mono_mem  lower_bounds_mono_mem
                 upper_bounds_mono  lower_bounds_mono
                 bdd_above.mono bdd_below.mono

attribute [mono] add_le_add mul_le_mul neg_le_neg
         mul_lt_mul_of_pos_left mul_lt_mul_of_pos_right
         imp_imp_imp le_implies_le_of_le_of_le
         sub_le_sub tsub_le_tsub tsub_le_tsub_right abs_le_abs sup_le_sup
         inf_le_inf
attribute [mono left] add_lt_add_of_le_of_lt mul_lt_mul'
attribute [mono right] add_lt_add_of_lt_of_le mul_lt_mul


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Sébastien Gouëzel
-/
import analysis.calculus.mean_value
import analysis.special_functions.pow_deriv
import analysis.special_functions.sqrt

/-!
# Collection of convex functions

In this file we prove that the following functions are convex:

* `strict_convex_on_exp` : The exponential function is strictly convex.
* `even.convex_on_pow`, `even.strict_convex_on_pow` : For an even `n : ℕ`, `λ x, x ^ n` is convex
  and strictly convex when `2 ≤ n`.
* `convex_on_pow`, `strict_convex_on_pow` : For `n : ℕ`, `λ x, x ^ n` is convex on $[0, +∞)$ and
  strictly convex when `2 ≤ n`.
* `convex_on_zpow`, `strict_convex_on_zpow` : For `m : ℤ`, `λ x, x ^ m` is convex on $[0, +∞)$ and
  strictly convex when `m ≠ 0, 1`.
* `convex_on_rpow`, `strict_convex_on_rpow` : For `p : ℝ`, `λ x, x ^ p` is convex on $[0, +∞)$ when
  `1 ≤ p` and strictly convex when `1 < p`.
* `strict_concave_on_log_Ioi`, `strict_concave_on_log_Iio`: `real.log` is strictly concave on
  $(0, +∞)$ and $(-∞, 0)$ respectively.

## TODO

For `p : ℝ`, prove that `λ x, x ^ p` is concave when `0 ≤ p ≤ 1` and strictly concave when
`0 < p < 1`.
-/

open real set
open_locale big_operators

/-- `exp` is strictly convex on the whole real line. -/
lemma strict_convex_on_exp : strict_convex_on ℝ univ exp :=
strict_convex_on_univ_of_deriv2_pos differentiable_exp (λ x, (iter_deriv_exp 2).symm ▸ exp_pos x)

/-- `exp` is convex on the whole real line. -/
lemma convex_on_exp : convex_on ℝ univ exp := strict_convex_on_exp.convex_on

/-- `x^n`, `n : ℕ` is convex on the whole real line whenever `n` is even -/
lemma even.convex_on_pow {n : ℕ} (hn : even n) : convex_on ℝ set.univ (λ x : ℝ, x^n) :=
begin
  apply convex_on_univ_of_deriv2_nonneg (differentiable_pow n),
  { simp only [deriv_pow', differentiable.mul, differentiable_const, differentiable_pow] },
  { intro x,
    obtain ⟨k, hk⟩ := (hn.tsub $ even_bit0 _).exists_two_nsmul _,
    rw [iter_deriv_pow, finset.prod_range_cast_nat_sub, hk, nsmul_eq_mul, pow_mul'],
    exact mul_nonneg (nat.cast_nonneg _) (pow_two_nonneg _) }
end

/-- `x^n`, `n : ℕ` is strictly convex on the whole real line whenever `n ≠ 0` is even. -/
lemma even.strict_convex_on_pow {n : ℕ} (hn : even n) (h : n ≠ 0) :
  strict_convex_on ℝ set.univ (λ x : ℝ, x^n) :=
begin
  apply strict_mono.strict_convex_on_univ_of_deriv (differentiable_pow n),
  rw deriv_pow',
  replace h := nat.pos_of_ne_zero h,
  exact strict_mono.const_mul (odd.strict_mono_pow $ nat.even.sub_odd h hn $ nat.odd_iff.2 rfl)
    (nat.cast_pos.2 h),
end

/-- `x^n`, `n : ℕ` is convex on `[0, +∞)` for all `n` -/
lemma convex_on_pow (n : ℕ) : convex_on ℝ (Ici 0) (λ x : ℝ, x^n) :=
begin
  apply convex_on_of_deriv2_nonneg (convex_Ici _) (continuous_pow n).continuous_on
    (differentiable_on_pow n),
  { simp only [deriv_pow'], exact (@differentiable_on_pow ℝ _ _ _).const_mul (n : ℝ) },
  { intros x hx,
    rw [iter_deriv_pow, finset.prod_range_cast_nat_sub],
    exact mul_nonneg (nat.cast_nonneg _) (pow_nonneg (interior_subset hx) _) }
end

/-- `x^n`, `n : ℕ` is strictly convex on `[0, +∞)` for all `n` greater than `2`. -/
lemma strict_convex_on_pow {n : ℕ} (hn : 2 ≤ n) : strict_convex_on ℝ (Ici 0) (λ x : ℝ, x^n) :=
begin
  apply strict_mono_on.strict_convex_on_of_deriv (convex_Ici _) (continuous_on_pow _)
    (differentiable_on_pow n),
  rw [deriv_pow', interior_Ici],
  exact λ x (hx : 0 < x) y hy hxy, mul_lt_mul_of_pos_left (pow_lt_pow_of_lt_left hxy hx.le $
    nat.sub_pos_of_lt hn) (nat.cast_pos.2 $ zero_lt_two.trans_le hn),
end

lemma finset.prod_nonneg_of_card_nonpos_even
  {α β : Type*} [linear_ordered_comm_ring β]
  {f : α → β} [decidable_pred (λ x, f x ≤ 0)]
  {s : finset α} (h0 : even (s.filter (λ x, f x ≤ 0)).card) :
  0 ≤ ∏ x in s, f x :=
calc 0 ≤ (∏ x in s, ((if f x ≤ 0 then (-1:β) else 1) * f x)) :
  finset.prod_nonneg (λ x _, by
    { split_ifs with hx hx, by simp [hx], simp at hx ⊢, exact le_of_lt hx })
... = _ : by rw [finset.prod_mul_distrib, finset.prod_ite, finset.prod_const_one,
  mul_one, finset.prod_const, neg_one_pow_eq_pow_mod_two, nat.even_iff.1 h0, pow_zero, one_mul]

lemma int_prod_range_nonneg (m : ℤ) (n : ℕ) (hn : even n) :
  0 ≤ ∏ k in finset.range n, (m - k) :=
begin
  rcases hn with ⟨n, rfl⟩,
  induction n with n ihn, { simp },
  rw ← two_mul at ihn,
  rw [← two_mul, nat.succ_eq_add_one, mul_add, mul_one, bit0, ← add_assoc, finset.prod_range_succ,
    finset.prod_range_succ, mul_assoc],
  refine mul_nonneg ihn _, generalize : (1 + 1) * n = k,
  cases le_or_lt m k with hmk hmk,
  { have : m ≤ k + 1, from hmk.trans (lt_add_one ↑k).le,
    exact mul_nonneg_of_nonpos_of_nonpos (sub_nonpos_of_le hmk) (sub_nonpos_of_le this) },
  { exact mul_nonneg (sub_nonneg_of_le hmk.le) (sub_nonneg_of_le hmk) }
end

lemma int_prod_range_pos {m : ℤ} {n : ℕ} (hn : even n) (hm : m ∉ Ico (0 : ℤ) n) :
  0 < ∏ k in finset.range n, (m - k) :=
begin
  refine (int_prod_range_nonneg m n hn).lt_of_ne (λ h, hm _),
  rw [eq_comm, finset.prod_eq_zero_iff] at h,
  obtain ⟨a, ha, h⟩ := h,
  rw sub_eq_zero.1 h,
  exact ⟨int.coe_zero_le _, int.coe_nat_lt.2 $ finset.mem_range.1 ha⟩,
end

/-- `x^m`, `m : ℤ` is convex on `(0, +∞)` for all `m` -/
lemma convex_on_zpow (m : ℤ) : convex_on ℝ (Ioi 0) (λ x : ℝ, x^m) :=
begin
  have : ∀ n : ℤ, differentiable_on ℝ (λ x, x ^ n) (Ioi (0 : ℝ)),
    from λ n, differentiable_on_zpow _ _ (or.inl $ lt_irrefl _),
  apply convex_on_of_deriv2_nonneg (convex_Ioi 0);
    try { simp only [interior_Ioi, deriv_zpow'] },
  { exact (this _).continuous_on },
  { exact this _ },
  { exact (this _).const_mul _ },
  { intros x hx,
    rw iter_deriv_zpow,
    refine mul_nonneg _ (zpow_nonneg (le_of_lt hx) _),
    exact_mod_cast int_prod_range_nonneg _ _ (even_bit0 1) }
end

/-- `x^m`, `m : ℤ` is convex on `(0, +∞)` for all `m` except `0` and `1`. -/
lemma strict_convex_on_zpow {m : ℤ} (hm₀ : m ≠ 0) (hm₁ : m ≠ 1) :
  strict_convex_on ℝ (Ioi 0) (λ x : ℝ, x^m) :=
begin
  have : ∀ n : ℤ, differentiable_on ℝ (λ x, x ^ n) (Ioi (0 : ℝ)),
    from λ n, differentiable_on_zpow _ _ (or.inl $ lt_irrefl _),
  apply strict_convex_on_of_deriv2_pos (convex_Ioi 0),
  { exact (this _).continuous_on },
   all_goals { rw interior_Ioi },
  { exact this _ },
  intros x hx,
  rw iter_deriv_zpow,
  refine mul_pos _ (zpow_pos_of_pos hx _),
  exact_mod_cast int_prod_range_pos (even_bit0 1) (λ hm, _),
  norm_cast at hm,
  rw ← finset.coe_Ico at hm,
  fin_cases hm; cc,
end

lemma convex_on_rpow {p : ℝ} (hp : 1 ≤ p) : convex_on ℝ (Ici 0) (λ x : ℝ, x^p) :=
begin
  have A : deriv (λ (x : ℝ), x ^ p) = λ x, p * x^(p-1), by { ext x, simp [hp] },
  apply convex_on_of_deriv2_nonneg (convex_Ici 0),
  { exact continuous_on_id.rpow_const (λ x _, or.inr (zero_le_one.trans hp)) },
  { exact (differentiable_rpow_const hp).differentiable_on },
  { rw A,
    assume x hx,
    replace hx : x ≠ 0, by { simp at hx, exact ne_of_gt hx },
    simp [differentiable_at.differentiable_within_at, hx] },
  { assume x hx,
    replace hx : 0 < x, by simpa using hx,
    suffices : 0 ≤ p * ((p - 1) * x ^ (p - 1 - 1)), by simpa [ne_of_gt hx, A],
    apply mul_nonneg (le_trans zero_le_one hp),
    exact mul_nonneg (sub_nonneg_of_le hp) (rpow_nonneg_of_nonneg hx.le _) }
end

lemma strict_convex_on_rpow {p : ℝ} (hp : 1 < p) : strict_convex_on ℝ (Ici 0) (λ x : ℝ, x^p) :=
begin
  have A : deriv (λ (x : ℝ), x ^ p) = λ x, p * x^(p-1), by { ext x, simp [hp.le] },
  apply strict_convex_on_of_deriv2_pos (convex_Ici 0),
  { exact continuous_on_id.rpow_const (λ x _, or.inr (zero_le_one.trans hp.le)) },
  { exact (differentiable_rpow_const hp.le).differentiable_on },
  rw interior_Ici,
  rintro x (hx : 0 < x),
  suffices : 0 < p * ((p - 1) * x ^ (p - 1 - 1)), by simpa [ne_of_gt hx, A],
  exact mul_pos (zero_lt_one.trans hp) (mul_pos (sub_pos_of_lt hp) (rpow_pos_of_pos hx _)),
end

lemma strict_concave_on_log_Ioi : strict_concave_on ℝ (Ioi 0) log :=
begin
  have h₁ : Ioi 0 ⊆ ({0} : set ℝ)ᶜ,
  { exact λ x (hx : 0 < x) (hx' : x = 0), hx.ne' hx' },
  refine strict_concave_on_open_of_deriv2_neg (convex_Ioi 0) is_open_Ioi
    (differentiable_on_log.mono h₁) (λ x (hx : 0 < x), _),
  rw [function.iterate_succ, function.iterate_one],
  change (deriv (deriv log)) x < 0,
  rw [deriv_log', deriv_inv],
  exact neg_neg_of_pos (inv_pos.2 $ sq_pos_of_ne_zero _ hx.ne'),
end

lemma strict_concave_on_log_Iio : strict_concave_on ℝ (Iio 0) log :=
begin
  have h₁ : Iio 0 ⊆ ({0} : set ℝ)ᶜ,
  { exact λ x (hx : x < 0) (hx' : x = 0), hx.ne hx' },
  refine strict_concave_on_open_of_deriv2_neg (convex_Iio 0) is_open_Iio
    (differentiable_on_log.mono h₁) (λ x (hx : x < 0), _),
  rw [function.iterate_succ, function.iterate_one],
  change (deriv (deriv log)) x < 0,
  rw [deriv_log', deriv_inv],
  exact neg_neg_of_pos (inv_pos.2 $ sq_pos_of_ne_zero _ hx.ne),
end

section sqrt_mul_log

lemma has_deriv_at_sqrt_mul_log {x : ℝ} (hx : x ≠ 0) :
  has_deriv_at (λ x, sqrt x * log x) ((2 + log x) / (2 * sqrt x)) x :=
begin
  convert (has_deriv_at_sqrt hx).mul (has_deriv_at_log hx),
  rw [add_div, div_mul_right (sqrt x) two_ne_zero, ←div_eq_mul_inv, sqrt_div_self',
      add_comm, div_eq_mul_one_div, mul_comm],
end

lemma deriv_sqrt_mul_log (x : ℝ) : deriv (λ x, sqrt x * log x) x = (2 + log x) / (2 * sqrt x) :=
begin
  cases lt_or_le 0 x with hx hx,
  { exact (has_deriv_at_sqrt_mul_log hx.ne').deriv },
  { rw [sqrt_eq_zero_of_nonpos hx, mul_zero, div_zero],
    refine has_deriv_within_at.deriv_eq_zero _ (unique_diff_on_Iic 0 x hx),
    refine (has_deriv_within_at_const x _ 0).congr_of_mem (λ x hx, _) hx,
    rw [sqrt_eq_zero_of_nonpos hx, zero_mul] },
end

lemma deriv_sqrt_mul_log' : deriv (λ x, sqrt x * log x) = λ x, (2 + log x) / (2 * sqrt x) :=
funext deriv_sqrt_mul_log

lemma deriv2_sqrt_mul_log (x : ℝ) :
  deriv^[2] (λ x, sqrt x * log x) x = -log x / (4 * sqrt x ^ 3) :=
begin
  simp only [nat.iterate, deriv_sqrt_mul_log'],
  cases le_or_lt x 0 with hx hx,
  { rw [sqrt_eq_zero_of_nonpos hx, zero_pow zero_lt_three, mul_zero, div_zero],
    refine has_deriv_within_at.deriv_eq_zero _ (unique_diff_on_Iic 0 x hx),
    refine (has_deriv_within_at_const _ _ 0).congr_of_mem (λ x hx, _) hx,
    rw [sqrt_eq_zero_of_nonpos hx, mul_zero, div_zero] },
  { have h₀ : sqrt x ≠ 0, from sqrt_ne_zero'.2 hx,
    convert (((has_deriv_at_log hx.ne').const_add 2).div
      ((has_deriv_at_sqrt hx.ne').const_mul 2) $ mul_ne_zero two_ne_zero h₀).deriv using 1,
    nth_rewrite 2 [← mul_self_sqrt hx.le],
    field_simp, ring },
end

lemma strict_concave_on_sqrt_mul_log_Ioi : strict_concave_on ℝ (set.Ioi 1) (λ x, sqrt x * log x) :=
begin
  refine strict_concave_on_open_of_deriv2_neg (convex_Ioi 1) is_open_Ioi (λ x hx, _) (λ x hx, _),
  { have h₀ : x ≠ 0, from (one_pos.trans hx.out).ne',
    exact (has_deriv_at_sqrt_mul_log h₀).differentiable_at.differentiable_within_at },
  { rw [deriv2_sqrt_mul_log x],
    exact div_neg_of_neg_of_pos (neg_neg_of_pos (log_pos hx))
      (mul_pos four_pos (pow_pos (sqrt_pos.mpr (zero_lt_one.trans hx)) 3)) },
end

end sqrt_mul_log

open_locale real

lemma strict_concave_on_sin_Icc : strict_concave_on ℝ (Icc 0 π) sin :=
begin
  apply strict_concave_on_of_deriv2_neg (convex_Icc _ _) continuous_on_sin
    differentiable_sin.differentiable_on (λ x hx, _),
  rw interior_Icc at hx,
  simp [sin_pos_of_mem_Ioo hx],
end

lemma strict_concave_on_cos_Icc : strict_concave_on ℝ (Icc (-(π/2)) (π/2)) cos :=
begin
  apply strict_concave_on_of_deriv2_neg (convex_Icc _ _) continuous_on_cos
    differentiable_cos.differentiable_on (λ x hx, _),
  rw interior_Icc at hx,
  simp [cos_pos_of_mem_Ioo hx],
end


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

! This file was ported from Lean 3 source module field_theory.fixed
! leanprover-community/mathlib commit e7bab9a85e92cf46c02cb4725a7be2f04691e3a7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.GroupRingAction.Invariant
import Mathbin.Algebra.Polynomial.GroupRingAction
import Mathbin.FieldTheory.Normal
import Mathbin.FieldTheory.Separable
import Mathbin.FieldTheory.Tower

/-!
# Fixed field under a group action.

This is the basis of the Fundamental Theorem of Galois Theory.
Given a (finite) group `G` that acts on a field `F`, we define `fixed_points G F`,
the subfield consisting of elements of `F` fixed_points by every element of `G`.

This subfield is then normal and separable, and in addition (TODO) if `G` acts faithfully on `F`
then `finrank (fixed_points G F) F = fintype.card G`.

## Main Definitions

- `fixed_points G F`, the subfield consisting of elements of `F` fixed_points by every element of
`G`, where `G` is a group that acts on `F`.

-/

noncomputable section

open Classical BigOperators

open MulAction Finset FiniteDimensional

universe u v w

variable {M : Type u} [Monoid M]

variable (G : Type u) [Group G]

variable (F : Type v) [Field F] [MulSemiringAction M F] [MulSemiringAction G F] (m : M)

/-- The subfield of F fixed by the field endomorphism `m`. -/
def FixedBy.subfield : Subfield F where
  carrier := fixedBy M F m
  zero_mem' := smul_zero m
  add_mem' x y hx hy := (smul_add m x y).trans <| congr_arg₂ _ hx hy
  neg_mem' x hx := (smul_neg m x).trans <| congr_arg _ hx
  one_mem' := smul_one m
  mul_mem' x y hx hy := (smul_mul' m x y).trans <| congr_arg₂ _ hx hy
  inv_mem' x hx := (smul_inv'' m x).trans <| congr_arg _ hx
#align fixed_by.subfield FixedBy.subfield

section InvariantSubfields

variable (M) {F}

/-- A typeclass for subrings invariant under a `mul_semiring_action`. -/
class IsInvariantSubfield (S : Subfield F) : Prop where
  smul_mem : ∀ (m : M) {x : F}, x ∈ S → m • x ∈ S
#align is_invariant_subfield IsInvariantSubfield

variable (S : Subfield F)

instance IsInvariantSubfield.toMulSemiringAction [IsInvariantSubfield M S] : MulSemiringAction M S
    where
  smul m x := ⟨m • x, IsInvariantSubfield.smul_mem m x.2⟩
  one_smul s := Subtype.eq <| one_smul M s
  mul_smul m₁ m₂ s := Subtype.eq <| mul_smul m₁ m₂ s
  smul_add m s₁ s₂ := Subtype.eq <| smul_add m s₁ s₂
  smul_zero m := Subtype.eq <| smul_zero m
  smul_one m := Subtype.eq <| smul_one m
  smul_mul m s₁ s₂ := Subtype.eq <| smul_mul' m s₁ s₂
#align is_invariant_subfield.to_mul_semiring_action IsInvariantSubfield.toMulSemiringAction

instance [IsInvariantSubfield M S] : IsInvariantSubring M S.toSubring
    where smul_mem := IsInvariantSubfield.smul_mem

end InvariantSubfields

namespace FixedPoints

variable (M)

-- we use `subfield.copy` so that the underlying set is `fixed_points M F`
/-- The subfield of fixed points by a monoid action. -/
def subfield : Subfield F :=
  Subfield.copy (⨅ m : M, FixedBy.subfield F m) (fixedPoints M F)
    (by
      ext z
      simp [fixed_points, FixedBy.subfield, infᵢ, Subfield.mem_infₛ])
#align fixed_points.subfield FixedPoints.subfield

instance : IsInvariantSubfield M (FixedPoints.subfield M F)
    where smul_mem g x hx g' := by rw [hx, hx]

instance : SMulCommClass M (FixedPoints.subfield M F) F
    where smul_comm m f f' := show m • (↑f * f') = f * m • f' by rw [smul_mul', f.prop m]

instance smul_comm_class' : SMulCommClass (FixedPoints.subfield M F) M F :=
  SMulCommClass.symm _ _ _
#align fixed_points.smul_comm_class' FixedPoints.smul_comm_class'

@[simp]
theorem smul (m : M) (x : FixedPoints.subfield M F) : m • x = x :=
  Subtype.eq <| x.2 m
#align fixed_points.smul FixedPoints.smul

-- Why is this so slow?
@[simp]
theorem smul_polynomial (m : M) (p : Polynomial (FixedPoints.subfield M F)) : m • p = p :=
  Polynomial.induction_on p (fun x => by rw [Polynomial.smul_C, smul])
    (fun p q ihp ihq => by rw [smul_add, ihp, ihq]) fun n x ih => by
    rw [smul_mul', Polynomial.smul_C, smul, smul_pow', Polynomial.smul_X]
#align fixed_points.smul_polynomial FixedPoints.smul_polynomial

instance : Algebra (FixedPoints.subfield M F) F := by infer_instance

theorem coe_algebraMap :
    algebraMap (FixedPoints.subfield M F) F = Subfield.subtype (FixedPoints.subfield M F) :=
  rfl
#align fixed_points.coe_algebra_map FixedPoints.coe_algebraMap

theorem linearIndependent_smul_of_linearIndependent {s : Finset F} :
    (LinearIndependent (FixedPoints.subfield G F) fun i : (s : Set F) => (i : F)) →
      LinearIndependent F fun i : (s : Set F) => MulAction.toFun G F i :=
  by
  haveI : IsEmpty ((∅ : Finset F) : Set F) := ⟨Subtype.prop⟩
  refine' Finset.induction_on s (fun _ => linearIndependent_empty_type) fun a s has ih hs => _
  rw [coe_insert] at hs⊢
  rw [linearIndependent_insert (mt mem_coe.1 has)] at hs
  rw [linearIndependent_insert' (mt mem_coe.1 has)]
  refine' ⟨ih hs.1, fun ha => _⟩
  rw [Finsupp.mem_span_image_iff_total] at ha
  rcases ha with ⟨l, hl, hla⟩
  rw [Finsupp.total_apply_of_mem_supported F hl] at hla
  suffices ∀ i ∈ s, l i ∈ FixedPoints.subfield G F
    by
    replace hla := (sum_apply _ _ fun i => l i • to_fun G F i).symm.trans (congr_fun hla 1)
    simp_rw [Pi.smul_apply, to_fun_apply, one_smul] at hla
    refine' hs.2 (hla ▸ Submodule.sum_mem _ fun c hcs => _)
    change (⟨l c, this c hcs⟩ : FixedPoints.subfield G F) • c ∈ _
    exact Submodule.smul_mem _ _ (Submodule.subset_span <| mem_coe.2 hcs)
  intro i his g
  refine'
    eq_of_sub_eq_zero
      (linearIndependent_iff'.1 (ih hs.1) s.attach (fun i => g • l i - l i) _ ⟨i, his⟩
          (mem_attach _ _) :
        _)
  refine' (@sum_attach _ _ s _ fun i => (g • l i - l i) • MulAction.toFun G F i).trans _
  ext g'
  dsimp only
  conv_lhs =>
    rw [sum_apply]
    congr
    skip
    ext
    rw [Pi.smul_apply, sub_smul, smul_eq_mul]
  rw [sum_sub_distrib, Pi.zero_apply, sub_eq_zero]
  conv_lhs =>
    congr
    skip
    ext
    rw [to_fun_apply, ← mul_inv_cancel_left g g', mul_smul, ← smul_mul', ← to_fun_apply _ x]
  show
    (∑ x in s, g • (fun y => l y • MulAction.toFun G F y) x (g⁻¹ * g')) =
      ∑ x in s, (fun y => l y • MulAction.toFun G F y) x g'
  rw [← smul_sum, ← sum_apply _ _ fun y => l y • to_fun G F y, ←
    sum_apply _ _ fun y => l y • to_fun G F y]
  dsimp only
  rw [hla, to_fun_apply, to_fun_apply, smul_smul, mul_inv_cancel_left]
#align fixed_points.linear_independent_smul_of_linear_independent FixedPoints.linearIndependent_smul_of_linearIndependent

section Fintype

variable [Fintype G] (x : F)

/-- `minpoly G F x` is the minimal polynomial of `(x : F)` over `fixed_points G F`. -/
def minpoly : Polynomial (FixedPoints.subfield G F) :=
  (prodXSubSmul G F x).toSubring (FixedPoints.subfield G F).toSubring fun c hc g =>
    let ⟨n, hc0, hn⟩ := Polynomial.mem_frange_iff.1 hc
    hn.symm ▸ prodXSubSmul.coeff G F x g n
#align fixed_points.minpoly FixedPoints.minpoly

namespace minpoly

theorem monic : (minpoly G F x).Monic :=
  by
  simp only [minpoly, Polynomial.monic_toSubring]
  exact prodXSubSmul.monic G F x
#align fixed_points.minpoly.monic FixedPoints.minpoly.monic

theorem eval₂ :
    Polynomial.eval₂ (Subring.subtype <| (FixedPoints.subfield G F).toSubring) x (minpoly G F x) =
      0 :=
  by
  rw [← prodXSubSmul.eval G F x, Polynomial.eval₂_eq_eval_map]
  simp only [minpoly, Polynomial.map_toSubring]
#align fixed_points.minpoly.eval₂ FixedPoints.minpoly.eval₂

theorem eval₂' :
    Polynomial.eval₂ (Subfield.subtype <| FixedPoints.subfield G F) x (minpoly G F x) = 0 :=
  eval₂ G F x
#align fixed_points.minpoly.eval₂' FixedPoints.minpoly.eval₂'

theorem ne_one : minpoly G F x ≠ (1 : Polynomial (FixedPoints.subfield G F)) := fun H =>
  have := eval₂ G F x
  (one_ne_zero : (1 : F) ≠ 0) <| by rwa [H, Polynomial.eval₂_one] at this
#align fixed_points.minpoly.ne_one FixedPoints.minpoly.ne_one

theorem of_eval₂ (f : Polynomial (FixedPoints.subfield G F))
    (hf : Polynomial.eval₂ (Subfield.subtype <| FixedPoints.subfield G F) x f = 0) :
    minpoly G F x ∣ f :=
  by
  erw [← Polynomial.map_dvd_map' (Subfield.subtype <| FixedPoints.subfield G F), minpoly,
    Polynomial.map_toSubring _ (Subfield G F).toSubring, prodXSubSmul]
  refine'
    Fintype.prod_dvd_of_coprime
      (Polynomial.pairwise_coprime_X_sub_C <| MulAction.injective_ofQuotientStabilizer G x) fun y =>
      QuotientGroup.induction_on y fun g => _
  rw [Polynomial.dvd_iff_isRoot, Polynomial.IsRoot.def, MulAction.ofQuotientStabilizer_mk,
    Polynomial.eval_smul', ← Subfield.toSubring_subtype_eq_subtype, ←
    IsInvariantSubring.coe_subtypeHom' G (FixedPoints.subfield G F).toSubring, ←
    MulSemiringActionHom.coe_polynomial, ← MulSemiringActionHom.map_smul, smul_polynomial,
    MulSemiringActionHom.coe_polynomial, IsInvariantSubring.coe_subtypeHom', Polynomial.eval_map,
    Subfield.toSubring_subtype_eq_subtype, hf, smul_zero]
#align fixed_points.minpoly.of_eval₂ FixedPoints.minpoly.of_eval₂

-- Why is this so slow?
theorem irreducible_aux (f g : Polynomial (FixedPoints.subfield G F)) (hf : f.Monic) (hg : g.Monic)
    (hfg : f * g = minpoly G F x) : f = 1 ∨ g = 1 :=
  by
  have hf2 : f ∣ minpoly G F x := by
    rw [← hfg]
    exact dvd_mul_right _ _
  have hg2 : g ∣ minpoly G F x := by
    rw [← hfg]
    exact dvd_mul_left _ _
  have := eval₂ G F x
  rw [← hfg, Polynomial.eval₂_mul, mul_eq_zero] at this
  cases this
  · right
    have hf3 : f = minpoly G F x :=
      Polynomial.eq_of_monic_of_associated hf (monic G F x)
        (associated_of_dvd_dvd hf2 <| @of_eval₂ G _ F _ _ _ x f this)
    rwa [← mul_one (minpoly G F x), hf3, mul_right_inj' (monic G F x).NeZero] at hfg
  · left
    have hg3 : g = minpoly G F x :=
      Polynomial.eq_of_monic_of_associated hg (monic G F x)
        (associated_of_dvd_dvd hg2 <| @of_eval₂ G _ F _ _ _ x g this)
    rwa [← one_mul (minpoly G F x), hg3, mul_left_inj' (monic G F x).NeZero] at hfg
#align fixed_points.minpoly.irreducible_aux FixedPoints.minpoly.irreducible_aux

theorem irreducible : Irreducible (minpoly G F x) :=
  (Polynomial.irreducible_of_monic (monic G F x) (ne_one G F x)).2 (irreducible_aux G F x)
#align fixed_points.minpoly.irreducible FixedPoints.minpoly.irreducible

end minpoly

end Fintype

theorem isIntegral [Finite G] (x : F) : IsIntegral (FixedPoints.subfield G F) x :=
  by
  cases nonempty_fintype G
  exact ⟨minpoly G F x, minpoly.monic G F x, minpoly.eval₂ G F x⟩
#align fixed_points.is_integral FixedPoints.isIntegral

section Fintype

variable [Fintype G] (x : F)

theorem minpoly_eq_minpoly : minpoly G F x = minpoly (FixedPoints.subfield G F) x :=
  minpoly.eq_of_irreducible_of_monic (minpoly.irreducible G F x) (minpoly.eval₂ G F x)
    (minpoly.monic G F x)
#align fixed_points.minpoly_eq_minpoly FixedPoints.minpoly_eq_minpoly

theorem dim_le_card : Module.rank (FixedPoints.subfield G F) F ≤ Fintype.card G :=
  dim_le fun s hs => by
    simpa only [dim_fun', Cardinal.mk_coe_finset, Finset.coe_sort_coe, Cardinal.lift_natCast,
      Cardinal.natCast_le] using
      cardinal_lift_le_dim_of_linear_independent'
        (linear_independent_smul_of_linear_independent G F hs)
#align fixed_points.dim_le_card FixedPoints.dim_le_card

end Fintype

section Finite

variable [Finite G]

instance normal : Normal (FixedPoints.subfield G F) F :=
  ⟨fun x => (isIntegral G F x).IsAlgebraic _, fun x =>
    (Polynomial.splits_id_iff_splits _).1 <|
      by
      cases nonempty_fintype G
      rw [← minpoly_eq_minpoly, minpoly, coe_algebra_map, ← Subfield.toSubring_subtype_eq_subtype,
        Polynomial.map_toSubring _ (Subfield G F).toSubring, prodXSubSmul]
      exact Polynomial.splits_prod _ fun _ _ => Polynomial.splits_X_sub_C _⟩
#align fixed_points.normal FixedPoints.normal

instance separable : IsSeparable (FixedPoints.subfield G F) F :=
  ⟨isIntegral G F, fun x => by
    cases nonempty_fintype G
    -- this was a plain rw when we were using unbundled subrings
    erw [← minpoly_eq_minpoly, ← Polynomial.separable_map (FixedPoints.subfield G F).Subtype,
      minpoly, Polynomial.map_toSubring _ (Subfield G F).toSubring]
    exact Polynomial.separable_prod_x_sub_c_iff.2 (injective_of_quotient_stabilizer G x)⟩
#align fixed_points.separable FixedPoints.separable

instance : FiniteDimensional (subfield G F) F :=
  by
  cases nonempty_fintype G
  exact
    IsNoetherian.iff_fg.1
      (IsNoetherian.iff_dim_lt_aleph0.2 <| (dim_le_card G F).trans_lt <| Cardinal.nat_lt_aleph0 _)

end Finite

theorem finrank_le_card [Fintype G] : finrank (subfield G F) F ≤ Fintype.card G :=
  by
  rw [← Cardinal.natCast_le, finrank_eq_dim]
  apply dim_le_card
#align fixed_points.finrank_le_card FixedPoints.finrank_le_card

end FixedPoints

theorem linearIndependent_toLinearMap (R : Type u) (A : Type v) (B : Type w) [CommSemiring R]
    [Ring A] [Algebra R A] [CommRing B] [IsDomain B] [Algebra R B] :
    LinearIndependent B (AlgHom.toLinearMap : (A →ₐ[R] B) → A →ₗ[R] B) :=
  have : LinearIndependent B (LinearMap.ltoFun R A B ∘ AlgHom.toLinearMap) :=
    ((linearIndependent_monoidHom A B).comp (coe : (A →ₐ[R] B) → A →* B) fun f g hfg =>
        AlgHom.ext <| MonoidHom.ext_iff.1 hfg :
      _)
  this.of_comp _
#align linear_independent_to_linear_map linearIndependent_toLinearMap

theorem cardinal_mk_algHom (K : Type u) (V : Type v) (W : Type w) [Field K] [Field V] [Algebra K V]
    [FiniteDimensional K V] [Field W] [Algebra K W] [FiniteDimensional K W] :
    Cardinal.mk (V →ₐ[K] W) ≤ finrank W (V →ₗ[K] W) :=
  cardinal_mk_le_finrank_of_linearIndependent <| linearIndependent_toLinearMap K V W
#align cardinal_mk_alg_hom cardinal_mk_algHom

noncomputable instance AlgEquiv.fintype (K : Type u) (V : Type v) [Field K] [Field V] [Algebra K V]
    [FiniteDimensional K V] : Fintype (V ≃ₐ[K] V) :=
  Fintype.ofEquiv (V →ₐ[K] V) (algEquivEquivAlgHom K V).symm
#align alg_equiv.fintype AlgEquiv.fintype

theorem finrank_algHom (K : Type u) (V : Type v) [Field K] [Field V] [Algebra K V]
    [FiniteDimensional K V] : Fintype.card (V →ₐ[K] V) ≤ finrank V (V →ₗ[K] V) :=
  fintype_card_le_finrank_of_linearIndependent <| linearIndependent_toLinearMap K V V
#align finrank_alg_hom finrank_algHom

namespace FixedPoints

theorem finrank_eq_card (G : Type u) (F : Type v) [Group G] [Field F] [Fintype G]
    [MulSemiringAction G F] [FaithfulSMul G F] :
    finrank (FixedPoints.subfield G F) F = Fintype.card G :=
  le_antisymm (FixedPoints.finrank_le_card G F) <|
    calc
      Fintype.card G ≤ Fintype.card (F →ₐ[FixedPoints.subfield G F] F) :=
        Fintype.card_le_of_injective _ (MulSemiringAction.toAlgHom_injective _ F)
      _ ≤ finrank F (F →ₗ[FixedPoints.subfield G F] F) := (finrank_algHom (fixedPoints G F) F)
      _ = finrank (FixedPoints.subfield G F) F := finrank_linear_map' _ _ _

#align fixed_points.finrank_eq_card FixedPoints.finrank_eq_card

/-- `mul_semiring_action.to_alg_hom` is bijective. -/
theorem toAlgHom_bijective (G : Type u) (F : Type v) [Group G] [Field F] [Finite G]
    [MulSemiringAction G F] [FaithfulSMul G F] :
    Function.Bijective (MulSemiringAction.toAlgHom _ _ : G → F →ₐ[subfield G F] F) :=
  by
  cases nonempty_fintype G
  rw [Fintype.bijective_iff_injective_and_card]
  constructor
  · exact MulSemiringAction.toAlgHom_injective _ F
  · apply le_antisymm
    · exact Fintype.card_le_of_injective _ (MulSemiringAction.toAlgHom_injective _ F)
    · rw [← finrank_eq_card G F]
      exact LE.le.trans_eq (finrank_algHom _ F) (finrank_linear_map' _ _ _)
#align fixed_points.to_alg_hom_bijective FixedPoints.toAlgHom_bijective

/-- Bijection between G and algebra homomorphisms that fix the fixed points -/
def toAlgHomEquiv (G : Type u) (F : Type v) [Group G] [Field F] [Fintype G] [MulSemiringAction G F]
    [FaithfulSMul G F] : G ≃ (F →ₐ[FixedPoints.subfield G F] F) :=
  Equiv.ofBijective _ (toAlgHom_bijective G F)
#align fixed_points.to_alg_hom_equiv FixedPoints.toAlgHomEquiv

end FixedPoints


variables P Q R :  Prop

example : (P → Q) ∧ (Q → R) → (P → R) :=
begin
    intros h,
    cases h with hpq hqr,
    intro hp,
    exact hqr (hpq hp),
end

/- Alternatively -/

example : (P → Q) ∧ (Q → R) → (P → R) :=
begin
    intro h,
    cases h with hpq hqr,
    intro hp,
    apply hqr (hpq hp),
end

/- Alternatively -/

example : (P → Q) ∧ (Q → R) → (P → R) :=
begin
intros h,
    have hpq : P → Q,
    exact h.left,
    have hqr : Q → R,
    exact h.right,
    clear h,
    intro hp,
    have hq : Q,
    exact hpq hp,
    exact hqr hq,
end


import Mathlib.Data.Real.Basic
import Mathlib.Algebra.Order.AbsoluteValue
import Mathlib.Tactic.Linarith
import Playground.Analysis.Topology

def Sequence := ℕ → ℝ

namespace Sequence
def of (u : ℕ → ℝ) : Sequence := u

section
  variable (u : Sequence)
  def TendsTo (l : ℝ) := ∀ ε > 0, ∃ N, ∀ n ≥ N, |u n - l| < ε

  def IsCauchy := ∀ ε > 0, ∃ N, ∀ n ≥ N, ∀ m ≥ N, |u n - u m| < ε

  def Increasing := ∀ n, u n ≤ u (n + 1)

  def Decreasing := ∀ n, u (n + 1) ≤ u n

  def image := Set.univ.image u

  def BoundedAbove := BddAbove u.image

  def BoundedBelow := BddBelow u.image

  def Bounded := u.BoundedAbove ∧ u.BoundedBelow
end

namespace IsCauchy
section
  variable {u : Sequence}
  theorem boundedAbove : u.IsCauchy → u.BoundedAbove := λ hu =>
    let ⟨N, h⟩ := hu 1 zero_lt_one
    have h := h N (le_refl _)
    let b := (u N) + 1
    have hb := by
      intro r ⟨n, ⟨_, hr⟩⟩
      rw [←hr]
      dsimp; have h := h
      sorry
    ⟨b, hb⟩

  theorem boundedBelow : u.IsCauchy → u.BoundedAbove := sorry

  theorem bounded : u.IsCauchy → u.Bounded := sorry

  noncomputable def limit : u.IsCauchy → ℝ := sorry

  theorem tendsTo_limit (hu : u.IsCauchy) : u.TendsTo hu.limit := sorry
end
end IsCauchy

section
  variable {u : Sequence}
  theorem TendsTo.isCauchy {l} : u.TendsTo l → u.IsCauchy := sorry

  theorem TendsTo.bounded {l} : u.TendsTo l → u.Bounded := λ h => h.isCauchy.bounded

  noncomputable def BoundedAbove.imageSup : u.BoundedAbove → ℝ := λ h =>
    (Real.exists_isLUB u.image ⟨u 0, ⟨0, ⟨⟨⟩, rfl⟩⟩⟩ h).choose

  theorem BoundedAbove.Increasing.tendsTo_imageSup (h : u.BoundedAbove) : u.Increasing →
    u.TendsTo h.imageSup := sorry

  noncomputable def BoundedBelow.imageInf : u.BoundedBelow → ℝ := sorry

  theorem BoundedBelow.Decreasing.tendsTo_imageInf (h : u.BoundedBelow) : u.Decreasing →
    u.TendsTo h.imageInf := sorry
end

def Constant (c : ℝ) := of λ _ => c

def le (u v : Sequence) := ∀ n, u n ≤ v n
instance : LE Sequence where le := le

end Sequence

noncomputable def Set.closure.sequence {s : Set ℝ} {x : ℝ} (hx : s.closure x)
  : Sequence :=
  λ n =>
    let r := (1 : ℝ) / n
    (hx r sorry).choose

theorem Set.closure.sequence_tendsTo {s : Set ℝ} {x : ℝ} (hx : s.closure x)
  : hx.sequence.TendsTo x :=
  sorry


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

/-!
# Invertibility of elements given a characteristic

This file includes some instances of `invertible` for specific numbers in
characteristic zero. Some more cases are given as a `def`, to be included only
when needed. To construct instances for concrete numbers,
`invertible_of_nonzero` is a useful definition.
-/

variables {K : Type*}

section field
variables [field K]

/-- A natural number `t` is invertible in a field `K` if the charactistic of `K` does not divide
`t`. -/
def invertible_of_ring_char_not_dvd
  {t : ℕ} (not_dvd : ¬(ring_char K ∣ t)) : invertible (t : K) :=
invertible_of_nonzero (λ h, not_dvd ((ring_char.spec K t).mp h))

lemma not_ring_char_dvd_of_invertible {t : ℕ} [invertible (t : K)] :
  ¬(ring_char K ∣ t) :=
begin
  rw [← ring_char.spec, ← ne.def],
  exact nonzero_of_invertible (t : K)
end

/-- A natural number `t` is invertible in a field `K` of charactistic `p` if `p` does not divide
`t`. -/
def invertible_of_char_p_not_dvd {p : ℕ} [char_p K p]
  {t : ℕ} (not_dvd : ¬(p ∣ t)) : invertible (t : K) :=
invertible_of_nonzero (λ h, not_dvd ((char_p.cast_eq_zero_iff K p t).mp h))

instance invertible_of_pos [char_zero K] (n : ℕ) [h : fact (0 < n)] :
  invertible (n : K) :=
invertible_of_nonzero $ by simpa [pos_iff_ne_zero] using h.out

end field

section division_ring
variables [division_ring K] [char_zero K]

instance invertible_succ (n : ℕ) : invertible (n.succ : K) :=
invertible_of_nonzero (nat.cast_ne_zero.mpr (nat.succ_ne_zero _))

/-!
A few `invertible n` instances for small numerals `n`. Feel free to add your own
number when you need its inverse.
-/

instance invertible_two : invertible (2 : K) :=
invertible_of_nonzero (by exact_mod_cast (dec_trivial : 2 ≠ 0))

instance invertible_three : invertible (3 : K) :=
invertible_of_nonzero (by exact_mod_cast (dec_trivial : 3 ≠ 0))

end division_ring


import chapter_1
import tactic.simps

namespace surreal

/-
This chapter is mostly about the protagonists trying to make sense of the text they found my defining some cleaner mathematical notation.

They define surreals concisely like this: `x = (Xₗ, Xᵣ) where Xₗ ≱ Xᵣ`
Here by `Xₗ ≱ Xᵣ` they mean that every `xₗ ≱ xᵣ` where `xₗ ∈ Xₗ` and `xᵣ ∈ Xᵣ`.

Capitals are generally used to denote sets, and the same lowercase letters denote elements from those sets.

In our case, the equivalent of `Xₗ` is simply `x.left`, and `Xᵣ` is `x.right`. For elements of those
sets, we tend to call them `xl` and `xr`, because it's just more confortable to read and write without those tiny subscripts.
-/

/-
We'll not take a small pause to define ≱ both for surreals and sets of surreals, since Lean's `has_le` doesn't include this variant automatically, and it is used extensively moving forward. Note that < might not strictly equivalent to ≱, we might prove it later on, but we shouldn't take it for granted.
-/

@[notation_class]
class has_nge (α β: Type*) := (nge : α → β → Prop)

/-
Left-binding power 50 is the same as other inequality operators.
https://leanprover.github.io/theorem_proving_in_lean/interacting_with_lean.html#notation
https://github.com/leanprover/lean/blob/master/library/init/core.lean#L50
-/
infix ` ≱ `:50 := has_nge.nge

def nge_num_num (x y: surreal): Prop :=
  ¬(x ≥ y)
@[simps] instance has_nge_num_num : has_nge surreal surreal := ⟨nge_num_num⟩

def nge_set_set (X Y: set surreal): Prop :=
  ∀ x ∈ X, ∀ y ∈ Y, x ≱ y
@[simps] instance has_nge_set_set : has_nge (set surreal) (set surreal) := ⟨nge_set_set⟩

/-
Let's take a moment to consider `x = (Xₗ, Xᵣ) where Xₗ ≱ Xᵣ`. It is nice and concise, but in my opinion it doesn't exactly match the wording from the rules.

It says: `no member of the left is greater than or equal to any member of the right set`

This, to me, literally translates to something like: there doesn't exist a pair of members of the left and right sets that are greater than or equal to each other. Or in mathematical notation: `¬∃ xl ∈ x.left, ∃ xr ∈ x.right, xl ≥ xr`, which is our definition for `valid`.

Whereas `Xₗ ≱ Xᵣ` here implies `∀ xl ∈ x.left, ∀ xr ∈ x.right, xl ≱ xr`, which is intuitively equivalent, but we should prove it is, just to be safe.
-/

lemma rule_1_nge (x: surreal): valid x.left x.right ↔ x.left ≱ x.right :=
begin
  simp [valid, nge_num_num, nge_set_set],
end

/-
Then they redefine the numbers with the new notation: `0 = (∅,∅)`, `-1 = (∅, {0})`, `1 = ({0}, ∅)`

Then they check if they are valid, and they find out that:
> If Xₗ or Xᵣ is empty, the condition Xₗ ≱ Xᵣ is true no matter what is in the other set.
-/

lemma valid_empty (L R: set surreal): L = ∅ ∨ R = ∅ → valid L R :=
begin
  simp [valid],
  intro h0,
  apply or.elim h0,
  begin
    intro L0,
    intros l lL r rR hge,
    rw L0 at lL,
    exact lL,
  end,
  begin
    intro R0,
    intros l lL r rR hge,
    rw R0 at rR,
    exact rR,
  end
end

/-
They also express `rule_2` with the new notation: `x ≤ y means Xₗ ≱ y and x ≱ Yᵣ`
-/

/-
They have now introduced ≱ between sets and numbers and viceversa. Let's define those then.
-/

def nge_set_num (X: set surreal) (y: surreal) :=
  ∀ x ∈ X, x ≱ y
@[simps] instance has_nge_set_num : has_nge (set surreal) surreal := ⟨nge_set_num⟩

def nge_num_set (x: surreal) (Y: set surreal) :=
  ∀ y ∈ Y, x ≱ y
@[simps] instance has_nge_num_set : has_nge surreal (set surreal) := ⟨nge_num_set⟩

/-
Again, the semantics differ somewhat from the original wording, so let's check that they are indeed
equivalent to our original definition from `rule_2`.
-/

lemma rule_2_nge (x y: surreal): x ≤ y ↔ x.left ≱ y ∧ x ≱ y.right :=
begin
  rw rule_2,
  simp [nge_set_num, nge_num_set, nge_num_num],
end

end surreal


import .love02_backward_proofs_exercise_sheet

/- # LoVe Homework 2: Backward Proofs

Homework must be done individually. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

namespace backward_proofs

/- ## Question 1 (4 points): Connectives and Quantifiers

1.1 (3 points). Complete the following proofs using basic tactics such as
`intro`, `apply`, and `exact`.

Hint: Some strategies for carrying out such proofs are described at the end of
Section 2.3 in the Hitchhiker's Guide. -/

lemma B (a b c : Prop) :
  (a → b) → (c → a) → c → b :=
sorry

lemma S (a b c : Prop) :
  (a → b → c) → (a → b) → a → c :=
sorry

lemma more_nonsense (a b c : Prop) :
  (c → (a → b) → a) → c → b → a :=
sorry

lemma even_more_nonsense (a b c : Prop) :
  (a → a → b) → (b → c) → a → b → c :=
sorry

/- 1.2 (1 point). Prove the following lemma using basic tactics. -/

lemma weak_peirce (a b : Prop) :
  ((((a → b) → a) → a) → b) → b :=
sorry

/- ## Question 2 (5 points): Logical Connectives

2.1 (1 point). Prove the following property about implication using basic
tactics.

Hints:

* Keep in mind that `¬ a` is the same as `a → false`. You can start by invoking
  `rw not_def` if this helps you.

* You will need to apply the elimination rules for `∨` and `false` at some
  point. -/

lemma about_implication (a b : Prop) :
  ¬ a ∨ b → a → b :=
sorry

/- 2.2 (2 points). Prove the missing link in our chain of classical axiom
implications.

Hints:

* You can use `rw double_negation` to unfold the definition of
  `double_negation`, and similarly for the other definitions.

* You will need to apply the double negation hypothesis for `a ∨ ¬ a`. You will
  also need the left and right introduction rules for `∨` at some point. -/

#check excluded_middle
#check peirce
#check double_negation

lemma em_of_dn :
  double_negation → excluded_middle :=
sorry

/- 2.3 (2 points). We have proved three of the six possible implications
between `excluded_middle`, `peirce`, and `double_negation`. State and prove the
three missing implications, exploiting the three theorems we already have. -/

#check peirce_of_em
#check dn_of_peirce
#check em_of_dn

-- enter your solution here

end backward_proofs

end LoVe


import tactic.induction
import tactic.ring_exp  -- for split_ifs
import .A_lists

/-
# 2. Trees
We'll prove CPS equivalences for the following tree functions:
* `inord`
* `fold`
* `find`

All higher-order functions are written as "fully-CPS" HOFs -- in particular,
any functional arguments must also be in CPS.
-/

inductive tree (α : Sort _)
| empty : tree
| node : α → tree → tree → tree

namespace tree

-- ## 2.1. `inord`
-- A basic inorder traversal of a tree
def inord {α : Sort _} : tree α → llist α
| tree.empty := llist.nil
| (tree.node x l r) := llist.append (inord l) (llist.cons x (inord r))

def inord_cps {α β : Sort _} : tree α → (llist α → β) → β
| tree.empty k := k llist.nil
| (tree.node x l r) k :=
  inord_cps l (λll,
    inord_cps r (λlr,
      llist.append_cps ll (llist.cons x lr) k
    )
  )

lemma inord_cps_equiv_inord {α β : Sort _} :
  ∀ (t : tree α) (k : llist α → β), inord_cps t k = k (inord t) :=
begin
  intro t,
  induction' t,
  case empty {
    intro k,
    refl,
  },
  case node : x l r ihl ihr {
    intro k,
    rw inord_cps,
    rw (ihl (λ (ll : llist α), r.inord_cps (λ (lr : llist α), ll.append_cps (llist.cons x lr) k))),
    -- as advised by https://leanprover-community.github.io/extras/simp.html, we
    -- avoid simp in the middle of a proof; this is merely to β-reduce
    dsimp only,
    rw (ihr (λ (lr : llist α), l.inord.append_cps (llist.cons x lr) k)),
    dsimp only,
    rw llist.append_cps_equiv_append,
    refl,  -- equivalently, rw ←inord
  }
end

-- ## 2.2. `fold`
-- A basic tree fold function
def fold {α β : Sort _} (f : α → β → β → β) (z : β) : tree α → β
| tree.empty := z
| (tree.node x l r) := f x (fold l) (fold r)

universe u
-- This has the same issue as the list foldr regarding type universes
-- def fold_cps {α : Sort _} {β γ : Sort u} (f : α → β → β → (β → γ) → γ) (z : β) :
--     tree α → (β → γ) → γ
-- | tree.empty k := k z
-- | (tree.node x l r) k := fold_cps l (λxl, fold_cps r (λxr, f x xl xr k))

def fold_cps {α β γ : Sort _} (f : α → β → β → (β → γ) → γ) (z : β) (t : tree α) :
    (β → γ) → γ :=
@tree.rec_on α (λ _, (β → γ) → γ) t
(λk, k z)
(λx l r lrec rrec k, lrec (λxl, rrec (λxr, f x xl xr k)))

-- Since using the recursor manually doesn't generate equation lemmas, we must
-- provide them manually
lemma fold_cps_eqn {α β γ : Sort _} (f : α → β → β → (β → γ) → γ) (z : β) (x l r) (k : β → γ) :
  fold_cps f z (tree.node x l r) k = fold_cps f z l (λxl, fold_cps f z r (λxr, f x xl xr k)) := rfl

lemma fold_cps_equiv_fold {α β γ : Sort _} :
  ∀ (f : α → β → β → β) (z : β) (t : tree α) (k : β → γ),
    fold_cps (λx l r k, k (f x l r)) z t k = k (fold f z t) :=
begin
  intros f z t,
  induction' t,
  case empty {
    intro k,
    refl,
  },
  case node : x l r ihl ihr {
    intro k,
    let f_cps := (λ(x : α) (l : β) (r : β) (k : β → γ), k (f x l r)),
    rw fold_cps_eqn,  -- would be "rw fold_cps" if we'd defined fold_cps normally
    rw (ihl f z (λxl, fold_cps f_cps z r (λxr, f_cps x xl xr k))),
    dsimp only,
    rw (ihr f z (λ (xr : β), f_cps x (fold f z l) xr k)),
    refl,
  }
end

-- ## 2.3. `find`
-- A basic find function on a tree: finds the first (preordered) element
-- satisfying a decidable predicate p
def find {α : Sort _} (p : α → Prop) [decidable_pred p] : tree α → option α
| tree.empty := none
| (tree.node x l r) :=
  if p x
  then x
  else match find l with
       | none := find r
       | res := res
       end

/-
 A CPS version of find. We opt here for a simple success/failure continuation
 format; an alternative implementation might allow the predicate to pass
 "evidence" of success or failure to each continuation. For our purposes,
 however, this implementation seems reasonable (and already sufficiently
 complicated).
-/
def find_cps {α β : Sort _} (p : α → (unit → β) → (unit → β) → β) :
  tree α → (α → β) → (unit → β) → β
| tree.empty sk fk := fk ()
| (tree.node x l r) sk fk := p x (λ_, sk x)
                                 (λ_, find_cps l sk (λ_, find_cps r sk fk))

/-
 This helper lemma is slightly more general than the equivalence we want to
 prove because we need a more general induction hypothesis (namely, the failure
 continuation is not always (λ_, none) in recursive calls, so we can't restrict
 ourselves to that in the general proposition); we'll recover
 find_cps_equiv_find as an instance of this.
-/
lemma find_cps_equiv_find_helper {α : Sort _} (p : α → Prop) [decidable_pred p]  :
  ∀ (t : tree α) (fk : unit → option α),
    find_cps (λx sk fk, if p x then sk () else fk ())
             t
             some
             fk
    = (find p t <|> fk ()) :=
begin
  intro t,
  induction' t,
  case empty {
    intro fk,
    rw [find_cps, find],
    unfold has_orelse.orelse,
    rw option.none_orelse',
  },
  case node : x l r ihl ihr {
    intro fk,
    rw find_cps,
    -- Deal with bug in synthesis of decidability type-class by explicitly
    -- resetting the index. Note that we need to do this here because otherwise
    -- split_ifs is going to rely on classical.choice and a bunch of other
    -- very non-constructive (and unnecessary) axioms
    resetI,
    split_ifs,
    {
      -- case p x true
      rw find,
      split_ifs,
      exact with_top.some_eq_coe x,
    },
    {
      -- case p x false
      rw (ihr p fk),
      rw (ihl p (λ (_x : unit), find p r <|> fk ())),
      rw find,
      split_ifs, -- by case assumption, p x ==> false
      cases' (find p l),
      case some {
        -- case find p l ==> some x
        rw find._match_1,
        refl,
      },
      case none {
        -- case find p l ==> none
        rw find._match_1,
        unfold has_orelse.orelse,
        cases' (find p r),
        case some {
          -- case find p l ==> none AND find p r ==> some x
          rw option.none_orelse',
        },
        case none {
          -- case find p r ==> none AND find p r ==> none
          rw option.none_orelse',
        }
      }
    }
  }
end

-- We recover the desired equivalence as an instance of the helper
lemma find_cps_equiv_find {α : Sort _} (p : α → Prop) [decidable_pred p]  :
  ∀ (t : tree α),
    find_cps (λx sk fk, if p x then sk () else fk ())
             t
             some
             (λ_, none)
    = find p t :=
begin
  intro t,
  have h := find_cps_equiv_find_helper p t (λ_, none),
  unfold has_orelse.orelse at h,
  have h_orelse : ∀(x : option α), option.orelse x none = x :=
    λx, by cases' x; refl,
  rw h_orelse at h,
  exact h,
end

end tree


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.of_associative
import linear_algebra.matrix.reindex
import linear_algebra.matrix.to_linear_equiv

/-!
# Lie algebras of matrices

An important class of Lie algebras are those arising from the associative algebra structure on
square matrices over a commutative ring. This file provides some very basic definitions whose
primary value stems from their utility when constructing the classical Lie algebras using matrices.

## Main definitions

  * `lie_equiv_matrix'`
  * `matrix.lie_conj`
  * `matrix.reindex_lie_equiv`

## Tags

lie algebra, matrix
-/

universes u v w w₁ w₂

section matrices
open_locale matrix

variables {R : Type u} [comm_ring R]
variables {n : Type w} [decidable_eq n] [fintype n]

/-- The natural equivalence between linear endomorphisms of finite free modules and square matrices
is compatible with the Lie algebra structures. -/
def lie_equiv_matrix' : module.End R (n → R) ≃ₗ⁅R⁆ matrix n n R :=
{ map_lie' := λ T S,
  begin
    let f := @linear_map.to_matrix' R _ n n _ _,
    change f (T.comp S - S.comp T) = (f T) * (f S) - (f S) * (f T),
    have h : ∀ (T S : module.End R _), f (T.comp S) = (f T) ⬝ (f S) := linear_map.to_matrix'_comp,
    rw [linear_equiv.map_sub, h, h, matrix.mul_eq_mul, matrix.mul_eq_mul],
  end,
  ..linear_map.to_matrix' }

@[simp] lemma lie_equiv_matrix'_apply (f : module.End R (n → R)) :
  lie_equiv_matrix' f = f.to_matrix' := rfl

@[simp] lemma lie_equiv_matrix'_symm_apply (A : matrix n n R) :
  (@lie_equiv_matrix' R _ n _ _).symm A = A.to_lin' := rfl

/-- An invertible matrix induces a Lie algebra equivalence from the space of matrices to itself. -/
def matrix.lie_conj (P : matrix n n R) (h : invertible P) :
  matrix n n R ≃ₗ⁅R⁆ matrix n n R :=
((@lie_equiv_matrix' R _ n _ _).symm.trans (P.to_linear_equiv' h).lie_conj).trans lie_equiv_matrix'

@[simp] lemma matrix.lie_conj_apply (P A : matrix n n R) (h : invertible P) :
  P.lie_conj h A = P ⬝ A ⬝ P⁻¹ :=
by simp [linear_equiv.conj_apply, matrix.lie_conj, linear_map.to_matrix'_comp,
         linear_map.to_matrix'_to_lin']

@[simp] lemma matrix.lie_conj_symm_apply (P A : matrix n n R) (h : invertible P) :
  (P.lie_conj h).symm A = P⁻¹ ⬝ A ⬝ P :=
by simp [linear_equiv.symm_conj_apply, matrix.lie_conj, linear_map.to_matrix'_comp,
         linear_map.to_matrix'_to_lin']

variables {m : Type w₁} [decidable_eq m] [fintype m] (e : n ≃ m)

/-- For square matrices, the natural map that reindexes a matrix's rows and columns with equivalent
types, `matrix.reindex`, is an equivalence of Lie algebras. -/
def matrix.reindex_lie_equiv : matrix n n R ≃ₗ⁅R⁆ matrix m m R :=
{ to_fun := matrix.reindex e e,
  map_lie' := λ M N, by simp only [lie_ring.of_associative_ring_bracket, matrix.reindex_apply,
    matrix.submatrix_mul_equiv, matrix.mul_eq_mul, matrix.submatrix_sub, pi.sub_apply],
  ..(matrix.reindex_linear_equiv R R e e) }

@[simp] lemma matrix.reindex_lie_equiv_apply (M : matrix n n R) :
  matrix.reindex_lie_equiv e M = matrix.reindex e e M := rfl

@[simp] lemma matrix.reindex_lie_equiv_symm :
  (matrix.reindex_lie_equiv e : _ ≃ₗ⁅R⁆ _).symm = matrix.reindex_lie_equiv e.symm := rfl

end matrices


import Hm.Set
import Hm.Relation

class HasPrec (α : Sort u) where
  Prec : α → α → Sort v

export HasPrec (Prec)

class HasPrecEq (α : Sort u) where
  PrecEq : α → α → Sort v

export HasPrecEq (PrecEq)

infix:55 " ≺ " => HasPrec.Prec
infix:55 " ≼ " => HasPrecEq.PrecEq

class PartialOrder {α : Type _} (rel : RelationOn α) where
  reflexive : reflexive rel
  antisymmetrical : antisymmetrical rel
  transitive : transitive rel

class StrictPartialOrder {α : Type _} (rel : RelationOn α) where
  irreflexive : irreflexive rel
  asymmetrical : asymmetrical rel
  transitive : transitive rel

/-
These instances allow us to use ≺ and ≼ (denoted with \prec \preceq)
when we know there exist PartialOrder Relations on a type α

variable (α : Type u) (a b : α) (R : RelationOn α) [PartialOrder R]
#check a ≼ b

And

variable (α : Type u) (a b : α) (R : RelationOn α) [StrictPartialOrder R]
#check a ≺ b

However you have to be careful about this in the presence of multiple
PartialOrder / StrictPartialOrder relations at once since lean will
automatically pick one according to what it thinks is best. This might
however not be what you think is best
-/

instance {R : RelationOn α} [PartialOrder R] : HasPrecEq α where
  PrecEq := λ a b => (a, b) ∈ R

instance {R : RelationOn α} [StrictPartialOrder R] : HasPrec α where
  Prec := λ a b => (a, b) ∈ R

def comparable {α : Type u} (R : RelationOn α) [PartialOrder R] (a : α) (b : α) : Prop := a ≼ b ∨ b ≼ a

def strict_comparable {α : Type u} (R : RelationOn α) [StrictPartialOrder R] (a : α) (b : α) : Prop := a ≺ b ∨ b ≺ a

class TotalOrder {α : Type _} (rel : RelationOn α) extends PartialOrder rel where
  total : ∀ a b, comparable rel a b

class StrictTotalOrder {α : Type _} (rel : RelationOn α) extends StrictPartialOrder rel where
  total : ∀ a b, strict_comparable rel a b

namespace PartialOrder

def minimum (R : RelationOn α) [PartialOrder R] (x : α) : Prop := ¬(∃ y, y ≠ x ∧ y ≼ x)
def topoligical_sorting (TR : RelationOn α) [TotalOrder TR] (R : RelationOn α) [PartialOrder R] : Prop :=
  R ⊆ TR

inductive Chain {α : Type u} (R: RelationOn α) [PartialOrder R] : List α → Prop where
| single : Chain R [a]
| cons_cons (preceq: a ≼ b) (neq: a ≠ b) : Chain R (b :: l) → Chain R (a :: b :: l)

-- A Tactic that can do stuff like this automatically might be interesting
example [PartialOrder (Nat.le : RelationOn Nat)]: Chain (Nat.le : RelationOn Nat) [0, 1, 2] := by
  apply Chain.cons_cons
  case preceq =>
    exact Nat.le.step $ Nat.le.refl
  case neq =>
    intro h
    injection h
  case a =>
    apply Chain.cons_cons
    case preceq =>
      exact Nat.le.step $ Nat.le.refl
    case neq =>
      intro h
      injection h with h
      injection h
    case a =>
      exact Chain.single
end PartialOrder

namespace StrictPartialOrder

def minimum (R : RelationOn α) [StrictPartialOrder R] (x : α) : Prop := ¬(∃y, y ≠ x ∧ y ≺ x)
def topoligical_sorting (TR : RelationOn α) [StrictTotalOrder TR] (R : RelationOn α) [StrictPartialOrder R] : Prop :=
  R ⊆ TR

inductive Chain {α : Type u} (R: RelationOn α) [StrictPartialOrder R] : List α → Prop where
| single : Chain R [a]
| cons_cons (prec: a ≺ b) : Chain R (b :: l) → Chain R (a :: b :: l)

example [StrictPartialOrder (Nat.lt : RelationOn Nat)]: Chain (Nat.lt : RelationOn Nat) [0, 1, 2] := by
  apply Chain.cons_cons
  case prec =>
    exact Nat.lt.base 0
  case a =>
    apply Chain.cons_cons
    case prec =>
      exact Nat.lt.base 1
    case a =>
      exact Chain.single

end StrictPartialOrder


/-
Copyright (c) 2023 Kexing Ying. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kexing Ying

! This file was ported from Lean 3 source module probability.kernel.invariance
! leanprover-community/mathlib commit 97d1aa955750bd57a7eeef91de310e633881670b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Probability.Kernel.Composition

/-!
# Invariance of measures along a kernel

We define the push-forward of a measure along a kernel which results in another measure. In the
case that the push-forward measure is the same as the original measure, we say that the measure is
invariant with respect to the kernel.

## Main definitions

* `probability_theory.kernel.map_measure`: the push-forward of a measure along a kernel.
* `probability_theory.kernel.invariant`: invariance of a given measure with respect to a kernel.

## Useful lemmas

* `probability_theory.kernel.comp_apply_eq_map_measure`,
  `probability_theory.kernel.const_map_measure_eq_comp_const`, and
  `probability_theory.kernel.comp_const_apply_eq_map_measure` established the relationship between
  the push-forward measure and the composition of kernels.

-/

open MeasureTheory

open MeasureTheory ENNReal ProbabilityTheory

namespace ProbabilityTheory

variable {α β γ : Type _} {mα : MeasurableSpace α} {mβ : MeasurableSpace β} {mγ : MeasurableSpace γ}

include mα mβ

namespace Kernel

/-! ### Push-forward of measures along a kernel -/

/-- The push-forward of a measure along a kernel. -/
noncomputable def mapMeasure (κ : kernel α β) (μ : Measure α) : Measure β :=
  Measure.ofMeasurable (fun s hs => ∫⁻ x, κ x s ∂μ)
    (by simp only [measure_empty, lintegral_const, MulZeroClass.zero_mul])
    (by
      intro f hf₁ hf₂
      simp_rw [measure_Union hf₂ hf₁,
        lintegral_tsum fun i => (kernel.measurable_coe κ (hf₁ i)).AeMeasurable])
#align probability_theory.kernel.map_measure ProbabilityTheory.kernel.mapMeasure

@[simp]
theorem mapMeasure_apply (κ : kernel α β) (μ : Measure α) {s : Set β} (hs : MeasurableSet s) :
    mapMeasure κ μ s = ∫⁻ x, κ x s ∂μ := by rw [map_measure, measure.of_measurable_apply s hs]
#align probability_theory.kernel.map_measure_apply ProbabilityTheory.kernel.mapMeasure_apply

@[simp]
theorem mapMeasure_zero (κ : kernel α β) : mapMeasure κ 0 = 0 :=
  by
  ext1 s hs
  rw [map_measure_apply κ 0 hs, lintegral_zero_measure, measure.coe_zero, Pi.zero_apply]
#align probability_theory.kernel.map_measure_zero ProbabilityTheory.kernel.mapMeasure_zero

@[simp]
theorem mapMeasure_add (κ : kernel α β) (μ ν : Measure α) :
    mapMeasure κ (μ + ν) = mapMeasure κ μ + mapMeasure κ ν :=
  by
  ext1 s hs
  rw [map_measure_apply κ (μ + ν) hs, lintegral_add_measure, measure.coe_add, Pi.add_apply,
    map_measure_apply κ μ hs, map_measure_apply κ ν hs]
#align probability_theory.kernel.map_measure_add ProbabilityTheory.kernel.mapMeasure_add

@[simp]
theorem mapMeasure_smul (κ : kernel α β) (μ : Measure α) (r : ℝ≥0∞) :
    mapMeasure κ (r • μ) = r • mapMeasure κ μ :=
  by
  ext1 s hs
  rw [map_measure_apply κ (r • μ) hs, lintegral_smul_measure, measure.coe_smul, Pi.smul_apply,
    map_measure_apply κ μ hs, smul_eq_mul]
#align probability_theory.kernel.map_measure_smul ProbabilityTheory.kernel.mapMeasure_smul

include mγ

theorem comp_apply_eq_mapMeasure (η : kernel β γ) [IsSFiniteKernel η] (κ : kernel α β)
    [IsSFiniteKernel κ] (a : α) : (η ∘ₖ κ) a = mapMeasure η (κ a) :=
  by
  ext1 s hs
  rw [comp_apply η κ a hs, map_measure_apply η _ hs]
#align probability_theory.kernel.comp_apply_eq_map_measure ProbabilityTheory.kernel.comp_apply_eq_mapMeasure

omit mγ

theorem const_mapMeasure_eq_comp_const (κ : kernel α β) [IsSFiniteKernel κ] (μ : Measure α)
    [IsFiniteMeasure μ] : const α (mapMeasure κ μ) = κ ∘ₖ const α μ :=
  by
  ext1 a; ext1 s hs
  rw [const_apply, map_measure_apply _ _ hs, comp_apply _ _ _ hs, const_apply]
#align probability_theory.kernel.const_map_measure_eq_comp_const ProbabilityTheory.kernel.const_mapMeasure_eq_comp_const

theorem comp_const_apply_eq_mapMeasure (κ : kernel α β) [IsSFiniteKernel κ] (μ : Measure α)
    [IsFiniteMeasure μ] (a : α) : (κ ∘ₖ const α μ) a = mapMeasure κ μ := by
  rw [← const_apply (map_measure κ μ) a, const_map_measure_eq_comp_const κ μ]
#align probability_theory.kernel.comp_const_apply_eq_map_measure ProbabilityTheory.kernel.comp_const_apply_eq_mapMeasure

theorem lintegral_mapMeasure (κ : kernel α β) [IsSFiniteKernel κ] (μ : Measure α)
    [IsFiniteMeasure μ] {f : β → ℝ≥0∞} (hf : Measurable f) :
    (∫⁻ b, f b ∂mapMeasure κ μ) = ∫⁻ a, ∫⁻ b, f b ∂κ a ∂μ :=
  by
  by_cases hα : Nonempty α
  · have := const_apply μ hα.some
    swap
    infer_instance
    conv_rhs => rw [← this]
    rw [← lintegral_comp _ _ _ hf, ← comp_const_apply_eq_map_measure κ μ hα.some]
  · haveI := not_nonempty_iff.1 hα
    rw [μ.eq_zero_of_is_empty, map_measure_zero, lintegral_zero_measure, lintegral_zero_measure]
#align probability_theory.kernel.lintegral_map_measure ProbabilityTheory.kernel.lintegral_mapMeasure

omit mβ

/-! ### Invariant measures of kernels -/

/-- A measure `μ` is invariant with respect to the kernel `κ` if the push-forward measure of `μ`
along `κ` equals `μ`. -/
def Invariant (κ : kernel α α) (μ : Measure α) : Prop :=
  mapMeasure κ μ = μ
#align probability_theory.kernel.invariant ProbabilityTheory.kernel.Invariant

variable {κ η : kernel α α} {μ : Measure α}

theorem Invariant.def (hκ : Invariant κ μ) : mapMeasure κ μ = μ :=
  hκ
#align probability_theory.kernel.invariant.def ProbabilityTheory.kernel.Invariant.def

theorem Invariant.comp_const [IsSFiniteKernel κ] [IsFiniteMeasure μ] (hκ : Invariant κ μ) :
    κ ∘ₖ const α μ = const α μ := by rw [← const_map_measure_eq_comp_const κ μ, hκ.def]
#align probability_theory.kernel.invariant.comp_const ProbabilityTheory.kernel.Invariant.comp_const

theorem Invariant.comp [IsSFiniteKernel κ] [IsSFiniteKernel η] [IsFiniteMeasure μ]
    (hκ : Invariant κ μ) (hη : Invariant η μ) : Invariant (κ ∘ₖ η) μ :=
  by
  by_cases hα : Nonempty α
  ·
    simp_rw [invariant, ← comp_const_apply_eq_map_measure (κ ∘ₖ η) μ hα.some, comp_assoc,
      hη.comp_const, hκ.comp_const, const_apply]
  · haveI := not_nonempty_iff.1 hα
    exact Subsingleton.elim _ _
#align probability_theory.kernel.invariant.comp ProbabilityTheory.kernel.Invariant.comp

end Kernel

end ProbabilityTheory


/-
Copyright (c) 2021 Manuel Candales. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Manuel Candales
-/
import data.real.basic
import data.real.sqrt
import data.nat.prime
import number_theory.primes_congruent_one
import number_theory.legendre_symbol.quadratic_reciprocity
import tactic.linear_combination

/-!
# IMO 2008 Q3
Prove that there exist infinitely many positive integers `n` such that `n^2 + 1` has a prime
divisor which is greater than `2n + √(2n)`.

# Solution
We first prove the following lemma: for every prime `p > 20`, satisfying `p ≡ 1 [MOD 4]`,
there exists `n ∈ ℕ` such that `p ∣ n^2 + 1` and `p > 2n + √(2n)`. Then the statement of the
problem follows from the fact that there exist infinitely many primes `p ≡ 1 [MOD 4]`.

To prove the lemma, notice that `p ≡ 1 [MOD 4]` implies `∃ n ∈ ℕ` such that `n^2 ≡ -1 [MOD p]`
and we can take this `n` such that `n ≤ p/2`. Let `k = p - 2n ≥ 0`. Then we have:
`k^2 + 4 = (p - 2n)^2 + 4 ≣ 4n^2 + 4 ≡ 0 [MOD p]`. Then `k^2 + 4 ≥ p` and so `k ≥ √(p - 4) > 4`.
Then `p = 2n + k ≥ 2n + √(p - 4) = 2n + √(2n + k - 4) > √(2n)` and we are done.
-/

open real

lemma p_lemma (p : ℕ) (hpp : nat.prime p) (hp_mod_4_eq_1 : p ≡ 1 [MOD 4]) (hp_gt_20 : p > 20) :
  ∃ n : ℕ, p ∣ n ^ 2 + 1 ∧ (p : ℝ) > 2 * n + sqrt(2 * n) :=
begin
  haveI := fact.mk hpp,
  have hp_mod_4_ne_3 : p % 4 ≠ 3, { linarith [(show p % 4 = 1, by exact hp_mod_4_eq_1)] },
  obtain ⟨y, hy⟩ := zmod.exists_sq_eq_neg_one_iff.mpr hp_mod_4_ne_3,

  let m := zmod.val_min_abs y,
  let n := int.nat_abs m,

  have hnat₁ : p ∣ n ^ 2 + 1,
  { refine int.coe_nat_dvd.mp _,
    simp only [int.nat_abs_sq, int.coe_nat_pow, int.coe_nat_succ, int.coe_nat_dvd.mp],
    refine (zmod.int_coe_zmod_eq_zero_iff_dvd (m ^ 2 + 1) p).mp _,
    simp only [int.cast_pow, int.cast_add, int.cast_one, zmod.coe_val_min_abs],
    rw [pow_two, ← hy], exact add_left_neg 1 },

  have hnat₂ : n ≤ p / 2 := zmod.nat_abs_val_min_abs_le y,
  have hnat₃ : p ≥ 2 * n, { linarith [nat.div_mul_le_self p 2] },

  set k : ℕ := p - 2 * n with hnat₄,

  have hnat₅ : p ∣ k ^ 2 + 4,
  { cases hnat₁ with x hx,
    have : (p:ℤ) ∣ k ^ 2 + 4,
    { use (p:ℤ) - 4 * n + 4 * x,
      have hcast₁ : (k:ℤ) = p - 2 * n, { assumption_mod_cast },
      have hcast₂ : (n:ℤ) ^ 2 + 1 = p * x, { assumption_mod_cast },
      linear_combination ((k:ℤ) + p - 2 * n)*hcast₁ + 4*hcast₂ },
    assumption_mod_cast },

  have hnat₆ : k ^ 2 + 4 ≥ p := nat.le_of_dvd (k ^ 2 + 3).succ_pos hnat₅,

  have hreal₁ : (k:ℝ) = p - 2 * n, { assumption_mod_cast },
  have hreal₂ : (p:ℝ) > 20,        { assumption_mod_cast },
  have hreal₃ : (k:ℝ) ^ 2 + 4 ≥ p, { assumption_mod_cast },

  have hreal₅ : (k:ℝ) > 4,
  { refine lt_of_pow_lt_pow 2 k.cast_nonneg _,
    linarith only [hreal₂, hreal₃] },

  have hreal₆ : (k:ℝ) > sqrt (2 * n),
  { refine lt_of_pow_lt_pow 2 k.cast_nonneg _,
    rw sq_sqrt (mul_nonneg zero_le_two n.cast_nonneg),
    linarith only [hreal₁, hreal₃, hreal₅] },

  exact ⟨n, hnat₁, by linarith only [hreal₆, hreal₁]⟩,
end

theorem imo2008_q3 : ∀ N : ℕ, ∃ n : ℕ, n ≥ N ∧
  ∃ p : ℕ, nat.prime p ∧ p ∣ n ^ 2 + 1 ∧ (p : ℝ) > 2 * n + sqrt(2 * n) :=
begin
  intro N,
  obtain ⟨p, hpp, hineq₁, hpmod4⟩ := nat.exists_prime_gt_modeq_one (N ^ 2 + 20) four_ne_zero,
  obtain ⟨n, hnat, hreal⟩ := p_lemma p hpp hpmod4 (by linarith [hineq₁, nat.zero_le (N ^ 2)]),

  have hineq₂  : n ^ 2 + 1 ≥ p := nat.le_of_dvd (n ^ 2).succ_pos hnat,
  have hineq₃  : n * n ≥ N * N, { linarith [hineq₁, hineq₂] },
  have hn_ge_N : n ≥ N := nat.mul_self_le_mul_self_iff.mpr hineq₃,

  exact ⟨n, hn_ge_N, p, hpp, hnat, hreal⟩,
end