import data.complex.basic data.real.cau_seq tactic.norm_num data.nat.basic tactic.ring algebra.archimedean .series .limits
section a
open real nat is_absolute_value
noncomputable theory
local attribute [instance, priority 0] classical.prop_decidable

lemma pow_inv' {α : Type*} [discrete_field α] (a : α) (n : ℕ) : (monoid.pow a n)⁻¹ = monoid.pow a⁻¹ n := begin
  induction n with n' hi,
  simp!,
  simp!,rw [mul_inv',mul_comm,hi],
end

lemma pow_abs {α : Type*} [decidable_linear_ordered_comm_ring α] (a : α) (n : ℕ) : monoid.pow (abs a) n = abs (monoid.pow a n) := begin
  induction n with n' hi,
  simp!, simp!,rw [hi,abs_mul],
end

lemma pow_incrs_of_gt_one {α : Type*}  [linear_ordered_semiring α] {x : α} {n m : ℕ} : 1 < x → n < m → monoid.pow x n < monoid.pow x m := begin
  assume x1 nm,revert n,
  induction m with m' hi,assume n nm,
  {exact absurd nm (not_lt_of_ge (zero_le n))},
  assume n nm,
  cases m' with m'',
  {rw eq_zero_of_le_zero (le_of_lt_succ nm),simpa!,},
  cases n with n',
  {simp!, simp! at hi,
  rw ←one_mul (1 : α),
  exact mul_lt_mul x1 (le_of_lt (@hi 0 dec_trivial)) (by norm_num) (le_of_lt(lt_trans (by norm_num) x1))},
  {have hi' := @hi n' (lt_of_succ_lt_succ nm),
  suffices : x * monoid.pow x n' < x * monoid.pow x (succ m''),
    simpa [monoid.pow],
  refine mul_lt_mul' (le_refl x) hi' _ (lt_trans (by norm_num) x1),
  clear hi hi' nm m'',
  induction n' with n'' hi,
  simp!,norm_num,
  simp!,exact mul_nonneg (le_of_lt (lt_trans (by norm_num) x1)) hi},
end

lemma pow_dcrs_of_lt_one_of_pos {α : Type*}  [discrete_linear_ordered_field α] {x : α} {n m : ℕ} : x < 1 → 0 < x → n < m → monoid.pow x m < monoid.pow x n := begin
  assume x1 x0 nm,rw [←inv_lt_inv,pow_inv',pow_inv'],
  have x11 : 1 < x⁻¹ ,rw lt_inv,simpa,{norm_num},exact x0,
  exact pow_incrs_of_gt_one x11 nm,
  exact pow_pos x0 _,exact pow_pos x0 _,
end

lemma pow_unbounded_of_gt_one {α : Type*} [discrete_linear_ordered_field α] [archimedean α] {x : α} (y : α) : 1 < x → ∃ n : ℕ, y < monoid.pow x n := begin
  assume x1,
  have : ∀ m : ℕ, (x - 1) * m < monoid.pow x m ∧ 1 ≤ monoid.pow x m,
    assume m, induction m with m' hi,
    simp,{norm_num},
    rw [←add_one,nat.cast_add,nat.cast_one], simp only [mul_add,monoid.pow],rw mul_one,
    have : x * monoid.pow x m' = monoid.pow x m' + (x - 1) * monoid.pow x m',
      rw add_comm,simp[mul_add,add_mul],
    rw this,split,
    refine add_lt_add_of_lt_of_le hi.left _,rw ←sub_pos at x1,
    have :=mul_le_mul (le_refl (x - 1)) hi.right (by norm_num) (le_of_lt x1),rwa mul_one at this,
    rw [←this, ←one_mul (1 : α)],
    exact mul_le_mul (le_of_lt x1) hi.right (by norm_num) (le_of_lt (lt_trans (by norm_num) x1)),
  cases exists_nat_gt (y / (x - 1)) with n hn,
  existsi n,rw [div_lt_iff,mul_comm] at hn,
  exact lt_trans hn (this n).left,rwa sub_pos,
end

lemma geo_series_eq {α : Type*} [field α] (x : α) (n : ℕ) : x ≠ 1 → series (monoid.pow x) n = (1 - monoid.pow x (succ n)) / (1 - x) := begin
  assume x1,have x1' : 1 + -x ≠ 0,assume h,rw [eq_comm, ←sub_eq_iff_eq_add] at h,simp at h,trivial,
  induction n with n' hi,
  simp![div_self x1'],rw eq_div_iff_mul_eq,simpa,
  rw [_root_.series_succ,_root_.pow_succ _ (succ n')],
  rw hi,simp,rw [add_mul,div_mul_cancel _ x1',mul_add],ring,exact x1',
end

lemma geo_series_cau {α : Type*} [discrete_linear_ordered_field α] [archimedean α] (x : α) : abs x < 1 → is_cau_seq abs (series (monoid.pow x)) := begin
  assume x1, have : series (monoid.pow x) = λ n,(1 - monoid.pow x (succ n)) / (1 - x),
    apply funext,assume n,refine geo_series_eq x n _ ,assume h, rw h at x1,exact absurd x1 (by norm_num),rw this,
  have absx : 0 < abs (1 - x),refine abs_pos_of_ne_zero _,assume h,rw sub_eq_zero_iff_eq at h,rw ←h at x1,
  have : ¬abs (1 : α) < 1,norm_num,trivial,simp at absx,
  cases classical.em (x = 0),rw h,simp[monoid.pow],assume ε ε0,existsi 1,assume j j1,simpa!,
  have x2: 1 < (abs x)⁻¹,rw lt_inv,simpa,{norm_num},exact abs_pos_of_ne_zero h,
  have pos_x : 0 < abs x := abs_pos_of_ne_zero h,
  assume ε ε0,cases pow_unbounded_of_gt_one (2 / (ε * abs (1 - x))) x2 with i hi,
  have ε2 : 0 < 2 / (ε * abs (1 - x)) := div_pos (by norm_num) (mul_pos ε0 absx),
  rw [←pow_inv',lt_inv ε2 (pow_pos pos_x _)] at hi,
  existsi i,assume j ji,rw [inv_eq_one_div,div_div_eq_mul_div,one_mul,lt_div_iff (by norm_num : (0 : α) < 2)] at hi,
  rw [div_sub_div_same,abs_div,div_lt_iff absx],
  refine lt_of_le_of_lt _ hi,
  simp,
  refine le_trans (abs_add _ _) _,
  have : monoid.pow (abs x) i * 2 = monoid.pow (abs x) i + monoid.pow (abs x) i,ring,
  rw this,
  refine add_le_add _ _,
  {rw [←one_mul (monoid.pow (abs x) i),pow_abs,_root_.pow_succ,abs_mul],
  exact mul_le_mul_of_nonneg_right (le_of_lt x1) (abs_nonneg _)},
  {rw [abs_neg,←pow_abs],
  refine le_of_lt (pow_dcrs_of_lt_one_of_pos x1 pos_x (lt_succ_of_le ji))},
end

lemma geo_series_const_cau {α : Type*} [discrete_linear_ordered_field α] [archimedean α] (a x : α) : abs x < 1 → is_cau_seq abs (series (λ n, a * monoid.pow x n)) := begin
  assume x1 ε ε0,
  cases classical.em (a = 0),
  existsi 0,intros,rw [series_mul_left],induction j,simp!,assumption,rw h,simpa!,
  cases geo_series_cau x x1 (ε / abs a) (div_pos ε0 (abs_pos_of_ne_zero h)) with i hi,
  existsi i,assume j ji,rw [series_mul_left,series_mul_left,←mul_sub,abs_mul,mul_comm,←lt_div_iff],exact hi j ji,exact abs_pos_of_ne_zero h,
end

lemma series_cau_of_abv_le_cau {α : Type*} {β : Type*} [discrete_linear_ordered_field α] [ring β] {f : ℕ → β}
    {g : ℕ → α} {abv : β → α} [is_absolute_value abv] (n : ℕ) : (∀ m, n ≤ m → abv (f m) ≤ g m) →
    is_cau_seq abs (series g) → is_cau_seq abv (series f) := begin
  assume hm hg ε ε0,cases hg (ε / 2) (div_pos ε0 (by norm_num)) with i hi,
  existsi max n i,
  assume j ji,
  have hi₁ := hi j (le_trans (le_max_right n i) ji),
  have hi₂ := hi (max n i) (le_max_right n i),
  have sub_le := abs_sub_le (series g j) (series g i) (series g (max n i)),
  have := add_lt_add hi₁ hi₂,rw abs_sub (series g (max n i)) at this,
  have ε2 : ε / 2 + ε / 2 = ε,ring,
  rw ε2 at this,
  refine lt_of_le_of_lt _ this,
  refine le_trans _ sub_le,
  refine le_trans _ (le_abs_self _),
  generalize hk : j - max n i = k,clear this ε2 hi₂ hi₁ hi ε0 ε hg sub_le,
  rw nat.sub_eq_iff_eq_add ji at hk,rw hk, clear hk ji j,
  induction k with k' hi,simp,rw abv_zero abv,
  rw succ_add,unfold series,
  rw [add_comm,add_sub_assoc],
  refine le_trans (abv_add _ _ _) _,
  rw [add_comm (series g (k' + max n i)),add_sub_assoc],
  refine add_le_add _ _,
  refine hm _ _,rw [←zero_add n,←succ_add],refine add_le_add _ _,exact zero_le _,
  simp, exact le_max_left _ _,assumption,
end

-- The form of ratio test with  0 ≤ r < 1, and abv (f (succ m)) ≤ r * abv (f m) handled zero terms of series the best
lemma series_ratio_test {α : Type*} {β : Type*} [discrete_linear_ordered_field α]  [ring β]
    [archimedean α] {abv : β → α} [is_absolute_value abv] {f : ℕ → β} (n : ℕ) (r : α) :
    0 ≤ r → r < 1 → (∀ m, n ≤ m → abv (f (succ m)) ≤ r * abv (f m)) → is_cau_seq abv (series f)
  := begin
  assume r0 r1 h,
  refine series_cau_of_abv_le_cau (succ n) _ (geo_series_const_cau (abv (f (succ n)) * monoid.pow r⁻¹ (succ n)) r _),
  assume m mn,
  generalize hk : m - (succ n) = k,rw nat.sub_eq_iff_eq_add mn at hk,
  cases classical.em (r = 0) with r_zero r_pos,have m_pos := lt_of_lt_of_le (succ_pos n) mn,
  have := pred_le_pred mn,simp at this,
  have := h (pred m) this,simp[r_zero,succ_pred_eq_of_pos m_pos] at this,
  refine le_trans this _,refine mul_nonneg _ _,refine mul_nonneg (abv_nonneg _ _) (pow_nonneg (inv_nonneg.mpr r0) _),exact pow_nonneg r0 _,
  replace r_pos : 0 < r,cases lt_or_eq_of_le r0 with h h,exact h,exact absurd h.symm r_pos,
  revert m n,
  induction k with k' hi,assume m n h mn hk,
  rw [hk,zero_add,mul_right_comm,←pow_inv',←div_eq_mul_inv,mul_div_cancel],
  exact (ne_of_lt (pow_pos r_pos _)).symm,
  assume m n h mn hk,rw [hk,succ_add],
  have kn : k' + (succ n) ≥ (succ n), rw ←zero_add (succ n),refine add_le_add _ _,exact zero_le _,simp,
  replace hi := hi (k' + (succ n)) n h kn rfl,
  rw [(by simp!;ring : monoid.pow r (succ (k' + succ n)) = monoid.pow r (k' + succ n) * r),←mul_assoc],
  replace h := h (k' + succ n) (le_of_succ_le kn),rw mul_comm at h,
  exact le_trans h (mul_le_mul_of_nonneg_right hi r0),
  rwa abs_of_nonneg r0,
end
lemma series_cau_of_abv_cau {α : Type*} {β : Type*} [discrete_linear_ordered_field α] [ring β] {abv : β → α} {f : ℕ → β}
    [is_absolute_value abv] : is_cau_seq abs (series (λ n, abv (f n))) → is_cau_seq abv (series f) :=
   λ h, series_cau_of_abv_le_cau 0 (λ n h, le_refl _) h

lemma series_cauchy_prod {α β : Type*} [discrete_linear_ordered_field α] [ring β] {a b : ℕ → β}
{abv : β → α} [is_absolute_value abv] : is_cau_seq abs (series (λ n, abv (a n))) → is_cau_seq abv (series b) →
∀ ε : α, 0 < ε → ∃ i : ℕ, ∀ j ≥ i, abv (series a j * series b j - series (λ n,
series (λ m, a m * b (n - m)) n) j) < ε := begin
  assume ha hb ε ε0,
  cases seq_bounded_above_of_cau hb with Q hQ,
  cases seq_bounded_above_of_cau ha with P hP,
  have P0 : 0 < P,exact lt_of_le_of_lt (abs_nonneg _) (hP 0),
  have Pε0 := div_pos ε0 (mul_pos (show (2 : α) > 0, from by norm_num) P0),
  cases cau_seq.cauchy₂ ⟨_, hb⟩ Pε0 with N hN,simp at hN,
  have Qε0 := div_pos ε0 (mul_pos (show (4 : α) > 0, from by norm_num) (lt_of_le_of_lt (abv_nonneg _ _) (hQ 0))),
  cases cau_seq.cauchy₂ ⟨_, ha⟩ Qε0 with M hM,simp at hM,
  existsi 2 * (max N M + 1),
  assume K hK,have := series_series_diag_flip (λ m n, a m * b n) K,simp at this,rw this,clear this,
  have : (λ (i : ℕ), series (λ (k : ℕ), a i * b k) (K - i)) = (λ (i : ℕ), a i * series (λ (k : ℕ), b k) (K - i)),
    {apply funext,assume i,rw series_mul_left},
  rw this,clear this,simp,
  have : series (λ (i : ℕ), a i * series b (K - i)) K = series (λ (i : ℕ), a i * (series b (K - i) - series b K))
  K + series (λ i, a i * series b K) K,
    {rw ←series_add,simp[(mul_add _ _ _).symm]},
  rw this, clear this,
  rw series_mul_series,simp,
  rw abv_neg abv,
  refine lt_of_le_of_lt (abv_series_le_series_abv _) _,
  simp [abv_mul abv],
  suffices : series (λ (i : ℕ), abv (a i) * abv (series b (K - i) + -series b K)) (max N M + 1) +
  (series (λ (i : ℕ), abv (a i) * abv (series b (K - i) + -series b K)) K -series (λ (i : ℕ),
  abv (a i) * abv (series b (K - i) + -series b K)) (max N M + 1)) < ε / (2 * P) * P + ε / (4 * Q) * (2 * Q),
  { simp [(div_div_eq_div_mul _ _ _).symm] at this,
    rwa[div_mul_cancel _ (ne_of_lt P0).symm,(by norm_num : (4 : α) = 2 * 2),←div_div_eq_div_mul,mul_comm (2 : α),←mul_assoc,
    div_mul_cancel _ (ne_of_lt (lt_of_le_of_lt (abv_nonneg _ _) (hQ 0))).symm,div_mul_cancel,add_halves] at this,
    norm_num},
  refine add_lt_add _ _,
  {have : series (λ (i : ℕ), abv (a i) * abv (series b (K - i) + -series b K)) (max N M + 1) ≤ series
  (λ (i : ℕ), abv (a i) * (ε / (2 * P))) (max N M + 1),
    {refine series_le_series _,assume m mJ,refine mul_le_mul_of_nonneg_left _ _,
      {refine le_of_lt (hN (K - m) K _ _),{
      refine nat.le_sub_left_of_add_le (le_trans _ hK),
      rw[succ_mul,one_mul],
      exact add_le_add mJ (le_trans (le_max_left _ _) (le_of_lt (lt_add_one _)))},
      {refine le_trans _ hK,rw ←one_mul N,
      refine mul_le_mul (by norm_num) (by rw one_mul;exact le_trans (le_max_left _ _)
      (le_of_lt (lt_add_one _))) (zero_le _) (zero_le _)}},
      exact abv_nonneg abv _},
  refine lt_of_le_of_lt this _,
  rw [series_mul_right,mul_comm],
  specialize hP (max N M + 1),rwa abs_of_nonneg at hP,
  refine (mul_lt_mul_left Pε0).mpr hP,
  refine series_nonneg _,assume x h,exact abv_nonneg abv _},
  {have hNMK : max N M + 1 < K,
    {refine lt_of_lt_of_le _ hK,
    rw [succ_mul,one_mul,←add_zero (max N M + 1)],
    refine add_lt_add_of_le_of_lt (le_refl _) _,rw add_zero,
    refine add_pos_of_nonneg_of_pos (zero_le _) (by norm_num)},
  rw series_sub_series _ hNMK,
  have : nat.sum (λ (i : ℕ), abv (a i) * abv (series b (K - i) + -series b K)) (max N M + 2) K
  ≤ nat.sum (λ (i : ℕ), abv (a i) * (2 * Q)) (max N M + 2) K,
    {unfold nat.sum,refine series_le_series _,
    assume m hm,
    refine mul_le_mul_of_nonneg_left _ _,
    {refine le_trans (abv_add abv _ _) _,
    rw ←(by ring : Q + Q = 2 * Q),
    refine add_le_add (le_of_lt (hQ _)) _,
    rw abv_neg abv, exact le_of_lt (hQ _)},
    exact abv_nonneg abv _},
  refine lt_of_le_of_lt this _,
  rw [←series_sub_series _ hNMK,series_mul_right,series_mul_right,←sub_mul],
  refine (mul_lt_mul_right (mul_pos (by norm_num) (lt_of_le_of_lt (abv_nonneg abv _) (hQ 0)))).mpr _,
  refine lt_of_le_of_lt (le_abs_self _) _,
  refine hM _ _ _ (le_trans (le_max_right _ _) (le_of_lt (lt_add_one _))),
  refine le_trans _ hK,
  rw [succ_mul,one_mul,←add_zero M],
  exact add_le_add (le_trans (le_max_right _ _) (le_of_lt (lt_add_one _))) (zero_le _)},
end
#print axioms series_cauchy_prod
end a
open nat
lemma complex.exp_series_abs_cau (z : ℂ) : is_cau_seq abs (series (λ m, complex.abs( monoid.pow z m / fact m))) := begin
  cases exists_nat_gt (complex.abs z) with n hn,
  have n_pos : (0 : ℝ) < n := lt_of_le_of_lt (complex.abs_nonneg _) hn,
  refine series_ratio_test n (complex.abs z / n) _ _ _,exact div_nonneg_of_nonneg_of_pos (complex.abs_nonneg _) n_pos,rwa [div_lt_iff n_pos,one_mul],
  assume m mn,rw [abs_of_nonneg (complex.abs_nonneg _),abs_of_nonneg (complex.abs_nonneg _)],
  unfold monoid.pow fact,simp only [complex.abs_div,complex.abs_mul,div_eq_mul_inv,mul_inv',nat.cast_mul,complex.abs_inv],
  have : complex.abs z * complex.abs (monoid.pow z m) * ((complex.abs ↑(fact m))⁻¹ * (complex.abs ↑(succ m))⁻¹) = complex.abs z * complex.abs (monoid.pow z m) * (complex.abs ↑(fact m))⁻¹ * (complex.abs ↑(succ m))⁻¹,ring,rw this,
  have : complex.abs z * (↑n)⁻¹ * (complex.abs (monoid.pow z m) * (complex.abs ↑(fact m))⁻¹) = complex.abs z * complex.abs (monoid.pow z m) * (complex.abs ↑(fact m))⁻¹ * (↑n)⁻¹,ring,
  rw this,
  rw[(by simp : (succ m : ℂ) = ((succ m : ℝ) : ℂ)),complex.abs_of_nonneg],
  refine mul_le_mul_of_nonneg_left _ _,
  rw [inv_le_inv,nat.cast_le],exact le_succ_of_le mn,
  rw [←nat.cast_zero,nat.cast_lt],exact succ_pos _,exact n_pos,rw[←complex.abs_inv,←complex.abs_mul,←complex.abs_mul],
  exact complex.abs_nonneg _,rw[←nat.cast_zero,nat.cast_le],exact zero_le _,
end

lemma complex.exp_series_cau (z : ℂ) : is_cau_seq complex.abs (series (λ m, monoid.pow z m / fact m)) := series_cau_of_abv_cau (complex.exp_series_abs_cau z)

def exp (z : ℂ) : ℂ := complex.lim (series (λ n, monoid.pow z n / fact n))

def sin (z : ℂ) : ℂ := (exp (⟨0, 1⟩ * z) - exp (-⟨0, 1⟩ * z)) / (2 * ⟨0, 1⟩)

def cos (z : ℂ) : ℂ := (exp (⟨0, 1⟩ * z) + exp (-⟨0, 1⟩ * z)) / 2

def tan (z : ℂ) : ℂ := sin z / cos z

def sinh (z : ℂ) : ℂ := (exp z - exp (-z)) / 2

def cosh (z : ℂ) : ℂ := (exp z + exp (-z)) / 2

def tanh (z : ℂ) : ℂ := sinh z / cosh z

@[simp] lemma exp_zero : exp 0 = 1 := begin
  unfold exp,rw [eq_comm,complex.lim_const (complex.exp_series_cau 0)],
  assume ε ε0,existsi 0,assume j j1,
  induction j with j' hi,simpa!,
  replace hi := hi dec_trivial,simp! at *,assumption
end
-- really stupid proof, because there's no of is_cau_seq f * g from is_cau_seq f and is_cau_seq g
lemma exp_add (x y : ℂ) : exp (x + y) = exp x * exp y := begin
 have hxa := complex.exp_series_abs_cau x,
 have hx := complex.exp_series_cau x,
 have hy := complex.exp_series_cau y,
 have hxy := complex.exp_series_cau (x + y),
 unfold exp,rw complex.lim_mul hx hy,
 have hj : ∀ j : ℕ, series (λ (m : ℕ), monoid.pow (x + y) m / ↑(fact m)) j = series (λ i, series (λ k,monoid.pow x k / fact k * (monoid.pow y (i - k) / fact (i - k))) i) j := sorry,
 have hf := funext hj,simp at hf,have hxy1 := hxy, rw hf at hxy1,
 have := series_cauchy_prod hxa hy,
 rw[eq_comm, complex.lim_eq_lim_iff_equiv (cau_seq.of_near _ ⟨_, hxy⟩ _) hxy],
 assume ε ε0,
 simp [hj],simp at this,
 exact this ε ε0,
 simp [hj], simp at this,exact this,
end


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import algebra.algebra.basic
import set_theory.cardinal_ordinal
import tactic.ring_exp

/-!
# Quaternions

In this file we define quaternions `ℍ[R]` over a commutative ring `R`, and define some
algebraic structures on `ℍ[R]`.

## Main definitions

* `quaternion_algebra R a b`, `ℍ[R, a, b]` :
  [quaternion algebra](https://en.wikipedia.org/wiki/Quaternion_algebra) with coefficients `a`, `b`
* `quaternion R`, `ℍ[R]` : the space of quaternions, a.k.a. `quaternion_algebra R (-1) (-1)`;
* `quaternion.norm_sq` : square of the norm of a quaternion;
* `quaternion.conj` : conjugate of a quaternion;

We also define the following algebraic structures on `ℍ[R]`:

* `ring ℍ[R, a, b]` and `algebra R ℍ[R, a, b]` : for any commutative ring `R`;
* `ring ℍ[R]` and `algebra R ℍ[R]` : for any commutative ring `R`;
* `domain ℍ[R]` : for a linear ordered commutative ring `R`;
* `division_algebra ℍ[R]` : for a linear ordered field `R`.

## Notation

The following notation is available with `open_locale quaternion`.

* `ℍ[R, c₁, c₂]` : `quaternion_algebra R  c₁ c₂`
* `ℍ[R]` : quaternions over `R`.

## Implementation notes

We define quaternions over any ring `R`, not just `ℝ` to be able to deal with, e.g., integer
or rational quaternions without using real numbers. In particular, all definitions in this file
are computable.

## Tags

quaternion
-/

/-- Quaternion algebra over a type with fixed coefficients $a=i^2$ and $b=j^2$.
Implemented as a structure with four fields: `re`, `im_i`, `im_j`, and `im_k`. -/
@[nolint unused_arguments, ext]
structure quaternion_algebra (R : Type*) (a b : R) :=
mk {} :: (re : R) (im_i : R) (im_j : R) (im_k : R)

localized "notation `ℍ[` R`,` a`,` b `]` := quaternion_algebra R a b" in quaternion

namespace quaternion_algebra

/-- The equivalence between a quaternion algebra over R and R × R × R × R. -/
@[simps]
def equiv_prod {R : Type*} (c₁ c₂ : R) : ℍ[R, c₁, c₂] ≃ R × R × R × R :=
{ to_fun := λ a, ⟨a.1, a.2, a.3, a.4⟩,
  inv_fun := λ a, ⟨a.1, a.2.1, a.2.2.1, a.2.2.2⟩,
  left_inv := λ ⟨a₁, a₂, a₃, a₄⟩, rfl,
  right_inv := λ ⟨a₁, a₂, a₃, a₄⟩, rfl }

@[simp] lemma mk.eta {R : Type*} {c₁ c₂} : ∀ a : ℍ[R, c₁, c₂], mk a.1 a.2 a.3 a.4 = a
| ⟨a₁, a₂, a₃, a₄⟩ := rfl

variables {R : Type*} [comm_ring R] {c₁ c₂ : R} (r x y z : R) (a b c : ℍ[R, c₁, c₂])

instance : has_coe_t R (ℍ[R, c₁, c₂]) := ⟨λ x, ⟨x, 0, 0, 0⟩⟩

@[simp] lemma coe_re : (x : ℍ[R, c₁, c₂]).re = x := rfl
@[simp] lemma coe_im_i : (x : ℍ[R, c₁, c₂]).im_i = 0 := rfl
@[simp] lemma coe_im_j : (x : ℍ[R, c₁, c₂]).im_j = 0 := rfl
@[simp] lemma coe_im_k : (x : ℍ[R, c₁, c₂]).im_k = 0 := rfl

lemma coe_injective : function.injective (coe : R → ℍ[R, c₁, c₂]) :=
λ x y h, congr_arg re h

@[simp] lemma coe_inj {x y : R} : (x : ℍ[R, c₁, c₂]) = y ↔ x = y := coe_injective.eq_iff

@[simps] instance : has_zero ℍ[R, c₁, c₂] := ⟨⟨0, 0, 0, 0⟩⟩

@[simp, norm_cast] lemma coe_zero : ((0 : R) : ℍ[R, c₁, c₂]) = 0 := rfl

instance : inhabited ℍ[R, c₁, c₂] := ⟨0⟩

@[simps] instance : has_one ℍ[R, c₁, c₂] := ⟨⟨1, 0, 0, 0⟩⟩

@[simp, norm_cast] lemma coe_one : ((1 : R) : ℍ[R, c₁, c₂]) = 1 := rfl

@[simps] instance : has_add ℍ[R, c₁, c₂] :=
⟨λ a b, ⟨a.1 + b.1, a.2 + b.2, a.3 + b.3, a.4 + b.4⟩⟩

@[simp] lemma mk_add_mk (a₁ a₂ a₃ a₄ b₁ b₂ b₃ b₄ : R) :
  (mk a₁ a₂ a₃ a₄ : ℍ[R, c₁, c₂]) + mk b₁ b₂ b₃ b₄ = mk (a₁ + b₁) (a₂ + b₂) (a₃ + b₃) (a₄ + b₄) :=
rfl

@[simps] instance : has_neg ℍ[R, c₁, c₂] := ⟨λ a, ⟨-a.1, -a.2, -a.3, -a.4⟩⟩

@[simp] lemma neg_mk (a₁ a₂ a₃ a₄ : R) : -(mk a₁ a₂ a₃ a₄ : ℍ[R, c₁, c₂]) = ⟨-a₁, -a₂, -a₃, -a₄⟩ :=
rfl

@[simps] instance : has_sub ℍ[R, c₁, c₂] :=
⟨λ a b, ⟨a.1 - b.1, a.2 - b.2, a.3 - b.3, a.4 - b.4⟩⟩

@[simp] lemma mk_sub_mk (a₁ a₂ a₃ a₄ b₁ b₂ b₃ b₄ : R) :
  (mk a₁ a₂ a₃ a₄ : ℍ[R, c₁, c₂]) - mk b₁ b₂ b₃ b₄ = mk (a₁ - b₁) (a₂ - b₂) (a₃ - b₃) (a₄ - b₄) :=
rfl

/-- Multiplication is given by

* `1 * x = x * 1 = x`;
* `i * i = c₁`;
* `j * j = c₂`;
* `i * j = k`, `j * i = -k`;
* `k * k = -c₁ * c₂`;
* `i * k = c₁ * j`, `k * i = `-c₁ * j`;
* `j * k = -c₂ * i`, `k * j = c₂ * i`.  -/
@[simps] instance : has_mul ℍ[R, c₁, c₂] := ⟨λ a b,
  ⟨a.1 * b.1 + c₁ * a.2 * b.2 + c₂ * a.3 * b.3 - c₁ * c₂ * a.4 * b.4,
   a.1 * b.2 + a.2 * b.1 - c₂ * a.3 * b.4 + c₂ * a.4 * b.3,
   a.1 * b.3 + c₁ * a.2 * b.4 + a.3 * b.1 - c₁ *  a.4 * b.2,
   a.1 * b.4 + a.2 * b.3 - a.3 * b.2 + a.4 * b.1⟩⟩

@[simp] lemma mk_mul_mk (a₁ a₂ a₃ a₄ b₁ b₂ b₃ b₄ : R) :
  (mk a₁ a₂ a₃ a₄ : ℍ[R, c₁, c₂]) * mk b₁ b₂ b₃ b₄ =
    ⟨a₁ * b₁ + c₁ * a₂ * b₂ + c₂ * a₃ * b₃ - c₁ * c₂ * a₄ * b₄,
     a₁ * b₂ + a₂ * b₁ - c₂ * a₃ * b₄ + c₂ * a₄ * b₃,
     a₁ * b₃ + c₁ * a₂ * b₄ + a₃ * b₁ - c₁ *  a₄ * b₂,
     a₁ * b₄ + a₂ * b₃ - a₃ * b₂ + a₄ * b₁⟩ := rfl

instance : ring ℍ[R, c₁, c₂] :=
by refine_struct
  { add := (+),
    zero := (0 : ℍ[R, c₁, c₂]),
    neg := has_neg.neg,
    sub := has_sub.sub,
    mul := (*),
    one := 1,
    nsmul := @nsmul_rec _ ⟨(0 : ℍ[R, c₁, c₂])⟩ ⟨(+)⟩,
    zsmul := @zsmul_rec _ ⟨(0 : ℍ[R, c₁, c₂])⟩ ⟨(+)⟩ ⟨has_neg.neg⟩,
    npow := @npow_rec _ ⟨(1 : ℍ[R, c₁, c₂])⟩ ⟨(*)⟩ };
  intros; try { refl }; ext; simp; ring_exp

instance : algebra R ℍ[R, c₁, c₂] :=
{ smul := λ r a, ⟨r * a.1, r * a.2, r * a.3, r * a.4⟩,
  to_fun := coe,
  map_one' := rfl,
  map_zero' := rfl,
  map_mul' := λ x y, by ext; simp,
  map_add' := λ x y, by ext; simp,
  smul_def' := λ r x, by ext; simp,
  commutes' := λ r x, by ext; simp [mul_comm] }

@[simp] lemma smul_re : (r • a).re = r • a.re := rfl
@[simp] lemma smul_im_i : (r • a).im_i = r • a.im_i := rfl
@[simp] lemma smul_im_j : (r • a).im_j = r • a.im_j := rfl
@[simp] lemma smul_im_k : (r • a).im_k = r • a.im_k := rfl

@[simp] lemma smul_mk (re im_i im_j im_k : R) :
  r • (⟨re, im_i, im_j, im_k⟩ : ℍ[R, c₁, c₂]) = ⟨r • re, r • im_i, r • im_j, r • im_k⟩ := rfl

lemma algebra_map_eq (r : R) : algebra_map R ℍ[R,c₁,c₂] r = ⟨r, 0, 0, 0⟩ := rfl

section
variables (R c₁ c₂)

/-- `quaternion_algebra.re` as a `linear_map`-/
@[simps] def re_lm : ℍ[R, c₁, c₂] →ₗ[R] R :=
{ to_fun := re, map_add' := λ x y, rfl, map_smul' := λ r x, rfl }

/-- `quaternion_algebra.im_i` as a `linear_map`-/
@[simps] def im_i_lm : ℍ[R, c₁, c₂] →ₗ[R] R :=
{ to_fun := im_i, map_add' := λ x y, rfl, map_smul' := λ r x, rfl }

/-- `quaternion_algebra.im_j` as a `linear_map`-/
@[simps] def im_j_lm : ℍ[R, c₁, c₂] →ₗ[R] R :=
{ to_fun := im_j, map_add' := λ x y, rfl, map_smul' := λ r x, rfl }

/-- `quaternion_algebra.im_k` as a `linear_map`-/
@[simps] def im_k_lm : ℍ[R, c₁, c₂] →ₗ[R] R :=
{ to_fun := im_k, map_add' := λ x y, rfl, map_smul' := λ r x, rfl }

end

@[norm_cast, simp] lemma coe_add : ((x + y : R) : ℍ[R, c₁, c₂]) = x + y :=
(algebra_map R ℍ[R, c₁, c₂]).map_add x y

@[norm_cast, simp] lemma coe_sub : ((x - y : R) : ℍ[R, c₁, c₂]) = x - y :=
(algebra_map R ℍ[R, c₁, c₂]).map_sub x y

@[norm_cast, simp] lemma coe_neg : ((-x : R) : ℍ[R, c₁, c₂]) = -x :=
(algebra_map R ℍ[R, c₁, c₂]).map_neg x

@[norm_cast, simp] lemma coe_mul : ((x * y : R) : ℍ[R, c₁, c₂]) = x * y :=
(algebra_map R ℍ[R, c₁, c₂]).map_mul x y

lemma coe_commutes : ↑r * a = a * r := algebra.commutes r a

lemma coe_commute : commute ↑r a := coe_commutes r a

lemma coe_mul_eq_smul : ↑r * a = r • a := (algebra.smul_def r a).symm

lemma mul_coe_eq_smul : a * r = r • a :=
by rw [← coe_commutes, coe_mul_eq_smul]

@[norm_cast, simp] lemma coe_algebra_map : ⇑(algebra_map R ℍ[R, c₁, c₂]) = coe := rfl

lemma smul_coe : x • (y : ℍ[R, c₁, c₂]) = ↑(x * y) := by rw [coe_mul, coe_mul_eq_smul]

/-- Quaternion conjugate. -/
def conj : ℍ[R, c₁, c₂] ≃ₗ[R] ℍ[R, c₁, c₂] :=
linear_equiv.of_involutive
{ to_fun := λ a, ⟨a.1, -a.2, -a.3, -a.4⟩,
  map_add' := λ a b, by ext; simp [neg_add],
  map_smul' := λ r a, by ext; simp } $
λ a, by simp

@[simp] lemma re_conj : (conj a).re = a.re := rfl
@[simp] lemma im_i_conj : (conj a).im_i = - a.im_i := rfl
@[simp] lemma im_j_conj : (conj a).im_j = - a.im_j := rfl
@[simp] lemma im_k_conj : (conj a).im_k = - a.im_k := rfl

@[simp] lemma conj_mk (a₁ a₂ a₃ a₄ : R) :
  conj (mk a₁ a₂ a₃ a₄ : ℍ[R, c₁, c₂]) = ⟨a₁, -a₂, -a₃, -a₄⟩ :=
rfl

@[simp] lemma conj_conj : a.conj.conj = a := ext _ _ rfl (neg_neg _) (neg_neg _) (neg_neg _)

lemma conj_add : (a + b).conj = a.conj + b.conj := conj.map_add a b

@[simp] lemma conj_mul : (a * b).conj = b.conj * a.conj := by ext; simp; ring_exp

lemma conj_conj_mul : (a.conj * b).conj = b.conj * a :=
by rw [conj_mul, conj_conj]

lemma conj_mul_conj : (a * b.conj).conj = b * a.conj :=
by rw [conj_mul, conj_conj]

lemma self_add_conj' : a + a.conj = ↑(2 * a.re) := by ext; simp [two_mul]

lemma self_add_conj : a + a.conj = 2 * a.re :=
by simp only [self_add_conj', two_mul, coe_add]

lemma conj_add_self' : a.conj + a = ↑(2 * a.re) := by rw [add_comm, self_add_conj']

lemma conj_add_self : a.conj + a = 2 * a.re := by rw [add_comm, self_add_conj]

lemma conj_eq_two_re_sub : a.conj = ↑(2 * a.re) - a := eq_sub_iff_add_eq.2 a.conj_add_self'

lemma commute_conj_self : commute a.conj a :=
begin
  rw [a.conj_eq_two_re_sub],
  exact (coe_commute (2 * a.re) a).sub_left (commute.refl a)
end

lemma commute_self_conj : commute a a.conj :=
a.commute_conj_self.symm

lemma commute_conj_conj {a b : ℍ[R, c₁, c₂]} (h : commute a b) : commute a.conj b.conj :=
calc a.conj * b.conj = (b * a).conj    : (conj_mul b a).symm
                 ... = (a * b).conj    : by rw h.eq
                 ... = b.conj * a.conj : conj_mul a b

@[simp] lemma conj_coe : conj (x : ℍ[R, c₁, c₂]) = x := by ext; simp

lemma conj_smul : conj (r • a) = r • conj a := conj.map_smul r a

@[simp] lemma conj_one : conj (1 : ℍ[R, c₁, c₂]) = 1 := conj_coe 1

lemma eq_re_of_eq_coe {a : ℍ[R, c₁, c₂]} {x : R} (h : a = x) : a = a.re :=
by rw [h, coe_re]

lemma eq_re_iff_mem_range_coe {a : ℍ[R, c₁, c₂]} :
  a = a.re ↔ a ∈ set.range (coe : R → ℍ[R, c₁, c₂]) :=
⟨λ h, ⟨a.re, h.symm⟩, λ ⟨x, h⟩, eq_re_of_eq_coe h.symm⟩

@[simp]
lemma conj_fixed {R : Type*} [comm_ring R] [no_zero_divisors R] [char_zero R]
  {c₁ c₂ : R} {a : ℍ[R, c₁, c₂]} :
  conj a = a ↔ a = a.re :=
by simp [ext_iff, neg_eq_iff_add_eq_zero, add_self_eq_zero]

-- Can't use `rw ← conj_fixed` in the proof without additional assumptions

lemma conj_mul_eq_coe : conj a * a = (conj a * a).re := by ext; simp; ring_exp

lemma mul_conj_eq_coe : a * conj a = (a * conj a).re :=
by { rw a.commute_self_conj.eq, exact a.conj_mul_eq_coe }

lemma conj_zero : conj (0 : ℍ[R, c₁, c₂]) = 0 := conj.map_zero

lemma conj_neg : (-a).conj = -a.conj := (conj : ℍ[R, c₁, c₂] ≃ₗ[R] _).map_neg a

lemma conj_sub : (a - b).conj = a.conj - b.conj := (conj : ℍ[R, c₁, c₂] ≃ₗ[R] _).map_sub a b

instance : star_ring ℍ[R, c₁, c₂] :=
{ star := conj,
  star_involutive := conj_conj,
  star_add := conj_add,
  star_mul := conj_mul }

@[simp] lemma star_def (a : ℍ[R, c₁, c₂]) : star a = conj a := rfl

open mul_opposite

/-- Quaternion conjugate as an `alg_equiv` to the opposite ring. -/
def conj_ae : ℍ[R, c₁, c₂] ≃ₐ[R] (ℍ[R, c₁, c₂]ᵐᵒᵖ) :=
{ to_fun := op ∘ conj,
  inv_fun := conj ∘ unop,
  map_mul' := λ x y, by simp,
  commutes' := λ r, by simp,
  .. conj.to_add_equiv.trans op_add_equiv }

@[simp] lemma coe_conj_ae : ⇑(conj_ae : ℍ[R, c₁, c₂] ≃ₐ[R] _) = op ∘ conj := rfl

end quaternion_algebra

/-- Space of quaternions over a type. Implemented as a structure with four fields:
`re`, `im_i`, `im_j`, and `im_k`. -/
def quaternion (R : Type*) [has_one R] [has_neg R] := quaternion_algebra R (-1) (-1)

localized "notation `ℍ[` R `]` := quaternion R" in quaternion

/-- The equivalence between the quaternions over R and R × R × R × R. -/
def quaternion.equiv_prod (R : Type*) [has_one R] [has_neg R] : ℍ[R] ≃ R × R × R × R :=
quaternion_algebra.equiv_prod _ _

namespace quaternion

variables {R : Type*} [comm_ring R] (r x y z : R) (a b c : ℍ[R])

export quaternion_algebra (re im_i im_j im_k)

instance : has_coe_t R ℍ[R] := quaternion_algebra.has_coe_t
instance : ring ℍ[R] := quaternion_algebra.ring
instance : inhabited ℍ[R] := quaternion_algebra.inhabited
instance : algebra R ℍ[R] := quaternion_algebra.algebra
instance : star_ring ℍ[R] := quaternion_algebra.star_ring

@[ext] lemma ext : a.re = b.re → a.im_i = b.im_i → a.im_j = b.im_j → a.im_k = b.im_k → a = b :=
quaternion_algebra.ext a b

lemma ext_iff {a b : ℍ[R]} :
  a = b ↔ a.re = b.re ∧ a.im_i = b.im_i ∧ a.im_j = b.im_j ∧ a.im_k = b.im_k :=
quaternion_algebra.ext_iff a b

@[simp, norm_cast] lemma coe_re : (x : ℍ[R]).re = x := rfl
@[simp, norm_cast] lemma coe_im_i : (x : ℍ[R]).im_i = 0 := rfl
@[simp, norm_cast] lemma coe_im_j : (x : ℍ[R]).im_j = 0 := rfl
@[simp, norm_cast] lemma coe_im_k : (x : ℍ[R]).im_k = 0 := rfl

@[simp] lemma zero_re : (0 : ℍ[R]).re = 0 := rfl
@[simp] lemma zero_im_i : (0 : ℍ[R]).im_i = 0 := rfl
@[simp] lemma zero_im_j : (0 : ℍ[R]).im_j = 0 := rfl
@[simp] lemma zero_im_k : (0 : ℍ[R]).im_k = 0 := rfl
@[simp, norm_cast] lemma coe_zero : ((0 : R) : ℍ[R]) = 0 := rfl

@[simp] lemma one_re : (1 : ℍ[R]).re = 1 := rfl
@[simp] lemma one_im_i : (1 : ℍ[R]).im_i = 0 := rfl
@[simp] lemma one_im_j : (1 : ℍ[R]).im_j = 0 := rfl
@[simp] lemma one_im_k : (1 : ℍ[R]).im_k = 0 := rfl
@[simp, norm_cast] lemma coe_one : ((1 : R) : ℍ[R]) = 1 := rfl

@[simp] lemma add_re : (a + b).re = a.re + b.re := rfl
@[simp] lemma add_im_i : (a + b).im_i = a.im_i + b.im_i := rfl
@[simp] lemma add_im_j : (a + b).im_j = a.im_j + b.im_j := rfl
@[simp] lemma add_im_k : (a + b).im_k = a.im_k + b.im_k := rfl
@[simp, norm_cast] lemma coe_add : ((x + y : R) : ℍ[R]) = x + y := quaternion_algebra.coe_add x y

@[simp] lemma neg_re : (-a).re = -a.re := rfl
@[simp] lemma neg_im_i : (-a).im_i = -a.im_i := rfl
@[simp] lemma neg_im_j : (-a).im_j = -a.im_j := rfl
@[simp] lemma neg_im_k : (-a).im_k = -a.im_k := rfl
@[simp, norm_cast] lemma coe_neg : ((-x : R) : ℍ[R]) = -x := quaternion_algebra.coe_neg x

@[simp] lemma sub_re : (a - b).re = a.re - b.re := rfl
@[simp] lemma sub_im_i : (a - b).im_i = a.im_i - b.im_i := rfl
@[simp] lemma sub_im_j : (a - b).im_j = a.im_j - b.im_j := rfl
@[simp] lemma sub_im_k : (a - b).im_k = a.im_k - b.im_k := rfl
@[simp, norm_cast] lemma coe_sub : ((x - y : R) : ℍ[R]) = x - y := quaternion_algebra.coe_sub x y

@[simp] lemma mul_re :
  (a * b).re = a.re * b.re - a.im_i * b.im_i - a.im_j * b.im_j - a.im_k * b.im_k :=
(quaternion_algebra.has_mul_mul_re a b).trans $
  by simp only [one_mul, neg_mul, sub_eq_add_neg, neg_neg]

@[simp] lemma mul_im_i :
  (a * b).im_i = a.re * b.im_i + a.im_i * b.re + a.im_j * b.im_k - a.im_k * b.im_j :=
(quaternion_algebra.has_mul_mul_im_i a b).trans $
  by simp only [one_mul, neg_mul, sub_eq_add_neg, neg_neg]

@[simp] lemma mul_im_j :
  (a * b).im_j = a.re * b.im_j - a.im_i * b.im_k + a.im_j * b.re + a.im_k * b.im_i :=
(quaternion_algebra.has_mul_mul_im_j a b).trans $
  by simp only [one_mul, neg_mul, sub_eq_add_neg, neg_neg]

@[simp] lemma mul_im_k :
  (a * b).im_k = a.re * b.im_k + a.im_i * b.im_j - a.im_j * b.im_i + a.im_k * b.re :=
(quaternion_algebra.has_mul_mul_im_k a b).trans $
  by simp only [one_mul, neg_mul, sub_eq_add_neg, neg_neg]

@[simp, norm_cast] lemma coe_mul : ((x * y : R) : ℍ[R]) = x * y := quaternion_algebra.coe_mul x y

lemma coe_injective : function.injective (coe : R → ℍ[R]) := quaternion_algebra.coe_injective

@[simp] lemma coe_inj {x y : R} : (x : ℍ[R]) = y ↔ x = y := coe_injective.eq_iff

@[simp] lemma smul_re : (r • a).re = r • a.re := rfl
@[simp] lemma smul_im_i : (r • a).im_i = r • a.im_i := rfl
@[simp] lemma smul_im_j : (r • a).im_j = r • a.im_j := rfl
@[simp] lemma smul_im_k : (r • a).im_k = r • a.im_k := rfl

lemma coe_commutes : ↑r * a = a * r := quaternion_algebra.coe_commutes r a

lemma coe_commute : commute ↑r a := quaternion_algebra.coe_commute r a

lemma coe_mul_eq_smul : ↑r * a = r • a := quaternion_algebra.coe_mul_eq_smul r a

lemma mul_coe_eq_smul : a * r = r • a := quaternion_algebra.mul_coe_eq_smul r a

@[simp] lemma algebra_map_def : ⇑(algebra_map R ℍ[R]) = coe := rfl

lemma smul_coe : x • (y : ℍ[R]) = ↑(x * y) := quaternion_algebra.smul_coe x y

/-- Quaternion conjugate. -/
def conj : ℍ[R] ≃ₗ[R]  ℍ[R] := quaternion_algebra.conj

@[simp] lemma conj_re : a.conj.re = a.re := rfl
@[simp] lemma conj_im_i : a.conj.im_i = - a.im_i := rfl
@[simp] lemma conj_im_j : a.conj.im_j = - a.im_j := rfl
@[simp] lemma conj_im_k : a.conj.im_k = - a.im_k := rfl

@[simp] lemma conj_conj : a.conj.conj = a := a.conj_conj

@[simp] lemma conj_add : (a + b).conj = a.conj + b.conj := a.conj_add b

@[simp] lemma conj_mul : (a * b).conj = b.conj * a.conj := a.conj_mul b

lemma conj_conj_mul : (a.conj * b).conj = b.conj * a := a.conj_conj_mul b

lemma conj_mul_conj : (a * b.conj).conj = b * a.conj := a.conj_mul_conj b

lemma self_add_conj' : a + a.conj = ↑(2 * a.re) := a.self_add_conj'

lemma self_add_conj : a + a.conj = 2 * a.re := a.self_add_conj

lemma conj_add_self' : a.conj + a = ↑(2 * a.re) := a.conj_add_self'

lemma conj_add_self : a.conj + a = 2 * a.re := a.conj_add_self

lemma conj_eq_two_re_sub : a.conj = ↑(2 * a.re) - a := a.conj_eq_two_re_sub

lemma commute_conj_self : commute a.conj a := a.commute_conj_self

lemma commute_self_conj : commute a a.conj := a.commute_self_conj

lemma commute_conj_conj {a b : ℍ[R]} (h : commute a b) : commute a.conj b.conj :=
quaternion_algebra.commute_conj_conj h

alias commute_conj_conj ← commute.quaternion_conj

@[simp] lemma conj_coe : conj (x : ℍ[R]) = x := quaternion_algebra.conj_coe x

@[simp] lemma conj_smul : conj (r • a) = r • conj a := a.conj_smul r

@[simp] lemma conj_one : conj (1 : ℍ[R]) = 1 := conj_coe 1

lemma eq_re_of_eq_coe {a : ℍ[R]} {x : R} (h : a = x) : a = a.re :=
quaternion_algebra.eq_re_of_eq_coe h

lemma eq_re_iff_mem_range_coe {a : ℍ[R]} : a = a.re ↔ a ∈ set.range (coe : R → ℍ[R]) :=
quaternion_algebra.eq_re_iff_mem_range_coe

@[simp] lemma conj_fixed {R : Type*} [comm_ring R] [no_zero_divisors R] [char_zero R] {a : ℍ[R]} :
  conj a = a ↔ a = a.re :=
quaternion_algebra.conj_fixed

lemma conj_mul_eq_coe : conj a * a = (conj a * a).re := a.conj_mul_eq_coe

lemma mul_conj_eq_coe : a * conj a = (a * conj a).re := a.mul_conj_eq_coe

@[simp] lemma conj_zero : conj (0:ℍ[R]) = 0 := quaternion_algebra.conj_zero

@[simp] lemma conj_neg : (-a).conj = -a.conj := a.conj_neg

@[simp] lemma conj_sub : (a - b).conj = a.conj - b.conj := a.conj_sub b

open mul_opposite

/-- Quaternion conjugate as an `alg_equiv` to the opposite ring. -/
def conj_ae : ℍ[R] ≃ₐ[R] (ℍ[R]ᵐᵒᵖ) := quaternion_algebra.conj_ae

@[simp] lemma coe_conj_ae : ⇑(conj_ae : ℍ[R] ≃ₐ[R] ℍ[R]ᵐᵒᵖ) = op ∘ conj := rfl

/-- Square of the norm. -/
def norm_sq : ℍ[R] →*₀ R :=
{ to_fun := λ a, (a * a.conj).re,
  map_zero' := by rw [conj_zero, zero_mul, zero_re],
  map_one' := by rw [conj_one, one_mul, one_re],
  map_mul' := λ x y, coe_injective $ by conv_lhs { rw [← mul_conj_eq_coe, conj_mul, mul_assoc,
    ← mul_assoc y, y.mul_conj_eq_coe, coe_commutes, ← mul_assoc, x.mul_conj_eq_coe, ← coe_mul] } }

lemma norm_sq_def : norm_sq a = (a * a.conj).re := rfl

lemma norm_sq_def' : norm_sq a = a.1^2 + a.2^2 + a.3^2 + a.4^2 :=
by simp only [norm_sq_def, sq, mul_neg, sub_neg_eq_add,
  mul_re, conj_re, conj_im_i, conj_im_j, conj_im_k]

lemma norm_sq_coe : norm_sq (x : ℍ[R]) = x^2 :=
by rw [norm_sq_def, conj_coe, ← coe_mul, coe_re, sq]

@[simp] lemma norm_sq_neg : norm_sq (-a) = norm_sq a :=
by simp only [norm_sq_def, conj_neg, neg_mul_neg]

lemma self_mul_conj : a * a.conj = norm_sq a := by rw [mul_conj_eq_coe, norm_sq_def]

lemma conj_mul_self : a.conj * a = norm_sq a := by rw [← a.commute_self_conj.eq, self_mul_conj]

lemma coe_norm_sq_add :
  (norm_sq (a + b) : ℍ[R]) = norm_sq a + a * b.conj + b * a.conj + norm_sq b :=
by simp [← self_mul_conj, mul_add, add_mul, add_assoc]

end quaternion

namespace quaternion

variables {R : Type*}

section linear_ordered_comm_ring

variables [linear_ordered_comm_ring R] {a : ℍ[R]}

@[simp] lemma norm_sq_eq_zero : norm_sq a = 0 ↔ a = 0 :=
begin
  refine ⟨λ h, _, λ h, h.symm ▸ norm_sq.map_zero⟩,
  rw [norm_sq_def', add_eq_zero_iff', add_eq_zero_iff', add_eq_zero_iff'] at h,
  exact ext a 0 (pow_eq_zero h.1.1.1) (pow_eq_zero h.1.1.2) (pow_eq_zero h.1.2) (pow_eq_zero h.2),
  all_goals { apply_rules [sq_nonneg, add_nonneg] }
end

lemma norm_sq_ne_zero : norm_sq a ≠ 0 ↔ a ≠ 0 := not_congr norm_sq_eq_zero

@[simp] lemma norm_sq_nonneg : 0 ≤ norm_sq a :=
by { rw norm_sq_def', apply_rules [sq_nonneg, add_nonneg] }

@[simp] lemma norm_sq_le_zero : norm_sq a ≤ 0 ↔ a = 0 :=
by simpa only [le_antisymm_iff, norm_sq_nonneg, and_true] using @norm_sq_eq_zero _ _ a

instance : nontrivial ℍ[R] :=
{ exists_pair_ne := ⟨0, 1, mt (congr_arg re) zero_ne_one⟩, }

instance : is_domain ℍ[R] :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ a b hab,
    have norm_sq a * norm_sq b = 0, by rwa [← norm_sq.map_mul, norm_sq_eq_zero],
    (eq_zero_or_eq_zero_of_mul_eq_zero this).imp norm_sq_eq_zero.1 norm_sq_eq_zero.1,
  ..quaternion.nontrivial, }

end linear_ordered_comm_ring

section field

variables [linear_ordered_field R] (a b : ℍ[R])

@[simps { attrs := [] }]instance : has_inv ℍ[R] := ⟨λ a, (norm_sq a)⁻¹ • a.conj⟩

instance : division_ring ℍ[R] :=
{ inv := has_inv.inv,
  inv_zero := by rw [has_inv_inv, conj_zero, smul_zero],
  mul_inv_cancel := λ a ha, by rw [has_inv_inv, algebra.mul_smul_comm, self_mul_conj, smul_coe,
    inv_mul_cancel (norm_sq_ne_zero.2 ha), coe_one],
  .. quaternion.nontrivial,
  .. quaternion.ring }

@[simp] lemma norm_sq_inv : norm_sq a⁻¹ = (norm_sq a)⁻¹ :=
monoid_with_zero_hom.map_inv norm_sq _

@[simp] lemma norm_sq_div : norm_sq (a / b) = norm_sq a / norm_sq b :=
monoid_with_zero_hom.map_div norm_sq a b

end field

end quaternion

namespace cardinal

open_locale cardinal quaternion

section quaternion_algebra

variables {R : Type*} (c₁ c₂ : R)

private theorem pow_four [infinite R] : #R ^ 4 = #R :=
power_nat_eq (omega_le_mk R) $ by simp

/-- The cardinality of a quaternion algebra, as a type. -/
lemma mk_quaternion_algebra : #ℍ[R, c₁, c₂] = #R ^ 4 :=
by { rw mk_congr (quaternion_algebra.equiv_prod c₁ c₂), simp only [mk_prod, lift_id], ring }

@[simp] lemma mk_quaternion_algebra_of_infinite [infinite R] : #ℍ[R, c₁, c₂] = #R :=
by rw [mk_quaternion_algebra, pow_four]

/-- The cardinality of a quaternion algebra, as a set. -/
lemma mk_univ_quaternion_algebra : #(set.univ : set ℍ[R, c₁, c₂]) = #R ^ 4 :=
by rw [mk_univ, mk_quaternion_algebra]

@[simp] lemma mk_univ_quaternion_algebra_of_infinite [infinite R] :
  #(set.univ : set ℍ[R, c₁, c₂]) = #R :=
by rw [mk_univ_quaternion_algebra, pow_four]

end quaternion_algebra

section quaternion

variables (R : Type*) [has_one R] [has_neg R]

/-- The cardinality of the quaternions, as a type. -/
@[simp] lemma mk_quaternion : #ℍ[R] = #R ^ 4 :=
mk_quaternion_algebra _ _

@[simp] lemma mk_quaternion_of_infinite [infinite R] : #ℍ[R] = #R :=
by rw [mk_quaternion, pow_four]

/-- The cardinality of the quaternions, as a set. -/
@[simp] lemma mk_univ_quaternion : #(set.univ : set ℍ[R]) = #R ^ 4 :=
mk_univ_quaternion_algebra _ _

@[simp] lemma mk_univ_quaternion_of_infinite [infinite R] : #(set.univ : set ℍ[R]) = #R :=
by rw [mk_univ_quaternion, pow_four]

end quaternion

end cardinal


-- WIP

-- this might be awful to do without int.

import solutions.world3_le
import data.nat.basic
#print prefix nat
namespace mynat

def divides (a b : mynat) := ∃ c, a * c = b

instance : has_dvd mynat := ⟨mynat.divides⟩

def is_prime (n : mynat) : Prop := n ≠ 1 ∧ ∀ d, d ∣ n → d = 1 ∨ d = n

theorem has_prime_factor (n : mynat) : 1 < n → ∃ p : mynat, is_prime p ∧ p ∣ n :=
begin [nat_num_game]
  intro h,
  cases n with n,
    exfalso, apply @not_lt_zero 1,
    exact h,
  cases n with n,
    exfalso,
    rw ←one_eq_succ_zero at h,
    apply lt_irrefl (1 : mynat),
    assumption,
  clear h,
  revert n,
  apply strong_induction,
  -- strong induction successfully applied!
  sorry
end

end mynat


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

! This file was ported from Lean 3 source module combinatorics.hales_jewett
! leanprover-community/mathlib commit 23aa88e32dcc9d2a24cca7bc23268567ed4cd7d6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Option
import Mathbin.Data.Fintype.Pi
import Mathbin.Data.Fintype.Sum
import Mathbin.Algebra.BigOperators.Basic

/-!
# The Hales-Jewett theorem

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

We prove the Hales-Jewett theorem and deduce Van der Waerden's theorem as a corollary.

The Hales-Jewett theorem is a result in Ramsey theory dealing with *combinatorial lines*. Given
an 'alphabet' `α : Type*` and `a b : α`, an example of a combinatorial line in `α^5` is
`{ (a, x, x, b, x) | x : α }`. See `combinatorics.line` for a precise general definition. The
Hales-Jewett theorem states that for any fixed finite types `α` and `κ`, there exists a (potentially
huge) finite type `ι` such that whenever `ι → α` is `κ`-colored (i.e. for any coloring
`C : (ι → α) → κ`), there exists a monochromatic line. We prove the Hales-Jewett theorem using
the idea of *color focusing* and a *product argument*. See the proof of
`combinatorics.line.exists_mono_in_high_dimension'` for details.

The version of Van der Waerden's theorem in this file states that whenever a commutative monoid `M`
is finitely colored and `S` is a finite subset, there exists a monochromatic homothetic copy of `S`.
This follows from the Hales-Jewett theorem by considering the map `(ι → S) → M` sending `v`
to `∑ i : ι, v i`, which sends a combinatorial line to a homothetic copy of `S`.

## Main results

- `combinatorics.line.exists_mono_in_high_dimension`: the Hales-Jewett theorem.
- `combinatorics.exists_mono_homothetic_copy`: a generalization of Van der Waerden's theorem.

## Implementation details

For convenience, we work directly with finite types instead of natural numbers. That is, we write
`α, ι, κ` for (finite) types where one might traditionally use natural numbers `n, H, c`. This
allows us to work directly with `α`, `option α`, `(ι → α) → κ`, and `ι ⊕ ι'` instead of `fin n`,
`fin (n+1)`, `fin (c^(n^H))`, and `fin (H + H')`.

## Todo

- Prove a finitary version of Van der Waerden's theorem (either by compactness or by modifying the
current proof).

- One could reformulate the proof of Hales-Jewett to give explicit upper bounds on the number of
coordinates needed.

## Tags

combinatorial line, Ramsey theory, arithmetic progession

### References

* https://en.wikipedia.org/wiki/Hales%E2%80%93Jewett_theorem

-/

open Classical

open BigOperators

universe u v

namespace Combinatorics

#print Combinatorics.Line /-
/-- The type of combinatorial lines. A line `l : line α ι` in the hypercube `ι → α` defines a
function `α → ι → α` from `α` to the hypercube, such that for each coordinate `i : ι`, the function
`λ x, l x i` is either `id` or constant. We require lines to be nontrivial in the sense that
`λ x, l x i` is `id` for at least one `i`.

Formally, a line is represented by the function `l.idx_fun : ι → option α` which says whether
`λ x, l x i` is `id` (corresponding to `l.idx_fun i = none`) or constantly `y` (corresponding to
`l.idx_fun i = some y`).

When `α` has size `1` there can be many elements of `line α ι` defining the same function. -/
structure Line (α ι : Type _) where
  idxFun : ι → Option α
  proper : ∃ i, idx_fun i = none
#align combinatorics.line Combinatorics.Line
-/

namespace Line

-- This lets us treat a line `l : line α ι` as a function `α → ι → α`.
instance (α ι) : CoeFun (Line α ι) fun _ => α → ι → α :=
  ⟨fun l x i => (l.idxFun i).getD x⟩

#print Combinatorics.Line.IsMono /-
/-- A line is monochromatic if all its points are the same color. -/
def IsMono {α ι κ} (C : (ι → α) → κ) (l : Line α ι) : Prop :=
  ∃ c, ∀ x, C (l x) = c
#align combinatorics.line.is_mono Combinatorics.Line.IsMono
-/

#print Combinatorics.Line.diagonal /-
/-- The diagonal line. It is the identity at every coordinate. -/
def diagonal (α ι) [Nonempty ι] : Line α ι
    where
  idxFun _ := none
  proper := ⟨Classical.arbitrary ι, rfl⟩
#align combinatorics.line.diagonal Combinatorics.Line.diagonal
-/

instance (α ι) [Nonempty ι] : Inhabited (Line α ι) :=
  ⟨diagonal α ι⟩

#print Combinatorics.Line.AlmostMono /-
/-- The type of lines that are only one color except possibly at their endpoints. -/
structure AlmostMono {α ι κ : Type _} (C : (ι → Option α) → κ) where
  line : Line (Option α) ι
  Color : κ
  has_color : ∀ x : α, C (line (some x)) = color
#align combinatorics.line.almost_mono Combinatorics.Line.AlmostMono
-/

instance {α ι κ : Type _} [Nonempty ι] [Inhabited κ] :
    Inhabited (AlmostMono fun v : ι → Option α => (default : κ)) :=
  ⟨{  line := default
      Color := default
      has_color := fun _ => rfl }⟩

#print Combinatorics.Line.ColorFocused /-
/-- The type of collections of lines such that
- each line is only one color except possibly at its endpoint
- the lines all have the same endpoint
- the colors of the lines are distinct.
Used in the proof `exists_mono_in_high_dimension`. -/
structure ColorFocused {α ι κ : Type _} (C : (ι → Option α) → κ) where
  lines : Multiset (AlmostMono C)
  focus : ι → Option α
  is_focused : ∀ p ∈ lines, AlmostMono.line p none = focus
  distinct_colors : (lines.map AlmostMono.color).Nodup
#align combinatorics.line.color_focused Combinatorics.Line.ColorFocused
-/

instance {α ι κ} (C : (ι → Option α) → κ) : Inhabited (ColorFocused C) :=
  ⟨⟨0, fun _ => none, fun _ => False.elim, Multiset.nodup_zero⟩⟩

#print Combinatorics.Line.map /-
/-- A function `f : α → α'` determines a function `line α ι → line α' ι`. For a coordinate `i`,
`l.map f` is the identity at `i` if `l` is, and constantly `f y` if `l` is constantly `y` at `i`. -/
def map {α α' ι} (f : α → α') (l : Line α ι) : Line α' ι
    where
  idxFun i := (l.idxFun i).map f
  proper := ⟨l.proper.some, by rw [l.proper.some_spec, Option.map_none']⟩
#align combinatorics.line.map Combinatorics.Line.map
-/

#print Combinatorics.Line.vertical /-
/-- A point in `ι → α` and a line in `ι' → α` determine a line in `ι ⊕ ι' → α`. -/
def vertical {α ι ι'} (v : ι → α) (l : Line α ι') : Line α (Sum ι ι')
    where
  idxFun := Sum.elim (some ∘ v) l.idxFun
  proper := ⟨Sum.inr l.proper.some, l.proper.choose_spec⟩
#align combinatorics.line.vertical Combinatorics.Line.vertical
-/

#print Combinatorics.Line.horizontal /-
/-- A line in `ι → α` and a point in `ι' → α` determine a line in `ι ⊕ ι' → α`. -/
def horizontal {α ι ι'} (l : Line α ι) (v : ι' → α) : Line α (Sum ι ι')
    where
  idxFun := Sum.elim l.idxFun (some ∘ v)
  proper := ⟨Sum.inl l.proper.some, l.proper.choose_spec⟩
#align combinatorics.line.horizontal Combinatorics.Line.horizontal
-/

#print Combinatorics.Line.prod /-
/-- One line in `ι → α` and one in `ι' → α` together determine a line in `ι ⊕ ι' → α`. -/
def prod {α ι ι'} (l : Line α ι) (l' : Line α ι') : Line α (Sum ι ι')
    where
  idxFun := Sum.elim l.idxFun l'.idxFun
  proper := ⟨Sum.inl l.proper.some, l.proper.choose_spec⟩
#align combinatorics.line.prod Combinatorics.Line.prod
-/

/- warning: combinatorics.line.apply -> Combinatorics.Line.apply is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {ι : Type.{u2}} (l : Combinatorics.Line.{u1, u2} α ι) (x : α), Eq.{max (succ u2) (succ u1)} (ι -> α) (coeFn.{max (succ u1) (succ u2), max (succ u2) (succ u1)} (Combinatorics.Line.{u1, u2} α ι) (fun (_x : Combinatorics.Line.{u1, u2} α ι) => α -> ι -> α) (Combinatorics.Line.hasCoeToFun.{u1, u2} α ι) l x) (fun (i : ι) => Option.getD.{u1} α (Combinatorics.Line.idxFun.{u1, u2} α ι l i) x)
but is expected to have type
  forall {α : Type.{u2}} {ι : Type.{u1}} (l : Combinatorics.Line.{u2, u1} α ι) (x : α), Eq.{max (succ u1) (succ u2)} (ι -> α) ((fun (x : α) (i : ι) => Option.getD.{u2} α (Combinatorics.Line.idxFun.{u2, u1} α ι l i) x) x) (fun (i : ι) => Option.getD.{u2} α (Combinatorics.Line.idxFun.{u2, u1} α ι l i) x)
Case conversion may be inaccurate. Consider using '#align combinatorics.line.apply Combinatorics.Line.applyₓ'. -/
theorem apply {α ι} (l : Line α ι) (x : α) : l x = fun i => (l.idxFun i).getD x :=
  rfl
#align combinatorics.line.apply Combinatorics.Line.apply

/- warning: combinatorics.line.apply_none -> Combinatorics.Line.apply_none is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {ι : Type.{u2}} (l : Combinatorics.Line.{u1, u2} α ι) (x : α) (i : ι), (Eq.{succ u1} (Option.{u1} α) (Combinatorics.Line.idxFun.{u1, u2} α ι l i) (Option.none.{u1} α)) -> (Eq.{succ u1} α (coeFn.{max (succ u1) (succ u2), max (succ u2) (succ u1)} (Combinatorics.Line.{u1, u2} α ι) (fun (_x : Combinatorics.Line.{u1, u2} α ι) => α -> ι -> α) (Combinatorics.Line.hasCoeToFun.{u1, u2} α ι) l x i) x)
but is expected to have type
  forall {α : Type.{u2}} {ι : Type.{u1}} (l : Combinatorics.Line.{u2, u1} α ι) (x : α) (i : ι), (Eq.{succ u2} (Option.{u2} α) (Combinatorics.Line.idxFun.{u2, u1} α ι l i) (Option.none.{u2} α)) -> (Eq.{succ u2} α ((fun (x : α) (i : ι) => Option.getD.{u2} α (Combinatorics.Line.idxFun.{u2, u1} α ι l i) x) x i) x)
Case conversion may be inaccurate. Consider using '#align combinatorics.line.apply_none Combinatorics.Line.apply_noneₓ'. -/
theorem apply_none {α ι} (l : Line α ι) (x : α) (i : ι) (h : l.idxFun i = none) : l x i = x := by
  simp only [Option.getD_none, h, l.apply]
#align combinatorics.line.apply_none Combinatorics.Line.apply_none

/- warning: combinatorics.line.apply_of_ne_none -> Combinatorics.Line.apply_of_ne_none is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {ι : Type.{u2}} (l : Combinatorics.Line.{u1, u2} α ι) (x : α) (i : ι), (Ne.{succ u1} (Option.{u1} α) (Combinatorics.Line.idxFun.{u1, u2} α ι l i) (Option.none.{u1} α)) -> (Eq.{succ u1} (Option.{u1} α) (Option.some.{u1} α (coeFn.{max (succ u1) (succ u2), max (succ u2) (succ u1)} (Combinatorics.Line.{u1, u2} α ι) (fun (_x : Combinatorics.Line.{u1, u2} α ι) => α -> ι -> α) (Combinatorics.Line.hasCoeToFun.{u1, u2} α ι) l x i)) (Combinatorics.Line.idxFun.{u1, u2} α ι l i))
but is expected to have type
  forall {α : Type.{u2}} {ι : Type.{u1}} (l : Combinatorics.Line.{u2, u1} α ι) (x : α) (i : ι), (Ne.{succ u2} (Option.{u2} α) (Combinatorics.Line.idxFun.{u2, u1} α ι l i) (Option.none.{u2} α)) -> (Eq.{succ u2} (Option.{u2} α) (Option.some.{u2} α ((fun (x : α) (i : ι) => Option.getD.{u2} α (Combinatorics.Line.idxFun.{u2, u1} α ι l i) x) x i)) (Combinatorics.Line.idxFun.{u2, u1} α ι l i))
Case conversion may be inaccurate. Consider using '#align combinatorics.line.apply_of_ne_none Combinatorics.Line.apply_of_ne_noneₓ'. -/
theorem apply_of_ne_none {α ι} (l : Line α ι) (x : α) (i : ι) (h : l.idxFun i ≠ none) :
    some (l x i) = l.idxFun i := by rw [l.apply, Option.getD_of_ne_none h]
#align combinatorics.line.apply_of_ne_none Combinatorics.Line.apply_of_ne_none

/- warning: combinatorics.line.map_apply -> Combinatorics.Line.map_apply is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {α' : Type.{u2}} {ι : Type.{u3}} (f : α -> α') (l : Combinatorics.Line.{u1, u3} α ι) (x : α), Eq.{max (succ u3) (succ u2)} (ι -> α') (coeFn.{max (succ u2) (succ u3), max (succ u3) (succ u2)} (Combinatorics.Line.{u2, u3} α' ι) (fun (_x : Combinatorics.Line.{u2, u3} α' ι) => α' -> ι -> α') (Combinatorics.Line.hasCoeToFun.{u2, u3} α' ι) (Combinatorics.Line.map.{u1, u2, u3} α α' ι f l) (f x)) (Function.comp.{succ u3, succ u1, succ u2} ι α α' f (coeFn.{max (succ u1) (succ u3), max (succ u3) (succ u1)} (Combinatorics.Line.{u1, u3} α ι) (fun (_x : Combinatorics.Line.{u1, u3} α ι) => α -> ι -> α) (Combinatorics.Line.hasCoeToFun.{u1, u3} α ι) l x))
but is expected to have type
  forall {α : Type.{u3}} {α' : Type.{u2}} {ι : Type.{u1}} (f : α -> α') (l : Combinatorics.Line.{u3, u1} α ι) (x : α), Eq.{max (succ u1) (succ u2)} (ι -> α') ((fun (x : α') (i : ι) => Option.getD.{u2} α' (Combinatorics.Line.idxFun.{u2, u1} α' ι (Combinatorics.Line.map.{u3, u2, u1} α α' ι f l) i) x) (f x)) (Function.comp.{succ u1, succ u3, succ u2} ι α α' f ((fun (x : α) (i : ι) => Option.getD.{u3} α (Combinatorics.Line.idxFun.{u3, u1} α ι l i) x) x))
Case conversion may be inaccurate. Consider using '#align combinatorics.line.map_apply Combinatorics.Line.map_applyₓ'. -/
@[simp]
theorem map_apply {α α' ι} (f : α → α') (l : Line α ι) (x : α) : l.map f (f x) = f ∘ l x := by
  simp only [line.apply, line.map, Option.getD_map]
#align combinatorics.line.map_apply Combinatorics.Line.map_apply

/- warning: combinatorics.line.vertical_apply -> Combinatorics.Line.vertical_apply is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {ι : Type.{u2}} {ι' : Type.{u3}} (v : ι -> α) (l : Combinatorics.Line.{u1, u3} α ι') (x : α), Eq.{max (max (succ u2) (succ u3)) (succ u1)} ((Sum.{u2, u3} ι ι') -> α) (coeFn.{max (succ u1) (succ (max u2 u3)), max (succ (max u2 u3)) (succ u1)} (Combinatorics.Line.{u1, max u2 u3} α (Sum.{u2, u3} ι ι')) (fun (_x : Combinatorics.Line.{u1, max u2 u3} α (Sum.{u2, u3} ι ι')) => α -> (Sum.{u2, u3} ι ι') -> α) (Combinatorics.Line.hasCoeToFun.{u1, max u2 u3} α (Sum.{u2, u3} ι ι')) (Combinatorics.Line.vertical.{u1, u2, u3} α ι ι' v l) x) (Sum.elim.{u2, u3, succ u1} ι ι' α v (coeFn.{max (succ u1) (succ u3), max (succ u3) (succ u1)} (Combinatorics.Line.{u1, u3} α ι') (fun (_x : Combinatorics.Line.{u1, u3} α ι') => α -> ι' -> α) (Combinatorics.Line.hasCoeToFun.{u1, u3} α ι') l x))
but is expected to have type
  forall {α : Type.{u3}} {ι : Type.{u2}} {ι' : Type.{u1}} (v : ι -> α) (l : Combinatorics.Line.{u3, u1} α ι') (x : α), Eq.{max (max (succ u1) (succ u3)) (succ u2)} ((Sum.{u2, u1} ι ι') -> α) ((fun (x : α) (i : Sum.{u2, u1} ι ι') => Option.getD.{u3} α (Combinatorics.Line.idxFun.{u3, max u1 u2} α (Sum.{u2, u1} ι ι') (Combinatorics.Line.vertical.{u3, u2, u1} α ι ι' v l) i) x) x) (Sum.elim.{u2, u1, succ u3} ι ι' α v ((fun (x : α) (i : ι') => Option.getD.{u3} α (Combinatorics.Line.idxFun.{u3, u1} α ι' l i) x) x))
Case conversion may be inaccurate. Consider using '#align combinatorics.line.vertical_apply Combinatorics.Line.vertical_applyₓ'. -/
@[simp]
theorem vertical_apply {α ι ι'} (v : ι → α) (l : Line α ι') (x : α) :
    l.vertical v x = Sum.elim v (l x) := by
  funext i
  cases i <;> rfl
#align combinatorics.line.vertical_apply Combinatorics.Line.vertical_apply

/- warning: combinatorics.line.horizontal_apply -> Combinatorics.Line.horizontal_apply is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {ι : Type.{u2}} {ι' : Type.{u3}} (l : Combinatorics.Line.{u1, u2} α ι) (v : ι' -> α) (x : α), Eq.{max (max (succ u2) (succ u3)) (succ u1)} ((Sum.{u2, u3} ι ι') -> α) (coeFn.{max (succ u1) (succ (max u2 u3)), max (succ (max u2 u3)) (succ u1)} (Combinatorics.Line.{u1, max u2 u3} α (Sum.{u2, u3} ι ι')) (fun (_x : Combinatorics.Line.{u1, max u2 u3} α (Sum.{u2, u3} ι ι')) => α -> (Sum.{u2, u3} ι ι') -> α) (Combinatorics.Line.hasCoeToFun.{u1, max u2 u3} α (Sum.{u2, u3} ι ι')) (Combinatorics.Line.horizontal.{u1, u2, u3} α ι ι' l v) x) (Sum.elim.{u2, u3, succ u1} ι ι' α (coeFn.{max (succ u1) (succ u2), max (succ u2) (succ u1)} (Combinatorics.Line.{u1, u2} α ι) (fun (_x : Combinatorics.Line.{u1, u2} α ι) => α -> ι -> α) (Combinatorics.Line.hasCoeToFun.{u1, u2} α ι) l x) v)
but is expected to have type
  forall {α : Type.{u3}} {ι : Type.{u2}} {ι' : Type.{u1}} (l : Combinatorics.Line.{u3, u2} α ι) (v : ι' -> α) (x : α), Eq.{max (max (succ u2) (succ u3)) (succ u1)} ((Sum.{u2, u1} ι ι') -> α) ((fun (x : α) (i : Sum.{u2, u1} ι ι') => Option.getD.{u3} α (Combinatorics.Line.idxFun.{u3, max u2 u1} α (Sum.{u2, u1} ι ι') (Combinatorics.Line.horizontal.{u3, u2, u1} α ι ι' l v) i) x) x) (Sum.elim.{u2, u1, succ u3} ι ι' α ((fun (x : α) (i : ι) => Option.getD.{u3} α (Combinatorics.Line.idxFun.{u3, u2} α ι l i) x) x) v)
Case conversion may be inaccurate. Consider using '#align combinatorics.line.horizontal_apply Combinatorics.Line.horizontal_applyₓ'. -/
@[simp]
theorem horizontal_apply {α ι ι'} (l : Line α ι) (v : ι' → α) (x : α) :
    l.horizontal v x = Sum.elim (l x) v := by
  funext i
  cases i <;> rfl
#align combinatorics.line.horizontal_apply Combinatorics.Line.horizontal_apply

/- warning: combinatorics.line.prod_apply -> Combinatorics.Line.prod_apply is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {ι : Type.{u2}} {ι' : Type.{u3}} (l : Combinatorics.Line.{u1, u2} α ι) (l' : Combinatorics.Line.{u1, u3} α ι') (x : α), Eq.{max (max (succ u2) (succ u3)) (succ u1)} ((Sum.{u2, u3} ι ι') -> α) (coeFn.{max (succ u1) (succ (max u2 u3)), max (succ (max u2 u3)) (succ u1)} (Combinatorics.Line.{u1, max u2 u3} α (Sum.{u2, u3} ι ι')) (fun (_x : Combinatorics.Line.{u1, max u2 u3} α (Sum.{u2, u3} ι ι')) => α -> (Sum.{u2, u3} ι ι') -> α) (Combinatorics.Line.hasCoeToFun.{u1, max u2 u3} α (Sum.{u2, u3} ι ι')) (Combinatorics.Line.prod.{u1, u2, u3} α ι ι' l l') x) (Sum.elim.{u2, u3, succ u1} ι ι' α (coeFn.{max (succ u1) (succ u2), max (succ u2) (succ u1)} (Combinatorics.Line.{u1, u2} α ι) (fun (_x : Combinatorics.Line.{u1, u2} α ι) => α -> ι -> α) (Combinatorics.Line.hasCoeToFun.{u1, u2} α ι) l x) (coeFn.{max (succ u1) (succ u3), max (succ u3) (succ u1)} (Combinatorics.Line.{u1, u3} α ι') (fun (_x : Combinatorics.Line.{u1, u3} α ι') => α -> ι' -> α) (Combinatorics.Line.hasCoeToFun.{u1, u3} α ι') l' x))
but is expected to have type
  forall {α : Type.{u3}} {ι : Type.{u2}} {ι' : Type.{u1}} (l : Combinatorics.Line.{u3, u2} α ι) (l' : Combinatorics.Line.{u3, u1} α ι') (x : α), Eq.{max (max (succ u2) (succ u3)) (succ u1)} ((Sum.{u2, u1} ι ι') -> α) ((fun (x : α) (i : Sum.{u2, u1} ι ι') => Option.getD.{u3} α (Combinatorics.Line.idxFun.{u3, max u2 u1} α (Sum.{u2, u1} ι ι') (Combinatorics.Line.prod.{u3, u2, u1} α ι ι' l l') i) x) x) (Sum.elim.{u2, u1, succ u3} ι ι' α ((fun (x : α) (i : ι) => Option.getD.{u3} α (Combinatorics.Line.idxFun.{u3, u2} α ι l i) x) x) ((fun (x : α) (i : ι') => Option.getD.{u3} α (Combinatorics.Line.idxFun.{u3, u1} α ι' l' i) x) x))
Case conversion may be inaccurate. Consider using '#align combinatorics.line.prod_apply Combinatorics.Line.prod_applyₓ'. -/
@[simp]
theorem prod_apply {α ι ι'} (l : Line α ι) (l' : Line α ι') (x : α) :
    l.Prod l' x = Sum.elim (l x) (l' x) := by
  funext i
  cases i <;> rfl
#align combinatorics.line.prod_apply Combinatorics.Line.prod_apply

/- warning: combinatorics.line.diagonal_apply -> Combinatorics.Line.diagonal_apply is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {ι : Type.{u2}} [_inst_1 : Nonempty.{succ u2} ι] (x : α), Eq.{max (succ u2) (succ u1)} (ι -> α) (coeFn.{max (succ u1) (succ u2), max (succ u2) (succ u1)} (Combinatorics.Line.{u1, u2} α ι) (fun (_x : Combinatorics.Line.{u1, u2} α ι) => α -> ι -> α) (Combinatorics.Line.hasCoeToFun.{u1, u2} α ι) (Combinatorics.Line.diagonal.{u1, u2} α ι _inst_1) x) (fun (i : ι) => x)
but is expected to have type
  forall {α : Type.{u2}} {ι : Type.{u1}} [_inst_1 : Nonempty.{succ u1} ι] (x : α), Eq.{max (succ u1) (succ u2)} (ι -> α) ((fun (x : α) (i : ι) => Option.getD.{u2} α (Combinatorics.Line.idxFun.{u2, u1} α ι (Combinatorics.Line.diagonal.{u2, u1} α ι _inst_1) i) x) x) (fun (i : ι) => x)
Case conversion may be inaccurate. Consider using '#align combinatorics.line.diagonal_apply Combinatorics.Line.diagonal_applyₓ'. -/
@[simp]
theorem diagonal_apply {α ι} [Nonempty ι] (x : α) : Line.diagonal α ι x = fun i => x := by
  simp_rw [line.apply, line.diagonal, Option.getD_none]
#align combinatorics.line.diagonal_apply Combinatorics.Line.diagonal_apply

/- warning: combinatorics.line.exists_mono_in_high_dimension' clashes with [anonymous] -> [anonymous]
Case conversion may be inaccurate. Consider using '#align combinatorics.line.exists_mono_in_high_dimension' [anonymous]ₓ'. -/
#print [anonymous] /-
/-- The Hales-Jewett theorem. This version has a restriction on universe levels which is necessary
for the proof. See `exists_mono_in_high_dimension` for a fully universe-polymorphic version. -/
private theorem [anonymous] :
    ∀ (α : Type u) [Finite α] (κ : Type max v u) [Finite κ],
      ∃ (ι : Type)(_ : Fintype ι), ∀ C : (ι → α) → κ, ∃ l : Line α ι, l.IsMono C :=
  -- The proof proceeds by induction on `α`.
    Finite.induction_empty_option
    (-- We have to show that the theorem is invariant under `α ≃ α'` for the induction to work.
    fun α α' e =>
      forall_imp fun κ =>
        forall_imp fun _ =>
          Exists.imp fun ι =>
            Exists.imp fun _ h C =>
              let ⟨l, c, lc⟩ := h fun v => C (e ∘ v)
              ⟨l.map e, c, e.forall_congr_left.mp fun x => by rw [← lc x, line.map_apply]⟩)
    (by
      -- This deals with the degenerate case where `α` is empty.
      intro κ _
      by_cases h : Nonempty κ
      · skip
        exact ⟨Unit, inferInstance, fun C => ⟨default, Classical.arbitrary _, PEmpty.rec _⟩⟩
      · exact ⟨Empty, inferInstance, fun C => (h ⟨C (Empty.rec _)⟩).elim⟩)
    (by
      -- Now we have to show that the theorem holds for `option α` if it holds for `α`.
      intro α _ ihα κ _
      cases nonempty_fintype κ
      -- Later we'll need `α` to be nonempty. So we first deal with the trivial case where `α` is empty.
      -- Then `option α` has only one element, so any line is monochromatic.
      by_cases h : Nonempty α
      on_goal
        2 =>
        refine' ⟨Unit, inferInstance, fun C => ⟨diagonal _ _, C fun _ => none, _⟩⟩
        rintro (_ | ⟨a⟩); rfl; exact (h ⟨a⟩).elim
      -- The key idea is to show that for every `r`, in high dimension we can either find
      -- `r` color focused lines or a monochromatic line.
      suffices key :
        ∀ r : ℕ,
          ∃ (ι : Type)(_ : Fintype ι),
            ∀ C : (ι → Option α) → κ, (∃ s : color_focused C, s.lines.card = r) ∨ ∃ l, is_mono C l
      -- Given the key claim, we simply take `r = |κ| + 1`. We cannot have this many distinct colors so
      -- we must be in the second case, where there is a monochromatic line.
      · obtain ⟨ι, _inst, hι⟩ := key (Fintype.card κ + 1)
        refine' ⟨ι, _inst, fun C => (hι C).resolve_left _⟩
        rintro ⟨s, sr⟩
        apply Nat.not_succ_le_self (Fintype.card κ)
        rw [← Nat.add_one, ← sr, ← Multiset.card_map, ← Finset.card_mk]
        exact Finset.card_le_univ ⟨_, s.distinct_colors⟩
      -- We now prove the key claim, by induction on `r`.
      intro r
      induction' r with r ihr
      -- The base case `r = 0` is trivial as the empty collection is color-focused.
      · exact ⟨Empty, inferInstance, fun C => Or.inl ⟨default, Multiset.card_zero⟩⟩
      -- Supposing the key claim holds for `r`, we need to show it for `r+1`. First pick a high enough
      -- dimension `ι` for `r`.
      obtain ⟨ι, _inst, hι⟩ := ihr
      skip
      -- Then since the theorem holds for `α` with any number of colors, pick a dimension `ι'` such that
      -- `ι' → α` always has a monochromatic line whenever it is `(ι → option α) → κ`-colored.
      specialize ihα ((ι → Option α) → κ)
      obtain ⟨ι', _inst, hι'⟩ := ihα
      skip
      -- We claim that `ι ⊕ ι'` works for `option α` and `κ`-coloring.
      refine' ⟨Sum ι ι', inferInstance, _⟩
      intro C
      -- A `κ`-coloring of `ι ⊕ ι' → option α` induces an `(ι → option α) → κ`-coloring of `ι' → α`.
      specialize hι' fun v' v => C (Sum.elim v (some ∘ v'))
      -- By choice of `ι'` this coloring has a monochromatic line `l'` with color class `C'`, where
      -- `C'` is a `κ`-coloring of `ι → α`.
      obtain ⟨l', C', hl'⟩ := hι'
      -- If `C'` has a monochromatic line, then so does `C`. We use this in two places below.
      have mono_of_mono : (∃ l, is_mono C' l) → ∃ l, is_mono C l :=
        by
        rintro ⟨l, c, hl⟩
        refine' ⟨l.horizontal (some ∘ l' (Classical.arbitrary α)), c, fun x => _⟩
        rw [line.horizontal_apply, ← hl, ← hl']
      -- By choice of `ι`, `C'` either has `r` color-focused lines or a monochromatic line.
      specialize hι C'
      rcases hι with (⟨s, sr⟩ | _)
      on_goal 2 => exact Or.inr (mono_of_mono hι)
      -- Here we assume `C'` has `r` color focused lines. We split into cases depending on whether one of
      -- these `r` lines has the same color as the focus point.
      by_cases h : ∃ p ∈ s.lines, (p : almost_mono _).Color = C' s.focus
      -- If so then this is a `C'`-monochromatic line and we are done.
      · obtain ⟨p, p_mem, hp⟩ := h
        refine' Or.inr (mono_of_mono ⟨p.line, p.color, _⟩)
        rintro (_ | _)
        rw [hp, s.is_focused p p_mem]
        apply p.has_color
      -- If not, we get `r+1` color focused lines by taking the product of the `r` lines with `l'` and
      -- adding to this the vertical line obtained by the focus point and `l`.
      refine'
        Or.inl
          ⟨⟨(s.lines.map _).cons ⟨(l'.map some).vertical s.focus, C' s.focus, fun x => _⟩,
              Sum.elim s.focus (l'.map some none), _, _⟩,
            _⟩
      -- The vertical line is almost monochromatic.
      · rw [vertical_apply, ← congr_fun (hl' x), line.map_apply]
      · refine' fun p => ⟨p.line.prod (l'.map some), p.Color, fun x => _⟩
        -- The product lines are almost monochromatic.
        rw [line.prod_apply, line.map_apply, ← p.has_color, ← congr_fun (hl' x)]
      -- Our `r+1` lines have the same endpoint.
      · simp_rw [Multiset.mem_cons, Multiset.mem_map]
        rintro _ (rfl | ⟨q, hq, rfl⟩)
        · rw [line.vertical_apply]
        · rw [line.prod_apply, s.is_focused q hq]
      -- Our `r+1` lines have distinct colors (this is why we needed to split into cases above).
      · rw [Multiset.map_cons, Multiset.map_map, Multiset.nodup_cons, Multiset.mem_map]
        exact ⟨fun ⟨q, hq, he⟩ => h ⟨q, hq, he⟩, s.distinct_colors⟩
      -- Finally, we really do have `r+1` lines!
      · rw [Multiset.card_cons, Multiset.card_map, sr])
#align combinatorics.line.exists_mono_in_high_dimension' [anonymous]
-/

#print Combinatorics.Line.exists_mono_in_high_dimension /-
/-- The Hales-Jewett theorem: for any finite types `α` and `κ`, there exists a finite type `ι` such
that whenever the hypercube `ι → α` is `κ`-colored, there is a monochromatic combinatorial line. -/
theorem exists_mono_in_high_dimension (α : Type u) [Finite α] (κ : Type v) [Finite κ] :
    ∃ (ι : Type)(_ : Fintype ι), ∀ C : (ι → α) → κ, ∃ l : Line α ι, l.IsMono C :=
  let ⟨ι, ιfin, hι⟩ := exists_mono_in_high_dimension' α (ULift κ)
  ⟨ι, ιfin, fun C =>
    let ⟨l, c, hc⟩ := hι (ULift.up ∘ C)
    ⟨l, c.down, fun x => by rw [← hc]⟩⟩
#align combinatorics.line.exists_mono_in_high_dimension Combinatorics.Line.exists_mono_in_high_dimension
-/

end Line

/- warning: combinatorics.exists_mono_homothetic_copy -> Combinatorics.exists_mono_homothetic_copy is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} {κ : Type.{u2}} [_inst_1 : AddCommMonoid.{u1} M] (S : Finset.{u1} M) [_inst_2 : Finite.{succ u2} κ] (C : M -> κ), Exists.{1} Nat (fun (a : Nat) => Exists.{0} (GT.gt.{0} Nat Nat.hasLt a (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero)))) (fun (H : GT.gt.{0} Nat Nat.hasLt a (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero)))) => Exists.{succ u1} M (fun (b : M) => Exists.{succ u2} κ (fun (c : κ) => forall (s : M), (Membership.Mem.{u1, u1} M (Finset.{u1} M) (Finset.hasMem.{u1} M) s S) -> (Eq.{succ u2} κ (C (HAdd.hAdd.{u1, u1, u1} M M M (instHAdd.{u1} M (AddZeroClass.toHasAdd.{u1} M (AddMonoid.toAddZeroClass.{u1} M (AddCommMonoid.toAddMonoid.{u1} M _inst_1)))) (SMul.smul.{0, u1} Nat M (AddMonoid.SMul.{u1} M (AddCommMonoid.toAddMonoid.{u1} M _inst_1)) a s) b)) c)))))
but is expected to have type
  forall {M : Type.{u2}} {κ : Type.{u1}} [_inst_1 : AddCommMonoid.{u2} M] (S : Finset.{u2} M) [_inst_2 : Finite.{succ u1} κ] (C : M -> κ), Exists.{1} Nat (fun (a : Nat) => And (GT.gt.{0} Nat instLTNat a (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0))) (Exists.{succ u2} M (fun (b : M) => Exists.{succ u1} κ (fun (c : κ) => forall (s : M), (Membership.mem.{u2, u2} M (Finset.{u2} M) (Finset.instMembershipFinset.{u2} M) s S) -> (Eq.{succ u1} κ (C (HAdd.hAdd.{u2, u2, u2} M M M (instHAdd.{u2} M (AddZeroClass.toAdd.{u2} M (AddMonoid.toAddZeroClass.{u2} M (AddCommMonoid.toAddMonoid.{u2} M _inst_1)))) (HSMul.hSMul.{0, u2, u2} Nat M M (instHSMul.{0, u2} Nat M (AddMonoid.SMul.{u2} M (AddCommMonoid.toAddMonoid.{u2} M _inst_1))) a s) b)) c)))))
Case conversion may be inaccurate. Consider using '#align combinatorics.exists_mono_homothetic_copy Combinatorics.exists_mono_homothetic_copyₓ'. -/
/-- A generalization of Van der Waerden's theorem: if `M` is a finitely colored commutative
monoid, and `S` is a finite subset, then there exists a monochromatic homothetic copy of `S`. -/
theorem exists_mono_homothetic_copy {M κ : Type _} [AddCommMonoid M] (S : Finset M) [Finite κ]
    (C : M → κ) : ∃ a > 0, ∃ (b : M)(c : κ), ∀ s ∈ S, C (a • s + b) = c :=
  by
  obtain ⟨ι, _inst, hι⟩ := line.exists_mono_in_high_dimension S κ
  skip
  specialize hι fun v => C <| ∑ i, v i
  obtain ⟨l, c, hl⟩ := hι
  set s : Finset ι := { i ∈ Finset.univ | l.idx_fun i = none } with hs
  refine'
    ⟨s.card, finset.card_pos.mpr ⟨l.proper.some, _⟩, ∑ i in sᶜ, ((l.idx_fun i).map coe).getD 0, c,
      _⟩
  · rw [hs, Finset.sep_def, Finset.mem_filter]
    exact ⟨Finset.mem_univ _, l.proper.some_spec⟩
  intro x xs
  rw [← hl ⟨x, xs⟩]
  clear hl; congr
  rw [← Finset.sum_add_sum_compl s]
  congr 1
  · rw [← Finset.sum_const]
    apply Finset.sum_congr rfl
    intro i hi
    rw [hs, Finset.sep_def, Finset.mem_filter] at hi
    rw [l.apply_none _ _ hi.right, Subtype.coe_mk]
  · apply Finset.sum_congr rfl
    intro i hi
    rw [hs, Finset.sep_def, Finset.compl_filter, Finset.mem_filter] at hi
    obtain ⟨y, hy⟩ := option.ne_none_iff_exists.mp hi.right
    simp_rw [line.apply, ← hy, Option.map_some', Option.getD_some]
#align combinatorics.exists_mono_homothetic_copy Combinatorics.exists_mono_homothetic_copy

end Combinatorics


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_302 :
  (complex.I / 2)^2 = -(1 / 4) :=
begin
  norm_num,
end