/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland

This file attempts to define the rationals using a variant of
continued fractions as the primary definition.  Essentially,
the point is that any strictly positive rational p can be
written uniquely as n + 1 or n + 1 - 1/(1 + q), where n is
a natural number and q is another strictly positive rational.
This means that there is a free monoid on two generators that
acts on ℚ⁺, and evaluation at 1 ∈ ℚ⁺ gives a bijection from
that monoid to ℚ⁺.  The action actually extends to a group
action on ℚ ∪ {∞}, although we have not written that yet.

The possible advantage of this approach is that the positive
rationals become a straightforward inductive type with two
constructors; no quotient constructions or subtypes are
required.  The total ordering is also quite straightforward
from this point of view.

The disadvantage is that it becomes harder to set up the
algebraic structure.  There is an algorithm due to Gosper and
some of the material below in intended to lead towards an
implementation, but we have not yet completed that.

This approach also fails to leverage the relative computational
efficiency of the Lean virtual machine.
-/

import data.nat.basic
import tactic.find tactic.ring

inductive posrat : Type
| twist : posrat → posrat
| one : posrat
| succ : posrat → posrat

namespace posrat
open posrat

def nat_add : ℕ → posrat → posrat
| 0 a := a
| (nat.succ n) a := posrat.succ (nat_add n a)

def nat_succ (n : ℕ) : posrat := nat_add n one

def weight : posrat → ℕ
| (twist a) := nat.succ (weight a)
| one := 0
| (succ a) := nat.succ (weight a)

def pred_ceil : posrat → ℕ
| (twist a) := 0
| one := 0
| (succ a) := nat.succ (pred_ceil a)

def le : posrat → posrat → Prop
| (twist a) (twist b) := le a b
| (twist _) one := true
| (twist _) (succ _) := true
| one (twist _) := false
| one one := true
| one (succ _) := true
| (succ _) one := false
| (succ a) (succ b) := le a b
| (succ _) (twist _) := false

def lt (a b : posrat) : Prop := ¬ (le b a)

lemma pred_ceil_le : ∀ (a b : posrat),
 le a b → (pred_ceil a ≤ pred_ceil b) :=
begin
 intro a,
 induction a with a1 iha1 a2 iha2;
 intros b h; rcases b with b1 | _ | b2; simp[le] at h;
 simp[pred_ceil];
 try {contradiction};
 try {apply nat.succ_le_succ, apply iha2, assumption}
end

lemma le_refl : ∀ a : posrat, le a a
| (twist a) := le_refl a
| one := true.intro
| (succ a) := le_refl a

lemma le_antisymm : ∀ a b : posrat, le a b → le b a → a = b :=
begin
 intro a,
 induction a with a1 iha a2 iha;
 intros b a_le_b b_le_a;
 rcases b with b1 | _ | b2; simp[le] at a_le_b b_le_a ⊢;
 try {contradiction};
 try {apply iha,assumption,assumption},
end

lemma le_trans : ∀ {a b c : posrat}, le a b → le b c → le a c :=
begin
 intro a,
 induction a with a1 iha a2 iha;
 intros b c a_le_b b_le_c;
 rcases b with b1 | _ | b2;
 rcases c with c1 | _ | c2;
 simp[le] at a_le_b b_le_c ⊢;
 try {contradiction};
 try {apply iha,assumption,assumption},
end

lemma le_total : ∀ a b : posrat, le a b ∨ le b a :=
begin
 intro a,
 induction a with a1 iha a1 iha;
 intro b;
 rcases b with b1 | _ | b1; simp[le]; apply iha,
end

lemma lt_iff_le_not_le (a b : posrat) :
 (lt a b) ↔ (le a b) ∧ ¬ (le b a) :=
begin
 dsimp[lt],
 rcases (le_total a b) with a_le_b | b_le_a; split,
 {intro h,split;assumption},
 {intro h,exact h.right},
 {intro h,split;contradiction},
 {intro h,exact h.right}
end

def inv : posrat → posrat
| (twist a) := succ (inv a)
| one := one
| (succ a) := twist (inv a)

lemma inv_inv (a : posrat) : inv (inv a) = a :=
begin
 induction a with _ ih _ ih;
 simp[inv]; apply ih,
end

lemma inv_order: ∀ (a b : posrat), le a b ↔ le (inv b) (inv a) :=
begin
 intro a,
 induction a with a1 iha a1 iha;
 intro b;
 rcases b with b1 | _ | b1; simp[le,inv]; apply iha,
end

/-
mutual def mul2, div2
with mul2 : posrat → posrat
| (mul2 (succ a)) := succ (succ (mul2 a))
| (mul2 (twist (succ a))) := succ (twist (div2 a))
| (mul2 (twist (twist a))) := twist (mul2 a)
with div2 : posrat → posrat
| (div2 (twist a)) := twist (twist (div2 a))
| (div2 (succ (twist a))) := twist (succ (mul2 a))
| (div2 (succ (succ a))) := succ (div2 a)

def from_frac (u v : ℕ) (u_pos : u > 0) (v_pos : v > 0)
 : posrat := sorry

-/

structure mat : Type :=
(a : nat) (b : nat) (c : nat) (d : nat)
(det_prop : a * d = c * b + 1)

namespace mat

def ab (m : mat) : ℕ := m.a + m.b
def cd (m : mat) : ℕ := m.c + m.d

lemma a_pos (m : mat) : m.a > 0 :=
begin
 rcases m with ⟨_ | a0,b,c,d,det_prop⟩;
 simp at det_prop ⊢,
 { cases det_prop, }
end

lemma d_pos (m : mat) : m.d > 0 :=
begin
 rcases m with ⟨a,b,c,_ | d0,det_prop⟩;
 simp at det_prop ⊢,
 { cases det_prop }
end

def ab_pos (m : mat) : 0 < m.ab := nat.add_pos_left m.a_pos _
def cd_pos (m : mat) : 0 < m.cd := nat.add_pos_right _ m.d_pos

def aq  (m : mat) : ℚ := (m.a  : ℚ)
def bq  (m : mat) : ℚ := (m.b  : ℚ)
def cq  (m : mat) : ℚ := (m.c  : ℚ)
def dq  (m : mat) : ℚ := (m.d  : ℚ)
def abq (m : mat) : ℚ := (m.ab : ℚ)
def cdq (m : mat) : ℚ := (m.cd : ℚ)

def aq_pos  (m : mat) : 0 < m.aq  := int.cast_lt.mpr (int.coe_nat_lt.mpr m.a_pos)
def dq_pos  (m : mat) : 0 < m.dq  := int.cast_lt.mpr (int.coe_nat_lt.mpr m.d_pos)
def abq_pos (m : mat) : 0 < m.abq := int.cast_lt.mpr (int.coe_nat_lt.mpr m.ab_pos)
def cdq_pos (m : mat) : 0 < m.cdq := int.cast_lt.mpr (int.coe_nat_lt.mpr m.cd_pos)

def aq_nz  (m : mat) : m.aq  ≠ 0 := (ne_of_lt m.aq_pos ).symm
def dq_nz  (m : mat) : m.dq  ≠ 0 := (ne_of_lt m.dq_pos ).symm
def abq_nz (m : mat) : m.abq ≠ 0 := (ne_of_lt m.abq_pos).symm
def cdq_nz (m : mat) : m.cdq ≠ 0 := (ne_of_lt m.cdq_pos).symm

def au  (m : mat) : units ℚ := units.mk0 m.aq  m.aq_nz
def du  (m : mat) : units ℚ := units.mk0 m.dq  m.dq_nz
def abu (m : mat) : units ℚ := units.mk0 m.abq m.abq_nz
def cdu (m : mat) : units ℚ := units.mk0 m.cdq m.cdq_nz

def one : mat :=
 {a := 1, b := 0, c := 0, d := 1, det_prop := rfl}

def twist (m : mat) : mat :=
begin
 rcases m with ⟨ a,b,c,d,det_prop ⟩,
 have dp := calc
  a * (b + d) = a * b + a * d : mul_add a b d
  ... = a * b + (c * b + 1) : by rw[det_prop]
  ... = (a * b + c * b) + 1 : by rw[add_assoc]
  ... = (a + c) * b + 1 : by rw[← add_mul]
 ,
 exact ⟨ a , b, a + c, b + d, dp⟩
end

def succ (m : mat) : mat  :=
begin
 rcases m with ⟨ a,b,c,d,det_prop ⟩,
 have dp := calc
  (a + c) * d = a * d + c * d : add_mul a c d
  ... = c * b + 1 + c * d : by rw[det_prop]
  ... = c * b + c * d + 1 : by rw[add_assoc, add_comm 1 (c * d), ← add_assoc]
  ... = c * (b + d) + 1 : by rw[← mul_add]
 ,
 exact ⟨ a + c , b + d,  c, d, dp⟩
end

def inv (m : mat) : mat :=
begin
 rcases m with ⟨ a,b,c,d,det_prop ⟩,
 have dp : d * a = b * c + 1, by rw[mul_comm,det_prop,mul_comm],
 exact ⟨ d,c,b,a, dp⟩
end

def to_rat (m : mat) : ℚ := m.abq / m.cdq

lemma to_rat_pos (m : mat) : 0 < to_rat m :=
begin
 dsimp[to_rat],
 apply mul_pos,exact m.abq_pos,apply inv_pos.mpr,exact m.cdq_pos
end

lemma one_to_rat : to_rat mat.one = (1:ℚ) := begin
  change (0 + 1) / (0 + 1) = (1 : ℚ),
  rw[zero_add,div_one],
end

lemma succ_to_rat (m : mat) : to_rat (mat.succ m) = (to_rat m) + 1 :=
begin
 let cdnz := m.cdq_nz,
 rcases m with ⟨ a,b,c,d,det_prop ⟩,
 simp only [to_rat,mat.succ,mat.abq,mat.cdq,mat.ab,mat.cd] at cdnz ⊢,
 have : (((a + c + (b + d)) : ℕ) : ℚ) = ((a + b) : ℕ)  + ((c + d) : ℕ) := by { norm_cast, ring },
 rw[this,add_div,div_self cdnz]
end

def twist_rat (p : ℚ) : ℚ := p / (1 + p)

lemma rat_simp₀ {p q r : ℚ} (hp : p > 0) (hq : q > 0) (hr : r > 0) : p / q / r = p / (q * r) :=
begin
  change (p * q⁻¹) * r⁻¹ = p * (q * r)⁻¹,
  rw[mul_inv_rev, mul_comm r⁻¹, mul_assoc]
end

lemma twist_to_rat (m : mat) :
 to_rat (mat.twist m) = twist_rat (to_rat m) :=
begin
 let abp  := m.abq_pos,
 let cdp  := m.cdq_pos,
 let abnz := m.abq_nz,
 let cdnz := m.cdq_nz,
 rcases m with ⟨ a,b,c,d,det_prop ⟩,
 simp only[to_rat,mat.twist,mat.abq,mat.cdq,mat.ab,mat.cd,twist_rat]
  at abp cdp abnz cdnz ⊢,
 have : (((a + c + (b + d)) : ℕ) : ℚ) = ((a + b) : ℕ)  + ((c + d) : ℕ) := by { norm_cast, ring },
 rw[this],
 let p : ℚ := (a + b : ℕ),
 let q : ℚ := (c + d : ℕ),
 change p / (p + q) = (p / q) / (1 + p / q),
 have pp : p > 0 := abp,
 have qp : q > 0 := cdp,
 have op : (1 : ℚ) > 0 := one_pos,
 have rp := add_pos (div_pos pp qp) op,
 rw[add_comm (1 : ℚ), rat_simp₀ pp qp rp],
 congr' 1,
 rw[mul_add, mul_one, div_eq_mul_inv, ← mul_assoc, mul_comm q, mul_assoc],
 rw[mul_inv_cancel (ne_of_gt qp), mul_one]
end

lemma inv_to_rat (m : mat) :
 to_rat (mat.inv m) = (to_rat m)⁻¹ :=
begin
 let abp  := m.abq_pos,
 let cdp  := m.cdq_pos,
 let abnz := m.abq_nz,
 let cdnz := m.cdq_nz,
 rcases m with ⟨ a,b,c,d,det_prop ⟩,
 simp[to_rat,mat.inv,mat.abq,mat.cdq,mat.ab,mat.cd],
 rw[add_comm ↑c ↑d,add_comm ↑a ↑b],
end

end mat

def to_mat : posrat → mat
| (posrat.twist a) := mat.twist (to_mat a)
| posrat.one := mat.one
| (posrat.succ a) := mat.succ (to_mat a)

def to_rat (a : posrat) : rat := mat.to_rat (posrat.to_mat a)
def num (a : posrat) : ℕ := (posrat.to_mat a).ab
def den (a : posrat) : ℕ := (posrat.to_mat a).cd

end posrat


import breen_deligne.homotopy

noncomputable theory

open_locale nnreal big_operators

namespace breen_deligne

namespace data

variables (BD : data) (r r' : ℝ≥0)

lemma b_exists [hr : fact (r < 1)] (x : ℝ≥0) [fact (0 < x)] :
  ∃ b : ℕ, r ^ b ≤ x⁻¹ :=
begin
  suffices : ∃ b : ℕ, (r ^ b : ℝ) < x⁻¹,
  { rcases this with ⟨b, hb⟩,
    refine ⟨b, le_of_lt _⟩,
    rwa [← nnreal.coe_lt_coe, nnreal.coe_pow, nnreal.coe_inv] },
  refine exists_pow_lt_of_lt_one _ hr.out,
  simp only [nnreal.coe_pos, inv_pos],
  exact ‹fact (0 < x)›.out
end

/-- The smallest `b` such that `r ^ b ≤ x⁻¹`.  -/
def b [hr : fact (r < 1)] (x : ℝ≥0) [fact (0 < x)] := nat.find (b_exists r x)

/-- Example of a very suitable sequence of constants for given Breen--Deligne data. -/
noncomputable def κ (BD : data) (r r' : ℝ≥0) [hr : fact (r < 1)] : ℕ → ℝ≥0
| 0     := 1
| (n+1) := (max 1 (BD.d (n+1) n).factor)⁻¹ * (r' ^ (b r $ max 1 (BD.d (n+1) n).bound) * κ n)

instance c__pos [hr : fact (r < 1)] [hr' : fact (0 < r')] :
  Π (n : ℕ), fact (0 < κ BD r r' n)
| 0     := ⟨zero_lt_one⟩
| (n+1) :=
begin
  dsimp [κ],
  refine ⟨mul_pos (nnreal.inv_pos.mpr _) (mul_pos (pow_pos hr'.1 _) $ (c__pos _).1)⟩,
  exact lt_of_lt_of_le zero_lt_one (le_max_left _ _)
end

instance c_very_suitable [hr : fact (r < 1)] [hr' : fact (0 < r')] :
  BD.very_suitable r r' (BD.κ r r') :=
very_suitable.of_succ _ _ _ _
begin
  intro n,
  let N := max 1 (BD.d (n+1) n).bound,
  let b : ℕ := b r (max 1 (BD.d (n+1) n).bound),
  let c : ℝ≥0 := max 1 (BD.d (n+1) n).factor,
  refine ⟨N, b, c * BD.κ r r' (n+1), le_max_right _ _, _, _, _⟩,
  { intros g hg i,
    exact mul_le_mul' ((universal_map.le_factor _ _ hg _).trans $ le_max_right _ _) le_rfl },
  { rw [mul_comm, nnreal.mul_le_iff_le_inv, mul_one],
    convert nat.find_spec (b_exists r (max 1 (BD.d (n+1) n).bound)),
    { simp only [nat.cast_max, nat.cast_one], },
    { apply ne_of_gt,
      simp only [lt_max_iff, nat.cast_max, nat.cast_one, nat.cast_pos, zero_lt_one, true_or], } },
  { by_cases hc : c = 0,
    { simp only [hc, zero_mul, zero_le'] },
    rw nnreal.mul_le_iff_le_inv hc,
    dsimp [κ], exact le_rfl }
end
(λ i, (data.c__pos _ _ _ i).1)

end data

namespace package

variables (BD : package) (r r' : ℝ≥0)

/-- Example of an adept sequence of constants for
a given Breen--Deligne package `BD` and constants `κ`. -/
def κ' (BD : package) (κ : ℕ → ℝ≥0) : ℕ → ℝ≥0
| 0     := 1
| (n+1) := (BD.homotopy.hom n (n + 1)).factor * rescale_constants κ 2 n * (κ (n + 1))⁻¹

instance κ'_adept (κ : ℕ → ℝ≥0) [∀ i, fact (0 < κ i)] :
  package.adept BD κ (κ' BD κ) :=
{ htpy_suitable' :=
  begin
    intros n,
    apply universal_map.suitable_of_factor_le,
    dsimp [κ'],
    rw [inv_mul_cancel_right₀, mul_inv_cancel_right₀],
    { dsimp [rescale_constants], refine mul_ne_zero (ne_of_gt $ fact.out _) _, norm_num, },
    { exact ne_of_gt (fact.out _) }
  end }

end package

end breen_deligne

#lint-


import rates
import leu_pin

open_locale big_operators
open finset (range)

def xu_rate (χ γ δ₀ : ℕ → ℕ) (L : ℕ) (k : ℕ) : ℕ :=
max
  (γ (3 * L * (k + 1) * (δ₀ k) - 1))
  (χ (3 * k + 2) + 1)
  + 1

open leu_pin (δ)

lemma xu_quantitative
(a c s : ℕ → ℝ)
(L : ℕ)
(χ : ℕ → ℕ)
(γ : ℕ → ℕ)
(δ₀ : ℕ → ℕ)
(a0 : ∀ n : ℕ, 0 ≤ a n)
(a1 : ∀ n : ℕ, a n < 1)
(c0 : ∀ n : ℕ, 0 ≤ c n)
(s0 : ∀ n : ℕ, 0 ≤ s n)
(L_pos : 0 < L)
(h : ∀ n : ℕ, s (n + 1) ≤ (1 - a n) * (s n) + c n)
(L_bound_s : ∀ n : ℕ, s n ≤ L)
(χ_cauchy_mod : is_cauchy_modulus χ (λ n, ∑ i in range (n + 1), c i))
(γ_conv_rate : is_rate_of_convergence_towards γ (λ n, ∏ i in range (n + 1), (1 - a i)) 0)
(hδ₀ : ∀ k : ℕ, 1 / (δ₀ k : ℝ) ≤ (∏ i in range ((χ $ 3 * k + 2) + 1), (1 - a i))) :
is_rate_of_convergence_towards (xu_rate χ γ δ₀ L) s 0 :=
begin
  have δ_of_zero : ∀ k, δ (λ _, 0) χ k = (χ $ 3 * k + 2) + 1 :=  by simp only [forall_const, max_eq_right_iff, zero_le'],
  have := leu_pin.leu_pin_3_5 a (λ _, 0) c s L (λ _, 0) χ γ δ₀ a0 a1 c0 s0 (by simpa) L_pos (λ _ _ _, by { simp only [one_div, inv_nonneg], exact nat.cast_nonneg _ }) χ_cauchy_mod γ_conv_rate hδ₀,
  all_goals {simp_rw [δ_of_zero] at *,},
  exact this,
end

#check nat.cast_nonneg


/-
Copyright (c) 2022 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Heather Macbeth

! This file was ported from Lean 3 source module geometry.manifold.vector_bundle.tangent
! leanprover-community/mathlib commit 0187644979f2d3e10a06e916a869c994facd9a87
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Geometry.Manifold.VectorBundle.Basic

/-! # Tangent bundles

This file defines the tangent bundle as a smooth vector bundle.

Let `M` be a smooth manifold with corners with model `I` on `(E, H)`. We define the tangent bundle
of `M` using the `vector_bundle_core` construction indexed by the charts of `M` with fibers `E`.
Given two charts `i, j : local_homeomorph M H`, the coordinate change between `i` and `j` at a point
`x : M` is the derivative of the composite
```
  I.symm   i.symm    j     I
E -----> H -----> M --> H --> E
```
within the set `range I ⊆ E` at `I (i x) : E`.
This defines a smooth vector bundle `tangent_bundle` with fibers `tangent_space`.

## Main definitions

* `tangent_space I M x` is the fiber of the tangent bundle at `x : M`, which is defined to be `E`.

* `tangent_bundle I M` is the total space of `tangent_space I M`, proven to be a smooth vector
  bundle.
-/

open Bundle Set SmoothManifoldWithCorners LocalHomeomorph

open Manifold Topology Bundle

noncomputable section

variable {𝕜 : Type _} [NontriviallyNormedField 𝕜] {E : Type _} [NormedAddCommGroup E]
  [NormedSpace 𝕜 E] {H : Type _} [TopologicalSpace H] {I : ModelWithCorners 𝕜 E H} {M : Type _}
  [TopologicalSpace M] [ChartedSpace H M] [SmoothManifoldWithCorners I M] {F : Type _}
  [NormedAddCommGroup F] [NormedSpace 𝕜 F]

variable (I)

/-- Auxiliary lemma for tangent spaces: the derivative of a coordinate change between two charts is
  smooth on its source. -/
theorem contDiffOn_fderiv_coord_change (i j : atlas H M) :
    ContDiffOn 𝕜 ∞ (fderivWithin 𝕜 (j.1.extend I ∘ (i.1.extend I).symm) (range I))
      ((i.1.extend I).symm ≫ j.1.extend I).source :=
  by
  have h : ((i.1.extend I).symm ≫ j.1.extend I).source ⊆ range I :=
    by
    rw [i.1.extend_coord_change_source]
    apply image_subset_range
  intro x hx
  refine' (ContDiffWithinAt.fderivWithin_right _ I.unique_diff le_top <| h hx).mono h
  refine'
    (LocalHomeomorph.contDiffOn_extend_coord_change I (subset_maximal_atlas I j.2)
          (subset_maximal_atlas I i.2) x hx).mono_of_mem
      _
  exact i.1.extend_coord_change_source_mem_nhdsWithin j.1 I hx
#align cont_diff_on_fderiv_coord_change contDiffOn_fderiv_coord_change

variable (M)

open SmoothManifoldWithCorners

/-- Let `M` be a smooth manifold with corners with model `I` on `(E, H)`.
Then `vector_bundle_core I M` is the vector bundle core for the tangent bundle over `M`.
It is indexed by the atlas of `M`, with fiber `E` and its change of coordinates from the chart `i`
to the chart `j` at point `x : M` is the derivative of the composite
```
  I.symm   i.symm    j     I
E -----> H -----> M --> H --> E
```
within the set `range I ⊆ E` at `I (i x) : E`. -/
@[simps]
def tangentBundleCore : VectorBundleCore 𝕜 M E (atlas H M)
    where
  baseSet i := i.1.source
  isOpen_baseSet i := i.1.open_source
  indexAt := achart H
  mem_baseSet_at := mem_chart_source H
  coordChange i j x :=
    fderivWithin 𝕜 (j.1.extend I ∘ (i.1.extend I).symm) (range I) (i.1.extend I x)
  coordChange_self i x hx v :=
    by
    rw [Filter.EventuallyEq.fderivWithin_eq, fderivWithin_id', ContinuousLinearMap.id_apply]
    · exact I.unique_diff_at_image
    · exact I.unique_diff_at_image
    · filter_upwards [i.1.extend_target_mem_nhdsWithin I hx]with y hy
      exact (i.1.extend I).right_inv hy
    · simp_rw [Function.comp_apply, i.1.extend_left_inv I hx]
  continuousOn_coordChange i j :=
    by
    refine'
      (contDiffOn_fderiv_coord_change I i j).ContinuousOn.comp ((i.1.continuousOn_extend I).mono _)
        _
    · rw [i.1.extend_source]
      exact inter_subset_left _ _
    simp_rw [← i.1.extend_image_source_inter, maps_to_image]
  coordChange_comp := by
    rintro i j k x ⟨⟨hxi, hxj⟩, hxk⟩ v
    rw [fderivWithin_fderivWithin, Filter.EventuallyEq.fderivWithin_eq]
    · exact I.unique_diff_at_image
    · have := i.1.extend_preimage_mem_nhds I hxi (j.1.extend_source_mem_nhds I hxj)
      filter_upwards [nhdsWithin_le_nhds this]with y hy
      simp_rw [Function.comp_apply, (j.1.extend I).left_inv hy]
    · simp_rw [Function.comp_apply, i.1.extend_left_inv I hxi, j.1.extend_left_inv I hxj]
    ·
      exact
        (cont_diff_within_at_extend_coord_change' I (subset_maximal_atlas I k.2)
              (subset_maximal_atlas I j.2) hxk hxj).DifferentiableWithinAt
          le_top
    ·
      exact
        (cont_diff_within_at_extend_coord_change' I (subset_maximal_atlas I j.2)
              (subset_maximal_atlas I i.2) hxj hxi).DifferentiableWithinAt
          le_top
    · intro x hx
      exact mem_range_self _
    · exact I.unique_diff_at_image
    · rw [Function.comp_apply, i.1.extend_left_inv I hxi]
#align tangent_bundle_core tangentBundleCore

variable {M}

theorem tangentBundleCore_coordChange_achart (x x' z : M) :
    (tangentBundleCore I M).coordChange (achart H x) (achart H x') z =
      fderivWithin 𝕜 (extChartAt I x' ∘ (extChartAt I x).symm) (range I) (extChartAt I x z) :=
  rfl
#align tangent_bundle_core_coord_change_achart tangentBundleCore_coordChange_achart

include I

/-- The tangent space at a point of the manifold `M`. It is just `E`. We could use instead
`(tangent_bundle_core I M).to_topological_vector_bundle_core.fiber x`, but we use `E` to help the
kernel.
-/
@[nolint unused_arguments]
def TangentSpace (x : M) : Type _ :=
  E deriving TopologicalSpace, AddCommGroup, TopologicalAddGroup
#align tangent_space TangentSpace

omit I

variable (M)

-- is empty if the base manifold is empty
/-- The tangent bundle to a smooth manifold, as a Sigma type. Defined in terms of
`bundle.total_space` to be able to put a suitable topology on it. -/
@[nolint has_nonempty_instance, reducible]
def TangentBundle :=
  Bundle.TotalSpace (TangentSpace I : M → Type _)
#align tangent_bundle TangentBundle

-- mathport name: exprTM
local notation "TM" => TangentBundle I M

section TangentBundleInstances

/- In general, the definition of tangent_space is not reducible, so that type class inference
does not pick wrong instances. In this section, we record the right instances for
them, noting in particular that the tangent bundle is a smooth manifold. -/
section

attribute [local reducible] TangentSpace

variable {M} (x : M)

instance : Module 𝕜 (TangentSpace I x) := by infer_instance

instance : Inhabited (TangentSpace I x) :=
  ⟨0⟩

end

instance : TopologicalSpace TM :=
  (tangentBundleCore I M).toTopologicalSpace

instance : FiberBundle E (TangentSpace I : M → Type _) :=
  (tangentBundleCore I M).FiberBundle

instance : VectorBundle 𝕜 E (TangentSpace I : M → Type _) :=
  (tangentBundleCore I M).VectorBundle

namespace TangentBundle

protected theorem chartAt (p : TM) :
    chartAt (ModelProd H E) p =
      ((tangentBundleCore I M).toFiberBundleCore.localTriv (achart H p.1)).toLocalHomeomorph ≫ₕ
        (chartAt H p.1).Prod (LocalHomeomorph.refl E) :=
  rfl
#align tangent_bundle.chart_at TangentBundle.chartAt

theorem chartAt_toLocalEquiv (p : TM) :
    (chartAt (ModelProd H E) p).toLocalEquiv =
      (tangentBundleCore I M).toFiberBundleCore.localTrivAsLocalEquiv (achart H p.1) ≫
        (chartAt H p.1).toLocalEquiv.Prod (LocalEquiv.refl E) :=
  rfl
#align tangent_bundle.chart_at_to_local_equiv TangentBundle.chartAt_toLocalEquiv

theorem trivializationAt_eq_localTriv (x : M) :
    trivializationAt E (TangentSpace I) x =
      (tangentBundleCore I M).toFiberBundleCore.localTriv (achart H x) :=
  rfl
#align tangent_bundle.trivialization_at_eq_local_triv TangentBundle.trivializationAt_eq_localTriv

@[simp, mfld_simps]
theorem trivializationAt_source (x : M) :
    (trivializationAt E (TangentSpace I) x).source = π _ ⁻¹' (chartAt H x).source :=
  rfl
#align tangent_bundle.trivialization_at_source TangentBundle.trivializationAt_source

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp, mfld_simps]
theorem trivializationAt_target (x : M) :
    (trivializationAt E (TangentSpace I) x).target = (chartAt H x).source ×ˢ univ :=
  rfl
#align tangent_bundle.trivialization_at_target TangentBundle.trivializationAt_target

@[simp, mfld_simps]
theorem trivializationAt_baseSet (x : M) :
    (trivializationAt E (TangentSpace I) x).baseSet = (chartAt H x).source :=
  rfl
#align tangent_bundle.trivialization_at_base_set TangentBundle.trivializationAt_baseSet

theorem trivializationAt_apply (x : M) (z : TM) :
    trivializationAt E (TangentSpace I) x z =
      (z.1,
        fderivWithin 𝕜 ((chartAt H x).extend I ∘ ((chartAt H z.1).extend I).symm) (range I)
          ((chartAt H z.1).extend I z.1) z.2) :=
  rfl
#align tangent_bundle.trivialization_at_apply TangentBundle.trivializationAt_apply

@[simp, mfld_simps]
theorem trivializationAt_fst (x : M) (z : TM) : (trivializationAt E (TangentSpace I) x z).1 = z.1 :=
  rfl
#align tangent_bundle.trivialization_at_fst TangentBundle.trivializationAt_fst

@[simp, mfld_simps]
theorem mem_chart_source_iff (p q : TM) :
    p ∈ (chartAt (ModelProd H E) q).source ↔ p.1 ∈ (chartAt H q.1).source := by
  simp only [FiberBundle.chartedSpace_chartAt, mfld_simps]
#align tangent_bundle.mem_chart_source_iff TangentBundle.mem_chart_source_iff

@[simp, mfld_simps]
theorem mem_chart_target_iff (p : H × E) (q : TM) :
    p ∈ (chartAt (ModelProd H E) q).target ↔ p.1 ∈ (chartAt H q.1).target := by
  simp (config := { contextual := true }) only [FiberBundle.chartedSpace_chartAt,
    and_iff_left_iff_imp, mfld_simps]
#align tangent_bundle.mem_chart_target_iff TangentBundle.mem_chart_target_iff

@[simp, mfld_simps]
theorem coe_chartAt_fst (p q : TM) : ((chartAt (ModelProd H E) q) p).1 = chartAt H q.1 p.1 :=
  rfl
#align tangent_bundle.coe_chart_at_fst TangentBundle.coe_chartAt_fst

@[simp, mfld_simps]
theorem coe_chartAt_symm_fst (p : H × E) (q : TM) :
    ((chartAt (ModelProd H E) q).symm p).1 = ((chartAt H q.1).symm : H → M) p.1 :=
  rfl
#align tangent_bundle.coe_chart_at_symm_fst TangentBundle.coe_chartAt_symm_fst

end TangentBundle

instance tangentBundleCore.isSmooth : (tangentBundleCore I M).IsSmooth I :=
  by
  refine' ⟨fun i j => _⟩
  rw [SmoothOn, contMdiffOn_iff_source_of_mem_maximalAtlas (subset_maximal_atlas I i.2),
    contMdiffOn_iff_contDiffOn]
  refine' ((contDiffOn_fderiv_coord_change I i j).congr fun x hx => _).mono _
  · rw [LocalEquiv.trans_source'] at hx
    simp_rw [Function.comp_apply, tangentBundleCore_coordChange, (i.1.extend I).right_inv hx.1]
  · exact (i.1.extend_image_source_inter j.1 I).Subset
  · apply inter_subset_left
#align tangent_bundle_core.is_smooth tangentBundleCore.isSmooth

instance TangentBundle.smoothVectorBundle : SmoothVectorBundle E (TangentSpace I : M → Type _) I :=
  (tangentBundleCore I M).SmoothVectorBundle _
#align tangent_bundle.smooth_vector_bundle TangentBundle.smoothVectorBundle

end TangentBundleInstances

/-! ## The tangent bundle to the model space -/

/-- In the tangent bundle to the model space, the charts are just the canonical identification
between a product type and a sigma type, a.k.a. `equiv.sigma_equiv_prod`. -/
@[simp, mfld_simps]
theorem tangentBundle_model_space_chartAt (p : TangentBundle I H) :
    (chartAt (ModelProd H E) p).toLocalEquiv = (Equiv.sigmaEquivProd H E).toLocalEquiv :=
  by
  ext x : 1
  · ext
    · rfl
    exact (tangentBundleCore I H).coordChange_self (achart _ x.1) x.1 (mem_achart_source H x.1) x.2
  · intro x
    ext
    · rfl
    apply hEq_of_eq
    exact (tangentBundleCore I H).coordChange_self (achart _ x.1) x.1 (mem_achart_source H x.1) x.2
  simp_rw [TangentBundle.chartAt, FiberBundleCore.localTriv, FiberBundleCore.localTrivAsLocalEquiv,
    VectorBundleCore.toFiberBundleCore_baseSet, tangentBundleCore_baseSet]
  simp only [mfld_simps]
#align tangent_bundle_model_space_chart_at tangentBundle_model_space_chartAt

@[simp, mfld_simps]
theorem tangentBundle_model_space_coe_chartAt (p : TangentBundle I H) :
    ⇑(chartAt (ModelProd H E) p) = Equiv.sigmaEquivProd H E :=
  by
  unfold_coes
  simp_rw [tangentBundle_model_space_chartAt]
  rfl
#align tangent_bundle_model_space_coe_chart_at tangentBundle_model_space_coe_chartAt

@[simp, mfld_simps]
theorem tangentBundle_model_space_coe_chartAt_symm (p : TangentBundle I H) :
    ((chartAt (ModelProd H E) p).symm : ModelProd H E → TangentBundle I H) =
      (Equiv.sigmaEquivProd H E).symm :=
  by
  unfold_coes
  simp_rw [LocalHomeomorph.symm_toLocalEquiv, tangentBundle_model_space_chartAt]
  rfl
#align tangent_bundle_model_space_coe_chart_at_symm tangentBundle_model_space_coe_chartAt_symm

variable (H)

/-- The canonical identification between the tangent bundle to the model space and the product,
as a homeomorphism -/
def tangentBundleModelSpaceHomeomorph : TangentBundle I H ≃ₜ ModelProd H E :=
  {
    Equiv.sigmaEquivProd H
      E with
    continuous_toFun := by
      let p : TangentBundle I H := ⟨I.symm (0 : E), (0 : E)⟩
      have : Continuous (chart_at (ModelProd H E) p) :=
        by
        rw [continuous_iff_continuousOn_univ]
        convert LocalHomeomorph.continuousOn _
        simp only [TangentSpace.fiberBundle, mfld_simps]
      simpa only [mfld_simps] using this
    continuous_invFun :=
      by
      let p : TangentBundle I H := ⟨I.symm (0 : E), (0 : E)⟩
      have : Continuous (chart_at (ModelProd H E) p).symm :=
        by
        rw [continuous_iff_continuousOn_univ]
        convert LocalHomeomorph.continuousOn _
        simp only [mfld_simps]
      simpa only [mfld_simps] using this }
#align tangent_bundle_model_space_homeomorph tangentBundleModelSpaceHomeomorph

@[simp, mfld_simps]
theorem tangentBundleModelSpaceHomeomorph_coe :
    (tangentBundleModelSpaceHomeomorph H I : TangentBundle I H → ModelProd H E) =
      Equiv.sigmaEquivProd H E :=
  rfl
#align tangent_bundle_model_space_homeomorph_coe tangentBundleModelSpaceHomeomorph_coe

@[simp, mfld_simps]
theorem tangentBundleModelSpaceHomeomorph_coe_symm :
    ((tangentBundleModelSpaceHomeomorph H I).symm : ModelProd H E → TangentBundle I H) =
      (Equiv.sigmaEquivProd H E).symm :=
  rfl
#align tangent_bundle_model_space_homeomorph_coe_symm tangentBundleModelSpaceHomeomorph_coe_symm


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.group_ring_action
import algebra.hom.group_action
import data.polynomial.algebra_map
import data.polynomial.monic

/-!
# Group action on rings applied to polynomials

This file contains instances and definitions relating `mul_semiring_action` to `polynomial`.
-/

variables (M : Type*) [monoid M]

open_locale polynomial
namespace polynomial

variables (R : Type*) [semiring R]

variables {M}

lemma smul_eq_map [mul_semiring_action M R] (m : M) :
  ((•) m) = map (mul_semiring_action.to_ring_hom M R m) :=
begin
  suffices :
    distrib_mul_action.to_add_monoid_hom R[X] m =
      (map_ring_hom (mul_semiring_action.to_ring_hom M R m)).to_add_monoid_hom,
  { ext1 r, exact add_monoid_hom.congr_fun this r, },
  ext n r : 2,
  change m • monomial n r = map (mul_semiring_action.to_ring_hom M R m) (monomial n r),
  simpa only [polynomial.map_monomial, polynomial.smul_monomial],
end

variables (M)

noncomputable instance [mul_semiring_action M R] : mul_semiring_action M R[X] :=
{ smul := (•),
  smul_one := λ m, (smul_eq_map R m).symm ▸ map_one (mul_semiring_action.to_ring_hom M R m),
  smul_mul := λ m p q, (smul_eq_map R m).symm ▸ map_mul (mul_semiring_action.to_ring_hom M R m),
  ..polynomial.distrib_mul_action }

variables {M R}

variables [mul_semiring_action M R]

@[simp] lemma smul_X (m : M) : (m • X : R[X]) = X :=
(smul_eq_map R m).symm ▸ map_X _

variables (S : Type*) [comm_semiring S] [mul_semiring_action M S]

theorem smul_eval_smul (m : M) (f : S[X]) (x : S) :
  (m • f).eval (m • x) = m • f.eval x :=
polynomial.induction_on f
  (λ r, by rw [smul_C, eval_C, eval_C])
  (λ f g ihf ihg, by rw [smul_add, eval_add, ihf, ihg, eval_add, smul_add])
  (λ n r ih, by rw [smul_mul', smul_pow', smul_C, smul_X, eval_mul, eval_C, eval_pow, eval_X,
      eval_mul, eval_C, eval_pow, eval_X, smul_mul', smul_pow'])

variables (G : Type*) [group G]

theorem eval_smul' [mul_semiring_action G S] (g : G) (f : S[X]) (x : S) :
  f.eval (g • x) = g • (g⁻¹ • f).eval x :=
by rw [← smul_eval_smul, smul_inv_smul]

theorem smul_eval [mul_semiring_action G S] (g : G) (f : S[X]) (x : S) :
  (g • f).eval x = g • f.eval (g⁻¹ • x) :=
by rw [← smul_eval_smul, smul_inv_smul]

end polynomial

section comm_ring

variables (G : Type*) [group G] [fintype G]
variables (R : Type*) [comm_ring R] [mul_semiring_action G R]
open mul_action
open_locale classical

/-- the product of `(X - g • x)` over distinct `g • x`. -/
noncomputable def prod_X_sub_smul (x : R) : R[X] :=
(finset.univ : finset (G ⧸ mul_action.stabilizer G x)).prod $
λ g, polynomial.X - polynomial.C (of_quotient_stabilizer G x g)

theorem prod_X_sub_smul.monic (x : R) : (prod_X_sub_smul G R x).monic :=
polynomial.monic_prod_of_monic _ _ $ λ g _, polynomial.monic_X_sub_C _

theorem prod_X_sub_smul.eval (x : R) : (prod_X_sub_smul G R x).eval x = 0 :=
(monoid_hom.map_prod
  ((polynomial.aeval x).to_ring_hom.to_monoid_hom : R[X] →* R) _ _).trans $
  finset.prod_eq_zero (finset.mem_univ $ quotient_group.mk 1) $
  by simp

theorem prod_X_sub_smul.smul (x : R) (g : G) :
  g • prod_X_sub_smul G R x = prod_X_sub_smul G R x :=
finset.smul_prod.trans $ fintype.prod_bijective _ (mul_action.bijective g) _ _
  (λ g', by rw [of_quotient_stabilizer_smul, smul_sub, polynomial.smul_X, polynomial.smul_C])

theorem prod_X_sub_smul.coeff (x : R) (g : G) (n : ℕ) :
  g • (prod_X_sub_smul G R x).coeff n =
  (prod_X_sub_smul G R x).coeff n :=
by rw [← polynomial.coeff_smul, prod_X_sub_smul.smul]

end comm_ring

namespace mul_semiring_action_hom
variables {M}
variables {P : Type*} [comm_semiring P] [mul_semiring_action M P]
variables {Q : Type*} [comm_semiring Q] [mul_semiring_action M Q]
open polynomial

/-- An equivariant map induces an equivariant map on polynomials. -/
protected noncomputable def polynomial (g : P →+*[M] Q) : P[X] →+*[M] Q[X] :=
{ to_fun := map g,
  map_smul' := λ m p, polynomial.induction_on p
    (λ b, by rw [smul_C, map_C, coe_fn_coe, g.map_smul, map_C, coe_fn_coe, smul_C])
    (λ p q ihp ihq, by rw [smul_add, polynomial.map_add, ihp, ihq, polynomial.map_add, smul_add])
    (λ n b ih, by rw [smul_mul', smul_C, smul_pow', smul_X, polynomial.map_mul, map_C,
        polynomial.map_pow, map_X, coe_fn_coe, g.map_smul, polynomial.map_mul, map_C,
        polynomial.map_pow, map_X, smul_mul', smul_C, smul_pow', smul_X, coe_fn_coe]),
  map_zero' := polynomial.map_zero g,
  map_add' := λ p q, polynomial.map_add g,
  map_one' := polynomial.map_one g,
  map_mul' := λ p q, polynomial.map_mul g }

@[simp] theorem coe_polynomial (g : P →+*[M] Q) :
  (g.polynomial : P[X] → Q[X]) = map g :=
rfl

end mul_semiring_action_hom


import ground_zero.HITs.pushout ground_zero.HITs.interval
import ground_zero.types.integers
open ground_zero.types

/-
  Homotopical reals R.
  * HoTT 8.1.5
-/

namespace ground_zero.HITs
universes u v w

local notation ℤ := integers

inductive reals.rel : ℤ → ℤ → Prop
| glue (x : ℤ) : reals.rel x (integers.succ x)
def reals := quot reals.rel
notation `R` := reals

namespace reals
  def elem : ℤ → R := quot.mk rel
  def glue (z : ℤ) : elem z = elem (integers.succ z) :> R :=
  ground_zero.support.inclusion (quot.sound $ rel.glue z)

  def ind {π : R → Sort u} (cz : Π x, π (elem x))
    (sz : Π z, cz z =[glue z] cz (integers.succ z))
    (u : R) : π u := begin
    refine quot.hrec_on u _ _,
    exact cz, intros x y p, cases p,
    refine ground_zero.types.eq.rec _
      (equiv.subst_from_pathover (sz x)),
    apply ground_zero.types.heq.eq_subst_heq
  end

  def rec {π : Sort u} (cz : ℤ → π)
    (sz : Π z, cz z = cz (integers.succ z) :> π) : R → π :=
  ind cz (λ x, dep_path.pathover_of_eq (glue x) (sz x))

  def positive : Π n, elem 0 = elem (integers.pos n) :> R
  | 0 := ground_zero.types.eq.refl (elem 0)
  | (n + 1) := positive n ⬝ glue (integers.pos n)

  def negative : Π n, elem 0 = elem (integers.neg n) :> R
  | 0 := (glue (integers.neg 0))⁻¹
  | (n + 1) := negative n ⬝ (glue $ integers.neg (n + 1))⁻¹

  def center : Π z, elem 0 = elem z :> R
  | (integers.pos n) := positive n
  | (integers.neg n) := negative n

  def vect (u v : ℤ) : elem u = elem v :> R :=
  (center u)⁻¹ ⬝ center v
end reals

class has_mem (α : Sort u) (γ : Sort v) :=
(mem : α → γ → Sort w)
infix ` ∈ ` := has_mem.mem

def quasiset (α : Sort u) := α → Sort v
namespace quasiset
  abbreviation mk {α : Sort u} (f : α → Sort v) : quasiset α := f

  def membership {α : Sort u} (x : α) (s : quasiset α) := s x
  instance {α : Sort u} : has_mem α (quasiset α) := ⟨membership⟩

  notation `{` binder ` | ` r:(scoped P, mk P) `}` := r

  inductive bottom : Sort u
  def empty (α : Sort u) : quasiset α := { x | bottom }
end quasiset

namespace geometry
  notation `R²` := R × R

  class is_euclidian (S : Sort u) :=
  (B : S → S → S → Sort u)
  (equ : S → S → Sort u)
  (cong : S × S → S × S → Sort u)
  -- Tarski axioms
  (cong_refl (x y : S) : cong ⟨x, y⟩ ⟨y, x⟩)
  (cong_trans (a b c : S × S) : cong a b → cong a c → cong b c)
  (identity_of_congruence (x y z : S) : cong ⟨x, y⟩ ⟨z, z⟩ → equ x y)
  (segment_construction (x y a b : S) : Σ' z,
    B x y z × cong ⟨y, z⟩ ⟨a, b⟩)
  (five_segment (x y z x' y' z' u u' : S) :
    ¬(equ x y) →
    B x y z → B x' y' z' →
    cong ⟨x, y⟩ ⟨x', y'⟩ →
    cong ⟨y, z⟩ ⟨y', z'⟩ →
    cong ⟨x, u⟩ ⟨x', u'⟩ →
    cong ⟨y, u⟩ ⟨y', u'⟩ →
    cong ⟨z, u⟩ ⟨z', u'⟩)
  (identity_of_betweenness (x y : S) : B x y x → equ x y)
  (axiom_of_Pasch (x y z u v : S) :
    B x y z → B y v z → Σ' a, B u a y × B v a x)
  (lower_dimension (a b c : S) :
    ¬(B a b c) × ¬(B b c a) × ¬(B c a b))
  (upper_dimension (x y z u v : S) :
    cong ⟨x, u⟩ ⟨x, v⟩ →
    cong ⟨y, u⟩ ⟨y, v⟩ →
    cong ⟨z, u⟩ ⟨z, v⟩ →
    ¬(equ u v) →
    B x y z × B y z x × B z x y)
  (axiom_of_Euclid (x y z u v : S) :
    B x u v → B y u z → ¬(equ x y) →
    Σ' a b, B x y a × B x z b × B a v b)
  (axiom_schema_of_Continuity (φ ψ : S → Sort u) :
    (Σ' a, ∀ x y, φ x → ψ y → B a x y) →
    (Σ' b, ∀ x y, φ x → ψ y → B x b y))
  open is_euclidian

  notation a ` ≅ ` b := is_euclidian.cong a b

  section
    variables {S : Sort u} [is_euclidian S]

    instance in_segment : has_mem S (S × S) :=
    ⟨λ x a, B a.pr₁ x a.pr₂⟩

    def line (x y : S) :=
    { z | B y x z + B x y z + B x z y }

    def circle (radius : S × S) :=
    { z | ⟨radius.pr₁, z⟩ ≅ radius }

    def disk (radius : S × S) : quasiset S :=
    { z | Σ' (a : S × S), equ a.pr₁ radius.pr₁ × (a ≅ radius) × z ∈ a }

    def triangle (a b c : S) :=
    { z | B a z c + B a z b + B b z c }

    def ray (a b : S) :=
    { c | B a c b + B a b c }

    def angle (a b c : S) : quasiset S :=
    { z | (z ∈ ray b a) + (z ∈ ray b c) }

    def parallel (a b : quasiset S) :=
    ¬(Σ' (z : S), z ∈ a × z ∈ b)

    def segment.is_sum (r₁ r₂ r : S × S) :=
    Σ' z, (⟨r.pr₁, z⟩ ≅ r₁) × (⟨r.pr₂, z⟩ ≅ r₂)

    def sigma_unique (p : S → Sort v) :=
    Σ' x, p x × (Π y, p y → equ y x)

    notation `Σ!` binders `, ` r:(scoped P, sigma_unique P) := r

    def tang (A₁ A₂ : quasiset S) :=
    Σ! (z : S), z ∈ A₁ × z ∈ A₂

    def circle.tang (r₁ r₂ : S × S) :=
    tang (circle r₁) (circle r₂)

    theorem sum_of_radiuses_tang_circles (r₁ r₂ : S × S)
      (h : circle.tang r₁ r₂) :
      segment.is_sum r₁ r₂ ⟨r₁.pr₁, r₂.pr₁⟩ := begin
      cases h with z cond,
      cases cond with cond trash, clear trash,
      cases cond with belongs₁ belongs₂,
      existsi z, split,
      exact belongs₁, exact belongs₂
    end
  end
end geometry

end ground_zero.HITs


open classical
variables (α : Type) (p q : α -> Prop)
variable a : α
variable r : Prop
example : (∃ x, p x → r) ↔ (∀ x, p x) → r :=
iff.intro
  (assume h1 : ∃ x, p x → r,
    assume h2 : ∀ x, p x,
    exists.elim h1 $
    assume y(hb : p y -> r),
    show r, from  hb (h2 y))
  (assume h1 : (∀ x, p x) → r,
    show ∃ x, p x → r, from
      by_cases
        (assume hp : ∀ x, p x, exists.intro a (λ h', h1 hp))
        (assume hp' : ¬ ∀ x, p x,
          by_contradiction
            (assume hex' : ¬ ∃ x, p x → r,
              have hp : ∀ x, p x, from
                assume x,
                by_contradiction
                  (assume hp' : ¬ p x,
                    have hex : ∃ x, p x → r, from exists.intro x
                    (assume hp : p x, absurd hp hp'),
                    show false, from hex' hex),
              show false, from hp' hp)))


import M4R.Notation
import M4R.Logic

namespace M4R

  instance MemSubset [Mem α γ] : Subset γ where
    subset (a b : γ) := ∀ ⦃x : α⦄, x ∈ a → x ∈ b

  instance MemNotSubset [Mem α γ] : NotSubset γ where
    notsubset (a b : γ) := ¬a ⊆ b

  instance MemProperSubset [Mem α γ] : ProperSubset γ where
    propersubset (a b : γ) := a ⊆ b ∧ ∃ x : α, x ∉ a ∧ x ∈ b

  namespace Subset

    @[simp] protected theorem antisymm [Mem α γ] (a b : γ) : a ⊆ b ∧ b ⊆ a ↔ ∀ x : α, x ∈ a ↔ x ∈ b :=
      ⟨fun ⟨ab, ba⟩ x => ⟨@ab x, @ba x⟩, fun h => ⟨fun x => (h x).mp, fun x => (h x).mpr⟩⟩

    @[simp] theorem toSuperset [Mem α γ] (a b : γ) (x : α) : x ∈ a → a ⊆ b → x ∈ b :=
      fun xa ab => @ab x xa

    @[simp] protected theorem refl [Mem α γ] (a : γ) : a ⊆ a := fun _ => id

    @[simp] protected theorem trans [Mem α γ] {a b c : γ} : a ⊆ b → b ⊆ c → a ⊆ c := fun ab bc x xa => bc (ab xa)

  end Subset
  namespace NotSubset

    @[simp] theorem notsubset_def [Mem α γ] {a b : γ} : ¬(a ⊆ b) ↔ a ⊈ b := Iff.rfl

    theorem exists_def [Mem α γ] {a b : γ} : a ⊈ b ↔ ∃ x, x ∈ a ∧ x ∉ b := by
      apply not_iff_not.mp; simp only [←notsubset_def, iff_not_not,
        not_exists, not_and]; exact Iff.rfl

  end NotSubset
  namespace ProperSubset

    @[simp] theorem toSubset [Mem α γ] (a b : γ) : a ⊊ b → a ⊆ b := And.left

    @[simp] protected theorem trans [Mem α γ] {a b c : γ} : a ⊊ b → b ⊊ c → a ⊊ c := fun ab bc =>
      ⟨Subset.trans ab.left bc.left, let ⟨x, xa, xb⟩ := ab.right; ⟨x, xa, bc.left xb⟩⟩

    @[simp] protected theorem trans_left [Mem α γ] {a b c : γ} : a ⊊ b → b ⊆ c → a ⊊ c := fun ab bc =>
      ⟨Subset.trans ab.left bc, let ⟨x, xa, xb⟩ := ab.right; ⟨x, xa, bc xb⟩⟩

    @[simp] protected theorem trans_right [Mem α γ] {a b c : γ} : a ⊆ b → b ⊊ c → a ⊊ c := fun ab bc =>
      ⟨Subset.trans ab bc.left, let ⟨x, xb, xc⟩ := bc.right; ⟨x, fun xa => xb (ab xa), xc⟩⟩

    theorem toNotSubset [Mem α γ] {a b : γ} (h : a ⊊ b) : b ⊈ a :=
      let ⟨x, hxa, hxb⟩ := h.right; fun h' => absurd (h' hxb) hxa

    theorem notProperSubset [Mem α γ] {a b : γ} : ¬a ⊊ b ↔ (∃ x, x ∈ a ∧ x ∉ b) ∨ ∀ x, x ∈ a ∨ x ∉ b := by
      simp only [ProperSubset.propersubset, not_and_iff_or_not, not_exists, iff_not_not, ←NotSubset.exists_def]
      exact Iff.rfl

  end ProperSubset

end M4R


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import analysis.specific_limits.basic
import topology.metric_space.hausdorff_distance
import topology.sets.compacts

/-!
# Closed subsets

This file defines the metric and emetric space structure on the types of closed subsets and nonempty
compact subsets of a metric or emetric space.

The Hausdorff distance induces an emetric space structure on the type of closed subsets
of an emetric space, called `closeds`. Its completeness, resp. compactness, resp.
second-countability, follow from the corresponding properties of the original space.

In a metric space, the type of nonempty compact subsets (called `nonempty_compacts`) also
inherits a metric space structure from the Hausdorff distance, as the Hausdorff edistance is
always finite in this context.
-/

noncomputable theory
open_locale classical topological_space ennreal

universe u
open classical set function topological_space filter

namespace emetric
section
variables {α : Type u} [emetric_space α] {s : set α}

/-- In emetric spaces, the Hausdorff edistance defines an emetric space structure
on the type of closed subsets -/
instance closeds.emetric_space : emetric_space (closeds α) :=
{ edist               := λs t, Hausdorff_edist (s : set α) t,
  edist_self          := λs, Hausdorff_edist_self,
  edist_comm          := λs t, Hausdorff_edist_comm,
  edist_triangle      := λs t u, Hausdorff_edist_triangle,
  eq_of_edist_eq_zero :=
    λ s t h, closeds.ext $ (Hausdorff_edist_zero_iff_eq_of_closed s.closed t.closed).1 h }

/-- The edistance to a closed set depends continuously on the point and the set -/
lemma continuous_inf_edist_Hausdorff_edist :
  continuous (λ p : α × (closeds α), inf_edist p.1 p.2) :=
begin
  refine continuous_of_le_add_edist 2 (by simp) _,
  rintros ⟨x, s⟩ ⟨y, t⟩,
  calc inf_edist x s ≤ inf_edist x t + Hausdorff_edist (t : set α) s :
    inf_edist_le_inf_edist_add_Hausdorff_edist
  ... ≤ inf_edist y t + edist x y + Hausdorff_edist (t : set α) s :
    add_le_add_right inf_edist_le_inf_edist_add_edist _
  ... = inf_edist y t + (edist x y + Hausdorff_edist (s : set α) t)
      : by rw [add_assoc, Hausdorff_edist_comm]
  ... ≤ inf_edist y t + (edist (x, s) (y, t) + edist (x, s) (y, t)) :
    add_le_add_left (add_le_add (le_max_left _ _) (le_max_right _ _)) _
  ... = inf_edist y t + 2 * edist (x, s) (y, t) :
    by rw [← mul_two, mul_comm]
end

/-- Subsets of a given closed subset form a closed set -/
lemma is_closed_subsets_of_is_closed (hs : is_closed s) :
  is_closed {t : closeds α | (t : set α) ⊆ s} :=
begin
  refine is_closed_of_closure_subset (λt ht x hx, _),
  -- t : closeds α,  ht : t ∈ closure {t : closeds α | t ⊆ s},
  -- x : α,  hx : x ∈ t
  -- goal : x ∈ s
  have : x ∈ closure s,
  { refine mem_closure_iff.2 (λε εpos, _),
    rcases mem_closure_iff.1 ht ε εpos with ⟨u, hu, Dtu⟩,
    -- u : closeds α,  hu : u ∈ {t : closeds α | t ⊆ s},  hu' : edist t u < ε
    rcases exists_edist_lt_of_Hausdorff_edist_lt hx Dtu with ⟨y, hy, Dxy⟩,
    -- y : α,  hy : y ∈ u, Dxy : edist x y < ε
    exact ⟨y, hu hy, Dxy⟩ },
  rwa hs.closure_eq at this,
end

/-- By definition, the edistance on `closeds α` is given by the Hausdorff edistance -/
lemma closeds.edist_eq {s t : closeds α} : edist s t = Hausdorff_edist (s : set α) t := rfl

/-- In a complete space, the type of closed subsets is complete for the
Hausdorff edistance. -/
instance closeds.complete_space [complete_space α] : complete_space (closeds α) :=
begin
  /- We will show that, if a sequence of sets `s n` satisfies
  `edist (s n) (s (n+1)) < 2^{-n}`, then it converges. This is enough to guarantee
  completeness, by a standard completeness criterion.
  We use the shorthand `B n = 2^{-n}` in ennreal. -/
  let B : ℕ → ℝ≥0∞ := λ n, (2⁻¹)^n,
  have B_pos : ∀ n, (0:ℝ≥0∞) < B n,
    by simp [B, ennreal.pow_pos],
  have B_ne_top : ∀ n, B n ≠ ⊤,
    by simp [B, ennreal.pow_ne_top],
  /- Consider a sequence of closed sets `s n` with `edist (s n) (s (n+1)) < B n`.
  We will show that it converges. The limit set is t0 = ⋂n, closure (⋃m≥n, s m).
  We will have to show that a point in `s n` is close to a point in `t0`, and a point
  in `t0` is close to a point in `s n`. The completeness then follows from a
  standard criterion. -/
  refine complete_of_convergent_controlled_sequences B B_pos (λs hs, _),
  let t0 := ⋂ n, closure (⋃ m ≥ n, s m : set α),
  let t : closeds α := ⟨t0, is_closed_Inter (λ_, is_closed_closure)⟩,
  use t,
  -- The inequality is written this way to agree with `edist_le_of_edist_le_geometric_of_tendsto₀`
  have I1 : ∀ n, ∀ x ∈ s n, ∃ y ∈ t0, edist x y ≤ 2 * B n,
  { /- This is the main difficulty of the proof. Starting from `x ∈ s n`, we want
       to find a point in `t0` which is close to `x`. Define inductively a sequence of
       points `z m` with `z n = x` and `z m ∈ s m` and `edist (z m) (z (m+1)) ≤ B m`. This is
       possible since the Hausdorff distance between `s m` and `s (m+1)` is at most `B m`.
       This sequence is a Cauchy sequence, therefore converging as the space is complete, to
       a limit which satisfies the required properties. -/
    assume n x hx,
    obtain ⟨z, hz₀, hz⟩ : ∃ z : Π l, s (n + l), (z 0 : α) = x ∧
      ∀ k, edist (z k:α) (z (k+1):α) ≤ B n / 2^k,
    { -- We prove existence of the sequence by induction.
      have : ∀ l (z : s (n + l)), ∃ z' : s (n + l + 1), edist (z : α) z' ≤ B n / 2^l,
      { assume l z,
        obtain ⟨z', z'_mem, hz'⟩ : ∃ z' ∈ s (n + l + 1), edist (z : α) z' < B n / 2^l,
        { refine exists_edist_lt_of_Hausdorff_edist_lt _ _,
          { exact s (n + l) },
          { exact z.2 },
          simp only [B, ennreal.inv_pow, div_eq_mul_inv],
          rw [← pow_add],
          apply hs; simp },
        exact ⟨⟨z', z'_mem⟩, le_of_lt hz'⟩ },
      use [λ k, nat.rec_on k ⟨x, hx⟩ (λl z, some (this l z)), rfl],
      exact λ k, some_spec (this k _) },
    -- it follows from the previous bound that `z` is a Cauchy sequence
    have : cauchy_seq (λ k, ((z k):α)),
      from cauchy_seq_of_edist_le_geometric_two (B n) (B_ne_top n) hz,
    -- therefore, it converges
    rcases cauchy_seq_tendsto_of_complete this with ⟨y, y_lim⟩,
    use y,
    -- the limit point `y` will be the desired point, in `t0` and close to our initial point `x`.
    -- First, we check it belongs to `t0`.
    have : y ∈ t0 := mem_Inter.2 (λk, mem_closure_of_tendsto y_lim
    begin
      simp only [exists_prop, set.mem_Union, filter.eventually_at_top, set.mem_preimage,
        set.preimage_Union],
      exact ⟨k, λ m hm, ⟨n+m, zero_add k ▸ add_le_add (zero_le n) hm, (z m).2⟩⟩
    end),
    use this,
    -- Then, we check that `y` is close to `x = z n`. This follows from the fact that `y`
    -- is the limit of `z k`, and the distance between `z n` and `z k` has already been estimated.
    rw [← hz₀],
    exact edist_le_of_edist_le_geometric_two_of_tendsto₀ (B n) hz y_lim },
  have I2 : ∀ n, ∀ x ∈ t0, ∃ y ∈ s n, edist x y ≤ 2 * B n,
  { /- For the (much easier) reverse inequality, we start from a point `x ∈ t0` and we want
        to find a point `y ∈ s n` which is close to `x`.
        `x` belongs to `t0`, the intersection of the closures. In particular, it is well
        approximated by a point `z` in `⋃m≥n, s m`, say in `s m`. Since `s m` and
        `s n` are close, this point is itself well approximated by a point `y` in `s n`,
        as required. -/
    assume n x xt0,
    have : x ∈ closure (⋃ m ≥ n, s m : set α), by apply mem_Inter.1 xt0 n,
    rcases mem_closure_iff.1 this (B n) (B_pos n) with ⟨z, hz, Dxz⟩,
    -- z : α,  Dxz : edist x z < B n,
    simp only [exists_prop, set.mem_Union] at hz,
    rcases hz with ⟨m, ⟨m_ge_n, hm⟩⟩,
    -- m : ℕ, m_ge_n : m ≥ n, hm : z ∈ s m
    have : Hausdorff_edist (s m : set α) (s n) < B n := hs n m n m_ge_n (le_refl n),
    rcases exists_edist_lt_of_Hausdorff_edist_lt hm this with ⟨y, hy, Dzy⟩,
    -- y : α,  hy : y ∈ s n,  Dzy : edist z y < B n
    exact ⟨y, hy, calc
      edist x y ≤ edist x z + edist z y : edist_triangle _ _ _
            ... ≤ B n + B n : add_le_add (le_of_lt Dxz) (le_of_lt Dzy)
            ... = 2 * B n : (two_mul _).symm ⟩ },
  -- Deduce from the above inequalities that the distance between `s n` and `t0` is at most `2 B n`.
  have main : ∀n:ℕ, edist (s n) t ≤ 2 * B n := λn, Hausdorff_edist_le_of_mem_edist (I1 n) (I2 n),
  -- from this, the convergence of `s n` to `t0` follows.
  refine tendsto_at_top.2 (λε εpos, _),
  have : tendsto (λn, 2 * B n) at_top (𝓝 (2 * 0)),
    from ennreal.tendsto.const_mul
      (ennreal.tendsto_pow_at_top_nhds_0_of_lt_1 $ by simp [ennreal.one_lt_two])
      (or.inr $ by simp),
  rw mul_zero at this,
  obtain ⟨N, hN⟩ : ∃ N, ∀ b ≥ N, ε > 2 * B b,
    from ((tendsto_order.1 this).2 ε εpos).exists_forall_of_at_top,
  exact ⟨N, λn hn, lt_of_le_of_lt (main n) (hN n hn)⟩
end

/-- In a compact space, the type of closed subsets is compact. -/
instance closeds.compact_space [compact_space α] : compact_space (closeds α) :=
⟨begin
  /- by completeness, it suffices to show that it is totally bounded,
    i.e., for all ε>0, there is a finite set which is ε-dense.
    start from a set `s` which is ε-dense in α. Then the subsets of `s`
    are finitely many, and ε-dense for the Hausdorff distance. -/
  refine compact_of_totally_bounded_is_closed (emetric.totally_bounded_iff.2 (λε εpos, _))
    is_closed_univ,
  rcases exists_between εpos with ⟨δ, δpos, δlt⟩,
  rcases emetric.totally_bounded_iff.1
    (compact_iff_totally_bounded_complete.1 (@compact_univ α _ _)).1 δ δpos with ⟨s, fs, hs⟩,
  -- s : set α,  fs : finite s,  hs : univ ⊆ ⋃ (y : α) (H : y ∈ s), eball y δ
  -- we first show that any set is well approximated by a subset of `s`.
  have main : ∀ u : set α, ∃v ⊆ s, Hausdorff_edist u v ≤ δ,
  { assume u,
    let v := {x : α | x ∈ s ∧ ∃y∈u, edist x y < δ},
    existsi [v, ((λx hx, hx.1) : v ⊆ s)],
    refine Hausdorff_edist_le_of_mem_edist _ _,
    { assume x hx,
      have : x ∈ ⋃y ∈ s, ball y δ := hs (by simp),
      rcases mem_Union₂.1 this with ⟨y, ys, dy⟩,
      have : edist y x < δ := by simp at dy; rwa [edist_comm] at dy,
      exact ⟨y, ⟨ys, ⟨x, hx, this⟩⟩, le_of_lt dy⟩ },
    { rintros x ⟨hx1, ⟨y, yu, hy⟩⟩,
      exact ⟨y, yu, le_of_lt hy⟩ }},
  -- introduce the set F of all subsets of `s` (seen as members of `closeds α`).
  let F := {f : closeds α | (f : set α) ⊆ s},
  refine ⟨F, _, λ u _, _⟩,
  -- `F` is finite
  { apply @finite_of_finite_image _ _ F coe,
    { exact set_like.coe_injective.inj_on F },
    { refine fs.finite_subsets.subset (λb, _),
      simp only [and_imp, set.mem_image, set.mem_set_of_eq, exists_imp_distrib],
      assume x hx hx',
      rwa hx' at hx }},
  -- `F` is ε-dense
  { obtain ⟨t0, t0s, Dut0⟩ := main u,
    have : is_closed t0 := (fs.subset t0s).is_compact.is_closed,
    let t : closeds α := ⟨t0, this⟩,
    have : t ∈ F := t0s,
    have : edist u t < ε := lt_of_le_of_lt Dut0 δlt,
    apply mem_Union₂.2,
    exact ⟨t, ‹t ∈ F›, this⟩ }
end⟩

/-- In an emetric space, the type of non-empty compact subsets is an emetric space,
where the edistance is the Hausdorff edistance -/
instance nonempty_compacts.emetric_space : emetric_space (nonempty_compacts α) :=
{ edist               := λ s t, Hausdorff_edist (s : set α) t,
  edist_self          := λs, Hausdorff_edist_self,
  edist_comm          := λs t, Hausdorff_edist_comm,
  edist_triangle      := λs t u, Hausdorff_edist_triangle,
  eq_of_edist_eq_zero := λ s t h, nonempty_compacts.ext $ begin
    have : closure (s : set α) = closure t := Hausdorff_edist_zero_iff_closure_eq_closure.1 h,
    rwa [s.compact.is_closed.closure_eq, t.compact.is_closed.closure_eq] at this,
  end }

/-- `nonempty_compacts.to_closeds` is a uniform embedding (as it is an isometry) -/
lemma nonempty_compacts.to_closeds.uniform_embedding :
  uniform_embedding (@nonempty_compacts.to_closeds α _ _) :=
isometry.uniform_embedding $ λx y, rfl

/-- The range of `nonempty_compacts.to_closeds` is closed in a complete space -/
lemma nonempty_compacts.is_closed_in_closeds [complete_space α] :
  is_closed (range $ @nonempty_compacts.to_closeds α _ _) :=
begin
  have : range nonempty_compacts.to_closeds =
    {s : closeds α | (s : set α).nonempty ∧ is_compact (s : set α) },
  { ext s,
    refine ⟨_, λ h, ⟨⟨⟨s, h.2⟩, h.1⟩, closeds.ext rfl⟩⟩,
    rintro ⟨s, hs, rfl⟩,
    exact ⟨s.nonempty, s.compact⟩ },
  rw this,
  refine is_closed_of_closure_subset (λs hs, ⟨_, _⟩),
  { -- take a set set t which is nonempty and at a finite distance of s
    rcases mem_closure_iff.1 hs ⊤ ennreal.coe_lt_top with ⟨t, ht, Dst⟩,
    rw edist_comm at Dst,
    -- since `t` is nonempty, so is `s`
    exact nonempty_of_Hausdorff_edist_ne_top ht.1 (ne_of_lt Dst) },
  { refine compact_iff_totally_bounded_complete.2 ⟨_, s.closed.is_complete⟩,
    refine totally_bounded_iff.2 (λε (εpos : 0 < ε), _),
    -- we have to show that s is covered by finitely many eballs of radius ε
    -- pick a nonempty compact set t at distance at most ε/2 of s
    rcases mem_closure_iff.1 hs (ε/2) (ennreal.half_pos εpos.ne') with ⟨t, ht, Dst⟩,
    -- cover this space with finitely many balls of radius ε/2
    rcases totally_bounded_iff.1 (compact_iff_totally_bounded_complete.1 ht.2).1 (ε/2)
      (ennreal.half_pos εpos.ne') with ⟨u, fu, ut⟩,
    refine ⟨u, ⟨fu, λx hx, _⟩⟩,
    -- u : set α,  fu : finite u,  ut : t ⊆ ⋃ (y : α) (H : y ∈ u), eball y (ε / 2)
    -- then s is covered by the union of the balls centered at u of radius ε
    rcases exists_edist_lt_of_Hausdorff_edist_lt hx Dst with ⟨z, hz, Dxz⟩,
    rcases mem_Union₂.1 (ut hz) with ⟨y, hy, Dzy⟩,
    have : edist x y < ε := calc
      edist x y ≤ edist x z + edist z y : edist_triangle _ _ _
      ... < ε/2 + ε/2 : ennreal.add_lt_add Dxz Dzy
      ... = ε : ennreal.add_halves _,
    exact mem_bUnion hy this },
end

/-- In a complete space, the type of nonempty compact subsets is complete. This follows
from the same statement for closed subsets -/
instance nonempty_compacts.complete_space [complete_space α] :
  complete_space (nonempty_compacts α) :=
(complete_space_iff_is_complete_range
  nonempty_compacts.to_closeds.uniform_embedding.to_uniform_inducing).2 $
  nonempty_compacts.is_closed_in_closeds.is_complete

/-- In a compact space, the type of nonempty compact subsets is compact. This follows from
the same statement for closed subsets -/
instance nonempty_compacts.compact_space [compact_space α] : compact_space (nonempty_compacts α) :=
⟨begin
  rw nonempty_compacts.to_closeds.uniform_embedding.embedding.is_compact_iff_is_compact_image,
  rw [image_univ],
  exact nonempty_compacts.is_closed_in_closeds.is_compact
end⟩

/-- In a second countable space, the type of nonempty compact subsets is second countable -/
instance nonempty_compacts.second_countable_topology [second_countable_topology α] :
  second_countable_topology (nonempty_compacts α) :=
begin
  haveI : separable_space (nonempty_compacts α) :=
  begin
    /- To obtain a countable dense subset of `nonempty_compacts α`, start from
    a countable dense subset `s` of α, and then consider all its finite nonempty subsets.
    This set is countable and made of nonempty compact sets. It turns out to be dense:
    by total boundedness, any compact set `t` can be covered by finitely many small balls, and
    approximations in `s` of the centers of these balls give the required finite approximation
    of `t`. -/
    rcases exists_countable_dense α with ⟨s, cs, s_dense⟩,
    let v0 := {t : set α | finite t ∧ t ⊆ s},
    let v : set (nonempty_compacts α) := {t : nonempty_compacts α | (t : set α) ∈ v0},
    refine  ⟨⟨v, _, _⟩⟩,
    { have : countable v0, from countable_set_of_finite_subset cs,
      exact this.preimage set_like.coe_injective },
    { refine λt, mem_closure_iff.2 (λε εpos, _),
      -- t is a compact nonempty set, that we have to approximate uniformly by a a set in `v`.
      rcases exists_between εpos with ⟨δ, δpos, δlt⟩,
      have δpos' : 0 < δ / 2, from ennreal.half_pos δpos.ne',
      -- construct a map F associating to a point in α an approximating point in s, up to δ/2.
      have Exy : ∀x, ∃y, y ∈ s ∧ edist x y < δ/2,
      { assume x,
        rcases mem_closure_iff.1 (s_dense x) (δ/2) δpos' with ⟨y, ys, hy⟩,
        exact ⟨y, ⟨ys, hy⟩⟩ },
      let F := λx, some (Exy x),
      have Fspec : ∀x, F x ∈ s ∧ edist x (F x) < δ/2 := λx, some_spec (Exy x),

      -- cover `t` with finitely many balls. Their centers form a set `a`
      have : totally_bounded (t : set α) := t.compact.totally_bounded,
      rcases totally_bounded_iff.1 this (δ/2) δpos' with ⟨a, af, ta⟩,
      -- a : set α,  af : finite a,  ta : t ⊆ ⋃ (y : α) (H : y ∈ a), eball y (δ / 2)
      -- replace each center by a nearby approximation in `s`, giving a new set `b`
      let b := F '' a,
      have : finite b := af.image _,
      have tb : ∀ x ∈ t, ∃ y ∈ b, edist x y < δ,
      { assume x hx,
        rcases mem_Union₂.1 (ta hx) with ⟨z, za, Dxz⟩,
        existsi [F z, mem_image_of_mem _ za],
        calc edist x (F z) ≤ edist x z + edist z (F z) : edist_triangle _ _ _
             ... < δ/2 + δ/2 : ennreal.add_lt_add Dxz (Fspec z).2
             ... = δ : ennreal.add_halves _ },
      -- keep only the points in `b` that are close to point in `t`, yielding a new set `c`
      let c := {y ∈ b | ∃ x ∈ t, edist x y < δ},
      have : finite c := ‹finite b›.subset (λx hx, hx.1),
      -- points in `t` are well approximated by points in `c`
      have tc : ∀ x ∈ t, ∃ y ∈ c, edist x y ≤ δ,
      { assume x hx,
        rcases tb x hx with ⟨y, yv, Dxy⟩,
        have : y ∈ c := by simp [c, -mem_image]; exact ⟨yv, ⟨x, hx, Dxy⟩⟩,
        exact ⟨y, this, le_of_lt Dxy⟩ },
      -- points in `c` are well approximated by points in `t`
      have ct : ∀ y ∈ c, ∃ x ∈ t, edist y x ≤ δ,
      { rintro y ⟨hy1, x, xt, Dyx⟩,
        have : edist y x ≤ δ := calc
          edist y x = edist x y : edist_comm _ _
          ... ≤ δ : le_of_lt Dyx,
        exact ⟨x, xt, this⟩ },
      -- it follows that their Hausdorff distance is small
      have : Hausdorff_edist (t :set α) c ≤ δ :=
        Hausdorff_edist_le_of_mem_edist tc ct,
      have Dtc : Hausdorff_edist (t : set α) c < ε := this.trans_lt δlt,
      -- the set `c` is not empty, as it is well approximated by a nonempty set
      have hc : c.nonempty,
        from nonempty_of_Hausdorff_edist_ne_top t.nonempty (ne_top_of_lt Dtc),
      -- let `d` be the version of `c` in the type `nonempty_compacts α`
      let d : nonempty_compacts α := ⟨⟨c, ‹finite c›.is_compact⟩, hc⟩,
      have : c ⊆ s,
      { assume x hx,
        rcases (mem_image _ _ _).1 hx.1 with ⟨y, ⟨ya, yx⟩⟩,
        rw ← yx,
        exact (Fspec y).1 },
      have : d ∈ v := ⟨‹finite c›, this⟩,
      -- we have proved that `d` is a good approximation of `t` as requested
      exact ⟨d, ‹d ∈ v›, Dtc⟩ },
  end,
  apply uniform_space.second_countable_of_separable,
end

end --section
end emetric --namespace

namespace metric
section

variables {α : Type u} [metric_space α]

/-- `nonempty_compacts α` inherits a metric space structure, as the Hausdorff
edistance between two such sets is finite. -/
instance nonempty_compacts.metric_space : metric_space (nonempty_compacts α) :=
emetric_space.to_metric_space $ λ x y, Hausdorff_edist_ne_top_of_nonempty_of_bounded
  x.nonempty y.nonempty x.compact.bounded y.compact.bounded

/-- The distance on `nonempty_compacts α` is the Hausdorff distance, by construction -/
lemma nonempty_compacts.dist_eq {x y : nonempty_compacts α} :
  dist x y = Hausdorff_dist (x : set α) y := rfl

lemma lipschitz_inf_dist_set (x : α) : lipschitz_with 1 (λ s : nonempty_compacts α, inf_dist x s) :=
lipschitz_with.of_le_add $ assume s t,
by { rw dist_comm,
  exact inf_dist_le_inf_dist_add_Hausdorff_dist (edist_ne_top t s) }

lemma uniform_continuous_inf_dist_Hausdorff_dist :
  uniform_continuous (λ p : α × (nonempty_compacts α), inf_dist p.1 p.2) :=
lipschitz_inf_dist.uniform_continuous

end --section
end metric --namespace


/-
Copyright (c) 2022 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.clifford_algebra.fold
import linear_algebra.clifford_algebra.grading

/-!
# The universal property of the even subalgebra

## Main definitions

* `clifford_algebra.even Q`: The even subalgebra of `clifford_algebra Q`.
* `clifford_algebra.even_hom`: The type of bilinear maps that satisfy the universal property of the
  even subalgebra
* `clifford_algebra.even.lift`: The universal property of the even subalgebra, which states
  that every bilinear map `f` with `f v v = Q v` and `f u v * f v w = Q v • f u w` is in unique
  correspondence with an algebra morphism from `clifford_algebra.even Q`.

## Implementation notes

The approach here is outlined in "Computing with the universal properties of the Clifford algebra
and the even subalgebra" (to appear).

The broad summary is that we have two tricks available to us for implementing complex recursors on
top of `clifford_algebra.lift`: the first is to use morphisms as the output type, such as
`A = module.End R N` which is how we obtained `clifford_algebra.foldr`; and the second is to use
`N = (N', S)` where `N'` is the value we wish to compute, and `S` is some auxiliary state passed
between one recursor invocation and the next.
For the universal property of the even subalgebra, we apply a variant of the first trick again by
choosing `S` to itself be a submodule of morphisms.
-/

namespace clifford_algebra

variables {R M : Type*} [comm_ring R] [add_comm_group M] [module R M]
variables {Q : quadratic_form R M}
-- put this after `Q` since we want to talk about morphisms from `clifford_algebra Q` to `A` and
-- that order is more natural
variables {A B : Type*} [ring A] [ring B] [algebra R A] [algebra R B]

open_locale direct_sum

variables (Q)

/-- The even submodule `clifford_algebra.even_odd Q 0` is also a subalgebra. -/
def even : subalgebra R (clifford_algebra Q) :=
(even_odd Q 0).to_subalgebra
  set_like.graded_monoid.one_mem
  (λ x y hx hy, add_zero (0 : zmod 2) ▸ set_like.graded_monoid.mul_mem hx hy)

@[simp] lemma even_to_submodule : (even Q).to_submodule = even_odd Q 0 :=
rfl

variables (A)

/-- The type of bilinear maps which are accepted by `clifford_algebra.even.lift`. -/
@[ext]
structure even_hom : Type (max u_2 u_3) :=
(bilin : M →ₗ[R] M →ₗ[R] A)
(contract (m : M) : bilin m m = algebra_map R A (Q m))
(contract_mid (m₁ m₂ m₃ : M) : bilin m₁ m₂ * bilin m₂ m₃ = Q m₂ • bilin m₁ m₃)

variables {A Q}

/-- Compose an `even_hom` with an `alg_hom` on the output. -/
@[simps]
def even_hom.compr₂ (g : even_hom Q A) (f : A →ₐ[R] B) : even_hom Q B :=
{ bilin := g.bilin.compr₂ f.to_linear_map,
  contract := λ m, (f.congr_arg $ g.contract _).trans $ f.commutes _,
  contract_mid := λ m₁ m₂ m₃, (f.map_mul _ _).symm.trans $
    (f.congr_arg $ g.contract_mid _ _ _).trans $ f.map_smul _ _ }

variables (Q)

/-- The embedding of pairs of vectors into the even subalgebra, as a bilinear map. -/
@[simps bilin_apply_apply_coe]
def even.ι : even_hom Q (even Q) :=
{ bilin := linear_map.mk₂ R (λ m₁ m₂, ⟨ι Q m₁ * ι Q m₂, ι_mul_ι_mem_even_odd_zero _ _ _⟩)
             (λ _ _ _, by { simp only [linear_map.map_add, add_mul], refl })
             (λ _ _ _, by { simp only [linear_map.map_smul, smul_mul_assoc], refl })
             (λ _ _ _, by { simp only [linear_map.map_add, mul_add], refl })
             (λ _ _ _, by { simp only [linear_map.map_smul, mul_smul_comm], refl }),
  contract := λ m, subtype.ext $ ι_sq_scalar Q m,
  contract_mid := λ m₁ m₂ m₃, subtype.ext $
    calc  ι Q m₁ * ι Q m₂ * (ι Q m₂ * ι Q m₃)
        = ι Q m₁ * ((ι Q m₂ * ι Q m₂) * ι Q m₃) : by simp only [mul_assoc]
    ... = Q m₂ • (ι Q m₁ * ι Q m₃) : by rw [algebra.smul_def, ι_sq_scalar, algebra.left_comm] }

instance : inhabited (even_hom Q (even Q)) := ⟨even.ι Q⟩

variables (f : even_hom Q A)

/-- Two algebra morphisms from the even subalgebra are equal if they agree on pairs of generators.

See note [partially-applied ext lemmas]. -/
@[ext]

variables {Q}

namespace even.lift

/-- An auxiliary submodule used to store the half-applied values of `f`.
This is the span of elements `f'` such that `∃ x m₂, ∀ m₁, f' m₁ = f m₁ m₂ * x`.  -/
private def S : submodule R (M →ₗ[R] A) :=
submodule.span R
  {f' | ∃ x m₂, f' = linear_map.lcomp R _ (f.bilin.flip m₂) (linear_map.mul_right R x)}

/-- An auxiliary bilinear map that is later passed into `clifford_algebra.fold`. Our desired result
is stored in the `A` part of the accumulator, while auxiliary recursion state is stored in the `S f`
part. -/
private def f_fold : M →ₗ[R] (A × S f) →ₗ[R] (A × S f) :=
linear_map.mk₂ R (λ m acc,
  /- We could write this `snd` term in a point-free style as follows, but it wouldn't help as we
  don't have any prod or subtype combinators to deal with n-linear maps of this degree.
  ```lean
  (linear_map.lcomp R _ (algebra.lmul R A).to_linear_map.flip).comp $
    (linear_map.llcomp R M A A).flip.comp f.flip : M →ₗ[R] A →ₗ[R] M →ₗ[R] A)
  ```
  -/
  (acc.2 m, ⟨(linear_map.mul_right R acc.1).comp (f.bilin.flip m),
    submodule.subset_span $ ⟨_, _, rfl⟩⟩))
  (λ m₁ m₂ a, prod.ext
    (linear_map.map_add _ m₁ m₂)
    (subtype.ext $ linear_map.ext $ λ m₃,
      show f.bilin m₃ (m₁ + m₂) * a.1 = f.bilin m₃ m₁ * a.1 + f.bilin m₃ m₂ * a.1,
      by rw [map_add, add_mul]))
  (λ c m a, prod.ext
    (linear_map.map_smul _ c m)
    (subtype.ext $ linear_map.ext $ λ m₃,
      show f.bilin m₃ (c • m) * a.1 = c • (f.bilin m₃ m * a.1),
      by rw [linear_map.map_smul, smul_mul_assoc]))
  (λ m a₁ a₂, prod.ext rfl (subtype.ext $ linear_map.ext $ λ m₃, mul_add _ _ _))
  (λ c m a, prod.ext rfl (subtype.ext $ linear_map.ext $ λ m₃, mul_smul_comm _ _ _))

@[simp] private lemma fst_f_fold_f_fold (m₁ m₂ : M) (x : A × S f) :
  (f_fold f m₁ (f_fold f m₂ x)).fst = f.bilin m₁ m₂ * x.fst := rfl

@[simp] private lemma snd_f_fold_f_fold (m₁ m₂ m₃ : M) (x : A × S f) :
  ((f_fold f m₁ (f_fold f m₂ x)).snd : M →ₗ[R] A) m₃ = f.bilin m₃ m₁ * (x.snd : M →ₗ[R] A) m₂ := rfl

private lemma f_fold_f_fold (m : M) (x : A × S f) :
  f_fold f m (f_fold f m x) = Q m • x :=
begin
  obtain ⟨a, ⟨g, hg⟩⟩ := x,
  ext : 2,
  { change f.bilin m m * a = Q m • a,
    rw [algebra.smul_def, f.contract] },
  { ext m₁,
    change f.bilin _ _ * g m = Q m • g m₁,
    apply submodule.span_induction' _ _ _ _ hg,
    { rintros _ ⟨b, m₃, rfl⟩,
      change f.bilin _ _ * (f.bilin _ _ * b) = Q m • (f.bilin _ _ * b),
      rw [←smul_mul_assoc, ←mul_assoc, f.contract_mid] },
    { change f.bilin m₁ m * 0 = Q m • 0,
      rw [mul_zero, smul_zero] },
    { rintros x hx y hy ihx ihy,
      rw [linear_map.add_apply, linear_map.add_apply, mul_add, smul_add, ihx, ihy] },
    { rintros x hx c ihx,
      rw [linear_map.smul_apply, linear_map.smul_apply, mul_smul_comm, ihx, smul_comm] } },
end

/-- The final auxiliary construction for `clifford_algebra.even.lift`. This map is the forwards
direction of that equivalence, but not in the fully-bundled form. -/
@[simps apply {attrs := []}] def aux (f : even_hom Q A) : clifford_algebra.even Q →ₗ[R] A :=
begin
  refine _ ∘ₗ (even Q).val.to_linear_map,
  exact linear_map.fst _ _ _ ∘ₗ foldr Q (f_fold f) (f_fold_f_fold f) (1, 0),
end

@[simp] lemma aux_one : aux f 1 = 1 :=
(congr_arg prod.fst (foldr_one _ _ _ _))

@[simp] lemma aux_ι (m₁ m₂ : M) : aux f ((even.ι Q).bilin m₁ m₂) = f.bilin m₁ m₂ :=
(congr_arg prod.fst (foldr_mul _ _ _ _ _ _)).trans begin
  rw [foldr_ι, foldr_ι],
  exact mul_one _,
end

@[simp] lemma aux_algebra_map (r) (hr) :
  aux f ⟨algebra_map R _ r, hr⟩ = algebra_map R _ r :=
(congr_arg prod.fst (foldr_algebra_map _ _ _ _ _)).trans (algebra.algebra_map_eq_smul_one r).symm

@[simp] lemma aux_mul (x y : even Q) :
  aux f (x * y) = aux f x * aux f y :=
begin
  cases x,
  cases y,
  refine (congr_arg prod.fst (foldr_mul _ _ _ _ _ _)).trans _,
  dsimp only,
  refine even_induction Q _ _ _ _ x_property,
  { intros r,
    rw [foldr_algebra_map, aux_algebra_map],
    exact (algebra.smul_def r _), },
  { intros x y hx hy ihx ihy,
    rw [linear_map.map_add, prod.fst_add, ihx, ihy, ←add_mul, ←linear_map.map_add],
    refl, },
  { rintros m₁ m₂ x (hx : x ∈ even Q) ih,
    rw [aux_apply, foldr_mul, foldr_mul, foldr_ι, foldr_ι, fst_f_fold_f_fold, ih,
      ←mul_assoc, subtype.coe_mk, foldr_mul, foldr_mul, foldr_ι, foldr_ι, fst_f_fold_f_fold],
      refl }
end

end even.lift

open even.lift

variables (Q) {A}

/-- Every algebra morphism from the even subalgebra is in one-to-one correspondence with a
bilinear map that sends duplicate arguments to the quadratic form, and contracts across
multiplication. -/
@[simps symm_apply_bilin]
def even.lift : even_hom Q A ≃ (clifford_algebra.even Q →ₐ[R] A) :=
{ to_fun := λ f, alg_hom.of_linear_map (aux f) (aux_one f) (aux_mul f),
  inv_fun := λ F, (even.ι Q).compr₂ F,
  left_inv := λ f, even_hom.ext _ _ $ linear_map.ext₂ $ even.lift.aux_ι f,
  right_inv := λ F, even.alg_hom_ext Q $ even_hom.ext _ _ $ linear_map.ext₂ $ even.lift.aux_ι _ }

@[simp] lemma even.lift_ι (f : even_hom Q A) (m₁ m₂ : M) :
  even.lift Q f ((even.ι Q).bilin m₁ m₂) = f.bilin m₁ m₂ :=
even.lift.aux_ι _ _ _

end clifford_algebra


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

! This file was ported from Lean 3 source module ring_theory.coprime.ideal
! leanprover-community/mathlib commit 2bbc7e3884ba234309d2a43b19144105a753292e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.LinearAlgebra.Dfinsupp
import Mathlib.RingTheory.Ideal.Operations

/-!
# An additional lemma about coprime ideals

This lemma generalises `exists_sum_eq_one_iff_pairwise_coprime` to the case of non-principal ideals.
It is on a separate file due to import requirements.
-/

namespace Ideal

variable {ι R : Type _} [CommSemiring R]

/-- A finite family of ideals is pairwise coprime (that is, any two of them generate the whole ring)
iff when taking all the possible intersections of all but one of these ideals, the resulting family
of ideals still generate the whole ring.

For example with three ideals : `I ⊔ J = I ⊔ K = J ⊔ K = ⊤ ↔ (I ⊓ J) ⊔ (I ⊓ K) ⊔ (J ⊓ K) = ⊤`.

When ideals are all of the form `I i = R ∙ s i`, this is equivalent to the
`exists_sum_eq_one_iff_pairwise_coprime` lemma.-/
theorem supᵢ_infᵢ_eq_top_iff_pairwise {t : Finset ι} (h : t.Nonempty) (I : ι → Ideal R) :
    (⨆ i ∈ t, ⨅ (j) (_hj : j ∈ t) (_ij : j ≠ i), I j) = ⊤ ↔
      (t : Set ι).Pairwise fun i j => I i ⊔ I j = ⊤ := by
  haveI : DecidableEq ι := Classical.decEq ι
  rw [eq_top_iff_one, Submodule.mem_supᵢ_finset_iff_exists_sum]
  refine' h.cons_induction _ _ <;> clear t h
  · simp only [Finset.sum_singleton, Finset.coe_singleton, Set.pairwise_singleton, iff_true_iff]
    refine' fun a => ⟨fun i => if h : i = a then ⟨1, _⟩ else 0, _⟩
    · simp [h]
    · simp only [dif_pos, dif_ctx_congr, Submodule.coe_mk, eq_self_iff_true]
  intro a t hat h ih
  rw [Finset.coe_cons,
    Set.pairwise_insert_of_symmetric fun i j (h : I i ⊔ I j = ⊤) => sup_comm.trans h]
  constructor
  · rintro ⟨μ, hμ⟩
    rw [Finset.sum_cons] at hμ
    -- Porting note: `refine` yields goals in a different order than in lean3.
    refine ⟨ih.mp ⟨Pi.single h.choose ⟨μ a, ?a1⟩ + fun i => ⟨μ i, ?a2⟩, ?a3⟩, fun b hb ab => ?a4⟩
    case a1 =>
      have := Submodule.coe_mem (μ a)
      rw [mem_infᵢ] at this ⊢
      --for some reason `simp only [mem_infᵢ]` times out
      intro i
      specialize this i
      rw [mem_infᵢ, mem_infᵢ] at this ⊢
      intro hi _
      apply this (Finset.subset_cons _ hi)
      rintro rfl
      exact hat hi
    case a2 =>
      have := Submodule.coe_mem (μ i)
      simp only [mem_infᵢ] at this ⊢
      intro j hj ij
      exact this _ (Finset.subset_cons _ hj) ij
    case a3 =>
      rw [← @if_pos _ _ h.choose_spec R (μ a) 0, ← Finset.sum_pi_single', ← Finset.sum_add_distrib]
        at hμ
      convert hμ
      rename_i i _
      rw [Pi.add_apply, Submodule.coe_add, Submodule.coe_mk]
      by_cases hi : i = h.choose
      · rw [hi, Pi.single_eq_same, Pi.single_eq_same, Submodule.coe_mk]
      · rw [Pi.single_eq_of_ne hi, Pi.single_eq_of_ne hi, Submodule.coe_zero]
    case a4 =>
      rw [eq_top_iff_one, Submodule.mem_sup]
      rw [add_comm] at hμ
      refine' ⟨_, _, _, _, hμ⟩
      · refine' sum_mem _ fun x hx => _
        have := Submodule.coe_mem (μ x)
        simp only [mem_infᵢ] at this
        apply this _ (Finset.mem_cons_self _ _)
        rintro rfl
        exact hat hx
      · have := Submodule.coe_mem (μ a)
        simp only [mem_infᵢ] at this
        exact this _ (Finset.subset_cons _ hb) ab.symm
  · rintro ⟨hs, Hb⟩
    obtain ⟨μ, hμ⟩ := ih.mpr hs
    have := sup_infᵢ_eq_top fun b hb => Hb b hb (ne_of_mem_of_not_mem hb hat).symm
    rw [eq_top_iff_one, Submodule.mem_sup] at this
    obtain ⟨u, hu, v, hv, huv⟩ := this
    refine' ⟨fun i => if hi : i = a then ⟨v, _⟩ else ⟨u * μ i, _⟩, _⟩
    · simp only [mem_infᵢ] at hv⊢
      intro j hj ij
      rw [Finset.mem_cons, ← hi] at hj
      exact hv _ (hj.resolve_left ij)
    · have := Submodule.coe_mem (μ i)
      simp only [mem_infᵢ] at this⊢
      intro j hj ij
      rcases Finset.mem_cons.mp hj with (rfl | hj)
      · exact mul_mem_right _ _ hu
      · exact mul_mem_left _ _ (this _ hj ij)
    · dsimp only
      rw [Finset.sum_cons, dif_pos rfl, add_comm]
      rw [← mul_one u] at huv
      rw [← huv, ← hμ, Finset.mul_sum]
      congr 1
      apply Finset.sum_congr rfl
      intro j hj
      rw [dif_neg]
      rintro rfl
      exact hat hj
#align ideal.supr_infi_eq_top_iff_pairwise Ideal.supᵢ_infᵢ_eq_top_iff_pairwise

end Ideal


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

! This file was ported from Lean 3 source module category_theory.sigma.basic
! leanprover-community/mathlib commit ba2245edf0c8bb155f1569fd9b9492a9b384cde6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Whiskering
import Mathlib.CategoryTheory.Functor.FullyFaithful
import Mathlib.CategoryTheory.NatIso

/-!
# Disjoint union of categories

We define the category structure on a sigma-type (disjoint union) of categories.
-/

namespace CategoryTheory

namespace Sigma

universe w₁ w₂ w₃ v₁ v₂ u₁ u₂

variable {I : Type w₁} {C : I → Type u₁} [∀ i, Category.{v₁} (C i)]

/-- The type of morphisms of a disjoint union of categories: for `X : C i` and `Y : C j`, a morphism
`(i, X) ⟶ (j, Y)` if `i = j` is just a morphism `X ⟶ Y`, and if `i ≠ j` there are no such morphisms.
-/
inductive SigmaHom : (Σi, C i) → (Σi, C i) → Type max w₁ v₁ u₁
  | mk : ∀ {i : I} {X Y : C i}, (X ⟶ Y) → SigmaHom ⟨i, X⟩ ⟨i, Y⟩
#align category_theory.sigma.sigma_hom CategoryTheory.Sigma.SigmaHom

namespace SigmaHom

/-- The identity morphism on an object. -/
def id : ∀ X : Σi, C i, SigmaHom X X
  | ⟨_, _⟩ => mk (𝟙 _)
-- Porting note: reordered universes
#align category_theory.sigma.sigma_hom.id CategoryTheory.Sigma.SigmaHom.idₓ

instance (X : Σi, C i) : Inhabited (SigmaHom X X) :=
  ⟨id X⟩

/-- Composition of sigma homomorphisms. -/
def comp : ∀ {X Y Z : Σi, C i}, SigmaHom X Y → SigmaHom Y Z → SigmaHom X Z
  | _, _, _, mk f, mk g => mk (f ≫ g)
-- Porting note: reordered universes
#align category_theory.sigma.sigma_hom.comp CategoryTheory.Sigma.SigmaHom.compₓ

instance : CategoryStruct (Σi, C i) where
  Hom := SigmaHom
  id := id
  comp f g := comp f g

@[simp]
lemma comp_def (i : I) (X Y Z : C i) (f : X ⟶ Y) (g : Y ⟶ Z) : comp (mk f) (mk g) = mk (f ≫ g) :=
  rfl
#align category_theory.sigma.sigma_hom.comp_def CategoryTheory.Sigma.SigmaHom.comp_def

lemma assoc
  : ∀ {X Y Z W : Σi, C i} (f : X ⟶ Y) (g : Y ⟶ Z) (h : Z ⟶ W), (f ≫ g) ≫ h = f ≫ g ≫ h
  | _, _, _, _, mk _, mk _, mk _ => congr_arg mk (Category.assoc _ _ _)
#align category_theory.sigma.sigma_hom.assoc CategoryTheory.Sigma.SigmaHom.assoc

lemma id_comp : ∀ {X Y : Σi, C i} (f : X ⟶ Y), 𝟙 X ≫ f = f
  | _, _, mk _ => congr_arg mk (Category.id_comp _)
#align category_theory.sigma.sigma_hom.id_comp CategoryTheory.Sigma.SigmaHom.id_comp

lemma comp_id : ∀ {X Y : Σi, C i} (f : X ⟶ Y), f ≫ 𝟙 Y = f
  | _, _, mk _ => congr_arg mk (Category.comp_id _)
#align category_theory.sigma.sigma_hom.comp_id CategoryTheory.Sigma.SigmaHom.comp_id

end SigmaHom

instance sigma : Category (Σi, C i) where
  id_comp := SigmaHom.id_comp
  comp_id := SigmaHom.comp_id
  assoc := SigmaHom.assoc
#align category_theory.sigma.sigma CategoryTheory.Sigma.sigma

/-- The inclusion functor into the disjoint union of categories. -/
@[simps map]
def incl (i : I) : C i ⥤ Σi, C i where
  obj X := ⟨i, X⟩
  map := SigmaHom.mk
#align category_theory.sigma.incl CategoryTheory.Sigma.incl

@[simp]
lemma incl_obj {i : I} (X : C i) : (incl i).obj X = ⟨i, X⟩ :=
  rfl
#align category_theory.sigma.incl_obj CategoryTheory.Sigma.incl_obj

instance (i : I) : Full (incl i : C i ⥤ Σi, C i) where
  preimage := fun ⟨f⟩ => f
  witness := fun ⟨_⟩ => rfl

instance (i : I) : Faithful (incl i : C i ⥤ Σi, C i) where
  -- Porting note: was `tidy`
  map_injective {_ _ _ _} h := by injection h

section

variable {D : Type u₂} [Category.{v₂} D] (F : ∀ i, C i ⥤ D)

/--
To build a natural transformation over the sigma category, it suffices to specify it restricted to
each subcategory.
-/
def natTrans {F G : (Σi, C i) ⥤ D} (h : ∀ i : I, incl i ⋙ F ⟶ incl i ⋙ G) : F ⟶ G where
  app := fun ⟨j, X⟩ => (h j).app X
  naturality := by
    rintro ⟨j, X⟩ ⟨_, _⟩ ⟨f⟩
    apply (h j).naturality
#align category_theory.sigma.nat_trans CategoryTheory.Sigma.natTrans

@[simp]
lemma natTrans_app {F G : (Σi, C i) ⥤ D} (h : ∀ i : I, incl i ⋙ F ⟶ incl i ⋙ G) (i : I)
    (X : C i) : (natTrans h).app ⟨i, X⟩ = (h i).app X :=
  rfl
#align category_theory.sigma.nat_trans_app CategoryTheory.Sigma.natTrans_app

/-- (Implementation). An auxiliary definition to build the functor `desc`. -/
def descMap : ∀ X Y : Σi, C i, (X ⟶ Y) → ((F X.1).obj X.2 ⟶ (F Y.1).obj Y.2)
  | _, _, SigmaHom.mk g => (F _).map g
-- Porting note: reordered universes
#align category_theory.sigma.desc_map CategoryTheory.Sigma.descMapₓ

/-- Given a collection of functors `F i : C i ⥤ D`, we can produce a functor `(Σ i, C i) ⥤ D`.

The produced functor `desc F` satisfies: `incl i ⋙ desc F ≅ F i`, i.e. restricted to just the
subcategory `C i`, `desc F` agrees with `F i`, and it is unique (up to natural isomorphism) with
this property.

This witnesses that the sigma-type is the coproduct in Cat.
-/
@[simps obj]
def desc : (Σi, C i) ⥤ D where
  obj X := (F X.1).obj X.2
  map g := descMap F _ _ g
  map_id := by
    rintro ⟨i, X⟩
    apply (F i).map_id
  map_comp := by
    rintro ⟨i, X⟩ ⟨_, Y⟩ ⟨_, Z⟩ ⟨f⟩ ⟨g⟩
    apply (F i).map_comp
#align category_theory.sigma.desc CategoryTheory.Sigma.desc

@[simp]
lemma desc_map_mk {i : I} (X Y : C i) (f : X ⟶ Y) : (desc F).map (SigmaHom.mk f) = (F i).map f :=
  rfl
#align category_theory.sigma.desc_map_mk CategoryTheory.Sigma.desc_map_mk

-- We hand-generate the simp lemmas about this since they come out cleaner.
/-- This shows that when `desc F` is restricted to just the subcategory `C i`, `desc F` agrees with
`F i`.
-/
def inclDesc (i : I) : incl i ⋙ desc F ≅ F i :=
  NatIso.ofComponents (fun X => Iso.refl _) (by aesop)
#align category_theory.sigma.incl_desc CategoryTheory.Sigma.inclDesc

@[simp]
lemma inclDesc_hom_app (i : I) (X : C i) : (inclDesc F i).hom.app X = 𝟙 ((F i).obj X) :=
  rfl
#align category_theory.sigma.incl_desc_hom_app CategoryTheory.Sigma.inclDesc_hom_app

@[simp]
lemma inclDesc_inv_app (i : I) (X : C i) : (inclDesc F i).inv.app X = 𝟙 ((F i).obj X) :=
  rfl
#align category_theory.sigma.incl_desc_inv_app CategoryTheory.Sigma.inclDesc_inv_app

/-- If `q` when restricted to each subcategory `C i` agrees with `F i`, then `q` is isomorphic to
`desc F`.
-/
def descUniq (q : (Σi, C i) ⥤ D) (h : ∀ i, incl i ⋙ q ≅ F i) : q ≅ desc F :=
  (NatIso.ofComponents fun ⟨i, X⟩ => (h i).app X) <| by
    rintro ⟨i, X⟩ ⟨_, _⟩ ⟨f⟩
    apply (h i).hom.naturality f
#align category_theory.sigma.desc_uniq CategoryTheory.Sigma.descUniq

@[simp]
lemma descUniq_hom_app (q : (Σi, C i) ⥤ D) (h : ∀ i, incl i ⋙ q ≅ F i) (i : I) (X : C i) :
    (descUniq F q h).hom.app ⟨i, X⟩ = (h i).hom.app X :=
  rfl
#align category_theory.sigma.desc_uniq_hom_app CategoryTheory.Sigma.descUniq_hom_app

@[simp]
lemma descUniq_inv_app (q : (Σi, C i) ⥤ D) (h : ∀ i, incl i ⋙ q ≅ F i) (i : I) (X : C i) :
    (descUniq F q h).inv.app ⟨i, X⟩ = (h i).inv.app X :=
  rfl
#align category_theory.sigma.desc_uniq_inv_app CategoryTheory.Sigma.descUniq_inv_app

/--
If `q₁` and `q₂` when restricted to each subcategory `C i` agree, then `q₁` and `q₂` are isomorphic.
-/
@[simps]
def natIso {q₁ q₂ : (Σi, C i) ⥤ D} (h : ∀ i, incl i ⋙ q₁ ≅ incl i ⋙ q₂) : q₁ ≅ q₂ where
  hom := natTrans fun i => (h i).hom
  inv := natTrans fun i => (h i).inv
#align category_theory.sigma.nat_iso CategoryTheory.Sigma.natIso

end

section

variable (C) {J : Type w₂} (g : J → I)

/-- A function `J → I` induces a functor `Σ j, C (g j) ⥤ Σ i, C i`. -/
def map : (Σj : J, C (g j)) ⥤ Σi : I, C i :=
  desc fun j => incl (g j)
#align category_theory.sigma.map CategoryTheory.Sigma.map

@[simp]
lemma map_obj (j : J) (X : C (g j)) : (Sigma.map C g).obj ⟨j, X⟩ = ⟨g j, X⟩ :=
  rfl
#align category_theory.sigma.map_obj CategoryTheory.Sigma.map_obj

@[simp]
lemma map_map {j : J} {X Y : C (g j)} (f : X ⟶ Y) :
    (Sigma.map C g).map (SigmaHom.mk f) = SigmaHom.mk f :=
  rfl
#align category_theory.sigma.map_map CategoryTheory.Sigma.map_map

/-- The functor `Sigma.map C g` restricted to the subcategory `C j` acts as the inclusion of `g j`.
-/
@[simps!]
def inclCompMap (j : J) : incl j ⋙ map C g ≅ incl (g j) :=
  Iso.refl _
#align category_theory.sigma.incl_comp_map CategoryTheory.Sigma.inclCompMap

variable (I)

/-- The functor `Sigma.map` applied to the identity function is just the identity functor. -/
@[simps!]
def mapId : map C (id : I → I) ≅ 𝟭 (Σi, C i) :=
  natIso fun i => NatIso.ofComponents (fun X => Iso.refl _) (by aesop)
#align category_theory.sigma.map_id CategoryTheory.Sigma.mapId

variable {I} {K : Type w₃}

-- Porting note: Had to expand (G ∘ g) to (fun i => C (g i)) in lemma statement
-- so that the suitable cateogry instances could be found
/-- The functor `sigma.map` applied to a composition is a composition of functors. -/
@[simps!]
def mapComp (f : K → J) (g : J → I) : map (fun x => C (g x)) f ⋙ (map C g : _) ≅ map C (g ∘ f) :=
  (descUniq _ _) fun k =>
    (isoWhiskerRight (inclCompMap (fun i => C (g i)) f k) (map C g : _) : _) ≪≫ inclCompMap _ _ _
#align category_theory.sigma.map_comp CategoryTheory.Sigma.mapComp

end

namespace Functor

-- variable {C}

variable {D : I → Type u₁} [∀ i, Category.{v₁} (D i)]

/-- Assemble an `I`-indexed family of functors into a functor between the sigma types.
-/
def sigma (F : ∀ i, C i ⥤ D i) : (Σi, C i) ⥤ Σi, D i :=
  desc fun i => F i ⋙ incl i
#align category_theory.sigma.functor.sigma CategoryTheory.Sigma.Functor.sigma

end Functor

namespace natTrans

variable {D : I → Type u₁} [∀ i, Category.{v₁} (D i)]

variable {F G : ∀ i, C i ⥤ D i}

/-- Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
def sigma (α : ∀ i, F i ⟶ G i) : Functor.sigma F ⟶ Functor.sigma G where
  app f := SigmaHom.mk ((α f.1).app _)
  naturality := by
    rintro ⟨i, X⟩ ⟨_, _⟩ ⟨f⟩
    change SigmaHom.mk _ = SigmaHom.mk _
    rw [(α i).naturality]
#align category_theory.sigma.nat_trans.sigma CategoryTheory.Sigma.natTrans.sigma

end natTrans

end Sigma

end CategoryTheory