/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers, Manuel Candales
-/
import analysis.convex.between
import geometry.euclidean.angle.unoriented.basic

/-!
# Angles between points

This file defines unoriented angles in Euclidean affine spaces.

## Main definitions

* `euclidean_geometry.angle`, with notation `∠`, is the undirected angle determined by three
  points.

-/

noncomputable theory
open_locale big_operators
open_locale real
open_locale real_inner_product_space

namespace euclidean_geometry

open inner_product_geometry

variables {V : Type*} {P : Type*}
  [normed_add_comm_group V] [inner_product_space ℝ V] [metric_space P] [normed_add_torsor V P]
include V

/-- The undirected angle at `p2` between the line segments to `p1` and
`p3`. If either of those points equals `p2`, this is π/2. Use
`open_locale euclidean_geometry` to access the `∠ p1 p2 p3`
notation. -/
def angle (p1 p2 p3 : P) : ℝ := angle (p1 -ᵥ p2 : V) (p3 -ᵥ p2)

localized "notation (name := angle) `∠` := euclidean_geometry.angle" in euclidean_geometry

lemma continuous_at_angle {x : P × P × P} (hx12 : x.1 ≠ x.2.1) (hx32 : x.2.2 ≠ x.2.1) :
  continuous_at (λ y : P × P × P, ∠ y.1 y.2.1 y.2.2) x :=
begin
  let f : P × P × P → V × V := λ y, (y.1 -ᵥ y.2.1, y.2.2 -ᵥ y.2.1),
  have hf1 : (f x).1 ≠ 0, by simp [hx12],
  have hf2 : (f x).2 ≠ 0, by simp [hx32],
  exact (inner_product_geometry.continuous_at_angle hf1 hf2).comp
    ((continuous_fst.vsub continuous_snd.fst).prod_mk
      (continuous_snd.snd.vsub continuous_snd.fst)).continuous_at
end

@[simp] lemma _root_.affine_isometry.angle_map {V₂ P₂ : Type*}
  [normed_add_comm_group V₂] [inner_product_space ℝ V₂]
  [metric_space P₂] [normed_add_torsor V₂ P₂] (f : P →ᵃⁱ[ℝ] P₂) (p₁ p₂ p₃ : P) :
  ∠ (f p₁) (f p₂) (f p₃) = ∠ p₁ p₂ p₃ :=
by simp_rw [angle, ←affine_isometry.map_vsub, linear_isometry.angle_map]

@[simp, norm_cast] lemma _root_.affine_subspace.angle_coe {s : affine_subspace ℝ P}
  (p₁ p₂ p₃ : s) :
  by haveI : nonempty s := ⟨p₁⟩; exact ∠ (p₁ : P) (p₂ : P) (p₃ : P) = ∠ p₁ p₂ p₃ :=
by haveI : nonempty s := ⟨p₁⟩; exact s.subtypeₐᵢ.angle_map p₁ p₂ p₃

/-- Angles are translation invariant -/
@[simp] lemma angle_const_vadd (v : V) (p₁ p₂ p₃ : P) :
  ∠ (v +ᵥ p₁) (v +ᵥ p₂) (v +ᵥ p₃) = ∠ p₁ p₂ p₃ :=
(affine_isometry_equiv.const_vadd ℝ P v).to_affine_isometry.angle_map _ _ _

/-- Angles are translation invariant -/
@[simp] lemma angle_vadd_const (v₁ v₂ v₃ : V) (p : P) :
  ∠ (v₁ +ᵥ p) (v₂ +ᵥ p) (v₃ +ᵥ p) = ∠ v₁ v₂ v₃ :=
(affine_isometry_equiv.vadd_const ℝ p).to_affine_isometry.angle_map _ _ _

/-- Angles are translation invariant -/
@[simp] lemma angle_const_vsub (p p₁ p₂ p₃ : P) : ∠ (p -ᵥ p₁) (p -ᵥ p₂) (p -ᵥ p₃) = ∠ p₁ p₂ p₃ :=
(affine_isometry_equiv.const_vsub ℝ p).to_affine_isometry.angle_map _ _ _

/-- Angles are translation invariant -/
@[simp] lemma angle_vsub_const (p₁ p₂ p₃ p : P) : ∠ (p₁ -ᵥ p) (p₂ -ᵥ p) (p₃ -ᵥ p) = ∠ p₁ p₂ p₃ :=
(affine_isometry_equiv.vadd_const ℝ p).symm.to_affine_isometry.angle_map _ _ _

/-- Angles in a vector space are translation invariant -/
@[simp] lemma angle_add_const (v₁ v₂ v₃ : V) (v : V) : ∠ (v₁ + v) (v₂ + v) (v₃ + v) = ∠ v₁ v₂ v₃ :=
angle_vadd_const _ _ _ _

/-- Angles in a vector space are translation invariant -/
@[simp] lemma angle_const_add (v : V) (v₁ v₂ v₃ : V) : ∠ (v + v₁) (v + v₂) (v + v₃) = ∠ v₁ v₂ v₃ :=
angle_const_vadd _ _ _ _

/-- Angles in a vector space are translation invariant -/
@[simp] lemma angle_sub_const (v₁ v₂ v₃ : V) (v : V) : ∠ (v₁ - v) (v₂ - v) (v₃ - v) = ∠ v₁ v₂ v₃ :=
by simpa only [vsub_eq_sub] using angle_vsub_const v₁ v₂ v₃ v

/-- Angles in a vector space are invariant to inversion -/
@[simp] lemma angle_const_sub (v : V) (v₁ v₂ v₃ : V) : ∠ (v - v₁) (v - v₂) (v - v₃) = ∠ v₁ v₂ v₃ :=
by simpa only [vsub_eq_sub] using angle_const_vsub _ _ _ _

/-- Angles in a vector space are invariant to inversion -/
@[simp] lemma angle_neg (v₁ v₂ v₃ : V) : ∠ (-v₁) (-v₂) (-v₃) = ∠ v₁ v₂ v₃ :=
by simpa only [zero_sub] using angle_const_sub 0 v₁ v₂ v₃

/-- The angle at a point does not depend on the order of the other two
points. -/
lemma angle_comm (p1 p2 p3 : P) : ∠ p1 p2 p3 = ∠ p3 p2 p1 :=
angle_comm _ _

/-- The angle at a point is nonnegative. -/
lemma angle_nonneg (p1 p2 p3 : P) : 0 ≤ ∠ p1 p2 p3 :=
angle_nonneg _ _

/-- The angle at a point is at most π. -/
lemma angle_le_pi (p1 p2 p3 : P) : ∠ p1 p2 p3 ≤ π :=
angle_le_pi _ _

/-- The angle ∠AAB at a point. -/
lemma angle_eq_left (p1 p2 : P) : ∠ p1 p1 p2 = π / 2 :=
begin
  unfold angle,
  rw vsub_self,
  exact angle_zero_left _
end

/-- The angle ∠ABB at a point. -/
lemma angle_eq_right (p1 p2 : P) : ∠ p1 p2 p2 = π / 2 :=
by rw [angle_comm, angle_eq_left]

/-- The angle ∠ABA at a point. -/
lemma angle_eq_of_ne {p1 p2 : P} (h : p1 ≠ p2) : ∠ p1 p2 p1 = 0 :=
angle_self (λ he, h (vsub_eq_zero_iff_eq.1 he))

/-- If the angle ∠ABC at a point is π, the angle ∠BAC is 0. -/
lemma angle_eq_zero_of_angle_eq_pi_left {p1 p2 p3 : P} (h : ∠ p1 p2 p3 = π) :
  ∠ p2 p1 p3 = 0 :=
begin
  unfold angle at h,
  rw angle_eq_pi_iff at h,
  rcases h with ⟨hp1p2, ⟨r, ⟨hr, hpr⟩⟩⟩,
  unfold angle,
  rw angle_eq_zero_iff,
  rw [←neg_vsub_eq_vsub_rev, neg_ne_zero] at hp1p2,
  use [hp1p2, -r + 1, add_pos (neg_pos_of_neg hr) zero_lt_one],
  rw [add_smul, ←neg_vsub_eq_vsub_rev p1 p2, smul_neg],
  simp [←hpr]
end

/-- If the angle ∠ABC at a point is π, the angle ∠BCA is 0. -/
lemma angle_eq_zero_of_angle_eq_pi_right {p1 p2 p3 : P} (h : ∠ p1 p2 p3 = π) :
  ∠ p2 p3 p1 = 0 :=
begin
  rw angle_comm at h,
  exact angle_eq_zero_of_angle_eq_pi_left h
end

/-- If ∠BCD = π, then ∠ABC = ∠ABD. -/
lemma angle_eq_angle_of_angle_eq_pi (p1 : P) {p2 p3 p4 : P} (h : ∠ p2 p3 p4 = π) :
  ∠ p1 p2 p3 = ∠ p1 p2 p4 :=
begin
  unfold angle at *,
  rcases angle_eq_pi_iff.1 h with ⟨hp2p3, ⟨r, ⟨hr, hpr⟩⟩⟩,
  rw [eq_comm],
  convert angle_smul_right_of_pos (p1 -ᵥ p2) (p3 -ᵥ p2) (add_pos (neg_pos_of_neg hr) zero_lt_one),
  rw [add_smul, ← neg_vsub_eq_vsub_rev p2 p3, smul_neg, neg_smul, ← hpr],
  simp
end

/-- If ∠BCD = π, then ∠ACB + ∠ACD = π. -/
lemma angle_add_angle_eq_pi_of_angle_eq_pi (p1 : P) {p2 p3 p4 : P} (h : ∠ p2 p3 p4 = π) :
  ∠ p1 p3 p2 + ∠ p1 p3 p4 = π :=
begin
  unfold angle at h,
  rw [angle_comm p1 p3 p2, angle_comm p1 p3 p4],
  unfold angle,
  exact angle_add_angle_eq_pi_of_angle_eq_pi _ h
end

/-- Vertical Angles Theorem: angles opposite each other, formed by two intersecting straight
lines, are equal. -/
lemma angle_eq_angle_of_angle_eq_pi_of_angle_eq_pi {p1 p2 p3 p4 p5 : P}
  (hapc : ∠ p1 p5 p3 = π) (hbpd : ∠ p2 p5 p4 = π) : ∠ p1 p5 p2 = ∠ p3 p5 p4 :=
by linarith [angle_add_angle_eq_pi_of_angle_eq_pi p1 hbpd, angle_comm p4 p5 p1,
             angle_add_angle_eq_pi_of_angle_eq_pi p4 hapc, angle_comm p4 p5 p3]

/-- If ∠ABC = π then dist A B ≠ 0. -/
lemma left_dist_ne_zero_of_angle_eq_pi {p1 p2 p3 : P} (h : ∠ p1 p2 p3 = π) : dist p1 p2 ≠ 0 :=
begin
  by_contra heq,
  rw [dist_eq_zero] at heq,
  rw [heq, angle_eq_left] at h,
  exact real.pi_ne_zero (by linarith),
end

/-- If ∠ABC = π then dist C B ≠ 0. -/
lemma right_dist_ne_zero_of_angle_eq_pi {p1 p2 p3 : P} (h : ∠ p1 p2 p3 = π) : dist p3 p2 ≠ 0 :=
left_dist_ne_zero_of_angle_eq_pi $ (angle_comm _ _ _).trans h

/-- If ∠ABC = π, then (dist A C) = (dist A B) + (dist B C). -/
lemma dist_eq_add_dist_of_angle_eq_pi {p1 p2 p3 : P} (h : ∠ p1 p2 p3 = π) :
  dist p1 p3 = dist p1 p2 + dist p3 p2 :=
begin
  rw [dist_eq_norm_vsub V, dist_eq_norm_vsub V, dist_eq_norm_vsub V, ← vsub_sub_vsub_cancel_right],
  exact norm_sub_eq_add_norm_of_angle_eq_pi h,
end

/-- If A ≠ B and C ≠ B then ∠ABC = π if and only if (dist A C) = (dist A B) + (dist B C). -/
lemma dist_eq_add_dist_iff_angle_eq_pi {p1 p2 p3 : P} (hp1p2 : p1 ≠ p2) (hp3p2 : p3 ≠ p2) :
  dist p1 p3 = dist p1 p2 + dist p3 p2 ↔ ∠ p1 p2 p3 = π :=
begin
  rw [dist_eq_norm_vsub V, dist_eq_norm_vsub V, dist_eq_norm_vsub V, ← vsub_sub_vsub_cancel_right],
  exact norm_sub_eq_add_norm_iff_angle_eq_pi
    ((λ he, hp1p2 (vsub_eq_zero_iff_eq.1 he))) (λ he, hp3p2 (vsub_eq_zero_iff_eq.1 he)),
end

/-- If ∠ABC = 0, then (dist A C) = abs ((dist A B) - (dist B C)). -/
lemma dist_eq_abs_sub_dist_of_angle_eq_zero {p1 p2 p3 : P} (h : ∠ p1 p2 p3 = 0) :
  (dist p1 p3) = |(dist p1 p2) - (dist p3 p2)| :=
begin
  rw [dist_eq_norm_vsub V, dist_eq_norm_vsub V, dist_eq_norm_vsub V, ← vsub_sub_vsub_cancel_right],
  exact norm_sub_eq_abs_sub_norm_of_angle_eq_zero h,
end

/-- If A ≠ B and C ≠ B then ∠ABC = 0 if and only if (dist A C) = abs ((dist A B) - (dist B C)). -/
lemma dist_eq_abs_sub_dist_iff_angle_eq_zero {p1 p2 p3 : P} (hp1p2 : p1 ≠ p2) (hp3p2 : p3 ≠ p2) :
  (dist p1 p3) = |(dist p1 p2) - (dist p3 p2)| ↔ ∠ p1 p2 p3 = 0 :=
begin
  rw [dist_eq_norm_vsub V, dist_eq_norm_vsub V, dist_eq_norm_vsub V, ← vsub_sub_vsub_cancel_right],
  exact norm_sub_eq_abs_sub_norm_iff_angle_eq_zero
    ((λ he, hp1p2 (vsub_eq_zero_iff_eq.1 he))) (λ he, hp3p2 (vsub_eq_zero_iff_eq.1 he)),
end

/-- If M is the midpoint of the segment AB, then ∠AMB = π. -/
lemma angle_midpoint_eq_pi (p1 p2 : P) (hp1p2 : p1 ≠ p2) : ∠ p1 (midpoint ℝ p1 p2) p2 = π :=
have p2 -ᵥ midpoint ℝ p1 p2 = -(p1 -ᵥ midpoint ℝ p1 p2), by { rw neg_vsub_eq_vsub_rev, simp },
by simp [angle, this, hp1p2, -zero_lt_one]

/-- If M is the midpoint of the segment AB and C is the same distance from A as it is from B
then ∠CMA = π / 2. -/
lemma angle_left_midpoint_eq_pi_div_two_of_dist_eq {p1 p2 p3 : P} (h : dist p3 p1 = dist p3 p2) :
  ∠ p3 (midpoint ℝ p1 p2) p1 = π / 2 :=
begin
  let m : P := midpoint ℝ p1 p2,
  have h1 : p3 -ᵥ p1 = (p3 -ᵥ m) - (p1 -ᵥ m) := (vsub_sub_vsub_cancel_right p3 p1 m).symm,
  have h2 : p3 -ᵥ p2 = (p3 -ᵥ m) + (p1 -ᵥ m),
  { rw [left_vsub_midpoint, ← midpoint_vsub_right, vsub_add_vsub_cancel] },
  rw [dist_eq_norm_vsub V p3 p1, dist_eq_norm_vsub V p3 p2, h1, h2] at h,
  exact (norm_add_eq_norm_sub_iff_angle_eq_pi_div_two (p3 -ᵥ m) (p1 -ᵥ m)).mp h.symm,
end

/-- If M is the midpoint of the segment AB and C is the same distance from A as it is from B
then ∠CMB = π / 2. -/
lemma angle_right_midpoint_eq_pi_div_two_of_dist_eq {p1 p2 p3 : P} (h : dist p3 p1 = dist p3 p2) :
  ∠ p3 (midpoint ℝ p1 p2) p2 = π / 2 :=
by rw [midpoint_comm p1 p2, angle_left_midpoint_eq_pi_div_two_of_dist_eq h.symm]

/-- If the second of three points is strictly between the other two, the angle at that point
is π. -/
lemma _root_.sbtw.angle₁₂₃_eq_pi {p₁ p₂ p₃ : P} (h : sbtw ℝ p₁ p₂ p₃) : ∠ p₁ p₂ p₃ = π :=
begin
  rw [angle, angle_eq_pi_iff],
  rcases h with ⟨⟨r, ⟨hr0, hr1⟩, hp₂⟩, hp₂p₁, hp₂p₃⟩,
  refine ⟨vsub_ne_zero.2 hp₂p₁.symm, -(1 - r) / r, _⟩,
  have hr0' : r ≠ 0,
  { rintro rfl,
    rw ←hp₂ at hp₂p₁,
    simpa using hp₂p₁ },
  have hr1' : r ≠ 1,
  { rintro rfl,
    rw ←hp₂ at hp₂p₃,
    simpa using hp₂p₃ },
  replace hr0 := hr0.lt_of_ne hr0'.symm,
  replace hr1 := hr1.lt_of_ne hr1',
  refine ⟨div_neg_of_neg_of_pos (left.neg_neg_iff.2 (sub_pos.2 hr1)) hr0, _⟩,
  rw [←hp₂, affine_map.line_map_apply, vsub_vadd_eq_vsub_sub, vsub_vadd_eq_vsub_sub, vsub_self,
      zero_sub, smul_neg, smul_smul, div_mul_cancel _ hr0', neg_smul, neg_neg, sub_eq_iff_eq_add,
      ←add_smul, sub_add_cancel, one_smul]
end

/-- If the second of three points is strictly between the other two, the angle at that point
(reversed) is π. -/
lemma _root_.sbtw.angle₃₂₁_eq_pi {p₁ p₂ p₃ : P} (h : sbtw ℝ p₁ p₂ p₃) : ∠ p₃ p₂ p₁ = π :=
by rw [←h.angle₁₂₃_eq_pi, angle_comm]

/-- The angle between three points is π if and only if the second point is strictly between the
other two. -/
lemma angle_eq_pi_iff_sbtw {p₁ p₂ p₃ : P} : ∠ p₁ p₂ p₃ = π ↔ sbtw ℝ p₁ p₂ p₃ :=
begin
  refine ⟨_, λ h, h.angle₁₂₃_eq_pi⟩,
  rw [angle, angle_eq_pi_iff],
  rintro ⟨hp₁p₂, r, hr, hp₃p₂⟩,
  refine ⟨⟨1 / (1 - r),
           ⟨div_nonneg zero_le_one (sub_nonneg.2 (hr.le.trans zero_le_one)),
            (div_le_one (sub_pos.2 (hr.trans zero_lt_one))).2 ((le_sub_self_iff 1).2 hr.le)⟩, _⟩,
          (vsub_ne_zero.1 hp₁p₂).symm, _⟩,
  { rw ←eq_vadd_iff_vsub_eq at hp₃p₂,
    rw [affine_map.line_map_apply, hp₃p₂, vadd_vsub_assoc, ←neg_vsub_eq_vsub_rev p₂ p₁,
        smul_neg, ←neg_smul, smul_add, smul_smul, ←add_smul, eq_comm, eq_vadd_iff_vsub_eq],
    convert (one_smul ℝ (p₂ -ᵥ p₁)).symm,
    field_simp [(sub_pos.2 (hr.trans zero_lt_one)).ne.symm],
    abel },
  { rw [ne_comm, ←@vsub_ne_zero V, hp₃p₂, smul_ne_zero_iff],
    exact ⟨hr.ne, hp₁p₂⟩ }
end

/-- If the second of three points is weakly between the other two, and not equal to the first,
the angle at the first point is zero. -/
lemma _root_.wbtw.angle₂₁₃_eq_zero_of_ne {p₁ p₂ p₃ : P} (h : wbtw ℝ p₁ p₂ p₃) (hp₂p₁ : p₂ ≠ p₁) :
  ∠ p₂ p₁ p₃ = 0 :=
begin
  rw [angle, angle_eq_zero_iff],
  rcases h with ⟨r, ⟨hr0, hr1⟩, rfl⟩,
  have hr0' : r ≠ 0, { rintro rfl, simpa using hp₂p₁ },
  replace hr0 := hr0.lt_of_ne hr0'.symm,
  refine ⟨vsub_ne_zero.2 hp₂p₁, r⁻¹, inv_pos.2 hr0, _⟩,
  rw [affine_map.line_map_apply, vadd_vsub_assoc, vsub_self, add_zero, smul_smul,
      inv_mul_cancel hr0', one_smul]
end

/-- If the second of three points is strictly between the other two, the angle at the first point
is zero. -/
lemma _root_.sbtw.angle₂₁₃_eq_zero {p₁ p₂ p₃ : P} (h : sbtw ℝ p₁ p₂ p₃) : ∠ p₂ p₁ p₃ = 0 :=
h.wbtw.angle₂₁₃_eq_zero_of_ne h.ne_left

/-- If the second of three points is weakly between the other two, and not equal to the first,
the angle at the first point (reversed) is zero. -/
lemma _root_.wbtw.angle₃₁₂_eq_zero_of_ne {p₁ p₂ p₃ : P} (h : wbtw ℝ p₁ p₂ p₃) (hp₂p₁ : p₂ ≠ p₁) :
  ∠ p₃ p₁ p₂ = 0 :=
by rw [←h.angle₂₁₃_eq_zero_of_ne hp₂p₁, angle_comm]

/-- If the second of three points is strictly between the other two, the angle at the first point
(reversed) is zero. -/
lemma _root_.sbtw.angle₃₁₂_eq_zero {p₁ p₂ p₃ : P} (h : sbtw ℝ p₁ p₂ p₃) : ∠ p₃ p₁ p₂ = 0 :=
h.wbtw.angle₃₁₂_eq_zero_of_ne h.ne_left

/-- If the second of three points is weakly between the other two, and not equal to the third,
the angle at the third point is zero. -/
lemma _root_.wbtw.angle₂₃₁_eq_zero_of_ne {p₁ p₂ p₃ : P} (h : wbtw ℝ p₁ p₂ p₃) (hp₂p₃ : p₂ ≠ p₃) :
  ∠ p₂ p₃ p₁ = 0 :=
h.symm.angle₂₁₃_eq_zero_of_ne hp₂p₃

/-- If the second of three points is strictly between the other two, the angle at the third point
is zero. -/
lemma _root_.sbtw.angle₂₃₁_eq_zero {p₁ p₂ p₃ : P} (h : sbtw ℝ p₁ p₂ p₃) : ∠ p₂ p₃ p₁ = 0 :=
h.wbtw.angle₂₃₁_eq_zero_of_ne h.ne_right

/-- If the second of three points is weakly between the other two, and not equal to the third,
the angle at the third point (reversed) is zero. -/
lemma _root_.wbtw.angle₁₃₂_eq_zero_of_ne {p₁ p₂ p₃ : P} (h : wbtw ℝ p₁ p₂ p₃) (hp₂p₃ : p₂ ≠ p₃) :
  ∠ p₁ p₃ p₂ = 0 :=
h.symm.angle₃₁₂_eq_zero_of_ne hp₂p₃

/-- If the second of three points is strictly between the other two, the angle at the third point
(reversed) is zero. -/
lemma _root_.sbtw.angle₁₃₂_eq_zero {p₁ p₂ p₃ : P} (h : sbtw ℝ p₁ p₂ p₃) : ∠ p₁ p₃ p₂ = 0 :=
h.wbtw.angle₁₃₂_eq_zero_of_ne h.ne_right

/-- The angle between three points is zero if and only if one of the first and third points is
weakly between the other two, and not equal to the second. -/
lemma angle_eq_zero_iff_ne_and_wbtw {p₁ p₂ p₃ : P} :
  ∠ p₁ p₂ p₃ = 0 ↔ (p₁ ≠ p₂ ∧ wbtw ℝ p₂ p₁ p₃) ∨ (p₃ ≠ p₂ ∧ wbtw ℝ p₂ p₃ p₁) :=
begin
  split,
  { rw [angle, angle_eq_zero_iff],
    rintro ⟨hp₁p₂, r, hr0, hp₃p₂⟩,
    rcases le_or_lt 1 r with hr1 | hr1,
    { refine or.inl ⟨vsub_ne_zero.1 hp₁p₂, r⁻¹, ⟨(inv_pos.2 hr0).le, inv_le_one hr1⟩, _⟩,
      rw [affine_map.line_map_apply, hp₃p₂, smul_smul, inv_mul_cancel hr0.ne.symm, one_smul,
          vsub_vadd] },
    { refine or.inr ⟨_, r, ⟨hr0.le, hr1.le⟩, _⟩,
      { rw [←@vsub_ne_zero V, hp₃p₂, smul_ne_zero_iff],
        exact ⟨hr0.ne.symm, hp₁p₂⟩ },
      { rw [affine_map.line_map_apply, ←hp₃p₂, vsub_vadd] } } },
  { rintro (⟨hp₁p₂, h⟩ | ⟨hp₃p₂, h⟩),
    { exact h.angle₂₁₃_eq_zero_of_ne hp₁p₂ },
    { exact h.angle₃₁₂_eq_zero_of_ne hp₃p₂ } }
end

/-- The angle between three points is zero if and only if one of the first and third points is
strictly between the other two, or those two points are equal but not equal to the second. -/
lemma angle_eq_zero_iff_eq_and_ne_or_sbtw {p₁ p₂ p₃ : P} :
  ∠ p₁ p₂ p₃ = 0 ↔ (p₁ = p₃ ∧ p₁ ≠ p₂) ∨ sbtw ℝ p₂ p₁ p₃ ∨ sbtw ℝ p₂ p₃ p₁ :=
begin
  rw angle_eq_zero_iff_ne_and_wbtw,
  by_cases hp₁p₂ : p₁ = p₂, { simp [hp₁p₂] },
  by_cases hp₁p₃ : p₁ = p₃, { simp [hp₁p₃] },
  by_cases hp₃p₂ : p₃ = p₂, { simp [hp₃p₂] },
  simp [hp₁p₂, hp₁p₃, ne.symm hp₁p₃, sbtw, hp₃p₂]
end

/-- Three points are collinear if and only if the first or third point equals the second or the
angle between them is 0 or π. -/
lemma collinear_iff_eq_or_eq_or_angle_eq_zero_or_angle_eq_pi {p₁ p₂ p₃ : P} :
  collinear ℝ ({p₁, p₂, p₃} : set P) ↔ p₁ = p₂ ∨ p₃ = p₂ ∨ ∠ p₁ p₂ p₃ = 0 ∨ ∠ p₁ p₂ p₃ = π :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { replace h := h.wbtw_or_wbtw_or_wbtw,
    by_cases h₁₂ : p₁ = p₂, { exact or.inl h₁₂ },
    by_cases h₃₂ : p₃ = p₂, { exact or.inr (or.inl h₃₂) },
    rw [or_iff_right h₁₂, or_iff_right h₃₂],
    rcases h with h | h | h,
    { exact or.inr (angle_eq_pi_iff_sbtw.2 ⟨h, ne.symm h₁₂, ne.symm h₃₂⟩) },
    { exact or.inl (h.angle₃₁₂_eq_zero_of_ne h₃₂) },
    { exact or.inl (h.angle₂₃₁_eq_zero_of_ne h₁₂) } },
  { rcases h with rfl | rfl | h | h,
    { simpa using collinear_pair ℝ p₁ p₃ },
    { simpa using collinear_pair ℝ p₁ p₃ },
    { rw angle_eq_zero_iff_ne_and_wbtw at h,
      rcases h with ⟨-, h⟩ | ⟨-, h⟩,
      { rw set.insert_comm, exact h.collinear },
      { rw [set.insert_comm, set.pair_comm], exact h.collinear } },
    { rw angle_eq_pi_iff_sbtw at h,
      exact h.wbtw.collinear } }
end

/-- If the angle between three points is 0, they are collinear. -/
lemma collinear_of_angle_eq_zero {p₁ p₂ p₃ : P} (h : ∠ p₁ p₂ p₃ = 0) :
  collinear ℝ ({p₁, p₂, p₃} : set P) :=
collinear_iff_eq_or_eq_or_angle_eq_zero_or_angle_eq_pi.2 $ or.inr $ or.inr $ or.inl h

/-- If the angle between three points is π, they are collinear. -/
lemma collinear_of_angle_eq_pi {p₁ p₂ p₃ : P} (h : ∠ p₁ p₂ p₃ = π) :
  collinear ℝ ({p₁, p₂, p₃} : set P) :=
collinear_iff_eq_or_eq_or_angle_eq_zero_or_angle_eq_pi.2 $ or.inr $ or.inr $ or.inr h

/-- If three points are not collinear, the angle between them is nonzero. -/
lemma angle_ne_zero_of_not_collinear {p₁ p₂ p₃ : P} (h : ¬collinear ℝ ({p₁, p₂, p₃} : set P)) :
  ∠ p₁ p₂ p₃ ≠ 0 :=
mt collinear_of_angle_eq_zero h

/-- If three points are not collinear, the angle between them is not π. -/
lemma angle_ne_pi_of_not_collinear {p₁ p₂ p₃ : P} (h : ¬collinear ℝ ({p₁, p₂, p₃} : set P)) :
  ∠ p₁ p₂ p₃ ≠ π :=
mt collinear_of_angle_eq_pi h

/-- If three points are not collinear, the angle between them is positive. -/
lemma angle_pos_of_not_collinear {p₁ p₂ p₃ : P} (h : ¬collinear ℝ ({p₁, p₂, p₃} : set P)) :
  0 < ∠ p₁ p₂ p₃ :=
(angle_nonneg _ _ _).lt_of_ne (angle_ne_zero_of_not_collinear h).symm

/-- If three points are not collinear, the angle between them is less than π. -/
lemma angle_lt_pi_of_not_collinear {p₁ p₂ p₃ : P} (h : ¬collinear ℝ ({p₁, p₂, p₃} : set P)) :
  ∠ p₁ p₂ p₃ < π :=
(angle_le_pi _ _ _).lt_of_ne $ angle_ne_pi_of_not_collinear h

/-- The cosine of the angle between three points is 1 if and only if the angle is 0. -/
lemma cos_eq_one_iff_angle_eq_zero {p₁ p₂ p₃ : P} :
  real.cos (∠ p₁ p₂ p₃) = 1 ↔ ∠ p₁ p₂ p₃ = 0 :=
cos_eq_one_iff_angle_eq_zero

/-- The cosine of the angle between three points is 0 if and only if the angle is π / 2. -/
lemma cos_eq_zero_iff_angle_eq_pi_div_two {p₁ p₂ p₃ : P} :
  real.cos (∠ p₁ p₂ p₃) = 0 ↔ ∠ p₁ p₂ p₃ = π / 2 :=
cos_eq_zero_iff_angle_eq_pi_div_two

/-- The cosine of the angle between three points is -1 if and only if the angle is π. -/
lemma cos_eq_neg_one_iff_angle_eq_pi {p₁ p₂ p₃ : P} :
  real.cos (∠ p₁ p₂ p₃) = -1 ↔ ∠ p₁ p₂ p₃ = π :=
cos_eq_neg_one_iff_angle_eq_pi

/-- The sine of the angle between three points is 0 if and only if the angle is 0 or π. -/
lemma sin_eq_zero_iff_angle_eq_zero_or_angle_eq_pi {p₁ p₂ p₃ : P} :
  real.sin (∠ p₁ p₂ p₃) = 0 ↔ ∠ p₁ p₂ p₃ = 0 ∨ ∠ p₁ p₂ p₃ = π :=
sin_eq_zero_iff_angle_eq_zero_or_angle_eq_pi

/-- The sine of the angle between three points is 1 if and only if the angle is π / 2. -/
lemma sin_eq_one_iff_angle_eq_pi_div_two {p₁ p₂ p₃ : P} :
  real.sin (∠ p₁ p₂ p₃) = 1 ↔ ∠ p₁ p₂ p₃ = π / 2 :=
sin_eq_one_iff_angle_eq_pi_div_two

/-- Three points are collinear if and only if the first or third point equals the second or
the sine of the angle between three points is zero. -/
lemma collinear_iff_eq_or_eq_or_sin_eq_zero {p₁ p₂ p₃ : P} :
  collinear ℝ ({p₁, p₂, p₃} : set P) ↔ p₁ = p₂ ∨ p₃ = p₂ ∨ real.sin (∠ p₁ p₂ p₃) = 0 :=
by rw [sin_eq_zero_iff_angle_eq_zero_or_angle_eq_pi,
       collinear_iff_eq_or_eq_or_angle_eq_zero_or_angle_eq_pi]

/-- If three points are not collinear, the sine of the angle between them is positive. -/
lemma sin_pos_of_not_collinear {p₁ p₂ p₃ : P} (h : ¬collinear ℝ ({p₁, p₂, p₃} : set P)) :
  0 < real.sin (∠ p₁ p₂ p₃) :=
real.sin_pos_of_pos_of_lt_pi (angle_pos_of_not_collinear h) (angle_lt_pi_of_not_collinear h)

/-- If three points are not collinear, the sine of the angle between them is nonzero. -/
lemma sin_ne_zero_of_not_collinear {p₁ p₂ p₃ : P} (h : ¬collinear ℝ ({p₁, p₂, p₃} : set P)) :
  real.sin (∠ p₁ p₂ p₃) ≠ 0 :=
ne_of_gt (sin_pos_of_not_collinear h)

/-- If the sine of the angle between three points is 0, they are collinear. -/
lemma collinear_of_sin_eq_zero {p₁ p₂ p₃ : P} (h : real.sin (∠ p₁ p₂ p₃) = 0) :
  collinear ℝ ({p₁, p₂, p₃} : set P) :=
imp_of_not_imp_not _ _ sin_ne_zero_of_not_collinear h

end euclidean_geometry


/-
Copyright (c) 2020 Kevin Buzzard and
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, and whoever else wants to join in.
-/

-- imports the theory of multivariable polynomials over rings
import data.mv_polynomial
import for_mathlib.mv_polynomial

/-!
# The 𝕀 construction

Let k be a commutative ring and let n be a natural number.

This file defines the map 𝕍 from subsets of k[X₁,X₂,…,Xₙ]
to affine algebraic sets in kⁿ, and the map 𝕀 from affine algebraic
sets in kⁿ to ideals of k[X₁,X₂,…, Xₙ]. It proves basic properties
about them which can be shown without the Nullstellensatz.

To get 𝕍 in VS Code, type `\bbV`.

Note: we never assume that the number of variables is finite,
so actually instead of using a natural number n, we use an
arbitrary set N for our variables.

All the definitions work for k a commutative ring, but not all
of the the theorems do. But computer scientists want us to set
up the theory for commutative rings and mathematicians should
learn to think more like computer scientists.
So k starts off being a commutative ring.

## Important definitions

* `𝕍 : set (mv_polynomial n k) → set (n → k)`
  sending a subset S of k[X₁,X₂,…Xₙ] to the subset of kⁿ cut out by the zeros of all
  the elements of S.

##

## References

Martin Orr's lecture notes at
https://homepages.warwick.ac.uk/staff/Martin.Orr/2017-8/alg-geom/

## Tags

algebraic geometry, algebraic variety, 𝕍
-/

-- start of file
-- We're dealing with multivariable polynomials so let's open
-- the namespace to get easy access to all the functions
open mv_polynomial

-- let k be a commutative ring
variables {k : Type*} [comm_ring k]

-- and let n be any set, but pretend it's {1,2,...,n}.
-- We'll work with polynomials in variables X_i for i ∈ n.
variable {n : Type*}

/- Interlude: Lean 3 notation hell.

* the multivariable polynomial ring k[X₁, X₂, ..., Xₙ] is denoted
  `mv_polynomial n k`.

* The set kⁿ is denoted
  `n → k`
  (which means maps from n to k, and if you're thinking
   about n as {1,2,3,...,n} then you can see that this makes sense).

* subsets of a set X are denoted
  `set X`

* To evaluate a polynomial f on a vector x, we seem to have to write
  `eval x f`
  Note the order! "Maps on the right".

-/

namespace affine_algebraic_set

/-- 𝕀 : the function sending a subset of kⁿ to
  a subset of k[X₁,X₂,…Xₙ], defined in Martin Orr's notes. -/
def 𝕀 (X : set (n → k)) : set (mv_polynomial n k) :=
{f | ∀ x ∈ X, eval x f = 0 }

open set

/-- f ∈ 𝕀 X ↔ for all x ∈ X, f(x) = 0. This is true by definition. -/
lemma mem_𝕀_iff {X : set (n → k)} {f : mv_polynomial n k} :
  f ∈ 𝕀 X ↔ ∀ x ∈ X, eval x f = 0 := iff.rfl

-- proofs which a mathematician might get something from start here

/-- 𝕀 ∅ = all of k[X₁,X₂,…,Xₙ] -/
lemma empty : 𝕀 (∅ : set (n → k)) = univ :=
begin
  -- we have to prove that every f ∈ k[X₁,X₂,…,Xₙ] is in 𝕀 ∅
  rw eq_univ_iff_forall,
  -- so say f ∈ k[X₁,X₂,…,Xₙ] is arbitrary
  intro f,
  -- and we need to prove f ∈ 𝕀 ∅.
  -- Equivalently, we need to prove that for all x ∈ ∅, f(x) = 0
  rw mem_𝕀_iff,
  -- so say x is in the empty set
  intros x hx,
  -- and now we have a contradiction, so we can prove anything
  cases hx
end

lemma univ {k : Type*} [integral_domain k] [infinite k] {n : Type*} :
  𝕀 (univ : set (n → k)) = {0} :=
begin
  -- we prove inclusions in both directions
  apply set.subset.antisymm,
  { -- this way is the slightly tricky way;
    -- we need to prove that 𝕀 (kⁿ) ⊆ 0
    -- so say f ∈ 𝕀 (kⁿ) is arbitrary
    intros f hf,
    -- and we need to prove it's zero
    rw mem_singleton_iff,
    -- -> only poly that's zero everywhere is zero poly
    rw mem_𝕀_iff at hf,
    rw ←mv_polynomial.eval_eq_zero,
    intro x, apply hf x, apply mem_univ,
  },
  {
    -- unpack set
     rw singleton_subset_iff,
     -- apply definition of 𝕀
     rw mem_𝕀_iff,
     simp,
  },
end

lemma 𝕀_antimono (V W : set (n → k)) :
  V ⊆ W → 𝕀 W ⊆ 𝕀 V :=
begin
  -- Assume V ⊆ W and f a polynomial
  intros H f,
  -- Apply Definition of 𝕀 twice
  rw [mem_𝕀_iff,mem_𝕀_iff],
  -- More Assumptions
  intro P,
  intros x HX,
  -- Use that f(x)=0 ∀ x∈W
  apply P,
  -- Use V ⊆ W
  from H HX,
end

-- The image of 𝕀 is an ideal

-- We do this by defining a function 𝕀' from subsets of kⁿ to ideals of R,
-- and showing that 𝕀' agrees with 𝕀 when you take the ideal and consider
-- it as a set
noncomputable def 𝕀' (X : set (n → k)) : ideal (mv_polynomial n k) :=
{ carrier := 𝕀 X, -- underlying set is just 𝕀(X)
  zero := by simp [𝕀], -- zero is obviously in.
  add := begin
    -- Goal: if f and g are in 𝕀(X), then so is f + g.
    -- say f and g are elements of 𝕀(X).
    rintros f g hf hg,
    -- We know f(x) = 0 for all x ∈ X and g(x) = 0 for all x ∈ X
    change ∀ (x : n → k), x ∈ X → eval x f = 0 at hf,
    change ∀ (x : n → k), x ∈ X → eval x g = 0 at hg,
    -- so now say x ∈ X.
    intros x hx,
    -- We want to prove (f + g)(x)=0. But (f + g)(x)=f(x) + g(x)
    rw eval_add,
    -- so (f + g)(x) = 0 + 0
    rw [hf _ hx, hg _ hx],
    -- which is 0
    apply zero_add
  end,
  smul := begin
    -- goal: if f ∈ 𝕀(X) and c ∈ k[X₁,X₂,…,X_ₙ], then cf ∈ 𝕀(X).
    rintros c f hf,
    -- We know f(x) = 0 for all x ∈ X.
    change ∀ (x : n → k), x ∈ X → eval x f = 0 at hf,
    -- Let's choose x ∈ X
    intros x hx,
    -- We need to prove cf(x)=0.
    -- But cf(x)=c(x)f(x)
    rw [smul_eq_mul, eval_mul],
    -- and f(x)=0
    rw hf _ hx,
    -- so we're done
    rw mul_zero
    -- refl omitted because Lean rw is clever
  end }

lemma 𝕀_eq_𝕀' (X : set (n → k)) : (𝕀' X : set (mv_polynomial n k)) = 𝕀 X := rfl

end affine_algebraic_set


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

! This file was ported from Lean 3 source module dynamics.ergodic.conservative
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Constructions.BorelSpace
import Mathbin.Dynamics.Ergodic.MeasurePreserving
import Mathbin.Combinatorics.Pigeonhole

/-!
# Conservative systems

In this file we define `f : α → α` to be a *conservative* system w.r.t a measure `μ` if `f` is
non-singular (`measure_theory.quasi_measure_preserving`) and for every measurable set `s` of
positive measure at least one point `x ∈ s` returns back to `s` after some number of iterations of
`f`. There are several properties that look like they are stronger than this one but actually follow
from it:

* `measure_theory.conservative.frequently_measure_inter_ne_zero`,
  `measure_theory.conservative.exists_gt_measure_inter_ne_zero`: if `μ s ≠ 0`, then for infinitely
  many `n`, the measure of `s ∩ (f^[n]) ⁻¹' s` is positive.

* `measure_theory.conservative.measure_mem_forall_ge_image_not_mem_eq_zero`,
  `measure_theory.conservative.ae_mem_imp_frequently_image_mem`: a.e. every point of `s` visits `s`
  infinitely many times (Poincaré recurrence theorem).

We also prove the topological Poincaré recurrence theorem
`measure_theory.conservative.ae_frequently_mem_of_mem_nhds`. Let `f : α → α` be a conservative
dynamical system on a topological space with second countable topology and measurable open
sets. Then almost every point `x : α` is recurrent: it visits every neighborhood `s ∈ 𝓝 x`
infinitely many times.

## Tags

conservative dynamical system, Poincare recurrence theorem
-/

noncomputable section

open Classical Set Filter MeasureTheory Finset Function TopologicalSpace

open Classical Topology

variable {ι : Type _} {α : Type _} [MeasurableSpace α] {f : α → α} {s : Set α} {μ : Measure α}

namespace MeasureTheory

open Measure

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (m «expr ≠ » 0) -/
/-- We say that a non-singular (`measure_theory.quasi_measure_preserving`) self-map is
*conservative* if for any measurable set `s` of positive measure there exists `x ∈ s` such that `x`
returns back to `s` under some iteration of `f`. -/
structure Conservative (f : α → α)
  (μ : Measure α := by exact MeasureTheory.MeasureSpace.volume) extends
  QuasiMeasurePreserving f μ μ : Prop where
  exists_mem_image_mem :
    ∀ ⦃s⦄, MeasurableSet s → μ s ≠ 0 → ∃ x ∈ s, ∃ (m : _)(_ : m ≠ 0), (f^[m]) x ∈ s
#align measure_theory.conservative MeasureTheory.Conservative

/-- A self-map preserving a finite measure is conservative. -/
protected theorem MeasurePreserving.conservative [IsFiniteMeasure μ] (h : MeasurePreserving f μ μ) :
    Conservative f μ :=
  ⟨h.QuasiMeasurePreserving, fun s hsm h0 => h.exists_mem_image_mem hsm h0⟩
#align measure_theory.measure_preserving.conservative MeasureTheory.MeasurePreserving.conservative

namespace Conservative

/-- The identity map is conservative w.r.t. any measure. -/
protected theorem id (μ : Measure α) : Conservative id μ :=
  { toQuasiMeasurePreserving := QuasiMeasurePreserving.id μ
    exists_mem_image_mem := fun s hs h0 =>
      let ⟨x, hx⟩ := nonempty_of_measure_ne_zero h0
      ⟨x, hx, 1, one_ne_zero, hx⟩ }
#align measure_theory.conservative.id MeasureTheory.Conservative.id

/-- If `f` is a conservative map and `s` is a measurable set of nonzero measure, then
for infinitely many values of `m` a positive measure of points `x ∈ s` returns back to `s`
after `m` iterations of `f`. -/
theorem frequently_measure_inter_ne_zero (hf : Conservative f μ) (hs : MeasurableSet s)
    (h0 : μ s ≠ 0) : ∃ᶠ m in atTop, μ (s ∩ f^[m] ⁻¹' s) ≠ 0 :=
  by
  by_contra H
  simp only [not_frequently, eventually_at_top, Ne.def, Classical.not_not] at H
  rcases H with ⟨N, hN⟩
  induction' N with N ihN
  · apply h0
    simpa using hN 0 le_rfl
  rw [imp_false] at ihN
  push_neg  at ihN
  rcases ihN with ⟨n, hn, hμn⟩
  set T := s ∩ ⋃ n ≥ N + 1, f^[n] ⁻¹' s
  have hT : MeasurableSet T :=
    hs.inter (MeasurableSet.bunionᵢ (to_countable _) fun _ _ => hf.measurable.iterate _ hs)
  have hμT : μ T = 0 :=
    by
    convert(measure_bUnion_null_iff <| to_countable _).2 hN
    rw [← inter_Union₂]
    rfl
  have : μ ((s ∩ f^[n] ⁻¹' s) \ T) ≠ 0 := by rwa [measure_diff_null hμT]
  rcases hf.exists_mem_image_mem ((hs.inter (hf.measurable.iterate n hs)).diffₓ hT) this with
    ⟨x, ⟨⟨hxs, hxn⟩, hxT⟩, m, hm0, ⟨hxms, hxm⟩, hxx⟩
  refine' hxT ⟨hxs, mem_Union₂.2 ⟨n + m, _, _⟩⟩
  · exact add_le_add hn (Nat.one_le_of_lt <| pos_iff_ne_zero.2 hm0)
  · rwa [Set.mem_preimage, ← iterate_add_apply] at hxm
#align measure_theory.conservative.frequently_measure_inter_ne_zero MeasureTheory.Conservative.frequently_measure_inter_ne_zero

/-- If `f` is a conservative map and `s` is a measurable set of nonzero measure, then
for an arbitrarily large `m` a positive measure of points `x ∈ s` returns back to `s`
after `m` iterations of `f`. -/
theorem exists_gt_measure_inter_ne_zero (hf : Conservative f μ) (hs : MeasurableSet s)
    (h0 : μ s ≠ 0) (N : ℕ) : ∃ m > N, μ (s ∩ f^[m] ⁻¹' s) ≠ 0 :=
  let ⟨m, hm, hmN⟩ :=
    ((hf.frequently_measure_inter_ne_zero hs h0).and_eventually (eventually_gt_atTop N)).exists
  ⟨m, hmN, hm⟩
#align measure_theory.conservative.exists_gt_measure_inter_ne_zero MeasureTheory.Conservative.exists_gt_measure_inter_ne_zero

/-- Poincaré recurrence theorem: given a conservative map `f` and a measurable set `s`, the set
of points `x ∈ s` such that `x` does not return to `s` after `≥ n` iterations has measure zero. -/
theorem measure_mem_forall_ge_image_not_mem_eq_zero (hf : Conservative f μ) (hs : MeasurableSet s)
    (n : ℕ) : μ ({ x ∈ s | ∀ m ≥ n, (f^[m]) x ∉ s }) = 0 :=
  by
  by_contra H
  have : MeasurableSet (s ∩ { x | ∀ m ≥ n, (f^[m]) x ∉ s }) :=
    by
    simp only [set_of_forall, ← compl_set_of]
    exact
      hs.inter (MeasurableSet.binterᵢ (to_countable _) fun m _ => hf.measurable.iterate m hs.compl)
  rcases(hf.exists_gt_measure_inter_ne_zero this H) n with ⟨m, hmn, hm⟩
  rcases nonempty_of_measure_ne_zero hm with ⟨x, ⟨hxs, hxn⟩, hxm, -⟩
  exact hxn m hmn.lt.le hxm
#align measure_theory.conservative.measure_mem_forall_ge_image_not_mem_eq_zero MeasureTheory.Conservative.measure_mem_forall_ge_image_not_mem_eq_zero

/-- Poincaré recurrence theorem: given a conservative map `f` and a measurable set `s`,
almost every point `x ∈ s` returns back to `s` infinitely many times. -/
theorem ae_mem_imp_frequently_image_mem (hf : Conservative f μ) (hs : MeasurableSet s) :
    ∀ᵐ x ∂μ, x ∈ s → ∃ᶠ n in atTop, (f^[n]) x ∈ s :=
  by
  simp only [frequently_at_top, @forall_swap (_ ∈ s), ae_all_iff]
  intro n
  filter_upwards [measure_zero_iff_ae_nmem.1 (hf.measure_mem_forall_ge_image_not_mem_eq_zero hs n)]
  simp
#align measure_theory.conservative.ae_mem_imp_frequently_image_mem MeasureTheory.Conservative.ae_mem_imp_frequently_image_mem

theorem inter_frequently_image_mem_ae_eq (hf : Conservative f μ) (hs : MeasurableSet s) :
    (s ∩ { x | ∃ᶠ n in atTop, (f^[n]) x ∈ s } : Set α) =ᵐ[μ] s :=
  inter_eventuallyEq_left.2 <| hf.ae_mem_imp_frequently_image_mem hs
#align measure_theory.conservative.inter_frequently_image_mem_ae_eq MeasureTheory.Conservative.inter_frequently_image_mem_ae_eq

theorem measure_inter_frequently_image_mem_eq (hf : Conservative f μ) (hs : MeasurableSet s) :
    μ (s ∩ { x | ∃ᶠ n in atTop, (f^[n]) x ∈ s }) = μ s :=
  measure_congr (hf.inter_frequently_image_mem_ae_eq hs)
#align measure_theory.conservative.measure_inter_frequently_image_mem_eq MeasureTheory.Conservative.measure_inter_frequently_image_mem_eq

/-- Poincaré recurrence theorem: if `f` is a conservative dynamical system and `s` is a measurable
set, then for `μ`-a.e. `x`, if the orbit of `x` visits `s` at least once, then it visits `s`
infinitely many times.  -/
theorem ae_forall_image_mem_imp_frequently_image_mem (hf : Conservative f μ)
    (hs : MeasurableSet s) : ∀ᵐ x ∂μ, ∀ k, (f^[k]) x ∈ s → ∃ᶠ n in atTop, (f^[n]) x ∈ s :=
  by
  refine' ae_all_iff.2 fun k => _
  refine' (hf.ae_mem_imp_frequently_image_mem (hf.measurable.iterate k hs)).mono fun x hx hk => _
  rw [← map_add_at_top_eq_nat k, frequently_map]
  refine' (hx hk).mono fun n hn => _
  rwa [add_comm, iterate_add_apply]
#align measure_theory.conservative.ae_forall_image_mem_imp_frequently_image_mem MeasureTheory.Conservative.ae_forall_image_mem_imp_frequently_image_mem

/-- If `f` is a conservative self-map and `s` is a measurable set of positive measure, then
`μ.ae`-frequently we have `x ∈ s` and `s` returns to `s` under infinitely many iterations of `f`. -/
theorem frequently_ae_mem_and_frequently_image_mem (hf : Conservative f μ) (hs : MeasurableSet s)
    (h0 : μ s ≠ 0) : ∃ᵐ x ∂μ, x ∈ s ∧ ∃ᶠ n in atTop, (f^[n]) x ∈ s :=
  ((frequently_ae_mem_iff.2 h0).and_eventually (hf.ae_mem_imp_frequently_image_mem hs)).mono
    fun x hx => ⟨hx.1, hx.2 hx.1⟩
#align measure_theory.conservative.frequently_ae_mem_and_frequently_image_mem MeasureTheory.Conservative.frequently_ae_mem_and_frequently_image_mem

/-- Poincaré recurrence theorem. Let `f : α → α` be a conservative dynamical system on a topological
space with second countable topology and measurable open sets. Then almost every point `x : α`
is recurrent: it visits every neighborhood `s ∈ 𝓝 x` infinitely many times. -/
theorem ae_frequently_mem_of_mem_nhds [TopologicalSpace α] [SecondCountableTopology α]
    [OpensMeasurableSpace α] {f : α → α} {μ : Measure α} (h : Conservative f μ) :
    ∀ᵐ x ∂μ, ∀ s ∈ 𝓝 x, ∃ᶠ n in atTop, (f^[n]) x ∈ s :=
  by
  have : ∀ s ∈ countable_basis α, ∀ᵐ x ∂μ, x ∈ s → ∃ᶠ n in at_top, (f^[n]) x ∈ s := fun s hs =>
    h.ae_mem_imp_frequently_image_mem (is_open_of_mem_countable_basis hs).MeasurableSet
  refine' ((ae_ball_iff <| countable_countable_basis α).2 this).mono fun x hx s hs => _
  rcases(is_basis_countable_basis α).mem_nhds_iffₓ.1 hs with ⟨o, hoS, hxo, hos⟩
  exact (hx o hoS hxo).mono fun n hn => hos hn
#align measure_theory.conservative.ae_frequently_mem_of_mem_nhds MeasureTheory.Conservative.ae_frequently_mem_of_mem_nhds

/-- Iteration of a conservative system is a conservative system. -/
protected theorem iterate (hf : Conservative f μ) (n : ℕ) : Conservative (f^[n]) μ :=
  by
  cases n
  · exact conservative.id μ
  -- Discharge the trivial case `n = 0`
  refine' ⟨hf.1.iterate _, fun s hs hs0 => _⟩
  rcases(hf.frequently_ae_mem_and_frequently_image_mem hs hs0).exists with ⟨x, hxs, hx⟩
  /- We take a point `x ∈ s` such that `f^[k] x ∈ s` for infinitely many values of `k`,
    then we choose two of these values `k < l` such that `k ≡ l [MOD (n + 1)]`.
    Then `f^[k] x ∈ s` and `(f^[n + 1])^[(l - k) / (n + 1)] (f^[k] x) = f^[l] x ∈ s`. -/
  rw [Nat.frequently_atTop_iff_infinite] at hx
  rcases Nat.exists_lt_modEq_of_infinite hx n.succ_pos with ⟨k, hk, l, hl, hkl, hn⟩
  set m := (l - k) / (n + 1)
  have : (n + 1) * m = l - k := by
    apply Nat.mul_div_cancel'
    exact (Nat.modEq_iff_dvd' hkl.le).1 hn
  refine' ⟨(f^[k]) x, hk, m, _, _⟩
  · intro hm
    rw [hm, MulZeroClass.mul_zero, eq_comm, tsub_eq_zero_iff_le] at this
    exact this.not_lt hkl
  · rwa [← iterate_mul, this, ← iterate_add_apply, tsub_add_cancel_of_le]
    exact hkl.le
#align measure_theory.conservative.iterate MeasureTheory.Conservative.iterate

end Conservative

end MeasureTheory


/- -----------------------------------------------------------------------
Categories.
----------------------------------------------------------------------- -/

import ...p0_stdlib

namespace qp

open stdaux

universe variables ℓ ℓobj ℓhom ℓobj₁ ℓhom₁ ℓobj₂ ℓhom₂

/-! #brief A strict category.
-/
structure Cat
    : Type ((max ℓobj ℓhom) + 1)
:= (obj
    : Type ℓobj)
   (hom
     : ∀ (x y : obj)
       , Sort ℓhom)
   (id
     : ∀ (x : obj)
       , hom x x)
   (circ
     : ∀ {x y z : obj}
       , hom y z → hom x y → hom x z)
   (circ_assoc
     : ∀ {x y z w : obj}
          {h : hom z w} {g : hom y z} {f : hom x y}
       , circ h (circ g f) = circ (circ h g) f)
   (circ_id_left
     : ∀ {x y : obj} {f : hom x y}
       , circ (id y) f = f)
   (circ_id_right
     : ∀ {x y : obj} {f : hom x y}
       , circ f (id x) = f)

attribute [simp] Cat.circ_id_left
attribute [simp] Cat.circ_id_right

/-! #brief Equality of categories.
-/
theorem Cat.eq
    : ∀ {C₁ C₂ : Cat.{ℓobj ℓhom}}
      , C₁^.obj = C₂^.obj
      → C₁^.hom == C₂^.hom
      → C₁^.id == C₂^.id
      → @Cat.circ C₁ == @Cat.circ C₂
      → C₁ = C₂
| C₁ C₂ ωobj ωhom ωid ωcirc
:= begin
     cases C₁ with obj₁ hom₁ id₁ circ₁ ω₁₁ ω₁₂ ω₁₃,
     cases C₂ with obj₂ hom₂ id₂ circ₂ ω₂₁ ω₂₂ ω₂₃,
     simp at ωobj, subst ωobj,
     simp at ωhom, cases ωhom,
     simp at ωid, cases ωid,
     simp at ωcirc, cases ωcirc,
     exact rfl
   end

/-! #brief Left congruence for circ.
-/
theorem Cat.circ.congr_left {C : Cat.{ℓobj ℓhom}}
    {x y z : C^.obj}
    : ∀ {g₁ g₂ : C^.hom y z}
        {f : C^.hom x y}
        (ωg : g₁ = g₂)
      , C^.circ g₁ f = C^.circ g₂ f
| g .(g) f (eq.refl .(g)) := rfl

/-! #brief Right congruence for circ.
-/
theorem Cat.circ.congr_right {C : Cat.{ℓobj ℓhom}}
    {x y z : C^.obj}
    : ∀ {g : C^.hom y z}
        {f₁ f₂ : C^.hom x y}
        (ωf : f₁ = f₂)
      , C^.circ g f₁ = C^.circ g f₂
| g f .(f) (eq.refl .(f)) := rfl

/-! #brief Bi-congruence for circ.
-/
theorem Cat.circ.congr {C : Cat.{ℓobj ℓhom}}
    {x y z : C^.obj}
    : ∀ {g₁ g₂ : C^.hom y z}
        {f₁ f₂ : C^.hom x y}
        (ωg : g₁ = g₂)
        (ωf : f₁ = f₂)
      , C^.circ g₁ f₁ = C^.circ g₂ f₂
| g .(g) f .(f) (eq.refl .(g)) (eq.refl .(f)) := rfl

-- An object in a category.
-- \[[ \]]
notation `⟦` C `⟧` := Cat.obj C

-- The identity hom at an object.
-- \langle\langle \rangle\rangle
notation `⟨⟨` x `⟩⟩` := Cat.id _ x

-- A hom in a category.
-- \[[ : \to\to \]]
notation `⟦` C ` : ` x ` →→ ` y `⟧` := Cat.hom C x y

-- Composition of hom's in a category.
-- \o\o
infixl ` ∘∘ ` : 100 := Cat.circ _

/-! #brief A finite category.
-/
class Cat.Finite (C : Cat.{ℓobj ℓhom})
    : Type (max ℓobj ℓhom)
:= (obj_fin : FinType C^.obj)
   (hom_fin : ∀ (x y : C^.obj), FinSort (C^.hom x y))

attribute [instance] Cat.Finite.obj_fin
attribute [instance] Cat.Finite.hom_fin

/- -----------------------------------------------------------------------
The empty and star categories.
----------------------------------------------------------------------- -/

/-! #brief The category with one object and one hom.
-/
definition UnitCat : Cat.{ℓobj ℓhom}
:= { obj := punit
   , hom := λ u₁ u₂, punit
   , id := λ u, punit.star
   , circ := λ u₁ u₂ u₃ g f, punit.star
   , circ_assoc := λ u₁ u₂ u₃ u₄ h g f, rfl
   , circ_id_left := λ u₁ u₂ f, begin cases f, trivial end
   , circ_id_right := λ u₁ u₂ f, begin cases f, trivial end
   }

/-! #brief UnitCat is a finite category.
-/
instance UnitCat.Finite
    : Cat.Finite (UnitCat.{ℓobj ℓhom})
:= { obj_fin := punit.FinSort
   , hom_fin := λ u₁ u₂, punit.FinSort
   }

/-! #brief The category with no objects.
-/
definition EmptyCat : Cat.{ℓobj ℓhom}
:= { obj := pempty
   , hom := λ u₁ u₂, pempty
   , id := λ u, by cases u
   , circ := λ u₁ u₂ u₃ g f, by cases f
   , circ_assoc := λ u₁ u₂ u₃ u₄ h g f, by cases f
   , circ_id_left := λ u₁ u₂ f, by cases f
   , circ_id_right := λ u₁ u₂ f, by cases f
   }

/-! #brief EmptyCat is a finite category.
-/
instance EmptyCat.Finite
    : Cat.Finite (EmptyCat.{ℓobj ℓhom})
:= { obj_fin := pempty.FinSort
   , hom_fin := λ u₁ u₂, pempty.FinSort
   }

/- -----------------------------------------------------------------------
The Lean categories.
----------------------------------------------------------------------- -/

/-! #brief The category of Lean sorts at level ℓ.
-/
definition SortCat : Cat.{ℓ ℓ}
:= { obj := Sort.{ℓ}
   , hom := λ X Y, X → Y
   , id := λ X x, x
   , circ := λ X Y Z g f x, g (f x)
   , circ_assoc := λ X Y Z W h g f, rfl
   , circ_id_left := λ X Y f, rfl
   , circ_id_right := λ X Y f, rfl
   }

/-! #brief Composition in SortCat.
-/
theorem SortCat.simp_circ
    {X Y Z : SortCat.{ℓ}^.obj}
    {g : SortCat^.hom Y Z} {f : SortCat^.hom X Y}
    {x : X}
    : SortCat^.circ g f x = g (f x)
:= rfl

/-! #brief The category of Lean propositions.
-/
definition PropCat : Cat.{0 0}
:= SortCat.{0}

example : PropCat^.obj := true

/-! #brief Composition in PropCat.
-/
theorem PropCat.simp_circ
    {X Y Z : PropCat^.obj}
    {g : PropCat^.hom Y Z} {f : PropCat^.hom X Y}
    {x : X}
    : PropCat^.circ g f x = g (f x)
:= rfl

/-! #brief The category of Lean types at level ℓ.
-/
definition LeanCat : Cat.{(ℓ + 1) (ℓ + 1)}
:= SortCat.{ℓ + 1}

example : LeanCat.{0}^.obj := ℕ
example : LeanCat.{1}^.obj := ℕ → LeanCat.{0}^.obj
example : LeanCat.{ℓ}^.obj := punit
example : LeanCat.{ℓ}^.obj := list punit

/-! #brief Composition in LeanCat.
-/
theorem LeanCat.simp_circ
    {X Y Z : LeanCat.{ℓ}^.obj}
    {g : LeanCat^.hom Y Z} {f : LeanCat^.hom X Y}
    {x : X}
    : LeanCat^.circ g f x = g (f x)
:= rfl

/- -----------------------------------------------------------------------
Categories which box up certain theories.
----------------------------------------------------------------------- -/

/-! #brief The category of relations and monotone functions.
-/
definition CatOfRels : Cat.{(ℓ + 1) (ℓ + 1)}
:= { obj := Σ (A : Type ℓ), (A → A → Prop)
   , hom := λ A B, { f : A^.fst → B^.fst // monotone A^.snd B^.snd f }
   , id := λ A, { val := id, property := id.monotone A^.snd }
   , circ := λ A B C g f, { val := λ a, g^.val (f^.val a)
                          , property := begin
                                          intros a₁ a₂ ω,
                                          apply g^.property,
                                          apply f^.property,
                                          exact ω
                                        end
                          }
   , circ_assoc := λ A B C D h g f, subtype.eq rfl
   , circ_id_left := λ A B f, subtype.eq rfl
   , circ_id_right := λ A B f, subtype.eq rfl
   }

/-! #brief The category of preorders and monotone functions.
-/
definition CatOfPreorders : Cat.{(ℓ + 1) (ℓ + 1)}
:= { obj := { A : Σ (A : Type ℓ), (A → A → Prop) // reflexive A^.snd ∧ transitive A^.snd }
   , hom := λ A B, { f : A^.val^.fst → B^.val^.fst // monotone A^.val^.snd B^.val^.snd f }
   , id := λ A, { val := id, property := id.monotone A^.val^.snd }
   , circ := λ A B C g f, { val := λ a, g^.val (f^.val a)
                          , property := begin
                                          intros a₁ a₂ ω,
                                          apply g^.property,
                                          apply f^.property,
                                          exact ω
                                        end
                          }
   , circ_assoc := λ A B C D h g f, subtype.eq rfl
   , circ_id_left := λ A B f, subtype.eq rfl
   , circ_id_right := λ A B f, subtype.eq rfl
   }

/-! #brief The category of semigroups.
-/
definition CatOfSemigroups : Cat.{(ℓ + 1) (ℓ + 1)}
:= { obj := Σ (A : Type ℓ), semigroup A
   , hom := λ A B, { f : A^.fst → B^.fst // @semigroup.hom _ A^.snd _ B^.snd f }
   , id := λ A, { val := id, property := @semigroup.hom_id _ A^.snd }
   , circ := λ A B C g f, { val := λ a, g^.val (f^.val a)
                          , property := @semigroup.hom_comp
                                         _ A^.snd _ B^.snd _ C^.snd
                                         _ g^.property _ f^.property
                          }
   , circ_assoc := λ A B C D h g f, subtype.eq rfl
   , circ_id_left := λ A B f, subtype.eq rfl
   , circ_id_right := λ A B f, subtype.eq rfl
   }

/-! #brief The category of monoids.
-/
definition CatOfMonoids : Cat.{(ℓ + 1) (ℓ + 1)}
:= { obj := Σ (A : Type ℓ), monoid A
   , hom := λ A B, { f : A^.fst → B^.fst // @monoid.hom _ A^.snd _ B^.snd f }
   , id := λ A, { val := id, property := @monoid.hom_id _ A^.snd }
   , circ := λ A B C g f, { val := λ a, g^.val (f^.val a)
                          , property := @monoid.hom_comp
                                         _ A^.snd _ B^.snd _ C^.snd
                                         _ g^.property _ f^.property
                          }
   , circ_assoc := λ A B C D h g f, subtype.eq rfl
   , circ_id_left := λ A B f, subtype.eq rfl
   , circ_id_right := λ A B f, subtype.eq rfl
   }

/-! #brief The category of groups.
-/
definition CatOfGroups : Cat.{(ℓ + 1) (ℓ + 1)}
:= { obj := Σ (A : Type ℓ), group A
   , hom := λ A B, { f : A^.fst → B^.fst // @group.hom _ A^.snd _ B^.snd f }
   , id := λ A, { val := id, property := @group.hom_id _ A^.snd }
   , circ := λ A B C g f, { val := λ a, g^.val (f^.val a)
                          , property := @group.hom_comp
                                         _ A^.snd _ B^.snd _ C^.snd
                                         _ g^.property _ f^.property
                          }
   , circ_assoc := λ A B C D h g f, subtype.eq rfl
   , circ_id_left := λ A B f, subtype.eq rfl
   , circ_id_right := λ A B f, subtype.eq rfl
   }

/-! #brief The category of commutative rings.
-/
definition CatOfCommRings : Cat.{(ℓ + 1) (ℓ + 1)}
:= { obj := Σ (A : Type ℓ), comm_ring A
   , hom := λ A B, { f : A^.fst → B^.fst // @comm_ring.hom _ A^.snd _ B^.snd f }
   , id := λ A, { val := id, property := @comm_ring.hom_id _ A^.snd }
   , circ := λ A B C g f, { val := λ a, g^.val (f^.val a)
                          , property := @comm_ring.hom_comp
                                         _ A^.snd _ B^.snd _ C^.snd
                                         _ g^.property _ f^.property
                          }
   , circ_assoc := λ A B C D h g f, subtype.eq rfl
   , circ_id_left := λ A B f, subtype.eq rfl
   , circ_id_right := λ A B f, subtype.eq rfl
   }

/- -----------------------------------------------------------------------
Categories induced by monoids and groups.
----------------------------------------------------------------------- -/

/-! #brief A monoid category.
-/
definition MonoidCat (A : Type ℓ) [A_monoid : monoid A]
    : Cat.{(ℓ + 1) (ℓ + 1)}
:= { obj := punit
   , hom := λ u₁ u₂, A
   , id := λ u, 1
   , circ := λ u₁ u₂ u₃ g f, g * f
   , circ_assoc := λ u₁ u₂ u₃ u₄ h g f, eq.symm (mul_assoc h g f)
   , circ_id_left := λ u₁ u₂ f, one_mul f
   , circ_id_right := λ u₁ u₂ f, mul_one f
   }

/-! #brief A group category.
-/
definition GroupCat (A : Type ℓ) [A_group : group A]
    : Cat.{(ℓ + 1) (ℓ + 1)}
:= MonoidCat A

/- -----------------------------------------------------------------------
Preorder categories and categories of objects.
----------------------------------------------------------------------- -/

/-! #brief A preorder category.
-/
definition PreorderCat {A : Type ℓ}
    (r : A → A → Prop)
    (r_refl : reflexive r)
    (r_trans : transitive r)
    : Cat.{ℓ 0}
:= { obj := A
   , hom := r
   , id := r_refl
   , circ := λ a₁ a₂ a₃ g f, r_trans f g
   , circ_assoc := λ a₁ a₂ a₃ a₄ h g f, proof_irrel _ _
   , circ_id_left := λ a₁ a₂ f, proof_irrel _ _
   , circ_id_right := λ a₁ a₂ f, proof_irrel _ _
   }

/-! #brief The category of natural numbers, ordered by nat.le
-/
definition NatCat : Cat.{0 0}
:= PreorderCat nat.le @nat.le_refl @nat.le_trans

/-! #brief Decidable preorders on finite types induce finite categories.
-/
instance PreorderCat.Finite {A : Type ℓ}
    (r : A → A → Prop)
    (r_refl : reflexive r)
    (r_trans : transitive r)
    [A_FinType : FinType A]
    [r_decidable : decidable_rel r]
    : Cat.Finite (PreorderCat r r_refl r_trans)
:= { obj_fin := A_FinType
   , hom_fin := λ a₁ a₂, @Prop.decidable_FinSort (r a₁ a₂) (r_decidable a₁ a₂)
   }

/-! #brief A category of objects.
-/
definition ObjCat (A : Type ℓ)
    : Cat.{ℓ 0}
:= PreorderCat (@eq A) (@eq.refl A) (@eq.trans A)

/-! #brief Finite types yield finite object categories.
-/
instance ObjCat.Finite (A : Type ℓ)
    [A_FinType : FinType A]
    : Cat.Finite (ObjCat A)
:= PreorderCat.Finite (@eq A) (@eq.refl A) (@eq.trans A)

/-! #brief The finite category with N objects.
-/
definition FinCat (N : ℕ) : Cat.{0 0}
:= ObjCat (fin N)

/-! #brief The finite category is finite.
-/
instance FinCat.Finite (N : ℕ)
    : Cat.Finite (FinCat N)
:= ObjCat.Finite (fin N)

/- -----------------------------------------------------------------------
Arrow categories.
----------------------------------------------------------------------- -/

/-! #brief An object in an arrow category.
-/
structure Arr (C : Cat.{ℓobj ℓhom})
    : Type (max ℓobj ℓhom)
:= (dom : C^.obj)
   (codom : C^.obj)
   (hom : C^.hom dom codom)

/-! #brief A hom in an arrow category.
-/
structure ArrHom (C : Cat.{ℓobj ℓhom})
    (X Y : Arr C)
    : Sort (max 1 ℓhom)
:= (hom_dom : C^.hom X^.dom Y^.dom)
   (hom_codom : C^.hom X^.codom Y^.codom)
   (comm : hom_codom ∘∘ X^.hom = Y^.hom ∘∘ hom_dom)

/-! #brief Equality helper for ArrHom.
-/
theorem ArrHom.eq {C : Cat.{ℓobj ℓhom}}
    {X Y : Arr C}
    : ∀ {f₁ f₂ : ArrHom C X Y}
        (ωdom : f₁^.hom_dom = f₂^.hom_dom)
        (ωcodom : f₁^.hom_codom = f₂^.hom_codom)
      , f₁ = f₂
| (ArrHom.mk dom codom ω₁) (ArrHom.mk .(dom) .(codom) ω₂)
  (eq.refl .(dom)) (eq.refl .(codom))
  := rfl

/-! #brief The identity hom in an arrow category.
-/
definition ArrHom.id {C : Cat.{ℓobj ℓhom}}
    (X : Arr C)
    : ArrHom C X X
:= { hom_dom := C^.id X^.dom
   , hom_codom := C^.id X^.codom
   , comm := by rw [C^.circ_id_left, C^.circ_id_right]
   }

/-! #brief Composition of homs in an arrow category.
-/
definition ArrHom.comp {C : Cat.{ℓobj ℓhom}}
    {X Y Z : Arr C}
    (g : ArrHom C Y Z) (f : ArrHom C X Y)
    : ArrHom C X Z
:= { hom_dom := g^.hom_dom ∘∘ f^.hom_dom
   , hom_codom := g^.hom_codom ∘∘ f^.hom_codom
   , comm := begin
               repeat { rw -C^.circ_assoc }, rw f^.comm,
               repeat { rw C^.circ_assoc }, rw g^.comm
             end
   }

/-! #brief ArrHom.id is a left-identity for ArrHom.comp.
-/
theorem ArrHom.comp_id_left {C : Cat.{ℓobj ℓhom}}
    {X Y : Arr C} {f : ArrHom C X Y}
    : ArrHom.comp (ArrHom.id Y) f = f
:= ArrHom.eq C^.circ_id_left C^.circ_id_left

/-! #brief ArrHom.id is a right-identity for ArrHom.comp.
-/
theorem ArrHom.comp_id_right {C : Cat.{ℓobj ℓhom}}
    {X Y : Arr C} {f : ArrHom C X Y}
    : ArrHom.comp f (ArrHom.id X) = f
:= ArrHom.eq C^.circ_id_right C^.circ_id_right

/-! #brief ArrHom.comp is associative.
-/
theorem ArrHom.comp_assoc {C : Cat.{ℓobj ℓhom}}
    {X Y Z W : Arr C}
    {h : ArrHom C Z W} {g : ArrHom C Y Z} {f : ArrHom C X Y}
    : ArrHom.comp h (ArrHom.comp g f) = ArrHom.comp (ArrHom.comp h g) f
:= ArrHom.eq C^.circ_assoc C^.circ_assoc

/-! #brief An arrow category.
-/
definition ArrCat (C : Cat.{ℓobj ℓhom})
    : Cat.{(max ℓobj ℓhom) (max 1 ℓhom)}
:= { obj := Arr C
   , hom := ArrHom C
   , id := ArrHom.id
   , circ := @ArrHom.comp C
   , circ_id_left := λ x y f, ArrHom.comp_id_left
   , circ_id_right := λ x y f, ArrHom.comp_id_right
   , circ_assoc := λ x y z w h g f, ArrHom.comp_assoc
   }

/- -----------------------------------------------------------------------
Product categories.
----------------------------------------------------------------------- -/

/-! #brief The product category.
-/
definition ProdCat (C : Cat.{ℓobj₁ ℓhom₁}) (D : Cat.{ℓobj₂ ℓhom₂})
    : Cat.{(max ℓobj₁ ℓobj₂) (max 1 ℓhom₁ ℓhom₂)}
:= { obj := prod C^.obj D^.obj
   , hom := λ cd₁ cd₂, pprod (C^.hom cd₁^.fst cd₂^.fst)
                            (D^.hom cd₁^.snd cd₂^.snd)
   , id := λ cd, { fst := C^.id cd^.fst
                 , snd := D^.id cd^.snd
                 }
   , circ := λ x y z g f, { fst := C^.circ g^.fst f^.fst
                          , snd := D^.circ g^.snd f^.snd
                          }
   , circ_assoc := λ x y z w h g f, by rw [C^.circ_assoc, D^.circ_assoc]
   , circ_id_left := λ x y f, begin cases f, simp end
   , circ_id_right := λ x y f, begin cases f, simp end
   }

-- A product category.
-- \times\times
infixr `××` : 200 := ProdCat

/- -----------------------------------------------------------------------
Opposite categories.
----------------------------------------------------------------------- -/

/-! #brief The opposite category.
-/
@[reducible] definition OpCat (C : Cat.{ℓobj ℓhom})
    : Cat.{ℓobj ℓhom}
:= { obj := C^.obj
   , hom := λ x y, C^.hom y x
   , id := λ x, C^.id x
   , circ := λ x y z g f, C^.circ f g
   , circ_assoc := λ x y z w h g f, eq.symm C^.circ_assoc
   , circ_id_left := λ x y f, C^.circ_id_right
   , circ_id_right := λ x y f, C^.circ_id_left
   }

-- An opposite category.
-- \inv
notation C `⁻¹` := OpCat C

/-! #brief OpCat is an involution.
-/
theorem OpCat_OpCat (C : Cat.{ℓobj ℓhom})
    : OpCat (OpCat C) = C
:= begin
     apply Cat.eq,
     { trivial },
     { trivial },
     { trivial },
     { trivial }
   end

/-! #brief OpCat distributes over ProdCat.
-/
theorem OpCat_ProdCat (C : Cat.{ℓobj₁ ℓhom₁}) (D : Cat.{ℓobj₂ ℓhom₂})
    : OpCat (ProdCat C D) = ProdCat (OpCat C) (OpCat D)
:= begin
     apply Cat.eq,
     { trivial },
     { trivial },
     { trivial },
     { trivial }
   end

/- -----------------------------------------------------------------------
Over and under categories.
----------------------------------------------------------------------- -/

/-! #brief An object in an over category.
-/
structure OverObj (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    : Type (max ℓobj ℓhom)
:= (obj : C^.obj)
   (hom : C^.hom obj X)

/-! #brief The object contained within an over object.
-/
@[reducible] definition OverObj.dom {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    (A : OverObj C X)
    : C^.obj
:= A^.obj

/-! #brief The hom contained within an over object.
-/
@[reducible] definition OverObj.down {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    (A : OverObj C X)
    : C^.hom (OverObj.dom A) X
:= A^.hom

/-! #brief Eqaulity of objects in an over category.
-/
theorem OverObj.eq {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    : ∀ {A B : OverObj C X}
         (ωobj : A^.dom = B^.dom)
         (ωhom : A^.down == B^.down)
      , A = B
| (OverObj.mk obj hom) (OverObj.mk .(obj) .(hom))
  (eq.refl .(obj)) (heq.refl .(hom))
:= rfl

/-! #brief A hom in an over category.
-/
structure OverHom (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    (A B : OverObj C X)
    : Sort (max 1 ℓhom)
:= (hom : C^.hom A^.dom B^.dom)
   (triangle : A^.down = C^.circ B^.down hom)

/-! #brief Equality of homs in an over category.
-/
theorem OverHom.eq {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    {A B : OverObj C X}
    : ∀ {f₁ f₂ : OverHom C X A B}
      , f₁^.hom = f₂^.hom
      → f₁ = f₂
| (OverHom.mk hom ω₁) (OverHom.mk .(hom) ω₂) (eq.refl .(hom))
:= rfl

/-! #brief Heterogeneous equality of homs in an over category.
-/
theorem OverHom.heq {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    : ∀ {A₁ B₁ A₂ B₂ : OverObj C X}
         {f₁ : OverHom C X A₁ B₁}
         {f₂ : OverHom C X A₂ B₂}
      , A₁ = A₂ → B₁ = B₂ → f₁^.hom == f₂^.hom
      → f₁ == f₂
| (OverObj.mk a fa) (OverObj.mk b fb) (OverObj.mk .(a) .(fa)) (OverObj.mk .(b) .(fb))
  (OverHom.mk f ωf₁) (OverHom.mk .(f) ωf₂) (eq.refl ._) (eq.refl ._) (heq.refl ._)
:= heq.refl _

/-! #brief The identity hom in an over category.
-/
definition OverHom.id (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    (A : OverObj C X)
    : OverHom C X A A
:= { hom := C^.id A^.dom
   , triangle := eq.symm C^.circ_id_right
   }

/-! #brief Composition of homs in an over category.
-/
definition OverHom.comp (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    (P Q R : OverObj C X)
    (g : OverHom C X Q R)
    (f : OverHom C X P Q)
    : OverHom C X P R
:= { hom := C^.circ g^.hom f^.hom
   , triangle := by rw [f^.triangle, g^.triangle, C^.circ_assoc]
   }

/-! #brief Associativity of hom composition in an over category.
-/
theorem OverHom.comp_assoc (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    (P Q R S : OverObj C X)
    (h : OverHom C X R S)
    (g : OverHom C X Q R)
    (f : OverHom C X P Q)
    : OverHom.comp C X _ _ _ h (OverHom.comp C X _ _ _ g f)
       = OverHom.comp C X _ _ _ (OverHom.comp C X _ _ _ h g) f
:= begin
     apply OverHom.eq,
     exact C^.circ_assoc
   end

/-! #brief Left-identity of hom composition in an over category.
-/
theorem OverHom.comp_id_left (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    (P Q : OverObj C X)
    (f : OverHom C X P Q)
    : OverHom.comp C X _ _ _ (OverHom.id C X _) f = f
:= begin
     apply OverHom.eq,
     exact C^.circ_id_left
   end

/-! #brief Right-identity of hom composition in an over category.
-/
theorem OverHom.comp_id_right (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    (P Q : OverObj C X)
    (f : OverHom C X P Q)
    : OverHom.comp C X _ _ _ f (OverHom.id C X _) = f
:= begin
     apply OverHom.eq,
     exact C^.circ_id_right
   end

/-! #brief An over category.
-/
definition OverCat (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    : Cat.{(max ℓobj ℓhom) (max 1 ℓhom)}
:= { obj := OverObj C X
   , hom := OverHom C X
   , id := OverHom.id C X
   , circ := OverHom.comp C X
   , circ_assoc := OverHom.comp_assoc C X
   , circ_id_left := OverHom.comp_id_left C X
   , circ_id_right := OverHom.comp_id_right C X
   }

-- An over category.
-- //
notation C `//` X := OverCat C X

/-! #brief An under category.
-/
definition UnderCat (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    : Cat.{(max ℓobj ℓhom) (max 1 ℓhom)}
--:= OpCat (OverCat (OpCat C) X)
:= OpCat (OverCat (OpCat C) X)

-- An under category.
-- \\
notation C `\\` X := UnderCat C X

/-! #brief An object in an under category.
-/
definition UnderObj (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    : Type (max ℓobj ℓhom)
:= (UnderCat C X)^.obj

/-! #brief A hom in an under category.
-/
definition UnderHom (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    (A B : UnderObj C X)
    : Sort (max 1 ℓhom)
:= (UnderCat C X)^.hom A B

/-! #brief Constructor for an object in an under category.
-/
definition UnderObj.mk {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    {A : C^.obj} (f : C^.hom X A)
    : UnderObj C X
:= { obj := A, hom := f }

/-! #brief The object contained within an under object.
-/
@[reducible] definition UnderObj.codom {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    (A : UnderObj C X)
    : C^.obj
:= A^.obj

/-! #brief The hom contained within an under object.
-/
@[reducible] definition UnderObj.up {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    (A : UnderObj C X)
    : C^.hom X (UnderObj.codom A)
:= A^.hom

/-! #brief Constructor for a hom in an under category.
-/
definition UnderHom.mk {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    {A B : UnderObj C X}
    (f : C^.hom (UnderObj.codom A) (UnderObj.codom B))
    (ω : B^.up = C^.circ f A^.up)
    : UnderHom C X A B
:= { hom := f, triangle := ω }

/-! #brief The hom contained within an under hom.
-/
@[reducible] definition UnderHom.hom {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    {A B : UnderObj C X}
    (f : UnderHom C X A B)
    : C^.hom (UnderObj.codom A) (UnderObj.codom B)
:= f^.hom

/-! #brief The hom contained within an under hom.
-/
@[reducible] theorem UnderHom.triangle {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    (A B : UnderObj C X)
    (f : UnderHom C X A B)
    : B^.up = UnderHom.hom f ∘∘ A^.up
:= f^.triangle

/- -----------------------------------------------------------------------
Isomorphisms in categories.
----------------------------------------------------------------------- -/

/-! #brief An isomorphism in a category.
-/
structure Iso {C : Cat.{ℓobj ℓhom}}
    {c₁ c₂ : C^.obj}
    (f : C^.hom c₁ c₂) (g : C^.hom c₂ c₁)
    : Prop
:= (id₁ : C^.circ g f = C^.id c₁)
   (id₂ : C^.circ f g = C^.id c₂)

/-! #brief Iso's can be 'flipped' to run in the other direction.
-/
definition Iso.flip {C : Cat.{ℓobj ℓhom}}
    {c₁ c₂ : C^.obj}
    {f : C^.hom c₁ c₂} {g : C^.hom c₂ c₁}
    (iso : Iso f g)
    : Iso g f
:= { id₁ := iso^.id₂
   , id₂ := iso^.id₁
   }

/-! #brief Iso's have unique inverses.
-/
definition Iso.inv_uniq₂ {C : Cat.{ℓobj ℓhom}}
    {c₁ c₂ : C^.obj}
    {f : C^.hom c₁ c₂} {g₁ g₂ : C^.hom c₂ c₁}
    (iso₁ : Iso f g₁)
    (iso₂ : Iso f g₂)
    : g₁ = g₂
:= by calc g₁  = g₁ ∘∘ ⟨⟨c₂⟩⟩    : by rw C^.circ_id_right
           ... = g₁ ∘∘ (f ∘∘ g₂) : by rw iso₂^.id₂
           ... = (g₁ ∘∘ f) ∘∘ g₂ : by rw C^.circ_assoc
           ... = ⟨⟨c₁⟩⟩ ∘∘ g₂    : by rw iso₁^.id₁
           ... = g₂              : by rw C^.circ_id_left

/-! #brief Iso's have unique inverses.
-/
definition Iso.inv_uniq₁ {C : Cat.{ℓobj ℓhom}}
    {c₁ c₂ : C^.obj}
    {f₁ f₂ : C^.hom c₁ c₂} {g : C^.hom c₂ c₁}
    (iso₁ : Iso f₁ g)
    (iso₂ : Iso f₂ g)
    : f₁ = f₂
:= Iso.inv_uniq₂ (Iso.flip iso₁) (Iso.flip iso₂)

/-! #brief Identity homs are isomorphisms.
-/
theorem Cat.id.Iso {C : Cat.{ℓobj ℓhom}}
    (c : C^.obj)
    : Iso (C^.id c) (C^.id c)
:= { id₁ := C^.circ_id_left
   , id₂ := C^.circ_id_left
   }

/-! #brief Isomorphisms are closed under composition.
-/
theorem Cat.circ.Iso {C : Cat.{ℓobj ℓhom}}
    {c₁ c₂ c₃ : C^.obj}
    {f₂₃ : C^.hom c₂ c₃} {g₂₃ : C^.hom c₃ c₂} (iso₂₃ : Iso f₂₃ g₂₃)
    {f₁₂ : C^.hom c₁ c₂} {g₁₂ : C^.hom c₂ c₁} (iso₁₂ : Iso f₁₂ g₁₂)
    : Iso (C^.circ f₂₃ f₁₂) (C^.circ g₁₂ g₂₃)
:= { id₁ := by calc g₁₂ ∘∘ g₂₃ ∘∘ (f₂₃ ∘∘ f₁₂)
                        = g₁₂ ∘∘ (g₂₃ ∘∘ f₂₃) ∘∘ f₁₂ : by repeat {rw C^.circ_assoc}
                    ... = g₁₂ ∘∘ ⟨⟨c₂⟩⟩ ∘∘ f₁₂       : by rw iso₂₃^.id₁
                    ... = g₁₂ ∘∘ f₁₂                 : by rw C^.circ_id_right
                    ... = ⟨⟨c₁⟩⟩                     : by rw iso₁₂^.id₁
   , id₂ := by calc f₂₃ ∘∘ f₁₂ ∘∘ (g₁₂ ∘∘ g₂₃)
                        = f₂₃ ∘∘ (f₁₂ ∘∘ g₁₂) ∘∘ g₂₃ : by repeat {rw C^.circ_assoc}
                    ... = f₂₃ ∘∘ ⟨⟨c₂⟩⟩ ∘∘ g₂₃       : by rw iso₁₂^.id₂
                    ... = f₂₃ ∘∘ g₂₃                 : by rw C^.circ_id_right
                    ... = ⟨⟨c₃⟩⟩                     : by rw iso₂₃^.id₂
   }

/- -----------------------------------------------------------------------
Monomorphism and epimorphisms.
----------------------------------------------------------------------- -/

/-! #brief A monomorphism.
-/
class Monic {C : Cat.{ℓobj ℓhom}} {x y : C^.obj}
    (g : C^.hom x y)
    : Prop
:= (inj : ∀ {a : C^.obj} {f₁ f₂ : C^.hom a x}
             (ω : C^.circ g f₁ = C^.circ g f₂)
           , f₁ = f₂)

/-! #brief Helper for showing a hom is monic.
-/
definition Monic.show {C : Cat.{ℓobj ℓhom}} {x y : C^.obj}
    {g : C^.hom x y}
    (ω : ∀ {a : C^.obj} {f₁ f₂ : C^.hom a x} (ωf : C^.circ g f₁ = C^.circ g f₂), f₁ = f₂)
    : Monic g
:= { inj := @ω }

/-! #brief Using a monic.
-/
definition monic_cancel {C : Cat.{ℓobj ℓhom}} {x y : C^.obj}
    (g : C^.hom x y)
    [g_Monic : Monic g]
    {a : C^.obj} {f₁ f₂ : C^.hom a x}
    (ω : C^.circ g f₁ = C^.circ g f₂)
    : f₁ = f₂
:= Monic.inj ω

/-! #brief Identity homs are monic.
-/
instance Cat.id.Monic {C : Cat.{ℓobj ℓhom}}
    (c : C^.obj)
    : Monic (C^.id c)
:= Monic.show
    (λ a f₁ f₂ ω, by calc f₁ = ⟨⟨c⟩⟩ ∘∘ f₁ : eq.symm C^.circ_id_left
                         ... = ⟨⟨c⟩⟩ ∘∘ f₂ : ω
                         ... = f₂ : C^.circ_id_left)

/-! #brief Monics are closed under composition.
-/
instance Monic.circ {C : Cat.{ℓobj ℓhom}}
    {x y z : C^.obj}
    {g : C^.hom y z} [g_Monic : Monic g]
    {f : C^.hom x y} [f_Monic : Monic f]
    : Monic (C^.circ g f)
:= Monic.show
    (λ c f₁ f₂ ω
     , begin
         apply monic_cancel f,
         apply monic_cancel g,
         repeat { rw C^.circ_assoc },
         exact ω
       end)

/-! #brief In LeanCat, monics are injective.
-/
theorem LeanCat.Monic.inj {X Y : LeanCat.{ℓ}^.obj}
    {f : LeanCat.{ℓ}^.hom X Y}
    (f_Monic : @Monic LeanCat.{ℓ} X Y f)
    : function.injective f
:= λ x₁ x₂ ωx
   , let f₁ : X → X := λ x, x₁ in
     let f₂ : X → X := λ x, x₂ in
     let ωf : f₁ = f₂
           := begin
                apply @Monic.inj LeanCat.{ℓ} X Y f,
                apply funext, intro x, exact ωx
              end
     in calc x₁ = f₁ x₁  : rfl
             ... = f₂ x₁ : by rw ωf
             ... = x₂    : rfl

/-! #brief In LeanCat, left-inverses witness monics.
-/
definition LeanCat.Monic.by_witness {X Y : Type ℓ}
    {f : X → Y}
    {g : Y → X}
    (ωfg : ∀ {x : X}, g (f x) = x)
    : @Monic LeanCat.{ℓ} X Y f
:= Monic.show
    (λ T f₁ f₂ ω
     , sorry)

/-! #brief An epimorphism.
-/
@[class] definition Epic {C : Cat.{ℓobj ℓhom}} {x y : C^.obj}
    (f : C^.hom x y)
    : Prop
:= @Monic (OpCat C) y x f

/-! #brief Helper for showing a hom is epic.
-/
definition Epic.show {C : Cat.{ℓobj ℓhom}} {x y : C^.obj}
    {f : C^.hom x y}
    (ω : ∀ {z : C^.obj} (g₁ g₂ : C^.hom y z) (ωg : C^.circ g₁ f = C^.circ g₂ f), g₁ = g₂)
    : Epic f
:= Monic.show @ω

/-! #brief Using an epic.
-/
definition epic_cancel {C : Cat.{ℓobj ℓhom}} {x y : C^.obj}
    (f : C^.hom x y)
    [f_Epic : Epic f]
    {z : C^.obj} {g₁ g₂ : C^.hom y z}
    (ω : C^.circ g₁ f = C^.circ g₂ f)
    : g₁ = g₂
:= @Monic.inj (OpCat C) _ _ f f_Epic z g₁ g₂ ω

/-! #brief Identity homs are epic.
-/
instance Cat.id.Epic {C : Cat.{ℓobj ℓhom}}
    (c : C^.obj)
    : Epic (C^.id c)
:= Epic.show
    (λ z g₁ g₂ ω, by calc g₁ = g₁ ∘∘ ⟨⟨c⟩⟩ : eq.symm C^.circ_id_right
                         ... = g₂ ∘∘ ⟨⟨c⟩⟩ : ω
                         ... = g₂ : C^.circ_id_right)

/-! #brief Epics are closed under composition.
-/
instance Epic.circ {C : Cat.{ℓobj ℓhom}}
    {x y z : C^.obj}
    {g : C^.hom y z} [g_Epic : Epic g]
    {f : C^.hom x y} [f_Epic : Epic f]
    : Epic (C^.circ g f)
:= Epic.show
    (λ c f₁ f₂ ω
     , begin
         apply epic_cancel g,
         apply epic_cancel f,
         repeat { rw -C^.circ_assoc },
         exact ω
       end)

/- -----------------------------------------------------------------------
Casting homs.
----------------------------------------------------------------------- -/

/-! #brief A casting hom.
-/
definition cast_hom {C : Cat.{ℓobj ℓhom}}
    : ∀ {c₁ c₂ : C^.obj}
        (ω : c₁ = c₂)
      , C^.hom c₁ c₂
| c .(c) (eq.refl .(c)) := C^.id c

/-! #brief Casting homs are just identities.
-/
theorem cast_hom.simp {C : Cat.{ℓobj ℓhom}}
    : ∀ {c : C^.obj}
        (ω : c = c)
      , cast_hom ω = C^.id c
| c (eq.refl .(c)) := rfl

/-! #brief composition of casting homs.
-/
theorem cast_hom.circ {C : Cat.{ℓobj ℓhom}}
    : ∀ {c₁ c₂ c₃ : C^.obj}
        {ω₁₂ : c₁ = c₂}
        {ω₂₃ : c₂ = c₃}
      , C^.circ (cast_hom ω₂₃) (cast_hom ω₁₂)
         = cast_hom (eq.trans ω₁₂ ω₂₃)
| c .(c) .(c) (eq.refl .(c)) (eq.refl .(c)) := C^.circ_id_left

/-! #brief Left congruence of composition with casting homs.
-/
theorem cast_hom.circ.congr_left {C : Cat.{ℓobj ℓhom}}
    : ∀ {b c₁ c₂ d : C^.obj}
        {ω₁ : b = c₁}
        {ω₂ : b = c₂}
        {g₁ : C^.hom c₁ d}
        {g₂ : C^.hom c₂ d}
        (ωg : g₁ == g₂)
      , C^.circ g₁ (cast_hom ω₁) = C^.circ g₂ (cast_hom ω₂)
| b .(b) .(b) d (eq.refl .(b)) (eq.refl .(b)) g .(g) (heq.refl .(g)) := rfl

/-! #brief Right congruence of composition with casting homs.
-/
theorem cast_hom.circ.congr_right {C : Cat.{ℓobj ℓhom}}
    : ∀ {b c₁ c₂ d : C^.obj}
        {ω₁ : c₁ = d}
        {ω₂ : c₂ = d}
        {f₁ : C^.hom b c₁}
        {f₂ : C^.hom b c₂}
        (ωf : f₁ == f₂)
      , C^.circ (cast_hom ω₁) f₁ = C^.circ (cast_hom ω₂) f₂
| b c .(c) .(c) (eq.refl .(c)) (eq.refl .(c)) f .(f) (heq.refl .(f)) := rfl

/-! #brief Casting homs and heq.
-/
theorem cast_hom.circ_left_heq {C : Cat.{ℓobj ℓhom}}
    : ∀ {b c₁ c₂ : C^.obj}
        (ω : c₁ = c₂)
        (f : C^.hom b c₁)
      , C^.circ (cast_hom ω) f == f
| b c .(c) (eq.refl .(c)) f := heq_of_eq C^.circ_id_left

/-! #brief Casting homs and heq.
-/
theorem cast_hom.circ_right_heq {C : Cat.{ℓobj ℓhom}}
    : ∀ {c₁ c₂ d : C^.obj}
        (ω : c₁ = c₂)
        (g : C^.hom c₂ d)
      , C^.circ g (cast_hom ω) == g
| c .(c) d (eq.refl .(c)) g := heq_of_eq C^.circ_id_right

/-! #brief Casting homs are isos.
-/
theorem cast_hom.Iso {C : Cat.{ℓobj ℓhom}}
    : ∀ {c₁ c₂ : C^.obj}
        (ω₁₂ : c₁ = c₂)
        (ω₂₁ : c₂ = c₁)
      , Iso (cast_hom ω₁₂) (cast_hom ω₂₁)
| c .(c) (eq.refl .(c)) (eq.refl .(c)) := Cat.id.Iso c

/-! #brief Casting homs are monic.
-/
instance cast_hom.Monic {C : Cat.{ℓobj ℓhom}}
    : ∀ {c₁ c₂ : C^.obj}
        (ω : c₁ = c₂)
      , Monic (cast_hom ω)
| c .(c) (eq.refl .(c)) := Cat.id.Monic c

/-! #brief Casting homs are epic.
-/
instance cast_hom.Epic {C : Cat.{ℓobj ℓhom}}
    : ∀ {c₁ c₂ : C^.obj}
        (ω : c₁ = c₂)
      , Epic (cast_hom ω)
| c .(c) (eq.refl .(c)) := Cat.id.Epic c

/- -----------------------------------------------------------------------
Initial and final objects in categories.
----------------------------------------------------------------------- -/

/-! #brief A final object in a category.
-/
structure IsFinal (C : Cat.{ℓobj ℓhom})
    (obj : C^.obj)
    (hom : ∀ (c : C^.obj), C^.hom c obj)
    : Type (max ℓobj ℓhom)
:= (hom_uniq : ∀ {c : C^.obj} {h : C^.hom c obj}, h = hom c)

/-! #brief A category with a final object.
-/
class HasFinal (C : Cat.{ℓobj ℓhom})
    : Type (max ℓobj ℓhom)
:= (obj : C^.obj)
   (hom : ∀ (c : C^.obj), C^.hom c obj)
   (final : IsFinal C obj hom)

/-! #brief Helper for showing a category has a final object.
-/
definition HasFinal.show {C : Cat.{ℓobj ℓhom}}
    (x : C^.obj)
    (hom : ∀ (c : C^.obj), C^.hom c x)
    (hom_uniq : ∀ {c : C^.obj} {h : C^.hom c x}, h = hom c)
    : HasFinal C
:= { obj := x
   , hom := hom
   , final := { hom_uniq := @hom_uniq
              }
   }

/-! #brief The final object in a category with a final object.
-/
definition final (C : Cat.{ℓobj ℓhom})
    [C_HasFinal : HasFinal C]
    : C^.obj
:= HasFinal.obj C

/-! #brief The final hom in a category with a final object.
-/
definition final_hom {C : Cat.{ℓobj ℓhom}}
    [C_HasFinal : HasFinal C]
    (c : C^.obj)
    : C^.hom c (final C)
:= HasFinal.hom c

/-! #brief The final hom is unique.
-/
theorem final_hom.uniq (C : Cat.{ℓobj ℓhom})
    {C_HasFinal : HasFinal C}
    {c : C^.obj} {f : C^.hom c (final C)}
    : f = final_hom c
:= (HasFinal.final C)^.hom_uniq

/-! #brief The initial hom is unique.
-/
definition final_hom.uniq' (C : Cat.{ℓobj ℓhom})
    {C_HasFinal : HasFinal C}
    {c : C^.obj} {f g : C^.hom c (final C)}
    : f = g
:= eq.trans (final_hom.uniq C) (eq.symm (final_hom.uniq C))

/-! #brief The final hom to the final object is the identity.
-/
theorem final_hom.id (C : Cat.{ℓobj ℓhom})
    {C_HasFinal : HasFinal C}
    : final_hom (final C) = C^.id (final C)
:= eq.symm (final_hom.uniq C)

/-! #brief The unique iso between two final objects.
-/
definition final.iso {C : Cat.{ℓobj ℓhom}}
    (C_HasFinal₁ C_HasFinal₂ : HasFinal C)
    : C^.hom (@final C C_HasFinal₁) (@final C C_HasFinal₂)
:= @final_hom C C_HasFinal₂ (@final C C_HasFinal₁)

/-! #brief Final objects are unique up-to unique isomorphism.
-/
theorem HasFinal_uniq {C : Cat.{ℓobj ℓhom}}
    (C_HasFinal₁ C_HasFinal₂ : HasFinal C)
    : Iso (final.iso C_HasFinal₁ C_HasFinal₂)
          (final.iso C_HasFinal₂ C_HasFinal₁)
:= { id₁ := eq.trans (@final_hom.uniq _ C_HasFinal₁ _ _)
                     (eq.symm (@final_hom.uniq _ C_HasFinal₁ _ _))
   , id₂ := eq.trans (@final_hom.uniq _ C_HasFinal₂ _ _)
                     (eq.symm (@final_hom.uniq _ C_HasFinal₂ _ _))
   }

/-! #brief Final objects are unique up-to unique isomorphism.
-/
theorem HasFinal_uniq₁ {C : Cat.{ℓobj ℓhom}}
    (C_HasFinal₁ C_HasFinal₂ : HasFinal C)
    {f : C^.hom (@final _ C_HasFinal₂) (@final _ C_HasFinal₁)}
    {g : C^.hom (@final _ C_HasFinal₁) (@final _ C_HasFinal₂)}
    (iso : Iso f g)
    : f = final.iso C_HasFinal₂ C_HasFinal₁
:= @final_hom.uniq _ C_HasFinal₁ _ _

/-! #brief Final objects are unique up-to unique isomorphism.
-/
theorem HasFinal_uniq₂ {C : Cat.{ℓobj ℓhom}}
    (C_HasFinal₁ C_HasFinal₂ : HasFinal C)
    {f : C^.hom (@final _ C_HasFinal₂) (@final _ C_HasFinal₁)}
    {g : C^.hom (@final _ C_HasFinal₁) (@final _ C_HasFinal₂)}
    (iso : Iso f g)
    : g = final.iso C_HasFinal₁ C_HasFinal₂
:= @final_hom.uniq _ C_HasFinal₂ _ _

/-! #brief An initial object in a category.
-/
definition IsInit (C : Cat.{ℓobj ℓhom})
    (obj : C^.obj)
    (hom : ∀ (c : C^.obj), C^.hom obj c)
    : Type (max ℓobj ℓhom)
:= IsFinal (OpCat C) obj hom

/-! #brief A category with an initial object.
-/
@[class] definition HasInit (C : Cat.{ℓobj ℓhom})
    : Type (max ℓobj ℓhom)
:= HasFinal (OpCat C)

/-! #brief Helper for showing a category has a final object.
-/
definition HasInit.show {C : Cat.{ℓobj ℓhom}}
    (x : C^.obj)
    (hom : ∀ (c : C^.obj), C^.hom x c)
    (hom_uniq : ∀ {c : C^.obj} {h : C^.hom x c}, h = hom c)
    : HasInit C
:= HasFinal.show x hom @hom_uniq

/-! #brief The initial object in a category with a initial object.
-/
definition init (C : Cat.{ℓobj ℓhom})
    [C_HasInit : HasInit C]
    : C^.obj
:= @final (OpCat C) C_HasInit

/-! #brief The initial hom in a category with a initial object.
-/
definition init_hom {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    (c : C^.obj)
    : C^.hom (init C) c
:= @final_hom (OpCat C) C_HasInit c

/-! #brief The initial hom is unique.
-/
definition init_hom.uniq (C : Cat.{ℓobj ℓhom})
    {C_HasInit : HasInit C}
    {c : C^.obj} {f : C^.hom (init C) c}
    : f = init_hom c
:= @final_hom.uniq (OpCat C) C_HasInit c f

/-! #brief The initial hom is unique.
-/
definition init_hom.uniq' (C : Cat.{ℓobj ℓhom})
    {C_HasInit : HasInit C}
    {c : C^.obj} {f g : C^.hom (init C) c}
    : f = g
:= eq.trans (init_hom.uniq C) (eq.symm (init_hom.uniq C))

/-! #brief The unique iso between two initial objects.
-/
definition init.iso {C : Cat.{ℓobj ℓhom}}
    (C_HasInit₁ C_HasInit₂ : HasInit C)
    : C^.hom (@init C C_HasInit₁) (@init C C_HasInit₂)
:= @init_hom C C_HasInit₁ (@init C C_HasInit₂)

/-! #brief Initial objects are unique up-to unique isomorphism.
-/
theorem HasInit_uniq {C : Cat.{ℓobj ℓhom}}
    (C_HasInit₁ C_HasInit₂ : HasInit C)
    : Iso (init.iso C_HasInit₁ C_HasInit₂)
          (init.iso C_HasInit₂ C_HasInit₁)
:= { id₁ := eq.trans (@init_hom.uniq _ C_HasInit₁ _ _)
                     (eq.symm (@init_hom.uniq _ C_HasInit₁ _ _))
   , id₂ := eq.trans (@init_hom.uniq _ C_HasInit₂ _ _)
                     (eq.symm (@init_hom.uniq _ C_HasInit₂ _ _))
   }

/-! #brief Initial and final are dual concepts.
-/
theorem IsInit_dual_IsFinal (C : Cat.{ℓobj ℓhom})
    : IsInit C = IsFinal (OpCat C)
:= rfl

/-! #brief Final and initial are dual concepts.
-/
theorem IsFinal_dual_IsInit (C : Cat.{ℓobj ℓhom})
    : IsFinal C = IsInit (OpCat C)
:= funext (λ obj, funext (λ hom, begin cases C, trivial end))

/- -----------------------------------------------------------------------
Examples of initial and final objects in categories.
----------------------------------------------------------------------- -/

/-! #brief OverCat has an initial object when the global category does.
-/
instance OverCat.HasInit (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    [C_HasInit : HasInit C]
    : HasInit (OverCat C X)
:= HasInit.show { obj := init C, hom := init_hom X }
    (λ Y, { hom := init_hom Y^.obj, triangle := init_hom.uniq' C })
    (λ Y h, OverHom.eq (init_hom.uniq C))

/-! #brief OverCat has a final object.
-/
instance OverCat.HasFinal (C : Cat.{ℓobj ℓhom}) (X : C^.obj)
    : HasFinal (OverCat C X)
:= HasFinal.show
    { obj := X, hom := C^.id X }
    (λ Z, { hom := Z^.hom, triangle := eq.symm C^.circ_id_left })
    (λ Z h, OverHom.eq (eq.symm (eq.trans h^.triangle C^.circ_id_left )))

/-! #brief UnitCat has an initial object.
-/
instance UnitCat.HasInit
    : HasInit UnitCat.{ℓobj ℓhom}
:= HasInit.show punit.star (λ c, punit.star)
    (λ c h, begin cases h, trivial end)

/-! #brief UnitCat has a final object.
-/
instance UnitCat.HasFinal
    : HasFinal UnitCat.{ℓobj ℓhom}
:= HasFinal.show punit.star (λ c, punit.star) (λ c h, begin cases h, trivial end)

/-! #brief SortCat has an initial object.
-/
instance SortCat.HasInit
    : HasInit SortCat.{ℓ}
:= HasInit.show pempty (λ T e, by cases e) (λ c h, funext (λ e, by cases e))

/-! #brief PropCat has an initial object.
-/
instance PropCat.HasInit
    : HasInit PropCat
:= SortCat.HasInit

/-! #brief LeanCat has an initial object.
-/
instance LeanCat.HasInit
    : HasInit LeanCat.{ℓ}
:= SortCat.HasInit

/-! #brief Initial objects in LeanCat are uninhabited.
-/
theorem LeanCat.Init.elim
    [LeanCat_HasInit : HasInit LeanCat.{ℓ}]
    (e : init LeanCat.{ℓ})
    : false
:= by cases (init.iso LeanCat_HasInit LeanCat.HasInit e)

/-! #brief SortCat has a final object.
-/
instance SortCat.HasFinal
    : HasFinal SortCat.{ℓ}
:= HasFinal.show punit (λ T t, punit.star) (λ c h, funext (λ t, begin cases (h t), trivial end))

/-! #brief PropCat has a final object.
-/
instance PropCat.HasFinal
    : HasFinal PropCat
:= SortCat.HasFinal

/-! #brief LeanCat has a final object.
-/
instance LeanCat.HasFinal
    : HasFinal LeanCat.{ℓ}
:= SortCat.HasFinal

/-! #brief Final objects in LeanCat are uniquely inhabited.
-/
definition LeanCat.Final.intro
    [LeanCat_HasFinal : HasFinal LeanCat.{ℓ}]
    : final LeanCat.{ℓ}
:= final.iso LeanCat.HasFinal LeanCat_HasFinal punit.star

/-! #brief Final objects in LeanCat are uniquely.
-/
theorem LeanCat.Final.uniq
    {LeanCat_HasFinal : HasFinal LeanCat.{ℓ}}
    {u₁ u₂ : final LeanCat.{ℓ}}
    : u₁ = u₂
:= let f₁ : LeanCat.{ℓ}^.hom punit (final LeanCat.{ℓ})
         := λ u, u₁ in
   let f₂ : LeanCat.{ℓ}^.hom punit (final LeanCat.{ℓ})
         := λ u, u₂ in
   let ωf : f₁ = f₂
         := by calc f₁ = @final_hom _ LeanCat_HasFinal punit : @final_hom.uniq _ LeanCat_HasFinal _ f₁
                    ... = f₂ : eq.symm (@final_hom.uniq _ LeanCat_HasFinal _ f₂)
   in by calc u₁ = f₁ punit.star : rfl
              ... = f₂ punit.star : by rw ωf
              ... = u₂ : rfl

/-! #brief The category of natural numbers has an initial object.
-/
instance NatCat.HasInit
    :HasInit NatCat
:= HasInit.show nat.zero nat.zero_le (λ c h, proof_irrel _ _)

end qp