/-
Copyright (c) 2018 Ellen Arlt. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ellen Arlt, Blair Shi, Sean Leather, Mario Carneiro, Johan Commelin
-/
import data.matrix.basic

/-!
# Block Matrices

## Main definitions

* `matrix.from_blocks`: build a block matrix out of 4 blocks
* `matrix.to_blocks₁₁`, `matrix.to_blocks₁₂`, `matrix.to_blocks₂₁`, `matrix.to_blocks₂₂`:
  extract each of the four blocks from `matrix.from_blocks`.
* `matrix.block_diagonal`: block diagonal of equally sized blocks. On square blocks, this is a
  ring homomorphisms, `matrix.block_diagonal_ring_hom`.
* `matrix.block_diag`: extract the blocks from the diagonal of a block diagonal matrix.
* `matrix.block_diagonal'`: block diagonal of unequally sized blocks. On square blocks, this is a
  ring homomorphisms, `matrix.block_diagonal'_ring_hom`.
* `matrix.block_diag'`: extract the blocks from the diagonal of a block diagonal matrix.
-/

variables {l m n o p q : Type*} {m' n' p' : o → Type*}
variables {R : Type*} {S : Type*} {α : Type*} {β : Type*}

open_locale matrix

namespace matrix

section block_matrices

/-- We can form a single large matrix by flattening smaller 'block' matrices of compatible
dimensions. -/
@[pp_nodot]
def from_blocks (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  matrix (n ⊕ o) (l ⊕ m) α :=
of $ sum.elim (λ i, sum.elim (A i) (B i))
              (λ i, sum.elim (C i) (D i))

@[simp] lemma from_blocks_apply₁₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : n) (j : l) :
  from_blocks A B C D (sum.inl i) (sum.inl j) = A i j :=
rfl

@[simp] lemma from_blocks_apply₁₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : n) (j : m) :
  from_blocks A B C D (sum.inl i) (sum.inr j) = B i j :=
rfl

@[simp] lemma from_blocks_apply₂₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : o) (j : l) :
  from_blocks A B C D (sum.inr i) (sum.inl j) = C i j :=
rfl

@[simp] lemma from_blocks_apply₂₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : o) (j : m) :
  from_blocks A B C D (sum.inr i) (sum.inr j) = D i j :=
rfl

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"top left" submatrix. -/
def to_blocks₁₁ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix n l α :=
of $ λ i j, M (sum.inl i) (sum.inl j)

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"top right" submatrix. -/
def to_blocks₁₂ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix n m α :=
of $ λ i j, M (sum.inl i) (sum.inr j)

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"bottom left" submatrix. -/
def to_blocks₂₁ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix o l α :=
of $ λ i j, M (sum.inr i) (sum.inl j)

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"bottom right" submatrix. -/
def to_blocks₂₂ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix o m α :=
of $ λ i j, M (sum.inr i) (sum.inr j)

lemma from_blocks_to_blocks (M : matrix (n ⊕ o) (l ⊕ m) α) :
  from_blocks M.to_blocks₁₁ M.to_blocks₁₂ M.to_blocks₂₁ M.to_blocks₂₂ = M :=
begin
  ext i j, rcases i; rcases j; refl,
end

@[simp] lemma to_blocks_from_blocks₁₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₁₁ = A :=
rfl

@[simp] lemma to_blocks_from_blocks₁₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₁₂ = B :=
rfl

@[simp] lemma to_blocks_from_blocks₂₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₂₁ = C :=
rfl

@[simp] lemma to_blocks_from_blocks₂₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₂₂ = D :=
rfl

lemma from_blocks_map
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (f : α → β) :
  (from_blocks A B C D).map f = from_blocks (A.map f) (B.map f) (C.map f) (D.map f) :=
begin
  ext i j, rcases i; rcases j; simp [from_blocks],
end

lemma from_blocks_transpose
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D)ᵀ = from_blocks Aᵀ Cᵀ Bᵀ Dᵀ :=
begin
  ext i j, rcases i; rcases j; simp [from_blocks],
end

lemma from_blocks_conj_transpose [has_star α]
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D)ᴴ = from_blocks Aᴴ Cᴴ Bᴴ Dᴴ :=
begin
  simp only [conj_transpose, from_blocks_transpose, from_blocks_map]
end

@[simp] lemma from_blocks_submatrix_sum_swap_left
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (f : p → l ⊕ m) :
  (from_blocks A B C D).submatrix sum.swap f = (from_blocks C D A B).submatrix id f :=
by { ext i j, cases i; dsimp; cases f j; refl }

@[simp] lemma from_blocks_submatrix_sum_swap_right
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (f : p → n ⊕ o) :
  (from_blocks A B C D).submatrix f sum.swap = (from_blocks B A D C).submatrix f id :=
by { ext i j, cases j; dsimp; cases f i; refl }

lemma from_blocks_submatrix_sum_swap_sum_swap {l m n o α : Type*}
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).submatrix sum.swap sum.swap = from_blocks D C B A :=
by simp

/-- A 2x2 block matrix is block diagonal if the blocks outside of the diagonal vanish -/
def is_two_block_diagonal [has_zero α] (A : matrix (n ⊕ o) (l ⊕ m) α) : Prop :=
to_blocks₁₂ A = 0 ∧ to_blocks₂₁ A = 0

/-- Let `p` pick out certain rows and `q` pick out certain columns of a matrix `M`. Then
  `to_block M p q` is the corresponding block matrix. -/
def to_block (M : matrix m n α) (p : m → Prop) (q : n → Prop) :
  matrix {a // p a} {a // q a} α := M.submatrix coe coe

@[simp] lemma to_block_apply (M : matrix m n α) (p : m → Prop) (q : n → Prop)
  (i : {a // p a}) (j : {a // q a}) : to_block M p q i j = M ↑i ↑j := rfl

/-- Let `p` pick out certain rows and columns of a square matrix `M`. Then
  `to_square_block_prop M p` is the corresponding block matrix. -/
def to_square_block_prop (M : matrix m m α) (p : m → Prop) : matrix {a // p a} {a // p a} α :=
to_block M _ _

lemma to_square_block_prop_def (M : matrix m m α) (p : m → Prop) :
  to_square_block_prop M p = λ i j, M ↑i ↑j := rfl

/-- Let `b` map rows and columns of a square matrix `M` to blocks. Then
  `to_square_block M b k` is the block `k` matrix. -/
def to_square_block (M : matrix m m α) (b : m → β) (k : β) :
  matrix {a // b a = k} {a // b a = k} α := to_square_block_prop M _

lemma to_square_block_def (M : matrix m m α) (b : m → β) (k : β) :
  to_square_block M b k = λ i j, M ↑i ↑j := rfl

lemma from_blocks_smul [has_smul R α]
  (x : R) (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  x • (from_blocks A B C D) = from_blocks (x • A) (x • B) (x • C) (x • D) :=
begin
  ext i j, rcases i; rcases j; simp [from_blocks],
end

lemma from_blocks_neg [has_neg R]
  (A : matrix n l R) (B : matrix n m R) (C : matrix o l R) (D : matrix o m R) :
  - (from_blocks A B C D) = from_blocks (-A) (-B) (-C) (-D) :=
begin
  ext i j, cases i; cases j; simp [from_blocks],
end

lemma from_blocks_add [has_add α]
  (A  : matrix n l α) (B  : matrix n m α) (C  : matrix o l α) (D  : matrix o m α)
  (A' : matrix n l α) (B' : matrix n m α) (C' : matrix o l α) (D' : matrix o m α) :
  (from_blocks A B C D) + (from_blocks A' B' C' D') =
  from_blocks (A + A') (B + B')
              (C + C') (D + D') :=
begin
  ext i j, rcases i; rcases j; refl,
end

lemma from_blocks_multiply [fintype l] [fintype m] [non_unital_non_assoc_semiring α]
  (A  : matrix n l α) (B  : matrix n m α) (C  : matrix o l α) (D  : matrix o m α)
  (A' : matrix l p α) (B' : matrix l q α) (C' : matrix m p α) (D' : matrix m q α) :
  (from_blocks A B C D) ⬝ (from_blocks A' B' C' D') =
  from_blocks (A ⬝ A' + B ⬝ C') (A ⬝ B' + B ⬝ D')
              (C ⬝ A' + D ⬝ C') (C ⬝ B' + D ⬝ D') :=
begin
  ext i j, rcases i; rcases j;
  simp only [from_blocks, mul_apply, fintype.sum_sum_type, sum.elim_inl, sum.elim_inr,
    pi.add_apply, of_apply],
end

lemma from_blocks_mul_vec [fintype l] [fintype m] [non_unital_non_assoc_semiring α]
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (x : l ⊕ m → α) :
  mul_vec (from_blocks A B C D) x =
  sum.elim (mul_vec A (x ∘ sum.inl) + mul_vec B (x ∘ sum.inr))
           (mul_vec C (x ∘ sum.inl) + mul_vec D (x ∘ sum.inr)) :=
by { ext i, cases i; simp [mul_vec, dot_product] }

lemma vec_mul_from_blocks [fintype n] [fintype o] [non_unital_non_assoc_semiring α]
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (x : n ⊕ o → α) :
  vec_mul x (from_blocks A B C D) =
  sum.elim (vec_mul (x ∘ sum.inl) A + vec_mul (x ∘ sum.inr) C)
           (vec_mul (x ∘ sum.inl) B + vec_mul (x ∘ sum.inr) D) :=
by { ext i, cases i; simp [vec_mul, dot_product] }

variables [decidable_eq l] [decidable_eq m]

section has_zero
variables [has_zero α]

lemma to_block_diagonal_self (d : m → α) (p : m → Prop) :
  matrix.to_block (diagonal d) p p = diagonal (λ i : subtype p, d ↑i) :=
begin
  ext i j,
  by_cases i = j,
  { simp [h] },
  { simp [has_one.one, h, λ h', h $ subtype.ext h'], }
end

lemma to_block_diagonal_disjoint (d : m → α) {p q : m → Prop} (hpq : disjoint p q) :
  matrix.to_block (diagonal d) p q = 0 :=
begin
  ext ⟨i, hi⟩ ⟨j, hj⟩,
  have : i ≠ j, from λ heq, hpq.le_bot i ⟨hi, heq.symm ▸ hj⟩,
  simp [diagonal_apply_ne d this]
end

@[simp] lemma from_blocks_diagonal (d₁ : l → α) (d₂ : m → α) :
  from_blocks (diagonal d₁) 0 0 (diagonal d₂) = diagonal (sum.elim d₁ d₂) :=
begin
  ext i j, rcases i; rcases j; simp [diagonal],
end

end has_zero

section has_zero_has_one
variables [has_zero α] [has_one α]

@[simp] lemma from_blocks_one :
  from_blocks (1 : matrix l l α) 0 0 (1 : matrix m m α) = 1 :=
by { ext i j, rcases i; rcases j; simp [one_apply] }

@[simp] lemma to_block_one_self (p : m → Prop) : matrix.to_block (1 : matrix m m α) p p = 1 :=
to_block_diagonal_self _ p

lemma to_block_one_disjoint {p q : m → Prop} (hpq : disjoint p q) :
  matrix.to_block (1 : matrix m m α) p q = 0 :=
to_block_diagonal_disjoint _ hpq

end has_zero_has_one

end block_matrices

section block_diagonal
variables [decidable_eq o]

section has_zero
variables [has_zero α] [has_zero β]

/-- `matrix.block_diagonal M` turns a homogenously-indexed collection of matrices
`M : o → matrix m n α'` into a `m × o`-by-`n × o` block matrix which has the entries of `M` along
the diagonal and zero elsewhere.

See also `matrix.block_diagonal'` if the matrices may not have the same size everywhere.
-/
def block_diagonal (M : o → matrix m n α) : matrix (m × o) (n × o) α :=
of $ (λ ⟨i, k⟩ ⟨j, k'⟩, if k = k' then M k i j else 0 : m × o → n × o → α)

-- TODO: set as an equation lemma for `block_diagonal`, see mathlib4#3024
lemma block_diagonal_apply' (M : o → matrix m n α) (i k j k') :
  block_diagonal M ⟨i, k⟩ ⟨j, k'⟩ = if k = k' then M k i j else 0 :=
rfl

lemma block_diagonal_apply (M : o → matrix m n α) (ik jk) :
  block_diagonal M ik jk = if ik.2 = jk.2 then M ik.2 ik.1 jk.1 else 0 :=
by { cases ik, cases jk, refl }

@[simp]
lemma block_diagonal_apply_eq (M : o → matrix m n α) (i j k) :
  block_diagonal M (i, k) (j, k) = M k i j :=
if_pos rfl

lemma block_diagonal_apply_ne (M : o → matrix m n α) (i j) {k k'} (h : k ≠ k') :
  block_diagonal M (i, k) (j, k') = 0 :=
if_neg h

lemma block_diagonal_map (M : o → matrix m n α) (f : α → β) (hf : f 0 = 0) :
  (block_diagonal M).map f = block_diagonal (λ k, (M k).map f) :=
begin
  ext,
  simp only [map_apply, block_diagonal_apply, eq_comm],
  rw [apply_ite f, hf],
end

@[simp] lemma block_diagonal_transpose (M : o → matrix m n α) :
  (block_diagonal M)ᵀ = block_diagonal (λ k, (M k)ᵀ) :=
begin
  ext,
  simp only [transpose_apply, block_diagonal_apply, eq_comm],
  split_ifs with h,
  { rw h },
  { refl }
end

@[simp] lemma block_diagonal_conj_transpose
  {α : Type*} [add_monoid α] [star_add_monoid α] (M : o → matrix m n α) :
  (block_diagonal M)ᴴ = block_diagonal (λ k, (M k)ᴴ) :=
begin
  simp only [conj_transpose, block_diagonal_transpose],
  rw block_diagonal_map _ star (star_zero α),
end

@[simp] lemma block_diagonal_zero :
  block_diagonal (0 : o → matrix m n α) = 0 :=
by { ext, simp [block_diagonal_apply] }

@[simp] lemma block_diagonal_diagonal [decidable_eq m] (d : o → m → α) :
  block_diagonal (λ k, diagonal (d k)) = diagonal (λ ik, d ik.2 ik.1) :=
begin
  ext ⟨i, k⟩ ⟨j, k'⟩,
  simp only [block_diagonal_apply, diagonal_apply, prod.mk.inj_iff, ← ite_and],
  congr' 1,
  rw and_comm,
end

@[simp] lemma block_diagonal_one [decidable_eq m] [has_one α] :
  block_diagonal (1 : o → matrix m m α) = 1 :=
show block_diagonal (λ (_ : o), diagonal (λ (_ : m), (1 : α))) = diagonal (λ _, 1),
by rw [block_diagonal_diagonal]

end has_zero

@[simp] lemma block_diagonal_add [add_zero_class α] (M N : o → matrix m n α) :
  block_diagonal (M + N) = block_diagonal M + block_diagonal N :=
begin
  ext,
  simp only [block_diagonal_apply, pi.add_apply],
  split_ifs; simp
end

section
variables (o m n α)
/-- `matrix.block_diagonal` as an `add_monoid_hom`. -/
@[simps] def block_diagonal_add_monoid_hom [add_zero_class α] :
  (o → matrix m n α) →+ matrix (m × o) (n × o) α :=
{ to_fun := block_diagonal,
  map_zero' := block_diagonal_zero,
  map_add' := block_diagonal_add }
end

@[simp] lemma block_diagonal_neg [add_group α] (M : o → matrix m n α) :
  block_diagonal (-M) = - block_diagonal M :=
map_neg (block_diagonal_add_monoid_hom m n o α) M

@[simp] lemma block_diagonal_sub [add_group α] (M N : o → matrix m n α) :
  block_diagonal (M - N) = block_diagonal M - block_diagonal N :=
map_sub (block_diagonal_add_monoid_hom m n o α) M N

@[simp] lemma block_diagonal_mul [fintype n] [fintype o] [non_unital_non_assoc_semiring α]
  (M : o → matrix m n α) (N : o → matrix n p α) :
  block_diagonal (λ k, M k ⬝ N k) = block_diagonal M ⬝ block_diagonal N :=
begin
  ext ⟨i, k⟩ ⟨j, k'⟩,
  simp only [block_diagonal_apply, mul_apply, ← finset.univ_product_univ, finset.sum_product],
  split_ifs with h; simp [h]
end

section
variables (α m o)
/-- `matrix.block_diagonal` as a `ring_hom`. -/
@[simps]
def block_diagonal_ring_hom [decidable_eq m] [fintype o] [fintype m] [non_assoc_semiring α] :
  (o → matrix m m α) →+* matrix (m × o) (m × o) α :=
{ to_fun := block_diagonal,
  map_one' := block_diagonal_one,
  map_mul' := block_diagonal_mul,
  ..block_diagonal_add_monoid_hom m m o α }
end

@[simp] lemma block_diagonal_pow [decidable_eq m] [fintype o] [fintype m] [semiring α]
  (M : o → matrix m m α) (n : ℕ)  :
  block_diagonal (M ^ n) = block_diagonal M ^ n :=
map_pow (block_diagonal_ring_hom m o α) M n

@[simp] lemma block_diagonal_smul {R : Type*} [monoid R] [add_monoid α] [distrib_mul_action R α]
  (x : R) (M : o → matrix m n α) : block_diagonal (x • M) = x • block_diagonal M :=
by { ext, simp only [block_diagonal_apply, pi.smul_apply], split_ifs; simp }

end block_diagonal

section block_diag

/-- Extract a block from the diagonal of a block diagonal matrix.

This is the block form of `matrix.diag`, and the left-inverse of `matrix.block_diagonal`. -/
def block_diag (M : matrix (m × o) (n × o) α) (k : o) : matrix m n α :=
of $ λ i j, M (i, k) (j, k)

-- TODO: set as an equation lemma for `block_diag`, see mathlib4#3024
lemma block_diag_apply (M : matrix (m × o) (n × o) α) (k : o) (i j) :
  block_diag M k i j = M (i, k) (j, k) := rfl

lemma block_diag_map (M : matrix (m × o) (n × o) α) (f : α → β) :
  block_diag (M.map f) = λ k, (block_diag M k).map f :=
rfl

@[simp] lemma block_diag_transpose (M : matrix (m × o) (n × o) α) (k : o) :
  block_diag Mᵀ k = (block_diag M k)ᵀ :=
ext $ λ i j, rfl

@[simp] lemma block_diag_conj_transpose
  {α : Type*} [add_monoid α] [star_add_monoid α] (M : matrix (m × o) (n × o) α) (k : o) :
  block_diag Mᴴ k = (block_diag M k)ᴴ :=
ext $ λ i j, rfl

section has_zero
variables [has_zero α] [has_zero β]

@[simp] lemma block_diag_zero :
  block_diag (0 : matrix (m × o) (n × o) α) = 0 :=
rfl

@[simp] lemma block_diag_diagonal [decidable_eq o] [decidable_eq m] (d : (m × o) → α) (k : o) :
  block_diag (diagonal d) k = diagonal (λ i, d (i, k)) :=
ext $ λ i j, begin
  obtain rfl | hij := decidable.eq_or_ne i j,
  { rw [block_diag_apply, diagonal_apply_eq, diagonal_apply_eq] },
  { rw [block_diag_apply, diagonal_apply_ne _ hij, diagonal_apply_ne _ (mt _ hij)],
    exact prod.fst_eq_iff.mpr },
end

@[simp] lemma block_diag_block_diagonal [decidable_eq o] (M : o → matrix m n α) :
  block_diag (block_diagonal M) = M :=
funext $ λ k, ext $ λ i j, block_diagonal_apply_eq M i j _

@[simp] lemma block_diag_one [decidable_eq o] [decidable_eq m] [has_one α] :
  block_diag (1 : matrix (m × o) (m × o) α) = 1 :=
funext $ block_diag_diagonal _

end has_zero

@[simp] lemma block_diag_add [add_zero_class α] (M N : matrix (m × o) (n × o) α) :
  block_diag (M + N) = block_diag M + block_diag N :=
rfl

section
variables (o m n α)
/-- `matrix.block_diag` as an `add_monoid_hom`. -/
@[simps] def block_diag_add_monoid_hom [add_zero_class α] :
  matrix (m × o) (n × o) α →+ (o → matrix m n α) :=
{ to_fun := block_diag,
  map_zero' := block_diag_zero,
  map_add' := block_diag_add }
end

@[simp] lemma block_diag_neg [add_group α] (M : matrix (m × o) (n × o) α) :
  block_diag (-M) = - block_diag M :=
map_neg (block_diag_add_monoid_hom m n o α) M

@[simp] lemma block_diag_sub [add_group α] (M N : matrix (m × o) (n × o) α) :
  block_diag (M - N) = block_diag M - block_diag N :=
map_sub (block_diag_add_monoid_hom m n o α) M N

@[simp] lemma block_diag_smul {R : Type*} [monoid R] [add_monoid α] [distrib_mul_action R α]
  (x : R) (M : matrix (m × o) (n × o) α) : block_diag (x • M) = x • block_diag M :=
rfl

end block_diag

section block_diagonal'

variables [decidable_eq o]

section has_zero
variables [has_zero α] [has_zero β]

/-- `matrix.block_diagonal' M` turns `M : Π i, matrix (m i) (n i) α` into a
`Σ i, m i`-by-`Σ i, n i` block matrix which has the entries of `M` along the diagonal
and zero elsewhere.

This is the dependently-typed version of `matrix.block_diagonal`. -/
def block_diagonal' (M : Π i, matrix (m' i) (n' i) α) : matrix (Σ i, m' i) (Σ i, n' i) α :=
of $ (λ ⟨k, i⟩ ⟨k', j⟩, if h : k = k' then M k i (cast (congr_arg n' h.symm) j) else 0 :
  (Σ i, m' i) → (Σ i, n' i) → α)

-- TODO: set as an equation lemma for `block_diagonal'`, see mathlib4#3024
lemma block_diagonal'_apply' (M : Π i, matrix (m' i) (n' i) α) (k i k' j) :
  block_diagonal' M ⟨k, i⟩ ⟨k', j⟩ =
    if h : k = k' then M k i (cast (congr_arg n' h.symm) j) else 0 :=
rfl

lemma block_diagonal'_eq_block_diagonal (M : o → matrix m n α) {k k'} (i j) :
  block_diagonal M (i, k) (j, k') = block_diagonal' M ⟨k, i⟩ ⟨k', j⟩ :=
rfl

lemma block_diagonal'_submatrix_eq_block_diagonal (M : o → matrix m n α) :
  (block_diagonal' M).submatrix (prod.to_sigma ∘ prod.swap) (prod.to_sigma ∘ prod.swap) =
    block_diagonal M :=
matrix.ext $ λ ⟨k, i⟩ ⟨k', j⟩, rfl

lemma block_diagonal'_apply (M : Π i, matrix (m' i) (n' i) α) (ik jk) :
  block_diagonal' M ik jk = if h : ik.1 = jk.1 then
    M ik.1 ik.2 (cast (congr_arg n' h.symm) jk.2) else 0 :=
by { cases ik, cases jk, refl }

@[simp]
lemma block_diagonal'_apply_eq (M : Π i, matrix (m' i) (n' i) α) (k i j) :
  block_diagonal' M ⟨k, i⟩ ⟨k, j⟩ = M k i j :=
dif_pos rfl

lemma block_diagonal'_apply_ne (M : Π i, matrix (m' i) (n' i) α) {k k'} (i j) (h : k ≠ k') :
  block_diagonal' M ⟨k, i⟩ ⟨k', j⟩ = 0 :=
dif_neg h

lemma block_diagonal'_map (M : Π i, matrix (m' i) (n' i) α) (f : α → β) (hf : f 0 = 0) :
  (block_diagonal' M).map f = block_diagonal' (λ k, (M k).map f) :=
begin
  ext,
  simp only [map_apply, block_diagonal'_apply, eq_comm],
  rw [apply_dite f, hf],
end

@[simp] lemma block_diagonal'_transpose (M : Π i, matrix (m' i) (n' i) α) :
  (block_diagonal' M)ᵀ = block_diagonal' (λ k, (M k)ᵀ) :=
begin
  ext ⟨ii, ix⟩ ⟨ji, jx⟩,
  simp only [transpose_apply, block_diagonal'_apply],
  split_ifs; cc
end

@[simp] lemma block_diagonal'_conj_transpose {α} [add_monoid α] [star_add_monoid α]
  (M : Π i, matrix (m' i) (n' i) α) :
  (block_diagonal' M)ᴴ = block_diagonal' (λ k, (M k)ᴴ) :=
begin
  simp only [conj_transpose, block_diagonal'_transpose],
  exact block_diagonal'_map _ star (star_zero α),
end

@[simp] lemma block_diagonal'_zero :
  block_diagonal' (0 : Π i, matrix (m' i) (n' i) α) = 0 :=
by { ext, simp [block_diagonal'_apply] }

@[simp] lemma block_diagonal'_diagonal [Π i, decidable_eq (m' i)] (d : Π i, m' i → α) :
  block_diagonal' (λ k, diagonal (d k)) = diagonal (λ ik, d ik.1 ik.2) :=
begin
  ext ⟨i, k⟩ ⟨j, k'⟩,
  simp only [block_diagonal'_apply, diagonal],
  obtain rfl | hij := decidable.eq_or_ne i j,
  { simp, },
  { simp [hij] },
end

@[simp] lemma block_diagonal'_one [∀ i, decidable_eq (m' i)] [has_one α] :
  block_diagonal' (1 : Π i, matrix (m' i) (m' i) α) = 1 :=
show block_diagonal' (λ (i : o), diagonal (λ (_ : m' i), (1 : α))) = diagonal (λ _, 1),
by rw [block_diagonal'_diagonal]

end has_zero

@[simp] lemma block_diagonal'_add [add_zero_class α] (M N : Π i, matrix (m' i) (n' i) α) :
  block_diagonal' (M + N) = block_diagonal' M + block_diagonal' N :=
begin
  ext,
  simp only [block_diagonal'_apply, pi.add_apply],
  split_ifs; simp
end

section
variables (m' n' α)
/-- `matrix.block_diagonal'` as an `add_monoid_hom`. -/
@[simps] def block_diagonal'_add_monoid_hom [add_zero_class α] :
  (Π i, matrix (m' i) (n' i) α) →+ matrix (Σ i, m' i) (Σ i, n' i) α :=
{ to_fun := block_diagonal',
  map_zero' := block_diagonal'_zero,
  map_add' := block_diagonal'_add }
end

@[simp]

@[simp] lemma block_diagonal'_sub [add_group α] (M N : Π i, matrix (m' i) (n' i) α) :
  block_diagonal' (M - N) = block_diagonal' M - block_diagonal' N :=
map_sub (block_diagonal'_add_monoid_hom m' n' α) M N

@[simp] lemma block_diagonal'_mul [non_unital_non_assoc_semiring α]
  [Π i, fintype (n' i)] [fintype o]
  (M : Π i, matrix (m' i) (n' i) α) (N : Π i, matrix (n' i) (p' i) α) :
  block_diagonal' (λ k, M k ⬝ N k) = block_diagonal' M ⬝ block_diagonal' N :=
begin
  ext ⟨k, i⟩ ⟨k', j⟩,
  simp only [block_diagonal'_apply, mul_apply, ← finset.univ_sigma_univ, finset.sum_sigma],
  rw fintype.sum_eq_single k,
  { split_ifs; simp },
  { intros j' hj', exact finset.sum_eq_zero (λ _ _, by rw [dif_neg hj'.symm, zero_mul]) },
end

section
variables (α m')
/-- `matrix.block_diagonal'` as a `ring_hom`. -/
@[simps]
def block_diagonal'_ring_hom [Π i, decidable_eq (m' i)] [fintype o] [Π i, fintype (m' i)]
  [non_assoc_semiring α] :
  (Π i, matrix (m' i) (m' i) α) →+* matrix (Σ i, m' i) (Σ i, m' i) α :=
{ to_fun := block_diagonal',
  map_one' := block_diagonal'_one,
  map_mul' := block_diagonal'_mul,
  ..block_diagonal'_add_monoid_hom m' m' α }
end

@[simp] lemma block_diagonal'_pow [Π i, decidable_eq (m' i)] [fintype o] [Π i, fintype (m' i)]
  [semiring α] (M : Π i, matrix (m' i) (m' i) α) (n : ℕ)  :
  block_diagonal' (M ^ n) = block_diagonal' M ^ n :=
map_pow (block_diagonal'_ring_hom m' α) M n

@[simp] lemma block_diagonal'_smul {R : Type*} [semiring R] [add_comm_monoid α] [module R α]
  (x : R) (M : Π i, matrix (m' i) (n' i) α) : block_diagonal' (x • M) = x • block_diagonal' M :=
by { ext, simp only [block_diagonal'_apply, pi.smul_apply], split_ifs; simp }

end block_diagonal'

section block_diag'

/-- Extract a block from the diagonal of a block diagonal matrix.

This is the block form of `matrix.diag`, and the left-inverse of `matrix.block_diagonal'`. -/
def block_diag' (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) : matrix (m' k) (n' k) α :=
of $ λ i j, M ⟨k, i⟩ ⟨k, j⟩

-- TODO: set as an equation lemma for `block_diag'`, see mathlib4#3024
lemma block_diag'_apply (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) (i j) :
  block_diag' M k i j = M ⟨k, i⟩ ⟨k, j⟩ := rfl

lemma block_diag'_map (M : matrix (Σ i, m' i) (Σ i, n' i) α) (f : α → β) :
  block_diag' (M.map f) = λ k, (block_diag' M k).map f :=
rfl

@[simp] lemma block_diag'_transpose (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) :
  block_diag' Mᵀ k = (block_diag' M k)ᵀ :=
ext $ λ i j, rfl

@[simp] lemma block_diag'_conj_transpose
  {α : Type*} [add_monoid α] [star_add_monoid α] (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) :
  block_diag' Mᴴ k = (block_diag' M k)ᴴ :=
ext $ λ i j, rfl

section has_zero
variables [has_zero α] [has_zero β]

@[simp] lemma block_diag'_zero :
  block_diag' (0 : matrix (Σ i, m' i) (Σ i, n' i) α) = 0 :=
rfl

@[simp] lemma block_diag'_diagonal [decidable_eq o] [Π i, decidable_eq (m' i)]
  (d : (Σ i, m' i) → α) (k : o) :
  block_diag' (diagonal d) k = diagonal (λ i, d ⟨k, i⟩) :=
ext $ λ i j, begin
  obtain rfl | hij := decidable.eq_or_ne i j,
  { rw [block_diag'_apply, diagonal_apply_eq, diagonal_apply_eq] },
  { rw [block_diag'_apply, diagonal_apply_ne _ hij, diagonal_apply_ne _ (mt (λ h, _) hij)],
    cases h, refl },
end

@[simp] lemma block_diag'_block_diagonal' [decidable_eq o] (M : Π i, matrix (m' i) (n' i) α) :
  block_diag' (block_diagonal' M) = M :=
funext $ λ k, ext $ λ i j, block_diagonal'_apply_eq M _ _ _

@[simp] lemma block_diag'_one [decidable_eq o] [Π i, decidable_eq (m' i)] [has_one α] :
  block_diag' (1 : matrix (Σ i, m' i) (Σ i, m' i) α) = 1 :=
funext $ block_diag'_diagonal _

end has_zero

@[simp] lemma block_diag'_add [add_zero_class α] (M N : matrix (Σ i, m' i) (Σ i, n' i) α) :
  block_diag' (M + N) = block_diag' M + block_diag' N :=
rfl

section
variables (m' n' α)
/-- `matrix.block_diag'` as an `add_monoid_hom`. -/
@[simps] def block_diag'_add_monoid_hom [add_zero_class α] :
  matrix (Σ i, m' i) (Σ i, n' i) α →+ Π i, matrix (m' i) (n' i) α :=
{ to_fun := block_diag',
  map_zero' := block_diag'_zero,
  map_add' := block_diag'_add }
end

@[simp] lemma block_diag'_neg [add_group α] (M : matrix (Σ i, m' i) (Σ i, n' i) α) :
  block_diag' (-M) = - block_diag' M :=
map_neg (block_diag'_add_monoid_hom m' n' α) M

@[simp] lemma block_diag'_sub [add_group α] (M N : matrix (Σ i, m' i) (Σ i, n' i) α) :
  block_diag' (M - N) = block_diag' M - block_diag' N :=
map_sub (block_diag'_add_monoid_hom m' n' α) M N

@[simp] lemma block_diag'_smul {R : Type*} [monoid R] [add_monoid α] [distrib_mul_action R α]
  (x : R) (M : matrix (Σ i, m' i) (Σ i, n' i) α) : block_diag' (x • M) = x • block_diag' M :=
rfl

end block_diag'

section
variables [comm_ring R]

lemma to_block_mul_eq_mul {m n k : Type*} [fintype n] (p : m → Prop) (q : k → Prop)
  (A : matrix m n R) (B : matrix n k R) :
  (A ⬝ B).to_block p q = A.to_block p ⊤ ⬝ B.to_block ⊤ q :=
begin
  ext i k,
  simp only [to_block_apply, mul_apply],
  rw finset.sum_subtype,
  simp [has_top.top, complete_lattice.top, bounded_order.top],
end

lemma to_block_mul_eq_add
  {m n k : Type*} [fintype n] (p : m → Prop) (q : n → Prop) [decidable_pred q] (r : k → Prop)
  (A : matrix m n R) (B : matrix n k R) :
  (A ⬝ B).to_block p r =
    A.to_block p q ⬝ B.to_block q r + A.to_block p (λ i, ¬ q i) ⬝ B.to_block (λ i, ¬ q i) r :=
begin
  classical,
  ext i k,
  simp only [to_block_apply, mul_apply, pi.add_apply],
  convert (fintype.sum_subtype_add_sum_subtype q (λ x, A ↑i x * B x ↑k)).symm
end

end

end matrix


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Morenikeji Neri

! This file was ported from Lean 3 source module ring_theory.principal_ideal_domain
! leanprover-community/mathlib commit 6010cf523816335f7bae7f8584cb2edaace73940
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.EuclideanDomain.Instances
import Mathlib.RingTheory.UniqueFactorizationDomain

/-!
# Principal ideal rings and principal ideal domains

A principal ideal ring (PIR) is a ring in which all left ideals are principal. A
principal ideal domain (PID) is an integral domain which is a principal ideal ring.

# Main definitions

Note that for principal ideal domains, one should use
`[IsDomain R] [IsPrincipalIdealRing R]`. There is no explicit definition of a PID.
Theorems about PID's are in the `principal_ideal_ring` namespace.

- `IsPrincipalIdealRing`: a predicate on rings, saying that every left ideal is principal.
- `generator`: a generator of a principal ideal (or more generally submodule)
- `to_unique_factorization_monoid`: a PID is a unique factorization domain

# Main results

- `to_maximal_ideal`: a non-zero prime ideal in a PID is maximal.
- `EuclideanDomain.to_principal_ideal_domain` : a Euclidean domain is a PID.

-/

universe u v

variable {R : Type u} {M : Type v}

open Set Function

open Submodule

open Classical

section

variable [Ring R] [AddCommGroup M] [Module R M]

-- Porting note: renamed field to `principal'` and added `principal` to fix explicit argument
/-- An `R`-submodule of `M` is principal if it is generated by one element. -/
@[mk_iff]
class Submodule.IsPrincipal (S : Submodule R M) : Prop where
  principal' : ∃ a, S = span R {a}
#align submodule.is_principal Submodule.IsPrincipal

theorem Submodule.IsPrincipal.principal (S : Submodule R M) [Submodule.IsPrincipal S] :
    ∃ a, S = span R {a} :=
  Submodule.IsPrincipal.principal'
#align submodule.is_principal.principal Submodule.IsPrincipal.principal

instance bot_isPrincipal : (⊥ : Submodule R M).IsPrincipal :=
  ⟨⟨0, by simp⟩⟩
#align bot_is_principal bot_isPrincipal

instance top_isPrincipal : (⊤ : Submodule R R).IsPrincipal :=
  ⟨⟨1, Ideal.span_singleton_one.symm⟩⟩
#align top_is_principal top_isPrincipal

variable (R)

/-- A ring is a principal ideal ring if all (left) ideals are principal. -/
@[mk_iff isPrincipalIdealRing_iff]
class IsPrincipalIdealRing (R : Type u) [Ring R] : Prop where
  principal : ∀ S : Ideal R, S.IsPrincipal
#align is_principal_ideal_ring IsPrincipalIdealRing

attribute [instance] IsPrincipalIdealRing.principal

instance (priority := 100) DivisionRing.isPrincipalIdealRing (K : Type u) [DivisionRing K] :
    IsPrincipalIdealRing K where
  principal S := by
    rcases Ideal.eq_bot_or_top S with (rfl | rfl)
    apply bot_isPrincipal
    apply top_isPrincipal
#align division_ring.is_principal_ideal_ring DivisionRing.isPrincipalIdealRing

end

namespace Submodule.IsPrincipal

variable [AddCommGroup M]

section Ring

variable [Ring R] [Module R M]

/-- `generator I`, if `I` is a principal submodule, is an `x ∈ M` such that `span R {x} = I` -/
noncomputable def generator (S : Submodule R M) [S.IsPrincipal] : M :=
  Classical.choose (principal S)
#align submodule.is_principal.generator Submodule.IsPrincipal.generator

theorem span_singleton_generator (S : Submodule R M) [S.IsPrincipal] : span R {generator S} = S :=
  Eq.symm (Classical.choose_spec (principal S))
#align submodule.is_principal.span_singleton_generator Submodule.IsPrincipal.span_singleton_generator

theorem _root_.Ideal.span_singleton_generator (I : Ideal R) [I.IsPrincipal] :
    Ideal.span ({generator I} : Set R) = I :=
  Eq.symm (Classical.choose_spec (principal I))
#align ideal.span_singleton_generator Ideal.span_singleton_generator

@[simp]
theorem generator_mem (S : Submodule R M) [S.IsPrincipal] : generator S ∈ S := by
  conv_rhs => rw [← span_singleton_generator S]
  exact subset_span (mem_singleton _)
#align submodule.is_principal.generator_mem Submodule.IsPrincipal.generator_mem

theorem mem_iff_eq_smul_generator (S : Submodule R M) [S.IsPrincipal] {x : M} :
    x ∈ S ↔ ∃ s : R, x = s • generator S := by
  simp_rw [@eq_comm _ x, ← mem_span_singleton, span_singleton_generator]
#align submodule.is_principal.mem_iff_eq_smul_generator Submodule.IsPrincipal.mem_iff_eq_smul_generator

theorem eq_bot_iff_generator_eq_zero (S : Submodule R M) [S.IsPrincipal] :
    S = ⊥ ↔ generator S = 0 := by rw [← @span_singleton_eq_bot R M, span_singleton_generator]
#align submodule.is_principal.eq_bot_iff_generator_eq_zero Submodule.IsPrincipal.eq_bot_iff_generator_eq_zero

end Ring

section CommRing

variable [CommRing R] [Module R M]

theorem mem_iff_generator_dvd (S : Ideal R) [S.IsPrincipal] {x : R} : x ∈ S ↔ generator S ∣ x :=
  (mem_iff_eq_smul_generator S).trans (exists_congr fun a => by simp only [mul_comm, smul_eq_mul])
#align submodule.is_principal.mem_iff_generator_dvd Submodule.IsPrincipal.mem_iff_generator_dvd

theorem prime_generator_of_isPrime (S : Ideal R) [Submodule.IsPrincipal S] [is_prime : S.IsPrime]
    (ne_bot : S ≠ ⊥) : Prime (generator S) :=
  ⟨fun h => ne_bot ((eq_bot_iff_generator_eq_zero S).2 h), fun h =>
    is_prime.ne_top (S.eq_top_of_isUnit_mem (generator_mem S) h), fun _ _ => by
    simpa only [← mem_iff_generator_dvd S] using is_prime.2⟩
#align submodule.is_principal.prime_generator_of_is_prime Submodule.IsPrincipal.prime_generator_of_isPrime

-- Note that the converse may not hold if `ϕ` is not injective.
set_option synthInstance.etaExperiment true in
theorem generator_map_dvd_of_mem {N : Submodule R M} (ϕ : M →ₗ[R] R) [(N.map ϕ).IsPrincipal] {x : M}
    (hx : x ∈ N) : generator (N.map ϕ) ∣ ϕ x := by
  rw [← mem_iff_generator_dvd, Submodule.mem_map]
  exact ⟨x, hx, rfl⟩
#align submodule.is_principal.generator_map_dvd_of_mem Submodule.IsPrincipal.generator_map_dvd_of_mem

-- Note that the converse may not hold if `ϕ` is not injective.
set_option synthInstance.etaExperiment true in
theorem generator_submoduleImage_dvd_of_mem {N O : Submodule R M} (hNO : N ≤ O) (ϕ : O →ₗ[R] R)
    [(ϕ.submoduleImage N).IsPrincipal] {x : M} (hx : x ∈ N) :
    generator (ϕ.submoduleImage N) ∣ ϕ ⟨x, hNO hx⟩ := by
  rw [← mem_iff_generator_dvd, LinearMap.mem_submoduleImage_of_le hNO]
  exact ⟨x, hx, rfl⟩
#align submodule.is_principal.generator_submodule_image_dvd_of_mem Submodule.IsPrincipal.generator_submoduleImage_dvd_of_mem

end CommRing

end Submodule.IsPrincipal

namespace IsPrime

open Submodule.IsPrincipal Ideal

-- TODO -- for a non-ID one could perhaps prove that if p < q are prime then q maximal;
-- 0 isn't prime in a non-ID PIR but the Krull dimension is still <= 1.
-- The below result follows from this, but we could also use the below result to
-- prove this (quotient out by p).
theorem to_maximal_ideal [CommRing R] [IsDomain R] [IsPrincipalIdealRing R] {S : Ideal R}
    [hpi : IsPrime S] (hS : S ≠ ⊥) : IsMaximal S :=
  isMaximal_iff.2
    ⟨(ne_top_iff_one S).1 hpi.1, by
      intro T x hST hxS hxT
      cases' (mem_iff_generator_dvd _).1 (hST <| generator_mem S) with z hz
      cases hpi.mem_or_mem (show generator T * z ∈ S from hz ▸ generator_mem S)
      case inl h =>
        have hTS : T ≤ S
        rwa [← T.span_singleton_generator, Ideal.span_le, singleton_subset_iff]
        exact (hxS <| hTS hxT).elim
      case inr h =>
        cases' (mem_iff_generator_dvd _).1 h with y hy
        have : generator S ≠ 0 := mt (eq_bot_iff_generator_eq_zero _).2 hS
        rw [← mul_one (generator S), hy, mul_left_comm, mul_right_inj' this] at hz
        exact hz.symm ▸ T.mul_mem_right _ (generator_mem T)⟩
#align is_prime.to_maximal_ideal IsPrime.to_maximal_ideal

end IsPrime

section

open EuclideanDomain

variable [EuclideanDomain R]

theorem mod_mem_iff {S : Ideal R} {x y : R} (hy : y ∈ S) : x % y ∈ S ↔ x ∈ S :=
  ⟨fun hxy => div_add_mod x y ▸ S.add_mem (S.mul_mem_right _ hy) hxy, fun hx =>
    (mod_eq_sub_mul_div x y).symm ▸ S.sub_mem hx (S.mul_mem_right _ hy)⟩
#align mod_mem_iff mod_mem_iff

-- see Note [lower instance priority]
instance (priority := 100) EuclideanDomain.to_principal_ideal_domain : IsPrincipalIdealRing R
    where principal S :=
    ⟨if h : { x : R | x ∈ S ∧ x ≠ 0 }.Nonempty then
        have wf : WellFounded (EuclideanDomain.r : R → R → Prop) := EuclideanDomain.r_wellFounded
        have hmin :
          WellFounded.min wf { x : R | x ∈ S ∧ x ≠ 0 } h ∈ S ∧
            WellFounded.min wf { x : R | x ∈ S ∧ x ≠ 0 } h ≠ 0 :=
          WellFounded.min_mem wf { x : R | x ∈ S ∧ x ≠ 0 } h
        ⟨WellFounded.min wf { x : R | x ∈ S ∧ x ≠ 0 } h,
          Submodule.ext fun x =>
            ⟨fun hx =>
              div_add_mod x (WellFounded.min wf { x : R | x ∈ S ∧ x ≠ 0 } h) ▸
                (Ideal.mem_span_singleton.2 <|
                  dvd_add (dvd_mul_right _ _) <|
                    by
                    have :
                      x % WellFounded.min wf { x : R | x ∈ S ∧ x ≠ 0 } h ∉
                        { x : R | x ∈ S ∧ x ≠ 0 } :=
                      fun h₁ => WellFounded.not_lt_min wf _ h h₁ (mod_lt x hmin.2)
                    have : x % WellFounded.min wf { x : R | x ∈ S ∧ x ≠ 0 } h = 0 :=
                      by
                      simp only [not_and_or, Set.mem_setOf_eq, not_ne_iff] at this
                      exact this.neg_resolve_left <| (mod_mem_iff hmin.1).2 hx
                    simp [*]),
              fun hx =>
              let ⟨y, hy⟩ := Ideal.mem_span_singleton.1 hx
              hy.symm ▸ S.mul_mem_right _ hmin.1⟩⟩
      else
        ⟨0,
          Submodule.ext fun a => by
            rw [← @Submodule.bot_coe R R _ _ _, span_eq, Submodule.mem_bot]
            exact
              ⟨fun haS => by_contra fun ha0 => h ⟨a, ⟨haS, ha0⟩⟩, fun h₁ =>
                h₁.symm ▸ S.zero_mem⟩⟩⟩
#align euclidean_domain.to_principal_ideal_domain EuclideanDomain.to_principal_ideal_domain

end

theorem IsField.isPrincipalIdealRing {R : Type _} [CommRing R] (h : IsField R) :
    IsPrincipalIdealRing R :=
  @EuclideanDomain.to_principal_ideal_domain R (@Field.toEuclideanDomain R h.toField)
#align is_field.is_principal_ideal_ring IsField.isPrincipalIdealRing

namespace PrincipalIdealRing

open IsPrincipalIdealRing

-- see Note [lower instance priority]
instance (priority := 100) isNoetherianRing [Ring R] [IsPrincipalIdealRing R] :
    IsNoetherianRing R :=
  isNoetherianRing_iff.2
    ⟨fun s : Ideal R =>
      by
      rcases(IsPrincipalIdealRing.principal s).principal with ⟨a, rfl⟩
      rw [← Finset.coe_singleton]
      exact ⟨{a}, SetLike.coe_injective rfl⟩⟩
#align principal_ideal_ring.is_noetherian_ring PrincipalIdealRing.isNoetherianRing

theorem isMaximal_of_irreducible [CommRing R] [IsPrincipalIdealRing R] {p : R}
    (hp : Irreducible p) : Ideal.IsMaximal (span R ({p} : Set R)) :=
  ⟨⟨mt Ideal.span_singleton_eq_top.1 hp.1, fun I hI =>
      by
      rcases principal I with ⟨a, rfl⟩
      erw [Ideal.span_singleton_eq_top]
      rcases Ideal.span_singleton_le_span_singleton.1 (le_of_lt hI) with ⟨b, rfl⟩
      refine' (of_irreducible_mul hp).resolve_right (mt (fun hb => _) (not_le_of_lt hI))
      erw [Ideal.span_singleton_le_span_singleton, IsUnit.mul_right_dvd hb]⟩⟩
#align principal_ideal_ring.is_maximal_of_irreducible PrincipalIdealRing.isMaximal_of_irreducible

variable [CommRing R] [IsDomain R] [IsPrincipalIdealRing R]

theorem irreducible_iff_prime {p : R} : Irreducible p ↔ Prime p :=
  ⟨fun hp => (Ideal.span_singleton_prime hp.ne_zero).1 <| (isMaximal_of_irreducible hp).isPrime,
    Prime.irreducible⟩
#align principal_ideal_ring.irreducible_iff_prime PrincipalIdealRing.irreducible_iff_prime

theorem associates_irreducible_iff_prime : ∀ {p : Associates R}, Irreducible p ↔ Prime p :=
  fun {p} => (Associates.irreducible_iff_prime_iff.1 fun _ => irreducible_iff_prime) p
#align principal_ideal_ring.associates_irreducible_iff_prime PrincipalIdealRing.associates_irreducible_iff_prime

section

open Classical

/-- `factors a` is a multiset of irreducible elements whose product is `a`, up to units -/
noncomputable def factors (a : R) : Multiset R :=
  if h : a = 0 then ∅ else Classical.choose (WfDvdMonoid.exists_factors a h)
#align principal_ideal_ring.factors PrincipalIdealRing.factors

theorem factors_spec (a : R) (h : a ≠ 0) :
    (∀ b ∈ factors a, Irreducible b) ∧ Associated (factors a).prod a := by
  unfold factors; rw [dif_neg h]
  exact Classical.choose_spec (WfDvdMonoid.exists_factors a h)
#align principal_ideal_ring.factors_spec PrincipalIdealRing.factors_spec

theorem ne_zero_of_mem_factors {R : Type v} [CommRing R] [IsDomain R] [IsPrincipalIdealRing R]
    {a b : R} (ha : a ≠ 0) (hb : b ∈ factors a) : b ≠ 0 :=
  Irreducible.ne_zero ((factors_spec a ha).1 b hb)
#align principal_ideal_ring.ne_zero_of_mem_factors PrincipalIdealRing.ne_zero_of_mem_factors

theorem mem_submonoid_of_factors_subset_of_units_subset (s : Submonoid R) {a : R} (ha : a ≠ 0)
    (hfac : ∀ b ∈ factors a, b ∈ s) (hunit : ∀ c : Rˣ, (c : R) ∈ s) : a ∈ s := by
  rcases(factors_spec a ha).2 with ⟨c, hc⟩
  rw [← hc]
  exact mul_mem (multiset_prod_mem _ hfac) (hunit _)
#align principal_ideal_ring.mem_submonoid_of_factors_subset_of_units_subset PrincipalIdealRing.mem_submonoid_of_factors_subset_of_units_subset

/-- If a `RingHom` maps all units and all factors of an element `a` into a submonoid `s`, then it
also maps `a` into that submonoid. -/
theorem ringHom_mem_submonoid_of_factors_subset_of_units_subset {R S : Type _} [CommRing R]
    [IsDomain R] [IsPrincipalIdealRing R] [Semiring S] (f : R →+* S) (s : Submonoid S) (a : R)
    (ha : a ≠ 0) (h : ∀ b ∈ factors a, f b ∈ s) (hf : ∀ c : Rˣ, f c ∈ s) : f a ∈ s :=
  mem_submonoid_of_factors_subset_of_units_subset (s.comap f.toMonoidHom) ha h hf
#align principal_ideal_ring.ring_hom_mem_submonoid_of_factors_subset_of_units_subset PrincipalIdealRing.ringHom_mem_submonoid_of_factors_subset_of_units_subset

-- see Note [lower instance priority]
/-- A principal ideal domain has unique factorization -/
instance (priority := 100) to_uniqueFactorizationMonoid : UniqueFactorizationMonoid R :=
  { (IsNoetherianRing.wfDvdMonoid : WfDvdMonoid R) with
    irreducible_iff_prime := PrincipalIdealRing.irreducible_iff_prime }
#align principal_ideal_ring.to_unique_factorization_monoid PrincipalIdealRing.to_uniqueFactorizationMonoid

end

end PrincipalIdealRing

section Surjective

open Submodule

variable {S N : Type _} [Ring R] [AddCommGroup M] [AddCommGroup N] [Ring S]

variable [Module R M] [Module R N]

set_option synthInstance.etaExperiment true in
theorem Submodule.IsPrincipal.of_comap (f : M →ₗ[R] N) (hf : Function.Surjective f)
    (S : Submodule R N) [hI : IsPrincipal (S.comap f)] : IsPrincipal S :=
  ⟨⟨f (IsPrincipal.generator (S.comap f)), by
      rw [← Set.image_singleton, ← Submodule.map_span, IsPrincipal.span_singleton_generator,
        Submodule.map_comap_eq_of_surjective hf]⟩⟩
#align submodule.is_principal.of_comap Submodule.IsPrincipal.of_comap

set_option synthInstance.etaExperiment true in
theorem Ideal.IsPrincipal.of_comap (f : R →+* S) (hf : Function.Surjective f) (I : Ideal S)
    [hI : IsPrincipal (I.comap f)] : IsPrincipal I :=
  ⟨⟨f (IsPrincipal.generator (I.comap f)), by
      rw [Ideal.submodule_span_eq, ← Set.image_singleton, ← Ideal.map_span,
        Ideal.span_singleton_generator, Ideal.map_comap_of_surjective f hf]⟩⟩
#align ideal.is_principal.of_comap Ideal.IsPrincipal.of_comap

set_option synthInstance.etaExperiment true in
/-- The surjective image of a principal ideal ring is again a principal ideal ring. -/
theorem IsPrincipalIdealRing.of_surjective [IsPrincipalIdealRing R] (f : R →+* S)
    (hf : Function.Surjective f) : IsPrincipalIdealRing S :=
  ⟨fun I => Ideal.IsPrincipal.of_comap f hf I⟩
#align is_principal_ideal_ring.of_surjective IsPrincipalIdealRing.of_surjective

end Surjective

section

open Ideal

variable [CommRing R] [IsDomain R] [IsPrincipalIdealRing R] [GCDMonoid R]

theorem span_gcd (x y : R) : span ({gcd x y} : Set R) = span ({x, y} : Set R) := by
  obtain ⟨d, hd⟩ := IsPrincipalIdealRing.principal (span ({x, y} : Set R))
  rw [submodule_span_eq] at hd
  rw [hd]
  suffices Associated d (gcd x y) by
    obtain ⟨D, HD⟩ := this
    rw [← HD]
    exact span_singleton_mul_right_unit D.isUnit _
  apply associated_of_dvd_dvd
  · rw [dvd_gcd_iff]
    constructor <;> rw [← Ideal.mem_span_singleton, ← hd, Ideal.mem_span_pair]
    · use 1, 0
      rw [one_mul, MulZeroClass.zero_mul, add_zero]
    · use 0, 1
      rw [one_mul, MulZeroClass.zero_mul, zero_add]
  · obtain ⟨r, s, rfl⟩ : ∃ r s, r * x + s * y = d := by
      rw [← Ideal.mem_span_pair, hd, Ideal.mem_span_singleton]
    apply dvd_add <;> apply dvd_mul_of_dvd_right
    exacts[gcd_dvd_left x y, gcd_dvd_right x y]
#align span_gcd span_gcd

theorem gcd_dvd_iff_exists (a b : R) {z} : gcd a b ∣ z ↔ ∃ x y, z = a * x + b * y := by
  simp_rw [mul_comm a, mul_comm b, @eq_comm _ z, ← Ideal.mem_span_pair, ← span_gcd,
    Ideal.mem_span_singleton]
#align gcd_dvd_iff_exists gcd_dvd_iff_exists

/-- **Bézout's lemma** -/
theorem exists_gcd_eq_mul_add_mul (a b : R) : ∃ x y, gcd a b = a * x + b * y := by
  rw [← gcd_dvd_iff_exists]
#align exists_gcd_eq_mul_add_mul exists_gcd_eq_mul_add_mul

theorem gcd_isUnit_iff (x y : R) : IsUnit (gcd x y) ↔ IsCoprime x y := by
  rw [IsCoprime, ← Ideal.mem_span_pair, ← span_gcd, ← span_singleton_eq_top, eq_top_iff_one]
#align gcd_is_unit_iff gcd_isUnit_iff

-- this should be proved for UFDs surely?
theorem isCoprime_of_dvd (x y : R) (nonzero : ¬(x = 0 ∧ y = 0))
    (H : ∀ z ∈ nonunits R, z ≠ 0 → z ∣ x → ¬z ∣ y) : IsCoprime x y := by
  rw [← gcd_isUnit_iff]
  by_contra h
  refine' H _ h _ (gcd_dvd_left _ _) (gcd_dvd_right _ _)
  rwa [Ne, gcd_eq_zero_iff]
#align is_coprime_of_dvd isCoprime_of_dvd

-- this should be proved for UFDs surely?
theorem dvd_or_coprime (x y : R) (h : Irreducible x) : x ∣ y ∨ IsCoprime x y := by
  refine' or_iff_not_imp_left.2 fun h' => _
  apply isCoprime_of_dvd
  · rintro ⟨rfl, rfl⟩
    simp at h
  · rintro z nu - ⟨w, rfl⟩ dy
    refine' h' (dvd_trans _ dy)
    simpa using mul_dvd_mul_left z (isUnit_iff_dvd_one.1 <| (of_irreducible_mul h).resolve_left nu)
#align dvd_or_coprime dvd_or_coprime

theorem isCoprime_of_irreducible_dvd {x y : R} (nonzero : ¬(x = 0 ∧ y = 0))
    (H : ∀ z : R, Irreducible z → z ∣ x → ¬z ∣ y) : IsCoprime x y := by
  apply isCoprime_of_dvd x y nonzero
  intro z znu znz zx zy
  obtain ⟨i, h1, h2⟩ := WfDvdMonoid.exists_irreducible_factor znu znz
  apply H i h1 <;>
    · apply dvd_trans h2
      assumption
#align is_coprime_of_irreducible_dvd isCoprime_of_irreducible_dvd

theorem isCoprime_of_prime_dvd {x y : R} (nonzero : ¬(x = 0 ∧ y = 0))
    (H : ∀ z : R, Prime z → z ∣ x → ¬z ∣ y) : IsCoprime x y :=
  isCoprime_of_irreducible_dvd nonzero fun z zi => H z <| GCDMonoid.prime_of_irreducible zi
#align is_coprime_of_prime_dvd isCoprime_of_prime_dvd

theorem Irreducible.coprime_iff_not_dvd {p n : R} (pp : Irreducible p) : IsCoprime p n ↔ ¬p ∣ n :=
  by
  constructor
  · intro co H
    apply pp.not_unit
    rw [isUnit_iff_dvd_one]
    apply IsCoprime.dvd_of_dvd_mul_left co
    rw [mul_one n]
    exact H
  · intro nd
    apply isCoprime_of_irreducible_dvd
    · rintro ⟨hp, -⟩
      exact pp.ne_zero hp
    rintro z zi zp zn
    exact nd ((zi.associated_of_dvd pp zp).symm.dvd.trans zn)
#align irreducible.coprime_iff_not_dvd Irreducible.coprime_iff_not_dvd

theorem Prime.coprime_iff_not_dvd {p n : R} (pp : Prime p) : IsCoprime p n ↔ ¬p ∣ n :=
  pp.irreducible.coprime_iff_not_dvd
#align prime.coprime_iff_not_dvd Prime.coprime_iff_not_dvd

theorem Irreducible.dvd_iff_not_coprime {p n : R} (hp : Irreducible p) : p ∣ n ↔ ¬IsCoprime p n :=
  iff_not_comm.2 hp.coprime_iff_not_dvd
#align irreducible.dvd_iff_not_coprime Irreducible.dvd_iff_not_coprime

theorem Irreducible.coprime_pow_of_not_dvd {p a : R} (m : ℕ) (hp : Irreducible p) (h : ¬p ∣ a) :
    IsCoprime a (p ^ m) :=
  (hp.coprime_iff_not_dvd.2 h).symm.pow_right
#align irreducible.coprime_pow_of_not_dvd Irreducible.coprime_pow_of_not_dvd

theorem Irreducible.coprime_or_dvd {p : R} (hp : Irreducible p) (i : R) : IsCoprime p i ∨ p ∣ i :=
  (_root_.em _).imp_right hp.dvd_iff_not_coprime.2
#align irreducible.coprime_or_dvd Irreducible.coprime_or_dvd

theorem exists_associated_pow_of_mul_eq_pow' {a b c : R} (hab : IsCoprime a b) {k : ℕ}
    (h : a * b = c ^ k) : ∃ d : R, Associated (d ^ k) a :=
  exists_associated_pow_of_mul_eq_pow ((gcd_isUnit_iff _ _).mpr hab) h
#align exists_associated_pow_of_mul_eq_pow' exists_associated_pow_of_mul_eq_pow'

end

section PrincipalOfPrime

open Set Ideal

variable (R) [CommRing R]

/-- `nonPrincipals R` is the set of all ideals of `R` that are not principal ideals. -/
def nonPrincipals :=
  { I : Ideal R | ¬I.IsPrincipal }
#align non_principals nonPrincipals

theorem nonPrincipals_def {I : Ideal R} : I ∈ nonPrincipals R ↔ ¬I.IsPrincipal :=
  Iff.rfl
#align non_principals_def nonPrincipals_def

variable {R}

theorem nonPrincipals_eq_empty_iff : nonPrincipals R = ∅ ↔ IsPrincipalIdealRing R := by
  simp [Set.eq_empty_iff_forall_not_mem, isPrincipalIdealRing_iff, nonPrincipals_def]
#align non_principals_eq_empty_iff nonPrincipals_eq_empty_iff

/-- Any chain in the set of non-principal ideals has an upper bound which is non-principal.
(Namely, the union of the chain is such an upper bound.)
-/
theorem nonPrincipals_zorn (c : Set (Ideal R)) (hs : c ⊆ nonPrincipals R)
    (hchain : IsChain (· ≤ ·) c) {K : Ideal R} (hKmem : K ∈ c) :
    ∃ I ∈ nonPrincipals R, ∀ J ∈ c, J ≤ I := by
  refine' ⟨supₛ c, _, fun J hJ => le_supₛ hJ⟩
  rintro ⟨x, hx⟩
  have hxmem : x ∈ supₛ c := hx.symm ▸ Submodule.mem_span_singleton_self x
  obtain ⟨J, hJc, hxJ⟩ := (Submodule.mem_supₛ_of_directed ⟨K, hKmem⟩ hchain.directedOn).1 hxmem
  have hsupₛJ : supₛ c = J := le_antisymm (by simp [hx, Ideal.span_le, hxJ]) (le_supₛ hJc)
  specialize hs hJc
  rw [← hsupₛJ, hx, nonPrincipals_def] at hs
  exact hs ⟨⟨x, rfl⟩⟩
#align non_principals_zorn nonPrincipals_zorn

/-- If all prime ideals in a commutative ring are principal, so are all other ideals. -/
theorem IsPrincipalIdealRing.of_prime (H : ∀ P : Ideal R, P.IsPrime → P.IsPrincipal) :
    IsPrincipalIdealRing R := by
  -- Suppose the set of `nonPrincipals` is not empty.
  rw [← nonPrincipals_eq_empty_iff, Set.eq_empty_iff_forall_not_mem]
  intro J hJ
  -- We will show a maximal element `I ∈ nonPrincipals R` (which exists by Zorn) is prime.
  obtain ⟨I, Ibad, -, Imax⟩ := zorn_nonempty_partialOrder₀ (nonPrincipals R) nonPrincipals_zorn _ hJ
  have Imax' : ∀ {J}, I < J → J.IsPrincipal :=
    by
    intro J hJ
    by_contra He
    exact hJ.ne (Imax _ ((nonPrincipals_def R).2 He) hJ.le).symm
  by_cases hI1 : I = ⊤
  · subst hI1
    exact Ibad top_isPrincipal
  -- Let `x y : R` with `x * y ∈ I` and suppose WLOG `y ∉ I`.
  refine' Ibad (H I ⟨hI1, fun {x y} hxy => or_iff_not_imp_right.mpr fun hy => _⟩)
  obtain ⟨a, ha⟩ : (I ⊔ span {y}).IsPrincipal :=
    Imax' (left_lt_sup.mpr (mt I.span_singleton_le_iff_mem.mp hy))
  -- Then `x ∈ I.colon (span {y})`, which is equal to `I` if it's not principal.
  suffices He : ¬(I.colon (span {y})).IsPrincipal
  · rw [← Imax _ ((nonPrincipals_def R).2 He) fun a ha =>
        Ideal.mem_colon_singleton.2 (mul_mem_right _ _ ha)]
    exact Ideal.mem_colon_singleton.2 hxy
  -- So suppose for the sake of contradiction that both `I ⊔ span {y}` and `I.colon (span {y})`
  -- are principal.
  rintro ⟨b, hb⟩
  -- We will show `I` is generated by `a * b`.
  refine (nonPrincipals_def _).1 Ibad ⟨a * b, ?_⟩
  refine'
    le_antisymm (α := Ideal R) (fun i hi => _) <| (span_singleton_mul_span_singleton a b).ge.trans _
  · have hisup : i ∈ I ⊔ span {y} := Ideal.mem_sup_left hi
    have : y ∈ I ⊔ span {y} := Ideal.mem_sup_right (Ideal.mem_span_singleton_self y)
    erw [ha, mem_span_singleton'] at hisup this
    obtain ⟨v, rfl⟩ := this
    obtain ⟨u, rfl⟩ := hisup
    have hucolon : u ∈ I.colon (span {v * a}) :=
      by
      rw [Ideal.mem_colon_singleton, mul_comm v, ← mul_assoc]
      exact mul_mem_right _ _ hi
    erw [hb, mem_span_singleton'] at hucolon
    obtain ⟨z, rfl⟩ := hucolon
    exact mem_span_singleton'.2 ⟨z, by ring⟩
  · rw [← Ideal.submodule_span_eq, ← ha, Ideal.sup_mul, sup_le_iff,
      span_singleton_mul_span_singleton, mul_comm y, Ideal.span_singleton_le_iff_mem]
    exact ⟨mul_le_right, Ideal.mem_colon_singleton.1 <| hb.symm ▸ Ideal.mem_span_singleton_self b⟩
#align is_principal_ideal_ring.of_prime IsPrincipalIdealRing.of_prime

end PrincipalOfPrime


import data.nat.basic
import data.nat.parity
import tactic

namespace lecture5

set_option class.instance_max_depth 100

open nat

example {m : ℕ} (m_divd_14 : 14 ∣ m) : 7 ∣ (135 * m + 693) :=
begin
  cases m_divd_14 with i ih,
  refine dvd.intro _ _,
  use 270 * i + 99,
  rw ih,
  linarith,
end

end lecture5


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

! This file was ported from Lean 3 source module control.lawful_fix
! leanprover-community/mathlib commit 92ca63f0fb391a9ca5f22d2409a6080e786d99f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Stream.Init
import Mathlib.Tactic.ApplyFun
import Mathlib.Control.Fix
import Mathlib.Order.OmegaCompletePartialOrder
import Mathlib.Tactic.WLOG

/-!
# Lawful fixed point operators

This module defines the laws required of a `Fix` instance, using the theory of
omega complete partial orders (ωCPO). Proofs of the lawfulness of all `Fix` instances in
`Control.Fix` are provided.

## Main definition

 * class `LawfulFix`
-/

universe u v

open Classical

variable {α : Type _} {β : α → Type _}

open OmegaCompletePartialOrder

/- Porting note: in `#align`s, mathport is putting some `fix`es where `Fix`es should be. -/
/-- Intuitively, a fixed point operator `fix` is lawful if it satisfies `fix f = f (fix f)` for all
`f`, but this is inconsistent / uninteresting in most cases due to the existence of "exotic"
functions `f`, such as the function that is defined iff its argument is not, familiar from the
halting problem. Instead, this requirement is limited to only functions that are `continuous` in the
sense of `ω`-complete partial orders, which excludes the example because it is not monotone
(making the input argument less defined can make `f` more defined). -/
class LawfulFix (α : Type _) [OmegaCompletePartialOrder α] extends Fix α where
  fix_eq : ∀ {f : α →o α}, Continuous f → Fix.fix f = f (Fix.fix f)
#align lawful_fix LawfulFix

theorem LawfulFix.fix_eq' {α} [OmegaCompletePartialOrder α] [LawfulFix α] {f : α → α}
    (hf : Continuous' f) : Fix.fix f = f (Fix.fix f) :=
  LawfulFix.fix_eq (hf.to_bundled _)
#align lawful_fix.fix_eq' LawfulFix.fix_eq'

namespace Part

open Part Nat Nat.Upto

namespace Fix

variable (f : ((a : _) → Part <| β a) →o (a : _) → Part <| β a)

theorem approx_mono' {i : ℕ} : Fix.approx f i ≤ Fix.approx f (succ i) := by
  induction i with
  | zero => dsimp [approx]; apply @bot_le _ _ _ (f ⊥)
  | succ _ i_ih => intro ; apply f.monotone; apply i_ih
#align part.fix.approx_mono' Part.Fix.approx_mono'

theorem approx_mono ⦃i j : ℕ⦄ (hij : i ≤ j) : approx f i ≤ approx f j := by
  induction' j with j ih
  · cases hij
    exact le_rfl
  cases hij; · exact le_rfl
  exact le_trans (ih ‹_›) (approx_mono' f)
#align part.fix.approx_mono Part.Fix.approx_mono

theorem mem_iff (a : α) (b : β a) : b ∈ Part.fix f a ↔ ∃ i, b ∈ approx f i a := by
  by_cases h₀ : ∃ i : ℕ, (approx f i a).Dom
  · simp only [Part.fix_def f h₀]
    constructor <;> intro hh
    · exact ⟨_, hh⟩
    have h₁ := Nat.find_spec h₀
    rw [dom_iff_mem] at h₁
    cases' h₁ with y h₁
    replace h₁ := approx_mono' f _ _ h₁
    suffices : y = b
    · subst this
      exact h₁
    cases' hh with i hh
    revert h₁; generalize succ (Nat.find h₀) = j; intro h₁
    wlog case : i ≤ j
    · cases' le_total i j with H H <;> [skip, symm] <;> apply_assumption <;> assumption
    replace hh := approx_mono f case _ _ hh
    apply Part.mem_unique h₁ hh
  · simp only [fix_def' (⇑f) h₀, not_exists, false_iff_iff, not_mem_none]
    simp only [dom_iff_mem, not_exists] at h₀
    intro; apply h₀
#align part.fix.mem_iff Part.Fix.mem_iff

theorem approx_le_fix (i : ℕ) : approx f i ≤ Part.fix f := fun a b hh ↦ by
  rw [mem_iff f]
  exact ⟨_, hh⟩
#align part.fix.approx_le_fix Part.Fix.approx_le_fix

/-- The series of approximations of `fix f` (see `approx`) as a `Chain` -/
def approxChain : Chain ((a : _) → Part <| β a) :=
  ⟨approx f, approx_mono f⟩
#align part.fix.approx_chain Part.Fix.approxChain

theorem le_f_of_mem_approx {x} : x ∈ approxChain f → x ≤ f x := by
  simp only [(· ∈ ·), forall_exists_index]
  rintro i rfl
  apply approx_mono'
#align part.fix.le_f_of_mem_approx Part.Fix.le_f_of_mem_approx

theorem approx_mem_approxChain {i} : approx f i ∈ approxChain f :=
  Stream'.mem_of_nth_eq rfl
#align part.fix.approx_mem_approx_chain Part.Fix.approx_mem_approxChain

end Fix

open Fix

variable {α : Type _}

variable (f : ((a : _) → Part <| β a) →o (a : _) → Part <| β a)

open OmegaCompletePartialOrder

open Part hiding ωSup

open Nat

open Nat.Upto OmegaCompletePartialOrder

theorem fix_eq_ωSup : Part.fix f = ωSup (approxChain f) := by
  apply le_antisymm
  · intro x
    cases' exists_fix_le_approx f x with i hx
    trans approx f i.succ x
    · trans
      apply hx
      apply approx_mono' f
    apply le_ωSup_of_le i.succ
    dsimp [approx]
    rfl
  · apply ωSup_le _ _ _
    simp only [Fix.approxChain, OrderHom.coe_fun_mk]
    intro y x
    apply approx_le_fix f
#align part.fix_eq_ωSup Part.fix_eq_ωSup

theorem fix_le {X : (a : _) → Part <| β a} (hX : f X ≤ X) : Part.fix f ≤ X := by
  rw [fix_eq_ωSup f]
  apply ωSup_le _ _ _
  simp only [Fix.approxChain, OrderHom.coe_fun_mk]
  intro i
  induction i with
  | zero => dsimp [Fix.approx]; apply bot_le
  | succ _ i_ih => trans f X; apply f.monotone i_ih ; apply hX
#align part.fix_le Part.fix_le

variable {f} (hc : Continuous f)

theorem fix_eq : Part.fix f = f (Part.fix f) := by
  rw [fix_eq_ωSup f, hc]
  apply le_antisymm
  · apply ωSup_le_ωSup_of_le _
    intro i
    exists i
    intro x
    -- intros x y hx,
    apply le_f_of_mem_approx _ ⟨i, rfl⟩
  · apply ωSup_le_ωSup_of_le _
    intro i
    exists i.succ
#align part.fix_eq Part.fix_eq

end Part

namespace Part

/-- `toUnit` as a monotone function -/
@[simps]
def toUnitMono (f : Part α →o Part α) : (Unit → Part α) →o Unit → Part α where
  toFun x u := f (x u)
  monotone' x y (h : x ≤ y) u := f.monotone <| h u
#align part.to_unit_mono Part.toUnitMono

theorem to_unit_cont (f : Part α →o Part α) (hc : Continuous f) : Continuous (toUnitMono f)
  | _ => by
    ext ⟨⟩ : 1
    dsimp [OmegaCompletePartialOrder.ωSup]
    erw [hc, Chain.map_comp]; rfl
#align part.to_unit_cont Part.to_unit_cont

-- Porting note: `noncomputable` is required because the code generator does not support recursor
--               `Acc.rec` yet.
noncomputable instance lawfulFix : LawfulFix (Part α) :=
  ⟨fun {f : Part α →o Part α} hc ↦ show Part.fix (toUnitMono f) () = _ by
    rw [Part.fix_eq (to_unit_cont f hc)]; rfl⟩
#align part.lawful_fix Part.lawfulFix

end Part

open Sigma

namespace Pi

-- Porting note: `noncomputable` is required because the code generator does not support recursor
--               `Acc.rec` yet.
noncomputable instance lawfulFix {β} : LawfulFix (α → Part β) :=
  ⟨fun {_f} ↦ Part.fix_eq⟩
#align pi.lawful_fix Pi.lawfulFix

variable {γ : ∀ a : α, β a → Type _}

section Monotone

variable (α β γ)

/-- `Sigma.curry` as a monotone function. -/
@[simps]
def monotoneCurry [(x y : _) → Preorder <| γ x y] :
    (∀ x : Σa, β a, γ x.1 x.2) →o ∀ (a) (b : β a), γ a b where
  toFun := curry
  monotone' _x _y h a b := h ⟨a, b⟩
#align pi.monotone_curry Pi.monotoneCurry

/-- `Sigma.uncurry` as a monotone function. -/
@[simps]
def monotoneUncurry [(x y : _) → Preorder <| γ x y] :
    (∀ (a) (b : β a), γ a b) →o ∀ x : Σa, β a, γ x.1 x.2 where
  toFun := uncurry
  monotone' _x _y h a := h a.1 a.2
#align pi.monotone_uncurry Pi.monotoneUncurry

variable [(x y : _) → OmegaCompletePartialOrder <| γ x y]

open OmegaCompletePartialOrder.Chain

theorem continuous_curry : Continuous <| monotoneCurry α β γ := fun c ↦ by
  ext (x y)
  dsimp [curry, ωSup]
  rw [map_comp, map_comp]
  rfl
#align pi.continuous_curry Pi.continuous_curry

theorem continuous_uncurry : Continuous <| monotoneUncurry α β γ := fun c ↦ by
  ext (x y)
  dsimp [uncurry, ωSup]
  rw [map_comp, map_comp]
  rfl
#align pi.continuous_uncurry Pi.continuous_uncurry

end Monotone

open Fix

instance hasFix [Fix <| (x : Sigma β) → γ x.1 x.2] : Fix ((x : _) → (y : β x) → γ x y) :=
  ⟨fun f ↦ curry (fix <| uncurry ∘ f ∘ curry)⟩
#align pi.has_fix Pi.hasFix

variable [∀ x y, OmegaCompletePartialOrder <| γ x y]

section Curry

variable {f : ((x : _) → (y : β x) → γ x y) →o (x : _) → (y : β x) → γ x y}

variable (hc : Continuous f)

theorem uncurry_curry_continuous :
    Continuous <| (monotoneUncurry α β γ).comp <| f.comp <| monotoneCurry α β γ :=
  continuous_comp _ _ (continuous_comp _ _ (continuous_curry _ _ _) hc) (continuous_uncurry _ _ _)
#align pi.uncurry_curry_continuous Pi.uncurry_curry_continuous

end Curry

instance Pi.lawfulFix' [LawfulFix <| (x : Sigma β) → γ x.1 x.2] :
    LawfulFix ((x y : _) → γ x y) where
  fix_eq {_f} hc := by
    dsimp [fix]
    conv =>
      lhs
      erw [LawfulFix.fix_eq (uncurry_curry_continuous hc)]
#align pi.pi.lawful_fix' Pi.Pi.lawfulFix'

end Pi


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Kappelmann
-/
import algebra.order.floor
import tactic.field_simp

/-!
# Floor Function for Rational Numbers

## Summary

We define the `floor` function and the `floor_ring` instance on `ℚ`. Some technical lemmas relating
`floor` to integer division and modulo arithmetic are derived as well as some simple inequalities.

## Tags

rat, rationals, ℚ, floor
-/

open int

namespace rat

/-- `floor q` is the largest integer `z` such that `z ≤ q` -/
protected def floor : ℚ → ℤ
| ⟨n, d, h, c⟩ := n / d

protected theorem le_floor {z : ℤ} : ∀ {r : ℚ}, z ≤ rat.floor r ↔ (z : ℚ) ≤ r
| ⟨n, d, h, c⟩ := begin
  simp [rat.floor],
  rw [num_denom'],
  have h' := int.coe_nat_lt.2 h,
  conv { to_rhs,
    rw [coe_int_eq_mk, rat.le_def zero_lt_one h', mul_one] },
  exact int.le_div_iff_mul_le h'
end

instance : floor_ring ℚ :=
floor_ring.of_floor ℚ rat.floor $ λ a z, rat.le_floor.symm

protected lemma floor_def {q : ℚ} : ⌊q⌋ = q.num / q.denom := by { cases q, refl }

lemma floor_int_div_nat_eq_div {n : ℤ} {d : ℕ} : ⌊(↑n : ℚ) / (↑d : ℚ)⌋ = n / (↑d : ℤ) :=
begin
  rw [rat.floor_def],
  cases decidable.em (d = 0) with d_eq_zero d_ne_zero,
  { simp [d_eq_zero] },
  { set q := (n : ℚ) / d with q_eq,
    obtain ⟨c, n_eq_c_mul_num, d_eq_c_mul_denom⟩ : ∃ c, n = c * q.num ∧ (d : ℤ) = c * q.denom, by
    { rw q_eq,
      exact_mod_cast (@rat.exists_eq_mul_div_num_and_eq_mul_div_denom n d
        (by exact_mod_cast d_ne_zero)) },
    suffices : q.num / q.denom = c * q.num / (c * q.denom),
      by rwa [n_eq_c_mul_num, d_eq_c_mul_denom],
    suffices : c > 0, by solve_by_elim [int.mul_div_mul_of_pos],
    have q_denom_mul_c_pos : (0 : ℤ) < q.denom * c, by
    { have : (d : ℤ) > 0, by exact_mod_cast (pos_iff_ne_zero.elim_right d_ne_zero),
      rwa [d_eq_c_mul_denom, mul_comm] at this },
    suffices : (0 : ℤ) ≤ q.denom, from pos_of_mul_pos_left q_denom_mul_c_pos this,
    exact_mod_cast (le_of_lt q.pos) }
end

end rat

lemma int.mod_nat_eq_sub_mul_floor_rat_div {n : ℤ} {d : ℕ} : n % d = n - d * ⌊(n : ℚ) / d⌋ :=
by rw [(eq_sub_of_add_eq $ int.mod_add_div n d), rat.floor_int_div_nat_eq_div]

lemma nat.coprime_sub_mul_floor_rat_div_of_coprime {n d : ℕ} (n_coprime_d : n.coprime d) :
  ((n : ℤ) - d * ⌊(n : ℚ)/ d⌋).nat_abs.coprime d :=
begin
  have : (n : ℤ) % d = n - d * ⌊(n : ℚ)/ d⌋, from int.mod_nat_eq_sub_mul_floor_rat_div,
  rw ←this,
  have : d.coprime n, from n_coprime_d.symm,
  rwa [nat.coprime, nat.gcd_rec] at this
end

namespace rat

lemma num_lt_succ_floor_mul_denom (q : ℚ) : q.num < (⌊q⌋ + 1) * q.denom :=
begin
  suffices : (q.num : ℚ) < (⌊q⌋ + 1) * q.denom, by exact_mod_cast this,
  suffices : (q.num : ℚ) < (q - fract q + 1) * q.denom, by
  { have : (⌊q⌋ : ℚ) = q - fract q, from (eq_sub_of_add_eq $ floor_add_fract q),
    rwa this },
  suffices : (q.num : ℚ) < q.num + (1 - fract q) * q.denom, by
  { have : (q - fract q + 1) * q.denom = q.num + (1 - fract q) * q.denom, calc
      (q - fract q + 1) * q.denom = (q + (1 - fract q)) * q.denom            : by ring
                              ... = q * q.denom + (1 - fract q) * q.denom    : by rw add_mul
                              ... = q.num + (1 - fract q) * q.denom : by simp,
    rwa this },
  suffices : 0 < (1 - fract q) * q.denom, by { rw ←sub_lt_iff_lt_add', simpa },
  have : 0 < 1 - fract q, by
  { have : fract q < 1, from fract_lt_one q,
    have : 0 + fract q < 1, by simp [this],
    rwa lt_sub_iff_add_lt },
  exact mul_pos this (by exact_mod_cast q.pos)
end

lemma fract_inv_num_lt_num_of_pos {q : ℚ} (q_pos : 0 < q): (fract q⁻¹).num < q.num :=
begin
  -- we know that the numerator must be positive
  have q_num_pos : 0 < q.num, from rat.num_pos_iff_pos.elim_right q_pos,
  -- we will work with the absolute value of the numerator, which is equal to the numerator
  have q_num_abs_eq_q_num : (q.num.nat_abs : ℤ) = q.num, from
    (int.nat_abs_of_nonneg q_num_pos.le),
  set q_inv := (q.denom : ℚ) / q.num with q_inv_def,
  have q_inv_eq : q⁻¹ = q_inv, from rat.inv_def',
  suffices : (q_inv - ⌊q_inv⌋).num < q.num, by rwa q_inv_eq,
  suffices : ((q.denom - q.num * ⌊q_inv⌋ : ℚ) / q.num).num < q.num, by
    field_simp [this, (ne_of_gt q_num_pos)],
  suffices : (q.denom : ℤ) - q.num * ⌊q_inv⌋ < q.num, by
  { -- use that `q.num` and `q.denom` are coprime to show that the numerator stays unreduced
    have : ((q.denom - q.num * ⌊q_inv⌋ : ℚ) / q.num).num = q.denom - q.num * ⌊q_inv⌋, by
    { suffices : ((q.denom : ℤ) - q.num * ⌊q_inv⌋).nat_abs.coprime q.num.nat_abs, by
        exact_mod_cast (rat.num_div_eq_of_coprime q_num_pos this),
      have : (q.num.nat_abs : ℚ) = (q.num : ℚ), by exact_mod_cast q_num_abs_eq_q_num,
      have tmp := nat.coprime_sub_mul_floor_rat_div_of_coprime q.cop.symm,
      simpa only [this, q_num_abs_eq_q_num] using tmp },
    rwa this },
  -- to show the claim, start with the following inequality
  have q_inv_num_denom_ineq : q⁻¹.num - ⌊q⁻¹⌋ * q⁻¹.denom < q⁻¹.denom, by
  { have : q⁻¹.num < (⌊q⁻¹⌋ + 1) * q⁻¹.denom, from rat.num_lt_succ_floor_mul_denom q⁻¹,
    have : q⁻¹.num < ⌊q⁻¹⌋ * q⁻¹.denom + q⁻¹.denom, by rwa [right_distrib, one_mul] at this,
    rwa [←sub_lt_iff_lt_add'] at this },
  -- use that `q.num` and `q.denom` are coprime to show that q_inv is the unreduced reciprocal
  -- of `q`
  have : q_inv.num = q.denom ∧ q_inv.denom = q.num.nat_abs, by
  { have coprime_q_denom_q_num : q.denom.coprime q.num.nat_abs, from q.cop.symm,
    have : int.nat_abs q.denom = q.denom, by simp,
    rw ←this at coprime_q_denom_q_num,
    rw q_inv_def,
    split,
    { exact_mod_cast (rat.num_div_eq_of_coprime q_num_pos coprime_q_denom_q_num) },
    { suffices : (((q.denom : ℚ) / q.num).denom : ℤ) = q.num.nat_abs, by exact_mod_cast this,
      rw q_num_abs_eq_q_num,
      exact_mod_cast (rat.denom_div_eq_of_coprime q_num_pos coprime_q_denom_q_num) } },
  rwa [q_inv_eq, this.left, this.right, q_num_abs_eq_q_num, mul_comm] at q_inv_num_denom_ineq
end

end rat


-- Game axiomatics

import game.world_09_advanced_multiplication
import mynat.le
namespace mynat

lemma one_add_le_self (x : mynat) : x ≤ 1 + x := begin[nat_num_game]
  use 1,
  apply add_comm,
end

lemma le_refl (x : mynat) : x ≤ x := begin[nat_num_game]
  use 0,
  refl,
end

attribute [refl] mynat.le_refl

theorem le_succ (a b : mynat) : a ≤ b → a ≤ (succ b) := begin[nat_num_game]
  intro h,
  cases h,
  rw h_h,
  use succ h_w,
  refl,
end

lemma zero_le (a : mynat) : 0 ≤ a := begin[nat_num_game]
  induction a,
  refl, {
    cases a_ih,
    rw a_ih_h,
    use succ a_ih_w,
    refl
  }
end

theorem le_trans (a b c : mynat) (hab : a ≤ b) (hbc : b ≤ c) : a ≤ c := begin[nat_num_game]
  cases hab,
  cases hbc,
  rw hab_h at hbc_h,
  use hab_w + hbc_w,
  rw add_assoc at hbc_h,
  apply hbc_h,
end

theorem le_antisymm (a b : mynat) (hab : a ≤ b) (hba : b ≤ a) : a = b := begin[nat_num_game]
  cases hab,
  cases hba,
  rw [hab_h, add_assoc] at hba_h,
  symmetry at hba_h,
  have w_sum_eq_zero_h := eq_zero_of_add_right_eq_self hba_h,
  have hab_w_eq_zero := add_right_eq_zero w_sum_eq_zero_h,
  rw [hab_w_eq_zero, add_zero] at hab_h,
  rwa [hab_h],
end

lemma le_zero (a : mynat) (h : a ≤ 0) : a = 0 := begin[nat_num_game]
  induction a,
  refl, {
    exfalso,
    cases h,
    symmetry at h_h,
    apply succ_ne_zero,
    exact add_right_eq_zero h_h,
  }
end

lemma succ_le_succ (a b : mynat) (h : a ≤ b) : succ a ≤ succ b := begin[nat_num_game]
  cases h,
  use h_w,
  rwa [succ_add, h_h],
end

theorem le_total (a b : mynat) : a ≤ b ∨ b ≤ a := begin[nat_num_game]
  induction b generalizing a, {
    right,
    apply zero_le,
  }, {
    cases a, {
      left,
      apply zero_le,
    }, {
      cases b_ih a, {
        left,
        apply succ_le_succ,
        exact h
      }, {
        right,
        apply succ_le_succ,
        exact h
      }
    }
  }
end

instance : linear_order mynat := by structure_helper

lemma le_succ_self (a : mynat) : a ≤ succ a := begin[nat_num_game]
  apply le_succ,
  apply le_refl,
end

theorem add_le_add_right {a b : mynat} : a ≤ b → ∀ t, (a + t) ≤ (b + t) := begin[nat_num_game]
  intros h t,
  induction t,
  rwa [add_zero], {
    rwa [add_succ, add_succ],
    apply succ_le_succ,
    exact t_ih,
  }
end

theorem le_of_succ_le_succ (a b : mynat) : succ a ≤ succ b → a ≤ b := begin[nat_num_game]
  intro h,
  cases h,
  use h_w,
  rw [succ_add, succ_eq_succ_iff] at h_h,
  apply h_h,
end

theorem not_succ_le_self (a : mynat) : ¬ (succ a ≤ a) := begin[nat_num_game]
  intro h,
  induction a, {
    cases h,
    rw succ_add at h_h,
    apply zero_ne_succ,
    apply h_h,
  }, {
    apply a_ih,
    apply le_of_succ_le_succ,
    apply h,
  }
end

theorem add_le_add_left {a b : mynat} (h : a ≤ b) (t : mynat) : t + a ≤ t + b := begin[nat_num_game]
  induction t, {
    rwa [zero_add, zero_add]
  }, {
    rw [succ_add, succ_add],
    apply succ_le_succ,
    apply t_ih
  }
end

lemma lt_aux_one (a b : mynat) : a ≤ b ∧ ¬ (b ≤ a) → succ a ≤ b := begin[nat_num_game]
  intro h,
  cases h,
  cases h_left,
  cases h_left_w, {
    exfalso,
    apply h_right,
    rwa h_left_h,
    refl,
  }, {
    rw h_left_h,
    use h_left_w,
    rwa [add_succ, succ_add],
  }
end

lemma lt_aux_two (a b : mynat) : succ a ≤ b → a ≤ b ∧ ¬ (b ≤ a) := begin[nat_num_game]
  intro h,
  split, {
    cases h,
    use h_w + 1,
    rwa [h_h, succ_eq_add_one, add_assoc, add_comm(h_w)],
  }, {
    intro le_h,
    apply not_succ_le_self b,
    cases le_h,
    rw le_h_h at h,
    cases h,
    use le_h_w + h_w,
    rw succ_add,
    rwa [succ_add, add_assoc] at h_h,
  }
end

definition lt (a b : mynat) := a ≤ b ∧ ¬ (b ≤ a)
instance : has_lt mynat := ⟨lt⟩

lemma lt_iff_succ_le (a b : mynat) : a < b ↔ succ a ≤ b := begin[nat_num_game]
  split,
  intro h, exact lt_aux_one _ _ h,
  intro h, exact lt_aux_two _ _ h,
end

end mynat


-- amazing theory of limsups

import limits

namespace M1P1

/- Section
Sequences, subsequences, and monotonic subsequences.
-/

/- Sub-section
Definitions
-/

/-
We model a sequence $a₀, a₁, a₂, \dots$ of real numbers as a function
from $ℕ := \{0,1,2,\dots\}$ to $ℝ$, sending $n$ to $a_n$. We sometimes write such
a sequence as $(a_n)_{n≥0}$ or just $(a_n)$.
-/

/- Definition
A sequence $(a_n)$ is *increasing* if forall $n∈ℕ$ we have $a_n≤a_{n+1}$. Note that equality
is allowed here -- so for example the sequence $3, 3, 3, 3, …$ is increasing. A sequence is
*strictly increasing* if for all $n∈ℕ$ we have $a_n<a_{n+1}$; constant sequences
are not strictly increasing.
-/
def is_increasing {X : Type*} [has_le X] (a : ℕ → X) : Prop :=
∀ n : ℕ, a n ≤ a (n + 1)
def is_strictly_increasing {X : Type*} [has_lt X] (a : ℕ → X) : Prop :=
∀ n : ℕ, a n < a (n + 1)
/- Definition
Similarly a sequence $(a_n)$ is *decreasing* if $∀ n∈ℕ, a_{n+1}≤ a_n$ and is
*strictly decreasing* if $∀ n∈ℕ, a_{n+1}<a_n$.
-/
def is_decreasing {X : Type*} [has_le X] (a : ℕ → X) : Prop :=
∀ n : ℕ, a (n + 1) ≤ a n
def is_strictly_decreasing {X : Type*} [has_lt X] (a : ℕ → X) : Prop :=
∀ n : ℕ, a (n + 1) < a n
/-
A *subsequence* of a sequence $(a_n)$ is a sequence $(b_m)$ of the form
$a_{k_0}$, $a_{k_1}$, $a_{k_2}$, where the indices $0≤ k_0<k_1<k_2<…$ are strictly increasing.
-/
def is_subsequence {X : Type*} (a : ℕ → X) (b : ℕ → X) :=
∃ k : ℕ → ℕ, is_strictly_increasing k ∧ ∀ n, a (k n) = b n

definition is_limit_point (a : ℕ → ℝ) (l : ℝ) :=
∃ (b : ℕ → ℝ), is_subsequence a b ∧ is_limit b l

end M1P1


/-
Copyright (c) 2021 Shing Tak Lam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Shing Tak Lam

! This file was ported from Lean 3 source module algebraic_topology.fundamental_groupoid.basic
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Category.Groupoid
import Mathbin.CategoryTheory.Groupoid
import Mathbin.Topology.Category.Top.Basic
import Mathbin.Topology.Homotopy.Path

/-!
# Fundamental groupoid of a space

Given a topological space `X`, we can define the fundamental groupoid of `X` to be the category with
objects being points of `X`, and morphisms `x ⟶ y` being paths from `x` to `y`, quotiented by
homotopy equivalence. With this, the fundamental group of `X` based at `x` is just the automorphism
group of `x`.
-/

universe u v

variable {X : Type u} {Y : Type v} [TopologicalSpace X] [TopologicalSpace Y]

variable {x₀ x₁ : X}

noncomputable section

open unitInterval

namespace Path

namespace Homotopy

section

/-- Auxilliary function for `refl_trans_symm` -/
def reflTransSymmAux (x : I × I) : ℝ :=
  if (x.2 : ℝ) ≤ 1 / 2 then x.1 * 2 * x.2 else x.1 * (2 - 2 * x.2)
#align path.homotopy.refl_trans_symm_aux Path.Homotopy.reflTransSymmAux

@[continuity]
theorem continuous_reflTransSymmAux : Continuous reflTransSymmAux :=
  by
  refine' continuous_if_le _ _ (Continuous.continuousOn _) (Continuous.continuousOn _) _
  · continuity
  · continuity
  · continuity
  · continuity
  intro x hx
  norm_num [hx, mul_assoc]
#align path.homotopy.continuous_refl_trans_symm_aux Path.Homotopy.continuous_reflTransSymmAux

theorem reflTransSymmAux_mem_I (x : I × I) : reflTransSymmAux x ∈ I :=
  by
  dsimp only [refl_trans_symm_aux]
  split_ifs
  · constructor
    · apply mul_nonneg
      · apply mul_nonneg
        · unit_interval
        · norm_num
      · unit_interval
    · rw [mul_assoc]
      apply mul_le_one
      · unit_interval
      · apply mul_nonneg
        · norm_num
        · unit_interval
      · linarith
  · constructor
    · apply mul_nonneg
      · unit_interval
      linarith [unitInterval.nonneg x.2, unitInterval.le_one x.2]
    · apply mul_le_one
      · unit_interval
      · linarith [unitInterval.nonneg x.2, unitInterval.le_one x.2]
      · linarith [unitInterval.nonneg x.2, unitInterval.le_one x.2]
#align path.homotopy.refl_trans_symm_aux_mem_I Path.Homotopy.reflTransSymmAux_mem_I

/-- For any path `p` from `x₀` to `x₁`, we have a homotopy from the constant path based at `x₀` to
  `p.trans p.symm`. -/
def reflTransSymm (p : Path x₀ x₁) : Homotopy (Path.refl x₀) (p.trans p.symm)
    where
  toFun x := p ⟨reflTransSymmAux x, reflTransSymmAux_mem_I x⟩
  continuous_toFun := by continuity
  map_zero_left' := by norm_num [refl_trans_symm_aux]
  map_one_left' x :=
    by
    dsimp only [refl_trans_symm_aux, Path.coe_toContinuousMap, Path.trans]
    change _ = ite _ _ _
    split_ifs
    · rw [Path.extend, Set.IccExtend_of_mem]
      · norm_num
      · rw [unitInterval.mul_pos_mem_iff zero_lt_two]
        exact ⟨unitInterval.nonneg x, h⟩
    · rw [Path.symm, Path.extend, Set.IccExtend_of_mem]
      · congr 1
        ext
        norm_num [sub_sub_eq_add_sub]
      · rw [unitInterval.two_mul_sub_one_mem_iff]
        exact ⟨(not_le.1 h).le, unitInterval.le_one x⟩
  prop' t x hx := by
    cases hx
    · rw [hx]
      simp [refl_trans_symm_aux]
    · rw [Set.mem_singleton_iff] at hx
      rw [hx]
      norm_num [refl_trans_symm_aux]
#align path.homotopy.refl_trans_symm Path.Homotopy.reflTransSymm

/-- For any path `p` from `x₀` to `x₁`, we have a homotopy from the constant path based at `x₁` to
  `p.symm.trans p`. -/
def reflSymmTrans (p : Path x₀ x₁) : Homotopy (Path.refl x₁) (p.symm.trans p) :=
  (reflTransSymm p.symm).cast rfl <| congr_arg _ Path.symm_symm
#align path.homotopy.refl_symm_trans Path.Homotopy.reflSymmTrans

end

section TransRefl

/-- Auxilliary function for `trans_refl_reparam` -/
def transReflReparamAux (t : I) : ℝ :=
  if (t : ℝ) ≤ 1 / 2 then 2 * t else 1
#align path.homotopy.trans_refl_reparam_aux Path.Homotopy.transReflReparamAux

@[continuity]
theorem continuous_transReflReparamAux : Continuous transReflReparamAux :=
  by
  refine' continuous_if_le _ _ (Continuous.continuousOn _) (Continuous.continuousOn _) _ <;>
    [continuity, continuity, continuity, continuity, skip]
  intro x hx
  norm_num [hx]
#align path.homotopy.continuous_trans_refl_reparam_aux Path.Homotopy.continuous_transReflReparamAux

theorem transReflReparamAux_mem_I (t : I) : transReflReparamAux t ∈ I :=
  by
  unfold trans_refl_reparam_aux
  split_ifs <;> constructor <;> linarith [unitInterval.le_one t, unitInterval.nonneg t]
#align path.homotopy.trans_refl_reparam_aux_mem_I Path.Homotopy.transReflReparamAux_mem_I

theorem transReflReparamAux_zero : transReflReparamAux 0 = 0 := by norm_num [trans_refl_reparam_aux]
#align path.homotopy.trans_refl_reparam_aux_zero Path.Homotopy.transReflReparamAux_zero

theorem transReflReparamAux_one : transReflReparamAux 1 = 1 := by norm_num [trans_refl_reparam_aux]
#align path.homotopy.trans_refl_reparam_aux_one Path.Homotopy.transReflReparamAux_one

theorem trans_refl_reparam (p : Path x₀ x₁) :
    p.trans (Path.refl x₁) =
      p.reparam (fun t => ⟨transReflReparamAux t, transReflReparamAux_mem_I t⟩) (by continuity)
        (Subtype.ext transReflReparamAux_zero) (Subtype.ext transReflReparamAux_one) :=
  by
  ext
  unfold trans_refl_reparam_aux
  simp only [Path.trans_apply, not_le, coe_to_fun, Function.comp_apply]
  split_ifs
  · rfl
  · simp
#align path.homotopy.trans_refl_reparam Path.Homotopy.trans_refl_reparam

/-- For any path `p` from `x₀` to `x₁`, we have a homotopy from `p.trans (path.refl x₁)` to `p`.
-/
def transRefl (p : Path x₀ x₁) : Homotopy (p.trans (Path.refl x₁)) p :=
  ((Homotopy.reparam p (fun t => ⟨transReflReparamAux t, transReflReparamAux_mem_I t⟩)
          (by continuity) (Subtype.ext transReflReparamAux_zero)
          (Subtype.ext transReflReparamAux_one)).cast
      rfl (trans_refl_reparam p).symm).symm
#align path.homotopy.trans_refl Path.Homotopy.transRefl

/-- For any path `p` from `x₀` to `x₁`, we have a homotopy from `(path.refl x₀).trans p` to `p`.
-/
def reflTrans (p : Path x₀ x₁) : Homotopy ((Path.refl x₀).trans p) p :=
  (transRefl p.symm).symm₂.cast (by simp) (by simp)
#align path.homotopy.refl_trans Path.Homotopy.reflTrans

end TransRefl

section Assoc

/-- Auxilliary function for `trans_assoc_reparam`. -/
def transAssocReparamAux (t : I) : ℝ :=
  if (t : ℝ) ≤ 1 / 4 then 2 * t else if (t : ℝ) ≤ 1 / 2 then t + 1 / 4 else 1 / 2 * (t + 1)
#align path.homotopy.trans_assoc_reparam_aux Path.Homotopy.transAssocReparamAux

@[continuity]
theorem continuous_transAssocReparamAux : Continuous transAssocReparamAux := by
  refine'
        continuous_if_le _ _ (Continuous.continuousOn _)
          (continuous_if_le _ _ (Continuous.continuousOn _) (Continuous.continuousOn _)
              _).ContinuousOn
          _ <;>
      [continuity, continuity, continuity, continuity, continuity, continuity, continuity, skip,
      skip] <;>
    · intro x hx
      norm_num [hx]
#align path.homotopy.continuous_trans_assoc_reparam_aux Path.Homotopy.continuous_transAssocReparamAux

theorem transAssocReparamAux_mem_I (t : I) : transAssocReparamAux t ∈ I :=
  by
  unfold trans_assoc_reparam_aux
  split_ifs <;> constructor <;> linarith [unitInterval.le_one t, unitInterval.nonneg t]
#align path.homotopy.trans_assoc_reparam_aux_mem_I Path.Homotopy.transAssocReparamAux_mem_I

theorem transAssocReparamAux_zero : transAssocReparamAux 0 = 0 := by
  norm_num [trans_assoc_reparam_aux]
#align path.homotopy.trans_assoc_reparam_aux_zero Path.Homotopy.transAssocReparamAux_zero

theorem transAssocReparamAux_one : transAssocReparamAux 1 = 1 := by
  norm_num [trans_assoc_reparam_aux]
#align path.homotopy.trans_assoc_reparam_aux_one Path.Homotopy.transAssocReparamAux_one

theorem trans_assoc_reparam {x₀ x₁ x₂ x₃ : X} (p : Path x₀ x₁) (q : Path x₁ x₂) (r : Path x₂ x₃) :
    (p.trans q).trans r =
      (p.trans (q.trans r)).reparam
        (fun t => ⟨transAssocReparamAux t, transAssocReparamAux_mem_I t⟩) (by continuity)
        (Subtype.ext transAssocReparamAux_zero) (Subtype.ext transAssocReparamAux_one) :=
  by
  ext
  simp only [trans_assoc_reparam_aux, Path.trans_apply, mul_inv_cancel_left₀, not_le,
    Function.comp_apply, Ne.def, not_false_iff, bit0_eq_zero, one_ne_zero, mul_ite, Subtype.coe_mk,
    Path.coe_reparam]
  -- TODO: why does split_ifs not reduce the ifs??????
  split_ifs with h₁ h₂ h₃ h₄ h₅
  · simp [h₂, h₃, -one_div]
  · exfalso
    linarith
  · exfalso
    linarith
  · have h : ¬(x : ℝ) + 1 / 4 ≤ 1 / 2 := by linarith
    have h' : 2 * ((x : ℝ) + 1 / 4) - 1 ≤ 1 / 2 := by linarith
    have h'' : 2 * (2 * (x : ℝ)) - 1 = 2 * (2 * (↑x + 1 / 4) - 1) := by linarith
    simp only [h₄, h₁, h, h', h'', dif_neg (show ¬False from id), dif_pos True.intro, if_false,
      if_true]
  · exfalso
    linarith
  · have h : ¬(1 / 2 : ℝ) * (x + 1) ≤ 1 / 2 := by linarith
    have h' : ¬2 * ((1 / 2 : ℝ) * (x + 1)) - 1 ≤ 1 / 2 := by linarith
    simp only [h₁, h₅, h, h', if_false, dif_neg (show ¬False from id)]
    congr
    ring
#align path.homotopy.trans_assoc_reparam Path.Homotopy.trans_assoc_reparam

/-- For paths `p q r`, we have a homotopy from `(p.trans q).trans r` to `p.trans (q.trans r)`.
-/
def transAssoc {x₀ x₁ x₂ x₃ : X} (p : Path x₀ x₁) (q : Path x₁ x₂) (r : Path x₂ x₃) :
    Homotopy ((p.trans q).trans r) (p.trans (q.trans r)) :=
  ((Homotopy.reparam (p.trans (q.trans r))
          (fun t => ⟨transAssocReparamAux t, transAssocReparamAux_mem_I t⟩) (by continuity)
          (Subtype.ext transAssocReparamAux_zero) (Subtype.ext transAssocReparamAux_one)).cast
      rfl (trans_assoc_reparam p q r).symm).symm
#align path.homotopy.trans_assoc Path.Homotopy.transAssoc

end Assoc

end Homotopy

end Path

/--
The fundamental groupoid of a space `X` is defined to be a type synonym for `X`, and we subsequently
put a `category_theory.groupoid` structure on it.
-/
def FundamentalGroupoid (X : Type u) :=
  X
#align fundamental_groupoid FundamentalGroupoid

namespace FundamentalGroupoid

instance {X : Type u} [h : Inhabited X] : Inhabited (FundamentalGroupoid X) :=
  h

attribute [local reducible] FundamentalGroupoid

attribute [local instance] Path.Homotopic.setoid

instance : CategoryTheory.Groupoid (FundamentalGroupoid X)
    where
  Hom x y := Path.Homotopic.Quotient x y
  id x := ⟦Path.refl x⟧
  comp x y z := Path.Homotopic.Quotient.comp
  id_comp' x y f :=
    Quotient.inductionOn f fun a =>
      show ⟦(Path.refl x).trans a⟧ = ⟦a⟧ from Quotient.sound ⟨Path.Homotopy.reflTrans a⟩
  comp_id' x y f :=
    Quotient.inductionOn f fun a =>
      show ⟦a.trans (Path.refl y)⟧ = ⟦a⟧ from Quotient.sound ⟨Path.Homotopy.transRefl a⟩
  assoc' w x y z f g h :=
    Quotient.induction_on₃ f g h fun p q r =>
      show ⟦(p.trans q).trans r⟧ = ⟦p.trans (q.trans r)⟧ from
        Quotient.sound ⟨Path.Homotopy.transAssoc p q r⟩
  inv x y p :=
    Quotient.lift (fun l : Path x y => ⟦l.symm⟧)
      (by
        rintro a b ⟨h⟩
        rw [Quotient.eq']
        exact ⟨h.symm₂⟩)
      p
  inv_comp' x y f :=
    Quotient.inductionOn f fun a =>
      show ⟦a.symm.trans a⟧ = ⟦Path.refl y⟧ from
        Quotient.sound ⟨(Path.Homotopy.reflSymmTrans a).symm⟩
  comp_inv' x y f :=
    Quotient.inductionOn f fun a =>
      show ⟦a.trans a.symm⟧ = ⟦Path.refl x⟧ from
        Quotient.sound ⟨(Path.Homotopy.reflTransSymm a).symm⟩

theorem comp_eq (x y z : FundamentalGroupoid X) (p : x ⟶ y) (q : y ⟶ z) : p ≫ q = p.comp q :=
  rfl
#align fundamental_groupoid.comp_eq FundamentalGroupoid.comp_eq

theorem id_eq_path_refl (x : FundamentalGroupoid X) : 𝟙 x = ⟦Path.refl x⟧ :=
  rfl
#align fundamental_groupoid.id_eq_path_refl FundamentalGroupoid.id_eq_path_refl

/-- The functor sending a topological space `X` to its fundamental groupoid.
-/
def fundamentalGroupoidFunctor : TopCat ⥤ CategoryTheory.GroupoidCat
    where
  obj X := { α := FundamentalGroupoid X }
  map X Y f :=
    { obj := f
      map := fun x y p => p.mapFn f
      map_id' := fun X => rfl
      map_comp' := fun x y z p q =>
        Quotient.induction_on₂ p q fun a b => by
          simp [comp_eq, ← Path.Homotopic.map_lift, ← Path.Homotopic.comp_lift] }
  map_id' := by
    intro X
    change _ = (⟨_, _, _, _⟩ : FundamentalGroupoid X ⥤ FundamentalGroupoid X)
    congr
    ext (x y p)
    refine' Quotient.inductionOn p fun q => _
    rw [← Path.Homotopic.map_lift]
    conv_rhs => rw [← q.map_id]
    rfl
  map_comp' := by
    intro X Y Z f g
    congr
    ext (x y p)
    refine' Quotient.inductionOn p fun q => _
    simp only [Quotient.map_mk, Path.map_map, Quotient.eq']
    rfl
#align fundamental_groupoid.fundamental_groupoid_functor FundamentalGroupoid.fundamentalGroupoidFunctor

-- mathport name: fundamental_groupoid_functor
scoped notation "π" => FundamentalGroupoid.fundamentalGroupoidFunctor

-- mathport name: fundamental_groupoid_functor.obj
scoped notation "πₓ" => FundamentalGroupoid.fundamentalGroupoidFunctor.obj

-- mathport name: fundamental_groupoid_functor.map
scoped notation "πₘ" => FundamentalGroupoid.fundamentalGroupoidFunctor.map

theorem map_eq {X Y : TopCat} {x₀ x₁ : X} (f : C(X, Y)) (p : Path.Homotopic.Quotient x₀ x₁) :
    (πₘ f).map p = p.mapFn f :=
  rfl
#align fundamental_groupoid.map_eq FundamentalGroupoid.map_eq

/-- Help the typechecker by converting a point in a groupoid back to a point in
the underlying topological space. -/
@[reducible]
def toTop {X : TopCat} (x : πₓ X) : X :=
  x
#align fundamental_groupoid.to_top FundamentalGroupoid.toTop

/-- Help the typechecker by converting a point in a topological space to a
point in the fundamental groupoid of that space -/
@[reducible]
def fromTop {X : TopCat} (x : X) : πₓ X :=
  x
#align fundamental_groupoid.from_top FundamentalGroupoid.fromTop

/-- Help the typechecker by converting an arrow in the fundamental groupoid of
a topological space back to a path in that space (i.e., `path.homotopic.quotient`). -/
@[reducible]
def toPath {X : TopCat} {x₀ x₁ : πₓ X} (p : x₀ ⟶ x₁) : Path.Homotopic.Quotient x₀ x₁ :=
  p
#align fundamental_groupoid.to_path FundamentalGroupoid.toPath

/-- Help the typechecker by convering a path in a topological space to an arrow in the
fundamental groupoid of that space. -/
@[reducible]
def fromPath {X : TopCat} {x₀ x₁ : X} (p : Path.Homotopic.Quotient x₀ x₁) : x₀ ⟶ x₁ :=
  p
#align fundamental_groupoid.from_path FundamentalGroupoid.fromPath

end FundamentalGroupoid


/-
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 algebra.quadratic_discriminant
import analysis.special_functions.trigonometric.basic
import analysis.convex.specific_functions

/-!
# Complex trigonometric functions

Basic facts and derivatives for the complex trigonometric functions.

Several facts about the real trigonometric functions have the proofs deferred here, rather than
`analysis.special_functions.trigonometric.basic`,
as they are most easily proved by appealing to the corresponding fact for complex trigonometric
functions, or require additional imports which are not available in that file.
-/

noncomputable theory

namespace complex

open set filter
open_locale real

theorem cos_eq_zero_iff {θ : ℂ} : cos θ = 0 ↔ ∃ k : ℤ, θ = (2 * k + 1) * π / 2 :=
begin
  have h : (exp (θ * I) + exp (-θ * I)) / 2 = 0 ↔ exp (2 * θ * I) = -1,
  { rw [@div_eq_iff _ _ (exp (θ * I) + exp (-θ * I)) 2 0 two_ne_zero, zero_mul,
      add_eq_zero_iff_eq_neg, neg_eq_neg_one_mul, ← div_eq_iff (exp_ne_zero _), ← exp_sub],
    field_simp only, congr' 3, ring },
  rw [cos, h, ← exp_pi_mul_I, exp_eq_exp_iff_exists_int, mul_right_comm],
  refine exists_congr (λ x, _),
  refine (iff_of_eq $ congr_arg _ _).trans (mul_right_inj' $ mul_ne_zero two_ne_zero I_ne_zero),
  field_simp, ring,
end

theorem cos_ne_zero_iff {θ : ℂ} : cos θ ≠ 0 ↔ ∀ k : ℤ, θ ≠ (2 * k + 1) * π / 2 :=
by rw [← not_exists, not_iff_not, cos_eq_zero_iff]

theorem sin_eq_zero_iff {θ : ℂ} : sin θ = 0 ↔ ∃ k : ℤ, θ = k * π :=
begin
  rw [← complex.cos_sub_pi_div_two, cos_eq_zero_iff],
  split,
  { rintros ⟨k, hk⟩,
    use k + 1,
    field_simp [eq_add_of_sub_eq hk],
    ring },
  { rintros ⟨k, rfl⟩,
    use k - 1,
    field_simp,
    ring }
end

theorem sin_ne_zero_iff {θ : ℂ} : sin θ ≠ 0 ↔ ∀ k : ℤ, θ ≠ k * π :=
by rw [← not_exists, not_iff_not, sin_eq_zero_iff]

lemma tan_eq_zero_iff {θ : ℂ} : tan θ = 0 ↔ ∃ k : ℤ, θ = k * π / 2 :=
begin
  have h := (sin_two_mul θ).symm,
  rw mul_assoc at h,
  rw [tan, div_eq_zero_iff, ← mul_eq_zero, ← zero_mul ((1/2):ℂ), mul_one_div,
      cancel_factors.cancel_factors_eq_div h two_ne_zero, mul_comm],
  simpa only [zero_div, zero_mul, ne.def, not_false_iff] with field_simps using sin_eq_zero_iff,
end

lemma tan_ne_zero_iff {θ : ℂ} : tan θ ≠ 0 ↔ ∀ k : ℤ, θ ≠ k * π / 2 :=
by rw [← not_exists, not_iff_not, tan_eq_zero_iff]

lemma tan_int_mul_pi_div_two (n : ℤ) : tan (n * π/2) = 0 :=
tan_eq_zero_iff.mpr (by use n)

lemma cos_eq_cos_iff {x y : ℂ} :
  cos x = cos y ↔ ∃ k : ℤ, y = 2 * k * π + x ∨ y = 2 * k * π - x :=
calc cos x = cos y ↔ cos x - cos y = 0 : sub_eq_zero.symm
... ↔ -2 * sin((x + y)/2) * sin((x - y)/2) = 0 : by rw cos_sub_cos
... ↔ sin((x + y)/2) = 0 ∨ sin((x - y)/2) = 0 : by simp [(by norm_num : (2:ℂ) ≠ 0)]
... ↔ sin((x - y)/2) = 0 ∨ sin((x + y)/2) = 0 : or.comm
... ↔ (∃ k : ℤ, y = 2 * k * π + x) ∨ (∃ k :ℤ, y = 2 * k * π - x) :
begin
  apply or_congr;
    field_simp [sin_eq_zero_iff, (by norm_num : -(2:ℂ) ≠ 0), eq_sub_iff_add_eq',
      sub_eq_iff_eq_add, mul_comm (2:ℂ), mul_right_comm _ (2:ℂ)],
  split; { rintros ⟨k, rfl⟩, use -k, simp, },
end
... ↔ ∃ k : ℤ, y = 2 * k * π + x ∨ y = 2 * k * π - x : exists_or_distrib.symm

lemma sin_eq_sin_iff {x y : ℂ} :
  sin x = sin y ↔ ∃ k : ℤ, y = 2 * k * π + x ∨ y = (2 * k + 1) * π - x :=
begin
  simp only [← complex.cos_sub_pi_div_two, cos_eq_cos_iff, sub_eq_iff_eq_add],
  refine exists_congr (λ k, or_congr _ _); refine eq.congr rfl _; field_simp; ring
end

lemma tan_add {x y : ℂ}
  (h : ((∀ k : ℤ, x ≠ (2 * k + 1) * π / 2) ∧ ∀ l : ℤ, y ≠ (2 * l + 1) * π / 2)
     ∨ ((∃ k : ℤ, x = (2 * k + 1) * π / 2) ∧ ∃ l : ℤ, y = (2 * l + 1) * π / 2)) :
  tan (x + y) = (tan x + tan y) / (1 - tan x * tan y) :=
begin
  rcases h with ⟨h1, h2⟩ | ⟨⟨k, rfl⟩, ⟨l, rfl⟩⟩,
  { rw [tan, sin_add, cos_add,
        ← div_div_div_cancel_right (sin x * cos y + cos x * sin y)
            (mul_ne_zero (cos_ne_zero_iff.mpr h1) (cos_ne_zero_iff.mpr h2)),
        add_div, sub_div],
    simp only [←div_mul_div_comm, ←tan, mul_one, one_mul,
              div_self (cos_ne_zero_iff.mpr h1), div_self (cos_ne_zero_iff.mpr h2)] },
  { obtain ⟨t, hx, hy, hxy⟩ := ⟨tan_int_mul_pi_div_two, t (2*k+1), t (2*l+1), t (2*k+1+(2*l+1))⟩,
    simp only [int.cast_add, int.cast_bit0, int.cast_mul, int.cast_one, hx, hy] at hx hy hxy,
    rw [hx, hy, add_zero, zero_div,
        mul_div_assoc, mul_div_assoc, ← add_mul (2*(k:ℂ)+1) (2*l+1) (π/2), ← mul_div_assoc, hxy] },
end

lemma tan_add' {x y : ℂ}
  (h : ((∀ k : ℤ, x ≠ (2 * k + 1) * π / 2) ∧ ∀ l : ℤ, y ≠ (2 * l + 1) * π / 2)) :
  tan (x + y) = (tan x + tan y) / (1 - tan x * tan y) :=
tan_add (or.inl h)

lemma tan_two_mul {z : ℂ} : tan (2 * z) = 2 * tan z / (1 - tan z ^ 2) :=
begin
  by_cases h : ∀ k : ℤ, z ≠ (2 * k + 1) * π / 2,
  { rw [two_mul, two_mul, sq, tan_add (or.inl ⟨h, h⟩)] },
  { rw not_forall_not at h,
    rw [two_mul, two_mul, sq, tan_add (or.inr ⟨h, h⟩)] },
end

lemma tan_add_mul_I {x y : ℂ}
  (h : ((∀ k : ℤ, x ≠ (2 * k + 1) * π / 2) ∧ ∀ l : ℤ, y * I ≠ (2 * l + 1) * π / 2)
     ∨ ((∃ k : ℤ, x = (2 * k + 1) * π / 2) ∧ ∃ l : ℤ, y * I = (2 * l + 1) * π / 2)) :
  tan (x + y*I) = (tan x + tanh y * I) / (1 - tan x * tanh y * I) :=
by rw [tan_add h, tan_mul_I, mul_assoc]

lemma tan_eq {z : ℂ}
  (h : ((∀ k : ℤ, (z.re:ℂ) ≠ (2 * k + 1) * π / 2) ∧ ∀ l : ℤ, (z.im:ℂ) * I ≠ (2 * l + 1) * π / 2)
     ∨ ((∃ k : ℤ, (z.re:ℂ) = (2 * k + 1) * π / 2) ∧ ∃ l : ℤ, (z.im:ℂ) * I = (2 * l + 1) * π / 2)) :
  tan z = (tan z.re + tanh z.im * I) / (1 - tan z.re * tanh z.im * I) :=
by convert tan_add_mul_I h; exact (re_add_im z).symm

open_locale topology

lemma continuous_on_tan : continuous_on tan {x | cos x ≠ 0} :=
continuous_on_sin.div continuous_on_cos $ λ x, id

@[continuity]
lemma continuous_tan : continuous (λ x : {x | cos x ≠ 0}, tan x) :=
continuous_on_iff_continuous_restrict.1 continuous_on_tan

lemma cos_eq_iff_quadratic {z w : ℂ} :
  cos z = w ↔ (exp (z * I)) ^ 2 - 2 * w * exp (z * I) + 1 = 0 :=
begin
  rw ← sub_eq_zero,
  field_simp [cos, exp_neg, exp_ne_zero],
  refine eq.congr _ rfl,
  ring
end

lemma cos_surjective : function.surjective cos :=
begin
  intro x,
  obtain ⟨w, w₀, hw⟩ : ∃ w ≠ 0, 1 * w * w + (-2 * x) * w + 1 = 0,
  { rcases exists_quadratic_eq_zero one_ne_zero
      ⟨_, ((cpow_nat_inv_pow _ two_ne_zero).symm.trans $ pow_two _)⟩ with ⟨w, hw⟩,
    refine ⟨w, _, hw⟩,
    rintro rfl,
    simpa only [zero_add, one_ne_zero, mul_zero] using hw },
  refine ⟨log w / I, cos_eq_iff_quadratic.2 _⟩,
  rw [div_mul_cancel _ I_ne_zero, exp_log w₀],
  convert hw,
  ring
end

@[simp] lemma range_cos : range cos = set.univ :=
cos_surjective.range_eq

lemma sin_surjective : function.surjective sin :=
begin
  intro x,
  rcases cos_surjective x with ⟨z, rfl⟩,
  exact ⟨z + π / 2, sin_add_pi_div_two z⟩
end

@[simp] lemma range_sin : range sin = set.univ :=
sin_surjective.range_eq

end complex

namespace real

open_locale real

theorem cos_eq_zero_iff {θ : ℝ} : cos θ = 0 ↔ ∃ k : ℤ, θ = (2 * k + 1) * π / 2 :=
by exact_mod_cast @complex.cos_eq_zero_iff θ

theorem cos_ne_zero_iff {θ : ℝ} : cos θ ≠ 0 ↔ ∀ k : ℤ, θ ≠ (2 * k + 1) * π / 2 :=
by rw [← not_exists, not_iff_not, cos_eq_zero_iff]

lemma cos_eq_cos_iff {x y : ℝ} :
  cos x = cos y ↔ ∃ k : ℤ, y = 2 * k * π + x ∨ y = 2 * k * π - x :=
by exact_mod_cast @complex.cos_eq_cos_iff x y

lemma sin_eq_sin_iff {x y : ℝ} :
  sin x = sin y ↔ ∃ k : ℤ, y = 2 * k * π + x ∨ y = (2 * k + 1) * π - x :=
by exact_mod_cast @complex.sin_eq_sin_iff x y

lemma lt_sin_mul {x : ℝ} (hx : 0 < x) (hx' : x < 1) : x < sin ((π / 2) * x) :=
by simpa [mul_comm x] using strict_concave_on_sin_Icc.2 ⟨le_rfl, pi_pos.le⟩
  ⟨pi_div_two_pos.le, half_le_self pi_pos.le⟩ pi_div_two_pos.ne (sub_pos.2 hx') hx

lemma le_sin_mul {x : ℝ} (hx : 0 ≤ x) (hx' : x ≤ 1) : x ≤ sin ((π / 2) * x) :=
by simpa [mul_comm x] using strict_concave_on_sin_Icc.concave_on.2 ⟨le_rfl, pi_pos.le⟩
  ⟨pi_div_two_pos.le, half_le_self pi_pos.le⟩ (sub_nonneg.2 hx') hx

lemma mul_lt_sin {x : ℝ} (hx : 0 < x) (hx' : x < π / 2) : (2 / π) * x < sin x :=
begin
  rw [←inv_div],
  simpa [-inv_div, pi_div_two_pos.ne'] using @lt_sin_mul ((π / 2)⁻¹ * x) _ _,
  { exact mul_pos (inv_pos.2 pi_div_two_pos) hx },
  { rwa [←div_eq_inv_mul, div_lt_one pi_div_two_pos] },
end

/-- In the range `[0, π / 2]`, we have a linear lower bound on `sin`. This inequality forms one half
of Jordan's inequality, the other half is `real.sin_lt` -/
lemma mul_le_sin {x : ℝ} (hx : 0 ≤ x) (hx' : x ≤ π / 2) : (2 / π) * x ≤ sin x :=
begin
  rw [←inv_div],
  simpa [-inv_div, pi_div_two_pos.ne'] using @le_sin_mul ((π / 2)⁻¹ * x) _ _,
  { exact mul_nonneg (inv_nonneg.2 pi_div_two_pos.le) hx },
  { rwa [←div_eq_inv_mul, div_le_one pi_div_two_pos] },
end

end real


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import data.set.lattice
/-!
# Accumulate

The function `accumulate` takes a set `s` and returns `⋃ y ≤ x, s y`.
-/

variables {α β γ : Type*} {s : α → set β} {t : α → set γ}

namespace set

/-- `accumulate s` is the union of `s y` for `y ≤ x`. -/
def accumulate [has_le α] (s : α → set β) (x : α) : set β := ⋃ y ≤ x, s y

variable {s}
lemma accumulate_def [has_le α] {x : α} : accumulate s x = ⋃ y ≤ x, s y := rfl
@[simp] lemma mem_accumulate [has_le α] {x : α} {z : β} : z ∈ accumulate s x ↔ ∃ y ≤ x, z ∈ s y :=
mem_bUnion_iff

lemma subset_accumulate [preorder α] {x : α} : s x ⊆ accumulate s x :=
λ z, mem_bUnion le_rfl

lemma monotone_accumulate [preorder α] : monotone (accumulate s) :=
λ x y hxy, bUnion_subset_bUnion_left $ λ z hz, le_trans hz hxy

lemma bUnion_accumulate [preorder α] (x : α) : (⋃ y ≤ x, accumulate s y) = ⋃ y ≤ x, s y :=
begin
  apply subset.antisymm,
  { exact bUnion_subset (λ x hx, (monotone_accumulate hx : _)) },
  { exact bUnion_subset_bUnion_right (λ x hx, subset_accumulate) }
end

lemma Union_accumulate [preorder α] : (⋃ x, accumulate s x) = ⋃ x, s x :=
begin
  apply subset.antisymm,
  { simp only [subset_def, mem_Union, exists_imp_distrib, mem_accumulate],
    intros z x x' hx'x hz, exact ⟨x', hz⟩ },
  { exact Union_subset_Union (λ i, subset_accumulate),  }
end

end set