/-
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.equiv
import linear_algebra.finrank
import linear_algebra.free_module.basic
import linear_algebra.free_module.finite.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 (name := quaternion_algebra) `ℍ[` 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 }

/-- The equivalence between a quaternion algebra over `R` and `fin 4 → R`. -/
@[simps symm_apply]
def equiv_tuple {R : Type*} (c₁ c₂ : R) : ℍ[R, c₁, c₂] ≃ (fin 4 → R) :=
{ to_fun := λ a, ![a.1, a.2, a.3, a.4],
  inv_fun := λ a, ⟨a 0, a 1, a 2, a 3⟩,
  left_inv := λ ⟨a₁, a₂, a₃, a₄⟩, rfl,
  right_inv := λ f, by ext ⟨_, _|_|_|_|_|⟨⟩⟩; refl }

@[simp] lemma equiv_tuple_apply {R : Type*} (c₁ c₂ : R) (x : ℍ[R, c₁, c₂]) :
  equiv_tuple c₁ c₂ x = ![x.re, x.im_i, x.im_j, x.im_k] := 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 {S T R : Type*} [comm_ring R] {c₁ c₂ : R} (r x y z : R) (a b c : ℍ[R, c₁, c₂])

/-- The imaginary part of a quaternion. -/
def im (x : ℍ[R, c₁, c₂]) : ℍ[R, c₁, c₂] := ⟨0, x.im_i, x.im_j, x.im_k⟩

@[simp] lemma im_re : a.im.re = 0 := rfl
@[simp] lemma im_im_i : a.im.im_i = a.im_i := rfl
@[simp] lemma im_im_j : a.im.im_j = a.im_j := rfl
@[simp] lemma im_im_k : a.im.im_k = a.im_k := rfl
@[simp] lemma im_idem : a.im.im = a.im := rfl

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

@[simp, norm_cast] lemma coe_re : (x : ℍ[R, c₁, c₂]).re = x := rfl
@[simp, norm_cast] lemma coe_im_i : (x : ℍ[R, c₁, c₂]).im_i = 0 := rfl
@[simp, norm_cast] lemma coe_im_j : (x : ℍ[R, c₁, c₂]).im_j = 0 := rfl
@[simp, norm_cast] 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

@[norm_cast, simp] lemma coe_add : ((x + y : R) : ℍ[R, c₁, c₂]) = x + y :=
by ext; simp

@[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

@[norm_cast, simp] lemma coe_neg : ((-x : R) : ℍ[R, c₁, c₂]) = -x :=
by ext; simp

@[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

@[simp, norm_cast] lemma coe_im : (x : ℍ[R, c₁, c₂]).im = 0 := rfl

@[simp] lemma re_add_im : ↑a.re + a.im = a :=
ext _ _ (add_zero _) (zero_add _) (zero_add _) (zero_add _)

@[simp] lemma sub_self_im : a - a.im = a.re :=
ext _ _ (sub_zero _) (sub_self _) (sub_self _) (sub_self _)

@[simp] lemma sub_self_re : a - a.re = a.im :=
ext _ _ (sub_self _) (sub_zero _) (sub_zero _) (sub_zero _)

/-- 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

section
variables [has_smul S R] [has_smul T R] (s : S)

/-
The `ring R` argument is not used, but it's also much stronger than the other definitions in this
file need; for instance `quaternion_algebra.has_zero` only really needs `has_zero R`. For
simplicity we just keep things consistent.
-/
@[nolint unused_arguments]
instance : has_smul S ℍ[R, c₁, c₂] :=
{ smul := λ s a, ⟨s • a.1, s • a.2, s • a.3, s • a.4⟩ }

instance [has_smul S T] [is_scalar_tower S T R] : is_scalar_tower S T ℍ[R, c₁, c₂] :=
{ smul_assoc := λ s t x, by ext; exact smul_assoc _ _ _ }

instance [smul_comm_class S T R] : smul_comm_class S T ℍ[R, c₁, c₂] :=
{ smul_comm := λ s t x, by ext; exact smul_comm _ _ _ }

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

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

end

@[simp, norm_cast] lemma coe_smul [smul_zero_class S R] (s : S) (r : R) :
  (↑(s • r) : ℍ[R, c₁, c₂]) = s • ↑r :=
ext _ _ rfl (smul_zero s).symm (smul_zero s).symm (smul_zero s).symm

instance : add_comm_group ℍ[R, c₁, c₂] :=
by refine_struct
  { add := (+),
    neg := has_neg.neg,
    sub := has_sub.sub,
    zero := (0 : ℍ[R, c₁, c₂]),
    nsmul := (•),
    zsmul := (•), };
  intros; try { refl }; ext; simp; ring_exp

instance : add_group_with_one ℍ[R, c₁, c₂] :=
{ nat_cast := λ n, ((n : R) : ℍ[R, c₁, c₂]),
  nat_cast_zero := by simp,
  nat_cast_succ := by simp,
  int_cast := λ n, ((n : R) : ℍ[R, c₁, c₂]),
  int_cast_of_nat := λ _, congr_arg coe (int.cast_of_nat _),
  int_cast_neg_succ_of_nat := λ n,
    show ↑↑_ = -↑↑_, by rw [int.cast_neg, int.cast_coe_nat, coe_neg],
  one := 1,
  .. quaternion_algebra.add_comm_group }

@[simp, norm_cast] lemma nat_cast_re (n : ℕ) : (n : ℍ[R, c₁, c₂]).re = n := rfl
@[simp, norm_cast] lemma nat_cast_im_i (n : ℕ) : (n : ℍ[R, c₁, c₂]).im_i = 0 := rfl
@[simp, norm_cast] lemma nat_cast_im_j (n : ℕ) : (n : ℍ[R, c₁, c₂]).im_j = 0 := rfl
@[simp, norm_cast] lemma nat_cast_im_k (n : ℕ) : (n : ℍ[R, c₁, c₂]).im_k = 0 := rfl
@[simp, norm_cast] lemma nat_cast_im (n : ℕ) : (n : ℍ[R, c₁, c₂]).im = 0 := rfl
@[norm_cast] lemma coe_nat_cast (n : ℕ) : ↑(n : R) = (n : ℍ[R, c₁, c₂]) := rfl

@[simp, norm_cast] lemma int_cast_re (z : ℤ) : (z : ℍ[R, c₁, c₂]).re = z := rfl
@[simp, norm_cast] lemma int_cast_im_i (z : ℤ) : (z : ℍ[R, c₁, c₂]).im_i = 0 := rfl
@[simp, norm_cast] lemma int_cast_im_j (z : ℤ) : (z : ℍ[R, c₁, c₂]).im_j = 0 := rfl
@[simp, norm_cast] lemma int_cast_im_k (z : ℤ) : (z : ℍ[R, c₁, c₂]).im_k = 0 := rfl
@[simp, norm_cast] lemma int_cast_im (z : ℤ) : (z : ℍ[R, c₁, c₂]).im = 0 := rfl
@[norm_cast] lemma coe_int_cast (z : ℤ) : ↑(z : R) = (z : ℍ[R, c₁, c₂]) := rfl

instance : ring ℍ[R, c₁, c₂] :=
by refine_struct
  { add := (+),
    mul := (*),
    one := 1,
    npow := @npow_rec _ ⟨(1 : ℍ[R, c₁, c₂])⟩ ⟨(*)⟩,
    .. quaternion_algebra.add_group_with_one,
    .. quaternion_algebra.add_comm_group };
  intros; try { refl }; ext; simp; ring_exp

@[norm_cast, simp] lemma coe_mul : ((x * y : R) : ℍ[R, c₁, c₂]) = x * y :=
by ext; simp

-- TODO: add weaker `mul_action`, `distrib_mul_action`, and `module` instances (and repeat them
-- for `ℍ[R]`)
instance [comm_semiring S] [algebra S R] : algebra S ℍ[R, c₁, c₂] :=
{ smul := (•),
  to_fun := λ s, coe (algebra_map S R s),
  map_one' := by simpa only [map_one],
  map_zero' := by simpa only [map_zero],
  map_mul' := λ x y, by rw [map_mul, coe_mul],
  map_add' := λ x y, by rw [map_add, coe_add],
  smul_def' := λ s x, by ext; simp [algebra.smul_def],
  commutes' := λ s x, by ext; simp [algebra.commutes] }

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

section
variables (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 }

/-- `quaternion_algebra.equiv_tuple` as a linear equivalence. -/
def linear_equiv_tuple : ℍ[R,c₁,c₂] ≃ₗ[R] (fin 4 → R) :=
linear_equiv.symm  -- proofs are not `rfl` in the forward direction
  { to_fun := (equiv_tuple c₁ c₂).symm,
    inv_fun := equiv_tuple c₁ c₂,
    map_add' := λ v₁ v₂, rfl,
    map_smul' := λ v₁ v₂, rfl,
    .. (equiv_tuple c₁ c₂).symm }

@[simp] lemma coe_linear_equiv_tuple : ⇑(linear_equiv_tuple c₁ c₂) = equiv_tuple c₁ c₂ := rfl
@[simp] lemma coe_linear_equiv_tuple_symm :
  ⇑(linear_equiv_tuple c₁ c₂).symm = (equiv_tuple c₁ c₂).symm := rfl

/-- `ℍ[R, c₁, c₂]` has a basis over `R` given by `1`, `i`, `j`, and `k`. -/
noncomputable def basis_one_i_j_k : basis (fin 4) R ℍ[R, c₁, c₂] :=
basis.of_equiv_fun $ linear_equiv_tuple c₁ c₂

@[simp] lemma coe_basis_one_i_j_k_repr (q : ℍ[R, c₁, c₂]) :
  ⇑((basis_one_i_j_k c₁ c₂).repr q) = ![q.re, q.im_i, q.im_j, q.im_k] := rfl

instance : module.finite R ℍ[R, c₁, c₂] := module.finite.of_basis (basis_one_i_j_k c₁ c₂)
instance : module.free R ℍ[R, c₁, c₂] := module.free.of_basis (basis_one_i_j_k c₁ c₂)

lemma dim_eq_four [strong_rank_condition R] : module.rank R ℍ[R, c₁, c₂] = 4 :=
by { rw [dim_eq_card_basis (basis_one_i_j_k c₁ c₂), fintype.card_fin], norm_num }

lemma finrank_eq_four [strong_rank_condition R] : finite_dimensional.finrank R ℍ[R, c₁, c₂] = 4 :=
have cardinal.to_nat 4 = 4,
  by rw [←cardinal.to_nat_cast 4, nat.cast_bit0, nat.cast_bit0, nat.cast_one],
by rw [finite_dimensional.finrank, dim_eq_four, this]

end

@[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_pow (n : ℕ) : (↑(x ^ n) : ℍ[R, c₁, c₂]) = ↑x ^ n :=
(algebra_map R ℍ[R, c₁, c₂]).map_pow x n

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 im_conj : (conj a).im = - a.im := ext _ _ neg_zero.symm rfl rfl 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, norm_cast] lemma conj_coe : conj (x : ℍ[R, c₁, c₂]) = x := by ext; simp

@[simp] lemma conj_im : conj a.im = - a.im := im_conj _

@[simp, norm_cast] lemma conj_nat_cast (n : ℕ) : conj (n : ℍ[R, c₁, c₂]) = n :=
by rw [←coe_nat_cast, conj_coe]
@[simp, norm_cast] lemma conj_int_cast (z : ℤ) : conj (z : ℍ[R, c₁, c₂]) = z :=
by rw [←coe_int_cast, conj_coe]

@[simp] lemma conj_smul [monoid S] [distrib_mul_action S R] (s : S) (a : ℍ[R, c₁, c₂]) :
  conj (s • a) = s • conj a :=
ext _ _ rfl (smul_neg _ _).symm (smul_neg _ _).symm (smul_neg _ _).symm

@[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⟩

section char_zero
variables [no_zero_divisors R] [char_zero R]

@[simp]
lemma conj_eq_self {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]

lemma conj_eq_neg {c₁ c₂ : R} {a : ℍ[R, c₁, c₂]} :
  conj a = -a ↔ a.re = 0 :=
by simp [ext_iff, eq_neg_iff_add_eq_zero]

end char_zero
-- Can't use `rw ← conj_eq_self` 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

@[simp] lemma conj_pow (n : ℕ) : (a ^ n).conj = a.conj ^ n := star_pow _ _

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 (name := quaternion) `ℍ[` R `]` := quaternion R" in quaternion

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

/-- The equivalence between the quaternions over `R` and `fin 4 → R`. -/
@[simps symm_apply]
def quaternion.equiv_tuple (R : Type*) [has_one R] [has_neg R] : ℍ[R] ≃ (fin 4 → R) :=
quaternion_algebra.equiv_tuple _ _

@[simp] lemma quaternion.equiv_tuple_apply (R : Type*) [has_one R] [has_neg R] (x : ℍ[R]) :
  quaternion.equiv_tuple R x = ![x.re, x.im_i, x.im_j, x.im_k] := rfl

namespace quaternion

variables {S T 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 [has_smul S R] : has_smul S ℍ[R] := quaternion_algebra.has_smul
instance [has_smul S T] [has_smul S R] [has_smul T R] [is_scalar_tower S T R] :
  is_scalar_tower S T ℍ[R] := quaternion_algebra.is_scalar_tower
instance [has_smul S R] [has_smul T R] [smul_comm_class S T R] :
  smul_comm_class S T ℍ[R] := quaternion_algebra.smul_comm_class
instance [comm_semiring S] [algebra S R] : algebra S ℍ[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

/-- The imaginary part of a quaternion. -/
def im (x : ℍ[R]) : ℍ[R] := x.im

@[simp] lemma im_re : a.im.re = 0 := rfl
@[simp] lemma im_im_i : a.im.im_i = a.im_i := rfl
@[simp] lemma im_im_j : a.im.im_j = a.im_j := rfl
@[simp] lemma im_im_k : a.im.im_k = a.im_k := rfl
@[simp] lemma im_idem : a.im.im = a.im := rfl

@[simp] lemma re_add_im : ↑a.re + a.im = a := a.re_add_im
@[simp] lemma sub_self_im : a - a.im = a.re := a.sub_self_im
@[simp] lemma sub_self_re : a - a.re = a.im := a.sub_self_re

@[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, norm_cast] lemma coe_im : (x : ℍ[R]).im = 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] lemma zero_im : (0 : ℍ[R]).im = 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] lemma one_im : (1 : ℍ[R]).im = 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] lemma add_im : (a + b).im = a.im + b.im := ext _ _ (add_zero _).symm rfl rfl 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] lemma neg_im : (-a).im = -a.im := ext _ _ neg_zero.symm rfl rfl 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] lemma sub_im : (a - b).im = a.im - b.im := ext _ _ (sub_zero _).symm rfl rfl 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

@[norm_cast, simp] lemma coe_pow (n : ℕ) : (↑(x ^ n) : ℍ[R]) = ↑x ^ n :=
quaternion_algebra.coe_pow x n

@[simp, norm_cast] lemma nat_cast_re (n : ℕ) : (n : ℍ[R]).re = n := rfl
@[simp, norm_cast] lemma nat_cast_im_i (n : ℕ) : (n : ℍ[R]).im_i = 0 := rfl
@[simp, norm_cast] lemma nat_cast_im_j (n : ℕ) : (n : ℍ[R]).im_j = 0 := rfl
@[simp, norm_cast] lemma nat_cast_im_k (n : ℕ) : (n : ℍ[R]).im_k = 0 := rfl
@[simp, norm_cast] lemma nat_cast_im (n : ℕ) : (n : ℍ[R]).im = 0 := rfl
@[norm_cast] lemma coe_nat_cast (n : ℕ) : ↑(n : R) = (n : ℍ[R]) := rfl

@[simp, norm_cast] lemma int_cast_re (z : ℤ) : (z : ℍ[R]).re = z := rfl
@[simp, norm_cast] lemma int_cast_im_i (z : ℤ) : (z : ℍ[R]).im_i = 0 := rfl
@[simp, norm_cast] lemma int_cast_im_j (z : ℤ) : (z : ℍ[R]).im_j = 0 := rfl
@[simp, norm_cast] lemma int_cast_im_k (z : ℤ) : (z : ℍ[R]).im_k = 0 := rfl
@[simp, norm_cast] lemma int_cast_im (z : ℤ) : (z : ℍ[R]).im = 0 := rfl
@[norm_cast] lemma coe_int_cast (z : ℤ) : ↑(z : R) = (z : ℍ[R]) := rfl

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 [has_smul S R] (s : S) : (s • a).re = s • a.re := rfl
@[simp] lemma smul_im_i [has_smul S R] (s : S) : (s • a).im_i = s • a.im_i := rfl
@[simp] lemma smul_im_j [has_smul S R] (s : S) : (s • a).im_j = s • a.im_j := rfl
@[simp] lemma smul_im_k [has_smul S R] (s : S) : (s • a).im_k = s • a.im_k := rfl
@[simp] lemma smul_im [smul_zero_class S R] (s : S) : (s • a).im = s • a.im :=
ext _ _ (smul_zero _).symm rfl rfl rfl

@[simp, norm_cast] lemma coe_smul [smul_zero_class S R] (s : S) (r : R) :
  (↑(s • r) : ℍ[R]) = s • ↑r :=
quaternion_algebra.coe_smul _ _

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

instance : module.finite R ℍ[R] := quaternion_algebra.module.finite _ _
instance : module.free R ℍ[R] := quaternion_algebra.module.free _ _

lemma dim_eq_four [strong_rank_condition R] : module.rank R ℍ[R] = 4 :=
quaternion_algebra.dim_eq_four _ _

lemma finrank_eq_four [strong_rank_condition R] : finite_dimensional.finrank R ℍ[R] = 4 :=
quaternion_algebra.finrank_eq_four _ _

/-- 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_im : a.conj.im = - a.im := a.im_conj

@[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, norm_cast] lemma conj_coe : conj (x : ℍ[R]) = x := quaternion_algebra.conj_coe x
@[simp] lemma im_conj : a.im.conj = - a.im := quaternion_algebra.im_conj _

@[simp, norm_cast] lemma conj_nat_cast (n : ℕ) : conj (n : ℍ[R]) = n :=
quaternion_algebra.conj_nat_cast _
@[simp, norm_cast] lemma conj_int_cast (z : ℤ) : conj (z : ℍ[R]) = z :=
quaternion_algebra.conj_int_cast _

@[simp] lemma conj_smul [monoid S] [distrib_mul_action S R] (s : S) (a : ℍ[R]) :
  conj (s • a) = s • conj a := quaternion_algebra.conj_smul _ _

@[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

section char_zero
variables [no_zero_divisors R] [char_zero R]

@[simp] lemma conj_eq_self {a : ℍ[R]} : conj a = a ↔ a = a.re := quaternion_algebra.conj_eq_self

@[simp] lemma conj_eq_neg {a : ℍ[R]} : conj a = -a ↔ a.re = 0 := quaternion_algebra.conj_eq_neg

end char_zero

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

@[simp] lemma conj_pow (n : ℕ) : conj (a ^ n) = conj a ^ n := a.conj_pow n

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_conj : norm_sq (conj a) = norm_sq a := by simp [norm_sq_def']

@[norm_cast] lemma norm_sq_nat_cast (n : ℕ) : norm_sq (n : ℍ[R]) = n^2 :=
by rw [←coe_nat_cast, norm_sq_coe]

@[norm_cast] lemma norm_sq_int_cast (z : ℤ) : norm_sq (z : ℍ[R]) = z^2 :=
by rw [←coe_int_cast, norm_sq_coe]

@[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 im_sq : a.im^2 = -norm_sq a.im :=
by simp_rw [sq, ←conj_mul_self, im_conj, neg_mul, neg_neg]

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]

lemma norm_sq_smul (r : R) (q : ℍ[R]) : norm_sq (r • q) = r^2 * norm_sq q :=
by simp_rw [norm_sq_def, conj_smul, smul_mul_smul, smul_re, sq, smul_eq_mul]

lemma norm_sq_add (a b : ℍ[R]) : norm_sq (a + b) = norm_sq a + norm_sq b + 2 * (a * conj b).re :=
calc norm_sq (a + b) = (norm_sq a + (a * conj b).re) + ((b * conj a).re + norm_sq b)
                     : by simp_rw [norm_sq_def, conj_add, add_mul, mul_add, add_re]
                 ... = norm_sq a + norm_sq b + ((a * conj b).re + (b * conj a).re) : by abel
                 ... = norm_sq a + norm_sq b + 2 * (a * conj b).re
                     : by rw [←add_re, ←conj_mul_conj a b, self_add_conj', coe_re]

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 : no_zero_divisors ℍ[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, }

instance : is_domain ℍ[R] :=
no_zero_divisors.to_is_domain _

lemma sq_eq_norm_sq : a^2 = norm_sq a ↔ a = a.re :=
begin
  simp_rw [←conj_eq_self],
  obtain rfl | hq0 := eq_or_ne a 0,
  { simp },
  { rw [←conj_mul_self, sq, mul_left_inj' hq0, eq_comm] }
end

lemma sq_eq_neg_norm_sq : a^2 = -norm_sq a ↔ a.re = 0 :=
begin
  simp_rw [←conj_eq_neg],
  obtain rfl | hq0 := eq_or_ne a 0,
  { simp },
  rw [←conj_mul_self, ←mul_neg, ←neg_sq, sq, mul_left_inj' (neg_ne_zero.mpr hq0), eq_comm],
end

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 : group_with_zero ℍ[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,
  .. (by apply_instance : monoid_with_zero ℍ[R]) }

@[norm_cast, simp] lemma coe_inv (x : R) : ((x⁻¹ : R) : ℍ[R]) = x⁻¹ :=
map_inv₀ (algebra_map R ℍ[R]) _

@[norm_cast, simp] lemma coe_div (x y : R) : ((x / y : R) : ℍ[R]) = x / y :=
map_div₀ (algebra_map R ℍ[R]) x y

@[norm_cast, simp] lemma coe_zpow (x : R) (z : ℤ) : ((x ^ z : R) : ℍ[R]) = x ^ z :=
map_zpow₀ (algebra_map R ℍ[R]) x z

instance : division_ring ℍ[R] :=
{ rat_cast := λ q, ↑(q : R),
  rat_cast_mk := λ n d hd h, by rw [rat.cast_mk', coe_mul, coe_int_cast, coe_inv, coe_nat_cast],
  qsmul := (•),
  qsmul_eq_mul' := λ q x, begin
    rw coe_mul_eq_smul,
    ext; exact division_ring.qsmul_eq_mul' _ _,
  end,
  .. quaternion.group_with_zero,
  .. quaternion.ring }

@[simp, norm_cast] lemma rat_cast_re (q : ℚ) : (q : ℍ[R]).re = q := rfl
@[simp, norm_cast] lemma rat_cast_im_i (q : ℚ) : (q : ℍ[R]).im_i = 0 := rfl
@[simp, norm_cast] lemma rat_cast_im_j (q : ℚ) : (q : ℍ[R]).im_j = 0 := rfl
@[simp, norm_cast] lemma rat_cast_im_k (q : ℚ) : (q : ℍ[R]).im_k = 0 := rfl
@[simp, norm_cast] lemma rat_cast_im (q : ℚ) : (q : ℍ[R]).im = 0 := rfl
@[norm_cast] lemma coe_rat_cast (q : ℚ) : ↑(q : R) = (q : ℍ[R]) := rfl

lemma conj_inv : conj (a⁻¹) = (conj a)⁻¹ := star_inv' a
lemma conj_zpow (z : ℤ) : conj (a ^ z) = conj a ^ z := star_zpow₀ a z
@[simp, norm_cast] lemma conj_rat_cast (q : ℚ) : conj (q : ℍ[R]) = q := @star_rat_cast ℍ[R] _ _ q

@[simp] lemma norm_sq_inv : norm_sq a⁻¹ = (norm_sq a)⁻¹ := map_inv₀ norm_sq _
@[simp] lemma norm_sq_div : norm_sq (a / b) = norm_sq a / norm_sq b := map_div₀ norm_sq a b
@[simp] lemma norm_sq_zpow (z : ℤ) : norm_sq (a ^ z) = norm_sq a ^ z := map_zpow₀ norm_sq a z
@[norm_cast] lemma norm_sq_rat_cast (q : ℚ) : norm_sq (q : ℍ[R]) = q^2 :=
by rw [←coe_rat_cast, norm_sq_coe]

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 (aleph_0_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


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro

! This file was ported from Lean 3 source module data.nat.prime_norm_num
! leanprover-community/mathlib commit 10b4e499f43088dd3bb7b5796184ad5216648ab1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Nat.Factors
import Mathbin.Data.Nat.Prime
import Mathbin.Tactic.NormNum

/-!
# Primality prover

This file provides a `norm_num` extention to prove that natural numbers are prime.

-/

namespace Tactic

namespace NormNum

theorem is_prime_helper (n : ℕ) (h₁ : 1 < n) (h₂ : Nat.minFac n = n) : Nat.Prime n :=
  Nat.prime_def_minFac.2 ⟨h₁, h₂⟩
#align tactic.norm_num.is_prime_helper Tactic.NormNum.is_prime_helper

theorem minFac_bit0 (n : ℕ) : Nat.minFac (bit0 n) = 2 := by
  simp [Nat.minFac_eq, show 2 ∣ bit0 n by simp [bit0_eq_two_mul n]]
#align tactic.norm_num.min_fac_bit0 Tactic.NormNum.minFac_bit0

/-- A predicate representing partial progress in a proof of `min_fac`. -/
def MinFacHelper (n k : ℕ) : Prop :=
  0 < k ∧ bit1 k ≤ Nat.minFac (bit1 n)
#align tactic.norm_num.min_fac_helper Tactic.NormNum.MinFacHelper

theorem MinFacHelper.n_pos {n k : ℕ} (h : MinFacHelper n k) : 0 < n :=
  pos_iff_ne_zero.2 fun e => by rw [e] at h <;> exact not_le_of_lt (Nat.bit1_lt h.1) h.2
#align tactic.norm_num.min_fac_helper.n_pos Tactic.NormNum.MinFacHelper.n_pos

theorem minFac_ne_bit0 {n k : ℕ} : Nat.minFac (bit1 n) ≠ bit0 k :=
  by
  rw [bit0_eq_two_mul]
  refine' fun e => absurd ((Nat.dvd_add_iff_right _).2 (dvd_trans ⟨_, e⟩ (Nat.minFac_dvd _))) _ <;>
    simp
#align tactic.norm_num.min_fac_ne_bit0 Tactic.NormNum.minFac_ne_bit0

theorem minFacHelper_0 (n : ℕ) (h : 0 < n) : MinFacHelper n 1 :=
  by
  refine' ⟨zero_lt_one, lt_of_le_of_ne _ min_fac_ne_bit0.symm⟩
  rw [Nat.succ_le_iff]
  refine' lt_of_le_of_ne (Nat.minFac_pos _) fun e => Nat.not_prime_one _
  rw [e]
  exact Nat.minFac_prime (Nat.bit1_lt h).ne'
#align tactic.norm_num.min_fac_helper_0 Tactic.NormNum.minFacHelper_0

theorem minFacHelper_1 {n k k' : ℕ} (e : k + 1 = k') (np : Nat.minFac (bit1 n) ≠ bit1 k)
    (h : MinFacHelper n k) : MinFacHelper n k' :=
  by
  rw [← e]
  refine'
    ⟨Nat.succ_pos _,
      (lt_of_le_of_ne (lt_of_le_of_ne _ _ : k + 1 + k < _) min_fac_ne_bit0.symm : bit0 (k + 1) < _)⟩
  · rw [add_right_comm]
    exact h.2
  · rw [add_right_comm]
    exact np.symm
#align tactic.norm_num.min_fac_helper_1 Tactic.NormNum.minFacHelper_1

theorem minFacHelper_2 (n k k' : ℕ) (e : k + 1 = k') (np : ¬Nat.Prime (bit1 k))
    (h : MinFacHelper n k) : MinFacHelper n k' :=
  by
  refine' min_fac_helper_1 e _ h
  intro e₁; rw [← e₁] at np
  exact np (Nat.minFac_prime <| ne_of_gt <| Nat.bit1_lt h.n_pos)
#align tactic.norm_num.min_fac_helper_2 Tactic.NormNum.minFacHelper_2

theorem minFacHelper_3 (n k k' c : ℕ) (e : k + 1 = k') (nc : bit1 n % bit1 k = c) (c0 : 0 < c)
    (h : MinFacHelper n k) : MinFacHelper n k' :=
  by
  refine' min_fac_helper_1 e _ h
  refine' mt _ (ne_of_gt c0); intro e₁
  rw [← nc, ← Nat.dvd_iff_mod_eq_zero, ← e₁]
  apply Nat.minFac_dvd
#align tactic.norm_num.min_fac_helper_3 Tactic.NormNum.minFacHelper_3

theorem minFacHelper_4 (n k : ℕ) (hd : bit1 n % bit1 k = 0) (h : MinFacHelper n k) :
    Nat.minFac (bit1 n) = bit1 k :=
  by
  rw [← Nat.dvd_iff_mod_eq_zero] at hd
  exact le_antisymm (Nat.minFac_le_of_dvd (Nat.bit1_lt h.1) hd) h.2
#align tactic.norm_num.min_fac_helper_4 Tactic.NormNum.minFacHelper_4

theorem minFacHelper_5 (n k k' : ℕ) (e : bit1 k * bit1 k = k') (hd : bit1 n < k')
    (h : MinFacHelper n k) : Nat.minFac (bit1 n) = bit1 n :=
  by
  refine' (Nat.prime_def_minFac.1 (Nat.prime_def_le_sqrt.2 ⟨Nat.bit1_lt h.n_pos, _⟩)).2
  rw [← e] at hd
  intro m m2 hm md
  have := le_trans h.2 (le_trans (Nat.minFac_le_of_dvd m2 md) hm)
  rw [Nat.le_sqrt] at this
  exact not_le_of_lt hd this
#align tactic.norm_num.min_fac_helper_5 Tactic.NormNum.minFacHelper_5

open _Root_.NormNum

/-- Given `e` a natural numeral and `d : nat` a factor of it, return `⊢ ¬ prime e`. -/
unsafe def prove_non_prime (e : expr) (n d₁ : ℕ) : tactic expr := do
  let e₁ := reflect d₁
  let c ← mk_instance_cache q(Nat)
  let (c, p₁) ← prove_lt_nat c q(1) e₁
  let d₂ := n / d₁
  let e₂ := reflect d₂
  let (c, e', p) ← prove_mul_nat c e₁ e₂
  guard (e' == e)
  let (c, p₂) ← prove_lt_nat c q(1) e₂
  return <| q(@Nat.not_prime_mul').mk_app [e₁, e₂, e, p, p₁, p₂]
#align tactic.norm_num.prove_non_prime tactic.norm_num.prove_non_prime

/-- Given `a`,`a1 := bit1 a`, `n1` the value of `a1`, `b` and `p : min_fac_helper a b`,
  returns `(c, ⊢ min_fac a1 = c)`. -/
unsafe def prove_min_fac_aux (a a1 : expr) (n1 : ℕ) :
    instance_cache → expr → expr → tactic (instance_cache × expr × expr)
  | ic, b, p => do
    let k ← b.toNat
    let k1 := bit1 k
    let b1 := q((bit1 : ℕ → ℕ)).mk_app [b]
    if n1 < k1 * k1 then do
        let (ic, e', p₁) ← prove_mul_nat ic b1 b1
        let (ic, p₂) ← prove_lt_nat ic a1 e'
        return (ic, a1, q(minFacHelper_5).mk_app [a, b, e', p₁, p₂, p])
      else
        let d := k1
        if to_bool (d < k1) then do
          let k' := k + 1
          let e' := reflect k'
          let (ic, p₁) ← prove_succ ic b e'
          let p₂ ← prove_non_prime b1 k1 d
          prove_min_fac_aux ic e' <| q(minFacHelper_2).mk_app [a, b, e', p₁, p₂, p]
        else do
          let nc := n1 % k1
          let (ic, c, pc) ← prove_div_mod ic a1 b1 tt
          if nc = 0 then return (ic, b1, q(minFacHelper_4).mk_app [a, b, pc, p])
            else do
              let (ic, p₀) ← prove_pos ic c
              let k' := k + 1
              let e' := reflect k'
              let (ic, p₁) ← prove_succ ic b e'
              prove_min_fac_aux ic e' <| q(minFacHelper_3).mk_app [a, b, e', c, p₁, pc, p₀, p]
#align tactic.norm_num.prove_min_fac_aux tactic.norm_num.prove_min_fac_aux

/-- Given `a` a natural numeral, returns `(b, ⊢ min_fac a = b)`. -/
unsafe def prove_min_fac (ic : instance_cache) (e : expr) : tactic (instance_cache × expr × expr) :=
  match match_numeral e with
  | match_numeral_result.zero => return (ic, q((2 : ℕ)), q(Nat.minFac_zero))
  | match_numeral_result.one => return (ic, q((1 : ℕ)), q(Nat.minFac_one))
  | match_numeral_result.bit0 e => return (ic, q(2), q(minFac_bit0).mk_app [e])
  | match_numeral_result.bit1 e => do
    let n ← e.toNat
    let c ← mk_instance_cache q(Nat)
    let (c, p) ← prove_pos c e
    let a1 := q((bit1 : ℕ → ℕ)).mk_app [e]
    prove_min_fac_aux e a1 (bit1 n) c q(1) (q(minFacHelper_0).mk_app [e, p])
  | _ => failed
#align tactic.norm_num.prove_min_fac tactic.norm_num.prove_min_fac

/-- A partial proof of `factors`. Asserts that `l` is a sorted list of primes, lower bounded by a
prime `p`, which multiplies to `n`. -/
def FactorsHelper (n p : ℕ) (l : List ℕ) : Prop :=
  p.Prime → List.Chain (· ≤ ·) p l ∧ (∀ a ∈ l, Nat.Prime a) ∧ List.prod l = n
#align tactic.norm_num.factors_helper Tactic.NormNum.FactorsHelper

theorem factorsHelper_nil (a : ℕ) : FactorsHelper 1 a [] := fun pa =>
  ⟨List.Chain.nil, by rintro _ ⟨⟩, List.prod_nil⟩
#align tactic.norm_num.factors_helper_nil Tactic.NormNum.factorsHelper_nil

theorem factorsHelper_cons' (n m a b : ℕ) (l : List ℕ) (h₁ : b * m = n) (h₂ : a ≤ b)
    (h₃ : Nat.minFac b = b) (H : FactorsHelper m b l) : FactorsHelper n a (b :: l) := fun pa =>
  have pb : b.Prime := Nat.prime_def_minFac.2 ⟨le_trans pa.two_le h₂, h₃⟩
  let ⟨f₁, f₂, f₃⟩ := H pb
  ⟨List.Chain.cons h₂ f₁, fun c h => h.elim (fun e => e.symm ▸ pb) (f₂ _), by
    rw [List.prod_cons, f₃, h₁]⟩
#align tactic.norm_num.factors_helper_cons' Tactic.NormNum.factorsHelper_cons'

theorem factorsHelper_cons (n m a b : ℕ) (l : List ℕ) (h₁ : b * m = n) (h₂ : a < b)
    (h₃ : Nat.minFac b = b) (H : FactorsHelper m b l) : FactorsHelper n a (b :: l) :=
  factorsHelper_cons' _ _ _ _ _ h₁ h₂.le h₃ H
#align tactic.norm_num.factors_helper_cons Tactic.NormNum.factorsHelper_cons

theorem factorsHelper_sn (n a : ℕ) (h₁ : a < n) (h₂ : Nat.minFac n = n) : FactorsHelper n a [n] :=
  factorsHelper_cons _ _ _ _ _ (mul_one _) h₁ h₂ (factorsHelper_nil _)
#align tactic.norm_num.factors_helper_sn Tactic.NormNum.factorsHelper_sn

theorem factorsHelper_same (n m a : ℕ) (l : List ℕ) (h : a * m = n) (H : FactorsHelper m a l) :
    FactorsHelper n a (a :: l) := fun pa =>
  factorsHelper_cons' _ _ _ _ _ h le_rfl (Nat.prime_def_minFac.1 pa).2 H pa
#align tactic.norm_num.factors_helper_same Tactic.NormNum.factorsHelper_same

theorem factorsHelper_same_sn (a : ℕ) : FactorsHelper a a [a] :=
  factorsHelper_same _ _ _ _ (mul_one _) (factorsHelper_nil _)
#align tactic.norm_num.factors_helper_same_sn Tactic.NormNum.factorsHelper_same_sn

theorem factorsHelper_end (n : ℕ) (l : List ℕ) (H : FactorsHelper n 2 l) : Nat.factors n = l :=
  let ⟨h₁, h₂, h₃⟩ := H Nat.prime_two
  have := List.chain'_iff_pairwise.1 (@List.Chain'.tail _ _ (_ :: _) h₁)
  (List.eq_of_perm_of_sorted (Nat.factors_unique h₃ h₂) this (Nat.factors_sorted _)).symm
#align tactic.norm_num.factors_helper_end Tactic.NormNum.factorsHelper_end

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- Given `n` and `a` natural numerals, returns `(l, ⊢ factors_helper n a l)`. -/ unsafe
  def
    prove_factors_aux
    : instance_cache → expr → expr → ℕ → ℕ → tactic ( instance_cache × expr × expr )
    |
      c , en , ea , n , a
      =>
      let
        b := n . minFac
        if
          b < n
          then
          do
            let m := n / b
              let ( c , em ) ← c . ofNat m
              if
                b = a
                then
                do
                  let ( c , _ , p₁ ) ← prove_mul_nat c ea em
                    let ( c , l , p₂ ) ← prove_factors_aux c em ea m a
                    pure
                      (
                        c
                          ,
                          q( ( $ ( ea ) :: $ ( l ) : List ℕ ) )
                            ,
                            q( factorsHelper_same ) . mk_app [ en , em , ea , l , p₁ , p₂ ]
                        )
                else
                do
                  let ( c , eb ) ← c b
                    let ( c , _ , p₁ ) ← prove_mul_nat c eb em
                    let ( c , p₂ ) ← prove_lt_nat c ea eb
                    let ( c , _ , p₃ ) ← prove_min_fac c eb
                    let ( c , l , p₄ ) ← prove_factors_aux c em eb m b
                    pure
                      (
                        c
                          ,
                          q( ( $ ( eb ) :: $ ( l ) : List ℕ ) )
                            ,
                            q( factorsHelper_cons ) . mk_app
                              [ en , em , ea , eb , l , p₁ , p₂ , p₃ , p₄ ]
                        )
          else
          if
            b = a
            then
            pure ( c , q( ( [ $ ( ea ) ] : List ℕ ) ) , q( factorsHelper_same_sn ) . mk_app [ ea ] )
            else
            do
              let ( c , p₁ ) ← prove_lt_nat c ea en
                let ( c , _ , p₂ ) ← prove_min_fac c en
                pure
                  (
                    c
                      ,
                      q( ( [ $ ( en ) ] : List ℕ ) )
                        ,
                        q( factorsHelper_sn ) . mk_app [ en , ea , p₁ , p₂ ]
                    )
#align tactic.norm_num.prove_factors_aux tactic.norm_num.prove_factors_aux

/-- Evaluates the `prime` and `min_fac` functions. -/
@[norm_num]
unsafe def eval_prime : expr → tactic (expr × expr)
  | q(Nat.Prime $(e)) => do
    let n ← e.toNat
    match n with
      | 0 => false_intro q(Nat.not_prime_zero)
      | 1 => false_intro q(Nat.not_prime_one)
      | _ =>
        let d₁ := n
        if d₁ < n then prove_non_prime e n d₁ >>= false_intro
        else do
          let e₁ := reflect d₁
          let c ← mk_instance_cache q(ℕ)
          let (c, p₁) ← prove_lt_nat c q(1) e₁
          let (c, e₁, p) ← prove_min_fac c e
          true_intro <| q(is_prime_helper).mk_app [e, p₁, p]
  | q(Nat.minFac $(e)) => do
    let ic ← mk_instance_cache q(ℕ)
    Prod.snd <$> prove_min_fac ic e
  | q(Nat.factors $(e)) => do
    let n ← e.toNat
    match n with
      | 0 => pure (q(@List.nil ℕ), q(Nat.factors_zero))
      | 1 => pure (q(@List.nil ℕ), q(Nat.factors_one))
      | _ => do
        let c ← mk_instance_cache q(ℕ)
        let (c, l, p) ← prove_factors_aux c e q(2) n 2
        pure (l, q(factorsHelper_end).mk_app [e, l, p])
  | _ => failed
#align tactic.norm_num.eval_prime tactic.norm_num.eval_prime

end NormNum

end Tactic


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

universes u

namespace Mathlib

/-!
# The completion of a metric space

Completion of uniform spaces are already defined in `topology.uniform_space.completion`. We show
here that the uniform space completion of a metric space inherits a metric space structure,
by extending the distance to the completion and checking that it is indeed a distance, and that
it defines the same uniformity as the already defined uniform structure on the completion
-/

namespace metric

/-- The distance on the completion is obtained by extending the distance on the original space,
by uniform continuity. -/
protected instance uniform_space.completion.has_dist {α : Type u} [metric_space α] :
    has_dist (uniform_space.completion α) :=
  has_dist.mk (uniform_space.completion.extension₂ dist)

/-- The new distance is uniformly continuous. -/
protected theorem completion.uniform_continuous_dist {α : Type u} [metric_space α] :
    uniform_continuous
        fun (p : uniform_space.completion α × uniform_space.completion α) =>
          dist (prod.fst p) (prod.snd p) :=
  uniform_space.completion.uniform_continuous_extension₂ dist

/-- The new distance is an extension of the original distance. -/
protected theorem completion.dist_eq {α : Type u} [metric_space α] (x : α) (y : α) :
    dist ↑x ↑y = dist x y :=
  uniform_space.completion.extension₂_coe_coe uniform_continuous_dist x y

/- Let us check that the new distance satisfies the axioms of a distance, by starting from the
properties on α and extending them to `completion α` by continuity. -/

protected theorem completion.dist_self {α : Type u} [metric_space α]
    (x : uniform_space.completion α) : dist x x = 0 :=
  sorry

protected theorem completion.dist_comm {α : Type u} [metric_space α]
    (x : uniform_space.completion α) (y : uniform_space.completion α) : dist x y = dist y x :=
  sorry

protected theorem completion.dist_triangle {α : Type u} [metric_space α]
    (x : uniform_space.completion α) (y : uniform_space.completion α)
    (z : uniform_space.completion α) : dist x z ≤ dist x y + dist y z :=
  sorry

/-- Elements of the uniformity (defined generally for completions) can be characterized in terms
of the distance. -/
protected theorem completion.mem_uniformity_dist {α : Type u} [metric_space α]
    (s : set (uniform_space.completion α × uniform_space.completion α)) :
    s ∈ uniformity (uniform_space.completion α) ↔
        ∃ (ε : ℝ), ∃ (H : ε > 0), ∀ {a b : uniform_space.completion α}, dist a b < ε → (a, b) ∈ s :=
  sorry

/-- If two points are at distance 0, then they coincide. -/
protected theorem completion.eq_of_dist_eq_zero {α : Type u} [metric_space α]
    (x : uniform_space.completion α) (y : uniform_space.completion α) (h : dist x y = 0) : x = y :=
  sorry

/-- Reformulate `completion.mem_uniformity_dist` in terms that are suitable for the definition
of the metric space structure. -/
protected theorem completion.uniformity_dist' {α : Type u} [metric_space α] :
    uniformity (uniform_space.completion α) =
        infi
          fun (ε : Subtype fun (ε : ℝ) => 0 < ε) =>
            filter.principal
              (set_of
                fun (p : uniform_space.completion α × uniform_space.completion α) =>
                  dist (prod.fst p) (prod.snd p) < subtype.val ε) :=
  sorry

protected theorem completion.uniformity_dist {α : Type u} [metric_space α] :
    uniformity (uniform_space.completion α) =
        infi
          fun (ε : ℝ) =>
            infi
              fun (H : ε > 0) =>
                filter.principal
                  (set_of
                    fun (p : uniform_space.completion α × uniform_space.completion α) =>
                      dist (prod.fst p) (prod.snd p) < ε) :=
  sorry

/-- Metric space structure on the completion of a metric space. -/
protected instance completion.metric_space {α : Type u} [metric_space α] :
    metric_space (uniform_space.completion α) :=
  metric_space.mk completion.dist_self completion.eq_of_dist_eq_zero completion.dist_comm
    completion.dist_triangle
    (fun (x y : uniform_space.completion α) =>
      ennreal.of_real (uniform_space.completion.extension₂ dist x y))
    (uniform_space.completion.uniform_space α)

/-- The embedding of a metric space in its completion is an isometry. -/
theorem completion.coe_isometry {α : Type u} [metric_space α] : isometry coe :=
  iff.mpr isometry_emetric_iff_metric completion.dist_eq

end Mathlib


import data.finset.basic
import data.list.basic
import data.nat.basic
import tactic.core
import algebra.big_operators
open finset nat

open_locale big_operators

--------------------------------------------------------------------------
--- Define turan numbers.
---
--- Since the Turan problem asks for the maximum number of edges in a K_t-free graph of order n
--  We don't care about t = 0 or t = 1
--  so we define turan_numb t n to be what most people would call turan (t+1) n
--  eg turan 0 n is the max size (number of edges) in a K_2 free graph
--  Turan's theorem says that this is the number of edges in a balanced complete (t+1)-partite graph
--

-- Main definitions below: ...

namespace turanpartition

--classical Turan numbers
def turan_numb : ℕ → ℕ → ℕ:=
begin
  intros t n,
  set a:= n/(t+1),--- size of a small part
  set b:= n%(t+1),-- number of large parts
  exact (a^2)*nat.choose(t+1-b)(2)+a*(a+1)*b*(t+1-b)+((a+1)^2)*nat.choose(b)(2)
end

--complement is often easier to deal with and we also multiply by 2 to convert edges to degree sum
-- so 2*(turan_numb t n) = n^2 - (turan_numb'  t n)
def turan_numb'  : ℕ → ℕ → ℕ:=
begin
  intros t n,
  set a:= n/(t+1),--- size of a small part
  set b:= n%(t+1),-- number of large parts
  exact (t+1-b)*a^2 + b*(a+1)^2
end

-- choose two simplification
lemma two (a :ℕ) : 2*nat.choose a 2 = a*(a-1):=
begin
  induction a with a ha,{ dsimp,rwa [zero_mul, mul_zero],},
  {rw [nat.choose, choose_one_right, succ_sub_succ_eq_sub, tsub_zero, mul_add], norm_num, rw  ha,
  cases (eq_zero_or_eq_succ_pred a);{rw h, ring,},}
end

-- square simp
lemma square (b c:ℕ) : (b+c)^2=b^2+2*b*c+c^2:=by ring

-- this is a mess but it works
lemma tn_turan_numb'  (t n : ℕ) : (turan_numb'  t n) + 2*(turan_numb t n) = n^2:=
begin
  unfold turan_numb turan_numb' , dsimp,
  have t1:t+1-1=t:=tsub_eq_of_eq_add rfl,
  have n1:=div_add_mod n (t+1),
  have n2:=(mod_lt n (succ_pos t)), rw succ_eq_add_one at n2,
  have n3: (t+1)-n%(t+1)+n%(t+1)=(t+1):= tsub_add_cancel_of_le (le_of_lt n2),
  set a:= n/(t+1) with ha, set b:= n%(t+1) with hb,
  cases nat.eq_zero_or_pos n with hn,{ rw hn at *,
  simp only [*, nat.zero_div, zero_pow', ne.def, bit0_eq_zero, nat.one_ne_zero, not_false_iff, mul_zero, zero_add, zero_mul,
  choose_zero_succ] at *,},{
  cases nat.eq_zero_or_pos b with hb',{
    rw hb' at *,ring_nf, rw [two, tsub_zero, nat.choose], rw add_zero at n1,
    rw [mul_zero,mul_zero,add_zero,add_zero,add_zero,← n1,t1],ring_nf,},
  {rw [← n3 , add_mul] at n1, nth_rewrite 2 ← mul_one b at n1, rw [add_assoc ,← mul_add  b] at n1,
  nth_rewrite_rhs 0 ← n1,  rw [mul_add, mul_add, ← mul_assoc 2 , ← mul_assoc 2 ((a+1)^2)],
  nth_rewrite 0 mul_comm 2 _, nth_rewrite 1 mul_comm 2 _,
  rw [mul_assoc, mul_assoc _ 2,two,two, square ((t+1-b)*a) (b*(a+1)),mul_comm _ (a^2)],
  set c:=(t+1-b) with hc, have hc1:1≤ c:=by linarith, have hb1:1≤ b:=by linarith,
  have hc2:(c-1+1=c):=by linarith, have hb2:(b-1+1=b):=by linarith,
  ring_nf,rw [hc2, hb2], nth_rewrite 3 ← mul_one 2,rw [← mul_add 2, hb2],ring_nf,},}
end

--sum of degrees in a turan graph
lemma tn_turan_numb'_2 (t n : ℕ) : 2*(turan_numb t n) = n^2 - (turan_numb'  t n):=
begin
  rw ← tn_turan_numb' t n, exact (add_tsub_cancel_left _ _).symm
end

-- start with some helper functions that don't need partitions to be defined.
-- here P : ℕ → ℕ plays the role of sizes of parts in a (t+1)-partition

-- sum of part sizes i.e number of vertices
def psum (t : ℕ) (P : ℕ → ℕ): ℕ:= ∑i in range(t+1), P i

-- sum of squares of part sizes (basically 2*edges in complement of corresponding complete multipartite graph)
def sum_sq (t : ℕ) (P: ℕ → ℕ): ℕ := ∑i in range(t+1),(P i)^2

-- inevitable mod (t+1) calculation related to sizes of parts in balanced partition
lemma mod_tplus1 {a b c d t: ℕ} (hc: c ≤ t) (hd:d ≤ t) (ht: (t+1)*a + c = (t+1)*b+d) :
 (a = b) ∧ (c = d):=
begin
  have hc':c<t+1:=by linarith [hc], have hd':d<t+1:=by linarith [hd],
  have mc: c%(t+1)=c:=mod_eq_of_lt hc',have md: d%(t+1)=d:=mod_eq_of_lt hd',
  rw [add_comm,add_comm _ d] at ht,
  have hmtl:(c+(t+1)*a)%(t+1)=c%(t+1):=add_mul_mod_self_left c (t+1) a,
  have hmtr:(d+(t+1)*b)%(t+1)=d%(t+1):=add_mul_mod_self_left d (t+1) b,
  rw mc at hmtl, rw md at hmtr,rw ht at hmtl,rw hmtl at hmtr,
  refine ⟨_,hmtr⟩, rw hmtr at ht,simp only [add_right_inj, mul_eq_mul_left_iff, succ_ne_zero, or_false] at *,
  exact ht
end

---can this be used to simplify the previous lemma ?
lemma mod_tplus1' {t n:ℕ} : (t+1)*(n/(t+1))+n%(t+1)=n:=
begin
  exact div_add_mod n (t+1)
end

-- now lots of  results about balanced partitions
-- these are partitions whose parts differ by at most 1
-- a balanced (t+1) partition is one with almost equal parts
def balanced (t : ℕ) (P : ℕ → ℕ): Prop:= ∀ i ∈ range(t+1),∀ j∈ range(t+1), P i ≤ (P j) + 1

-- smallest part is well-defined
def min_p (t : ℕ) (P : ℕ → ℕ) : ℕ:= begin
  have nem: ((range(t+1)).image(λi , P i)).nonempty :=(nonempty.image_iff  _).mpr (nonempty_range_succ),
  exact min' ((range(t+1)).image(λi , P i)) nem
end

-- indices of small parts
def small_parts {t : ℕ} {P:ℕ → ℕ} (h: balanced t P) : finset ℕ:=(range(t+1)).filter (λi, P i = min_p t P)

-- .. and large parts
def large_parts {t : ℕ} {P:ℕ → ℕ} (h: balanced t P) : finset ℕ:=(range(t+1)).filter (λi, P i = min_p t P +1 )

-- there is a smallest part
lemma small_nonempty {t : ℕ} {P:ℕ → ℕ} (h: balanced t P) :(small_parts h).nonempty:=
begin
  rw small_parts, have nem: ((range(t+1)).image(λi , P i)).nonempty :=(nonempty.image_iff  _).mpr (nonempty_range_succ),
  set a:ℕ:=min' ((range(t+1)).image(λi , P i)) nem with ha,
  have ain:= min'_mem ((range(t+1)).image(λi , P i)) nem,
  rw [← ha, mem_image] at ain,
  obtain ⟨k,hk1,hk2⟩:=ain, use k, rw mem_filter,
  refine ⟨hk1,_⟩,rw ha at hk2,exact hk2
end

-- in a balanced partition all parts are small or large
lemma con_sum {t :ℕ} {P :ℕ → ℕ} (h: balanced t P): ∀i∈ range(t+1), P i = min_p t P ∨ P i = min_p t P +1:=
begin
  unfold balanced at h,
  have nem: ((range(t+1)).image(λi , P i)).nonempty :=(nonempty.image_iff  _).mpr (nonempty_range_succ),
  set a:ℕ:=min' ((range(t+1)).image(λi , P i)) nem with ha,
  set b:ℕ:=max' ((range(t+1)).image(λi , P i)) nem with hb,
  intros i hi,
  have ale: a ≤ P i:= min'_le ((range(t+1)).image(λi , P i)) (P i) (mem_image_of_mem (P ) hi),
  have leb:P i ≤ b:= le_max' ((range(t+1)).image(λi , P i)) (P i) (mem_image_of_mem (P ) hi),
  have ain:= min'_mem ((range(t+1)).image(λi , P i)) nem, rw ← ha at ain,
  have bin:= max'_mem ((range(t+1)).image(λi , P i)) nem, rw ← hb at bin,
  have blea: b≤ a+1,{ rw mem_image at *,
    obtain ⟨k,hk,hak⟩:=ain, obtain ⟨l,hl,hbl⟩:=bin,
    rw [← hak,←hbl], exact h l hl k hk,},
  have ple :=le_trans leb blea,
  by_contra, push_neg at h, cases h, have h1:=lt_of_le_of_ne ale h_left.symm,
  have h2:=lt_of_le_of_ne ple h_right, linarith
end

-- large parts are those that aren't small
lemma large_parts' {t : ℕ} {P:ℕ → ℕ} (h: balanced t P): large_parts h = (range(t+1)).filter (λi, ¬ P i = min_p t P):=
begin
  have :=con_sum h, unfold large_parts, ext ,rw [mem_filter,mem_filter],split,{
  intro h', refine ⟨h'.1,_⟩, intros h2, rw h2 at h', exact succ_ne_self (min_p t P) h'.2.symm},{
  intros h', refine ⟨h'.1,_⟩, specialize this a h'.1,  cases this,{ exfalso, exact h'.2 this}, {exact this},}
end

-- parts cannot be both small and large
lemma parts_disjoint {t : ℕ}  {P :ℕ → ℕ} (h: balanced t P) : disjoint (small_parts h) (large_parts h):=
begin
  convert disjoint_filter_filter_neg (range(t+1)) (λi, P i = min_p t P),
  exact large_parts' h
end

-- all parts are either small or large
lemma parts_union {t : ℕ}  {P :ℕ → ℕ} (h: balanced t P) : (range(t+1)) = (small_parts h) ∪ (large_parts h):=
begin
  have := con_sum h,
  ext,unfold small_parts, unfold large_parts, rw mem_union, split,{intro ha,
  rw [mem_filter,mem_filter],specialize this a ha, cases this, left ,exact ⟨ha,this⟩,right,exact ⟨ha,this⟩},{
  rw [mem_filter,mem_filter],intros h, cases h, {exact h_1.1}, {exact h_1.1},}
end

-- so the number of small parts + large parts = t+1
lemma parts_card_add {t : ℕ}  {P :ℕ → ℕ} (h: balanced t P) : (small_parts h).card + (large_parts h).card= t+1:=
begin
  rw [← card_range (t+1), parts_union h, card_disjoint_union (parts_disjoint h)]
end

-- not all parts are large since there is at least one small part
lemma large_parts_card {t : ℕ} {P:ℕ → ℕ} (h: balanced t P) : (large_parts h).card ≤ t:=
begin
  have spos:0 < (small_parts h).card:=card_pos.mpr (small_nonempty h),
  have := parts_card_add h, linarith
end

-- number of small parts is (t+1) - number of large
lemma small_parts_card  {t : ℕ} {P:ℕ → ℕ} (h: balanced t P) : (small_parts h).card =(t+1)-(large_parts h).card:=
begin
  rw ← parts_card_add h, rwa [add_tsub_cancel_right]
end

-- any sum of a function over a balanced partition is easy to compute
lemma bal_sum_f {t : ℕ} {P: ℕ → ℕ} (h: balanced t P) (f: ℕ → ℕ):∑ i in range(t+1), f (P i) =
(small_parts h).card * f(min_p t P) + (large_parts h).card * f(min_p t P+1) :=
begin
  rw [parts_union h, sum_union (parts_disjoint h)], congr,
  {rw [card_eq_sum_ones, sum_mul, one_mul], apply sum_congr,refl,rw small_parts,intros x, rw mem_filter,intro hx,rw hx.2},
  {rw [card_eq_sum_ones, sum_mul, one_mul], apply sum_congr,refl, rw large_parts,intros x, rw mem_filter,intro hx,rw hx.2}
end

-- simple equation for sum of parts
lemma bal_sum {t : ℕ} {P : ℕ → ℕ} (h: balanced t P) : psum t P = (small_parts h).card * (min_p t P) +
  (large_parts h).card * (min_p t P+1) := bal_sum_f h (λi,i)

-- alternative version of previous lemma
lemma bal_sum' {t : ℕ} {P : ℕ → ℕ} (h: balanced t P) : psum t P = (t+1)* (min_p t P) + (large_parts h).card :=
begin
  rw [bal_sum h, mul_add,mul_one,← add_assoc,← add_mul,parts_card_add h]
end

--now thinking about balanced (t+1)-partitions whose parts sum to n

-- a balanced partition that sums to n
def bal (t n : ℕ) (P:ℕ → ℕ) : Prop:= balanced t P ∧ psum t P = n

-- given a balanced partition of n into (t+1)-parts the small part is n/(t+1) and there are n%(t+1) large parts
lemma bal_sum_n {t n :ℕ} {P :ℕ→ ℕ} (hb: bal t n P) : min_p t P = n/(t+1) ∧ (large_parts hb.1).card = n%(t+1):=
begin
  unfold bal at hb, cases hb with hb1 hb2,
  rw [bal_sum' hb1, ← div_add_mod n (t+1)] at hb2, exact mod_tplus1 (large_parts_card hb1) (le_of_lt_succ (mod_lt n (succ_pos t))) hb2
end

-- sum of a function f over parts of a balanced partition  of n into (t+1) parts is:
lemma bal_sum_n_f {t n : ℕ} {P: ℕ → ℕ} (hb: bal t n P)  (f: ℕ → ℕ) :∑ i in range(t+1), f (P i) =
(t+1-n%(t+1)) * f(n/(t+1)) + (n%(t+1)) * f(n/(t+1)+1) :=
begin
  unfold bal at hb,
  obtain hf :=bal_sum_f hb.1, obtain ⟨mn,ln⟩:= bal_sum_n hb,
  specialize hf f,  rwa [mn, small_parts_card, ln] at hf
end

-- sum of squares of balanced partition is turan_numb'
lemma bal_turan_help {n t :ℕ} {P:ℕ→ ℕ} (hb: bal t n P):  sum_sq t P = turan_numb'  t n:=
begin
  rw turan_numb' , rw sum_sq, rw bal_sum_n_f hb (λi, i^2),
end

--so given two balanced (t+1) partitions summing to n their sum_sq  agree
lemma bal_turan_help' {n t :ℕ} {P Q:ℕ→ ℕ} (hp: bal t n P) (hq: bal t n Q):
 sum_sq t P = sum_sq t Q:=
begin
  rw bal_turan_help hp, rw bal_turan_help hq,
end

--hence sum_sq + 2* turan number is n^2
lemma bal_turan_bd {n t:ℕ} {P:ℕ→ ℕ} (hp: bal t n P)  : sum_sq t P + 2*turan_numb t n = n^2:=
begin
  rw bal_turan_help hp, exact tn_turan_numb'  t n
end

--- introduce the partitions we use to build complete multipartite graphs
-- this is a partition of A:finset α into t+1 parts each of which is a finset α
variables {α : Type*}[fintype α][nonempty α][decidable_eq α]
@[ext]
structure multi_part (α : Type*)[decidable_eq α][fintype α][nonempty α]:=
(t :ℕ) (P: ℕ → finset α) (A :finset α)
(uni: A = (range(t+1)).bUnion (λi , P i))
(disj: ∀i∈ range(t+1),∀j∈ range(t+1), i≠j → disjoint (P i) (P j))

--TO DO rewrite constructors for multi_part using this for "move" and set.pairwise_disjoint.insert for "insert"
lemma disjoint_insert_erase {A B : finset α} {v: α} (hv: v∈ A) (hd:disjoint A B) : disjoint (A.erase v) (insert v B):=
begin
  rw [disjoint_insert_right, mem_erase],
  refine ⟨_,disjoint_of_subset_left (erase_subset v A) hd⟩,
  {push_neg,intro h,exfalso, exact h rfl},
 end

def parts_t_A (t : ℕ) (A : finset α) (M : multi_part α) : Prop:= M.t=t ∧ M.A=A

-- given M with M.t+1 parts and partition sets P we have P' M is the corresponding sizes of parts
def P' (M: multi_part α) :ℕ → ℕ:= (λi, (M.P i).card)

--sum of squares of part sizes useful for counting edges in complete multitpartite graph on M
def sum_sq_c (M: multi_part α): ℕ:= ∑i in range(M.t+1), card(M.P i)^2

-- a partition is moveable if the part sizes are unbalanced
def moveable (M : multi_part α)  :Prop := ¬ balanced M.t (P' M)

--- ie. turan_partition means the sizes of parts is such that it is balanced
def turan_partition (M : multi_part α) :Prop :=∀i∈ range(M.t+1),∀j∈ range(M.t+1), (M.P i).card ≤ (M.P j).card +1
-- no vertex can be moved between parts of a turan_partition to increase the number of edges in the complete
-- (t+1)-partite graph defined by M
lemma turan_partition_iff_not_moveable (M : multi_part α) :turan_partition M ↔ ¬moveable M:=
begin
  unfold turan_partition, unfold moveable,push_neg,refl
end

-- if a partition is not a turan_partition then we can find two parts and a vertex to move from one to the other
lemma not_turan_partition_imp {M: multi_part α} (h: ¬turan_partition M): ∃i∈ range(M.t+1),∃j∈ range(M.t+1),∃v∈M.P i, j≠i ∧ (M.P j).card +1< (M.P i).card:=
begin
  rw [turan_partition_iff_not_moveable, not_not,  moveable,balanced,  P'] at h, push_neg at h,
  obtain ⟨i,hi,j,hj,hc⟩:=h, use [i, hi, j, hj],
  have ic: 0<(M.P i).card:= by linarith,
  rw card_pos at ic, obtain ⟨v,hv⟩:=ic,
  have cne: (M.P i).card≠(M.P j).card:= by linarith,
  refine ⟨v,hv,_,hc⟩, intro eq,rw eq at cne, exact cne rfl
end

---there is a partition
instance (α :Type*)[decidable_eq α][fintype α][nonempty α][decidable_eq α] : inhabited (multi_part α):=
{default:={ t:=0, P:= λ i , ∅, A:=∅, uni:=rfl,
disj:=λ i hi j hj ne, disjoint_empty_left ∅,}}

-- given any B:finset α and s:nat there is an partition of B into s+1 parts 1 x B and s x ∅
def default_M (B:finset α) (s:ℕ)  : multi_part α:={
  t:=s, P:= begin intro i, exact ite (i=0) (B) (∅), end, A:=B,
  uni:= begin ext, split,{intro ha,rw mem_bUnion,use 0, rw mem_range, exact ⟨zero_lt_succ s,ha⟩},
   {rw mem_bUnion,intro h, cases h with i h2,cases h2,split_ifs at h2_h,{exact h2_h},{exfalso, exact h2_h},},end,
  disj:= begin intros i hi j hj ne,split_ifs,{exfalso,rw h at ne,rw h_1 at ne, exact ne rfl},
    {exact disjoint_empty_right _},{exact disjoint_empty_left _},{exact disjoint_empty_left _},end,}

--TODO : this should use set.pairwise_disjoint.insert to be much simpler
-- we want to build a complete (t+1)-partite graph one part at a time
-- given a current partition into t+1 parts we can insert a new
-- disjoint set to the partition, increasing the number of parts by 1.
--- (We will need this to build the complete multipartite graph used for Furedi's stabilty result)
def insert (M : multi_part α)  {B : finset α} (h: disjoint M.A B): multi_part α :={
  t:=M.t+1,
  P:=begin intro i, exact ite (i≠M.t+1) (M.P i) (B), end,
  A:=B ∪ M.A,
  uni:= begin
    rw range_succ, rw [bUnion_insert],rw M.uni, split_ifs, {contradiction},{
    ext,rw [mem_union,mem_union,mem_bUnion,mem_bUnion],
    split, {intro h, cases h with hb hP, {left, exact hb},{right,
    obtain ⟨a1, H, H2⟩:=hP, use [a1,H],split_ifs, {exact H2},{
    push_neg at h_2, exfalso, rw h_2 at H, exact not_mem_range_self H},},},{
    intros h,cases h with hb hP,{left, exact hb},{right,
    obtain ⟨a1, H, H2⟩:=hP,split_ifs at H2, {use [a1,H, H2]},{
    push_neg at h_2, exfalso, rw h_2 at H, exact not_mem_range_self H},},},},
  end,
  disj:= begin
    intros i hi j hj iltj, split_ifs,{ refine M.disj i _ j _ iltj,
    {exact mem_range.mpr (lt_of_le_of_ne (mem_range_succ_iff.mp hi) h_1)},
    {exact mem_range.mpr (lt_of_le_of_ne (mem_range_succ_iff.mp hj) h_2)}},
    {{rw [M.uni, disjoint_bUnion_left] at h,
    apply h i (mem_range.mpr (lt_of_le_of_ne (mem_range_succ_iff.mp hi) h_1))},},
    {{rw [M.uni, disjoint_bUnion_left] at h, rw disjoint.comm,
    apply h j (mem_range.mpr (lt_of_le_of_ne (mem_range_succ_iff.mp hj) h_2))},},
    {{push_neg at h_1,push_neg at h_2, rw ← h_2 at h_1, exfalso, exact iltj h_1},},
  end,}
--

--- after inserting B the vertex set is the union of new and old
lemma insert_AB (M: multi_part α) {B :finset α} (h: disjoint M.A B):
(insert M h).A = M.A ∪ B:=union_comm _ _

-- number of parts has increased by 1 (so now have (t+2) parts rather than (t+1))
lemma insert_t (M: multi_part α) {B :finset α} (h: disjoint M.A B):(insert M h).t =M.t+1:=rfl

--the parts are the same except the last which is the new set.
lemma insert_P (M: multi_part α) {B :finset α} (h: disjoint M.A B) :∀i, (insert M h).P i =
 ite (i≠ M.t+1) (M.P i) (B) :=λi, rfl

--all vertices in the new part are in the last part of the new partition
lemma insert_P' (M: multi_part α) {B :finset α} (h: disjoint M.A B) : ∀v∈B, v∈ (insert M h).P (M.t+1):=
begin
  intros v hv, rw insert_P,split_ifs,{exfalso, exact h_1 rfl}, {exact hv}
end

--conversely if v is in the last part of the new partition then it is from the inserted part.
lemma insert_C (M: multi_part α) {B :finset α} (h: disjoint M.A B){v:α} : v∈ (insert M h).P (M.t+1) → v∈ B:=
begin
  intro h1, rw insert_P at h1,split_ifs at h1,{exfalso, exact h_1 rfl}, {exact h1}
end

-- there is always a (s+1)-partition of B for any B:finset α and s:ℕ
lemma exists_mpartition (B: finset α) (s:ℕ): ∃ M:multi_part α, M.A=B ∧ M.t=s:=⟨default_M B s,rfl,rfl⟩

---M.disj is the same as "pairwise_disjoint" but without any coercion to set for range(t+1)
lemma pair_disjoint (M : multi_part α) : ((range(M.t+1):set ℕ)).pairwise_disjoint M.P:=M.disj

-- member of a part implies member of union
lemma mem_part{M:multi_part α} {v :α} {i :ℕ}: i∈range(M.t+1) → v ∈ M.P i → v ∈ M.A :=
begin
  intros hi hv,rw M.uni,rw mem_bUnion, exact ⟨i,hi,hv⟩
end

-- every vertex in M.A belongs to a part
lemma inv_part {M:multi_part α} {v :α} (hA: v∈M.A): ∃ i∈ range(M.t+1), v ∈ M.P i:=
begin
  rw [M.uni,mem_bUnion] at hA, exact hA
end

-- M.A is the union of its parts
lemma bUnion_parts (M:multi_part α) :M.A=finset.bUnion (range(M.t+1)) (λi,(M.P i)):=
begin
  ext,rw mem_bUnion, split,{intros hA, use inv_part hA},
  {intro hA, obtain ⟨i,hi,hi2⟩:=hA,exact mem_part hi hi2}
end

-- so (by disj) card of M.A is the sum of sizes of parts
lemma card_uni (M:multi_part α) :(M.A).card = ∑ i in range(M.t+1), (M.P i).card:=
begin
  rw bUnion_parts M, rw card_bUnion, intros x hx y hy ne, exact M.disj x hx y hy ne
end

-- Any turan partition with M.t and M.A is bal M.t |M.A| ((M.P i).card)
lemma turan_bal {M : multi_part α} (hM: turan_partition M) : bal M.t (M.A.card) (P' M):=
begin
  rw turan_partition_iff_not_moveable at hM,unfold moveable at hM,
  rw not_not at hM, rw card_uni, exact ⟨hM,rfl⟩,
end

-- if v belongs to P i and P j then i = j.
lemma uniq_part {M : multi_part α}{v :α} {i j : ℕ} : i ∈ range(M.t+1)→ j ∈ range(M.t+1) → v ∈ M.P i → v ∈ M.P j → i = j:=
begin
  intros hi hj hiv hjv, by_contra, have:=M.disj i hi j hj h, exact this (mem_inter.mpr ⟨hiv,hjv⟩)
end

-- if v belongs to P i and i ≠ j and is in range then v ∉ P j
lemma uniq_part' {M : multi_part α}{v :α} {i j : ℕ} : i ∈ range(M.t+1)→ j ∈ range(M.t+1) → i ≠ j → v ∈ M.P i → v ∉ M.P j:=
begin
  intros hi hj hiv ne, contrapose hiv,push_neg at hiv,rw not_ne_iff, exact uniq_part hi hj ne hiv
end

-- every part is contained in A
lemma sub_part {M:multi_part α} {i : ℕ} (hi: i ∈ range(M.t+1)) : M.P i ⊆ M.A :=
begin
  rw M.uni, intros x hx,  rw  mem_bUnion,  exact ⟨i,hi,hx⟩
end

-- if there are two different parts then the sum of their sizes is at most the size of the whole
-- could make a version for any number of parts ≥ 2 but don't need it,
lemma two_parts {M: multi_part α} {i j : ℕ} (hi: i ∈ range(M.t+1))  (hj: j ∈ range(M.t+1)) (hne: i≠ j) : (M.P i).card + (M.P j).card ≤ M.A.card:=
begin
  rw card_uni, rw ← sum_erase_add (range(M.t+1)) _ hj, apply nat.add_le_add_right,
  rw ← sum_erase_add ((range(M.t+1)).erase j) _ (mem_erase_of_ne_of_mem hne hi),
  nth_rewrite 0 ← zero_add (M.P i).card, apply nat.add_le_add_right,
  simp only [zero_le]
end

--A is the union of each part and the sdiff
lemma sdiff_part {M:multi_part α} {i : ℕ} (hi: i ∈ range(M.t+1)) : M.A = M.A\(M.P i)∪M.P i :=
begin
  have:= sub_part hi,
  rwa [sdiff_union_self_eq_union, left_eq_union_iff_subset] at *,
end

-- each part is disjoint from its sdiff with the whole
lemma disjoint_part {M:multi_part α} {i : ℕ} : disjoint ((M.A)\(M.P i)) (M.P i) := sdiff_disjoint

-- size of uni = sum of rest and part
lemma card_part_uni {M:multi_part α} {i : ℕ} (hi: i ∈ range(M.t+1)):  M.A.card= (M.A\(M.P i)).card + (M.P i).card:=
begin
  nth_rewrite 0 sdiff_part hi,
  apply card_disjoint_union sdiff_disjoint
end

--  We can create a new partition by moving v ∈ M.P i from P i to P j.
-- We only want to do this if this increases the number of edges in the complete multipartite graph.
--  Any non-Turan partition contains a vertex that can be moved to increase
--  the number of edges in corresponding graph
-- TODO: figure out why "(M.P j).insert v" caused an error (so used (M.P j)∪ {v} instead)
--  but it didn't complain about "(M.P i).erase v"
--- Error message :'insert' is not a valid "field" because environment does not contain
-- 'finset.insert' M.P j which has type finset α
--- This is due to the "insert" defined for multi_part α above that clashes, and somehow finset.insert doesn't work
def move (M : multi_part α) {v : α} {i j: ℕ} (hvi: i∈ range(M.t+1) ∧ v∈ M.P i) (hj : j∈range(M.t+1) ∧ j≠i) : multi_part α :={
  t:=M.t,
  P:= begin intros k, exact ite (k ≠ i ∧ k ≠ j) (M.P k) (ite (k = i) ((M.P i).erase v) ((M.P j) ∪ {v})),end,
  A:=M.A,
  uni:=begin
    rw M.uni,ext,split, {rw [mem_bUnion,mem_bUnion],intros h,simp only [*, mem_range, ne.def, exists_prop] at *,
    by_cases hav: a=v,{
      refine ⟨j,hj.1,_⟩,rw ← hav at *, split_ifs,{exfalso, exact h_1.2 rfl},{exfalso, push_neg at h_1,exact hj.2 h_2},
      {refine mem_union_right _ (mem_singleton_self a)}, },
      {obtain ⟨k,hk1,hk2⟩:=h,
      refine ⟨k,hk1,_⟩, split_ifs, {exact hk2}, {refine mem_erase.mpr _,rw h_1 at hk2, exact ⟨hav,hk2⟩},
      {push_neg at h, rw (h h_1) at hk2, exact mem_union_left _ hk2},},},
    {rw [mem_bUnion,mem_bUnion],intros h,simp only [*, mem_range, ne.def, exists_prop] at *,
    by_cases hav: a=v,{
      rw ← hav at hvi, exact ⟨ i,hvi⟩},
      {obtain ⟨k,hk1,hk2⟩:=h, split_ifs at hk2, {exact ⟨k,hk1,hk2⟩}, {exact ⟨i,hvi.1,(erase_subset v (M.P i)) hk2⟩},
      {refine ⟨j,hj.1,_⟩, rw mem_union at hk2, cases hk2, {exact hk2},{exfalso, exact hav (mem_singleton.mp hk2)},},},}, end,
  disj:=begin
    intros a ha b hb ne,split_ifs, {exact M.disj a ha b hb ne},
    {have:=M.disj a ha i hvi.1 h.1, apply disjoint_of_subset_right _ this, exact erase_subset _ _},
    {simp only [disjoint_union_right, disjoint_singleton_right], refine ⟨M.disj a ha j hj.1 h.2,_⟩,
    intro hv, exact h.1 (uniq_part ha hvi.1 hv hvi.2)},
    {have:=M.disj i hvi.1 b hb  h_2.1.symm,apply disjoint_of_subset_left _ this, exact erase_subset _ _},
    {exfalso, push_neg at h, push_neg at h_2,rw [h_1,h_3] at ne, exact ne rfl},
    {simp only [disjoint_union_right, disjoint_singleton_right, mem_erase, _root_.ne.def, eq_self_iff_true, not_true, false_and,
    not_false_iff, and_true],
    have:=M.disj i hvi.1 j hj.1 hj.2.symm, apply disjoint_of_subset_left _ this, exact erase_subset _ _},
    {simp only [disjoint_union_left, disjoint_singleton_right],
    refine ⟨M.disj j hj.1 b hb h_2.2.symm,_⟩, rw disjoint_singleton_left,
    intro hb2, have:= uniq_part hb hvi.1 hb2 hvi.2 , exact h_2.1 this},
    {simp only [disjoint_union_left, disjoint_singleton_left, mem_erase, _root_.ne.def, eq_self_iff_true],
    simp only [not_true, false_and,not_false_iff, and_true],
    have:=M.disj j hj.1  i hvi.1 hj.2, apply disjoint_of_subset_right _ this, exact erase_subset _ _},
    {exfalso, push_neg at h_2,push_neg at h, have bj:= h_2 h_3, have aj:= h h_1,rw aj at ne, rw bj at ne, exact ne rfl},
end,}

-- new whole is same as old
lemma move_A {M : multi_part α} {v : α} {i j: ℕ} (hvi: i∈ range(M.t+1) ∧ v∈ M.P i) (hj : j∈range(M.t+1) ∧ j≠i) :(move M hvi hj).A=M.A:=
rfl

-- the moved partition still has t+1 parts
lemma move_t {M : multi_part α} {v : α} {i j: ℕ} (hvi: i∈ range(M.t+1) ∧ v∈ M.P i) (hj : j∈range(M.t+1) ∧ j≠i) :(move M hvi hj).t=M.t:=
 rfl

-- the moved parts are the same except for P i and P j which have lost/gained v
lemma move_P {M : multi_part α} {v : α} {i j k: ℕ} (hvi: i∈ range(M.t+1) ∧ v∈ M.P i) (hj : j∈range(M.t+1) ∧ j≠i) : k∈ range(M.t+1) → ((move M hvi hj).P k) = ite (k≠i ∧k≠j) (M.P k) (ite (k=i) ((M.P i).erase v) ((M.P j) ∪ {v})):=
begin
  intros k , refl,
end

-- the sizes of parts changed by moving v
lemma move_Pcard {M : multi_part α} {v : α} {i j k: ℕ} (hvi: i∈ range(M.t+1) ∧ v∈ M.P i) (hj : j∈range(M.t+1) ∧ j≠i) : k∈ range(M.t+1) → ((move M hvi hj).P k).card = ite (k≠i ∧k≠j) (M.P k).card (ite (k=i) ((M.P i).card -1) ((M.P j).card+1)):=
begin
  intros hk,rw move_P hvi hj hk,split_ifs,
  {refl},  {exact card_erase_of_mem hvi.2},{
  have jv:=uniq_part' hvi.1 hj.1 hj.2.symm hvi.2,
  rw ← disjoint_singleton_right at jv,
  apply card_disjoint_union jv}
end

--- the complement of the part with v has gained v
lemma sdiff_erase {v : α} {A B :finset α} (hB: B⊆A) (hv: v ∈ B) : A\(B.erase v)=(A\B) ∪ {v} :=
begin
  ext, split, {intro h, rw [mem_union,mem_sdiff] at *,rw mem_sdiff at h,rw mem_erase at h,
  push_neg at h, by_cases h': a=v,{right, exact mem_singleton.mpr h'},
  {left, exact ⟨h.1,(h.2 h')⟩}},
  {intros h,rw mem_sdiff,rw mem_erase,rw [mem_union,mem_sdiff] at h, push_neg,
  cases h,{exact ⟨h.1,λi,h.2⟩},{by_contra h',push_neg at h',
  have ha:=hB hv,
  have:=mem_singleton.mp h, rw ← this at ha,
  have h2:=h' ha, exact h2.1 this},}
end

--..hence its size  has increased
lemma card_sdiff_erase {v : α} {A B :finset α} (hB: B⊆A) (hv: v ∈ B) : (A\(B.erase v)).card=(A\B).card+1 :=
begin
  have hv2: v∉A\B, {rw mem_sdiff,push_neg,intro i, exact hv,},
  have:=disjoint_singleton_right.mpr hv2,
  rw sdiff_erase hB hv, exact card_disjoint_union this
end

--  complement of part without v has lost v
lemma sdiff_insert {v : α} {A B :finset α} (hB: B⊆A) (hv: v ∉ B) : A\(B ∪  {v})=(A\B).erase v:=
begin
  ext,split,{intro h,
  rw mem_erase, rw mem_sdiff at *,rw mem_union at h, push_neg at h,rw mem_singleton at h,  exact ⟨h.2.2,h.1,h.2.1⟩},
  {intro h,rw mem_erase at h, rw mem_sdiff, rw mem_union, push_neg,rw mem_singleton, rw mem_sdiff at h, exact ⟨h.2.1,h.2.2,h.1⟩}
end

--- .. hence its size has decreased
lemma card_sdiff_insert {v : α} {A B :finset α} (hB: B⊆A) (hvB: v ∉ B) (hvA: v ∈ A) : (A\(B ∪ {v})).card=(A\B).card -1:=
begin
  have : v∈A\B:=mem_sdiff.mpr ⟨hvA,hvB⟩,
  rw sdiff_insert hB hvB, exact card_erase_of_mem this
end

-- how have the sizes of the complements of parts changed by moving v
-- for parts other than i and j nothing has changed, for i and j we have calculated the changes above
lemma move_Pcard_sdiff {M : multi_part α} {v : α} {i j k: ℕ} (hvi: i∈ range(M.t+1) ∧ v∈ M.P i) (hj : j∈range(M.t+1) ∧ j≠i) :
 k∈ range(M.t+1) → (((move M hvi hj).A)\((move M hvi hj).P k)).card = ite (k≠i ∧k≠j) ((M.A)\(M.P k)).card (ite (k=i) (((M.A)\(M.P i)).card +1) (((M.A)\(M.P j)).card-1)):=
begin
  intros hk,rw move_P hvi hj hk,rw move_A hvi hj,split_ifs, {refl},
  {exact card_sdiff_erase (sub_part  hvi.1) hvi.2},
  {exact card_sdiff_insert (sub_part  hj.1) (uniq_part' hvi.1 hj.1 hj.2.symm hvi.2) (mem_part hvi.1 hvi.2)}
end

-- key increment inequality we need to show moving a vertex in a moveable partition is increases deg sum
-- (TODO: rewrite this now I'm not a complete novice..)
lemma move_change {a b n:ℕ} (hb: b+1<a) (hn: a+b ≤ n):  a*(n-a) +b*(n-b) < (a-1)*(n-a+1)+ (b+1)*(n-b-1):=
begin
  rw mul_add, rw add_mul,rw mul_one, rw one_mul,
  have ha:=tsub_add_cancel_of_le (by linarith [hb]: 1 ≤ a),
  have h2: a ≤ n-b:=le_tsub_of_add_le_right hn,
  have hnb:=tsub_add_cancel_of_le  (le_trans (by linarith [hb]: 1 ≤ a) h2),
  nth_rewrite 0 ← ha, nth_rewrite 0 ← hnb,
  rw [add_mul,mul_add,one_mul,mul_one ,add_assoc,add_assoc],
  apply nat.add_lt_add_left,
  rw [add_comm, ← add_assoc, add_comm (a-1), add_assoc, add_assoc],
  apply nat.add_lt_add_left,
  have ab: b< a-1:=by linarith [hb],
  have nba: (n-a)< (n-b-1),{
    have nba': (n-a)<(n-(b+1)),{
      have h3:=tsub_pos_of_lt hb,
      have h4: a ≤ n :=by linarith,
      have h6:=tsub_add_tsub_cancel (h4) (le_of_lt hb),
      linarith,}, rw add_comm at nba',
      rwa tsub_add_eq_tsub_tsub_swap at nba',},
  exact nat.add_lt_add ab nba
end

end turanpartition


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

import linear_algebra.basic

/-!
# Basics on bilinear maps

This file provides basics on bilinear maps. The most general form considered are maps that are
semilinear in both arguments. They are of type `M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P`, where `M` and `N`
are modules over `R` and `S` respectively, `P` is a module over both `R₂` and `S₂` with
commuting actions, and `ρ₁₂ : R →+* R₂` and `σ₁₂ : S →+* S₂`.

## Main declarations

* `linear_map.mk₂`: a constructor for bilinear maps,
  taking an unbundled function together with proof witnesses of bilinearity
* `linear_map.flip`: turns a bilinear map `M × N → P` into `N × M → P`
* `linear_map.lcomp` and `linear_map.llcomp`: composition of linear maps as a bilinear map
* `linear_map.compl₂`: composition of a bilinear map `M × N → P` with a linear map `Q → M`
* `linear_map.compr₂`: composition of a bilinear map `M × N → P` with a linear map `Q → N`
* `linear_map.lsmul`: scalar multiplication as a bilinear map `R × M → M`

## Tags

bilinear
-/

namespace linear_map

section semiring

-- the `ₗ` subscript variables are for special cases about linear (as opposed to semilinear) maps
variables {R : Type*} [semiring R] {S : Type*} [semiring S]
variables {R₂ : Type*} [semiring R₂] {S₂ : Type*} [semiring S₂]
variables {M : Type*} {N : Type*} {P : Type*}
variables {M₂ : Type*} {N₂ : Type*} {P₂ : Type*}
variables {Nₗ : Type*} {Pₗ : Type*}
variables {M' : Type*} {N' : Type*} {P' : Type*}

variables [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P]
variables [add_comm_monoid M₂] [add_comm_monoid N₂] [add_comm_monoid P₂]
variables [add_comm_monoid Nₗ] [add_comm_monoid Pₗ]
variables [add_comm_group M'] [add_comm_group N'] [add_comm_group P']
variables [module R M] [module S N] [module R₂ P] [module S₂ P]
variables [module R M₂] [module S N₂] [module R P₂] [module S₂ P₂]
variables [module R Pₗ] [module S Pₗ]
variables [module R M'] [module S N'] [module R₂ P'] [module S₂ P']
variables [smul_comm_class S₂ R₂ P] [smul_comm_class S R Pₗ] [smul_comm_class S₂ R₂ P']
variables [smul_comm_class S₂ R P₂]
variables {ρ₁₂ : R →+* R₂} {σ₁₂ : S →+* S₂}

variables (ρ₁₂ σ₁₂)
/-- Create a bilinear map from a function that is semilinear in each component.
See `mk₂'` and `mk₂` for the linear case. -/
def mk₂'ₛₗ (f : M → N → P)
  (H1 : ∀ m₁ m₂ n, f (m₁ + m₂) n = f m₁ n + f m₂ n)
  (H2 : ∀ (c:R) m n, f (c • m) n = (ρ₁₂ c) • f m n)
  (H3 : ∀ m n₁ n₂, f m (n₁ + n₂) = f m n₁ + f m n₂)
  (H4 : ∀ (c:S) m n, f m (c • n) = (σ₁₂ c) • f m n) : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P :=
{ to_fun := λ m, { to_fun := f m, map_add' := H3 m, map_smul' := λ c, H4 c m},
  map_add' := λ m₁ m₂, linear_map.ext $ H1 m₁ m₂,
  map_smul' := λ c m, linear_map.ext $ H2 c m }
variables {ρ₁₂ σ₁₂}

@[simp] theorem mk₂'ₛₗ_apply
  (f : M → N → P) {H1 H2 H3 H4} (m : M) (n : N) :
  (mk₂'ₛₗ ρ₁₂ σ₁₂ f H1 H2 H3 H4 : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) m n = f m n := rfl

variables (R S)
/-- Create a bilinear map from a function that is linear in each component.
See `mk₂` for the special case where both arguments come from modules over the same ring. -/
def mk₂' (f : M → N → Pₗ)
  (H1 : ∀ m₁ m₂ n, f (m₁ + m₂) n = f m₁ n + f m₂ n)
  (H2 : ∀ (c:R) m n, f (c • m) n = c • f m n)
  (H3 : ∀ m n₁ n₂, f m (n₁ + n₂) = f m n₁ + f m n₂)
  (H4 : ∀ (c:S) m n, f m (c • n) = c • f m n) : M →ₗ[R] N →ₗ[S] Pₗ :=
mk₂'ₛₗ (ring_hom.id R) (ring_hom.id S) f H1 H2 H3 H4
variables {R S}

@[simp] theorem mk₂'_apply
  (f : M → N → Pₗ) {H1 H2 H3 H4} (m : M) (n : N) :
  (mk₂' R S f H1 H2 H3 H4 : M →ₗ[R] N →ₗ[S] Pₗ) m n = f m n := rfl

theorem ext₂ {f g : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P}
  (H : ∀ m n, f m n = g m n) : f = g :=
linear_map.ext (λ m, linear_map.ext $ λ n, H m n)

section

local attribute [instance] smul_comm_class.symm

/-- Given a linear map from `M` to linear maps from `N` to `P`, i.e., a bilinear map from `M × N` to
`P`, change the order of variables and get a linear map from `N` to linear maps from `M` to `P`. -/
def flip (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) : N →ₛₗ[σ₁₂] M →ₛₗ[ρ₁₂] P :=
mk₂'ₛₗ σ₁₂ ρ₁₂ (λ n m, f m n)
  (λ n₁ n₂ m, (f m).map_add _ _)
  (λ c n m, (f m).map_smulₛₗ _ _)
  (λ n m₁ m₂, by rw f.map_add; refl)
  (λ c n m, by rw f.map_smulₛₗ; refl)

end

@[simp] theorem flip_apply (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (m : M) (n : N) : flip f n m = f m n := rfl

open_locale big_operators

variables {R}
theorem flip_inj {f g : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P} (H : flip f = flip g) : f = g :=
ext₂ $ λ m n, show flip f n m = flip g n m, by rw H

theorem map_zero₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (y) : f 0 y = 0 :=
(flip f y).map_zero

theorem map_neg₂ (f : M' →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P') (x y) : f (-x) y = -f x y :=
(flip f y).map_neg _

theorem map_sub₂ (f : M' →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P') (x y z) : f (x - y) z = f x z - f y z :=
(flip f z).map_sub _ _

theorem map_add₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (x₁ x₂ y) : f (x₁ + x₂) y = f x₁ y + f x₂ y :=
(flip f y).map_add _ _

theorem map_smul₂ (f : M₂ →ₗ[R] N₂ →ₛₗ[σ₁₂] P₂) (r : R) (x y) : f (r • x) y = r • f x y :=
(flip f y).map_smul _ _

theorem map_smulₛₗ₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (r : R) (x y) : f (r • x) y = (ρ₁₂ r) • f x y :=
(flip f y).map_smulₛₗ _ _

theorem map_sum₂ {ι : Type*} (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (t : finset ι) (x : ι → M) (y) :
  f (∑ i in t, x i) y = ∑ i in t, f (x i) y :=
(flip f y).map_sum

end semiring

section comm_semiring

variables {R : Type*} [comm_semiring R] {R₂ : Type*} [comm_semiring R₂]
variables {R₃ : Type*} [comm_semiring R₃] {R₄ : Type*} [comm_semiring R₄]
variables {M : Type*} {N : Type*} {P : Type*} {Q : Type*}
variables {Nₗ : Type*} {Pₗ : Type*} {Qₗ : Type*}

variables [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P] [add_comm_monoid Q]
variables [add_comm_monoid Nₗ] [add_comm_monoid Pₗ] [add_comm_monoid Qₗ]
variables [module R M] [module R₂ N] [module R₃ P] [module R₄ Q]
variables [module R Nₗ] [module R Pₗ] [module R Qₗ]
variables {σ₁₂ : R →+* R₂} {σ₂₃ : R₂ →+* R₃} {σ₁₃ : R →+* R₃}
variables {σ₄₂ : R₄ →+* R₂} {σ₄₃ : R₄ →+* R₃}
variables [ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃] [ring_hom_comp_triple σ₄₂ σ₂₃ σ₄₃]

variables (R)

/-- Create a bilinear map from a function that is linear in each component.

This is a shorthand for `mk₂'` for the common case when `R = S`. -/
def mk₂ (f : M → Nₗ → Pₗ)
  (H1 : ∀ m₁ m₂ n, f (m₁ + m₂) n = f m₁ n + f m₂ n)
  (H2 : ∀ (c:R) m n, f (c • m) n = c • f m n)
  (H3 : ∀ m n₁ n₂, f m (n₁ + n₂) = f m n₁ + f m n₂)
  (H4 : ∀ (c:R) m n, f m (c • n) = c • f m n) : M →ₗ[R] Nₗ →ₗ[R] Pₗ :=
mk₂' R R f H1 H2 H3 H4

@[simp] theorem mk₂_apply
  (f : M → Nₗ → Pₗ) {H1 H2 H3 H4} (m : M) (n : Nₗ) :
  (mk₂ R f H1 H2 H3 H4 : M →ₗ[R] Nₗ →ₗ[R] Pₗ) m n = f m n := rfl

variables (R M N P)
/-- Given a linear map from `M` to linear maps from `N` to `P`, i.e., a bilinear map `M → N → P`,
change the order of variables and get a linear map from `N` to linear maps from `M` to `P`. -/
def lflip : (M →ₛₗ[σ₁₃] N →ₛₗ[σ₂₃] P) →ₗ[R₃] N →ₛₗ[σ₂₃] M →ₛₗ[σ₁₃] P :=
{ to_fun := flip, map_add' := λ _ _, rfl, map_smul' := λ _ _, rfl }
variables {R M N P}

variables (f : M →ₛₗ[σ₁₃] N →ₛₗ[σ₂₃] P)

@[simp] theorem lflip_apply (m : M) (n : N) : lflip R M N P f n m = f m n := rfl

variables (R Pₗ)
/-- Composing a linear map `M → N` and a linear map `N → P` to form a linear map `M → P`. -/
def lcomp (f : M →ₗ[R] Nₗ) : (Nₗ →ₗ[R] Pₗ) →ₗ[R] M →ₗ[R] Pₗ :=
flip $ linear_map.comp (flip id) f

variables {R Pₗ}

@[simp] theorem lcomp_apply (f : M →ₗ[R] Nₗ) (g : Nₗ →ₗ[R] Pₗ) (x : M) :
  lcomp R Pₗ f g x = g (f x) := rfl

variables (P σ₂₃)
/-- Composing a semilinear map `M → N` and a semilinear map `N → P` to form a semilinear map
`M → P` is itself a linear map. -/
def lcompₛₗ (f : M →ₛₗ[σ₁₂] N) : (N →ₛₗ[σ₂₃] P) →ₗ[R₃] M →ₛₗ[σ₁₃] P :=
flip $ linear_map.comp (flip id) f
variables {P σ₂₃}

include σ₁₃
@[simp] theorem lcompₛₗ_apply (f : M →ₛₗ[σ₁₂] N) (g : N →ₛₗ[σ₂₃] P) (x : M) :
  lcompₛₗ P σ₂₃ f g x = g (f x) := rfl
omit σ₁₃

variables (R M Nₗ Pₗ)
/-- Composing a linear map `M → N` and a linear map `N → P` to form a linear map `M → P`. -/
def llcomp : (Nₗ →ₗ[R] Pₗ) →ₗ[R] (M →ₗ[R] Nₗ) →ₗ[R] M →ₗ[R] Pₗ :=
flip { to_fun := lcomp R Pₗ,
       map_add' := λ f f', ext₂ $ λ g x, g.map_add _ _,
       map_smul' := λ (c : R) f, ext₂ $ λ g x, g.map_smul _ _ }
variables {R M Nₗ Pₗ}

section
@[simp] theorem llcomp_apply (f : Nₗ →ₗ[R] Pₗ) (g : M →ₗ[R] Nₗ) (x : M) :
  llcomp R M Nₗ Pₗ f g x = f (g x) := rfl
end

/-- Composing a linear map `Q → N` and a bilinear map `M → N → P` to
form a bilinear map `M → Q → P`. -/
def compl₂ (g : Q →ₛₗ[σ₄₂] N) : M →ₛₗ[σ₁₃] Q →ₛₗ[σ₄₃] P := (lcompₛₗ _ _ g).comp f

include σ₄₃
@[simp]

/-- Composing a linear map `P → Q` and a bilinear map `M → N → P` to
form a bilinear map `M → N → Q`. -/
def compr₂ (f : M →ₗ[R] Nₗ →ₗ[R] Pₗ) (g : Pₗ →ₗ[R] Qₗ) : M →ₗ[R] Nₗ →ₗ[R] Qₗ :=
(llcomp R Nₗ Pₗ Qₗ g) ∘ₗ f

@[simp] theorem compr₂_apply (f : M →ₗ[R] Nₗ →ₗ[R] Pₗ) (g : Pₗ →ₗ[R] Qₗ) (m : M) (n : Nₗ) :
  f.compr₂ g m n = g (f m n) := rfl

variables (R M)
/-- Scalar multiplication as a bilinear map `R → M → M`. -/
def lsmul : R →ₗ[R] M →ₗ[R] M :=
mk₂ R (•) add_smul (λ _ _ _, mul_smul _ _ _) smul_add
(λ r s m, by simp only [smul_smul, smul_eq_mul, mul_comm])
variables {R M}

@[simp] theorem lsmul_apply (r : R) (m : M) : lsmul R M r m = r • m := rfl

end comm_semiring

section comm_ring

variables {R M : Type*} [comm_ring R] [add_comm_group M] [module R M]

lemma lsmul_injective [no_zero_smul_divisors R M] {x : R} (hx : x ≠ 0) :
  function.injective (lsmul R M x) :=
smul_right_injective _ hx

lemma ker_lsmul [no_zero_smul_divisors R M] {a : R} (ha : a ≠ 0) :
  (linear_map.lsmul R M a).ker = ⊥ :=
linear_map.ker_eq_bot_of_injective (linear_map.lsmul_injective ha)

end comm_ring

end linear_map