-- a "possible world" is just a non-negative integer w, representing
-- the number of blue-eyed islanders in that world.

-- If d (the day) and s (the number of are also non-negative integers, the function thinks(d,s,w) represents an
-- islander's opinion of possible world w on day d, given that they can
-- see s blue-eyed islanders and we have made it to day d without anyone leaving.
-- The output of the function is either "true",
-- meaning "I think that this is still logically possible", or "false", meaning "this
-- world is not possible any more".

def thinks : ℕ → ℕ → ℕ → Prop
-- on day zero...
| 0 s w :=
              -- "my eyes are either blue or brown, and..."
              (w = s ∨ w = s + 1) ∧
              -- "the traveller said there is a blue-eyed islander so w=0 is not a possible world"
              (w ≠ 0)
-- on day d+1, if nobody left on day d,
| (d+1) s w :=
          -- "I still know everything that I knew yesterday, and..."
              (thinks d s w) ∧
                -- I also know that whatever colour my eyes _actually_ are,
                -- the blue-eyed islanders could not work out their eye colour yesterday.
                -- Hence one of the following is true:
                ( -- either I have blue eyes and I couldn't work this out yesterday
                  -- because I couldn't rule out having brown eyes
                  (w=s+1 ∧ thinks d s s)
                  -- or
                  ∨
                  -- I have brown eyes and the blue-eyed Islanders could not
                  -- figure out their eye colour because there was more than one possibility
                  (w=s ∧ s ≠ 0 ∧ thinks d (s-1) (s-1) ∧ thinks d (s-1) s)
                )
--test suite

-- if there are 3 blue-eyed islanders then even on day 0 they
-- must believe that there are either 3 or 4 blue eyed islanders.
example : thinks 0 3 0 → false := by unfold thinks;simp

example : thinks 0 3 7 → false := begin
unfold thinks,
exact dec_trivial,
end

-- If there is one blue-eyed islander then on day 1 he leaves so we cannot find
-- islanders (with blue or brown eyes) mulling this situation over on day 2

-- Here's what this looks like as a brown-eyed islander:
example : thinks 2 1 1 → false := begin
unfold thinks,
simp,exact dec_trivial,
end

-- Here's what this looks like to a blue-eyed islander:

example : thinks 2 0 1 → false := begin
unfold thinks,
simp,
end

-- So in general we cannot get to day 2 with no leavers if there is one blue-eyed islander.

example : ∀ s, thinks 2 s 1 → false := begin
intro s,cases s with t,
unfold thinks,simp,
cases t with u,
unfold thinks,simp,exact dec_trivial,
unfold thinks,intro H,
have H2:= H.left.left.left,
revert H2,
exact dec_trivial,
end

-- Basic lemma with easy induction proof: if (on any day at all) an Islander
-- can see s blue-eyed islanders, then the only possible worlds have
-- w=s or w=s+1.

lemma blue_or_brown (d s w) : thinks d s w → w = s ∨ w = s + 1 :=
begin
induction d with d Hd,
{ exact and.elim_left },
intro H,
apply Hd,
exact H.left
end

-- The general theorem is that for all worlds w, we cannot make it to day w+1

theorem blue_eyed_islanders_leave : ∀ w, ∀ s, thinks (w+1) s w → false := begin
intro w,
induction w with w Hw,
-- base case easy
{ intros s H,
  unfold thinks at H,
  let H3 : 0 ≠ 0 := H.left.right,
  apply H3,simp,
},
-- inductive step
intros s H, -- H : thinks (nat.succ w + 1) s (nat.succ w)
-- d=w+1,w=w+1
have H2 : thinks (w+1) s (w+1)
          ∧ ((w+1=s+1 ∧ thinks (w+1) s s)
           ∨ (w+1=s ∧ s≠0 ∧ thinks (w+1) (s-1) (s-1) ∧ thinks (w+1) (s-1) s)),
  exact H,
clear H,
have H3 : ((w+1=s+1 ∧ thinks (w+1) s s)
           ∨ (w+1=s ∧ s≠0 ∧ thinks (w+1) (s-1) (s-1) ∧ thinks (w+1) (s-1) s)),
exact H2.right,
clear H2,
cases H3 with H4 H5,
{ apply (Hw s),
  have H6 : w = s := nat.succ_inj H4.1,
  have H7 : thinks (w+1) s s = thinks (w+1) s w := congr_arg (λ t, thinks (w+1) s t) (eq.symm H6),
  rw eq.symm H7,
  exact H4.right
},
{ have H1 : w=s-1,rw H5.left.symm,simp,
  apply Hw (s-1),
  have H2 : thinks (w + 1) (s - 1) w = thinks (w + 1) (s - 1) (s - 1) :=
    congr_arg _ H1,
  rw H2,
  exact H5.right.right.left
}
end


import .src_ordered_field tactic

namespace mth1001

namespace myreal

section ordered

variables {R : Type} [myordered_field R]

open_locale classical

open myordered_field

lemma pos_one : pos (1 : R) :=
begin
  rcases trichotomy (1 : R) with ⟨hpo, _, _ ⟩ | ⟨_, hoe, _ ⟩  | ⟨hnpo, hnoe, hpno⟩ ,
  { exact hpo, },
  { exact absurd hoe zero_ne_one.symm, },
  { exfalso, apply hnpo,
    convert pos_mul_of_pos_of_pos _ _ hpno hpno,
    rw [neg_mul_neg_self, one_mul], },
end

lemma pos_nat (n : ℕ) : n ≠ 0 → pos (n : R) :=
begin
  induction n with k hk,
  { intro _, contradiction, },
  { intro _,
    rw coe_nat_succ,
    by_cases h₁ : k = 0,
    { rw h₁,
      change pos((0 : R) + (1 : R)),
      rw zero_add,
      exact pos_one, },
    { exact pos_add_of_pos_of_pos _ _ (hk h₁) pos_one }, },
end

lemma lt_iff_pos_sub (x y : R) : x < y ↔ pos (y -x) := by refl

lemma lt_iff_pos_neg (x y : R) : x < y ↔ pos (y + -x) := by refl

lemma zero_lt_one' : (0 : R) < (1 : R) :=
begin
  rw [lt_iff_pos_sub, sub_zero],
  exact pos_one,
end

lemma gt_zero_mul_of_gt_zero_of_gt_zero {a b : R} (h₁ : 0 < a) (h₂ : 0 < b) : 0 < a * b :=
begin
  rw [lt_iff_pos_sub, sub_zero] at *,
  exact pos_mul_of_pos_of_pos a b h₁ h₂,
end

lemma mul_pos (a b : R) : 0 < a → 0 < b → 0 < a * b :=
begin
  intros h₁ h₂,
  rw [lt_iff_pos_sub, sub_zero] at *,
  exact pos_mul_of_pos_of_pos a b h₁ h₂,
end

lemma neg_pos {x : R} : 0 < -x ↔ x < 0:=
begin
  repeat {rw lt_iff_pos_neg},
  rw zero_add,
  have : -(0 : R) = (0 : R),
  { rw [←add_zero (-(0 : R) : R), neg_add], },
  rw [this, add_zero],
end

lemma trichotomy' (x y: R) : x < y ∧ ¬x = y ∧ ¬y < x ∨
                               ¬x < y ∧ x = y ∧ ¬y < x ∨
                               ¬x < y ∧ ¬x = y ∧ y < x :=
begin
  repeat {rw lt_iff_pos_sub},
  have : x - y = -(y - x),
  { rw [sub_eq_add_neg', sub_eq_add_neg', neg_add_eq_neg_add_neg', neg_neg], },
  rw this,
  rw [@eq_comm _ x y, (sub_eq_zero_iff_eq y x).symm],
  exact trichotomy (y + -x),
end

lemma lt_trans {x y z : R} : x < y → y < z → x < z :=
begin
  repeat {rw lt_iff_pos_sub},
  intros pyx pzy,
  have : z - x = (z - y) + (y - x),
  { repeat {rw sub_eq_add_neg'},
    rw [←add_assoc, add_assoc z _ _, neg_add, add_zero], },
  rw this,
  exact pos_add_of_pos_of_pos _ _ pzy pyx,
end

lemma add_lt_add_iff_right_mpr {x y : R} (z : R) : x < y → x + z < y + z :=
begin
  repeat {rw lt_iff_pos_sub},
  apply eq.substr,
  rw [sub_eq_add_neg', neg_add_eq_neg_add_neg', ←add_assoc],
  rw [add_assoc y, add_neg', add_zero, sub_eq_add_neg'],
end

lemma add_lt_add_iff_right_mp {x y : R} (z : R) : x + z < y + z → x < y :=
begin
  intro h,
  convert add_lt_add_iff_right_mpr (-z) h;
  rw [add_assoc, add_neg', add_zero],
end

lemma add_lt_add_iff_right {x y : R} (z : R) : x + z < y + z ↔ x < y :=
iff.intro (add_lt_add_iff_right_mp z) (add_lt_add_iff_right_mpr z)

theorem neg_lt_neg_iff  {a b : R} : -a < -b ↔ b < a :=
begin
  have h₁ : -a < -b ↔ -a + a < -b + a, from (add_lt_add_iff_right a).symm,
  have h₂ : b < a ↔ b + -a < a + -a, from (add_lt_add_iff_right (-a)).symm,
  have h₃ : -b + a = - (b + -a),
  { rw [neg_add_eq_neg_add_neg', neg_neg, add_comm], },
  rw [h₁, h₂, neg_add, add_neg', h₃, neg_pos],
end

lemma mul_lt_mul_left_mpr {x y z : R} : 0 < z → x < y → z * x < z * y :=
begin
  repeat {rw lt_iff_pos_sub},
  rw [←mul_sub, sub_zero],
  exact pos_mul_of_pos_of_pos _ _,
end

theorem add_lt_add {a b c d : R} : a < b → c < d → a + c < b + d :=
begin
  repeat {rw lt_iff_pos_sub},
  intros h₁ h₂,
  convert pos_add_of_pos_of_pos _ _ h₁ h₂,
  repeat {rw sub_eq_add_neg'},
  rw neg_add_eq_neg_add_neg',
  rw [add_assoc, add_comm (-c) (-a), ←add_assoc d, add_comm d (-a), add_assoc (-a), ←add_assoc],
end

lemma lt_irrefl {x : R} : ¬x < x :=
begin
  rcases (trichotomy' x x) with ⟨_, _, nxx⟩ | ⟨nxx, _⟩ | ⟨nxx, _⟩;
  exact nxx,
end

theorem ne_of_gt {a b : R} (h : b < a) : a ≠ b :=
λ k, lt_irrefl (@eq.subst _ (λ x, b < x) a b k h)

lemma le_iff_lt_or_eq {x y : R} : x ≤ y ↔ ((x < y) ∨ x = y) := by refl

lemma zero_le_one : (0 : R) ≤ 1 :=
begin
  rw le_iff_lt_or_eq,
  exact or.inl zero_lt_one',
end

lemma le_refl (x : R) : x ≤ x := or.inr rfl

lemma not_le_iff_lt (x y : R) : ¬(x ≤ y) ↔ (y < x) :=
begin
  rw le_iff_lt_or_eq,
  push_neg,
  rcases trichotomy' x y with ⟨hxlty, _, _⟩ | ⟨_, hxy, hnyltx ⟩  | ⟨hnxlty, hnxy, hxlty ⟩ ,
  { split,
    { rintro ⟨hnxy, _⟩,
      contradiction, },
    { intros hyltx, exfalso,
      exact lt_irrefl (lt_trans hxlty hyltx), }, },
  { split,
    { rintro ⟨_, hnxy⟩,
      contradiction, },
    { intro hyltx, contradiction, }, },
  { split,
    { intro _, exact hxlty, },
    { intro _, exact ⟨hnxlty, hnxy⟩, }, },
end

lemma not_lt_iff_le (x y : R) : ¬(x < y) ↔ (y ≤ x) :=
by rw [←not_le_iff_lt, not_not]

lemma lt_iff_le_not_le (a b : R) : a < b ↔ a ≤ b ∧ ¬b ≤ a :=
begin
  rw [not_le_iff_lt, le_iff_lt_or_eq, or_and_distrib_right, and_self],
  exact ⟨λ h, or.inl h, λ h, or.elim h id (λ k, k.2)⟩,
end

lemma neg_nonneg {x : R} : 0 ≤ -x ↔ x ≤ 0 :=
begin
  repeat {rw le_iff_lt_or_eq},
  have k : 0 < -x ↔ x < 0, from neg_pos,
  split,
  { rintro (h₁ | h₂),
    { left, rwa ←k, },
    { right, rw [←neg_neg x, ←h₂, neg_zero], } },
  { rintro (h | rfl),
    { left, rwa k, },
    { right, rw neg_zero, }, },
end

lemma le_trans (x y z : R) : x ≤ y → y ≤ z → x ≤ z :=
begin
  rintro (h₁ | rfl) (h₂ | rfl),
  { left, exact lt_trans h₁ h₂},
  { left, exact h₁ },
  { left, exact h₂, },
  { right, refl, },
end

lemma lt_of_le_of_lt {a b c : R} (h₁ : a ≤ b) (h₂ : b < c) : a < c :=
begin
  cases h₁ with altb aeqb,
  { exact lt_trans altb h₂, },
  { rw aeqb, exact h₂, },
end

lemma le_total (x y : R) : x ≤ y ∨ y ≤ x :=
begin
  rcases trichotomy' x y with ⟨xltx, _⟩ | ⟨_, xeqy, _⟩ | ⟨_, _, yltx⟩,
  { left, left, exact xltx, },
  { left, right, exact xeqy, },
  { right, left, exact yltx, },
end

lemma anti_symm (x y : R) : x ≤ y → y ≤ x → x = y :=
begin
  intros h₁ h₂,
  have h : (x ≠ y → false), -- Could do this using `by_contra`, but that's slow.
  { intro h,
    have h₃ : y < x := or.elim h₂ id (λ k, absurd k.symm h),
    have h₄ : x < y := or.elim h₁ id (λ k, absurd k h),
    exact lt_irrefl (lt_trans h₃ h₄), },
  rw [←(@not_not (x=y))],
  exact h,
end

theorem neg_le_neg_iff {a b : R} : -a ≤ -b ↔ b ≤ a :=
begin
  repeat {rw le_iff_lt_or_eq},
  split,
  { rintro (hlt | heq),
    { left, rwa ←neg_lt_neg_iff, },
    { right, rw [←neg_neg a, heq, neg_neg], }, },
  { rintro (hlt | heq),
    { left, rwa neg_lt_neg_iff, },
    { right, rw heq, }, },
end

theorem add_le_add {a b c d : R} : a ≤ b → c ≤ d → a + c ≤ b + d :=
begin
  rintro (h₁| rfl) (h₂ | rfl),
  { left, exact add_lt_add h₁ h₂ },
  { left, exact add_lt_add_iff_right_mpr c h₁, },
  { left, repeat {rw add_comm a _},
    exact add_lt_add_iff_right_mpr a h₂, },
  { exact le_refl _, },
end

theorem add_le_add_left (a b: R) : a ≤ b →  ∀ (c : R), c + a ≤ c + b :=
λ aleb c, add_le_add (le_refl c) aleb

theorem mul_self_non_neg (a : R) : 0 ≤ a * a:=
begin
  rcases trichotomy' 0 a with ⟨posa, _⟩ | ⟨_, eq0, _⟩ | ⟨_, _, nega⟩,
  { left,
    convert mul_lt_mul_left_mpr posa posa,
    rw mul_zero, },
  { right,
    rw [←eq0, mul_zero], },
  { left,
    rw ←neg_pos at nega,
    rw ←neg_mul_neg_self,
    convert mul_lt_mul_left_mpr nega nega,
    rw mul_zero, },
end

lemma non_neg_mul_of_non_neg_of_non_neg {a b : R} (h₁ : 0 ≤ a) (h₂ : 0 ≤ b) : 0 ≤ a * b :=
begin
  cases h₁ with apos aeq0,
  { cases h₂ with bpos beq0,
    { left, exact gt_zero_mul_of_gt_zero_of_gt_zero apos bpos, },
    { right, rw [←beq0, mul_zero], }, },
  { right,
    rw [←aeq0, zero_mul], },
end

lemma non_neg_of_non_neg_mul_of_pos {x y : R} (h₁ : 0 ≤ x * y) (h₂ : 0 < x) : 0 ≤ y :=
begin
  cases h₁ with xlty xyeq0,
  { by_contra h₃,
    rw [not_le_iff_lt, ←neg_pos] at h₃,
    have h₄ : 0 < x * -y, from gt_zero_mul_of_gt_zero_of_gt_zero h₂ h₃,
    rw [←neg_mul_eq_mul_neg, neg_pos] at h₄,
    exact lt_irrefl (lt_trans h₄ xlty), },
  { right,
    rw mul_comm at xyeq0,
    symmetry,
    apply eq_zero_of_not_eq_zero_of_mul_not_eq_zero _ _ (ne_of_gt h₂) (xyeq0.symm), },
end

lemma non_neg_mul_iff_non_neg_and_non_neg_or_non_pos_and_non_pos (a b : R)
  : 0 ≤ a * b ↔ (0 ≤ a ∧ 0 ≤ b) ∨ (a ≤ 0 ∧ b ≤ 0) :=
begin
  split,
  { intro h₁,
    by_cases h₂ : 0 ≤ a,
    { by_cases h₃ : a = 0,
      { rw h₃,
        exact or.elim (le_total b 0) (λ h₄, or.inr ⟨le_refl 0, h₄⟩) (λ h₄, or.inl ⟨le_refl 0, h₄⟩), },
      { have h₄ : 0 < a, from or.elim h₂ id (λ aeq0, absurd aeq0.symm h₃),
        have h₅ : 0 ≤ b, from non_neg_of_non_neg_mul_of_pos h₁ h₄,
        exact or.inl ⟨or.inl h₄, h₅⟩, }, },
    { rw not_le_iff_lt at h₂,
      right,
      have k : b ≤ 0,
      { by_contra h₃,
        rw not_le_iff_lt at h₃,
        rw ←neg_pos at h₂,
        have h₄ : 0 < b * -a, from gt_zero_mul_of_gt_zero_of_gt_zero h₃ h₂,
        rw [←neg_mul_eq_mul_neg, mul_comm, neg_pos] at h₄,
        exact lt_irrefl (lt_of_le_of_lt h₁ h₄), },
      exact ⟨or.inl h₂, k⟩, }, },
  { rintro (⟨h₁, h₂⟩ | ⟨h₁, h₂⟩),
    { exact non_neg_mul_of_non_neg_of_non_neg h₁ h₂, },
    { rw ←neg_mul_neg a b,
      rw ←neg_nonneg at h₁ h₂,
      exact non_neg_mul_of_non_neg_of_non_neg h₁ h₂, }, },
end

theorem inv_pos {a : R}  (h : a ≠ 0) : 0 < a⁻¹ ↔ 0 < a :=
begin
  split,
  { intro k,
    have h₂ : 0 ≤ a * a, from mul_self_non_neg a,
    cases h₂ with posaa eq0,
    { convert mul_lt_mul_left_mpr k posaa,
      { rw mul_zero, },
      { rw [←mul_assoc, inv_mul a h, one_mul], }, },
    { have h₃ : a = 0,
      { cases eq_zero_or_eq_zero_of_mul_eq_zero a a eq0.symm;
        assumption, },
      exact absurd h₃ h, }, },
  { intro k,
    have h₂ : 0 ≤ (a⁻¹ * a⁻¹), from mul_self_non_neg a⁻¹,
    cases h₂ with posainvsq eq0,
    { convert mul_lt_mul_left_mpr k posainvsq,
      { rw mul_zero, },
      { rw [←mul_assoc, mul_inv a h, one_mul], }, },
    { have h₃ : a⁻¹ = 0,
      { cases eq_zero_or_eq_zero_of_mul_eq_zero _ _ eq0.symm;
        assumption, },
      exact absurd h₃ (inv_ne_zero h), }, },
end

theorem inv_lt_inv {a b : R} (h₁ : 0  < a) (h₂ : 0 < b) : a⁻¹ < b⁻¹ ↔ b < a :=
begin
  split,
  { intro h₃,
    have h₄ : a * a⁻¹ < a * b⁻¹, from mul_lt_mul_left_mpr h₁ h₃,
    have h₅ : a ≠ 0, from ne_of_gt h₁,
    rw (mul_inv a h₅) at h₄,
    have h₆ : b * 1 < b * (a * b⁻¹), from mul_lt_mul_left_mpr h₂ h₄,
    have h₇ : b ≠ 0, from ne_of_gt h₂,
    rw [mul_one, mul_comm, mul_assoc, inv_mul b h₇, mul_one] at h₆,
    exact h₆, },
  { intro h₃,
    have h₅ : a ≠ 0, from ne_of_gt h₁,
    have k₁ : a⁻¹ > 0, from (inv_pos h₅).mpr h₁,
    have h₄ : a⁻¹ * b < a⁻¹ * a, from mul_lt_mul_left_mpr k₁ h₃,
    rw inv_mul a h₅ at h₄,
    have h₇ : b ≠ 0, from ne_of_gt h₂,
    have k₂ : b⁻¹ > 0, from (inv_pos h₇).mpr h₂,
    have h₆ :  b⁻¹ * (a⁻¹ * b) < b⁻¹ * 1, from mul_lt_mul_left_mpr k₂ h₄,
    rw [mul_comm, mul_assoc, mul_inv b h₇, mul_one, mul_one] at h₆,
    exact h₆, },
end

end ordered

section max_abs

variables {R : Type} [myordered_field R]

open_locale classical

open myordered_field

lemma le_max_right (a b : R) : b ≤ max a b :=
begin
  unfold max,
  by_cases h : b ≤ a,
  { rwa (if_pos h), },
  { rw (if_neg h),
    exact le_refl b, },
end

lemma le_max_left (a b : R) : a ≤ max a b :=
begin
  unfold max,
  by_cases h : b ≤ a,
  { rw (if_pos h),
    exact le_refl a, },
  { rw (if_neg h),
    rw not_le_iff_lt at h,
    left, exact h, },
end

lemma max_choice (a b : R) : max a b = a ∨ max a b = b :=
begin
  unfold max,
  by_cases h : b ≤ a,
  { rw (if_pos h), left, refl, },
  { rw (if_neg h),
    right, refl, },
end

lemma neg_le_abs (a : R) : -a ≤ abs a :=
begin
  unfold abs max,
  by_cases h : -a ≤ a,
  { rw (if_pos h), exact h, },
  { rw (if_neg h), exact le_refl (-a), },
end

lemma le_abs_self (a : R) : a ≤ abs a :=
begin
  unfold abs max,
  by_cases h : -a ≤ a,
  { rw (if_pos h), right, refl, },
  { rw (if_neg h), left,
    rw le_iff_lt_or_eq at h,
    push_neg at h,
    rw [not_lt_iff_le, le_iff_lt_or_eq, or_and_distrib_right] at h,
    rcases h with ⟨haltma, _⟩ | ⟨hama, hnama⟩,
    { exact haltma, },
    { exact absurd hama hnama.symm, }, },
end

theorem triangle_inequality (x y : R) : abs (x + y) ≤ abs x + abs y :=
begin
  by_cases h : -(x+y) ≤ x+y,
  { have : abs (x+y) = x + y,
    { unfold abs max,
      rw (if_pos h), },
    rw this,
    have h₁ : x ≤ abs x, from le_abs_self x,
    have h₂ : y ≤ abs y, from le_abs_self y,
    exact add_le_add h₁ h₂, },
  { have : abs (x+y) = -(x+y),
    { unfold abs max,
      rw (if_neg h), },
    rw this,
    rw [neg_add_eq_neg_add_neg', add_comm],
    have h₁ : -x ≤ abs x, from neg_le_abs x,
    have h₂ : -y ≤ abs y, from neg_le_abs y,
    exact add_le_add h₁ h₂, },
end

end max_abs

section upper_bounds

variables {R : Type} [myordered_field R]

theorem sup_uniqueness (S : set R) (a b : R) (h₁ : is_sup a S) (h₂ : is_sup b S) : a = b :=
anti_symm _ _ (h₁.right b h₂.left) (h₂.right a h₁.left)

theorem empty_set_upper_bound (u : R) : upper_bound u ∅ :=
λ s, (set.mem_empty_eq s) ▸ false.elim

end upper_bounds

section instance_linear_ordered_comm_ring

open_locale classical

noncomputable theory

variables {R : Type} [myordered_field R]

instance : linear_ordered_comm_ring R :=
{ add               := comm_group.add,
  add_assoc         := comm_group.add_assoc,
  zero              := comm_group.zero,
  zero_add          := zero_add,
  add_zero          := add_zero,
  neg               := comm_group.neg,
  add_left_neg      := neg_add,
  add_comm          := comm_group.add_comm,
  mul               := myfield.mul,
  mul_assoc         := myfield.mul_assoc,
  one               := myfield.one,
  one_mul           := one_mul,
  mul_one           := myfield.mul_one,
  left_distrib      := myfield.mul_add,
  right_distrib     := add_mul,
  le                := le,
  lt                := lt,
  lt_iff_le_not_le  := lt_iff_le_not_le,
  le_refl           := le_refl,
  le_trans          := le_trans,
  le_antisymm       := anti_symm,
  add_le_add_left   := add_le_add_left,
  mul_pos           := mul_pos,
  le_total          := le_total,
  mul_comm          := myfield.mul_comm,
  zero_lt_one       := zero_lt_one',
  zero_ne_one       := zero_ne_one,
}

end instance_linear_ordered_comm_ring

end myreal

end mth1001


import propositional_logic.and_swap -- hide

/-
# Propositional logic
## Level 4: Implication elimination

Given proofs of $p \to q$ ($p$ implies $q$) and $p$, you know $q$. This is *implication elimination*,
sometimes called *modus ponens*.

In Lean, if `h₁ : p → q` is a proof of `p → q` and `h₂ : p` is a proof of `p`, then `h₁ h₂` is a proof
of `q`.

**Notation**: The symbol `→` is typed `\r`.
-/

variables (p q r : Prop) -- hide

example (h₁ : p → q) (h₂ : p) : q :=
begin
  from h₁ h₂
end

/-
As an example, we'll prove $r$ on the assumptions $h_1 : p \to (q \land r)$ and $h_2 : p$.
-/

example (h₁ : p → (q ∧ r)) (h₂ : p) : r :=
begin
  have h₃ : q ∧ r, from h₁ h₂,
  show r, from h₃.right,
end

namespace exlean -- hide
/-
## Task

Prove the following result in Lean.
-/

/- Theorem : no-side-bar
Let $p$, $q$, and $r$ be propositions. Assuming $h_1 : p \to q \land r$ and $h_2 : p$, we have $q$.
-/
theorem imp_elim_example (h₁ : p → q ∧ r) (h₂ : p) : q :=
begin
  have h₃ : q ∧ r, from h₁ h₂,
  show q, from h₃.left,

end

end exlean -- hide


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

import data.polynomial.basic
import data.finset.nat_antidiagonal
import data.nat.choose.sum

/-!
# Theory of univariate polynomials

The theorems include formulas for computing coefficients, such as
`coeff_add`, `coeff_sum`, `coeff_mul`

-/

noncomputable theory

open finsupp finset add_monoid_algebra
open_locale big_operators polynomial

namespace polynomial
universes u v
variables {R : Type u} {S : Type v} {a b : R} {n m : ℕ}

variables [semiring R] {p q r : R[X]}

section coeff

lemma coeff_one (n : ℕ) : coeff (1 : R[X]) n = if 0 = n then 1 else 0 :=
coeff_monomial

@[simp]
lemma coeff_add (p q : R[X]) (n : ℕ) : coeff (p + q) n = coeff p n + coeff q n :=
by { rcases p, rcases q, simp_rw [←of_finsupp_add, coeff], exact finsupp.add_apply _ _ _ }

@[simp] lemma coeff_smul [monoid S] [distrib_mul_action S R] (r : S) (p : R[X]) (n : ℕ) :
  coeff (r • p) n = r • coeff p n :=
by { rcases p, simp_rw [←of_finsupp_smul, coeff], exact finsupp.smul_apply _ _ _ }

lemma support_smul [monoid S] [distrib_mul_action S R] (r : S) (p : R[X]) :
  support (r • p) ⊆ support p :=
begin
  assume i hi,
  simp [mem_support_iff] at hi ⊢,
  contrapose! hi,
  simp [hi]
end

/-- `polynomial.sum` as a linear map. -/
@[simps] def lsum {R A M : Type*} [semiring R] [semiring A] [add_comm_monoid M]
  [module R A] [module R M] (f : ℕ → A →ₗ[R] M) :
  polynomial A →ₗ[R] M :=
{ to_fun := λ p, p.sum (λ n r, f n r),
  map_add' := λ p q, sum_add_index p q _ (λ n, (f n).map_zero) (λ n _ _, (f n).map_add _ _),
  map_smul' := λ c p,
  begin
    rw [sum_eq_of_subset _ (λ n r, f n r) (λ n, (f n).map_zero) _ (support_smul c p)],
    simp only [sum_def, finset.smul_sum, coeff_smul, linear_map.map_smul, ring_hom.id_apply]
  end }

variable (R)
/-- The nth coefficient, as a linear map. -/
def lcoeff (n : ℕ) : R[X] →ₗ[R] R :=
{ to_fun := λ p, coeff p n,
  map_add' := λ p q, coeff_add p q n,
  map_smul' := λ r p, coeff_smul r p n }

variable {R}

@[simp] lemma lcoeff_apply (n : ℕ) (f : R[X]) : lcoeff R n f = coeff f n := rfl

@[simp] lemma finset_sum_coeff {ι : Type*} (s : finset ι) (f : ι → R[X]) (n : ℕ) :
  coeff (∑ b in s, f b) n = ∑ b in s, coeff (f b) n :=
(lcoeff R n).map_sum

lemma coeff_sum [semiring S] (n : ℕ) (f : ℕ → R → S[X]) :
  coeff (p.sum f) n = p.sum (λ a b, coeff (f a b) n) :=
by { rcases p, simp [polynomial.sum, support, coeff] }

/-- Decomposes the coefficient of the product `p * q` as a sum
over `nat.antidiagonal`. A version which sums over `range (n + 1)` can be obtained
by using `finset.nat.sum_antidiagonal_eq_sum_range_succ`. -/
lemma coeff_mul (p q : R[X]) (n : ℕ) :
  coeff (p * q) n = ∑ x in nat.antidiagonal n, coeff p x.1 * coeff q x.2 :=
begin
  rcases p, rcases q,
  simp_rw [←of_finsupp_mul, coeff],
  exact add_monoid_algebra.mul_apply_antidiagonal p q n _ (λ x, nat.mem_antidiagonal)
end

@[simp] lemma mul_coeff_zero (p q : R[X]) : coeff (p * q) 0 = coeff p 0 * coeff q 0 :=
by simp [coeff_mul]

lemma coeff_mul_X_zero (p : R[X]) : coeff (p * X) 0 = 0 :=
by simp

lemma coeff_X_mul_zero (p : R[X]) : coeff (X * p) 0 = 0 :=
by simp

lemma coeff_C_mul_X_pow (x : R) (k n : ℕ) :
  coeff (C x * X^k : R[X]) n = if n = k then x else 0 :=
by { rw [← monomial_eq_C_mul_X, coeff_monomial], congr' 1, simp [eq_comm] }

lemma coeff_C_mul_X (x : R) (n : ℕ) : coeff (C x * X : R[X]) n = if n = 1 then x else 0 :=
by rw [← pow_one X, coeff_C_mul_X_pow]

@[simp] lemma coeff_C_mul (p : R[X]) : coeff (C a * p) n = a * coeff p n :=
begin
  rcases p,
  simp_rw [←monomial_zero_left, ←of_finsupp_single, ←of_finsupp_mul, coeff],
  exact add_monoid_algebra.single_zero_mul_apply p a n
end

lemma C_mul' (a : R) (f : R[X]) : C a * f = a • f :=
by { ext, rw [coeff_C_mul, coeff_smul, smul_eq_mul] }

@[simp] lemma coeff_mul_C (p : R[X]) (n : ℕ) (a : R) :
  coeff (p * C a) n = coeff p n * a :=
begin
  rcases p,
  simp_rw [←monomial_zero_left, ←of_finsupp_single, ←of_finsupp_mul, coeff],
  exact add_monoid_algebra.mul_single_zero_apply p a n
end

lemma coeff_X_pow (k n : ℕ) :
  coeff (X^k : R[X]) n = if n = k then 1 else 0 :=
by simp only [one_mul, ring_hom.map_one, ← coeff_C_mul_X_pow]

@[simp]
lemma coeff_X_pow_self (n : ℕ) :
  coeff (X^n : R[X]) n = 1 :=
by simp [coeff_X_pow]

@[simp]
theorem coeff_mul_X_pow (p : R[X]) (n d : ℕ) :
  coeff (p * polynomial.X ^ n) (d + n) = coeff p d :=
begin
  rw [coeff_mul, sum_eq_single (d,n), coeff_X_pow, if_pos rfl, mul_one],
  { rintros ⟨i,j⟩ h1 h2, rw [coeff_X_pow, if_neg, mul_zero], rintro rfl, apply h2,
    rw [nat.mem_antidiagonal, add_right_cancel_iff] at h1, subst h1 },
  { exact λ h1, (h1 (nat.mem_antidiagonal.2 rfl)).elim }
end

@[simp]
theorem coeff_X_pow_mul (p : R[X]) (n d : ℕ) :
  coeff (polynomial.X ^ n * p) (d + n) = coeff p d :=
by rw [(commute_X_pow p n).eq, coeff_mul_X_pow]

lemma coeff_mul_X_pow' (p : R[X]) (n d : ℕ) :
  (p * X ^ n).coeff d = ite (n ≤ d) (p.coeff (d - n)) 0 :=
begin
  split_ifs,
  { rw [← tsub_add_cancel_of_le h, coeff_mul_X_pow, add_tsub_cancel_right] },
  { refine (coeff_mul _ _ _).trans (finset.sum_eq_zero (λ x hx, _)),
    rw [coeff_X_pow, if_neg, mul_zero],
    exact ne_of_lt (lt_of_le_of_lt (nat.le_of_add_le_right
      (le_of_eq (finset.nat.mem_antidiagonal.mp hx))) (not_le.mp h)) },
end

lemma coeff_X_pow_mul' (p : R[X]) (n d : ℕ) :
  (X ^ n * p).coeff d = ite (n ≤ d) (p.coeff (d - n)) 0 :=
by rw [(commute_X_pow p n).eq, coeff_mul_X_pow']

@[simp] theorem coeff_mul_X (p : R[X]) (n : ℕ) :
  coeff (p * X) (n + 1) = coeff p n :=
by simpa only [pow_one] using coeff_mul_X_pow p 1 n

@[simp] theorem coeff_X_mul (p : R[X]) (n : ℕ) :
  coeff (X * p) (n + 1) = coeff p n := by rw [(commute_X p).eq, coeff_mul_X]

theorem mul_X_pow_eq_zero {p : R[X]} {n : ℕ}
  (H : p * X ^ n = 0) : p = 0 :=
ext $ λ k, (coeff_mul_X_pow p n k).symm.trans $ ext_iff.1 H (k+n)

lemma mul_X_pow_injective (n : ℕ) : function.injective (λ P : R[X], X ^ n * P) :=
begin
  intros P Q hPQ,
  simp only at hPQ,
  ext i,
  rw [← coeff_X_pow_mul P n i, hPQ, coeff_X_pow_mul Q n i]
end

lemma mul_X_injective : function.injective (λ P : R[X], X * P) :=
pow_one (X : R[X]) ▸ mul_X_pow_injective 1

lemma C_mul_X_pow_eq_monomial (c : R) (n : ℕ) : C c * X^n = monomial n c :=
by { ext1, rw [monomial_eq_smul_X, coeff_smul, coeff_C_mul, smul_eq_mul] }

lemma support_mul_X_pow (c : R) (n : ℕ) (H : c ≠ 0) : (C c * X^n).support = singleton n :=
by rw [C_mul_X_pow_eq_monomial, support_monomial n c H]

lemma support_C_mul_X_pow' {c : R} {n : ℕ} : (C c * X^n).support ⊆ singleton n :=
by { rw [C_mul_X_pow_eq_monomial], exact support_monomial' n c }

lemma coeff_X_add_C_pow (r : R) (n k : ℕ) :
  ((X + C r) ^ n).coeff k = r ^ (n - k) * (n.choose k : R) :=
begin
  rw [(commute_X (C r : R[X])).add_pow, ← lcoeff_apply, linear_map.map_sum],
  simp only [one_pow, mul_one, lcoeff_apply, ← C_eq_nat_cast, ←C_pow, coeff_mul_C, nat.cast_id],
  rw [finset.sum_eq_single k, coeff_X_pow_self, one_mul],
  { intros _ _ h,
    simp [coeff_X_pow, h.symm] },
  { simp only [coeff_X_pow_self, one_mul, not_lt, finset.mem_range],
    intro h, rw [nat.choose_eq_zero_of_lt h, nat.cast_zero, mul_zero] }
end

lemma coeff_X_add_one_pow (R : Type*) [semiring R] (n k : ℕ) :
  ((X + 1) ^ n).coeff k = (n.choose k : R) :=
by rw [←C_1, coeff_X_add_C_pow, one_pow, one_mul]

lemma coeff_one_add_X_pow (R : Type*) [semiring R] (n k : ℕ) :
  ((1 + X) ^ n).coeff k = (n.choose k : R) :=
by rw [add_comm _ X, coeff_X_add_one_pow]

lemma C_dvd_iff_dvd_coeff (r : R) (φ : R[X]) :
  C r ∣ φ ↔ ∀ i, r ∣ φ.coeff i :=
begin
  split,
  { rintros ⟨φ, rfl⟩ c, rw coeff_C_mul, apply dvd_mul_right },
  { intro h,
    choose c hc using h,
    classical,
    let c' : ℕ → R := λ i, if i ∈ φ.support then c i else 0,
    let ψ : R[X] := ∑ i in φ.support, monomial i (c' i),
    use ψ,
    ext i,
    simp only [ψ, c', coeff_C_mul, mem_support_iff, coeff_monomial,
               finset_sum_coeff, finset.sum_ite_eq'],
    split_ifs with hi hi,
    { rw hc },
    { rw [not_not] at hi, rwa mul_zero } },
end

lemma coeff_bit0_mul (P Q : R[X]) (n : ℕ) :
  coeff (bit0 P * Q) n = 2 * coeff (P * Q) n :=
by simp [bit0, add_mul]

lemma smul_eq_C_mul (a : R) : a • p = C a * p := by simp [ext_iff]

lemma update_eq_add_sub_coeff {R : Type*} [ring R] (p : R[X]) (n : ℕ) (a : R) :
  p.update n a = p + (polynomial.C (a - p.coeff n) * polynomial.X ^ n) :=
begin
  ext,
  rw [coeff_update_apply, coeff_add, coeff_C_mul_X_pow],
  split_ifs with h;
  simp [h]
end

end coeff

section cast

@[simp] lemma nat_cast_coeff_zero {n : ℕ} {R : Type*} [semiring R] :
  (n : R[X]).coeff 0 = n :=
begin
  induction n with n ih,
  { simp, },
  { simp [ih], },
end

@[simp, norm_cast] theorem nat_cast_inj
  {m n : ℕ} {R : Type*} [semiring R] [char_zero R] : (↑m : R[X]) = ↑n ↔ m = n :=
begin
  fsplit,
  { intro h,
    apply_fun (λ p, p.coeff 0) at h,
    simpa using h, },
  { rintro rfl, refl, },
end

@[simp] lemma int_cast_coeff_zero {i : ℤ} {R : Type*} [ring R] :
  (i : R[X]).coeff 0 = i :=
by cases i; simp

@[simp, norm_cast] theorem int_cast_inj
  {m n : ℤ} {R : Type*} [ring R] [char_zero R] : (↑m : R[X]) = ↑n ↔ m = n :=
begin
  fsplit,
  { intro h,
    apply_fun (λ p, p.coeff 0) at h,
    simpa using h, },
  { rintro rfl, refl, },
end

end cast

instance [char_zero R] : char_zero R[X] :=
{ cast_injective := λ x y, nat_cast_inj.mp }

end polynomial


import data.finset

universes u

open finset

variables {α : Type u} [decidable_eq α] [fintype α]

/- A matroid M is an ordered pair `(E, ℐ)` consisting of a finite set `E` and
a collection `ℐ` of subsets of `E` having the following three properties:
  (I1) `∅ ∈ ℐ`.
  (I2) If `I ∈ ℐ` and `I' ⊆ I`, then `I' ∈ ℐ`.
  (I3) If `I₁` and `I₂` are in `I` and `|I₁| < |I₂|`, then there is an element `e` of `I₂ − I₁`
    such that `I₁ ∪ {e} ∈ I`.-/

-- could i define independence inductively?
-- in linear_independent.lean, independence is defined w.r.t. finsupp and the kernel, interesting
def can_exchange (ℐ : finset α → Prop) : Prop :=
∀ I₁ I₂, ℐ I₁ ∧ ℐ I₂ → finset.card I₁ < finset.card I₂ → ∃ (e ∈ I₂ \ I₁), (ℐ (insert e I₁))

@[ext]
structure matroid (α : Type u) [fintype α] [decidable_eq α] :=
(ℐ : finset α → Prop)
(empty : ℐ ∅) -- (I1)
(hereditary : ∀ (I₁ : finset α), ℐ I₁ → ∀ (I₂ : finset α), I₂ ⊆ I₁ → ℐ I₂) -- (I2)
(ind : can_exchange ℐ) -- (I3)

namespace matroid

variables (M : matroid α) [decidable_pred M.ℐ]

/- A subset of `E` that is not in `ℐ` is called dependent. -/
def dependent_sets : finset (finset α) := filter (λ s, ¬ M.ℐ s) univ.powerset

-- (C1)
lemma empty_not_dependent : ∅ ∉ M.dependent_sets :=
begin
  have h1 := M.empty,
  rw dependent_sets,
  simp,
  exact h1,
end

variables [decidable_pred (λ (D : finset α), can_exchange (λ (_x : finset α), _x ∈ D.powerset.erase D))]

def circuit : finset (finset α) :=
  finset.filter (λ (D : finset α), (∀ (S ∈ (erase D.powerset D)), M.ℐ S)) (M.dependent_sets)

@[simp]
lemma mem_circuit (C₁ : finset α) :
  C₁ ∈ M.circuit ↔ C₁ ∈ M.dependent_sets ∧ (∀ (C₂ ∈ (erase C₁.powerset C₁)), M.ℐ C₂) :=
begin
  rw circuit,
  rw dependent_sets,
  rw mem_filter,
end

/- `(C2)` if C₁ and C₂ are members of C and C₁ ⊆ C₂, then C₂ = C₂.
In other words, C forms an antichain. -/
lemma circuit_antichain (C₁ C₂ : finset α) (h₁ : C₁ ∈ M.circuit) (h₂ : C₂ ∈ M.circuit) : C₁ ⊆ C₂ → C₁ = C₂ :=
begin
  intros h,
  -- every proper subset of C₂ is independent
  -- then either C₁ is independent or C₁ = C₂
  rw circuit at h₂,
  simp at h₂,
  have h2 := h₂.2,
  by_contra h3,
  specialize h2 C₁ h3 h,
  rw circuit at h₁,
  rw mem_filter at h₁,
  have h1 := h₁.1,
  rw dependent_sets at h1,
  rw mem_filter at h1,
  apply h1.2,
  exact h2,
end

/- `(C3)` If C₁ and C₂ are distinct members of M.circuit and e ∈ C₁ ∩ C₂, then
there is a member C₃ of M.circuit such that C₃ ⊆ (C₁ ∪ C₂) - e.   -/
lemma circuit_dependence (C₁ C₂ : finset α) (h₁ : C₁ ∈ M.circuit) (h₂ : C₂ ∈ M.circuit) (h : C₁ ≠ C₂) (e : α) :
  e ∈ C₁ ∩ C₂ → ∃ C₃ ∈ M.circuit, C₃ ⊆ (C₁ ∪ C₂) \ {e} :=
begin
  intros h,
  sorry,
end

end matroid


/- LoVe Demo 3: Structured Proofs and Proof Terms -/

import .love01_definitions_and_lemma_statements_demo

namespace LoVe

/- Structured Proofs -/

lemma add_comm_zero_left (n : ℕ):
  add 0 n = add n 0 :=
add_comm 0 n

lemma add_comm_zero_left₂ (n : ℕ):
  add 0 n = add n 0 :=
by exact add_comm 0 n

lemma fst_of_two_props :
  ∀a b : Prop, a → b → a :=
assume a b ha hb,
show a, from ha

lemma fst_of_two_props₂ (a b : Prop) (ha : a) (hb : b) :
  a :=
show a,
begin
  exact ha
end

lemma fst_of_two_props₃ (a b : Prop) (ha : a) (hb : b) :
  a :=
ha

lemma prop_comp (a b c : Prop) (hab : a → b) (hbc : b → c) :
  a → c :=
assume ha,
have hb : b := hab ha,
have hc : c := hbc hb,
show c, from hc

lemma β_example {α β : Type} (f : α → β) (a : α) :
  (λx, f x) a = f a :=
rfl

def double (n : ℕ) : ℕ :=
n + n

lemma nat_exists_double_iden :
  ∃n : ℕ, double n = n :=
exists.intro 0
  (show double 0 = 0, from rfl)

lemma nat_exists_double_iden₂ :
  ∃n : ℕ, double n = n :=
exists.intro 0 rfl

lemma nat_exists_double_iden₃ :
  ∃n : ℕ, double n = n :=
exists.intro 0 (by refl)

lemma and_swap (a b : Prop) :
  a ∧ b → b ∧ a :=
assume hab : a ∧ b,
have ha : a := and.elim_left hab,
have hb : b := and.elim_right hab,
show b ∧ a, from and.intro hb ha

lemma and_swap₂ (a b : Prop) :
  a ∧ b → b ∧ a :=
assume hab : a ∧ b,
have ha : a := and.elim_left hab,
have hb : b := and.elim_right hab,
begin
  apply and.intro,
  { exact hb },
  { exact ha }
end

lemma or_swap (a b : Prop) :
  a ∨ b → b ∨ a :=
assume hab : a ∨ b,
show b ∨ a, from or.elim hab
  (assume ha,
   show b ∨ a, from or.intro_right b ha)
  (assume hb,
   show b ∨ a, from or.intro_left a hb)

lemma modus_ponens (a b : Prop) :
  (a → b) → a → b :=
assume (hab : a → b) (ha : a),
show b, from hab ha

lemma proof_of_negation (a : Prop) :
  a → ¬¬ a :=
assume ha hna,
show false, from hna ha

#check classical.by_contradiction

lemma proof_by_contradiction (a : Prop) :
  ¬¬ a → a :=
assume hnna,
show a, from classical.by_contradiction hnna

lemma exists_or {α : Type} (p q : α → Prop) :
  (∃x, p x ∨ q x) ↔ (∃x, p x) ∨ (∃x, q x) :=
iff.intro
  (assume hxpq,
   match hxpq with
   | Exists.intro x hpq :=
     match hpq with
     | or.inl hp := or.intro_left _ (exists.intro x hp)
     | or.inr hq := or.intro_right _ (exists.intro x hq)
     end
   end)
  (assume hxpq,
   match hxpq with
   | or.inl hxp :=
     match hxp with
     | Exists.intro x hp := exists.intro x (or.intro_left _ hp)
     end
   | or.inr hxq :=
     match hxq with
     | Exists.intro x hq := exists.intro x (or.intro_right _ hq)
     end
   end)

/- Calculational Proofs -/

lemma two_mul_example (m n : ℕ) :
  2 * m + n = m + n + m :=
calc 2 * m + n = (m + m) + n : by rw two_mul
... = m + n + m : by ac_refl

lemma two_mul_example₂ (m n : ℕ) :
  2 * m + n = m + n + m :=
have h₁ : 2 * m + n = (m + m) + n := by rw two_mul,
have h₂ : (m + m) + n = m + n + m := by ac_refl,
show _, from eq.trans h₁ h₂

/- Induction by Pattern Matching -/

lemma add_zero :
  ∀n : ℕ, add 0 n = n
| 0            := by refl
| (nat.succ m) := by simp [add, add_zero m]

lemma add_succ :
  ∀m n : ℕ, add (nat.succ m) n = nat.succ (add m n)
| m 0            := by refl
| m (nat.succ n) := by simp [add, add_succ m n]

lemma add_comm :
  ∀m n : ℕ, add m n = add n m
| m 0            := by simp [add, add_zero]
| m (nat.succ n) := by simp [add, add_succ, add_comm m n]

lemma add_comm₂ :
  ∀m n : ℕ, add m n = add n m
| m 0            := by simp [add, add_zero]
| m (nat.succ n) :=
  have ih : _ := add_comm₂ m n,
  by simp [add, add_succ, ih]

lemma add_assoc :
  ∀l m n : ℕ, add (add l m) n = add l (add m n)
| l m 0            := by refl
| l m (nat.succ n) := by simp [add, add_assoc l m n]

-- type classes (useful for `ac_refl` below)
instance : is_commutative ℕ add := ⟨add_comm⟩
instance : is_associative ℕ add := ⟨add_assoc⟩

lemma mul_add (l m : ℕ) :
  ∀n : ℕ, mul l (add m n) = add (mul l m) (mul l n)
| 0            := by refl
| (nat.succ l) := by simp [add, mul, mul_add l]; ac_refl

/- The Curry–Howard Correspondence -/

lemma and_swap₃ (a b : Prop) :
  a ∧ b → b ∧ a :=
λhab : a ∧ b, and.intro (and.elim_right hab) (and.elim_left hab)

lemma and_swap₄ (a b : Prop) :
  a ∧ b → b ∧ a :=
begin
  intro hab,
  apply and.intro,
  apply and.elim_right,
  exact hab,
  apply and.elim_left,
  exact hab
end

#print and_swap₃
#print and_swap₄

/- Forward Tactics -/

lemma prop_comp₂ (a b c : Prop) (hab : a → b) (hbc : b → c) :
  a → c :=
begin
  intro ha,
  have hb : b := hab ha,
  have hc : c := hbc hb,
  exact hc
end

end LoVe


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

! This file was ported from Lean 3 source module number_theory.von_mangoldt
! leanprover-community/mathlib commit c946d6097a6925ad16d7ec55677bbc977f9846de
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.IsPrimePow
import Mathbin.NumberTheory.ArithmeticFunction
import Mathbin.Analysis.SpecialFunctions.Log.Basic

/-!
# The von Mangoldt Function

In this file we define the von Mangoldt function: the function on natural numbers that returns
`log p` if the input can be expressed as `p^k` for a prime `p`.

## Main Results

The main definition for this file is

- `nat.arithmetic_function.von_mangoldt`: The von Mangoldt function `Λ`.

We then prove the classical summation property of the von Mangoldt function in
`nat.arithmetic_function.von_mangoldt_sum`, that `∑ i in n.divisors, Λ i = real.log n`, and use this
to deduce alternative expressions for the von Mangoldt function via Möbius inversion, see
`nat.arithmetic_function.sum_moebius_mul_log_eq`.

## Notation

We use the standard notation `Λ` to represent the von Mangoldt function.

-/

namespace Nat

namespace ArithmeticFunction

open Finset

open ArithmeticFunction

/-- `log` as an arithmetic function `ℕ → ℝ`. Note this is in the `nat.arithmetic_function`
namespace to indicate that it is bundled as an `arithmetic_function` rather than being the usual
real logarithm. -/
noncomputable def log : ArithmeticFunction ℝ :=
  ⟨fun n => Real.log n, by simp⟩
#align nat.arithmetic_function.log Nat.ArithmeticFunction.log

@[simp]
theorem log_apply {n : ℕ} : log n = Real.log n :=
  rfl
#align nat.arithmetic_function.log_apply Nat.ArithmeticFunction.log_apply

/--
The `von_mangoldt` function is the function on natural numbers that returns `log p` if the input can
be expressed as `p^k` for a prime `p`.
In the case when `n` is a prime power, `min_fac` will give the appropriate prime, as it is the
smallest prime factor.

In the `arithmetic_function` locale, we have the notation `Λ` for this function.
-/
noncomputable def vonMangoldt : ArithmeticFunction ℝ :=
  ⟨fun n => if IsPrimePow n then Real.log (minFac n) else 0, if_neg not_isPrimePow_zero⟩
#align nat.arithmetic_function.von_mangoldt Nat.ArithmeticFunction.vonMangoldt

-- mathport name: von_mangoldt
scoped[ArithmeticFunction] notation "Λ" => Nat.ArithmeticFunction.vonMangoldt

theorem vonMangoldt_apply {n : ℕ} : Λ n = if IsPrimePow n then Real.log (minFac n) else 0 :=
  rfl
#align nat.arithmetic_function.von_mangoldt_apply Nat.ArithmeticFunction.vonMangoldt_apply

@[simp]
theorem vonMangoldt_apply_one : Λ 1 = 0 := by simp [von_mangoldt_apply]
#align nat.arithmetic_function.von_mangoldt_apply_one Nat.ArithmeticFunction.vonMangoldt_apply_one

@[simp]
theorem vonMangoldt_nonneg {n : ℕ} : 0 ≤ Λ n :=
  by
  rw [von_mangoldt_apply]
  split_ifs
  · exact Real.log_nonneg (one_le_cast.2 (Nat.minFac_pos n))
  rfl
#align nat.arithmetic_function.von_mangoldt_nonneg Nat.ArithmeticFunction.vonMangoldt_nonneg

theorem vonMangoldt_apply_pow {n k : ℕ} (hk : k ≠ 0) : Λ (n ^ k) = Λ n := by
  simp only [von_mangoldt_apply, isPrimePow_pow_iff hk, pow_min_fac hk]
#align nat.arithmetic_function.von_mangoldt_apply_pow Nat.ArithmeticFunction.vonMangoldt_apply_pow

theorem vonMangoldt_apply_prime {p : ℕ} (hp : p.Prime) : Λ p = Real.log p := by
  rw [von_mangoldt_apply, prime.min_fac_eq hp, if_pos hp.prime.is_prime_pow]
#align nat.arithmetic_function.von_mangoldt_apply_prime Nat.ArithmeticFunction.vonMangoldt_apply_prime

theorem vonMangoldt_ne_zero_iff {n : ℕ} : Λ n ≠ 0 ↔ IsPrimePow n :=
  by
  rcases eq_or_ne n 1 with (rfl | hn); · simp [not_isPrimePow_one]
  exact (Real.log_pos (one_lt_cast.2 (min_fac_prime hn).one_lt)).ne'.ite_ne_right_iff
#align nat.arithmetic_function.von_mangoldt_ne_zero_iff Nat.ArithmeticFunction.vonMangoldt_ne_zero_iff

theorem vonMangoldt_pos_iff {n : ℕ} : 0 < Λ n ↔ IsPrimePow n :=
  vonMangoldt_nonneg.lt_iff_ne.trans (ne_comm.trans vonMangoldt_ne_zero_iff)
#align nat.arithmetic_function.von_mangoldt_pos_iff Nat.ArithmeticFunction.vonMangoldt_pos_iff

theorem vonMangoldt_eq_zero_iff {n : ℕ} : Λ n = 0 ↔ ¬IsPrimePow n :=
  vonMangoldt_ne_zero_iff.not_right
#align nat.arithmetic_function.von_mangoldt_eq_zero_iff Nat.ArithmeticFunction.vonMangoldt_eq_zero_iff

open BigOperators

theorem vonMangoldt_sum {n : ℕ} : (∑ i in n.divisors, Λ i) = Real.log n :=
  by
  refine' rec_on_prime_coprime _ _ _ n
  · simp
  · intro p k hp
    rw [sum_divisors_prime_pow hp, cast_pow, Real.log_pow, Finset.sum_range_succ', pow_zero,
      von_mangoldt_apply_one]
    simp [von_mangoldt_apply_pow (Nat.succ_ne_zero _), von_mangoldt_apply_prime hp]
  intro a b ha' hb' hab ha hb
  simp only [von_mangoldt_apply, ← sum_filter] at ha hb⊢
  rw [mul_divisors_filter_prime_pow hab, filter_union,
    sum_union (disjoint_divisors_filter_prime_pow hab), ha, hb, Nat.cast_mul,
    Real.log_mul (cast_ne_zero.2 (pos_of_gt ha').ne') (cast_ne_zero.2 (pos_of_gt hb').ne')]
#align nat.arithmetic_function.von_mangoldt_sum Nat.ArithmeticFunction.vonMangoldt_sum

@[simp]
theorem vonMangoldt_mul_zeta : Λ * ζ = log := by
  ext n
  rw [coe_mul_zeta_apply, von_mangoldt_sum]
  rfl
#align nat.arithmetic_function.von_mangoldt_mul_zeta Nat.ArithmeticFunction.vonMangoldt_mul_zeta

@[simp]
theorem zeta_mul_vonMangoldt : (ζ : ArithmeticFunction ℝ) * Λ = log :=
  by
  rw [mul_comm]
  simp
#align nat.arithmetic_function.zeta_mul_von_mangoldt Nat.ArithmeticFunction.zeta_mul_vonMangoldt

@[simp]
theorem log_mul_moebius_eq_vonMangoldt : log * μ = Λ := by
  rw [← von_mangoldt_mul_zeta, mul_assoc, coe_zeta_mul_coe_moebius, mul_one]
#align nat.arithmetic_function.log_mul_moebius_eq_von_mangoldt Nat.ArithmeticFunction.log_mul_moebius_eq_vonMangoldt

@[simp]
theorem moebius_mul_log_eq_vonMangoldt : (μ : ArithmeticFunction ℝ) * log = Λ :=
  by
  rw [mul_comm]
  simp
#align nat.arithmetic_function.moebius_mul_log_eq_von_mangoldt Nat.ArithmeticFunction.moebius_mul_log_eq_vonMangoldt

theorem sum_moebius_mul_log_eq {n : ℕ} : (∑ d in n.divisors, (μ d : ℝ) * log d) = -Λ n :=
  by
  simp only [← log_mul_moebius_eq_von_mangoldt, mul_comm log, mul_apply, log_apply, int_coe_apply, ←
    Finset.sum_neg_distrib, neg_mul_eq_mul_neg]
  rw [sum_divisors_antidiagonal fun i j => (μ i : ℝ) * -Real.log j]
  have :
    (∑ i : ℕ in n.divisors, (μ i : ℝ) * -Real.log (n / i : ℕ)) =
      ∑ i : ℕ in n.divisors, (μ i : ℝ) * Real.log i - μ i * Real.log n :=
    by
    apply sum_congr rfl
    simp only [and_imp, Int.cast_eq_zero, mul_eq_mul_left_iff, Ne.def, neg_inj, mem_divisors]
    intro m mn hn
    have : (m : ℝ) ≠ 0 := by
      rw [cast_ne_zero]
      rintro rfl
      exact hn (by simpa using mn)
    rw [Nat.cast_div mn this, Real.log_div (cast_ne_zero.2 hn) this, neg_sub, mul_sub]
  rw [this, sum_sub_distrib, ← sum_mul, ← Int.cast_sum, ← coe_mul_zeta_apply, eq_comm, sub_eq_self,
    moebius_mul_coe_zeta, mul_eq_zero, Int.cast_eq_zero]
  rcases eq_or_ne n 1 with (hn | hn) <;> simp [hn]
#align nat.arithmetic_function.sum_moebius_mul_log_eq Nat.ArithmeticFunction.sum_moebius_mul_log_eq

theorem vonMangoldt_le_log : ∀ {n : ℕ}, Λ n ≤ Real.log (n : ℝ)
  | 0 => by simp
  | n + 1 => by
    rw [← von_mangoldt_sum]
    exact single_le_sum (fun _ _ => von_mangoldt_nonneg) (mem_divisors_self _ n.succ_ne_zero)
#align nat.arithmetic_function.von_mangoldt_le_log Nat.ArithmeticFunction.vonMangoldt_le_log

end ArithmeticFunction

end Nat


/-
Copyright (c) 2020 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.erase_lead
import Mathlib.data.polynomial.degree.default
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Reverse of a univariate polynomial

The main definition is `reverse`.  Applying `reverse` to a polynomial `f : polynomial R` produces
the polynomial with a reversed list of coefficients, equivalent to `X^f.nat_degree * f(1/X)`.

The main result is that `reverse (f * g) = reverse (f) * reverse (g)`, provided the leading
coefficients of `f` and `g` do not multiply to zero.
-/

namespace polynomial

/-- If `i ≤ N`, then `rev_at_fun N i` returns `N - i`, otherwise it returns `i`.
This is the map used by the embedding `rev_at`.
-/
def rev_at_fun (N : ℕ) (i : ℕ) : ℕ := ite (i ≤ N) (N - i) i

theorem rev_at_fun_invol {N : ℕ} {i : ℕ} : rev_at_fun N (rev_at_fun N i) = i := sorry

theorem rev_at_fun_inj {N : ℕ} : function.injective (rev_at_fun N) := sorry

/-- If `i ≤ N`, then `rev_at N i` returns `N - i`, otherwise it returns `i`.
Essentially, this embedding is only used for `i ≤ N`.
The advantage of `rev_at N i` over `N - i` is that `rev_at` is an involution.
-/
def rev_at (N : ℕ) : ℕ ↪ ℕ :=
  function.embedding.mk (fun (i : ℕ) => ite (i ≤ N) (N - i) i) rev_at_fun_inj

/-- We prefer to use the bundled `rev_at` over unbundled `rev_at_fun`. -/
@[simp] theorem rev_at_fun_eq (N : ℕ) (i : ℕ) : rev_at_fun N i = coe_fn (rev_at N) i := rfl

@[simp] theorem rev_at_invol {N : ℕ} {i : ℕ} : coe_fn (rev_at N) (coe_fn (rev_at N) i) = i :=
  rev_at_fun_invol

@[simp] theorem rev_at_le {N : ℕ} {i : ℕ} (H : i ≤ N) : coe_fn (rev_at N) i = N - i := if_pos H

theorem rev_at_add {N : ℕ} {O : ℕ} {n : ℕ} {o : ℕ} (hn : n ≤ N) (ho : o ≤ O) :
    coe_fn (rev_at (N + O)) (n + o) = coe_fn (rev_at N) n + coe_fn (rev_at O) o :=
  sorry

/-- `reflect N f` is the polynomial such that `(reflect N f).coeff i = f.coeff (rev_at N i)`.
In other words, the terms with exponent `[0, ..., N]` now have exponent `[N, ..., 0]`.

In practice, `reflect` is only used when `N` is at least as large as the degree of `f`.

Eventually, it will be used with `N` exactly equal to the degree of `f`.  -/
def reflect {R : Type u_1} [semiring R] (N : ℕ) (f : polynomial R) : polynomial R :=
  finsupp.emb_domain (rev_at N) f

theorem reflect_support {R : Type u_1} [semiring R] (N : ℕ) (f : polynomial R) :
    finsupp.support (reflect N f) = finset.image (⇑(rev_at N)) (finsupp.support f) :=
  sorry

@[simp] theorem coeff_reflect {R : Type u_1} [semiring R] (N : ℕ) (f : polynomial R) (i : ℕ) :
    coeff (reflect N f) i = coeff f (coe_fn (rev_at N) i) :=
  sorry

@[simp] theorem reflect_zero {R : Type u_1} [semiring R] {N : ℕ} : reflect N 0 = 0 := rfl

@[simp] theorem reflect_eq_zero_iff {R : Type u_1} [semiring R] {N : ℕ} {f : polynomial R} :
    reflect N f = 0 ↔ f = 0 :=
  sorry

@[simp] theorem reflect_add {R : Type u_1} [semiring R] (f : polynomial R) (g : polynomial R)
    (N : ℕ) : reflect N (f + g) = reflect N f + reflect N g :=
  sorry

@[simp] theorem reflect_C_mul {R : Type u_1} [semiring R] (f : polynomial R) (r : R) (N : ℕ) :
    reflect N (coe_fn C r * f) = coe_fn C r * reflect N f :=
  sorry

@[simp] theorem reflect_C_mul_X_pow {R : Type u_1} [semiring R] (N : ℕ) (n : ℕ) {c : R} :
    reflect N (coe_fn C c * X ^ n) = coe_fn C c * X ^ coe_fn (rev_at N) n :=
  sorry

@[simp] theorem reflect_monomial {R : Type u_1} [semiring R] (N : ℕ) (n : ℕ) :
    reflect N (X ^ n) = X ^ coe_fn (rev_at N) n :=
  sorry

theorem reflect_mul_induction {R : Type u_1} [semiring R] (cf : ℕ) (cg : ℕ) (N : ℕ) (O : ℕ)
    (f : polynomial R) (g : polynomial R) :
    finset.card (finsupp.support f) ≤ Nat.succ cf →
        finset.card (finsupp.support g) ≤ Nat.succ cg →
          nat_degree f ≤ N →
            nat_degree g ≤ O → reflect (N + O) (f * g) = reflect N f * reflect O g :=
  sorry

@[simp] theorem reflect_mul {R : Type u_1} [semiring R] (f : polynomial R) (g : polynomial R)
    {F : ℕ} {G : ℕ} (Ff : nat_degree f ≤ F) (Gg : nat_degree g ≤ G) :
    reflect (F + G) (f * g) = reflect F f * reflect G g :=
  reflect_mul_induction (finset.card (finsupp.support f)) (finset.card (finsupp.support g)) F G f g
    (nat.le_succ (finset.card (finsupp.support f))) (nat.le_succ (finset.card (finsupp.support g)))
    Ff Gg

/-- The reverse of a polynomial f is the polynomial obtained by "reading f backwards".
Even though this is not the actual definition, reverse f = f (1/X) * X ^ f.nat_degree. -/
def reverse {R : Type u_1} [semiring R] (f : polynomial R) : polynomial R :=
  reflect (nat_degree f) f

@[simp] theorem reverse_zero {R : Type u_1} [semiring R] : reverse 0 = 0 := rfl

theorem reverse_mul {R : Type u_1} [semiring R] {f : polynomial R} {g : polynomial R}
    (fg : leading_coeff f * leading_coeff g ≠ 0) : reverse (f * g) = reverse f * reverse g :=
  sorry

@[simp] theorem reverse_mul_of_domain {R : Type u_1} [domain R] (f : polynomial R)
    (g : polynomial R) : reverse (f * g) = reverse f * reverse g :=
  sorry

@[simp] theorem coeff_zero_reverse {R : Type u_1} [semiring R] (f : polynomial R) :
    coeff (reverse f) 0 = leading_coeff f :=
  sorry

@[simp] theorem coeff_one_reverse {R : Type u_1} [semiring R] (f : polynomial R) :
    coeff (reverse f) 1 = next_coeff f :=
  sorry

end Mathlib


-- ereal facts

import analysis.special_functions.log.basic
import data.real.basic
import data.real.ennreal
import data.real.ereal
import topology.instances.ereal

import simple

open linear_order (min)
open_locale nnreal ennreal
noncomputable theory

-- log : ereal → ereal, turning nonpositives to -∞ and preserving ∞
def ereal.log : ereal → ereal
| ⊥ := ⊥
| (x : ℝ) := if x ≤ 0 then ⊥ else ↑(x.log)
| ⊤ := ⊤

-- exp : ereal → ereal, turning -∞ into 0 and preserving ∞
def ereal.exp : ereal → ereal
| ⊥ := 0
| (x : ℝ) := ↑(x.exp)
| ⊤ := ⊤

-- Is an ereal finite?
def ereal.is_finite (x : ereal) := ∃ y : ℝ, x = ↑y

@[simp] lemma ereal.coe_finite {x : ℝ} : ereal.is_finite (x : ereal) := by simp [ereal.is_finite]
lemma ereal.bot_infinite : ¬ereal.is_finite ⊥ := by simp [ereal.is_finite]
lemma ereal.top_infinite : ¬ereal.is_finite ⊤ := by simp [ereal.is_finite]
lemma ereal.is_finite.ne_bot {x : ereal} : ereal.is_finite x → x ≠ ⊥ := begin
  intro f, by_contradiction, rw h at f, have nf := ereal.bot_infinite, finish
end

instance : densely_ordered ereal := ⟨begin
  intros x y xy,
  induction x using ereal.rec,
  induction y using ereal.rec, finish,
  existsi ↑(y - 1), simp, apply_instance,
  existsi (0 : ereal), simp,
  induction y using ereal.rec, finish,
  simp at xy, rcases exists_between xy with ⟨a,lo,hi⟩, existsi ↑a, simp, finish, apply_instance,
  existsi ↑(x + 1), rw ereal.coe_lt_coe_iff, simp, rw ←ereal.coe_one, exact ereal.coe_lt_top _,
  simp at xy, finish,
end⟩

@[simp] lemma ereal.log_zero : ereal.log 0 = ⊥ := by { rw [←ereal.coe_zero, ereal.log], simp }
@[simp] lemma ereal.log_bot : ereal.log ⊥ = ⊥ := by simp [ereal.log]
@[simp] lemma ereal.log_top : ereal.log ⊤ = ⊤ := by simp [ereal.log]
@[simp] lemma ereal.exp_bot : ereal.exp ⊥ = 0 := by simp [ereal.exp]
@[simp] lemma ereal.exp_top : ereal.exp ⊤ = ⊤ := by simp [ereal.exp]
@[simp] lemma ereal.log_coe {x : ℝ} (h : x > 0) : ereal.log x = ↑(x.log) := begin rw ereal.log, simp, exact not_le_of_gt h end
@[simp] lemma ereal.exp_coe {x : ℝ} : ereal.exp x = ↑(x.exp) := rfl

@[simp] lemma ereal.log_exp {x : ereal} : x.exp.log = x := begin
  induction x using ereal.rec, simp, simp [ereal.log], apply not_le_of_gt, exact real.exp_pos _, simp,
end

@[simp] lemma ereal.exp_log {x : ereal} (h : x ≥ 0) : x.log.exp = x := begin
  induction x using ereal.rec, simp at h, finish, swap, simp,
  simp at h, rw [←ereal.coe_zero, ereal.coe_le_coe_iff] at h,
  by_cases z : x = 0, { rw z, simp },
  simp [lt_of_le_of_ne h (ne.symm z), real.exp_log],
end

lemma ereal.log_lt_top_iff {x : ereal} : x.log < ⊤ ↔ x < ⊤ := begin
  induction x using ereal.rec, simp, simp [ereal.log], by_cases x0 : x ≤ 0, simp [x0], simp [x0], simp,
end

lemma ereal.exp_pos_iff {x : ereal} : 0 < x.exp ↔ ⊥ < x := begin
  induction x using ereal.rec,
  simp, simp, rw [←ereal.coe_zero, ereal.coe_lt_coe_iff], simp [real.exp_pos], simp,
end

lemma ereal.log_eq_iff_eq_exp {x y : ereal} (h : x ≥ 0) : x.log = y ↔ x = y.exp := begin
  constructor, { intro e, rw ←e, simp [h] }, { intro e, rw e, simp }
end

lemma ereal.log_lt_iff_lt_exp {x y : ereal} (h : x ≥ 0) : x.log < y ↔ x < y.exp := begin
  induction x using ereal.rec, finish, swap, simp,
  rw ←ereal.coe_zero at h,
  have h' := ereal.coe_le_coe_iff.mp h,
  by_cases x0 : x = 0, { rw x0, simp [real.exp_pos], exact ereal.exp_pos_iff.symm },
  have xp := lt_of_le_of_ne h' (ne.symm x0),
  induction y using ereal.rec, simp, assumption,
  simp [ereal.exp_coe, ereal.coe_lt_coe_iff],
  rw [ereal.log_coe xp, ereal.coe_lt_coe_iff],
  exact real.log_lt_iff_lt_exp xp,
  rw ereal.log_coe xp, simp,
end

lemma ereal.log_le_iff_le_exp {x y : ereal} (h : x ≥ 0) : x.log ≤ y ↔ x ≤ y.exp := begin
  by_cases e : x = y.exp, { rw e, simp },
  constructor, {
    intro w, rw ←ereal.log_eq_iff_eq_exp h at e,
    have s := lt_of_le_of_ne w e,
    rw ereal.log_lt_iff_lt_exp h at s,
    exact le_of_lt s,
  }, {
    intro w,
    have s := lt_of_le_of_ne w e,
    rw ←ereal.log_lt_iff_lt_exp h at s,
    exact le_of_lt s,
  }
end

lemma ereal.coe_sub {x y : ℝ} : ((x - y : ℝ) : ereal) = (x : ereal) - (y : ereal) := rfl

lemma monotone_ereal_log : monotone ereal.log := begin
  intros x y,
  induction x using ereal.rec, simp,
  induction y using ereal.rec, simp,
  simp [ereal.log], intro xy,
  by_cases y0 : y ≤ 0, { simp [y0], exact not_lt_of_ge (trans y0 xy) },
  by_cases x0 : x ≤ 0, { simp [x0] },
  simp [x0, y0], simp at x0 y0, rwa real.log_le_log x0 y0,
  simp, simp, intro e, rw e, simp,
end

lemma ereal.log_surjective : function.surjective ereal.log := begin
  rw function.surjective, intro x, existsi x.exp, simp,
end

lemma continuous_ereal_log : continuous ereal.log :=
  monotone_ereal_log.continuous_of_surjective ereal.log_surjective

-- Clamp x into the interval [lo, hi]
def clamp {X : Type} [linear_order X] (x lo hi : X) : X := max lo (min hi x)

-- Simple facts about clamp
@[simp] lemma clamp_bot {X : Type} [linear_order X] [order_bot X] {lo hi : X} : clamp ⊥ lo hi = lo := by simp [clamp]
@[simp] lemma clamp_top {X : Type} [linear_order X] [order_top X] {lo hi : X} : clamp ⊤ lo hi = max lo hi := by simp [clamp]
lemma le_clamp {X : Type} [linear_order X] (x lo hi : X) : lo ≤ clamp x lo hi := by simp [clamp, le_max_left]
lemma clamp_le {X : Type} [linear_order X] (x lo hi : X) : clamp x lo hi ≤ max lo hi := by simp [clamp]
lemma monotone.clamp {X : Type} [linear_order X] (lo hi : X) : monotone (λ x, clamp x lo hi) :=
  monotone.comp (monotone.max monotone_const monotone_id) (monotone.min monotone_const monotone_id)
lemma le_clamp_of_le_hi {X : Type} [linear_order X] (x lo hi : X) : x ≤ hi → x ≤ clamp x lo hi := λ h, by simp [clamp, h]
lemma clamp_le_lox {X : Type} [linear_order X] (x lo hi : X) : clamp x lo hi ≤ max lo x := by simp [clamp, max_le_iff]

-- Clamp is the identity inside the bounds
lemma clamp_inv {X : Type} [linear_order X] (x y : X) {lo hi : X} (y0 : lo < y) (y1 : y < hi) : clamp x lo hi = y ↔ x = y := begin
  rw clamp, constructor, {
    intro h,
    by_cases x1 : x < hi, {
      simp [le_of_lt x1] at h,
      by_cases x0 : lo < x, simp [le_of_lt x0] at h, exact h, simp at x0, simp [x0] at h, rw h at y0, finish,
    }, {
      simp at x1, simp [x1] at h, rw ←h at y1, simp at y1, finish,
    }
  }, {
    intro h, rw h, simp [le_of_lt y0, le_of_lt y1],
  },
end

-- Clamp is continuous
lemma continuous_clamp {X : Type} [linear_order X] [topological_space X] [order_topology X]
    (lo hi : X) : continuous (λ x, clamp x lo hi) :=
  continuous.comp (continuous.max continuous_const continuous_id) (continuous.min continuous_const continuous_id)

-- Simple facts about min, max, and ereal coe
@[simp] lemma ereal.min_coe {x y : ℝ} : min (x : ereal) y = ↑(min x y) := begin
  by_cases h : x ≤ y, simp [h], simp at h, simp [le_of_lt h],
end
@[simp] lemma ereal.max_coe {x y : ℝ} : max (x : ereal) y = ↑(max x y) := begin
  by_cases h : x ≤ y, simp [h], simp at h, simp [le_of_lt h],
end
@[simp] lemma clamp_ereal_coe {x lo hi : ℝ} : clamp (x : ereal) lo hi = ↑(clamp x lo hi) := by simp [clamp]
@[simp] lemma ereal.min_coe_finite {x y : ℝ} : (min (x : ereal) y).is_finite := ⟨min x y, by simp⟩
@[simp] lemma ereal.max_coe_finite {x y : ℝ} : (max (x : ereal) y).is_finite := ⟨max x y, by simp⟩

-- Clamping ereals produces reals for real intervals
lemma ereal_clamp_finite (x : ereal) (lo hi : ℝ) : (clamp x ↑lo ↑hi).is_finite := begin
  rw clamp, induction x using ereal.rec, simp, simp, simp,
end
@[simp] lemma ereal.clamp_ne_bot {x : ereal} {lo hi : ℝ} : clamp x lo hi ≠ ⊥ :=
  ne_of_gt (lt_of_lt_of_le (by simp) (le_clamp x lo hi))
@[simp] lemma ereal.clamp_ne_top {x : ereal} {lo hi : ℝ} : clamp x lo hi ≠ ⊤ :=
  ne_of_lt (lt_of_le_of_lt (clamp_le x lo hi) (by simp))

-- Clamp an ereal to be between two real values
def ereal.clamp (x : ereal) (lo hi : ℝ) : ℝ := (clamp x ↑lo ↑hi).to_real

-- Facts about ereal.clamp
@[simp] lemma ereal.clamp_bot {lo hi : ℝ} : ereal.clamp ⊥ lo hi = lo := by simp [ereal.clamp]
@[simp] lemma ereal.clamp_top {lo hi : ℝ} : ereal.clamp ⊤ lo hi = max lo hi := by simp [ereal.clamp]
@[simp] lemma ereal.clamp_coe {x lo hi : ℝ} : ereal.clamp x lo hi = clamp x lo hi := by simp [ereal.clamp]
lemma ereal.le_clamp {x : ereal} {lo hi : ℝ} : lo ≤ x.clamp lo hi :=
  ereal.to_real_le_to_real (le_clamp x lo hi) (by simp) (by simp)
lemma ereal.clamp_le (x : ereal) (lo hi : ℝ) : x.clamp lo hi ≤ max lo hi :=
  ereal.to_real_le_to_real (clamp_le x lo hi) (by simp) (by simp)
lemma monotone.ereal_clamp (lo hi : ℝ) : monotone (λ x, ereal.clamp x lo hi) :=
  λ x y xy, ereal.to_real_le_to_real (monotone.clamp (lo : ereal) hi xy) (by simp) (by simp)
lemma ereal.le_clamp_of_le_hi (x : ereal) (lo hi : ℝ) : x ≤ hi → x ≤ x.clamp lo hi := begin
  intro h, rw ereal.clamp,
  rcases ereal_clamp_finite x lo hi with ⟨y,hy⟩, rw hy, simp, rw ←hy,
  exact le_clamp_of_le_hi x lo hi h,
end
lemma ereal.clamp_le_lox (x : ereal) (lo hi : ℝ) : ↑(x.clamp lo hi) ≤ max ↑lo x := begin
  rw ereal.clamp, have h := clamp_le_lox x lo hi,
  rcases ereal_clamp_finite x lo hi with ⟨y,hy⟩, rw hy at ⊢ h, exact trans (by simp) h,
end

-- ereal.clamp is the identity inside the bounds
lemma ereal.clamp_inv {x : ereal} {lo hi y : ℝ} (y0 : lo < y) (y1 : y < hi) : x.clamp lo hi = y ↔ x = y := begin
  have h := clamp_inv x y (ereal.coe_lt_coe_iff.mpr y0) (ereal.coe_lt_coe_iff.mpr y1),
  simp [ereal.clamp], rcases ereal_clamp_finite x lo hi with ⟨z,cz⟩, simp [cz] at h ⊢, assumption,
end

-- ereal.clamp is continuous in x
lemma continuous.ereal_clamp {lo hi : ℝ} : continuous (λ x, ereal.clamp x lo hi) := begin
  simp_rw ereal.clamp,
  apply ereal.continuous_on_to_real.comp_continuous (continuous_clamp _ _),
  simp,
end

-- Convert from ereal to ennreal, clamping negative values to 0
def ereal.to_ennreal : ereal → ennreal
| ⊤ := ⊤
| (x : ℝ) := ennreal.of_real x
| ⊥ := 0

lemma ereal.to_ennreal_neg {x : ereal} (h : x ≤ 0) : x.to_ennreal = 0 := begin
  induction x using ereal.rec,
  simp [ereal.to_ennreal],
  simp [ereal.to_ennreal],
  have e : (0 : ereal) = ((0 : ℝ) : ereal) := by simp,
  rw [e, ereal.coe_le_coe_iff] at h, exact h,
  simp at h, finish,
end

@[simp] lemma ereal.to_real_to_ennreal {x : ereal} : x.to_ennreal.to_real = max 0 x.to_real := begin
  by_cases h : x < 0, {
    simp [ereal.to_ennreal_neg (le_of_lt h)],
    induction x using ereal.rec, simp,
    have e : (0 : ereal) = ((0 : ℝ) : ereal) := by simp,
    rw [e, ereal.coe_lt_coe_iff] at h, simp [le_of_lt h],
    simp,
  }, {
    simp at h,
    induction x using ereal.rec,
    simp [ereal.to_ennreal], swap, simp [ereal.to_ennreal],
    simp [ereal.to_ennreal],
    have e : (0 : ereal) = ((0 : ℝ) : ereal) := by simp,
    rw [e, ereal.coe_le_coe_iff] at h, simp [ennreal.to_real_of_real h, h],
  }
end

lemma ereal.to_ennreal_ne_top_iff {x : ereal} : x.to_ennreal ≠ ⊤ ↔ x ≠ ⊤ := begin
  induction x using ereal.rec, simp [ereal.to_ennreal], simp [ereal.to_ennreal], simp [ereal.to_ennreal],
end

@[simp] lemma ereal.to_ennreal_coe {x : ennreal} : (x : ereal).to_ennreal = x := begin
  induction x using with_top.rec_top_coe,
  simp [ereal.to_ennreal],
  rw ←ennreal.to_real_eq_to_real,
  simp, swap, simp,
  rw ereal.to_ennreal_ne_top_iff, simp,
end

lemma ereal.coe_to_ennreal {x : ereal} (h : x ≥ 0) : ↑(x.to_ennreal) = x := begin
  induction x using ereal.rec,
  simp at h, simp [h], swap, simp [ereal.to_ennreal],
  simp [ereal.to_ennreal],
  have e : (0 : ereal) = ((0 : ℝ) : ereal) := by simp,
  have h' := simple.ge_to_le h,
  rw [e, ereal.coe_le_coe_iff] at h',
  rw ←real.coe_to_nnreal _ h',
  generalize hy : x.to_nnreal = y,
  rw ←ereal.coe_nnreal_eq_coe_real,
  simp,
end


/-
Copyright (c) 2021 Sara Díaz Real. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sara Díaz Real
-/
import data.int.basic
import algebra.associated
import tactic.linarith
import tactic.linear_combination

/-!
# IMO 2001 Q6
Let $a$, $b$, $c$, $d$ be integers with $a > b > c > d > 0$. Suppose that

$$ a*c + b*d = (a + b - c + d) * (-a + b + c + d). $$

Prove that $a*b + c*d$ is not prime.

-/

variables {a b c d : ℤ}

theorem imo2001_q6 (hd : 0 < d) (hdc : d < c) (hcb : c < b) (hba : b < a)
  (h : a*c + b*d = (a + b - c + d) * (-a + b + c + d)) :
  ¬ prime (a*b + c*d) :=
begin
  assume h0 : prime (a*b + c*d),
  have ha : 0 < a, { linarith },
  have hb : 0 < b, { linarith },
  have hc : 0 < c, { linarith },
  -- the key step is to show that `a*c + b*d` divides the product `(a*b + c*d) * (a*d + b*c)`
  have dvd_mul : a*c + b*d ∣ (a*b + c*d) * (a*d + b*c),
  { use b^2 + b*d + d^2,
    linear_combination (h, b*d) },
  -- since `a*b + c*d` is prime (by assumption), it must divide `a*c + b*d` or `a*d + b*c`
  obtain (h1 : a*b + c*d ∣ a*c + b*d) | (h2 : a*c + b*d ∣ a*d + b*c) :=
    h0.left_dvd_or_dvd_right_of_dvd_mul dvd_mul,
  -- in both cases, we derive a contradiction
  { have aux : 0 < a*c + b*d,         { nlinarith only [ha, hb, hc, hd] },
    have : a*b + c*d ≤ a*c + b*d,     { from int.le_of_dvd aux h1 },
    nlinarith only [hba, hcb, hdc, h, this] },
  { have aux : 0 < a*d + b*c,         { nlinarith only [ha, hb, hc, hd] },
    have : a*c + b*d ≤ a*d + b*c,     { from int.le_of_dvd aux h2 },
    nlinarith only [hba, hdc, h, this] },
end


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import field_theory.intermediate_field
import ring_theory.adjoin.field

/-!
# Splitting fields

This file introduces the notion of a splitting field of a polynomial and provides an embedding from
a splitting field to any field that splits the polynomial. A polynomial `f : K[X]` splits
over a field extension `L` of `K` if it is zero or all of its irreducible factors over `L` have
degree `1`. A field extension of `K` of a polynomial `f : K[X]` is called a splitting field
if it is the smallest field extension of `K` such that `f` splits.

## Main definitions

* `polynomial.splitting_field f`: A fixed splitting field of the polynomial `f`.
* `polynomial.is_splitting_field`: A predicate on a field to be a splitting field of a polynomial
  `f`.

## Main statements

* `polynomial.is_splitting_field.lift`: An embedding of a splitting field of the polynomial `f` into
  another field such that `f` splits.
* `polynomial.is_splitting_field.alg_equiv`: Every splitting field of a polynomial `f` is isomorphic
  to `splitting_field f` and thus, being a splitting field is unique up to isomorphism.

-/

noncomputable theory
open_locale classical big_operators polynomial

universes u v w

variables {F : Type u} {K : Type v} {L : Type w}

namespace polynomial

variables [field K] [field L] [field F]
open polynomial

section splitting_field

/-- Non-computably choose an irreducible factor from a polynomial. -/
def factor (f : K[X]) : K[X] :=
if H : ∃ g, irreducible g ∧ g ∣ f then classical.some H else X

lemma irreducible_factor (f : K[X]) : irreducible (factor f) :=
begin
  rw factor, split_ifs with H, { exact (classical.some_spec H).1 }, { exact irreducible_X }
end

/-- See note [fact non-instances]. -/
lemma fact_irreducible_factor (f : K[X]) : fact (irreducible (factor f)) :=
⟨irreducible_factor f⟩

local attribute [instance] fact_irreducible_factor

theorem factor_dvd_of_not_is_unit {f : K[X]} (hf1 : ¬is_unit f) : factor f ∣ f :=
begin
  by_cases hf2 : f = 0, { rw hf2, exact dvd_zero _ },
  rw [factor, dif_pos (wf_dvd_monoid.exists_irreducible_factor hf1 hf2)],
  exact (classical.some_spec $ wf_dvd_monoid.exists_irreducible_factor hf1 hf2).2
end

theorem factor_dvd_of_degree_ne_zero {f : K[X]} (hf : f.degree ≠ 0) : factor f ∣ f :=
factor_dvd_of_not_is_unit (mt degree_eq_zero_of_is_unit hf)

theorem factor_dvd_of_nat_degree_ne_zero {f : K[X]} (hf : f.nat_degree ≠ 0) :
  factor f ∣ f :=
factor_dvd_of_degree_ne_zero (mt nat_degree_eq_of_degree_eq_some hf)

/-- Divide a polynomial f by X - C r where r is a root of f in a bigger field extension. -/
def remove_factor (f : K[X]) : polynomial (adjoin_root $ factor f) :=
map (adjoin_root.of f.factor) f /ₘ (X - C (adjoin_root.root f.factor))

theorem X_sub_C_mul_remove_factor (f : K[X]) (hf : f.nat_degree ≠ 0) :
  (X - C (adjoin_root.root f.factor)) * f.remove_factor = map (adjoin_root.of f.factor) f :=
let ⟨g, hg⟩ := factor_dvd_of_nat_degree_ne_zero hf in
mul_div_by_monic_eq_iff_is_root.2 $ by rw [is_root.def, eval_map, hg, eval₂_mul, ← hg,
    adjoin_root.eval₂_root, zero_mul]

theorem nat_degree_remove_factor (f : K[X]) :
  f.remove_factor.nat_degree = f.nat_degree - 1 :=
by rw [remove_factor, nat_degree_div_by_monic _ (monic_X_sub_C _), nat_degree_map,
       nat_degree_X_sub_C]

theorem nat_degree_remove_factor' {f : K[X]} {n : ℕ} (hfn : f.nat_degree = n+1) :
  f.remove_factor.nat_degree = n :=
by rw [nat_degree_remove_factor, hfn, n.add_sub_cancel]

/-- Auxiliary construction to a splitting field of a polynomial, which removes
`n` (arbitrarily-chosen) factors.

Uses recursion on the degree. For better definitional behaviour, structures
including `splitting_field_aux` (such as instances) should be defined using
this recursion in each field, rather than defining the whole tuple through
recursion.
-/
def splitting_field_aux (n : ℕ) : Π {K : Type u} [field K], by exactI Π (f : K[X]), Type u :=
nat.rec_on n (λ K _ _, K) $ λ n ih K _ f, by exactI
ih f.remove_factor

namespace splitting_field_aux

theorem succ (n : ℕ) (f : K[X]) :
  splitting_field_aux (n+1) f = splitting_field_aux n f.remove_factor := rfl

instance field (n : ℕ) : Π {K : Type u} [field K], by exactI
  Π {f : K[X]}, field (splitting_field_aux n f) :=
nat.rec_on n (λ K _ _, ‹field K›) $ λ n ih K _ f, ih

instance inhabited {n : ℕ} {f : K[X]} :
  inhabited (splitting_field_aux n f) := ⟨37⟩

/-
Note that the recursive nature of this definition and `splitting_field_aux.field` creates
non-definitionally-equal diamonds in the `ℕ`- and `ℤ`- actions.
```lean
example (n : ℕ) {K : Type u} [field K] {f : K[X]} (hfn : f.nat_degree = n) :
    (add_comm_monoid.nat_module : module ℕ (splitting_field_aux n f hfn)) =
  @algebra.to_module _ _ _ _ (splitting_field_aux.algebra n _ hfn) :=
rfl  -- fails
```
It's not immediately clear whether this _can_ be fixed; the failure is much the same as the reason
that the following fails:
```lean
def cases_twice {α} (a₀ aₙ : α) : ℕ → α × α
| 0 := (a₀, a₀)
| (n + 1) := (aₙ, aₙ)

example (x : ℕ) {α} (a₀ aₙ : α) : (cases_twice a₀ aₙ x).1 = (cases_twice a₀ aₙ x).2 := rfl  -- fails
```
We don't really care at this point because this is an implementation detail (which is why this is
not a docstring), but we do in `splitting_field.algebra'` below. -/
instance algebra (n : ℕ) : Π (R : Type*) {K : Type u} [comm_semiring R] [field K],
  by exactI Π [algebra R K] {f : K[X]},
    algebra R (splitting_field_aux n f) :=
nat.rec_on n (λ R K _ _ _ _, by exactI ‹algebra R K›) $
         λ n ih R K _ _ _ f, by exactI ih R

instance is_scalar_tower (n : ℕ) : Π (R₁ R₂ : Type*) {K : Type u}
  [comm_semiring R₁] [comm_semiring R₂] [has_smul R₁ R₂] [field K],
  by exactI Π [algebra R₁ K] [algebra R₂ K],
  by exactI Π [is_scalar_tower R₁ R₂ K] {f : K[X]},
    is_scalar_tower R₁ R₂ (splitting_field_aux n f) :=
nat.rec_on n (λ R₁ R₂ K _ _ _ _ _ _ _ _, by exactI ‹is_scalar_tower R₁ R₂ K›) $
         λ n ih R₁ R₂ K _ _ _ _ _ _ _ f, by exactI ih R₁ R₂

instance algebra''' {n : ℕ} {f : K[X]} :
  algebra (adjoin_root f.factor)
    (splitting_field_aux n f.remove_factor) :=
splitting_field_aux.algebra n _

instance algebra' {n : ℕ} {f : K[X]} :
  algebra (adjoin_root f.factor) (splitting_field_aux n.succ f) :=
splitting_field_aux.algebra'''

instance algebra'' {n : ℕ} {f : K[X]} :
  algebra K (splitting_field_aux n f.remove_factor) :=
splitting_field_aux.algebra n K

instance scalar_tower' {n : ℕ} {f : K[X]} :
  is_scalar_tower K (adjoin_root f.factor)
    (splitting_field_aux n f.remove_factor) :=
begin
  -- finding this instance ourselves makes things faster
  haveI : is_scalar_tower K (adjoin_root f.factor) (adjoin_root f.factor) :=
    is_scalar_tower.right,
  exact
    splitting_field_aux.is_scalar_tower n K (adjoin_root f.factor),
end

instance scalar_tower {n : ℕ} {f : K[X]} :
  is_scalar_tower K (adjoin_root f.factor) (splitting_field_aux (n + 1) f) :=
splitting_field_aux.scalar_tower'

theorem algebra_map_succ (n : ℕ) (f : K[X]) :
  by exact algebra_map K (splitting_field_aux (n+1) f) =
    (algebra_map (adjoin_root f.factor)
        (splitting_field_aux n f.remove_factor)).comp
      (adjoin_root.of f.factor) :=
is_scalar_tower.algebra_map_eq _ _ _

protected theorem splits (n : ℕ) : ∀ {K : Type u} [field K], by exactI
  ∀ (f : K[X]) (hfn : f.nat_degree = n),
    splits (algebra_map K $ splitting_field_aux n f) f :=
nat.rec_on n (λ K _ _ hf, by exactI splits_of_degree_le_one _
  (le_trans degree_le_nat_degree $ hf.symm ▸ with_bot.coe_le_coe.2 zero_le_one)) $ λ n ih K _ f hf,
by { resetI, rw [← splits_id_iff_splits, algebra_map_succ, ← map_map, splits_id_iff_splits,
    ← X_sub_C_mul_remove_factor f (λ h, by { rw h at hf, cases hf })],
exact splits_mul _ (splits_X_sub_C _) (ih _ (nat_degree_remove_factor' hf)) }

theorem exists_lift (n : ℕ) : ∀ {K : Type u} [field K], by exactI
  ∀ (f : K[X]) (hfn : f.nat_degree = n) {L : Type*} [field L], by exactI
    ∀ (j : K →+* L) (hf : splits j f), ∃ k : splitting_field_aux n f →+* L,
      k.comp (algebra_map _ _) = j :=
nat.rec_on n (λ K _ _ _ L _ j _, by exactI ⟨j, j.comp_id⟩) $ λ n ih K _ f hf L _ j hj, by exactI
have hndf : f.nat_degree ≠ 0, by { intro h, rw h at hf, cases hf },
have hfn0 : f ≠ 0, by { intro h, rw h at hndf, exact hndf rfl },
let ⟨r, hr⟩ := exists_root_of_splits _ (splits_of_splits_of_dvd j hfn0 hj
  (factor_dvd_of_nat_degree_ne_zero hndf))
  (mt is_unit_iff_degree_eq_zero.2 f.irreducible_factor.1) in
have hmf0 : map (adjoin_root.of f.factor) f ≠ 0, from map_ne_zero hfn0,
have hsf : splits (adjoin_root.lift j r hr) f.remove_factor,
by { rw ← X_sub_C_mul_remove_factor _ hndf at hmf0, refine (splits_of_splits_mul _ hmf0 _).2,
  rwa [X_sub_C_mul_remove_factor _ hndf, ← splits_id_iff_splits, map_map, adjoin_root.lift_comp_of,
      splits_id_iff_splits] },
let ⟨k, hk⟩ := ih f.remove_factor (nat_degree_remove_factor' hf) (adjoin_root.lift j r hr) hsf in
⟨k, by rw [algebra_map_succ, ← ring_hom.comp_assoc, hk, adjoin_root.lift_comp_of]⟩

theorem adjoin_roots (n : ℕ) : ∀ {K : Type u} [field K], by exactI
  ∀ (f : K[X]) (hfn : f.nat_degree = n),
    algebra.adjoin K (↑(f.map $ algebra_map K $ splitting_field_aux n f).roots.to_finset :
      set (splitting_field_aux n f)) = ⊤ :=
nat.rec_on n (λ K _ f hf, by exactI algebra.eq_top_iff.2 (λ x, subalgebra.range_le _ ⟨x, rfl⟩)) $
λ n ih K _ f hfn, by exactI
have hndf : f.nat_degree ≠ 0, by { intro h, rw h at hfn, cases hfn },
have hfn0 : f ≠ 0, by { intro h, rw h at hndf, exact hndf rfl },
have hmf0 : map (algebra_map K (splitting_field_aux n.succ f)) f ≠ 0 := map_ne_zero hfn0,
by { rw [algebra_map_succ, ← map_map, ← X_sub_C_mul_remove_factor _ hndf,
         polynomial.map_mul] at hmf0 ⊢,
rw [roots_mul hmf0, polynomial.map_sub, map_X, map_C, roots_X_sub_C, multiset.to_finset_add,
    finset.coe_union, multiset.to_finset_singleton, finset.coe_singleton,
    algebra.adjoin_union_eq_adjoin_adjoin, ← set.image_singleton,
    algebra.adjoin_algebra_map K (adjoin_root f.factor)
      (splitting_field_aux n f.remove_factor),
    adjoin_root.adjoin_root_eq_top, algebra.map_top,
    is_scalar_tower.adjoin_range_to_alg_hom K (adjoin_root f.factor)
      (splitting_field_aux n f.remove_factor),
    ih _ (nat_degree_remove_factor' hfn), subalgebra.restrict_scalars_top] }

end splitting_field_aux

/-- A splitting field of a polynomial. -/
def splitting_field (f : K[X]) :=
splitting_field_aux f.nat_degree f

namespace splitting_field

variables (f : K[X])

instance : field (splitting_field f) :=
splitting_field_aux.field _

instance inhabited : inhabited (splitting_field f) := ⟨37⟩

/-- This should be an instance globally, but it creates diamonds with the `ℕ`, `ℤ`, and `ℚ` algebras
(via their `smul` and `to_fun` fields):

```lean
example :
  (algebra_nat : algebra ℕ (splitting_field f)) = splitting_field.algebra' f :=
rfl  -- fails

example :
  (algebra_int _ : algebra ℤ (splitting_field f)) = splitting_field.algebra' f :=
rfl  -- fails

example [char_zero K] [char_zero (splitting_field f)] :
  (algebra_rat : algebra ℚ (splitting_field f)) = splitting_field.algebra' f :=
rfl  -- fails
```

Until we resolve these diamonds, it's more convenient to only turn this instance on with
`local attribute [instance]` in places where the benefit of having the instance outweighs the cost.

In the meantime, the `splitting_field.algebra` instance below is immune to these particular diamonds
since `K = ℕ` and `K = ℤ` are not possible due to the `field K` assumption. Diamonds in
`algebra ℚ (splitting_field f)` instances are still possible via this instance unfortunately, but
these are less common as they require suitable `char_zero` instances to be present.
-/
instance algebra' {R} [comm_semiring R] [algebra R K] : algebra R (splitting_field f) :=
splitting_field_aux.algebra _ _

instance : algebra K (splitting_field f) :=
splitting_field_aux.algebra _ _

protected theorem splits : splits (algebra_map K (splitting_field f)) f :=
splitting_field_aux.splits _ _ rfl

variables [algebra K L] (hb : splits (algebra_map K L) f)

/-- Embeds the splitting field into any other field that splits the polynomial. -/
def lift : splitting_field f →ₐ[K] L :=
{ commutes' := λ r, by { have := classical.some_spec (splitting_field_aux.exists_lift _ _ rfl _ hb),
    exact ring_hom.ext_iff.1 this r },
  .. classical.some (splitting_field_aux.exists_lift _ _ _ _ hb) }

theorem adjoin_roots : algebra.adjoin K
    (↑(f.map (algebra_map K $ splitting_field f)).roots.to_finset : set (splitting_field f)) = ⊤ :=
splitting_field_aux.adjoin_roots _ _ rfl

theorem adjoin_root_set : algebra.adjoin K (f.root_set f.splitting_field) = ⊤ :=
adjoin_roots f

end splitting_field

variables (K L) [algebra K L]
/-- Typeclass characterising splitting fields. -/
class is_splitting_field (f : K[X]) : Prop :=
(splits [] : splits (algebra_map K L) f)
(adjoin_roots [] : algebra.adjoin K (↑(f.map (algebra_map K L)).roots.to_finset : set L) = ⊤)

namespace is_splitting_field

variables {K}
instance splitting_field (f : K[X]) : is_splitting_field K (splitting_field f) f :=
⟨splitting_field.splits f, splitting_field.adjoin_roots f⟩

section scalar_tower

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

variables {K}
instance map (f : F[X]) [is_splitting_field F L f] :
  is_splitting_field K L (f.map $ algebra_map F K) :=
⟨by { rw [splits_map_iff, ← is_scalar_tower.algebra_map_eq], exact splits L f },
 subalgebra.restrict_scalars_injective F $
  by { rw [map_map, ← is_scalar_tower.algebra_map_eq, subalgebra.restrict_scalars_top,
    eq_top_iff, ← adjoin_roots L f, algebra.adjoin_le_iff],
  exact λ x hx, @algebra.subset_adjoin K _ _ _ _ _ _ hx }⟩

variables {K} (L)
theorem splits_iff (f : K[X]) [is_splitting_field K L f] :
  polynomial.splits (ring_hom.id K) f ↔ (⊤ : subalgebra K L) = ⊥ :=
⟨λ h, eq_bot_iff.2 $ adjoin_roots L f ▸ (roots_map (algebra_map K L) h).symm ▸
  algebra.adjoin_le_iff.2 (λ y hy,
    let ⟨x, hxs, hxy⟩ := finset.mem_image.1 (by rwa multiset.to_finset_map at hy) in
    hxy ▸ set_like.mem_coe.2 $ subalgebra.algebra_map_mem _ _),
 λ h, @ring_equiv.to_ring_hom_refl K _ ▸
  ring_equiv.self_trans_symm (ring_equiv.of_bijective _ $ algebra.bijective_algebra_map_iff.2 h) ▸
  by { rw ring_equiv.to_ring_hom_trans, exact splits_comp_of_splits _ _ (splits L f) }⟩

theorem mul (f g : F[X]) (hf : f ≠ 0) (hg : g ≠ 0) [is_splitting_field F K f]
  [is_splitting_field K L (g.map $ algebra_map F K)] :
  is_splitting_field F L (f * g) :=
⟨(is_scalar_tower.algebra_map_eq F K L).symm ▸ splits_mul _
  (splits_comp_of_splits _ _ (splits K f))
  ((splits_map_iff _ _).1 (splits L $ g.map $ algebra_map F K)),
 by rw [polynomial.map_mul, roots_mul (mul_ne_zero (map_ne_zero hf : f.map (algebra_map F L) ≠ 0)
        (map_ne_zero hg)), multiset.to_finset_add, finset.coe_union,
      algebra.adjoin_union_eq_adjoin_adjoin,
      is_scalar_tower.algebra_map_eq F K L, ← map_map,
      roots_map (algebra_map K L) ((splits_id_iff_splits $ algebra_map F K).2 $ splits K f),
      multiset.to_finset_map, finset.coe_image, algebra.adjoin_algebra_map, adjoin_roots,
      algebra.map_top, is_scalar_tower.adjoin_range_to_alg_hom, ← map_map, adjoin_roots,
      subalgebra.restrict_scalars_top]⟩

end scalar_tower

/-- Splitting field of `f` embeds into any field that splits `f`. -/
def lift [algebra K F] (f : K[X]) [is_splitting_field K L f]
  (hf : polynomial.splits (algebra_map K F) f) : L →ₐ[K] F :=
if hf0 : f = 0 then (algebra.of_id K F).comp $
  (algebra.bot_equiv K L : (⊥ : subalgebra K L) →ₐ[K] K).comp $
  by { rw ← (splits_iff L f).1 (show f.splits (ring_hom.id K), from hf0.symm ▸ splits_zero _),
  exact algebra.to_top } else
alg_hom.comp (by { rw ← adjoin_roots L f, exact classical.choice (lift_of_splits _ $ λ y hy,
    have aeval y f = 0, from (eval₂_eq_eval_map _).trans $
      (mem_roots $ by exact map_ne_zero hf0).1 (multiset.mem_to_finset.mp hy),
    ⟨is_algebraic_iff_is_integral.1 ⟨f, hf0, this⟩,
      splits_of_splits_of_dvd _ hf0 hf $ minpoly.dvd _ _ this⟩) })
  algebra.to_top

theorem finite_dimensional (f : K[X]) [is_splitting_field K L f] : finite_dimensional K L :=
⟨@algebra.top_to_submodule K L _ _ _ ▸ adjoin_roots L f ▸
  fg_adjoin_of_finite (finset.finite_to_set _) (λ y hy,
  if hf : f = 0
  then by { rw [hf, polynomial.map_zero, roots_zero] at hy, cases hy }
  else is_algebraic_iff_is_integral.1 ⟨f, hf, (eval₂_eq_eval_map _).trans $
    (mem_roots $ by exact map_ne_zero hf).1 (multiset.mem_to_finset.mp hy)⟩)⟩

instance (f : K[X]) : _root_.finite_dimensional K f.splitting_field :=
finite_dimensional f.splitting_field f

/-- Any splitting field is isomorphic to `splitting_field f`. -/
def alg_equiv (f : K[X]) [is_splitting_field K L f] : L ≃ₐ[K] splitting_field f :=
begin
  refine alg_equiv.of_bijective (lift L f $ splits (splitting_field f) f)
    ⟨ring_hom.injective (lift L f $ splits (splitting_field f) f).to_ring_hom, _⟩,
  haveI := finite_dimensional (splitting_field f) f,
  haveI := finite_dimensional L f,
  have : finite_dimensional.finrank K L = finite_dimensional.finrank K (splitting_field f) :=
  le_antisymm
    (linear_map.finrank_le_finrank_of_injective
      (show function.injective (lift L f $ splits (splitting_field f) f).to_linear_map, from
        ring_hom.injective (lift L f $ splits (splitting_field f) f : L →+* f.splitting_field)))
    (linear_map.finrank_le_finrank_of_injective
      (show function.injective (lift (splitting_field f) f $ splits L f).to_linear_map, from
        ring_hom.injective (lift (splitting_field f) f $ splits L f : f.splitting_field →+* L))),
  change function.surjective (lift L f $ splits (splitting_field f) f).to_linear_map,
  refine (linear_map.injective_iff_surjective_of_finrank_eq_finrank this).1 _,
  exact ring_hom.injective (lift L f $ splits (splitting_field f) f : L →+* f.splitting_field)
end

lemma of_alg_equiv [algebra K F] (p : K[X]) (f : F ≃ₐ[K] L) [is_splitting_field K F p] :
  is_splitting_field K L p :=
begin
  split,
  { rw ← f.to_alg_hom.comp_algebra_map,
    exact splits_comp_of_splits _ _ (splits F p) },
  { rw [←(algebra.range_top_iff_surjective f.to_alg_hom).mpr f.surjective,
        ←root_set, adjoin_root_set_eq_range (splits F p), root_set, adjoin_roots F p] },
end

end is_splitting_field

end splitting_field

end polynomial

namespace intermediate_field

open polynomial

variables [field K] [field L] [algebra K L] {p : K[X]}

lemma splits_of_splits {F : intermediate_field K L} (h : p.splits (algebra_map K L))
  (hF : ∀ x ∈ p.root_set L, x ∈ F) : p.splits (algebra_map K F) :=
begin
  simp_rw [root_set, finset.mem_coe, multiset.mem_to_finset] at hF,
  rw splits_iff_exists_multiset,
  refine ⟨multiset.pmap subtype.mk _ hF, map_injective _ (algebra_map F L).injective _⟩,
  conv_lhs { rw [polynomial.map_map, ←is_scalar_tower.algebra_map_eq,
    eq_prod_roots_of_splits h, ←multiset.pmap_eq_map _ _ _ hF] },
  simp_rw [polynomial.map_mul, polynomial.map_multiset_prod,
    multiset.map_pmap, polynomial.map_sub, map_C, map_X],
  refl,
end

end intermediate_field


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alexander Bentkamp, Yury Kudriashov
-/
import analysis.convex.basic
import analysis.normed_space.finite_dimension
import topology.path_connected

/-!
# Topological and metric properties of convex sets

We prove the following facts:

* `convex.interior` : interior of a convex set is convex;
* `convex.closure` : closure of a convex set is convex;
* `set.finite.compact_convex_hull` : convex hull of a finite set is compact;
* `set.finite.is_closed_convex_hull` : convex hull of a finite set is closed;
* `convex_on_dist` : distance to a fixed point is convex on any convex set;
* `convex_hull_ediam`, `convex_hull_diam` : convex hull of a set has the same (e)metric diameter
  as the original set;
* `bounded_convex_hull` : convex hull of a set is bounded if and only if the original set
  is bounded.
* `bounded_std_simplex`, `is_closed_std_simplex`, `compact_std_simplex`: topological properties
  of the standard simplex;
-/

variables {ι : Type*} {E : Type*}

open set

lemma real.convex_iff_is_preconnected {s : set ℝ} : convex s ↔ is_preconnected s :=
real.convex_iff_ord_connected.trans is_preconnected_iff_ord_connected.symm

alias real.convex_iff_is_preconnected ↔ convex.is_preconnected is_preconnected.convex

/-! ### Standard simplex -/

section std_simplex

variables [fintype ι]

/-- Every vector in `std_simplex ι` has `max`-norm at most `1`. -/
lemma std_simplex_subset_closed_ball :
  std_simplex ι ⊆ metric.closed_ball 0 1 :=
begin
  assume f hf,
  rw [metric.mem_closed_ball, dist_zero_right],
  refine (nnreal.coe_one ▸ nnreal.coe_le_coe.2 $ finset.sup_le $ λ x hx, _),
  change abs (f x) ≤ 1,
  rw [abs_of_nonneg $ hf.1 x],
  exact (mem_Icc_of_mem_std_simplex hf x).2
end

variable (ι)

/-- `std_simplex ι` is bounded. -/
lemma bounded_std_simplex : metric.bounded (std_simplex ι) :=
(metric.bounded_iff_subset_ball 0).2 ⟨1, std_simplex_subset_closed_ball⟩

/-- `std_simplex ι` is closed. -/
lemma is_closed_std_simplex : is_closed (std_simplex ι) :=
(std_simplex_eq_inter ι).symm ▸ is_closed_inter
  (is_closed_Inter $ λ i, is_closed_le continuous_const (continuous_apply i))
  (is_closed_eq (continuous_finset_sum _ $ λ x _, continuous_apply x) continuous_const)

/-- `std_simplex ι` is compact. -/
lemma compact_std_simplex : is_compact (std_simplex ι) :=
metric.compact_iff_closed_bounded.2 ⟨is_closed_std_simplex ι, bounded_std_simplex ι⟩

end std_simplex

/-! ### Topological vector space -/

section has_continuous_smul

variables [add_comm_group E] [module ℝ E] [topological_space E]
  [topological_add_group E] [has_continuous_smul ℝ E]

/-- In a topological vector space, the interior of a convex set is convex. -/
lemma convex.interior {s : set E} (hs : convex s) : convex (interior s) :=
convex_iff_pointwise_add_subset.mpr $ λ a b ha hb hab,
  have h : is_open (a • interior s + b • interior s), from
  or.elim (classical.em (a = 0))
  (λ heq,
    have hne : b ≠ 0, by { rw [heq, zero_add] at hab, rw hab, exact one_ne_zero },
    by { rw ← image_smul,
         exact (is_open_map_smul' hne _ is_open_interior).add_left } )
  (λ hne,
    by { rw ← image_smul,
         exact (is_open_map_smul' hne _ is_open_interior).add_right }),
  (subset_interior_iff_subset_of_open h).mpr $ subset.trans
    (by { simp only [← image_smul], apply add_subset_add; exact image_subset _ interior_subset })
    (convex_iff_pointwise_add_subset.mp hs ha hb hab)

/-- In a topological vector space, the closure of a convex set is convex. -/
lemma convex.closure {s : set E} (hs : convex s) : convex (closure s) :=
λ x y hx hy a b ha hb hab,
let f : E → E → E := λ x' y', a • x' + b • y' in
have hf : continuous (λ p : E × E, f p.1 p.2), from
  (continuous_const.smul continuous_fst).add (continuous_const.smul continuous_snd),
show f x y ∈ closure s, from
  mem_closure_of_continuous2 hf hx hy (λ x' hx' y' hy', subset_closure
  (hs hx' hy' ha hb hab))

/-- Convex hull of a finite set is compact. -/
lemma set.finite.compact_convex_hull {s : set E} (hs : finite s) :
  is_compact (convex_hull s) :=
begin
  rw [hs.convex_hull_eq_image],
  apply (compact_std_simplex _).image,
  haveI := hs.fintype,
  apply linear_map.continuous_on_pi
end

/-- Convex hull of a finite set is closed. -/
lemma set.finite.is_closed_convex_hull [t2_space E] {s : set E} (hs : finite s) :
  is_closed (convex_hull s) :=
hs.compact_convex_hull.is_closed

end has_continuous_smul

/-! ### Normed vector space -/

section normed_space
variables [normed_group E] [normed_space ℝ E]

lemma convex_on_dist (z : E) (s : set E) (hs : convex s) :
  convex_on s (λz', dist z' z) :=
and.intro hs $
assume x y hx hy a b ha hb hab,
calc
  dist (a • x + b • y) z = ∥ (a • x + b • y) - (a + b) • z ∥ :
    by rw [hab, one_smul, normed_group.dist_eq]
  ... = ∥a • (x - z) + b • (y - z)∥ :
    by rw [add_smul, smul_sub, smul_sub, sub_eq_add_neg, sub_eq_add_neg, sub_eq_add_neg, neg_add,
           ←add_assoc, add_assoc (a • x), add_comm (b • y)]; simp only [add_assoc]
  ... ≤ ∥a • (x - z)∥ + ∥b • (y - z)∥ :
    norm_add_le (a • (x - z)) (b • (y - z))
  ... = a * dist x z + b * dist y z :
    by simp [norm_smul, normed_group.dist_eq, real.norm_eq_abs, abs_of_nonneg ha, abs_of_nonneg hb]

lemma convex_ball (a : E) (r : ℝ) : convex (metric.ball a r) :=
by simpa only [metric.ball, sep_univ] using (convex_on_dist a _ convex_univ).convex_lt r

lemma convex_closed_ball (a : E) (r : ℝ) : convex (metric.closed_ball a r) :=
by simpa only [metric.closed_ball, sep_univ] using (convex_on_dist a _ convex_univ).convex_le r

/-- Given a point `x` in the convex hull of `s` and a point `y`, there exists a point
of `s` at distance at least `dist x y` from `y`. -/
lemma convex_hull_exists_dist_ge {s : set E} {x : E} (hx : x ∈ convex_hull s) (y : E) :
  ∃ x' ∈ s, dist x y ≤ dist x' y :=
(convex_on_dist y _ (convex_convex_hull _)).exists_ge_of_mem_convex_hull hx

/-- Given a point `x` in the convex hull of `s` and a point `y` in the convex hull of `t`,
there exist points `x' ∈ s` and `y' ∈ t` at distance at least `dist x y`. -/
lemma convex_hull_exists_dist_ge2 {s t : set E} {x y : E}
  (hx : x ∈ convex_hull s) (hy : y ∈ convex_hull t) :
  ∃ (x' ∈ s) (y' ∈ t), dist x y ≤ dist x' y' :=
begin
  rcases convex_hull_exists_dist_ge hx y with ⟨x', hx', Hx'⟩,
  rcases convex_hull_exists_dist_ge hy x' with ⟨y', hy', Hy'⟩,
  use [x', hx', y', hy'],
  exact le_trans Hx' (dist_comm y x' ▸ dist_comm y' x' ▸ Hy')
end

/-- Emetric diameter of the convex hull of a set `s` equals the emetric diameter of `s. -/
@[simp] lemma convex_hull_ediam (s : set E) :
  emetric.diam (convex_hull s) = emetric.diam s :=
begin
  refine (emetric.diam_le $ λ x hx y hy, _).antisymm (emetric.diam_mono $ subset_convex_hull s),
  rcases convex_hull_exists_dist_ge2 hx hy with ⟨x', hx', y', hy', H⟩,
  rw edist_dist,
  apply le_trans (ennreal.of_real_le_of_real H),
  rw ← edist_dist,
  exact emetric.edist_le_diam_of_mem hx' hy'
end

/-- Diameter of the convex hull of a set `s` equals the emetric diameter of `s. -/
@[simp] lemma convex_hull_diam (s : set E) :
  metric.diam (convex_hull s) = metric.diam s :=
by simp only [metric.diam, convex_hull_ediam]

/-- Convex hull of `s` is bounded if and only if `s` is bounded. -/
@[simp] lemma bounded_convex_hull {s : set E} :
  metric.bounded (convex_hull s) ↔ metric.bounded s :=
by simp only [metric.bounded_iff_ediam_ne_top, convex_hull_ediam]

lemma convex.is_path_connected {s : set E} (hconv : convex s) (hne : s.nonempty) :
  is_path_connected s :=
begin
  refine is_path_connected_iff.mpr ⟨hne, _⟩,
  intros x y x_in y_in,
  let f := λ θ : ℝ, x + θ • (y - x),
  have hf : continuous f, by continuity,
  have h₀ : f 0 = x, by simp [f],
  have h₁ : f 1 = y, by { dsimp [f], rw one_smul, abel },
  have H := hconv.segment_subset x_in y_in,
  rw segment_eq_image' at H,
  exact joined_in.of_line hf.continuous_on h₀ h₁ H
end

@[priority 100]
instance normed_space.path_connected : path_connected_space E :=
path_connected_space_iff_univ.mpr $ convex_univ.is_path_connected ⟨(0 : E), trivial⟩

@[priority 100]
instance normed_space.loc_path_connected : loc_path_connected_space E :=
loc_path_connected_of_bases (λ x, metric.nhds_basis_ball)
  (λ x r r_pos, (convex_ball x r).is_path_connected $ by simp [r_pos])

end normed_space


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen, Kexing Ying, Eric Wieser
-/
import linear_algebra.quadratic_form.isometry
import analysis.special_functions.pow
import data.real.sign

/-!
# Real quadratic forms

Sylvester's law of inertia `equivalent_one_neg_one_weighted_sum_squared`:
A real quadratic form is equivalent to a weighted
sum of squares with the weights being ±1 or 0.

When the real quadratic form is nondegerate we can take the weights to be ±1,
as in `equivalent_one_zero_neg_one_weighted_sum_squared`.

-/

namespace quadratic_form

open_locale big_operators
open real finset

variables {ι : Type*} [fintype ι]

/-- The isometry between a weighted sum of squares with weights `u` on the
(non-zero) real numbers and the weighted sum of squares with weights `sign ∘ u`. -/
noncomputable def isometry_sign_weighted_sum_squares
  [decidable_eq ι] (w : ι → ℝ) :
  isometry (weighted_sum_squares ℝ w) (weighted_sum_squares ℝ (sign ∘ w)) :=
begin
  let u := λ i, if h : w i = 0 then (1 : ℝˣ) else units.mk0 (w i) h,
  have hu' : ∀ i : ι, (sign (u i) * u i) ^ - (1 / 2 : ℝ) ≠ 0,
  { intro i, refine (ne_of_lt (real.rpow_pos_of_pos
      (sign_mul_pos_of_ne_zero _ $ units.ne_zero _) _)).symm},
  convert ((weighted_sum_squares ℝ w).isometry_basis_repr
    ((pi.basis_fun ℝ ι).units_smul (λ i, (is_unit_iff_ne_zero.2 $ hu' i).unit))),
  ext1 v,
  rw [basis_repr_apply, weighted_sum_squares_apply, weighted_sum_squares_apply],
  refine sum_congr rfl (λ j hj, _),
  have hsum : (∑ (i : ι), v i • ((is_unit_iff_ne_zero.2 $ hu' i).unit : ℝ) •
    (pi.basis_fun ℝ ι) i) j = v j • (sign (u j) * u j) ^ - (1 / 2 : ℝ),
  { rw [finset.sum_apply, sum_eq_single j, pi.basis_fun_apply, is_unit.unit_spec,
        linear_map.std_basis_apply, pi.smul_apply, pi.smul_apply, function.update_same,
        smul_eq_mul, smul_eq_mul, smul_eq_mul, mul_one],
    intros i _ hij,
    rw [pi.basis_fun_apply, linear_map.std_basis_apply, pi.smul_apply, pi.smul_apply,
        function.update_noteq hij.symm, pi.zero_apply, smul_eq_mul, smul_eq_mul,
        mul_zero, mul_zero],
    intro hj', exact false.elim (hj' hj) },
  simp_rw basis.units_smul_apply,
  erw [hsum],
  simp only [u, function.comp, smul_eq_mul],
  split_ifs,
  { simp only [h, zero_smul, zero_mul, real.sign_zero] },
  have hwu : w j = u j,
  { simp only [u, dif_neg h, units.coe_mk0] },
  simp only [hwu, units.coe_mk0],
  suffices : (u j : ℝ).sign * v j * v j = (sign (u j) * u j) ^ - (1 / 2 : ℝ) *
    (sign (u j) * u j) ^ - (1 / 2 : ℝ) * u j * v j * v j,
  { erw [← mul_assoc, this], ring },
  rw [← real.rpow_add (sign_mul_pos_of_ne_zero _ $ units.ne_zero _),
      show - (1 / 2 : ℝ) + - (1 / 2) = -1, by ring, real.rpow_neg_one, mul_inv,
      inv_sign, mul_assoc (sign (u j)) (u j)⁻¹,
      inv_mul_cancel (units.ne_zero _), mul_one],
  apply_instance
end

/-- **Sylvester's law of inertia**: A nondegenerate real quadratic form is equivalent to a weighted
sum of squares with the weights being ±1. -/
theorem equivalent_one_neg_one_weighted_sum_squared
  {M : Type*} [add_comm_group M] [module ℝ M] [finite_dimensional ℝ M]
  (Q : quadratic_form ℝ M) (hQ : (associated Q).nondegenerate) :
  ∃ w : fin (finite_dimensional.finrank ℝ M) → ℝ,
  (∀ i, w i = -1 ∨ w i = 1) ∧ equivalent Q (weighted_sum_squares ℝ w) :=
let ⟨w, ⟨hw₁⟩⟩ := Q.equivalent_weighted_sum_squares_units_of_nondegenerate' hQ in
  ⟨sign ∘ coe ∘ w,
   λ i, sign_apply_eq_of_ne_zero (w i) (w i).ne_zero,
   ⟨hw₁.trans (isometry_sign_weighted_sum_squares (coe ∘ w))⟩⟩

/-- **Sylvester's law of inertia**: A real quadratic form is equivalent to a weighted
sum of squares with the weights being ±1 or 0. -/
theorem equivalent_one_zero_neg_one_weighted_sum_squared
  {M : Type*} [add_comm_group M] [module ℝ M] [finite_dimensional ℝ M]
  (Q : quadratic_form ℝ M) :
  ∃ w : fin (finite_dimensional.finrank ℝ M) → ℝ,
  (∀ i, w i = -1 ∨ w i = 0 ∨ w i = 1) ∧ equivalent Q (weighted_sum_squares ℝ w) :=
let ⟨w, ⟨hw₁⟩⟩ := Q.equivalent_weighted_sum_squares in
  ⟨sign ∘ coe ∘ w,
   λ i, sign_apply_eq (w i),
   ⟨hw₁.trans (isometry_sign_weighted_sum_squares w)⟩⟩

end quadratic_form


/- Universe polymorphism

Type universes as you know them so far:

  Sort 0    Sort 1    Sort 2    Sort 3 ...
  Prop      Type      Type 1    Type 2 ...

Type is short for Type 0 and for Sort 1.

Prop is special. Types in Prop specify
propositions. All values of such a type
are considered equal and equally good as
proofs.

Sometimes we want to be able to specify that
any sort (whether Prop, Type, or some higher
type Universe) will do as the value of some
type parameter. The utility is that we extend
the notion of polymorphism across all universe
levels: 0, 1, 2, ... (all natural numbers).

In cases where we want definitions with this
higher level of generality, we can declare a
"universe variable" and use it as an explicit
universe level parameter to Sort or Type.
-/

universe u      -- universe variable
#check Sort 0
#check Sort 1
#check Sort u   -- used here
#check Type 0
#check Type

/-
As an example, here's a super-general definition
of the identity function. For any type universe u
(from above) and any (implicit) "type" α, funk will
take and then just return any value a of type α. We
give a few example expressions
-/
def funk {α : Sort u} (a : α) : α := a
#reduce funk 1            -- a is 1, so α = ℕ, so u = 1
#reduce funk (1 = 1)
#reduce funk nat          --
#reduce funk Prop         --
#reduce funk Type         --
#reduce funk (Type 0)     --
#reduce funk (Sort 1)     --
#reduce funk (Sort 2)     -- etc.

/-
Continuing with our example, it should now be clear that
the "funk" function is really just the identity function
on objects of any types in any type universe, from Prop
through Type on up.
-/

example : funk (1 = 1)  = (1 = 1) := rfl  --
example : funk nat      = nat     := rfl  --
example : funk (Sort 0) = Prop    := rfl  --
example : funk (Type 0) = Type    := rfl  --
example : funk (Sort 1) = Type    := rfl  --
example : funk (Sort 2) = Type 1  := rfl  -- etc.
example : funk (Sort 2) = Type 2  := rfl  -- nope

/-
Takeaway I: If you want maximally general parametric
polymorphism, generalize over universe levels, as in
the preceding example. When you see an argument of type,
Sort u, you're looking at parametric polymorphism, with
type arguments from any universe level.
-/

/- Optional

Higher-universe types, by the way, have values
that themselves contain types as "field values."
The type of a type-containing object will inhabit
the universe one higher than that of the highest
universe levels of any of its contained types.
-/