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

/-!
# Quaternions

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

## Main definitions

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

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

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

## Notation

The following notation is available with `open_locale quaternion`.

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

## Implementation notes

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

## Tags

quaternion
-/

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

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

namespace quaternion_algebra

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

/-- Multiplication is given by

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

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

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

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

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

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

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

section
variables (R c₁ c₂)

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

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

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

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

end

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open mul_opposite

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

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

end quaternion_algebra

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

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

namespace quaternion

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

export quaternion_algebra (re im_i im_j im_k)

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

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

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

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

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

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

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

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

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

@[simp] lemma mul_re :
  (a * b).re = a.re * b.re - a.im_i * b.im_i - a.im_j * b.im_j - a.im_k * b.im_k :=
(quaternion_algebra.has_mul_mul_re a b).trans $
  by simp only [one_mul, ← neg_mul_eq_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_eq_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_eq_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_eq_neg_mul, sub_eq_add_neg, neg_neg]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

alias commute_conj_conj ← commute.quaternion_conj

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

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

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

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

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

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

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

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

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

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

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

open mul_opposite

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

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

/-- Square of the norm. -/
def norm_sq : monoid_with_zero_hom ℍ[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, ← neg_mul_eq_mul_neg, sub_neg_eq_add,
  mul_re, conj_re, conj_im_i, conj_im_j, conj_im_k]

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

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

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

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

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

end quaternion

namespace quaternion

variables {R : Type*}

section linear_ordered_comm_ring

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

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

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

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

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

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

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

end linear_ordered_comm_ring

section field

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

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

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

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

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

end field

end quaternion


/-
Copyright (c) 2021 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import data.set_like.basic
import logic.equiv.fintype
import model_theory.semantics

/-!
# Definable Sets
This file defines what it means for a set over a first-order structure to be definable.

## Main Definitions
* `set.definable` is defined so that `A.definable L s` indicates that the
set `s` of a finite cartesian power of `M` is definable with parameters in `A`.
* `set.definable₁` is defined so that `A.definable₁ L s` indicates that
`(s : set M)` is definable with parameters in `A`.
* `set.definable₂` is defined so that `A.definable₂ L s` indicates that
`(s : set (M × M))` is definable with parameters in `A`.
* A `first_order.language.definable_set` is defined so that `L.definable_set A α` is the boolean
  algebra of subsets of `α → M` defined by formulas with parameters in `A`.

## Main Results
* `L.definable_set A α` forms a `boolean_algebra`
* `set.definable.image_comp` shows that definability is closed under projections in finite
  dimensions.

-/

universes u v w

namespace set

variables {M : Type w} (A : set M) (L : first_order.language.{u v}) [L.Structure M]
open_locale first_order
open first_order.language first_order.language.Structure

variables {α : Type*} {β : Type*}

/-- A subset of a finite Cartesian product of a structure is definable over a set `A` when
  membership in the set is given by a first-order formula with parameters from `A`. -/
def definable (s : set (α → M)) : Prop :=
∃ (φ : L[[A]].formula α), s = set_of φ.realize

variables {L} {A} {B : set M} {s : set (α → M)}

lemma definable.map_expansion {L' : first_order.language} [L'.Structure M] (h : A.definable L s)
  (φ : L →ᴸ L') [φ.is_expansion_on M] :
  A.definable L' s :=
begin
  obtain ⟨ψ, rfl⟩ := h,
  refine ⟨(φ.add_constants A).on_formula ψ, _⟩,
  ext x,
  simp only [mem_set_of_eq, Lhom.realize_on_formula],
end

lemma empty_definable_iff :
  (∅ : set M).definable L s ↔ ∃ (φ : L.formula α), s = set_of φ.realize :=
begin
  rw [definable, equiv.exists_congr_left (Lequiv.add_empty_constants L (∅ : set M)).on_formula],
  simp,
end

lemma definable_iff_empty_definable_with_params :
  A.definable L s ↔ (∅ : set M).definable (L[[A]]) s :=
empty_definable_iff.symm

lemma definable.mono (hAs : A.definable L s) (hAB : A ⊆ B) :
  B.definable L s :=
begin
  rw [definable_iff_empty_definable_with_params] at *,
  exact hAs.map_expansion (L.Lhom_with_constants_map (set.inclusion hAB)),
end

@[simp]
lemma definable_empty : A.definable L (∅ : set (α → M)) :=
⟨⊥, by {ext, simp} ⟩

@[simp]
lemma definable_univ : A.definable L (univ : set (α → M)) :=
⟨⊤, by {ext, simp} ⟩

@[simp]
lemma definable.inter {f g : set (α → M)} (hf : A.definable L f) (hg : A.definable L g) :
  A.definable L (f ∩ g) :=
begin
  rcases hf with ⟨φ, rfl⟩,
  rcases hg with ⟨θ, rfl⟩,
  refine ⟨φ ⊓ θ, _⟩,
  ext,
  simp,
end

@[simp]
lemma definable.union {f g : set (α → M)} (hf : A.definable L f) (hg : A.definable L g) :
  A.definable L (f ∪ g) :=
begin
  rcases hf with ⟨φ, hφ⟩,
  rcases hg with ⟨θ, hθ⟩,
  refine ⟨φ ⊔ θ, _⟩,
  ext,
  rw [hφ, hθ, mem_set_of_eq, formula.realize_sup, mem_union_eq, mem_set_of_eq,
    mem_set_of_eq],
end

lemma definable_finset_inf {ι : Type*} {f : Π (i : ι), set (α → M)}
  (hf : ∀ i, A.definable L (f i)) (s : finset ι) :
  A.definable L (s.inf f) :=
begin
  classical,
  refine finset.induction definable_univ (λ i s is h, _) s,
  rw finset.inf_insert,
  exact (hf i).inter h,
end

lemma definable_finset_sup {ι : Type*} {f : Π (i : ι), set (α → M)}
  (hf : ∀ i, A.definable L (f i)) (s : finset ι) :
  A.definable L (s.sup f) :=
begin
  classical,
  refine finset.induction definable_empty (λ i s is h, _) s,
  rw finset.sup_insert,
  exact (hf i).union h,
end

lemma definable_finset_bInter {ι : Type*} {f : Π (i : ι), set (α → M)}
  (hf : ∀ i, A.definable L (f i)) (s : finset ι) :
  A.definable L (⋂ i ∈ s, f i) :=
begin
  rw ← finset.inf_set_eq_bInter,
  exact definable_finset_inf hf s,
end

lemma definable_finset_bUnion {ι : Type*} {f : Π (i : ι), set (α → M)}
  (hf : ∀ i, A.definable L (f i)) (s : finset ι) :
  A.definable L (⋃ i ∈ s, f i) :=
begin
  rw ← finset.sup_set_eq_bUnion,
  exact definable_finset_sup hf s,
end

@[simp]
lemma definable.compl {s : set (α → M)} (hf : A.definable L s) :
  A.definable L sᶜ :=
begin
  rcases hf with ⟨φ, hφ⟩,
  refine ⟨φ.not, _⟩,
  rw hφ,
  refl,
end

@[simp]
lemma definable.sdiff {s t : set (α → M)} (hs : A.definable L s)
  (ht : A.definable L t) :
  A.definable L (s \ t) :=
hs.inter ht.compl

lemma definable.preimage_comp (f : α → β) {s : set (α → M)}
  (h : A.definable L s) :
  A.definable L ((λ g : β → M, g ∘ f) ⁻¹' s) :=
begin
  obtain ⟨φ, rfl⟩ := h,
  refine ⟨(φ.relabel f), _⟩,
  ext,
  simp only [set.preimage_set_of_eq, mem_set_of_eq, formula.realize_relabel],
end

lemma definable.image_comp_equiv {s : set (β → M)}
  (h : A.definable L s) (f : α ≃ β) :
  A.definable L ((λ g : β → M, g ∘ f) '' s) :=
begin
  refine (congr rfl _).mp (h.preimage_comp f.symm),
  rw image_eq_preimage_of_inverse,
  { intro i,
    ext b,
    simp only [function.comp_app, equiv.apply_symm_apply], },
  { intro i,
    ext a,
    simp }
end

lemma fin.coe_cast_add_zero {m : ℕ} : (fin.cast_add 0 : fin m → fin (m + 0)) = id :=
funext (λ _, fin.ext rfl)

/-- This lemma is only intended as a helper for `definable.image_comp. -/
lemma definable.image_comp_sum_inl_fin (m : ℕ) {s : set ((α ⊕ fin m) → M)}
  (h : A.definable L s) :
  A.definable L ((λ g : (α ⊕ fin m) → M, g ∘ sum.inl) '' s) :=
begin
  obtain ⟨φ, rfl⟩ := h,
  refine ⟨(bounded_formula.relabel id φ).exs, _⟩,
  ext x,
  simp only [set.mem_image, mem_set_of_eq, bounded_formula.realize_exs,
    bounded_formula.realize_relabel, function.comp.right_id, fin.coe_cast_add_zero],
  split,
  { rintro ⟨y, hy, rfl⟩,
    exact ⟨y ∘ sum.inr,
      (congr (congr rfl (sum.elim_comp_inl_inr y).symm) (funext fin_zero_elim)).mp hy⟩ },
  { rintro ⟨y, hy⟩,
    exact ⟨sum.elim x y, (congr rfl (funext fin_zero_elim)).mp hy, sum.elim_comp_inl _ _⟩, },
end

/-- Shows that definability is closed under finite projections. -/
lemma definable.image_comp_embedding {s : set (β → M)} (h : A.definable L s)
  (f : α ↪ β) [fintype β] :
  A.definable L ((λ g : β → M, g ∘ f) '' s) :=
begin
  classical,
  refine (congr rfl (ext (λ x, _))).mp (((h.image_comp_equiv
    (equiv.set.sum_compl (range f))).image_comp_equiv (equiv.sum_congr
    (equiv.of_injective f f.injective) (fintype.equiv_fin _).symm)).image_comp_sum_inl_fin _),
  simp only [mem_preimage, mem_image, exists_exists_and_eq_and],
  refine exists_congr (λ y, and_congr_right (λ ys, eq.congr_left (funext (λ a, _)))),
  simp,
end

/-- Shows that definability is closed under finite projections. -/
lemma definable.image_comp {s : set (β → M)} (h : A.definable L s)
  (f : α → β) [fintype α] [fintype β] :
  A.definable L ((λ g : β → M, g ∘ f) '' s) :=
begin
  classical,
  have h := (((h.image_comp_equiv (equiv.set.sum_compl (range f))).image_comp_equiv
    (equiv.sum_congr (_root_.equiv.refl _)
    (fintype.equiv_fin _).symm)).image_comp_sum_inl_fin _).preimage_comp (range_splitting f),
  have h' : A.definable L ({ x : α → M |
    ∀ a, x a = x (range_splitting f (range_factorization f a))}),
  { have h' : ∀ a, A.definable L {x : α → M | x a =
      x (range_splitting f (range_factorization f a))},
    { refine λ a, ⟨(var a).equal (var (range_splitting f (range_factorization f a))), ext _⟩,
      simp, },
    refine (congr rfl (ext _)).mp (definable_finset_bInter h' finset.univ),
    simp },
  refine (congr rfl (ext (λ x, _))).mp (h.inter h'),
  simp only [equiv.coe_trans, mem_inter_eq, mem_preimage, mem_image,
    exists_exists_and_eq_and, mem_set_of_eq],
  split,
  { rintro ⟨⟨y, ys, hy⟩, hx⟩,
    refine ⟨y, ys, _⟩,
    ext a,
    rw [hx a, ← function.comp_apply x, ← hy],
    simp, },
  { rintro ⟨y, ys, rfl⟩,
    refine ⟨⟨y, ys, _⟩, λ a, _⟩,
    { ext,
      simp [set.apply_range_splitting f] },
    { rw [function.comp_apply, function.comp_apply, apply_range_splitting f,
        range_factorization_coe], }}
end

variables (L) {M} (A)

/-- A 1-dimensional version of `definable`, for `set M`. -/
def definable₁ (s : set M) : Prop := A.definable L { x : fin 1 → M | x 0 ∈ s }

/-- A 2-dimensional version of `definable`, for `set (M × M)`. -/
def definable₂ (s : set (M × M)) : Prop := A.definable L { x : fin 2 → M | (x 0, x 1) ∈ s }

end set

namespace first_order
namespace language
open set

variables (L : first_order.language.{u v}) {M : Type w} [L.Structure M] (A : set M) (α : Type*)

/-- Definable sets are subsets of finite Cartesian products of a structure such that membership is
  given by a first-order formula. -/
def definable_set := { s : set (α → M) // A.definable L s}

namespace definable_set
variables {L} {A} {α}

instance : has_top (L.definable_set A α) := ⟨⟨⊤, definable_univ⟩⟩

instance : has_bot (L.definable_set A α) := ⟨⟨⊥, definable_empty⟩⟩

instance : inhabited (L.definable_set A α) := ⟨⊥⟩

instance : set_like (L.definable_set A α) (α → M) :=
{ coe := subtype.val,
  coe_injective' := subtype.val_injective }

@[simp]
lemma mem_top {x : α → M} : x ∈ (⊤ : L.definable_set A α) := mem_univ x

@[simp]
lemma coe_top : ((⊤ : L.definable_set A α) : set (α → M)) = ⊤ := rfl

@[simp]
lemma not_mem_bot {x : α → M} : ¬ x ∈ (⊥ : L.definable_set A α) := not_mem_empty x

@[simp]
lemma coe_bot : ((⊥ : L.definable_set A α) : set (α → M)) = ⊥ := rfl

instance : lattice (L.definable_set A α) :=
subtype.lattice (λ _ _, definable.union) (λ _ _, definable.inter)

lemma le_iff {s t : L.definable_set A α} : s ≤ t ↔ (s : set (α → M)) ≤ (t : set (α → M)) := iff.rfl

@[simp]
lemma coe_sup {s t : L.definable_set A α} : ((s ⊔ t : L.definable_set A α) : set (α → M)) = s ∪ t :=
rfl

@[simp]

@[simp]
lemma coe_inf {s t : L.definable_set A α} : ((s ⊓ t : L.definable_set A α) : set (α → M)) = s ∩ t :=
rfl

@[simp]
lemma mem_inf {s t : L.definable_set A α} {x : α → M} : x ∈ s ⊓ t ↔ x ∈ s ∧ x ∈ t := iff.rfl

instance : bounded_order (L.definable_set A α) :=
{ bot_le := λ s x hx, false.elim hx,
  le_top := λ s x hx, mem_univ x,
  .. definable_set.has_top,
  .. definable_set.has_bot }

instance : distrib_lattice (L.definable_set A α) :=
{ le_sup_inf := begin
    intros s t u x,
    simp only [and_imp, mem_inter_eq, set_like.mem_coe, coe_sup, coe_inf, mem_union_eq,
      subtype.val_eq_coe],
    tauto,
  end,
  .. definable_set.lattice }

/-- The complement of a definable set is also definable. -/
@[reducible] instance : has_compl (L.definable_set A α) :=
⟨λ ⟨s, hs⟩, ⟨sᶜ, hs.compl⟩⟩

@[simp]
lemma mem_compl {s : L.definable_set A α} {x : α → M} : x ∈ sᶜ ↔ ¬ x ∈ s :=
begin
  cases s with s hs,
  refl,
end

@[simp]
lemma coe_compl {s : L.definable_set A α} : ((sᶜ : L.definable_set A α) : set (α → M)) = sᶜ :=
begin
  ext,
  simp,
end

instance : boolean_algebra (L.definable_set A α) :=
{ sdiff := λ s t, s ⊓ tᶜ,
  sdiff_eq := λ s t, rfl,
  sup_inf_sdiff := λ ⟨s, hs⟩ ⟨t, ht⟩,
  begin
    apply le_antisymm;
    simp [le_iff],
  end,
  inf_inf_sdiff := λ ⟨s, hs⟩ ⟨t, ht⟩, begin
    rw eq_bot_iff,
    simp only [coe_compl, le_iff, coe_bot, coe_inf, subtype.coe_mk,
      le_eq_subset],
    intros x hx,
    simp only [set.mem_inter_eq, mem_compl_eq] at hx,
    tauto,
  end,
  inf_compl_le_bot := λ ⟨s, hs⟩, by simp [le_iff],
  top_le_sup_compl := λ ⟨s, hs⟩, by simp [le_iff],
  .. definable_set.has_compl,
  .. definable_set.bounded_order,
  .. definable_set.distrib_lattice }

end definable_set
end language
end first_order


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

! This file was ported from Lean 3 source module analysis.special_functions.trigonometric.bounds
! leanprover-community/mathlib commit 9df54c1b9dd5b6d6ed1472bfb6c10819aa95b5d7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.SpecialFunctions.Trigonometric.Basic
import Mathbin.Analysis.SpecialFunctions.Trigonometric.ArctanDeriv

/-!
# Polynomial bounds for trigonometric functions

## Main statements

This file contains upper and lower bounds for real trigonometric functions in terms
of polynomials. See `trigonometric.basic` for more elementary inequalities, establishing
the ranges of these functions, and their monotonicity in suitable intervals.

Here we prove the following:

* `sin_lt`: for `x > 0` we have `sin x < x`.
* `sin_gt_sub_cube`: For `0 < x ≤ 1` we have `x - x ^ 3 / 4 < sin x`.
* `lt_tan`: for `0 < x < π/2` we have `x < tan x`.
* `cos_le_one_div_sqrt_sq_add_one` and `cos_lt_one_div_sqrt_sq_add_one`: for
  `-3 * π / 2 ≤ x ≤ 3 * π / 2`, we have `cos x ≤ 1 / sqrt (x ^ 2 + 1)`, with strict inequality if
  `x ≠ 0`. (This bound is not quite optimal, but not far off)

## Tags

sin, cos, tan, angle
-/

noncomputable section

open Set

namespace Real

open Real

/-- For 0 < x, we have sin x < x. -/
theorem sin_lt {x : ℝ} (h : 0 < x) : sin x < x :=
  by
  cases' lt_or_le 1 x with h' h'
  · exact (sin_le_one x).trans_lt h'
  have hx : |x| = x := abs_of_nonneg h.le
  have := le_of_abs_le (sin_bound <| show |x| ≤ 1 by rwa [hx])
  rw [sub_le_iff_le_add', hx] at this
  apply this.trans_lt
  rw [sub_add, sub_lt_self_iff, sub_pos, div_eq_mul_inv (x ^ 3)]
  refine' mul_lt_mul' _ (by norm_num) (by norm_num) (pow_pos h 3)
  apply pow_le_pow_of_le_one h.le h'
  norm_num
#align real.sin_lt Real.sin_lt

/-- For 0 < x ≤ 1 we have x - x ^ 3 / 4 < sin x.

This is also true for x > 1, but it's nontrivial for x just above 1. This inequality is not
tight; the tighter inequality is sin x > x - x ^ 3 / 6 for all x > 0, but this inequality has
a simpler proof. -/
theorem sin_gt_sub_cube {x : ℝ} (h : 0 < x) (h' : x ≤ 1) : x - x ^ 3 / 4 < sin x :=
  by
  have hx : |x| = x := abs_of_nonneg h.le
  have := neg_le_of_abs_le (sin_bound <| show |x| ≤ 1 by rwa [hx])
  rw [le_sub_iff_add_le, hx] at this
  refine' lt_of_lt_of_le _ this
  have : x ^ 3 / 4 - x ^ 3 / 6 = x ^ 3 * 12⁻¹ := by norm_num [div_eq_mul_inv, ← mul_sub]
  rw [add_comm, sub_add, sub_neg_eq_add, sub_lt_sub_iff_left, ← lt_sub_iff_add_lt', this]
  refine' mul_lt_mul' _ (by norm_num) (by norm_num) (pow_pos h 3)
  apply pow_le_pow_of_le_one h.le h'
  norm_num
#align real.sin_gt_sub_cube Real.sin_gt_sub_cube

/-- The derivative of `tan x - x` is `1/(cos x)^2 - 1` away from the zeroes of cos. -/
theorem deriv_tan_sub_id (x : ℝ) (h : cos x ≠ 0) :
    deriv (fun y : ℝ => tan y - y) x = 1 / cos x ^ 2 - 1 :=
  HasDerivAt.deriv <| by simpa using (has_deriv_at_tan h).add (hasDerivAt_id x).neg
#align real.deriv_tan_sub_id Real.deriv_tan_sub_id

/-- For all `0 < x < π/2` we have `x < tan x`.

This is proved by checking that the function `tan x - x` vanishes
at zero and has non-negative derivative. -/
theorem lt_tan {x : ℝ} (h1 : 0 < x) (h2 : x < π / 2) : x < tan x :=
  by
  let U := Ico 0 (π / 2)
  have intU : interior U = Ioo 0 (π / 2) := interior_Ico
  have half_pi_pos : 0 < π / 2 := div_pos pi_pos two_pos
  have cos_pos : ∀ {y : ℝ}, y ∈ U → 0 < cos y :=
    by
    intro y hy
    exact cos_pos_of_mem_Ioo (Ico_subset_Ioo_left (neg_lt_zero.mpr half_pi_pos) hy)
  have sin_pos : ∀ {y : ℝ}, y ∈ interior U → 0 < sin y :=
    by
    intro y hy
    rw [intU] at hy
    exact sin_pos_of_mem_Ioo (Ioo_subset_Ioo_right (div_le_self pi_pos.le one_le_two) hy)
  have tan_cts_U : ContinuousOn tan U :=
    by
    apply ContinuousOn.mono continuous_on_tan
    intro z hz
    simp only [mem_set_of_eq]
    exact (cos_pos hz).ne'
  have tan_minus_id_cts : ContinuousOn (fun y : ℝ => tan y - y) U := tan_cts_U.sub continuousOn_id
  have deriv_pos : ∀ y : ℝ, y ∈ interior U → 0 < deriv (fun y' : ℝ => tan y' - y') y :=
    by
    intro y hy
    have := cos_pos (interior_subset hy)
    simp only [deriv_tan_sub_id y this.ne', one_div, gt_iff_lt, sub_pos]
    have bd2 : cos y ^ 2 < 1 := by
      apply lt_of_le_of_ne y.cos_sq_le_one
      rw [cos_sq']
      simpa only [Ne.def, sub_eq_self, pow_eq_zero_iff, Nat.succ_pos'] using (sin_pos hy).ne'
    rwa [lt_inv, inv_one]
    · exact zero_lt_one
    simpa only [sq, mul_self_pos] using this.ne'
  have mono := Convex.strictMonoOn_of_deriv_pos (convex_Ico 0 (π / 2)) tan_minus_id_cts deriv_pos
  have zero_in_U : (0 : ℝ) ∈ U := by rwa [left_mem_Ico]
  have x_in_U : x ∈ U := ⟨h1.le, h2⟩
  simpa only [tan_zero, sub_zero, sub_pos] using mono zero_in_U x_in_U h1
#align real.lt_tan Real.lt_tan

theorem le_tan {x : ℝ} (h1 : 0 ≤ x) (h2 : x < π / 2) : x ≤ tan x :=
  by
  rcases eq_or_lt_of_le h1 with (rfl | h1')
  · rw [tan_zero]
  · exact le_of_lt (lt_tan h1' h2)
#align real.le_tan Real.le_tan

theorem cos_lt_one_div_sqrt_sq_add_one {x : ℝ} (hx1 : -(3 * π / 2) ≤ x) (hx2 : x ≤ 3 * π / 2)
    (hx3 : x ≠ 0) : cos x < 1 / sqrt (x ^ 2 + 1) :=
  by
  suffices ∀ {y : ℝ} (hy1 : 0 < y) (hy2 : y ≤ 3 * π / 2), cos y < 1 / sqrt (y ^ 2 + 1)
    by
    rcases lt_or_lt_iff_ne.mpr hx3.symm with ⟨⟩
    · exact this h hx2
    · convert this (by linarith : 0 < -x) (by linarith) using 1
      · rw [cos_neg]
      · rw [neg_sq]
  intro y hy1 hy2
  have hy3 : 0 < y ^ 2 + 1 := by linarith [sq_nonneg y]
  rcases lt_or_le y (π / 2) with (hy2' | hy1')
  · -- Main case : `0 < y < π / 2`
    have hy4 : 0 < cos y := cos_pos_of_mem_Ioo ⟨by linarith, hy2'⟩
    rw [← abs_of_nonneg (cos_nonneg_of_mem_Icc ⟨by linarith, hy2'.le⟩), ←
      abs_of_nonneg (one_div_nonneg.mpr (sqrt_nonneg _)), ← sq_lt_sq, div_pow, one_pow,
      sq_sqrt hy3.le, lt_one_div (pow_pos hy4 _) hy3, ← inv_one_add_tan_sq hy4.ne', one_div,
      inv_inv, add_comm, add_lt_add_iff_left, sq_lt_sq, abs_of_pos hy1,
      abs_of_nonneg (tan_nonneg_of_nonneg_of_le_pi_div_two hy1.le hy2'.le)]
    exact Real.lt_tan hy1 hy2'
  · -- Easy case : `π / 2 ≤ y ≤ 3 * π / 2`
    refine' lt_of_le_of_lt _ (one_div_pos.mpr <| sqrt_pos_of_pos hy3)
    exact cos_nonpos_of_pi_div_two_le_of_le hy1' (by linarith [pi_pos])
#align real.cos_lt_one_div_sqrt_sq_add_one Real.cos_lt_one_div_sqrt_sq_add_one

theorem cos_le_one_div_sqrt_sq_add_one {x : ℝ} (hx1 : -(3 * π / 2) ≤ x) (hx2 : x ≤ 3 * π / 2) :
    cos x ≤ 1 / sqrt (x ^ 2 + 1) :=
  by
  rcases eq_or_ne x 0 with (rfl | hx3)
  · simp
  · exact (cos_lt_one_div_sqrt_sq_add_one hx1 hx2 hx3).le
#align real.cos_le_one_div_sqrt_sq_add_one Real.cos_le_one_div_sqrt_sq_add_one

end Real


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Abhimanyu Pallavi Sudhir, Jean Lo, Calle Sönne, Benjamin Davidson
-/
import analysis.special_functions.trigonometric.arctan
import analysis.special_functions.trigonometric.complex_deriv

/-!
# Derivatives of the `tan` and `arctan` functions.

Continuity and derivatives of the tangent and arctangent functions.
-/

noncomputable theory

namespace real

open set filter
open_locale topological_space real

lemma has_strict_deriv_at_tan {x : ℝ} (h : cos x ≠ 0) :
  has_strict_deriv_at tan (1 / (cos x)^2) x :=
by exact_mod_cast (complex.has_strict_deriv_at_tan (by exact_mod_cast h)).real_of_complex

lemma has_deriv_at_tan {x : ℝ} (h : cos x ≠ 0) :
  has_deriv_at tan (1 / (cos x)^2) x :=
by exact_mod_cast (complex.has_deriv_at_tan (by exact_mod_cast h)).real_of_complex

lemma tendsto_abs_tan_of_cos_eq_zero {x : ℝ} (hx : cos x = 0) :
  tendsto (λ x, abs (tan x)) (𝓝[≠] x) at_top :=
begin
  have hx : complex.cos x = 0, by exact_mod_cast hx,
  simp only [← complex.abs_of_real, complex.of_real_tan],
  refine (complex.tendsto_abs_tan_of_cos_eq_zero hx).comp _,
  refine tendsto.inf complex.continuous_of_real.continuous_at _,
  exact tendsto_principal_principal.2 (λ y, mt complex.of_real_inj.1)
end

lemma tendsto_abs_tan_at_top (k : ℤ) :
  tendsto (λ x, abs (tan x)) (𝓝[≠] ((2 * k + 1) * π / 2)) at_top :=
tendsto_abs_tan_of_cos_eq_zero $ cos_eq_zero_iff.2 ⟨k, rfl⟩

lemma differentiable_at_tan {x : ℝ} : differentiable_at ℝ tan x ↔ cos x ≠ 0 :=
⟨λ h, continuous_at_tan.1 h.continuous_at, λ h, (has_deriv_at_tan h).differentiable_at⟩

@[simp] lemma deriv_tan (x : ℝ) : deriv tan x = 1 / (cos x)^2 :=
if h : cos x = 0 then
  have ¬differentiable_at ℝ tan x := mt differentiable_at_tan.1 (not_not.2 h),
  by simp [deriv_zero_of_not_differentiable_at this, h, sq]
else (has_deriv_at_tan h).deriv

@[simp] lemma cont_diff_at_tan {n x} : cont_diff_at ℝ n tan x ↔ cos x ≠ 0 :=
⟨λ h, continuous_at_tan.1 h.continuous_at,
  λ h, (complex.cont_diff_at_tan.2 $ by exact_mod_cast h).real_of_complex⟩

lemma has_deriv_at_tan_of_mem_Ioo {x : ℝ} (h : x ∈ Ioo (-(π/2):ℝ) (π/2)) :
  has_deriv_at tan (1 / (cos x)^2) x :=
has_deriv_at_tan (cos_pos_of_mem_Ioo h).ne'

lemma differentiable_at_tan_of_mem_Ioo {x : ℝ} (h : x ∈ Ioo (-(π/2):ℝ) (π/2)) :
  differentiable_at ℝ tan x :=
(has_deriv_at_tan_of_mem_Ioo h).differentiable_at

lemma has_strict_deriv_at_arctan (x : ℝ) : has_strict_deriv_at arctan (1 / (1 + x^2)) x :=
have A : cos (arctan x) ≠ 0 := (cos_arctan_pos x).ne',
by simpa [cos_sq_arctan]
  using tan_local_homeomorph.has_strict_deriv_at_symm trivial (by simpa) (has_strict_deriv_at_tan A)

lemma has_deriv_at_arctan (x : ℝ) : has_deriv_at arctan (1 / (1 + x^2)) x :=
(has_strict_deriv_at_arctan x).has_deriv_at

lemma differentiable_at_arctan (x : ℝ) : differentiable_at ℝ arctan x :=
(has_deriv_at_arctan x).differentiable_at

lemma differentiable_arctan : differentiable ℝ arctan := differentiable_at_arctan

@[simp] lemma deriv_arctan : deriv arctan = (λ x, 1 / (1 + x^2)) :=
funext $ λ x, (has_deriv_at_arctan x).deriv

lemma cont_diff_arctan {n : with_top ℕ} : cont_diff ℝ n arctan :=
cont_diff_iff_cont_diff_at.2 $ λ x,
have cos (arctan x) ≠ 0 := (cos_arctan_pos x).ne',
tan_local_homeomorph.cont_diff_at_symm_deriv (by simpa) trivial (has_deriv_at_tan this)
  (cont_diff_at_tan.2 this)

end real

section
/-!
### Lemmas for derivatives of the composition of `real.arctan` with a differentiable function

In this section we register lemmas for the derivatives of the composition of `real.arctan` with a
differentiable function, for standalone use and use with `simp`. -/

open real

section deriv

variables {f : ℝ → ℝ} {f' x : ℝ} {s : set ℝ}

lemma has_strict_deriv_at.arctan (hf : has_strict_deriv_at f f' x) :
  has_strict_deriv_at (λ x, arctan (f x)) ((1 / (1 + (f x)^2)) * f') x :=
(real.has_strict_deriv_at_arctan (f x)).comp x hf

lemma has_deriv_at.arctan (hf : has_deriv_at f f' x) :
  has_deriv_at (λ x, arctan (f x)) ((1 / (1 + (f x)^2)) * f') x :=
(real.has_deriv_at_arctan (f x)).comp x hf

lemma has_deriv_within_at.arctan (hf : has_deriv_within_at f f' s x) :
  has_deriv_within_at (λ x, arctan (f x)) ((1 / (1 + (f x)^2)) * f') s x :=
(real.has_deriv_at_arctan (f x)).comp_has_deriv_within_at x hf

lemma deriv_within_arctan (hf : differentiable_within_at ℝ f s x)
  (hxs : unique_diff_within_at ℝ s x) :
  deriv_within (λ x, arctan (f x)) s x = (1 / (1 + (f x)^2)) * (deriv_within f s x) :=
hf.has_deriv_within_at.arctan.deriv_within hxs

@[simp] lemma deriv_arctan (hc : differentiable_at ℝ f x) :
  deriv (λ x, arctan (f x)) x = (1 / (1 + (f x)^2)) * (deriv f x) :=
hc.has_deriv_at.arctan.deriv

end deriv

section fderiv

variables {E : Type*} [normed_group E] [normed_space ℝ E] {f : E → ℝ} {f' : E →L[ℝ] ℝ} {x : E}
  {s : set E} {n : with_top ℕ}

lemma has_strict_fderiv_at.arctan (hf : has_strict_fderiv_at f f' x) :
  has_strict_fderiv_at (λ x, arctan (f x)) ((1 / (1 + (f x)^2)) • f') x :=
(has_strict_deriv_at_arctan (f x)).comp_has_strict_fderiv_at x hf

lemma has_fderiv_at.arctan (hf : has_fderiv_at f f' x) :
  has_fderiv_at (λ x, arctan (f x)) ((1 / (1 + (f x)^2)) • f') x :=
(has_deriv_at_arctan (f x)).comp_has_fderiv_at x hf

lemma has_fderiv_within_at.arctan (hf : has_fderiv_within_at f f' s x) :
  has_fderiv_within_at (λ x, arctan (f x)) ((1 / (1 + (f x)^2)) • f') s x :=
(has_deriv_at_arctan (f x)).comp_has_fderiv_within_at x hf

lemma fderiv_within_arctan (hf : differentiable_within_at ℝ f s x)
  (hxs : unique_diff_within_at ℝ s x) :
  fderiv_within ℝ (λ x, arctan (f x)) s x = (1 / (1 + (f x)^2)) • (fderiv_within ℝ f s x) :=
hf.has_fderiv_within_at.arctan.fderiv_within hxs

@[simp] lemma fderiv_arctan (hc : differentiable_at ℝ f x) :
  fderiv ℝ (λ x, arctan (f x)) x = (1 / (1 + (f x)^2)) • (fderiv ℝ f x) :=
hc.has_fderiv_at.arctan.fderiv

lemma differentiable_within_at.arctan (hf : differentiable_within_at ℝ f s x) :
  differentiable_within_at ℝ (λ x, real.arctan (f x)) s x :=
hf.has_fderiv_within_at.arctan.differentiable_within_at

@[simp] lemma differentiable_at.arctan (hc : differentiable_at ℝ f x) :
  differentiable_at ℝ (λ x, arctan (f x)) x :=
hc.has_fderiv_at.arctan.differentiable_at

lemma differentiable_on.arctan (hc : differentiable_on ℝ f s) :
  differentiable_on ℝ (λ x, arctan (f x)) s :=
λ x h, (hc x h).arctan

@[simp] lemma differentiable.arctan (hc : differentiable ℝ f) :
  differentiable ℝ (λ x, arctan (f x)) :=
λ x, (hc x).arctan

lemma cont_diff_at.arctan (h : cont_diff_at ℝ n f x) :
  cont_diff_at ℝ n (λ x, arctan (f x)) x :=
cont_diff_arctan.cont_diff_at.comp x h

lemma cont_diff.arctan (h : cont_diff ℝ n f) :
  cont_diff ℝ n (λ x, arctan (f x)) :=
cont_diff_arctan.comp h

lemma cont_diff_within_at.arctan (h : cont_diff_within_at ℝ n f s x) :
  cont_diff_within_at ℝ n (λ x, arctan (f x)) s x :=
cont_diff_arctan.comp_cont_diff_within_at h

lemma cont_diff_on.arctan (h : cont_diff_on ℝ n f s) :
  cont_diff_on ℝ n (λ x, arctan (f x)) s :=
cont_diff_arctan.comp_cont_diff_on h

end fderiv
end


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.comma

/-!
# The category of arrows

The category of arrows, with morphisms commutative squares.
We set this up as a specialization of the comma category `comma L R`,
where `L` and `R` are both the identity functor.

We also define the typeclass `has_lift`, representing a choice of a lift
of a commutative square (that is, a diagonal morphism making the two triangles commute).

## Tags

comma, arrow
-/

namespace category_theory

universes v u -- morphism levels before object levels. See note [category_theory universes].
variables {T : Type u} [category.{v} T]

section
variables (T)

/-- The arrow category of `T` has as objects all morphisms in `T` and as morphisms commutative
     squares in `T`. -/
@[derive category]
def arrow := comma.{v v v} (𝟭 T) (𝟭 T)

-- Satisfying the inhabited linter
instance arrow.inhabited [inhabited T] : inhabited (arrow T) :=
{ default := show comma (𝟭 T) (𝟭 T), from default (comma (𝟭 T) (𝟭 T)) }

end

namespace arrow

@[simp] lemma id_left (f : arrow T) : comma_morphism.left (𝟙 f) = 𝟙 (f.left) := rfl
@[simp] lemma id_right (f : arrow T) : comma_morphism.right (𝟙 f) = 𝟙 (f.right) := rfl

/-- An object in the arrow category is simply a morphism in `T`. -/
@[simps]
def mk {X Y : T} (f : X ⟶ Y) : arrow T :=
{ left := X,
  right := Y,
  hom := f }

instance {X Y : T} : has_coe (X ⟶ Y) (arrow T) := ⟨mk⟩

/-- A morphism in the arrow category is a commutative square connecting two objects of the arrow
    category. -/
@[simps]
def hom_mk {f g : arrow T} {u : f.left ⟶ g.left} {v : f.right ⟶ g.right}
  (w : u ≫ g.hom = f.hom ≫ v) : f ⟶ g :=
{ left := u,
  right := v,
  w' := w }

/-- We can also build a morphism in the arrow category out of any commutative square in `T`. -/
@[simps]
def hom_mk' {X Y : T} {f : X ⟶ Y} {P Q : T} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q}
  (w : u ≫ g = f ≫ v) : arrow.mk f ⟶ arrow.mk g :=
{ left := u,
  right := v,
  w' := w }

@[simp, reassoc] lemma w {f g : arrow T} (sq : f ⟶ g) : sq.left ≫ g.hom = f.hom ≫ sq.right := sq.w

-- `w_mk_left` is not needed, as it is a consequence of `w` and `mk_hom`.
@[simp, reassoc] lemma w_mk_right {f : arrow T} {X Y : T} {g : X ⟶ Y} (sq : f ⟶ mk g) :
  sq.left ≫ g = f.hom ≫ sq.right :=
sq.w

/-- Given a square from an arrow `i` to an isomorphism `p`, express the source part of `sq`
in terms of the inverse of `p`. -/
@[simp] lemma square_to_iso_invert (i : arrow T) {X Y : T} (p : X ≅ Y) (sq : i ⟶ arrow.mk p.hom) :
  i.hom ≫ sq.right ≫ p.inv = sq.left :=
by simpa only [category.assoc] using (iso.comp_inv_eq p).mpr ((arrow.w_mk_right sq).symm)

/-- Given a square from an isomorphism `i` to an arrow `p`, express the target part of `sq`
in terms of the inverse of `i`. -/
lemma square_from_iso_invert {X Y : T} (i : X ≅ Y) (p : arrow T) (sq : arrow.mk i.hom ⟶ p) :
  i.inv ≫ sq.left ≫ p.hom = sq.right :=
by simp only [iso.inv_hom_id_assoc, arrow.w, arrow.mk_hom]

/-- A lift of a commutative square is a diagonal morphism making the two triangles commute. -/
@[ext] structure lift_struct {f g : arrow T} (sq : f ⟶ g) :=
(lift : f.right ⟶ g.left)
(fac_left' : f.hom ≫ lift = sq.left . obviously)
(fac_right' : lift ≫ g.hom = sq.right . obviously)

restate_axiom lift_struct.fac_left'
restate_axiom lift_struct.fac_right'

instance lift_struct_inhabited {X : T} : inhabited (lift_struct (𝟙 (arrow.mk (𝟙 X)))) :=
⟨⟨𝟙 _, category.id_comp _, category.comp_id _⟩⟩

/-- `has_lift sq` says that there is some `lift_struct sq`, i.e., that it is possible to find a
    diagonal morphism making the two triangles commute. -/
class has_lift {f g : arrow T} (sq : f ⟶ g) : Prop :=
mk' :: (exists_lift : nonempty (lift_struct sq))

lemma has_lift.mk {f g : arrow T} {sq : f ⟶ g} (s : lift_struct sq) : has_lift sq :=
⟨nonempty.intro s⟩

attribute [simp, reassoc] lift_struct.fac_left lift_struct.fac_right

/-- Given `has_lift sq`, obtain a lift. -/
noncomputable def has_lift.struct {f g : arrow T} (sq : f ⟶ g) [has_lift sq] : lift_struct sq :=
classical.choice has_lift.exists_lift

/-- If there is a lift of a commutative square `sq`, we can access it by saying `lift sq`. -/
noncomputable abbreviation lift {f g : arrow T} (sq : f ⟶ g) [has_lift sq] : f.right ⟶ g.left :=
(has_lift.struct sq).lift

lemma lift.fac_left {f g : arrow T} (sq : f ⟶ g) [has_lift sq] : f.hom ≫ lift sq = sq.left :=
by simp

lemma lift.fac_right {f g : arrow T} (sq : f ⟶ g) [has_lift sq] : lift sq ≫ g.hom = sq.right :=
by simp

@[simp, reassoc]
lemma lift.fac_right_of_to_mk {X Y : T} {f : arrow T} {g : X ⟶ Y} (sq : f ⟶ mk g) [has_lift sq] :
  lift sq ≫ g = sq.right :=
by simp only [←mk_hom g, lift.fac_right]

@[simp, reassoc]
lemma lift.fac_left_of_from_mk {X Y : T} {f : X ⟶ Y} {g : arrow T} (sq : mk f ⟶ g) [has_lift sq] :
  f ≫ lift sq = sq.left :=
by simp only [←mk_hom f, lift.fac_left]

@[simp, reassoc]
lemma lift_mk'_left {X Y P Q : T} {f : X ⟶ Y} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q}
  (h : u ≫ g = f ≫ v) [has_lift $ arrow.hom_mk' h] : f ≫ lift (arrow.hom_mk' h) = u :=
by simp only [←arrow.mk_hom f, lift.fac_left, arrow.hom_mk'_left]

@[simp, reassoc]
lemma lift_mk'_right {X Y P Q : T} {f : X ⟶ Y} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q}
  (h : u ≫ g = f ≫ v) [has_lift $ arrow.hom_mk' h] : lift (arrow.hom_mk' h) ≫ g = v :=
by simp only [←arrow.mk_hom g, lift.fac_right, arrow.hom_mk'_right]

section

instance subsingleton_lift_struct_of_epi {f g : arrow T} (sq : f ⟶ g) [epi f.hom] :
  subsingleton (lift_struct sq) :=
subsingleton.intro $ λ a b, lift_struct.ext a b $ (cancel_epi f.hom).1 $ by simp

instance subsingleton_lift_struct_of_mono {f g : arrow T} (sq : f ⟶ g) [mono g.hom] :
  subsingleton (lift_struct sq) :=
subsingleton.intro $ λ a b, lift_struct.ext a b $ (cancel_mono g.hom).1 $ by simp

end

variables {C : Type u} [category.{v} C]
/-- A helper construction: given a square between `i` and `f ≫ g`, produce a square between
`i` and `g`, whose top leg uses `f`:
A  → X
     ↓f
↓i   Y             --> A → Y
     ↓g                ↓i  ↓g
B  → Z                 B → Z
 -/
@[simps] def square_to_snd {X Y Z: C} {i : arrow C} {f : X ⟶ Y} {g : Y ⟶ Z}
  (sq : i ⟶ arrow.mk (f ≫ g)) :
  i ⟶ arrow.mk g :=
{ left := sq.left ≫ f,
  right := sq.right }

end arrow

namespace functor

universes v₁ v₂ u₁ u₂

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

/-- A functor `C ⥤ D` induces a functor between the corresponding arrow categories. -/
@[simps]
def map_arrow (F : C ⥤ D) : arrow C ⥤ arrow D :=
{ obj := λ a,
  { left := F.obj a.left,
    right := F.obj a.right,
    hom := F.map a.hom, },
  map := λ a b f,
  { left := F.map f.left,
    right := F.map f.right,
    w' := by { have w := f.w, simp only [id_map] at w, dsimp, simp only [←F.map_comp, w], } } }

end functor

end category_theory


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

! This file was ported from Lean 3 source module group_theory.schreier
! leanprover-community/mathlib commit 8350c34a64b9bc3fc64335df8006bffcadc7baa6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.Abelianization
import Mathbin.GroupTheory.Exponent
import Mathbin.GroupTheory.Transfer

/-!
# Schreier's Lemma

In this file we prove Schreier's lemma.

## Main results

- `closure_mul_image_eq` : **Schreier's Lemma**: If `R : set G` is a right_transversal
  of `H : subgroup G` with `1 ∈ R`, and if `G` is generated by `S : set G`,
  then `H` is generated by the `set` `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`.
- `fg_of_index_ne_zero` : **Schreier's Lemma**: A finite index subgroup of a finitely generated
  group is finitely generated.
- `card_commutator_le_of_finite_commutator_set`: A theorem of Schur: The size of the commutator
  subgroup is bounded in terms of the number of commutators.
-/

open Pointwise

namespace Subgroup

open MemRightTransversals

variable {G : Type _} [Group G] {H : Subgroup G} {R S : Set G}

theorem closure_mul_image_mul_eq_top (hR : R ∈ rightTransversals (H : Set G)) (hR1 : (1 : G) ∈ R)
    (hS : closure S = ⊤) : (closure ((R * S).image fun g => g * (toFun hR g)⁻¹) : Set G) * R = ⊤ :=
  by
  let f : G → R := fun g => to_fun hR g
  let U : Set G := (R * S).image fun g => g * (f g)⁻¹
  change (closure U : Set G) * R = ⊤
  refine' top_le_iff.mp fun g hg => _
  apply closure_induction_right (eq_top_iff.mp hS (mem_top g))
  · exact ⟨1, 1, (closure U).one_mem, hR1, one_mul 1⟩
  · rintro - s hs ⟨u, r, hu, hr, rfl⟩
    rw [show u * r * s = u * (r * s * (f (r * s))⁻¹) * f (r * s) by group]
    refine' Set.mul_mem_mul ((closure U).mul_mem hu _) (f (r * s)).coe_prop
    exact subset_closure ⟨r * s, Set.mul_mem_mul hr hs, rfl⟩
  · rintro - s hs ⟨u, r, hu, hr, rfl⟩
    rw [show u * r * s⁻¹ = u * (f (r * s⁻¹) * s * r⁻¹)⁻¹ * f (r * s⁻¹) by group]
    refine' Set.mul_mem_mul ((closure U).mul_mem hu ((closure U).inv_mem _)) (f (r * s⁻¹)).2
    refine' subset_closure ⟨f (r * s⁻¹) * s, Set.mul_mem_mul (f (r * s⁻¹)).2 hs, _⟩
    rw [mul_right_inj, inv_inj, ← Subtype.coe_mk r hr, ← Subtype.ext_iff, Subtype.coe_mk]
    apply
      (mem_right_transversals_iff_exists_unique_mul_inv_mem.mp hR (f (r * s⁻¹) * s)).unique
        (mul_inv_to_fun_mem hR (f (r * s⁻¹) * s))
    rw [mul_assoc, ← inv_inv s, ← mul_inv_rev, inv_inv]
    exact to_fun_mul_inv_mem hR (r * s⁻¹)
#align subgroup.closure_mul_image_mul_eq_top Subgroup.closure_mul_image_mul_eq_top

/-- **Schreier's Lemma**: If `R : set G` is a right_transversal of `H : subgroup G`
  with `1 ∈ R`, and if `G` is generated by `S : set G`, then `H` is generated by the `set`
  `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`. -/
theorem closure_mul_image_eq (hR : R ∈ rightTransversals (H : Set G)) (hR1 : (1 : G) ∈ R)
    (hS : closure S = ⊤) : closure ((R * S).image fun g => g * (toFun hR g)⁻¹) = H :=
  by
  have hU : closure ((R * S).image fun g => g * (to_fun hR g)⁻¹) ≤ H :=
    by
    rw [closure_le]
    rintro - ⟨g, -, rfl⟩
    exact mul_inv_to_fun_mem hR g
  refine' le_antisymm hU fun h hh => _
  obtain ⟨g, r, hg, hr, rfl⟩ :=
    show h ∈ _ from eq_top_iff.mp (closure_mul_image_mul_eq_top hR hR1 hS) (mem_top h)
  suffices (⟨r, hr⟩ : R) = (⟨1, hR1⟩ : R) by rwa [show r = 1 from subtype.ext_iff.mp this, mul_one]
  apply (mem_right_transversals_iff_exists_unique_mul_inv_mem.mp hR r).unique
  · rw [Subtype.coe_mk, mul_inv_self]
    exact H.one_mem
  · rw [Subtype.coe_mk, inv_one, mul_one]
    exact (H.mul_mem_cancel_left (hU hg)).mp hh
#align subgroup.closure_mul_image_eq Subgroup.closure_mul_image_eq

/-- **Schreier's Lemma**: If `R : set G` is a right_transversal of `H : subgroup G`
  with `1 ∈ R`, and if `G` is generated by `S : set G`, then `H` is generated by the `set`
  `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`. -/
theorem closure_mul_image_eq_top (hR : R ∈ rightTransversals (H : Set G)) (hR1 : (1 : G) ∈ R)
    (hS : closure S = ⊤) :
    closure ((R * S).image fun g => ⟨g * (toFun hR g)⁻¹, mul_inv_toFun_mem hR g⟩ : Set H) = ⊤ :=
  by
  rw [eq_top_iff, ← map_subtype_le_map_subtype, MonoidHom.map_closure, Set.image_image]
  exact (map_subtype_le ⊤).trans (ge_of_eq (closure_mul_image_eq hR hR1 hS))
#align subgroup.closure_mul_image_eq_top Subgroup.closure_mul_image_eq_top

/-- **Schreier's Lemma**: If `R : finset G` is a right_transversal of `H : subgroup G`
  with `1 ∈ R`, and if `G` is generated by `S : finset G`, then `H` is generated by the `finset`
  `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`. -/
theorem closure_mul_image_eq_top' [DecidableEq G] {R S : Finset G}
    (hR : (R : Set G) ∈ rightTransversals (H : Set G)) (hR1 : (1 : G) ∈ R)
    (hS : closure (S : Set G) = ⊤) :
    closure (((R * S).image fun g => ⟨_, mul_inv_toFun_mem hR g⟩ : Finset H) : Set H) = ⊤ :=
  by
  rw [Finset.coe_image, Finset.coe_mul]
  exact closure_mul_image_eq_top hR hR1 hS
#align subgroup.closure_mul_image_eq_top' Subgroup.closure_mul_image_eq_top'

variable (H)

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem exists_finset_card_le_mul [FiniteIndex H] {S : Finset G} (hS : closure (S : Set G) = ⊤) :
    ∃ T : Finset H, T.card ≤ H.index * S.card ∧ closure (T : Set H) = ⊤ :=
  by
  letI := H.fintype_quotient_of_finite_index
  haveI : DecidableEq G := Classical.decEq G
  obtain ⟨R₀, hR : R₀ ∈ right_transversals (H : Set G), hR1⟩ := exists_right_transversal (1 : G)
  haveI : Fintype R₀ := Fintype.ofEquiv _ (mem_right_transversals.to_equiv hR)
  let R : Finset G := Set.toFinset R₀
  replace hR : (R : Set G) ∈ right_transversals (H : Set G) := by rwa [Set.coe_toFinset]
  replace hR1 : (1 : G) ∈ R := by rwa [Set.mem_toFinset]
  refine' ⟨_, _, closure_mul_image_eq_top' hR hR1 hS⟩
  calc
    _ ≤ (R * S).card := Finset.card_image_le
    _ ≤ (R ×ˢ S).card := Finset.card_image_le
    _ = R.card * S.card := (R.card_product S)
    _ = H.index * S.card := congr_arg (· * S.card) _

  calc
    R.card = Fintype.card R := (Fintype.card_coe R).symm
    _ = _ := (Fintype.card_congr (mem_right_transversals.to_equiv hR)).symm
    _ = Fintype.card (G ⧸ H) := (QuotientGroup.card_quotient_rightRel H)
    _ = H.index := H.index_eq_card.symm

#align subgroup.exists_finset_card_le_mul Subgroup.exists_finset_card_le_mul

/-- **Schreier's Lemma**: A finite index subgroup of a finitely generated
  group is finitely generated. -/
instance fg_of_index_ne_zero [hG : Group.Fg G] [FiniteIndex H] : Group.Fg H :=
  by
  obtain ⟨S, hS⟩ := hG.1
  obtain ⟨T, -, hT⟩ := exists_finset_card_le_mul H hS
  exact ⟨⟨T, hT⟩⟩
#align subgroup.fg_of_index_ne_zero Subgroup.fg_of_index_ne_zero

theorem rank_le_index_mul_rank [hG : Group.Fg G] [FiniteIndex H] :
    Group.rank H ≤ H.index * Group.rank G :=
  by
  haveI := H.fg_of_index_ne_zero
  obtain ⟨S, hS₀, hS⟩ := Group.rank_spec G
  obtain ⟨T, hT₀, hT⟩ := exists_finset_card_le_mul H hS
  calc
    Group.rank H ≤ T.card := Group.rank_le H hT
    _ ≤ H.index * S.card := hT₀
    _ = H.index * Group.rank G := congr_arg ((· * ·) H.index) hS₀

#align subgroup.rank_le_index_mul_rank Subgroup.rank_le_index_mul_rank

variable (G)

/-- If `G` has `n` commutators `[g₁, g₂]`, then `|G'| ∣ [G : Z(G)] ^ ([G : Z(G)] * n + 1)`,
where `G'` denotes the commutator of `G`. -/
theorem card_commutator_dvd_index_center_pow [Finite (commutatorSet G)] :
    Nat.card (commutator G) ∣
      (center G).index ^ ((center G).index * Nat.card (commutatorSet G) + 1) :=
  by
  -- First handle the case when `Z(G)` has infinite index and `[G : Z(G)]` is defined to be `0`
  by_cases hG : (center G).index = 0
  · simp_rw [hG, MulZeroClass.zero_mul, zero_add, pow_one, dvd_zero]
  haveI : finite_index (center G) := ⟨hG⟩
  -- Rewrite as `|Z(G) ∩ G'| * [G' : Z(G) ∩ G'] ∣ [G : Z(G)] ^ ([G : Z(G)] * n) * [G : Z(G)]`
  rw [← ((center G).subgroupOf (commutator G)).card_mul_index, pow_succ']
  -- We have `h1 : [G' : Z(G) ∩ G'] ∣ [G : Z(G)]`
  have h1 := relindex_dvd_index_of_normal (center G) (commutator G)
  -- So we can reduce to proving `|Z(G) ∩ G'| ∣ [G : Z(G)] ^ ([G : Z(G)] * n)`
  refine' mul_dvd_mul _ h1
  -- We know that `[G' : Z(G) ∩ G'] < ∞` by `h1` and `hG`
  haveI : finite_index ((center G).subgroupOf (commutator G)) := ⟨ne_zero_of_dvd_ne_zero hG h1⟩
  -- We have `h2 : rank (Z(G) ∩ G') ≤ [G' : Z(G) ∩ G'] * rank G'` by Schreier's lemma
  have h2 := rank_le_index_mul_rank ((center G).subgroupOf (commutator G))
  -- We have `h3 : [G' : Z(G) ∩ G'] * rank G' ≤ [G : Z(G)] * n` by `h1` and `rank G' ≤ n`
  have h3 := Nat.mul_le_mul (Nat.le_of_dvd (Nat.pos_of_ne_zero hG) h1) (rank_commutator_le_card G)
  -- So we can reduce to proving `|Z(G) ∩ G'| ∣ [G : Z(G)] ^ rank (Z(G) ∩ G')`
  refine' dvd_trans _ (pow_dvd_pow (center G).index (h2.trans h3))
  -- `Z(G) ∩ G'` is abelian, so it enough to prove that `g ^ [G : Z(G)] = 1` for `g ∈ Z(G) ∩ G'`
  apply card_dvd_exponent_pow_rank' _ fun g => _
  -- `Z(G)` is abelian, so `g ∈ Z(G) ∩ G' ≤ G' ≤ ker (transfer : G → Z(G))`
  have := Abelianization.commutator_subset_ker (MonoidHom.transferCenterPow G) g.1.2
  -- `transfer g` is defeq to `g ^ [G : Z(G)]`, so we are done
  simpa only [MonoidHom.mem_ker, Subtype.ext_iff] using this
#align subgroup.card_commutator_dvd_index_center_pow Subgroup.card_commutator_dvd_index_center_pow

/-- A bound for the size of the commutator subgroup in terms of the number of commutators. -/
def cardCommutatorBound (n : ℕ) :=
  (n ^ (2 * n)) ^ (n ^ (2 * n + 1) + 1)
#align subgroup.card_commutator_bound Subgroup.cardCommutatorBound

/-- A theorem of Schur: The size of the commutator subgroup is bounded in terms of the number of
  commutators. -/
theorem card_commutator_le_of_finite_commutatorSet [Finite (commutatorSet G)] :
    Nat.card (commutator G) ≤ cardCommutatorBound (Nat.card (commutatorSet G)) :=
  by
  have h1 := index_center_le_pow (closureCommutatorRepresentatives G)
  have h2 := card_commutator_dvd_index_center_pow (closureCommutatorRepresentatives G)
  rw [card_commutatorSet_closureCommutatorRepresentatives] at h1 h2
  rw [card_commutator_closureCommutatorRepresentatives] at h2
  replace h1 :=
    h1.trans
      (Nat.pow_le_pow_of_le_right Finite.card_pos (rank_closureCommutatorRepresentatives_le G))
  replace h2 := h2.trans (pow_dvd_pow _ (add_le_add_right (mul_le_mul_right' h1 _) 1))
  rw [← pow_succ'] at h2
  refine' (Nat.le_of_dvd _ h2).trans (Nat.pow_le_pow_of_le_left h1 _)
  exact pow_pos (Nat.pos_of_ne_zero finite_index.finite_index) _
#align subgroup.card_commutator_le_of_finite_commutator_set Subgroup.card_commutator_le_of_finite_commutatorSet

/-- A theorem of Schur: A group with finitely many commutators has finite commutator subgroup. -/
instance [Finite (commutatorSet G)] : Finite (commutator G) :=
  by
  have h2 := card_commutator_dvd_index_center_pow (closureCommutatorRepresentatives G)
  refine' Nat.finite_of_card_ne_zero fun h => _
  rw [card_commutator_closureCommutatorRepresentatives, h, zero_dvd_iff] at h2
  exact finite_index.finite_index (pow_eq_zero h2)

end Subgroup


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Reid Barton
-/
import category_theory.limits.shapes.images
import category_theory.filtered
import tactic.equiv_rw

/-!
# Limits in the category of types.

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

We show that the category of types has all (co)limits, by providing the usual concrete models.

We also give a characterisation of filtered colimits in `Type`, via
`colimit.ι F i xi = colimit.ι F j xj ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj`.

Finally, we prove the category of types has categorical images,
and that these agree with the range of a function.
-/

universes v u

open category_theory
open category_theory.limits

namespace category_theory.limits.types

variables {J : Type v} [small_category J]

/--
(internal implementation) the limit cone of a functor,
implemented as flat sections of a pi type
-/
def limit_cone (F : J ⥤ Type (max v u)) : cone F :=
{ X := F.sections,
  π := { app := λ j u, u.val j } }

local attribute [elab_simple] congr_fun
/-- (internal implementation) the fact that the proposed limit cone is the limit -/
def limit_cone_is_limit (F : J ⥤ Type (max v u)) : is_limit (limit_cone F) :=
{ lift := λ s v, ⟨λ j, s.π.app j v, λ j j' f, congr_fun (cone.w s f) _⟩,
  uniq' := by { intros, ext x j, exact congr_fun (w j) x } }

/--
The category of types has all limits.

See <https://stacks.math.columbia.edu/tag/002U>.
-/
instance has_limits_of_size : has_limits_of_size.{v} (Type (max v u)) :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit.mk
    { cone := limit_cone F, is_limit := limit_cone_is_limit F } } }

instance : has_limits (Type u) := types.has_limits_of_size.{u u}

/--
The equivalence between a limiting cone of `F` in `Type u` and the "concrete" definition as the
sections of `F`.
-/
def is_limit_equiv_sections {F : J ⥤ Type (max v u)} {c : cone F} (t : is_limit c) :
  c.X ≃ F.sections :=
(is_limit.cone_point_unique_up_to_iso t (limit_cone_is_limit F)).to_equiv

@[simp]
lemma is_limit_equiv_sections_apply
  {F : J ⥤ Type (max v u)} {c : cone F} (t : is_limit c) (j : J) (x : c.X) :
  (((is_limit_equiv_sections t) x) : Π j, F.obj j) j = c.π.app j x :=
rfl

@[simp]
lemma is_limit_equiv_sections_symm_apply
  {F : J ⥤ Type (max v u)} {c : cone F} (t : is_limit c) (x : F.sections) (j : J) :
  c.π.app j ((is_limit_equiv_sections t).symm x) = (x : Π j, F.obj j) j :=
begin
  equiv_rw (is_limit_equiv_sections t).symm at x,
  simp,
end

/--
The equivalence between the abstract limit of `F` in `Type u`
and the "concrete" definition as the sections of `F`.
-/
noncomputable
def limit_equiv_sections (F : J ⥤ Type (max v u)) : (limit F : Type (max v u)) ≃ F.sections :=
is_limit_equiv_sections (limit.is_limit _)

@[simp]
lemma limit_equiv_sections_apply (F : J ⥤ Type (max v u)) (x : limit F) (j : J) :
  (((limit_equiv_sections F) x) : Π j, F.obj j) j = limit.π F j x :=
rfl

@[simp]
lemma limit_equiv_sections_symm_apply (F : J ⥤ Type (max v u)) (x : F.sections) (j : J) :
  limit.π F j ((limit_equiv_sections F).symm x) = (x : Π j, F.obj j) j :=
is_limit_equiv_sections_symm_apply _ _ _

@[simp]
lemma limit_equiv_sections_symm_apply' (F : J ⥤ Type v) (x : F.sections) (j : J) :
  limit.π F j ((limit_equiv_sections.{v v} F).symm x) = (x : Π j, F.obj j) j :=
is_limit_equiv_sections_symm_apply _ _ _

/--
Construct a term of `limit F : Type u` from a family of terms `x : Π j, F.obj j`
which are "coherent": `∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j'`.
-/
@[ext]
noncomputable
def limit.mk (F : J ⥤ Type (max v u)) (x : Π j, F.obj j)
  (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') : (limit F : Type (max v u)) :=
(limit_equiv_sections F).symm ⟨x, h⟩

@[simp]
lemma limit.π_mk (F : J ⥤ Type (max v u)) (x : Π j, F.obj j)
  (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') (j) : limit.π F j (limit.mk F x h) = x j :=
by { dsimp [limit.mk], simp, }

@[simp]
lemma limit.π_mk' (F : J ⥤ Type v) (x : Π j, F.obj j)
  (h : ∀ (j j') (f : j ⟶ j'), F.map f (x j) = x j') (j) :
  limit.π F j (limit.mk.{v v} F x h) = x j :=
by { dsimp [limit.mk], simp, }

-- PROJECT: prove this for concrete categories where the forgetful functor preserves limits
@[ext]
lemma limit_ext (F : J ⥤ Type (max v u)) (x y : limit F) (w : ∀ j, limit.π F j x = limit.π F j y) :
  x = y :=
begin
  apply (limit_equiv_sections F).injective,
  ext j,
  simp [w j],
end

@[ext]
lemma limit_ext' (F : J ⥤ Type v) (x y : limit F) (w : ∀ j, limit.π F j x = limit.π F j y) :
  x = y :=
begin
  apply (limit_equiv_sections.{v v} F).injective,
  ext j,
  simp [w j],
end

lemma limit_ext_iff (F : J ⥤ Type (max v u)) (x y : limit F) :
  x = y ↔ (∀ j, limit.π F j x = limit.π F j y) :=
⟨λ t _, t ▸ rfl, limit_ext _ _ _⟩

lemma limit_ext_iff' (F : J ⥤ Type v) (x y : limit F) :
  x = y ↔ (∀ j, limit.π F j x = limit.π F j y) :=
⟨λ t _, t ▸ rfl, limit_ext _ _ _⟩

-- TODO: are there other limits lemmas that should have `_apply` versions?
-- Can we generate these like with `@[reassoc]`?
-- PROJECT: prove these for any concrete category where the forgetful functor preserves limits?

@[simp]
lemma limit.w_apply {F : J ⥤ Type (max v u)} {j j' : J} {x : limit F} (f : j ⟶ j') :
  F.map f (limit.π F j x) = limit.π F j' x :=
congr_fun (limit.w F f) x

@[simp]
lemma limit.lift_π_apply (F : J ⥤ Type (max v u)) (s : cone F) (j : J) (x : s.X) :
  limit.π F j (limit.lift F s x) = s.π.app j x :=
congr_fun (limit.lift_π s j) x

@[simp]
lemma limit.map_π_apply {F G : J ⥤ Type (max v u)} (α : F ⟶ G) (j : J) (x) :
  limit.π G j (lim_map α x) = α.app j (limit.π F j x) :=
congr_fun (lim_map_π α j) x

@[simp]
lemma limit.w_apply' {F : J ⥤ Type v} {j j' : J} {x : limit F} (f : j ⟶ j') :
  F.map f (limit.π F j x) = limit.π F j' x :=
congr_fun (limit.w F f) x

@[simp]
lemma limit.lift_π_apply' (F : J ⥤ Type v) (s : cone F) (j : J) (x : s.X) :
  limit.π F j (limit.lift F s x) = s.π.app j x :=
congr_fun (limit.lift_π s j) x

@[simp]
lemma limit.map_π_apply' {F G : J ⥤ Type v} (α : F ⟶ G) (j : J) (x) :
  limit.π G j (lim_map α x) = α.app j (limit.π F j x) :=
congr_fun (lim_map_π α j) x

/--
The relation defining the quotient type which implements the colimit of a functor `F : J ⥤ Type u`.
See `category_theory.limits.types.quot`.
-/
def quot.rel (F : J ⥤ Type (max v u)) : (Σ j, F.obj j) → (Σ j, F.obj j) → Prop :=
(λ p p', ∃ f : p.1 ⟶ p'.1, p'.2 = F.map f p.2)

/--
A quotient type implementing the colimit of a functor `F : J ⥤ Type u`,
as pairs `⟨j, x⟩` where `x : F.obj j`, modulo the equivalence relation generated by
`⟨j, x⟩ ~ ⟨j', x'⟩` whenever there is a morphism `f : j ⟶ j'` so `F.map f x = x'`.
-/
@[nolint has_nonempty_instance]
def quot (F : J ⥤ Type (max v u)) : Type (max v u) :=
@quot (Σ j, F.obj j) (quot.rel F)

/--
(internal implementation) the colimit cocone of a functor,
implemented as a quotient of a sigma type
-/
def colimit_cocone (F : J ⥤ Type (max v u)) : cocone F :=
{ X := quot F,
  ι :=
  { app := λ j x, quot.mk _ ⟨j, x⟩,
    naturality' := λ j j' f, funext $ λ x, eq.symm (quot.sound ⟨f, rfl⟩) } }

local attribute [elab_with_expected_type] quot.lift

/-- (internal implementation) the fact that the proposed colimit cocone is the colimit -/
def colimit_cocone_is_colimit (F : J ⥤ Type (max v u)) : is_colimit (colimit_cocone F) :=
{ desc := λ s, quot.lift (λ (p : Σ j, F.obj j), s.ι.app p.1 p.2)
    (assume ⟨j, x⟩ ⟨j', x'⟩ ⟨f, hf⟩, by rw hf; exact (congr_fun (cocone.w s f) x).symm) }

/--
The category of types has all colimits.

See <https://stacks.math.columbia.edu/tag/002U>.
-/
instance has_colimits_of_size : has_colimits_of_size.{v} (Type (max v u)) :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk
    { cocone := colimit_cocone F, is_colimit := colimit_cocone_is_colimit F } } }

instance : has_colimits (Type u) := types.has_colimits_of_size.{u u}

/--
The equivalence between the abstract colimit of `F` in `Type u`
and the "concrete" definition as a quotient.
-/
noncomputable
def colimit_equiv_quot (F : J ⥤ Type (max v u)) : (colimit F : Type (max v u)) ≃ quot F :=
(is_colimit.cocone_point_unique_up_to_iso
  (colimit.is_colimit F)
  (colimit_cocone_is_colimit F)).to_equiv

@[simp]
lemma colimit_equiv_quot_symm_apply (F : J ⥤ Type (max v u)) (j : J) (x : F.obj j) :
  (colimit_equiv_quot F).symm (quot.mk _ ⟨j, x⟩) = colimit.ι F j x :=
rfl

@[simp]
lemma colimit_equiv_quot_apply (F : J ⥤ Type (max v u)) (j : J) (x : F.obj j) :
  (colimit_equiv_quot F) (colimit.ι F j x) = quot.mk _ ⟨j, x⟩ :=
begin
  apply (colimit_equiv_quot F).symm.injective,
  simp,
end

@[simp]
lemma colimit.w_apply {F : J ⥤ Type (max v u)} {j j' : J} {x : F.obj j} (f : j ⟶ j') :
  colimit.ι F j' (F.map f x) = colimit.ι F j x :=
congr_fun (colimit.w F f) x

@[simp]
lemma colimit.ι_desc_apply (F : J ⥤ Type (max v u)) (s : cocone F) (j : J) (x : F.obj j) :
  colimit.desc F s (colimit.ι F j x) = s.ι.app j x :=
congr_fun (colimit.ι_desc s j) x

@[simp]
lemma colimit.ι_map_apply {F G : J ⥤ Type (max v u)} (α : F ⟶ G) (j : J) (x) :
  colim.map α (colimit.ι F j x) = colimit.ι G j (α.app j x) :=
congr_fun (colimit.ι_map α j) x

@[simp]
lemma colimit.w_apply' {F : J ⥤ Type v} {j j' : J} {x : F.obj j} (f : j ⟶ j') :
  colimit.ι F j' (F.map f x) = colimit.ι F j x :=
congr_fun (colimit.w F f) x

@[simp]
lemma colimit.ι_desc_apply' (F : J ⥤ Type v) (s : cocone F) (j : J) (x : F.obj j) :
  colimit.desc F s (colimit.ι F j x) = s.ι.app j x :=
congr_fun (colimit.ι_desc s j) x

@[simp]
lemma colimit.ι_map_apply' {F G : J ⥤ Type v} (α : F ⟶ G) (j : J) (x) :
  colim.map α (colimit.ι F j x) = colimit.ι G j (α.app j x) :=
congr_fun (colimit.ι_map α j) x

lemma colimit_sound
  {F : J ⥤ Type (max v u)} {j j' : J} {x : F.obj j} {x' : F.obj j'}
  (f : j ⟶ j') (w : F.map f x = x') : colimit.ι F j x = colimit.ι F j' x' :=
begin
  rw [←w],
  simp,
end

lemma colimit_sound'
  {F : J ⥤ Type (max v u)} {j j' : J} {x : F.obj j} {x' : F.obj j'} {j'' : J}
  (f : j ⟶ j'') (f' : j' ⟶ j'') (w : F.map f x = F.map f' x') :
  colimit.ι F j x = colimit.ι F j' x' :=
begin
  rw [←colimit.w _ f, ←colimit.w _ f'],
  rw [types_comp_apply, types_comp_apply, w],
end

lemma colimit_eq {F : J ⥤ Type (max v u)} {j j' : J} {x : F.obj j} {x' : F.obj j'}
  (w : colimit.ι F j x = colimit.ι F j' x') : eqv_gen (quot.rel F) ⟨j, x⟩ ⟨j', x'⟩ :=
begin
  apply quot.eq.1,
  simpa using congr_arg (colimit_equiv_quot F) w,
end

lemma jointly_surjective (F : J ⥤ Type (max v u)) {t : cocone F} (h : is_colimit t)
  (x : t.X) : ∃ j y, t.ι.app j y = x :=
begin
  suffices : (λ (x : t.X), ulift.up (∃ j y, t.ι.app j y = x)) = (λ _, ulift.up true),
  { have := congr_fun this x,
    have H := congr_arg ulift.down this,
    dsimp at H,
    rwa eq_true_iff at H },
  refine h.hom_ext _,
  intro j, ext y,
  erw iff_true,
  exact ⟨j, y, rfl⟩
end

/-- A variant of `jointly_surjective` for `x : colimit F`. -/
lemma jointly_surjective' {F : J ⥤ Type (max v u)}
  (x : colimit F) : ∃ j y, colimit.ι F j y = x :=
jointly_surjective F (colimit.is_colimit _) x

namespace filtered_colimit
/- For filtered colimits of types, we can give an explicit description
  of the equivalence relation generated by the relation used to form
  the colimit.  -/

variables (F : J ⥤ Type (max v u))

/--
An alternative relation on `Σ j, F.obj j`,
which generates the same equivalence relation as we use to define the colimit in `Type` above,
but that is more convenient when working with filtered colimits.

Elements in `F.obj j` and `F.obj j'` are equivalent if there is some `k : J` to the right
where their images are equal.
-/
protected def rel (x y : Σ j, F.obj j) : Prop :=
∃ k (f : x.1 ⟶ k) (g : y.1 ⟶ k), F.map f x.2 = F.map g y.2

lemma eqv_gen_quot_rel_of_rel (x y : Σ j, F.obj j) :
  filtered_colimit.rel F x y → eqv_gen (quot.rel F) x y :=
λ ⟨k, f, g, h⟩, eqv_gen.trans _ ⟨k, F.map f x.2⟩ _ (eqv_gen.rel _ _ ⟨f, rfl⟩)
  (eqv_gen.symm _ _ (eqv_gen.rel _ _ ⟨g, h⟩))

local attribute [elab_simple] nat_trans.app

/-- Recognizing filtered colimits of types. -/
noncomputable def is_colimit_of (t : cocone F) (hsurj : ∀ (x : t.X), ∃ i xi, x = t.ι.app i xi)
  (hinj : ∀ i j xi xj, t.ι.app i xi = t.ι.app j xj →
   ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj) : is_colimit t :=
-- Strategy: Prove that the map from "the" colimit of F (defined above) to t.X
-- is a bijection.
begin
  apply is_colimit.of_iso_colimit (colimit.is_colimit F),
  refine cocones.ext (equiv.to_iso (equiv.of_bijective _ _)) _,
  { exact colimit.desc F t },
  { split,
    { show function.injective _,
      intros a b h,
      rcases jointly_surjective F (colimit.is_colimit F) a with ⟨i, xi, rfl⟩,
      rcases jointly_surjective F (colimit.is_colimit F) b with ⟨j, xj, rfl⟩,
      change (colimit.ι F i ≫ colimit.desc F t) xi = (colimit.ι F j ≫ colimit.desc F t) xj at h,
      rw [colimit.ι_desc, colimit.ι_desc] at h,
      rcases hinj i j xi xj h with ⟨k, f, g, h'⟩,
      change colimit.ι F i xi = colimit.ι F j xj,
      rw [←colimit.w F f, ←colimit.w F g],
      change colimit.ι F k (F.map f xi) = colimit.ι F k (F.map g xj),
      rw h' },
    { show function.surjective _,
      intro x,
      rcases hsurj x with ⟨i, xi, rfl⟩,
      use colimit.ι F i xi,
      simp } },
  { intro j, apply colimit.ι_desc }
end

variables [is_filtered_or_empty J]

protected lemma rel_equiv : equivalence (filtered_colimit.rel F) :=
⟨λ x, ⟨x.1, 𝟙 x.1, 𝟙 x.1, rfl⟩,
 λ x y ⟨k, f, g, h⟩, ⟨k, g, f, h.symm⟩,
 λ x y z ⟨k, f, g, h⟩ ⟨k', f', g', h'⟩,
   let ⟨l, fl, gl, _⟩ := is_filtered_or_empty.cocone_objs k k',
       ⟨m, n, hn⟩ := is_filtered_or_empty.cocone_maps (g ≫ fl) (f' ≫ gl) in
   ⟨m, f ≫ fl ≫ n, g' ≫ gl ≫ n, calc
      F.map (f ≫ fl ≫ n) x.2
          = F.map (fl ≫ n) (F.map f x.2)  : by simp
      ... = F.map (fl ≫ n) (F.map g y.2)  : by rw h
      ... = F.map ((g ≫ fl) ≫ n) y.2      : by simp
      ... = F.map ((f' ≫ gl) ≫ n) y.2     : by rw hn
      ... = F.map (gl ≫ n) (F.map f' y.2) : by simp
      ... = F.map (gl ≫ n) (F.map g' z.2) : by rw h'
      ... = F.map (g' ≫ gl ≫ n) z.2       : by simp⟩⟩

protected lemma rel_eq_eqv_gen_quot_rel :
  filtered_colimit.rel F = eqv_gen (quot.rel F) :=
begin
  ext ⟨j, x⟩ ⟨j', y⟩,
  split,
  { apply eqv_gen_quot_rel_of_rel },
  { rw ←(filtered_colimit.rel_equiv F).eqv_gen_iff,
    exact eqv_gen.mono (rel_of_quot_rel F) }
end

lemma colimit_eq_iff_aux {i j : J} {xi : F.obj i} {xj : F.obj j} :
  (colimit_cocone F).ι.app i xi = (colimit_cocone F).ι.app j xj ↔
    filtered_colimit.rel F ⟨i, xi⟩ ⟨j, xj⟩ :=
begin
  change quot.mk _ _ = quot.mk _ _ ↔ _,
  rw [quot.eq, filtered_colimit.rel_eq_eqv_gen_quot_rel],
end

lemma is_colimit_eq_iff {t : cocone F} (ht : is_colimit t) {i j : J} {xi : F.obj i} {xj : F.obj j} :
  t.ι.app i xi = t.ι.app j xj ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj :=
let t' := colimit_cocone F,
    e : t' ≅ t := is_colimit.unique_up_to_iso (colimit_cocone_is_colimit F) ht,
    e' : t'.X ≅ t.X := (cocones.forget _).map_iso e in
begin
  refine iff.trans _ (colimit_eq_iff_aux F),
  convert e'.to_equiv.apply_eq_iff_eq; rw ←e.hom.w; refl
end

lemma colimit_eq_iff {i j : J} {xi : F.obj i} {xj : F.obj j} :
  colimit.ι F i xi = colimit.ι F j xj ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f xi = F.map g xj :=
is_colimit_eq_iff _ (colimit.is_colimit F)

end filtered_colimit

variables {α β : Type u} (f : α ⟶ β)

section -- implementation of `has_image`
/-- the image of a morphism in Type is just `set.range f` -/
def image : Type u := set.range f

instance [inhabited α] : inhabited (image f) :=
{ default := ⟨f default, ⟨_, rfl⟩⟩ }

/-- the inclusion of `image f` into the target -/
def image.ι : image f ⟶ β := subtype.val

instance : mono (image.ι f) :=
(mono_iff_injective _).2 subtype.val_injective

variables {f}

/-- the universal property for the image factorisation -/
noncomputable def image.lift (F' : mono_factorisation f) : image f ⟶ F'.I :=
(λ x, F'.e (classical.indefinite_description _ x.2).1 : image f → F'.I)

lemma image.lift_fac (F' : mono_factorisation f) : image.lift F' ≫ F'.m = image.ι f :=
begin
  ext x,
  change (F'.e ≫ F'.m) _ = _,
  rw [F'.fac, (classical.indefinite_description _ x.2).2],
  refl,
end
end

/-- the factorisation of any morphism in Type through a mono. -/
def mono_factorisation : mono_factorisation f :=
{ I := image f,
  m := image.ι f,
  e := set.range_factorization f }

/-- the facorisation through a mono has the universal property of the image. -/
noncomputable def is_image : is_image (mono_factorisation f) :=
{ lift := image.lift,
  lift_fac' := image.lift_fac }

instance : has_image f :=
has_image.mk ⟨_, is_image f⟩

instance : has_images (Type u) :=
{ has_image := by apply_instance }

instance : has_image_maps (Type u) :=
{ has_image_map := λ f g st, has_image_map.transport st (mono_factorisation f.hom) (is_image g.hom)
    (λ x, ⟨st.right x.1, ⟨st.left (classical.some x.2),
      begin
        have p := st.w,
        replace p := congr_fun p (classical.some x.2),
        simp only [functor.id_map, types_comp_apply, subtype.val_eq_coe] at p,
        erw [p, classical.some_spec x.2],
      end⟩⟩) rfl }

end category_theory.limits.types


import GMLInit.Data.Nat.Extended.Basic

namespace ENat

protected def le (x y : ENat) : Prop := ∀ n, x.isLE n || !y.isLE n
instance : LE ENat := ⟨ENat.le⟩

protected def lt (x y : ENat) : Prop := ∃ n, x.isLE n && !y.isLE n
instance : LT ENat := ⟨ENat.lt⟩

theorem zero_le (x : ENat) : 0 ≤ x := by
  intro n
  rw [isLE_zero, Bool.true_or]

theorem le_infinity (x : ENat) : x ≤ ∞ := by
  intro n
  rw [isLE_infinity, Bool.not_false, Bool.or_true]

theorem le_refl (x : ENat) : x ≤ x := by
  intro n
  cases x.isLE n <;> rfl

theorem le_trans {x y z : ENat} : x ≤ y → y ≤ z → x ≤ z := by
  intro hxy hyz n
  match hx : x.isLE n, hy : y.isLE n, hz : z.isLE n with
  | true, true, true => rfl
  | true, true, false => rfl
  | true, false, true => rfl
  | true, false, false => rfl
  | false, true, true =>
    have : false = true := by rw [←hxy n, hx, hy]; rfl
    contradiction
  | false, true, false => rfl
  | false, false, true =>
    have : false = true := by rw [←hyz n, hy, hz]; rfl
    contradiction
  | false, false, false => rfl

theorem le_antisymm {x y : ENat} : x ≤ y → y ≤ x → x = y := by
  intro hxy hyx
  apply ENat.ext
  intro n
  match hx : x.isLE n, hy : y.isLE n with
  | true, true => rfl
  | true, false =>
    have : false = true := by rw [←hyx n, hx, hy]; rfl
    contradiction
  | false, true =>
    have : false = true := by rw [←hxy n, hx, hy]; rfl
    contradiction
  | false, false => rfl

theorem le_of_eq {x y : ENat} : x = y → x ≤ y | rfl => le_refl _

theorem le_of_lt {x y : ENat} : x < y → x ≤ y
| ⟨n₀,h₀⟩ => by
  rw [Bool.and_eq_true] at h₀
  intro n
  cases Nat.le_total n n₀ with
  | inl hle =>
    have : y.isLE n = false := by
      rw [←Bool.not_eq_true]
      intro hy
      have : y.isLE n₀ = true := by
        apply y.mono hle
        exact hy
      simp [this] at h₀
    rw [this, Bool.not_false, Bool.or_true]
  | inr hge =>
    have : x.isLE n = true := by
      apply x.mono hge
      exact h₀.1
    rw [this, Bool.true_or]

theorem lt_irrefl (x : ENat) : ¬ x < x := by
  intro ⟨n, hn⟩
  have : false = true := by rw [←hn]; cases x.isLE n <;> rfl
  contradiction

theorem lt_of_le_of_lt {x y z : ENat} : x ≤ y → y < z → x < z := by
  intro hxy ⟨n,h⟩
  rw [Bool.and_eq_true] at h
  have h' := hxy n
  rw [Bool.or_eq_true] at h'
  match h, h' with
  | ⟨_,hz⟩, Or.inl hx =>
    exists n
    rw [hx, hz]
    rfl
  | ⟨hy,_⟩, Or.inr hy' =>
    rw [hy] at hy'
    contradiction

theorem lt_of_lt_of_le {x y z : ENat} : x < y → y ≤ z → x < z := by
  intro ⟨n,h⟩ hyz
  rw [Bool.and_eq_true] at h
  have h' := hyz n
  rw [Bool.or_eq_true] at h'
  match h, h' with
  | ⟨_,hy⟩, Or.inl hy' =>
    rw [hy'] at hy
    contradiction
  | ⟨hx,_⟩, Or.inr hz =>
    exists n
    rw [hx, hz]
    rfl

theorem lt_trans {x y z : ENat} : x < y → y < z → x < z := by
  intro hxy hyz
  apply lt_of_lt_of_le
  · exact hxy
  · apply le_of_lt
    exact hyz

instance : Relation.Reflexive (α:=ENat) (.≤.) := ⟨ENat.le_refl⟩

instance : Relation.Irreflexive (α:=ENat) (.<.) := ⟨ENat.lt_irrefl⟩

instance : Relation.Transitive (α:=ENat) (.≤.) := ⟨ENat.le_trans⟩

instance : Relation.Transitive (α:=ENat) (.<.) := ⟨ENat.lt_trans⟩

instance : Relation.HTransitive (α:=ENat) (β:=ENat) (γ:=ENat) (.≤.) (.<.) (.<.) := ⟨ENat.lt_of_le_of_lt⟩

instance : Relation.HTransitive (α:=ENat) (β:=ENat) (γ:=ENat) (.<.) (.≤.) (.<.) := ⟨ENat.lt_of_lt_of_le⟩

instance : Relation.Antisymmetric (α:=ENat) (.≤.) := ⟨ENat.le_antisymm⟩

end ENat