/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.shapes.terminal
import category_theory.discrete_category
import category_theory.epi_mono
import category_theory.over

/-!
# Binary (co)products

We define a category `walking_pair`, which is the index category
for a binary (co)product diagram. A convenience method `pair X Y`
constructs the functor from the walking pair, hitting the given objects.

We define `prod X Y` and `coprod X Y` as limits and colimits of such functors.

Typeclasses `has_binary_products` and `has_binary_coproducts` assert the existence
of (co)limits shaped as walking pairs.

We include lemmas for simplifying equations involving projections and coprojections, and define
braiding and associating isomorphisms, and the product comparison morphism.

## References
* [Stacks: Products of pairs](https://stacks.math.columbia.edu/tag/001R)
* [Stacks: coproducts of pairs](https://stacks.math.columbia.edu/tag/04AN)
-/

noncomputable theory

universes v u u₂

open category_theory

namespace category_theory.limits

/-- The type of objects for the diagram indexing a binary (co)product. -/
@[derive decidable_eq, derive inhabited]
inductive walking_pair : Type
| left | right

open walking_pair

/--
The equivalence swapping left and right.
-/
def walking_pair.swap : walking_pair ≃ walking_pair :=
{ to_fun := λ j, walking_pair.rec_on j right left,
  inv_fun := λ j, walking_pair.rec_on j right left,
  left_inv := λ j, by { cases j; refl, },
  right_inv := λ j, by { cases j; refl, }, }

@[simp] lemma walking_pair.swap_apply_left : walking_pair.swap left = right := rfl
@[simp] lemma walking_pair.swap_apply_right : walking_pair.swap right = left := rfl
@[simp] lemma walking_pair.swap_symm_apply_tt : walking_pair.swap.symm left = right := rfl
@[simp] lemma walking_pair.swap_symm_apply_ff : walking_pair.swap.symm right = left := rfl

/--
An equivalence from `walking_pair` to `bool`, sometimes useful when reindexing limits.
-/
def walking_pair.equiv_bool : walking_pair ≃ bool :=
{ to_fun := λ j, walking_pair.rec_on j tt ff, -- to match equiv.sum_equiv_sigma_bool
  inv_fun := λ b, bool.rec_on b right left,
  left_inv := λ j, by { cases j; refl, },
  right_inv := λ b, by { cases b; refl, }, }

@[simp] lemma walking_pair.equiv_bool_apply_left : walking_pair.equiv_bool left = tt := rfl
@[simp] lemma walking_pair.equiv_bool_apply_right : walking_pair.equiv_bool right = ff := rfl
@[simp] lemma walking_pair.equiv_bool_symm_apply_tt : walking_pair.equiv_bool.symm tt = left := rfl
@[simp] lemma walking_pair.equiv_bool_symm_apply_ff : walking_pair.equiv_bool.symm ff = right := rfl

variables {C : Type u}

/-- The function on the walking pair, sending the two points to `X` and `Y`. -/
def pair_function (X Y : C) : walking_pair → C := λ j, walking_pair.cases_on j X Y

@[simp] lemma pair_function_left (X Y : C) : pair_function X Y left = X := rfl
@[simp] lemma pair_function_right (X Y : C) : pair_function X Y right = Y := rfl

variables [category.{v} C]

/-- The diagram on the walking pair, sending the two points to `X` and `Y`. -/
def pair (X Y : C) : discrete walking_pair ⥤ C :=
discrete.functor (λ j, walking_pair.cases_on j X Y)

@[simp] lemma pair_obj_left (X Y : C) : (pair X Y).obj ⟨left⟩ = X := rfl
@[simp] lemma pair_obj_right (X Y : C) : (pair X Y).obj ⟨right⟩ = Y := rfl

section
variables {F G : discrete walking_pair ⥤ C} (f : F.obj ⟨left⟩ ⟶ G.obj ⟨left⟩)
  (g : F.obj ⟨right⟩ ⟶ G.obj ⟨right⟩)

local attribute [tidy] tactic.discrete_cases

/-- The natural transformation between two functors out of the
 walking pair, specified by its
components. -/
def map_pair : F ⟶ G := { app := λ j, discrete.rec_on j (λ j, walking_pair.cases_on j f g) }

@[simp] lemma map_pair_left : (map_pair f g).app ⟨left⟩ = f := rfl
@[simp] lemma map_pair_right : (map_pair f g).app ⟨right⟩ = g := rfl

/-- The natural isomorphism between two functors out of the walking pair, specified by its
components. -/
@[simps]
def map_pair_iso (f : F.obj ⟨left⟩ ≅ G.obj ⟨left⟩) (g : F.obj ⟨right⟩ ≅ G.obj ⟨right⟩) : F ≅ G :=
nat_iso.of_components (λ j, discrete.rec_on j (λ j, walking_pair.cases_on j f g)) (by tidy)

end

/-- Every functor out of the walking pair is naturally isomorphic (actually, equal) to a `pair` -/
@[simps]
def diagram_iso_pair (F : discrete walking_pair ⥤ C) :
  F ≅ pair (F.obj ⟨walking_pair.left⟩) (F.obj ⟨walking_pair.right⟩) :=
map_pair_iso (iso.refl _) (iso.refl _)

section
variables {D : Type u} [category.{v} D]

/-- The natural isomorphism between `pair X Y ⋙ F` and `pair (F.obj X) (F.obj Y)`. -/
def pair_comp (X Y : C) (F : C ⥤ D) : pair X Y ⋙ F ≅ pair (F.obj X) (F.obj Y) :=
diagram_iso_pair _

end

/-- A binary fan is just a cone on a diagram indexing a product. -/
abbreviation binary_fan (X Y : C) := cone (pair X Y)

/-- The first projection of a binary fan. -/
abbreviation binary_fan.fst {X Y : C} (s : binary_fan X Y) := s.π.app ⟨walking_pair.left⟩

/-- The second projection of a binary fan. -/
abbreviation binary_fan.snd {X Y : C} (s : binary_fan X Y) := s.π.app ⟨walking_pair.right⟩

@[simp] lemma binary_fan.π_app_left {X Y : C} (s : binary_fan X Y) :
  s.π.app ⟨walking_pair.left⟩ = s.fst := rfl
@[simp] lemma binary_fan.π_app_right {X Y : C} (s : binary_fan X Y) :
  s.π.app ⟨walking_pair.right⟩ = s.snd := rfl

/-- A convenient way to show that a binary fan is a limit. -/
def binary_fan.is_limit.mk {X Y : C} (s : binary_fan X Y)
  (lift : Π {T : C} (f : T ⟶ X) (g : T ⟶ Y), T ⟶ s.X)
  (hl₁ : ∀ {T : C} (f : T ⟶ X) (g : T ⟶ Y), lift f g ≫ s.fst = f)
  (hl₂ : ∀ {T : C} (f : T ⟶ X) (g : T ⟶ Y), lift f g ≫ s.snd = g)
  (uniq : ∀ {T : C} (f : T ⟶ X) (g : T ⟶ Y) (m : T ⟶ s.X) (h₁ : m ≫ s.fst = f)
    (h₂ : m ≫ s.snd = g), m = lift f g) : is_limit s := is_limit.mk
  (λ t, lift (binary_fan.fst t) (binary_fan.snd t))
  (by { rintros t (rfl|rfl), { exact hl₁ _ _ }, { exact hl₂ _ _ } })
  (λ t m h, uniq _ _ _ (h ⟨walking_pair.left⟩) (h ⟨walking_pair.right⟩))

lemma binary_fan.is_limit.hom_ext {W X Y : C} {s : binary_fan X Y} (h : is_limit s)
  {f g : W ⟶ s.X} (h₁ : f ≫ s.fst = g ≫ s.fst) (h₂ : f ≫ s.snd = g ≫ s.snd) : f = g :=
h.hom_ext $ λ j, discrete.rec_on j (λ j, walking_pair.cases_on j h₁ h₂)

/-- A binary cofan is just a cocone on a diagram indexing a coproduct. -/
abbreviation binary_cofan (X Y : C) := cocone (pair X Y)

/-- The first inclusion of a binary cofan. -/
abbreviation binary_cofan.inl {X Y : C} (s : binary_cofan X Y) := s.ι.app ⟨walking_pair.left⟩

/-- The second inclusion of a binary cofan. -/
abbreviation binary_cofan.inr {X Y : C} (s : binary_cofan X Y) := s.ι.app ⟨walking_pair.right⟩

@[simp] lemma binary_cofan.ι_app_left {X Y : C} (s : binary_cofan X Y) :
  s.ι.app ⟨walking_pair.left⟩ = s.inl := rfl
@[simp] lemma binary_cofan.ι_app_right {X Y : C} (s : binary_cofan X Y) :
  s.ι.app ⟨walking_pair.right⟩ = s.inr := rfl

/-- A convenient way to show that a binary cofan is a colimit. -/
def binary_cofan.is_colimit.mk {X Y : C} (s : binary_cofan X Y)
  (desc : Π {T : C} (f : X ⟶ T) (g : Y ⟶ T), s.X ⟶ T)
  (hd₁ : ∀ {T : C} (f : X ⟶ T) (g : Y ⟶ T), s.inl ≫ desc f g = f)
  (hd₂ : ∀ {T : C} (f : X ⟶ T) (g : Y ⟶ T), s.inr ≫ desc f g = g)
  (uniq : ∀ {T : C} (f : X ⟶ T) (g : Y ⟶ T) (m : s.X ⟶ T) (h₁ : s.inl ≫ m = f)
    (h₂ : s.inr ≫ m = g), m = desc f g) : is_colimit s := is_colimit.mk
    (λ t, desc (binary_cofan.inl t) (binary_cofan.inr t))
    (by { rintros t (rfl|rfl), { exact hd₁ _ _ }, { exact hd₂ _ _ }})
    (λ t m h, uniq _ _ _ (h ⟨walking_pair.left⟩) (h ⟨walking_pair.right⟩))

lemma binary_cofan.is_colimit.hom_ext {W X Y : C} {s : binary_cofan X Y} (h : is_colimit s)
  {f g : s.X ⟶ W} (h₁ : s.inl ≫ f = s.inl ≫ g) (h₂ : s.inr ≫ f = s.inr ≫ g) : f = g :=
h.hom_ext $ λ j, discrete.rec_on j (λ j, walking_pair.cases_on j h₁ h₂)

variables {X Y : C}

section
local attribute [tidy] tactic.discrete_cases

/-- A binary fan with vertex `P` consists of the two projections `π₁ : P ⟶ X` and `π₂ : P ⟶ Y`. -/
@[simps X]
def binary_fan.mk {P : C} (π₁ : P ⟶ X) (π₂ : P ⟶ Y) : binary_fan X Y :=
{ X := P,
  π := { app := λ j, discrete.rec_on j (λ j, walking_pair.cases_on j π₁ π₂) }}

/-- A binary cofan with vertex `P` consists of the two inclusions `ι₁ : X ⟶ P` and `ι₂ : Y ⟶ P`. -/
@[simps X]
def binary_cofan.mk {P : C} (ι₁ : X ⟶ P) (ι₂ : Y ⟶ P) : binary_cofan X Y :=
{ X := P,
  ι := { app := λ j, discrete.rec_on j (λ j, walking_pair.cases_on j ι₁ ι₂) }}

end

@[simp] lemma binary_fan.mk_π_app_left {P : C} (π₁ : P ⟶ X) (π₂ : P ⟶ Y) :
  (binary_fan.mk π₁ π₂).π.app ⟨walking_pair.left⟩ = π₁ := rfl
@[simp] lemma binary_fan.mk_π_app_right {P : C} (π₁ : P ⟶ X) (π₂ : P ⟶ Y) :
  (binary_fan.mk π₁ π₂).π.app ⟨walking_pair.right⟩ = π₂ := rfl
@[simp] lemma binary_cofan.mk_ι_app_left {P : C} (ι₁ : X ⟶ P) (ι₂ : Y ⟶ P) :
  (binary_cofan.mk ι₁ ι₂).ι.app ⟨walking_pair.left⟩ = ι₁ := rfl
@[simp] lemma binary_cofan.mk_ι_app_right {P : C} (ι₁ : X ⟶ P) (ι₂ : Y ⟶ P) :
  (binary_cofan.mk ι₁ ι₂).ι.app ⟨walking_pair.right⟩ = ι₂ := rfl

/-- If `s` is a limit binary fan over `X` and `Y`, then every pair of morphisms `f : W ⟶ X` and
    `g : W ⟶ Y` induces a morphism `l : W ⟶ s.X` satisfying `l ≫ s.fst = f` and `l ≫ s.snd = g`.
    -/
@[simps]
def binary_fan.is_limit.lift' {W X Y : C} {s : binary_fan X Y} (h : is_limit s) (f : W ⟶ X)
  (g : W ⟶ Y) : {l : W ⟶ s.X // l ≫ s.fst = f ∧ l ≫ s.snd = g} :=
⟨h.lift $ binary_fan.mk f g, h.fac _ _, h.fac _ _⟩

/-- If `s` is a colimit binary cofan over `X` and `Y`,, then every pair of morphisms `f : X ⟶ W` and
    `g : Y ⟶ W` induces a morphism `l : s.X ⟶ W` satisfying `s.inl ≫ l = f` and `s.inr ≫ l = g`.
    -/
@[simps]
def binary_cofan.is_colimit.desc' {W X Y : C} {s : binary_cofan X Y} (h : is_colimit s) (f : X ⟶ W)
  (g : Y ⟶ W) : {l : s.X ⟶ W // s.inl ≫ l = f ∧ s.inr ≫ l = g} :=
⟨h.desc $ binary_cofan.mk f g, h.fac _ _, h.fac _ _⟩

/-- An abbreviation for `has_limit (pair X Y)`. -/
abbreviation has_binary_product (X Y : C) := has_limit (pair X Y)
/-- An abbreviation for `has_colimit (pair X Y)`. -/
abbreviation has_binary_coproduct (X Y : C) := has_colimit (pair X Y)

/-- If we have a product of `X` and `Y`, we can access it using `prod X Y` or
    `X ⨯ Y`. -/
abbreviation prod (X Y : C) [has_binary_product X Y] := limit (pair X Y)

/-- If we have a coproduct of `X` and `Y`, we can access it using `coprod X Y ` or
    `X ⨿ Y`. -/
abbreviation coprod (X Y : C) [has_binary_coproduct X Y] := colimit (pair X Y)

notation X ` ⨯ `:20 Y:20 := prod X Y
notation X ` ⨿ `:20 Y:20 := coprod X Y

/-- The projection map to the first component of the product. -/
abbreviation prod.fst {X Y : C} [has_binary_product X Y] : X ⨯ Y ⟶ X :=
limit.π (pair X Y) ⟨walking_pair.left⟩

/-- The projecton map to the second component of the product. -/
abbreviation prod.snd {X Y : C} [has_binary_product X Y] : X ⨯ Y ⟶ Y :=
limit.π (pair X Y) ⟨walking_pair.right⟩

/-- The inclusion map from the first component of the coproduct. -/
abbreviation coprod.inl {X Y : C} [has_binary_coproduct X Y] : X ⟶ X ⨿ Y :=
colimit.ι (pair X Y) ⟨walking_pair.left⟩

/-- The inclusion map from the second component of the coproduct. -/
abbreviation coprod.inr {X Y : C} [has_binary_coproduct X Y] : Y ⟶ X ⨿ Y :=
colimit.ι (pair X Y) ⟨walking_pair.right⟩

/-- The binary fan constructed from the projection maps is a limit. -/
def prod_is_prod (X Y : C) [has_binary_product X Y] :
  is_limit (binary_fan.mk (prod.fst : X ⨯ Y ⟶ X) prod.snd) :=
(limit.is_limit _).of_iso_limit (cones.ext (iso.refl _) (by { rintro (_ | _), tidy }))

/-- The binary cofan constructed from the coprojection maps is a colimit. -/
def coprod_is_coprod (X Y : C) [has_binary_coproduct X Y] :
  is_colimit (binary_cofan.mk (coprod.inl : X ⟶ X ⨿ Y) coprod.inr) :=
(colimit.is_colimit _).of_iso_colimit (cocones.ext (iso.refl _) (by { rintro (_ | _), tidy }))

@[ext] lemma prod.hom_ext {W X Y : C} [has_binary_product X Y] {f g : W ⟶ X ⨯ Y}
  (h₁ : f ≫ prod.fst = g ≫ prod.fst) (h₂ : f ≫ prod.snd = g ≫ prod.snd) : f = g :=
binary_fan.is_limit.hom_ext (limit.is_limit _) h₁ h₂

@[ext] lemma coprod.hom_ext {W X Y : C} [has_binary_coproduct X Y] {f g : X ⨿ Y ⟶ W}
  (h₁ : coprod.inl ≫ f = coprod.inl ≫ g) (h₂ : coprod.inr ≫ f = coprod.inr ≫ g) : f = g :=
binary_cofan.is_colimit.hom_ext (colimit.is_colimit _) h₁ h₂

/-- If the product of `X` and `Y` exists, then every pair of morphisms `f : W ⟶ X` and `g : W ⟶ Y`
    induces a morphism `prod.lift f g : W ⟶ X ⨯ Y`. -/
abbreviation prod.lift {W X Y : C} [has_binary_product X Y] (f : W ⟶ X) (g : W ⟶ Y) : W ⟶ X ⨯ Y :=
limit.lift _ (binary_fan.mk f g)

/-- diagonal arrow of the binary product in the category `fam I` -/
abbreviation diag (X : C) [has_binary_product X X] : X ⟶ X ⨯ X :=
prod.lift (𝟙 _) (𝟙 _)

/-- If the coproduct of `X` and `Y` exists, then every pair of morphisms `f : X ⟶ W` and
    `g : Y ⟶ W` induces a morphism `coprod.desc f g : X ⨿ Y ⟶ W`. -/
abbreviation coprod.desc {W X Y : C} [has_binary_coproduct X Y] (f : X ⟶ W) (g : Y ⟶ W) :
  X ⨿ Y ⟶ W :=
colimit.desc _ (binary_cofan.mk f g)

/-- codiagonal arrow of the binary coproduct -/
abbreviation codiag (X : C) [has_binary_coproduct X X] : X ⨿ X ⟶ X :=
coprod.desc (𝟙 _) (𝟙 _)

@[simp, reassoc]
lemma prod.lift_fst {W X Y : C} [has_binary_product X Y] (f : W ⟶ X) (g : W ⟶ Y) :
  prod.lift f g ≫ prod.fst = f :=
limit.lift_π _ _

@[simp, reassoc]
lemma prod.lift_snd {W X Y : C} [has_binary_product X Y] (f : W ⟶ X) (g : W ⟶ Y) :
  prod.lift f g ≫ prod.snd = g :=
limit.lift_π _ _

-- The simp linter says simp can prove the reassoc version of this lemma.
@[reassoc, simp]
lemma coprod.inl_desc {W X Y : C} [has_binary_coproduct X Y] (f : X ⟶ W) (g : Y ⟶ W) :
  coprod.inl ≫ coprod.desc f g = f :=
colimit.ι_desc _ _

-- The simp linter says simp can prove the reassoc version of this lemma.
@[reassoc, simp]
lemma coprod.inr_desc {W X Y : C} [has_binary_coproduct X Y] (f : X ⟶ W) (g : Y ⟶ W) :
  coprod.inr ≫ coprod.desc f g = g :=
colimit.ι_desc _ _

instance prod.mono_lift_of_mono_left {W X Y : C} [has_binary_product X Y] (f : W ⟶ X) (g : W ⟶ Y)
  [mono f] : mono (prod.lift f g) :=
mono_of_mono_fac $ prod.lift_fst _ _

instance prod.mono_lift_of_mono_right {W X Y : C} [has_binary_product X Y] (f : W ⟶ X) (g : W ⟶ Y)
  [mono g] : mono (prod.lift f g) :=
mono_of_mono_fac $ prod.lift_snd _ _

instance coprod.epi_desc_of_epi_left {W X Y : C} [has_binary_coproduct X Y] (f : X ⟶ W) (g : Y ⟶ W)
  [epi f] : epi (coprod.desc f g) :=
epi_of_epi_fac $ coprod.inl_desc _ _

instance coprod.epi_desc_of_epi_right {W X Y : C} [has_binary_coproduct X Y] (f : X ⟶ W) (g : Y ⟶ W)
  [epi g] : epi (coprod.desc f g) :=
epi_of_epi_fac $ coprod.inr_desc _ _

/-- If the product of `X` and `Y` exists, then every pair of morphisms `f : W ⟶ X` and `g : W ⟶ Y`
    induces a morphism `l : W ⟶ X ⨯ Y` satisfying `l ≫ prod.fst = f` and `l ≫ prod.snd = g`. -/
def prod.lift' {W X Y : C} [has_binary_product X Y] (f : W ⟶ X) (g : W ⟶ Y) :
  {l : W ⟶ X ⨯ Y // l ≫ prod.fst = f ∧ l ≫ prod.snd = g} :=
⟨prod.lift f g, prod.lift_fst _ _, prod.lift_snd _ _⟩

/-- If the coproduct of `X` and `Y` exists, then every pair of morphisms `f : X ⟶ W` and
    `g : Y ⟶ W` induces a morphism `l : X ⨿ Y ⟶ W` satisfying `coprod.inl ≫ l = f` and
    `coprod.inr ≫ l = g`. -/
def coprod.desc' {W X Y : C} [has_binary_coproduct X Y] (f : X ⟶ W) (g : Y ⟶ W) :
  {l : X ⨿ Y ⟶ W // coprod.inl ≫ l = f ∧ coprod.inr ≫ l = g} :=
⟨coprod.desc f g, coprod.inl_desc _ _, coprod.inr_desc _ _⟩

/-- If the products `W ⨯ X` and `Y ⨯ Z` exist, then every pair of morphisms `f : W ⟶ Y` and
    `g : X ⟶ Z` induces a morphism `prod.map f g : W ⨯ X ⟶ Y ⨯ Z`. -/
def prod.map {W X Y Z : C} [has_binary_product W X] [has_binary_product Y Z]
  (f : W ⟶ Y) (g : X ⟶ Z) : W ⨯ X ⟶ Y ⨯ Z :=
lim_map (map_pair f g)

/-- If the coproducts `W ⨿ X` and `Y ⨿ Z` exist, then every pair of morphisms `f : W ⟶ Y` and
    `g : W ⟶ Z` induces a morphism `coprod.map f g : W ⨿ X ⟶ Y ⨿ Z`. -/
def coprod.map {W X Y Z : C} [has_binary_coproduct W X] [has_binary_coproduct Y Z]
  (f : W ⟶ Y) (g : X ⟶ Z) : W ⨿ X ⟶ Y ⨿ Z :=
colim_map (map_pair f g)

section prod_lemmas

-- Making the reassoc version of this a simp lemma seems to be more harmful than helpful.
@[reassoc, simp]
lemma prod.comp_lift {V W X Y : C} [has_binary_product X Y] (f : V ⟶ W) (g : W ⟶ X) (h : W ⟶ Y) :
  f ≫ prod.lift g h = prod.lift (f ≫ g) (f ≫ h) :=
by { ext; simp }

lemma prod.comp_diag {X Y : C} [has_binary_product Y Y] (f : X ⟶ Y) :
  f ≫ diag Y = prod.lift f f :=
by simp

@[simp, reassoc]
lemma prod.map_fst {W X Y Z : C} [has_binary_product W X] [has_binary_product Y Z]
  (f : W ⟶ Y) (g : X ⟶ Z) : prod.map f g ≫ prod.fst = prod.fst ≫ f :=
lim_map_π _ _

@[simp, reassoc]
lemma prod.map_snd {W X Y Z : C} [has_binary_product W X] [has_binary_product Y Z]
  (f : W ⟶ Y) (g : X ⟶ Z) : prod.map f g ≫ prod.snd = prod.snd ≫ g :=
lim_map_π _ _

@[simp] lemma prod.map_id_id {X Y : C} [has_binary_product X Y] :
  prod.map (𝟙 X) (𝟙 Y) = 𝟙 _ :=
by { ext; simp }

@[simp] lemma prod.lift_fst_snd {X Y : C} [has_binary_product X Y] :
  prod.lift prod.fst prod.snd = 𝟙 (X ⨯ Y) :=
by { ext; simp }

@[simp, reassoc] lemma prod.lift_map {V W X Y Z : C} [has_binary_product W X]
  [has_binary_product Y Z] (f : V ⟶ W) (g : V ⟶ X) (h : W ⟶ Y) (k : X ⟶ Z) :
  prod.lift f g ≫ prod.map h k = prod.lift (f ≫ h) (g ≫ k) :=
by { ext; simp }

@[simp] lemma prod.lift_fst_comp_snd_comp {W X Y Z : C} [has_binary_product W Y]
  [has_binary_product X Z] (g : W ⟶ X) (g' : Y ⟶ Z) :
  prod.lift (prod.fst ≫ g) (prod.snd ≫ g') = prod.map g g' :=
by { rw ← prod.lift_map, simp }

-- We take the right hand side here to be simp normal form, as this way composition lemmas for
-- `f ≫ h` and `g ≫ k` can fire (eg `id_comp`) , while `map_fst` and `map_snd` can still work just
-- as well.
@[simp, reassoc]
lemma prod.map_map {A₁ A₂ A₃ B₁ B₂ B₃ : C}
  [has_binary_product A₁ B₁] [has_binary_product A₂ B₂] [has_binary_product A₃ B₃]
  (f : A₁ ⟶ A₂) (g : B₁ ⟶ B₂) (h : A₂ ⟶ A₃) (k : B₂ ⟶ B₃) :
  prod.map f g ≫ prod.map h k = prod.map (f ≫ h) (g ≫ k) :=
by { ext; simp }

-- TODO: is it necessary to weaken the assumption here?
@[reassoc]
lemma prod.map_swap {A B X Y : C} (f : A ⟶ B) (g : X ⟶ Y)
  [has_limits_of_shape (discrete walking_pair) C] :
  prod.map (𝟙 X) f ≫ prod.map g (𝟙 B) = prod.map g (𝟙 A) ≫ prod.map (𝟙 Y) f :=
by simp

@[reassoc] lemma prod.map_comp_id {X Y Z W : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  [has_binary_product X W] [has_binary_product Z W] [has_binary_product Y W] :
  prod.map (f ≫ g) (𝟙 W) = prod.map f (𝟙 W) ≫ prod.map g (𝟙 W) :=
by simp

@[reassoc] lemma prod.map_id_comp {X Y Z W : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  [has_binary_product W X] [has_binary_product W Y] [has_binary_product W Z] :
  prod.map (𝟙 W) (f ≫ g) = prod.map (𝟙 W) f ≫ prod.map (𝟙 W) g :=
by simp

/-- If the products `W ⨯ X` and `Y ⨯ Z` exist, then every pair of isomorphisms `f : W ≅ Y` and
    `g : X ≅ Z` induces an isomorphism `prod.map_iso f g : W ⨯ X ≅ Y ⨯ Z`. -/
@[simps]
def prod.map_iso {W X Y Z : C} [has_binary_product W X] [has_binary_product Y Z]
  (f : W ≅ Y) (g : X ≅ Z) : W ⨯ X ≅ Y ⨯ Z :=
{ hom := prod.map f.hom g.hom,
  inv := prod.map f.inv g.inv }

instance is_iso_prod {W X Y Z : C} [has_binary_product W X] [has_binary_product Y Z]
  (f : W ⟶ Y) (g : X ⟶ Z) [is_iso f] [is_iso g] : is_iso (prod.map f g) :=
is_iso.of_iso (prod.map_iso (as_iso f) (as_iso g))

instance prod.map_mono {C : Type*} [category C] {W X Y Z : C} (f : W ⟶ Y) (g : X ⟶ Z) [mono f]
  [mono g] [has_binary_product W X] [has_binary_product Y Z] : mono (prod.map f g) :=
⟨λ A i₁ i₂ h, begin
  ext,
  { rw ← cancel_mono f, simpa using congr_arg (λ f, f ≫ prod.fst) h },
  { rw ← cancel_mono g, simpa using congr_arg (λ f, f ≫ prod.snd) h }
end⟩

@[simp, reassoc]
lemma prod.diag_map {X Y : C} (f : X ⟶ Y) [has_binary_product X X] [has_binary_product Y Y] :
  diag X ≫ prod.map f f = f ≫ diag Y :=
by simp

@[simp, reassoc]
lemma prod.diag_map_fst_snd {X Y : C} [has_binary_product X Y]
  [has_binary_product (X ⨯ Y) (X ⨯ Y)] :
  diag (X ⨯ Y) ≫ prod.map prod.fst prod.snd = 𝟙 (X ⨯ Y) :=
by simp

@[simp, reassoc]
lemma prod.diag_map_fst_snd_comp  [has_limits_of_shape (discrete walking_pair) C]
  {X X' Y Y' : C} (g : X ⟶ Y) (g' : X' ⟶ Y') :
  diag (X ⨯ X') ≫ prod.map (prod.fst ≫ g) (prod.snd ≫ g') = prod.map g g' :=
by simp

instance {X : C} [has_binary_product X X] : split_mono (diag X) :=
{ retraction := prod.fst }

end prod_lemmas

section coprod_lemmas

@[simp, reassoc]
lemma coprod.desc_comp {V W X Y : C} [has_binary_coproduct X Y] (f : V ⟶ W) (g : X ⟶ V)
  (h : Y ⟶ V) :
  coprod.desc g h ≫ f = coprod.desc (g ≫ f) (h ≫ f) :=
by { ext; simp }

lemma coprod.diag_comp {X Y : C} [has_binary_coproduct X X] (f : X ⟶ Y) :
  codiag X ≫ f = coprod.desc f f :=
by simp

@[simp, reassoc]
lemma coprod.inl_map {W X Y Z : C} [has_binary_coproduct W X] [has_binary_coproduct Y Z]
  (f : W ⟶ Y) (g : X ⟶ Z) : coprod.inl ≫ coprod.map f g = f ≫ coprod.inl :=
ι_colim_map _ _

@[simp, reassoc]
lemma coprod.inr_map {W X Y Z : C} [has_binary_coproduct W X] [has_binary_coproduct Y Z]
  (f : W ⟶ Y) (g : X ⟶ Z) : coprod.inr ≫ coprod.map f g = g ≫ coprod.inr :=
ι_colim_map _ _

@[simp]
lemma coprod.map_id_id {X Y : C} [has_binary_coproduct X Y] :
  coprod.map (𝟙 X) (𝟙 Y) = 𝟙 _ :=
by { ext; simp }

@[simp]
lemma coprod.desc_inl_inr {X Y : C} [has_binary_coproduct X Y] :
  coprod.desc coprod.inl coprod.inr = 𝟙 (X ⨿ Y) :=
by { ext; simp }

-- The simp linter says simp can prove the reassoc version of this lemma.
@[reassoc, simp]
lemma coprod.map_desc {S T U V W : C} [has_binary_coproduct U W] [has_binary_coproduct T V]
  (f : U ⟶ S) (g : W ⟶ S) (h : T ⟶ U) (k : V ⟶ W) :
  coprod.map h k ≫ coprod.desc f g = coprod.desc (h ≫ f) (k ≫ g) :=
by { ext; simp }

@[simp]
lemma coprod.desc_comp_inl_comp_inr {W X Y Z : C}
  [has_binary_coproduct W Y] [has_binary_coproduct X Z]
  (g : W ⟶ X) (g' : Y ⟶ Z) :
  coprod.desc (g ≫ coprod.inl) (g' ≫ coprod.inr) = coprod.map g g' :=
by { rw ← coprod.map_desc, simp }

-- We take the right hand side here to be simp normal form, as this way composition lemmas for
-- `f ≫ h` and `g ≫ k` can fire (eg `id_comp`) , while `inl_map` and `inr_map` can still work just
-- as well.
@[simp, reassoc]
lemma coprod.map_map {A₁ A₂ A₃ B₁ B₂ B₃ : C}
  [has_binary_coproduct A₁ B₁] [has_binary_coproduct A₂ B₂] [has_binary_coproduct A₃ B₃]
  (f : A₁ ⟶ A₂) (g : B₁ ⟶ B₂) (h : A₂ ⟶ A₃) (k : B₂ ⟶ B₃) :
  coprod.map f g ≫ coprod.map h k = coprod.map (f ≫ h) (g ≫ k) :=
by { ext; simp }

-- I don't think it's a good idea to make any of the following three simp lemmas.
@[reassoc]
lemma coprod.map_swap {A B X Y : C} (f : A ⟶ B) (g : X ⟶ Y)
  [has_colimits_of_shape (discrete walking_pair) C] :
  coprod.map (𝟙 X) f ≫ coprod.map g (𝟙 B) = coprod.map g (𝟙 A) ≫ coprod.map (𝟙 Y) f :=
by simp

@[reassoc] lemma coprod.map_comp_id {X Y Z W : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  [has_binary_coproduct Z W] [has_binary_coproduct Y W] [has_binary_coproduct X W] :
  coprod.map (f ≫ g) (𝟙 W) = coprod.map f (𝟙 W) ≫ coprod.map g (𝟙 W) :=
by simp

@[reassoc] lemma coprod.map_id_comp {X Y Z W : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  [has_binary_coproduct W X] [has_binary_coproduct W Y] [has_binary_coproduct W Z] :
  coprod.map (𝟙 W) (f ≫ g) = coprod.map (𝟙 W) f ≫ coprod.map (𝟙 W) g :=
by simp

/-- If the coproducts `W ⨿ X` and `Y ⨿ Z` exist, then every pair of isomorphisms `f : W ≅ Y` and
    `g : W ≅ Z` induces a isomorphism `coprod.map_iso f g : W ⨿ X ≅ Y ⨿ Z`. -/
@[simps]
def coprod.map_iso {W X Y Z : C} [has_binary_coproduct W X] [has_binary_coproduct Y Z]
  (f : W ≅ Y) (g : X ≅ Z) : W ⨿ X ≅ Y ⨿ Z :=
{ hom := coprod.map f.hom g.hom,
  inv := coprod.map f.inv g.inv }

instance is_iso_coprod {W X Y Z : C} [has_binary_coproduct W X] [has_binary_coproduct Y Z]
  (f : W ⟶ Y) (g : X ⟶ Z) [is_iso f] [is_iso g] : is_iso (coprod.map f g) :=
is_iso.of_iso (coprod.map_iso (as_iso f) (as_iso g))

instance coprod.map_epi {C : Type*} [category C] {W X Y Z : C} (f : W ⟶ Y) (g : X ⟶ Z) [epi f]
  [epi g] [has_binary_coproduct W X] [has_binary_coproduct Y Z] : epi (coprod.map f g) :=
⟨λ A i₁ i₂ h, begin
  ext,
  { rw ← cancel_epi f, simpa using congr_arg (λ f, coprod.inl ≫ f) h },
  { rw ← cancel_epi g, simpa using congr_arg (λ f, coprod.inr ≫ f) h }
end⟩

-- The simp linter says simp can prove the reassoc version of this lemma.
@[reassoc, simp]
lemma coprod.map_codiag {X Y : C} (f : X ⟶ Y) [has_binary_coproduct X X]
  [has_binary_coproduct Y Y] :
  coprod.map f f ≫ codiag Y = codiag X ≫ f :=
by simp

-- The simp linter says simp can prove the reassoc version of this lemma.
@[reassoc, simp]
lemma coprod.map_inl_inr_codiag {X Y : C} [has_binary_coproduct X Y]
  [has_binary_coproduct (X ⨿ Y) (X ⨿ Y)] :
  coprod.map coprod.inl coprod.inr ≫ codiag (X ⨿ Y) = 𝟙 (X ⨿ Y) :=
by simp

-- The simp linter says simp can prove the reassoc version of this lemma.
@[reassoc, simp]
lemma coprod.map_comp_inl_inr_codiag [has_colimits_of_shape (discrete walking_pair) C]
  {X X' Y Y' : C} (g : X ⟶ Y) (g' : X' ⟶ Y') :
  coprod.map (g ≫ coprod.inl) (g' ≫ coprod.inr) ≫ codiag (Y ⨿ Y') = coprod.map g g' :=
by simp

end coprod_lemmas

variables (C)

/--
`has_binary_products` represents a choice of product for every pair of objects.

See <https://stacks.math.columbia.edu/tag/001T>.
-/
abbreviation has_binary_products := has_limits_of_shape (discrete walking_pair) C

/--
`has_binary_coproducts` represents a choice of coproduct for every pair of objects.

See <https://stacks.math.columbia.edu/tag/04AP>.
-/
abbreviation has_binary_coproducts := has_colimits_of_shape (discrete walking_pair) C

/-- If `C` has all limits of diagrams `pair X Y`, then it has all binary products -/
lemma has_binary_products_of_has_limit_pair [Π {X Y : C}, has_limit (pair X Y)] :
  has_binary_products C :=
{ has_limit := λ F, has_limit_of_iso (diagram_iso_pair F).symm }

/-- If `C` has all colimits of diagrams `pair X Y`, then it has all binary coproducts -/
lemma has_binary_coproducts_of_has_colimit_pair [Π {X Y : C}, has_colimit (pair X Y)] :
  has_binary_coproducts C :=
{ has_colimit := λ F, has_colimit_of_iso (diagram_iso_pair F) }

section
variables {C}

/-- The braiding isomorphism which swaps a binary product. -/
@[simps] def prod.braiding (P Q : C) [has_binary_product P Q] [has_binary_product Q P] :
  P ⨯ Q ≅ Q ⨯ P :=
{ hom := prod.lift prod.snd prod.fst,
  inv := prod.lift prod.snd prod.fst }

/-- The braiding isomorphism can be passed through a map by swapping the order. -/
@[reassoc] lemma braid_natural [has_binary_products C] {W X Y Z : C} (f : X ⟶ Y) (g : Z ⟶ W) :
  prod.map f g ≫ (prod.braiding _ _).hom = (prod.braiding _ _).hom ≫ prod.map g f :=
by simp

@[reassoc] lemma prod.symmetry' (P Q : C) [has_binary_product P Q] [has_binary_product Q P] :
  prod.lift prod.snd prod.fst ≫ prod.lift prod.snd prod.fst = 𝟙 (P ⨯ Q) :=
(prod.braiding _ _).hom_inv_id

/-- The braiding isomorphism is symmetric. -/
@[reassoc] lemma prod.symmetry (P Q : C) [has_binary_product P Q] [has_binary_product Q P] :
  (prod.braiding P Q).hom ≫ (prod.braiding Q P).hom = 𝟙 _ :=
(prod.braiding _ _).hom_inv_id

/-- The associator isomorphism for binary products. -/
@[simps] def prod.associator [has_binary_products C] (P Q R : C) :
  (P ⨯ Q) ⨯ R ≅ P ⨯ (Q ⨯ R) :=
{ hom :=
  prod.lift
    (prod.fst ≫ prod.fst)
    (prod.lift (prod.fst ≫ prod.snd) prod.snd),
  inv :=
  prod.lift
    (prod.lift prod.fst (prod.snd ≫ prod.fst))
    (prod.snd ≫ prod.snd) }

@[reassoc]
lemma prod.pentagon [has_binary_products C] (W X Y Z : C) :
  prod.map ((prod.associator W X Y).hom) (𝟙 Z) ≫
      (prod.associator W (X ⨯ Y) Z).hom ≫ prod.map (𝟙 W) ((prod.associator X Y Z).hom) =
    (prod.associator (W ⨯ X) Y Z).hom ≫ (prod.associator W X (Y ⨯ Z)).hom :=
by simp

@[reassoc]
lemma prod.associator_naturality [has_binary_products C] {X₁ X₂ X₃ Y₁ Y₂ Y₃ : C}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃) :
  prod.map (prod.map f₁ f₂) f₃ ≫ (prod.associator Y₁ Y₂ Y₃).hom =
    (prod.associator X₁ X₂ X₃).hom ≫ prod.map f₁ (prod.map f₂ f₃) :=
by simp

variables [has_terminal C]

/-- The left unitor isomorphism for binary products with the terminal object. -/
@[simps] def prod.left_unitor (P : C) [has_binary_product (⊤_ C) P] :
  ⊤_ C ⨯ P ≅ P :=
{ hom := prod.snd,
  inv := prod.lift (terminal.from P) (𝟙 _) }

/-- The right unitor isomorphism for binary products with the terminal object. -/
@[simps] def prod.right_unitor (P : C) [has_binary_product P (⊤_ C)] :
  P ⨯ ⊤_ C ≅ P :=
{ hom := prod.fst,
  inv := prod.lift (𝟙 _) (terminal.from P) }

@[reassoc]
lemma prod.left_unitor_hom_naturality [has_binary_products C] (f : X ⟶ Y) :
  prod.map (𝟙 _) f ≫ (prod.left_unitor Y).hom = (prod.left_unitor X).hom ≫ f :=
prod.map_snd _ _

@[reassoc]
lemma prod.left_unitor_inv_naturality [has_binary_products C] (f : X ⟶ Y) :
  (prod.left_unitor X).inv ≫ prod.map (𝟙 _) f = f ≫ (prod.left_unitor Y).inv :=
by rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv, prod.left_unitor_hom_naturality]

@[reassoc]
lemma prod.right_unitor_hom_naturality [has_binary_products C] (f : X ⟶ Y) :
  prod.map f (𝟙 _) ≫ (prod.right_unitor Y).hom = (prod.right_unitor X).hom ≫ f :=
prod.map_fst _ _

@[reassoc]
lemma prod_right_unitor_inv_naturality [has_binary_products C] (f : X ⟶ Y) :
  (prod.right_unitor X).inv ≫ prod.map f (𝟙 _) = f ≫ (prod.right_unitor Y).inv :=
by rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv, prod.right_unitor_hom_naturality]

lemma prod.triangle [has_binary_products C] (X Y : C) :
  (prod.associator X (⊤_ C) Y).hom ≫ prod.map (𝟙 X) ((prod.left_unitor Y).hom) =
    prod.map ((prod.right_unitor X).hom) (𝟙 Y) :=
by tidy

end

section

variables {C} [has_binary_coproducts C]

/-- The braiding isomorphism which swaps a binary coproduct. -/
@[simps] def coprod.braiding (P Q : C) : P ⨿ Q ≅ Q ⨿ P :=
{ hom := coprod.desc coprod.inr coprod.inl,
  inv := coprod.desc coprod.inr coprod.inl }

@[reassoc] lemma coprod.symmetry' (P Q : C) :
  coprod.desc coprod.inr coprod.inl ≫ coprod.desc coprod.inr coprod.inl = 𝟙 (P ⨿ Q) :=
(coprod.braiding _ _).hom_inv_id

/-- The braiding isomorphism is symmetric. -/
lemma coprod.symmetry (P Q : C) :
  (coprod.braiding P Q).hom ≫ (coprod.braiding Q P).hom = 𝟙 _ :=
coprod.symmetry' _ _

/-- The associator isomorphism for binary coproducts. -/
@[simps] def coprod.associator
  (P Q R : C) : (P ⨿ Q) ⨿ R ≅ P ⨿ (Q ⨿ R) :=
{ hom :=
  coprod.desc
    (coprod.desc coprod.inl (coprod.inl ≫ coprod.inr))
    (coprod.inr ≫ coprod.inr),
  inv :=
  coprod.desc
    (coprod.inl ≫ coprod.inl)
    (coprod.desc (coprod.inr ≫ coprod.inl) coprod.inr) }

lemma coprod.pentagon (W X Y Z : C) :
  coprod.map ((coprod.associator W X Y).hom) (𝟙 Z) ≫
      (coprod.associator W (X ⨿ Y) Z).hom ≫ coprod.map (𝟙 W) ((coprod.associator X Y Z).hom) =
    (coprod.associator (W ⨿ X) Y Z).hom ≫ (coprod.associator W X (Y ⨿ Z)).hom :=
by simp

lemma coprod.associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂)
  (f₃ : X₃ ⟶ Y₃) :
  coprod.map (coprod.map f₁ f₂) f₃ ≫ (coprod.associator Y₁ Y₂ Y₃).hom =
    (coprod.associator X₁ X₂ X₃).hom ≫ coprod.map f₁ (coprod.map f₂ f₃) :=
by simp

variables [has_initial C]

/-- The left unitor isomorphism for binary coproducts with the initial object. -/
@[simps] def coprod.left_unitor
  (P : C) : ⊥_ C ⨿ P ≅ P :=
{ hom := coprod.desc (initial.to P) (𝟙 _),
  inv := coprod.inr }

/-- The right unitor isomorphism for binary coproducts with the initial object. -/
@[simps] def coprod.right_unitor
  (P : C) : P ⨿ ⊥_ C ≅ P :=
{ hom := coprod.desc (𝟙 _) (initial.to P),
  inv := coprod.inl }

lemma coprod.triangle (X Y : C) :
  (coprod.associator X (⊥_ C) Y).hom ≫ coprod.map (𝟙 X) ((coprod.left_unitor Y).hom) =
    coprod.map ((coprod.right_unitor X).hom) (𝟙 Y) :=
by tidy

end

section prod_functor
variables {C} [has_binary_products C]

/-- The binary product functor. -/
@[simps]
def prod.functor : C ⥤ C ⥤ C :=
{ obj := λ X, { obj := λ Y, X ⨯ Y, map := λ Y Z, prod.map (𝟙 X) },
  map := λ Y Z f, { app := λ T, prod.map f (𝟙 T) }}

/-- The product functor can be decomposed. -/
def prod.functor_left_comp (X Y : C) :
  prod.functor.obj (X ⨯ Y) ≅ prod.functor.obj Y ⋙ prod.functor.obj X :=
nat_iso.of_components (prod.associator _ _) (by tidy)

end prod_functor

section coprod_functor
variables {C} [has_binary_coproducts C]

/-- The binary coproduct functor. -/
@[simps]
def coprod.functor : C ⥤ C ⥤ C :=
{ obj := λ X, { obj := λ Y, X ⨿ Y, map := λ Y Z, coprod.map (𝟙 X) },
  map := λ Y Z f, { app := λ T, coprod.map f (𝟙 T) }}

/-- The coproduct functor can be decomposed. -/
def coprod.functor_left_comp (X Y : C) :
  coprod.functor.obj (X ⨿ Y) ≅ coprod.functor.obj Y ⋙ coprod.functor.obj X :=
nat_iso.of_components (coprod.associator _ _) (by tidy)

end coprod_functor

section prod_comparison

universe w

variables {C} {D : Type u₂} [category.{w} D]
variables (F : C ⥤ D) {A A' B B' : C}
variables [has_binary_product A B] [has_binary_product A' B']
variables [has_binary_product (F.obj A) (F.obj B)] [has_binary_product (F.obj A') (F.obj B')]
/--
The product comparison morphism.

In `category_theory/limits/preserves` we show this is always an iso iff F preserves binary products.
-/
def prod_comparison (F : C ⥤ D) (A B : C)
  [has_binary_product A B] [has_binary_product (F.obj A) (F.obj B)] :
  F.obj (A ⨯ B) ⟶ F.obj A ⨯ F.obj B :=
prod.lift (F.map prod.fst) (F.map prod.snd)

@[simp, reassoc]
lemma prod_comparison_fst :
  prod_comparison F A B ≫ prod.fst = F.map prod.fst :=
prod.lift_fst _ _

@[simp, reassoc]
lemma prod_comparison_snd :
  prod_comparison F A B ≫ prod.snd = F.map prod.snd :=
prod.lift_snd _ _

/-- Naturality of the prod_comparison morphism in both arguments. -/
@[reassoc] lemma prod_comparison_natural (f : A ⟶ A') (g : B ⟶ B') :
  F.map (prod.map f g) ≫ prod_comparison F A' B' =
    prod_comparison F A B ≫ prod.map (F.map f) (F.map g) :=
begin
  rw [prod_comparison, prod_comparison, prod.lift_map, ← F.map_comp, ← F.map_comp,
      prod.comp_lift, ← F.map_comp, prod.map_fst, ← F.map_comp, prod.map_snd]
end

/--
The product comparison morphism from `F(A ⨯ -)` to `FA ⨯ F-`, whose components are given by
`prod_comparison`.
-/
@[simps]
def prod_comparison_nat_trans [has_binary_products C] [has_binary_products D]
  (F : C ⥤ D) (A : C) :
  prod.functor.obj A ⋙ F ⟶ F ⋙ prod.functor.obj (F.obj A) :=
{ app := λ B, prod_comparison F A B,
  naturality' := λ B B' f, by simp [prod_comparison_natural] }

@[reassoc]
lemma inv_prod_comparison_map_fst [is_iso (prod_comparison F A B)] :
  inv (prod_comparison F A B) ≫ F.map prod.fst = prod.fst :=
by simp [is_iso.inv_comp_eq]

@[reassoc]
lemma inv_prod_comparison_map_snd [is_iso (prod_comparison F A B)] :
  inv (prod_comparison F A B) ≫ F.map prod.snd = prod.snd :=
by simp [is_iso.inv_comp_eq]

/-- If the product comparison morphism is an iso, its inverse is natural. -/
@[reassoc]
lemma prod_comparison_inv_natural (f : A ⟶ A') (g : B ⟶ B')
  [is_iso (prod_comparison F A B)] [is_iso (prod_comparison F A' B')] :
  inv (prod_comparison F A B) ≫ F.map (prod.map f g) =
    prod.map (F.map f) (F.map g) ≫ inv (prod_comparison F A' B') :=
by rw [is_iso.eq_comp_inv, category.assoc, is_iso.inv_comp_eq, prod_comparison_natural]

/--
The natural isomorphism `F(A ⨯ -) ≅ FA ⨯ F-`, provided each `prod_comparison F A B` is an
isomorphism (as `B` changes).
-/
@[simps {rhs_md := semireducible}]
def prod_comparison_nat_iso [has_binary_products C] [has_binary_products D]
  (A : C) [∀ B, is_iso (prod_comparison F A B)] :
  prod.functor.obj A ⋙ F ≅ F ⋙ prod.functor.obj (F.obj A) :=
{ hom := prod_comparison_nat_trans F A
  ..(@as_iso _ _ _ _ _ (nat_iso.is_iso_of_is_iso_app ⟨_, _⟩)) }

end prod_comparison

section coprod_comparison

universe w

variables {C} {D : Type u₂} [category.{w} D]
variables (F : C ⥤ D) {A A' B B' : C}
variables [has_binary_coproduct A B] [has_binary_coproduct A' B']
variables [has_binary_coproduct (F.obj A) (F.obj B)] [has_binary_coproduct (F.obj A') (F.obj B')]
/--
The coproduct comparison morphism.

In `category_theory/limits/preserves` we show
this is always an iso iff F preserves binary coproducts.
-/
def coprod_comparison (F : C ⥤ D) (A B : C)
  [has_binary_coproduct A B] [has_binary_coproduct (F.obj A) (F.obj B)] :
  F.obj A ⨿ F.obj B ⟶ F.obj (A ⨿ B) :=
coprod.desc (F.map coprod.inl) (F.map coprod.inr)

@[simp, reassoc]
lemma coprod_comparison_inl :
  coprod.inl ≫ coprod_comparison F A B  = F.map coprod.inl :=
coprod.inl_desc _ _

@[simp, reassoc]
lemma coprod_comparison_inr :
  coprod.inr ≫ coprod_comparison F A B = F.map coprod.inr :=
coprod.inr_desc _ _

/-- Naturality of the coprod_comparison morphism in both arguments. -/
@[reassoc] lemma coprod_comparison_natural (f : A ⟶ A') (g : B ⟶ B') :
  coprod_comparison F A B ≫ F.map (coprod.map f g) =
    coprod.map (F.map f) (F.map g) ≫ coprod_comparison F A' B' :=
begin
  rw [coprod_comparison, coprod_comparison, coprod.map_desc, ← F.map_comp, ← F.map_comp,
      coprod.desc_comp, ← F.map_comp, coprod.inl_map, ← F.map_comp, coprod.inr_map]
end

/--
The coproduct comparison morphism from `FA ⨿ F-` to `F(A ⨿ -)`, whose components are given by
`coprod_comparison`.
-/
@[simps]
def coprod_comparison_nat_trans [has_binary_coproducts C] [has_binary_coproducts D]
  (F : C ⥤ D) (A : C) :
  F ⋙ coprod.functor.obj (F.obj A) ⟶ coprod.functor.obj A ⋙ F :=
{ app := λ B, coprod_comparison F A B,
  naturality' := λ B B' f, by simp [coprod_comparison_natural] }

@[reassoc]
lemma map_inl_inv_coprod_comparison [is_iso (coprod_comparison F A B)] :
  F.map coprod.inl ≫ inv (coprod_comparison F A B) = coprod.inl :=
by simp [is_iso.inv_comp_eq]

@[reassoc]
lemma map_inr_inv_coprod_comparison [is_iso (coprod_comparison F A B)] :
  F.map coprod.inr ≫ inv (coprod_comparison F A B) = coprod.inr :=
by simp [is_iso.inv_comp_eq]

/-- If the coproduct comparison morphism is an iso, its inverse is natural. -/
@[reassoc]
lemma coprod_comparison_inv_natural (f : A ⟶ A') (g : B ⟶ B')
  [is_iso (coprod_comparison F A B)] [is_iso (coprod_comparison F A' B')] :
  inv (coprod_comparison F A B) ≫ coprod.map (F.map f) (F.map g) =
    F.map (coprod.map f g) ≫ inv (coprod_comparison F A' B') :=
by rw [is_iso.eq_comp_inv, category.assoc, is_iso.inv_comp_eq, coprod_comparison_natural]

/--
The natural isomorphism `FA ⨿ F- ≅ F(A ⨿ -)`, provided each `coprod_comparison F A B` is an
isomorphism (as `B` changes).
-/
@[simps {rhs_md := semireducible}]
def coprod_comparison_nat_iso [has_binary_coproducts C] [has_binary_coproducts D]
  (A : C) [∀ B, is_iso (coprod_comparison F A B)] :
  F ⋙ coprod.functor.obj (F.obj A) ≅ coprod.functor.obj A ⋙ F :=
{ hom := coprod_comparison_nat_trans F A
  ..(@as_iso _ _ _ _ _ (nat_iso.is_iso_of_is_iso_app ⟨_, _⟩)) }

end coprod_comparison

end category_theory.limits

open category_theory.limits

namespace category_theory

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

/-- Auxiliary definition for `over.coprod`. -/
@[simps]
def over.coprod_obj [has_binary_coproducts C] {A : C} : over A → over A ⥤ over A := λ f,
{ obj := λ g, over.mk (coprod.desc f.hom g.hom),
  map := λ g₁ g₂ k, over.hom_mk (coprod.map (𝟙 _) k.left) }

/-- A category with binary coproducts has a functorial `sup` operation on over categories. -/
@[simps]
def over.coprod [has_binary_coproducts C] {A : C} : over A ⥤ over A ⥤ over A :=
{ obj := λ f, over.coprod_obj f,
  map := λ f₁ f₂ k,
  { app := λ g, over.hom_mk (coprod.map k.left (𝟙 _))
      (by { dsimp, rw [coprod.map_desc, category.id_comp, over.w k] }),
    naturality' := λ f g k, by ext; { dsimp, simp, }, },
  map_id' := λ X, by ext; { dsimp, simp, },
  map_comp' := λ X Y Z f g, by ext; { dsimp, simp, }, }.

end category_theory


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

! This file was ported from Lean 3 source module algebra.order.pi
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Order.Ring.Defs
import Mathbin.Algebra.Ring.Pi
import Mathbin.Tactic.Positivity

/-!
# Pi instances for ordered groups and monoids

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

This file defines instances for ordered group, monoid, and related structures on Pi types.
-/

universe u v w

variable {ι α β : Type _}

variable {I : Type u}

-- The indexing type
variable {f : I → Type v}

-- The family of types already equipped with instances
variable (x y : ∀ i, f i) (i : I)

namespace Pi

#print Pi.orderedCommMonoid /-
/-- The product of a family of ordered commutative monoids is an ordered commutative monoid. -/
@[to_additive
      "The product of a family of ordered additive commutative monoids is\n  an ordered additive commutative monoid."]
instance orderedCommMonoid {ι : Type _} {Z : ι → Type _} [∀ i, OrderedCommMonoid (Z i)] :
    OrderedCommMonoid (∀ i, Z i) :=
  { Pi.partialOrder, Pi.commMonoid with
    mul_le_mul_left := fun f g w h i => mul_le_mul_left' (w i) _ }
#align pi.ordered_comm_monoid Pi.orderedCommMonoid
#align pi.ordered_add_comm_monoid Pi.orderedAddCommMonoid
-/

@[to_additive]
instance {ι : Type _} {α : ι → Type _} [∀ i, LE (α i)] [∀ i, Mul (α i)] [∀ i, ExistsMulOfLE (α i)] :
    ExistsMulOfLE (∀ i, α i) :=
  ⟨fun a b h =>
    ⟨fun i => (exists_mul_of_le <| h i).some,
      funext fun i => (exists_mul_of_le <| h i).choose_spec⟩⟩

/-- The product of a family of canonically ordered monoids is a canonically ordered monoid. -/
@[to_additive
      "The product of a family of canonically ordered additive monoids is\n  a canonically ordered additive monoid."]
instance {ι : Type _} {Z : ι → Type _} [∀ i, CanonicallyOrderedMonoid (Z i)] :
    CanonicallyOrderedMonoid (∀ i, Z i) :=
  { Pi.orderBot, Pi.orderedCommMonoid, Pi.existsMulOfLe with
    le_self_mul := fun f g i => le_self_mul }

#print Pi.orderedCancelCommMonoid /-
@[to_additive]
instance orderedCancelCommMonoid [∀ i, OrderedCancelCommMonoid <| f i] :
    OrderedCancelCommMonoid (∀ i : I, f i) := by
  refine_struct
      { Pi.partialOrder, Pi.monoid with
        mul := (· * ·)
        one := (1 : ∀ i, f i)
        le := (· ≤ ·)
        lt := (· < ·)
        npow := Monoid.npow } <;>
    pi_instance_derive_field
#align pi.ordered_cancel_comm_monoid Pi.orderedCancelCommMonoid
#align pi.ordered_cancel_add_comm_monoid Pi.orderedAddCancelCommMonoid
-/

#print Pi.orderedCommGroup /-
@[to_additive]
instance orderedCommGroup [∀ i, OrderedCommGroup <| f i] : OrderedCommGroup (∀ i : I, f i) :=
  { Pi.commGroup, Pi.orderedCommMonoid with
    mul := (· * ·)
    one := (1 : ∀ i, f i)
    le := (· ≤ ·)
    lt := (· < ·)
    npow := Monoid.npow }
#align pi.ordered_comm_group Pi.orderedCommGroup
#align pi.ordered_add_comm_group Pi.orderedAddCommGroup
-/

instance [∀ i, OrderedSemiring (f i)] : OrderedSemiring (∀ i, f i) :=
  { Pi.semiring,
    Pi.partialOrder with
    add_le_add_left := fun a b hab c i => add_le_add_left (hab _) _
    zero_le_one := fun _ => zero_le_one
    mul_le_mul_of_nonneg_left := fun a b c hab hc i => mul_le_mul_of_nonneg_left (hab _) <| hc _
    mul_le_mul_of_nonneg_right := fun a b c hab hc i => mul_le_mul_of_nonneg_right (hab _) <| hc _ }

instance [∀ i, OrderedCommSemiring (f i)] : OrderedCommSemiring (∀ i, f i) :=
  { Pi.commSemiring, Pi.orderedSemiring with }

instance [∀ i, OrderedRing (f i)] : OrderedRing (∀ i, f i) :=
  { Pi.ring, Pi.orderedSemiring with mul_nonneg := fun a b ha hb i => mul_nonneg (ha _) (hb _) }

instance [∀ i, OrderedCommRing (f i)] : OrderedCommRing (∀ i, f i) :=
  { Pi.commRing, Pi.orderedRing with }

end Pi

namespace Function

variable (β) [One α] [Preorder α] {a : α}

/- warning: function.one_le_const_of_one_le -> Function.one_le_const_of_one_le is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (β : Type.{u2}) [_inst_1 : One.{u1} α] [_inst_2 : Preorder.{u1} α] {a : α}, (LE.le.{u1} α (Preorder.toLE.{u1} α _inst_2) (OfNat.ofNat.{u1} α 1 (OfNat.mk.{u1} α 1 (One.one.{u1} α _inst_1))) a) -> (LE.le.{max u2 u1} (β -> α) (Pi.hasLe.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => Preorder.toLE.{u1} α _inst_2)) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (OfNat.mk.{max u2 u1} (β -> α) 1 (One.one.{max u2 u1} (β -> α) (Pi.instOne.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_1))))) (Function.const.{succ u1, succ u2} α β a))
but is expected to have type
  forall {α : Type.{u2}} (β : Type.{u1}) [_inst_1 : One.{u2} α] [_inst_2 : Preorder.{u2} α] {a : α}, (LE.le.{u2} α (Preorder.toLE.{u2} α _inst_2) (OfNat.ofNat.{u2} α 1 (One.toOfNat1.{u2} α _inst_1)) a) -> (LE.le.{max u2 u1} (β -> α) (Pi.hasLe.{u1, u2} β (fun (ᾰ : β) => α) (fun (i : β) => Preorder.toLE.{u2} α _inst_2)) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (One.toOfNat1.{max u2 u1} (β -> α) (Pi.instOne.{u1, u2} β (fun (a._@.Init.Prelude._hyg.54 : β) => α) (fun (i : β) => _inst_1)))) (Function.const.{succ u2, succ u1} α β a))
Case conversion may be inaccurate. Consider using '#align function.one_le_const_of_one_le Function.one_le_const_of_one_leₓ'. -/
@[to_additive const_nonneg_of_nonneg]
theorem one_le_const_of_one_le (ha : 1 ≤ a) : 1 ≤ const β a := fun _ => ha
#align function.one_le_const_of_one_le Function.one_le_const_of_one_le
#align function.const_nonneg_of_nonneg Function.const_nonneg_of_nonneg

/- warning: function.const_le_one_of_le_one -> Function.const_le_one_of_le_one is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (β : Type.{u2}) [_inst_1 : One.{u1} α] [_inst_2 : Preorder.{u1} α] {a : α}, (LE.le.{u1} α (Preorder.toLE.{u1} α _inst_2) a (OfNat.ofNat.{u1} α 1 (OfNat.mk.{u1} α 1 (One.one.{u1} α _inst_1)))) -> (LE.le.{max u2 u1} (β -> α) (Pi.hasLe.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => Preorder.toLE.{u1} α _inst_2)) (Function.const.{succ u1, succ u2} α β a) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (OfNat.mk.{max u2 u1} (β -> α) 1 (One.one.{max u2 u1} (β -> α) (Pi.instOne.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_1))))))
but is expected to have type
  forall {α : Type.{u2}} (β : Type.{u1}) [_inst_1 : One.{u2} α] [_inst_2 : Preorder.{u2} α] {a : α}, (LE.le.{u2} α (Preorder.toLE.{u2} α _inst_2) a (OfNat.ofNat.{u2} α 1 (One.toOfNat1.{u2} α _inst_1))) -> (LE.le.{max u2 u1} (β -> α) (Pi.hasLe.{u1, u2} β (fun (ᾰ : β) => α) (fun (i : β) => Preorder.toLE.{u2} α _inst_2)) (Function.const.{succ u2, succ u1} α β a) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (One.toOfNat1.{max u2 u1} (β -> α) (Pi.instOne.{u1, u2} β (fun (a._@.Init.Prelude._hyg.54 : β) => α) (fun (i : β) => _inst_1)))))
Case conversion may be inaccurate. Consider using '#align function.const_le_one_of_le_one Function.const_le_one_of_le_oneₓ'. -/
@[to_additive]
theorem const_le_one_of_le_one (ha : a ≤ 1) : const β a ≤ 1 := fun _ => ha
#align function.const_le_one_of_le_one Function.const_le_one_of_le_one
#align function.const_nonpos_of_nonpos Function.const_nonpos_of_nonpos

variable {β} [Nonempty β]

/- warning: function.one_le_const -> Function.one_le_const is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : One.{u1} α] [_inst_2 : Preorder.{u1} α] {a : α} [_inst_3 : Nonempty.{succ u2} β], Iff (LE.le.{max u2 u1} (β -> α) (Pi.hasLe.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => Preorder.toLE.{u1} α _inst_2)) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (OfNat.mk.{max u2 u1} (β -> α) 1 (One.one.{max u2 u1} (β -> α) (Pi.instOne.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_1))))) (Function.const.{succ u1, succ u2} α β a)) (LE.le.{u1} α (Preorder.toLE.{u1} α _inst_2) (OfNat.ofNat.{u1} α 1 (OfNat.mk.{u1} α 1 (One.one.{u1} α _inst_1))) a)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : One.{u2} α] [_inst_2 : Preorder.{u2} α] {a : α} [_inst_3 : Nonempty.{succ u1} β], Iff (LE.le.{max u2 u1} (β -> α) (Pi.hasLe.{u1, u2} β (fun (ᾰ : β) => α) (fun (i : β) => Preorder.toLE.{u2} α _inst_2)) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (One.toOfNat1.{max u2 u1} (β -> α) (Pi.instOne.{u1, u2} β (fun (a._@.Init.Prelude._hyg.54 : β) => α) (fun (i : β) => _inst_1)))) (Function.const.{succ u2, succ u1} α β a)) (LE.le.{u2} α (Preorder.toLE.{u2} α _inst_2) (OfNat.ofNat.{u2} α 1 (One.toOfNat1.{u2} α _inst_1)) a)
Case conversion may be inaccurate. Consider using '#align function.one_le_const Function.one_le_constₓ'. -/
@[simp, to_additive const_nonneg]
theorem one_le_const : 1 ≤ const β a ↔ 1 ≤ a :=
  @const_le_const _ _ _ _ 1 _
#align function.one_le_const Function.one_le_const
#align function.const_nonneg Function.const_nonneg

/- warning: function.one_lt_const -> Function.one_lt_const is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : One.{u1} α] [_inst_2 : Preorder.{u1} α] {a : α} [_inst_3 : Nonempty.{succ u2} β], Iff (LT.lt.{max u2 u1} (β -> α) (Preorder.toLT.{max u2 u1} (β -> α) (Pi.preorder.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_2))) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (OfNat.mk.{max u2 u1} (β -> α) 1 (One.one.{max u2 u1} (β -> α) (Pi.instOne.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_1))))) (Function.const.{succ u1, succ u2} α β a)) (LT.lt.{u1} α (Preorder.toLT.{u1} α _inst_2) (OfNat.ofNat.{u1} α 1 (OfNat.mk.{u1} α 1 (One.one.{u1} α _inst_1))) a)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : One.{u2} α] [_inst_2 : Preorder.{u2} α] {a : α} [_inst_3 : Nonempty.{succ u1} β], Iff (LT.lt.{max u2 u1} (β -> α) (Preorder.toLT.{max u2 u1} (β -> α) (Pi.preorder.{u1, u2} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_2))) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (One.toOfNat1.{max u2 u1} (β -> α) (Pi.instOne.{u1, u2} β (fun (a._@.Init.Prelude._hyg.54 : β) => α) (fun (i : β) => _inst_1)))) (Function.const.{succ u2, succ u1} α β a)) (LT.lt.{u2} α (Preorder.toLT.{u2} α _inst_2) (OfNat.ofNat.{u2} α 1 (One.toOfNat1.{u2} α _inst_1)) a)
Case conversion may be inaccurate. Consider using '#align function.one_lt_const Function.one_lt_constₓ'. -/
@[simp, to_additive const_pos]
theorem one_lt_const : 1 < const β a ↔ 1 < a :=
  @const_lt_const _ _ _ _ 1 a
#align function.one_lt_const Function.one_lt_const
#align function.const_pos Function.const_pos

/- warning: function.const_le_one -> Function.const_le_one is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : One.{u1} α] [_inst_2 : Preorder.{u1} α] {a : α} [_inst_3 : Nonempty.{succ u2} β], Iff (LE.le.{max u2 u1} (β -> α) (Pi.hasLe.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => Preorder.toLE.{u1} α _inst_2)) (Function.const.{succ u1, succ u2} α β a) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (OfNat.mk.{max u2 u1} (β -> α) 1 (One.one.{max u2 u1} (β -> α) (Pi.instOne.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_1)))))) (LE.le.{u1} α (Preorder.toLE.{u1} α _inst_2) a (OfNat.ofNat.{u1} α 1 (OfNat.mk.{u1} α 1 (One.one.{u1} α _inst_1))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : One.{u2} α] [_inst_2 : Preorder.{u2} α] {a : α} [_inst_3 : Nonempty.{succ u1} β], Iff (LE.le.{max u2 u1} (β -> α) (Pi.hasLe.{u1, u2} β (fun (ᾰ : β) => α) (fun (i : β) => Preorder.toLE.{u2} α _inst_2)) (Function.const.{succ u2, succ u1} α β a) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (One.toOfNat1.{max u2 u1} (β -> α) (Pi.instOne.{u1, u2} β (fun (a._@.Init.Prelude._hyg.54 : β) => α) (fun (i : β) => _inst_1))))) (LE.le.{u2} α (Preorder.toLE.{u2} α _inst_2) a (OfNat.ofNat.{u2} α 1 (One.toOfNat1.{u2} α _inst_1)))
Case conversion may be inaccurate. Consider using '#align function.const_le_one Function.const_le_oneₓ'. -/
@[simp, to_additive]
theorem const_le_one : const β a ≤ 1 ↔ a ≤ 1 :=
  @const_le_const _ _ _ _ _ 1
#align function.const_le_one Function.const_le_one
#align function.const_nonpos Function.const_nonpos

/- warning: function.const_lt_one -> Function.const_lt_one is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : One.{u1} α] [_inst_2 : Preorder.{u1} α] {a : α} [_inst_3 : Nonempty.{succ u2} β], Iff (LT.lt.{max u2 u1} (β -> α) (Preorder.toLT.{max u2 u1} (β -> α) (Pi.preorder.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_2))) (Function.const.{succ u1, succ u2} α β a) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (OfNat.mk.{max u2 u1} (β -> α) 1 (One.one.{max u2 u1} (β -> α) (Pi.instOne.{u2, u1} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_1)))))) (LT.lt.{u1} α (Preorder.toLT.{u1} α _inst_2) a (OfNat.ofNat.{u1} α 1 (OfNat.mk.{u1} α 1 (One.one.{u1} α _inst_1))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : One.{u2} α] [_inst_2 : Preorder.{u2} α] {a : α} [_inst_3 : Nonempty.{succ u1} β], Iff (LT.lt.{max u2 u1} (β -> α) (Preorder.toLT.{max u2 u1} (β -> α) (Pi.preorder.{u1, u2} β (fun (ᾰ : β) => α) (fun (i : β) => _inst_2))) (Function.const.{succ u2, succ u1} α β a) (OfNat.ofNat.{max u2 u1} (β -> α) 1 (One.toOfNat1.{max u2 u1} (β -> α) (Pi.instOne.{u1, u2} β (fun (a._@.Init.Prelude._hyg.54 : β) => α) (fun (i : β) => _inst_1))))) (LT.lt.{u2} α (Preorder.toLT.{u2} α _inst_2) a (OfNat.ofNat.{u2} α 1 (One.toOfNat1.{u2} α _inst_1)))
Case conversion may be inaccurate. Consider using '#align function.const_lt_one Function.const_lt_oneₓ'. -/
@[simp, to_additive]
theorem const_lt_one : const β a < 1 ↔ a < 1 :=
  @const_lt_const _ _ _ _ _ 1
#align function.const_lt_one Function.const_lt_one
#align function.const_neg Function.const_neg

end Function

namespace Tactic

open Function Positivity

variable (ι) [Zero α] {a : α}

private theorem function_const_nonneg_of_pos [Preorder α] (ha : 0 < a) : 0 ≤ const ι a :=
  const_nonneg_of_nonneg _ ha.le
#align tactic.function_const_nonneg_of_pos tactic.function_const_nonneg_of_pos

variable [Nonempty ι]

private theorem function_const_ne_zero : a ≠ 0 → const ι a ≠ 0 :=
  const_ne_zero.2
#align tactic.function_const_ne_zero tactic.function_const_ne_zero

private theorem function_const_pos [Preorder α] : 0 < a → 0 < const ι a :=
  const_pos.2
#align tactic.function_const_pos tactic.function_const_pos

/-- Extension for the `positivity` tactic: `function.const` is positive/nonnegative/nonzero if its
input is. -/
@[positivity]
unsafe def positivity_const : expr → tactic strictness
  | q(Function.const $(ι) $(a)) => do
    let strict_a ← core a
    match strict_a with
      | positive p =>
        positive <$> to_expr ``(function_const_pos $(ι) $(p)) <|>
          nonnegative <$> to_expr ``(function_const_nonneg_of_pos $(ι) $(p))
      | nonnegative p => nonnegative <$> to_expr ``(const_nonneg_of_nonneg $(ι) $(p))
      | nonzero p => nonzero <$> to_expr ``(function_const_ne_zero $(ι) $(p))
  | e =>
    pp e >>= fail ∘ format.bracket "The expression `" "` is not of the form `function.const ι a`"
#align tactic.positivity_const tactic.positivity_const

end Tactic


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import group_theory.group_action.defs

/-!
# Sum instances for additive and multiplicative actions

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

This file defines instances for additive and multiplicative actions on the binary `sum` type.

## See also

* `group_theory.group_action.option`
* `group_theory.group_action.pi`
* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
-/

variables {M N P α β γ : Type*}

namespace sum

section has_smul
variables [has_smul M α] [has_smul M β] [has_smul N α] [has_smul N β] (a : M) (b : α)
  (c : β) (x : α ⊕ β)

@[to_additive sum.has_vadd] instance : has_smul M (α ⊕ β) := ⟨λ a, sum.map ((•) a) ((•) a)⟩

@[to_additive] lemma smul_def : a • x = x.map ((•) a) ((•) a) := rfl
@[simp, to_additive] lemma smul_inl : a • (inl b : α ⊕ β) = inl (a • b) := rfl
@[simp, to_additive] lemma smul_inr : a • (inr c : α ⊕ β) = inr (a • c) := rfl
@[simp, to_additive] lemma smul_swap : (a • x).swap = a • x.swap := by cases x; refl

instance [has_smul M N] [is_scalar_tower M N α] [is_scalar_tower M N β] :
  is_scalar_tower M N (α ⊕ β) :=
⟨λ a b x,
  by { cases x, exacts [congr_arg inl (smul_assoc _ _ _), congr_arg inr (smul_assoc _ _ _)] }⟩

@[to_additive] instance [smul_comm_class M N α] [smul_comm_class M N β] :
  smul_comm_class M N (α ⊕ β) :=
⟨λ a b x,
  by { cases x, exacts [congr_arg inl (smul_comm _ _ _), congr_arg inr (smul_comm _ _ _)] }⟩

@[to_additive]
instance [has_smul Mᵐᵒᵖ α] [has_smul Mᵐᵒᵖ β] [is_central_scalar M α] [is_central_scalar M β] :
  is_central_scalar M (α ⊕ β) :=
⟨λ a x,
  by { cases x, exacts [congr_arg inl (op_smul_eq_smul _ _), congr_arg inr (op_smul_eq_smul _ _)] }⟩

@[to_additive] instance has_faithful_smul_left [has_faithful_smul M α] :
  has_faithful_smul M (α ⊕ β) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ a : α, by injection h (inl a)⟩

@[to_additive] instance has_faithful_smul_right [has_faithful_smul M β] :
  has_faithful_smul M (α ⊕ β) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ b : β, by injection h (inr b)⟩

end has_smul

@[to_additive] instance {m : monoid M} [mul_action M α] [mul_action M β] : mul_action M (α ⊕ β) :=
{ mul_smul := λ a b x,
    by { cases x, exacts [congr_arg inl (mul_smul _ _ _), congr_arg inr (mul_smul _ _ _)] },
  one_smul := λ x,
    by { cases x, exacts [congr_arg inl (one_smul _ _), congr_arg inr (one_smul _ _)] } }

end sum


/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg, Asta H. From
-/

import Aesop

set_option aesop.check.all true

inductive All (P : α → Prop) : List α → Prop where
  | none : All P []
  | more {x xs} : P x → All P xs → All P (x :: xs)

@[aesop unsafe]
axiom weaken {α} (P Q : α → Prop) (wk : ∀ x, P x → Q x) (xs : List α)
  (h : All P xs) : All Q xs

example : All (· ∈ []) (@List.nil α) := by
  aesop (options := { maxRuleApplications := 50, terminal := true })


abbrev VName := String

inductive Ty where
  | Bool
  | Int

def Ctxt := VName → Option Ty

variable (Γ : Ctxt) in
inductive Expr : Ty → Type where
  | var (h : Γ x = some τ) : Expr τ

def Expr.constFold : Expr Γ τ → Option Unit
  | var n   => none

theorem Expr.constFold_sound {e : Expr Γ τ} : constFold e = some v → True := by
  intro h
  induction e with
  | var   => simp only [constFold] at h


import category_theory.limits.fubini

import for_mathlib.Profinite.extend
import for_mathlib.AddCommGroup.exact
import for_mathlib.limit_flip_comp_iso

import condensed.ab
import pseudo_normed_group.bounded_limits
import condensed.extr.lift_comphaus
import condensed.projective_resolution
import condensed.kernel_comparison

.

universes u v

noncomputable theory

open_locale nnreal

open category_theory category_theory.limits opposite pseudo_normed_group

-- move me
namespace CompHaus

variables {J : Type u} [small_category J]
  (F G : J ⥤ CompHaus.{u}) (α : F ⟶ G)
variables (cF : cone F) (cG : cone G) (hcF : is_limit cF) (hcG : is_limit cG)

def pt {X : CompHaus.{u}} (x : X) : (⊤_ CompHaus) ⟶ X :=
⟨λ _, x, continuous_const⟩

@[simps] def diagram_of_pt (y : cG.X) : J ⥤ CompHaus.{u} :=
{ obj := λ j, pullback (α.app j) (pt y ≫ cG.π.app j),
  map := λ i j f, pullback.lift (pullback.fst ≫ F.map f) pullback.snd
    (by rw [category.assoc, α.naturality, pullback.condition_assoc, category.assoc, cG.w]),
  map_id' := λ j, by apply pullback.hom_ext; dsimp; simp,
  map_comp' := λ i j k f g, by { apply pullback.hom_ext; dsimp; simp } }

.

@[simps] def cone_of_pt (y : cG.X) : cone (diagram_of_pt F G α cG y) :=
{ X := pullback (hcG.map cF α) (pt y),
  π :=
  { app := λ j, pullback.lift
      (pullback.fst ≫ cF.π.app _)
      pullback.snd
      (by rw [category.assoc, ← pullback.condition_assoc, is_limit.map_π]),
    naturality' := λ i j f, by apply pullback.hom_ext; dsimp; simp } }

.

def is_limit_cone_of_pt (y : cG.X) : is_limit (cone_of_pt F G α cF cG hcG y) :=
{ lift := λ S, pullback.lift
    (hcF.lift ⟨S.X,
    { app := λ j, S.π.app j ≫ pullback.fst,
      naturality' := begin
        intros i j f,
        dsimp,
        rw ← S.w f, dsimp [diagram_of_pt],
        simp only [category.id_comp, category.assoc, pullback.lift_fst],
      end }⟩)
    (terminal.from _)
    begin
      apply hcG.hom_ext, intros j, dsimp,
      simp only [category.assoc, is_limit.map_π, is_limit.fac_assoc, pullback.condition],
      ext, refl,
    end,
  fac' := begin
    intros s j, dsimp, apply pullback.hom_ext,
    { simp only [category.assoc, pullback.lift_fst, pullback.lift_fst_assoc, is_limit.fac] },
    { simp only [eq_iff_true_of_subsingleton] },
  end,
  uniq' := begin
    intros s m hm,
    dsimp at m hm,
    apply pullback.hom_ext,
    { rw pullback.lift_fst,
      apply hcF.hom_ext, intros j,
      simp only [category.assoc, is_limit.fac, ← hm j, pullback.lift_fst] },
    { simp only [eq_iff_true_of_subsingleton] }
  end }

lemma is_limit.surjective_of_surjective [is_cofiltered J]
  (hα : ∀ j, function.surjective (α.app j)) :
  function.surjective (hcG.map cF α) := λ y,
let E := cone_of_pt F G α cF cG hcG y,
  hE : is_limit E := is_limit_cone_of_pt F G α cF cG hcF hcG y in
begin
  suffices : ∃ (e : (⊤_ CompHaus.{u}) ⟶ E.X),
    e ≫ (pullback.fst : E.X ⟶ cF.X) ≫ hcG.map cF α = pt y,
  { obtain ⟨e,he⟩ := this,
    use (terminal.from (CompHaus.of punit) ≫ e ≫ pullback.fst) punit.star,
    rw ← comp_apply,
    have : y = (terminal.from (CompHaus.of punit) ≫ pt y) punit.star := rfl,
    conv_rhs { rw this }, clear this, congr' 1,
    apply hcG.hom_ext,
    intros j,
    simp only [←he, category.assoc] },
  let E' := CompHaus_to_Top.map_cone E,
  let hE' : is_limit E' := is_limit_of_preserves CompHaus_to_Top hE,
  let ee : E' ≅ Top.limit_cone.{u u} _ :=
    hE'.unique_up_to_iso (Top.limit_cone_is_limit _),
  let e : E'.X ≅ (Top.limit_cone.{u u} _).X :=
    hE'.cone_point_unique_up_to_iso (Top.limit_cone_is_limit _),
  haveI : ∀ j : J, t2_space (((diagram_of_pt F G α cG y ⋙ CompHaus_to_Top).obj j)),
  { intros j, change t2_space ((diagram_of_pt F G α cG y).obj j), apply_instance },
  haveI : ∀ j : J, compact_space (((diagram_of_pt F G α cG y ⋙ CompHaus_to_Top).obj j)),
  { intros j, change compact_space ((diagram_of_pt F G α cG y).obj j), apply_instance },
  haveI : ∀ j : J, nonempty (((diagram_of_pt F G α cG y ⋙ CompHaus_to_Top).obj j)),
  { intro j, change nonempty ((diagram_of_pt F G α cG y).obj j),
    dsimp only [diagram_of_pt_obj],
    let y' := (terminal.from (CompHaus.of punit) ≫ pt y ≫ cG.π.app j) punit.star,
    obtain ⟨x', hx'⟩ := hα j y',
    refine ⟨(terminal.from (CompHaus.of punit) ≫ pullback.lift (pt x') (𝟙 _) _) punit.star⟩,
    ext z, exact hx', },
  have := Top.nonempty_limit_cone_of_compact_t2_cofiltered_system
    (diagram_of_pt F G α cG y ⋙ CompHaus_to_Top),
  obtain ⟨a⟩ := this,
  let b := e.inv a,
  use pt b,
  rw pullback.condition,
  refl,
end

-- Scott: perhaps life is easier if we use this version? I'm not too sure.
lemma is_limit.surjective_of_surjective' [is_cofiltered J]
  (hα : ∀ j, function.surjective (α.app j)) :
   function.surjective (lim_map α) :=
is_limit.surjective_of_surjective _ _ _ _ _ (limit.is_limit _) _ hα

end CompHaus

namespace CompHausFiltPseuNormGrp₁

-- move this
instance : has_zero_morphisms (CompHausFiltPseuNormGrp₁.{u}) :=
{ has_zero := λ M₁ M₂, ⟨0⟩,
  comp_zero' := λ _ _ f _, rfl,
  zero_comp' := λ _ _ _ f, by { ext, exact f.map_zero } }
variables {A B C : CompHausFiltPseuNormGrp₁.{u}}

structure exact_with_constant (f : A ⟶ B) (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0) : Prop :=
(comp_eq_zero : f ≫ g = 0)
(cond : ∀ c : ℝ≥0, g ⁻¹' {0} ∩ (filtration B c) ⊆ f '' (filtration A (r c)))
(large : id ≤ r)

lemma exact_with_constant.exact {f : A ⟶ B} {g : B ⟶ C} {r : ℝ≥0 → ℝ≥0}
  (h : exact_with_constant f g r) :
  exact ((to_PNG₁ ⋙ PseuNormGrp₁.to_Ab).map f) ((to_PNG₁ ⋙ PseuNormGrp₁.to_Ab).map g) :=
begin
  rw AddCommGroup.exact_iff',
  split,
  { ext x, have := h.comp_eq_zero, apply_fun (λ φ, φ.to_fun) at this, exact congr_fun this x },
  { intros y hy,
    obtain ⟨c, hc⟩ := B.exhaustive y,
    obtain ⟨a, ha, rfl⟩ := h.cond c ⟨_, hc⟩,
    { exact ⟨a, rfl⟩ },
    { simp only [set.mem_preimage, set.mem_singleton_iff], exact hy } },
end

-- TODO remove this; it's a redundant alias
@[simps obj_obj obj_map_apply map_app {fully_applied := ff}]
def Filtration : ℝ≥0 ⥤ CompHausFiltPseuNormGrp₁.{u} ⥤ CompHaus.{u} :=
CompHausFiltPseuNormGrp₁.level

instance mono_Filtration_map_app (c₁ c₂ : ℝ≥0) (h : c₁ ⟶ c₂) (M) :
  mono ((Filtration.map h).app M) :=
by { rw CompHaus.mono_iff_injective, convert injective_cast_le _ _ }

namespace exact_with_constant
noncomputable theory

variables (f : A ⟶ B) (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0) (c : ℝ≥0) (hrc : c ≤ r c)

variables {r c}

def c_le_rc : c ⟶ r c := hom_of_le $ hrc

/-- Given `f : A ⟶ B`, `P1` is the pullback `B_c ×_{B_{rc}} A_{rc}`. -/
def P1 : CompHaus :=
pullback ((Filtration.map (c_le_rc hrc)).app B) ((Filtration.obj (r c)).map f)

@[simps]
def pt {X : CompHaus} (x : X) : (⊤_ CompHaus) ⟶ X :=
⟨λ _, x, continuous_const⟩

/-- Given `g : B ⟶ C`, `P2` is the pullback `B_c ×_{C_c} {pt}`. -/
def P2 (c : ℝ≥0) : CompHaus :=
pullback ((Filtration.obj c).map g) (pt (0 : pseudo_normed_group.filtration C c))

def P1_to_P2 (hfg : f ≫ g = 0) : P1 f hrc ⟶ P2 g c :=
pullback.lift pullback.fst (terminal.from _)
begin
  rw [← cancel_mono ((Filtration.map (c_le_rc hrc)).app C), category.assoc,
    nat_trans.naturality, pullback.condition_assoc, ← functor.map_comp, hfg],
  refl,
end

lemma P1_to_P2_comp_fst (hfg : f ≫ g = 0) :
  P1_to_P2 f g hrc hfg ≫ pullback.fst = pullback.fst :=
pullback.lift_fst _ _ _

lemma surjective (h : exact_with_constant f g r) :
  ∃ (hfg : f ≫ g = 0), ∀ c, function.surjective (P1_to_P2 f g (h.large c) hfg) :=
begin
  have hfg : f ≫ g = 0,
  { ext x, exact fun_like.congr_fun h.exact.w x },
  refine ⟨hfg, _⟩,
  intros c y,
  let π₁ : P2 g c ⟶ (Filtration.obj c).obj B := pullback.fst,
  have hy : (π₁ y).val ∈ g ⁻¹' {0} ∩ filtration B c,
  asyncI
  { refine ⟨_, (π₁ y).2⟩,
    simp only [subtype.val_eq_coe, set.mem_preimage, set.mem_singleton_iff],
    have w := @pullback.condition _ _ _ _ _
      ((Filtration.obj c).map g) (pt (0 : pseudo_normed_group.filtration C c)) _,
    have := (fun_like.congr_fun w y),
    exact congr_arg subtype.val this, },
  obtain ⟨x, hx, hfx⟩ := h.cond c hy,
  let s : CompHaus.of punit ⟶ P1 f (h.large c) :=
  terminal.from _ ≫ pullback.lift (pt (π₁ y)) (pt ⟨x, hx⟩) _,
  swap, { ext t, exact hfx.symm },
  refine ⟨s punit.star, _⟩,
  suffices : s ≫ P1_to_P2 f g (h.large c) hfg = terminal.from _ ≫ pt y,
  { exact fun_like.congr_fun this punit.star },
  delta P1_to_P2,
  apply category_theory.limits.pullback.hom_ext,
  { simp only [category.assoc, pullback.lift_fst], refl },
  { exact subsingleton.elim _ _ }
end

lemma of_surjective (hfg : f ≫ g = 0) (hr : id ≤ r)
  (h : ∀ c, function.surjective (P1_to_P2 f g (hr c) hfg)) :
  exact_with_constant f g r :=
begin
  suffices H : ∀ (c : ℝ≥0), g ⁻¹' {0} ∩ filtration B c ⊆ f '' filtration A (r c),
  { refine ⟨_, H, hr⟩,
    ext x,
    have := congr_arg (coe_fn : (A ⟶ C) → (A → C)) hfg,
    exact congr_fun this x },
  rintro c y ⟨hy, hyc⟩,
  let t : CompHaus.of punit ⟶ P2 g c :=
  pullback.lift (terminal.from _ ≫ pt ⟨y, hyc⟩) (terminal.from _) _,
  swap, { ext, exact hy },
  obtain ⟨s, hs⟩ := h c (t punit.star),
  let π₂ : P1 f (hr c) ⟶ (Filtration.obj (r c)).obj A := pullback.snd,
  refine ⟨(π₂ s).val, _⟩,
  let P := CompHaus.of punit,
  suffices : terminal.from P ≫ pt s ≫ π₂ ≫ ((Filtration.obj (r c)).map f) =
    terminal.from _ ≫ pt ⟨y, filtration_mono (hr c) hyc⟩,
  { have hs := fun_like.congr_fun this punit.star, exact ⟨(π₂ s).2, congr_arg subtype.val hs⟩ },
  have H : terminal.from P ≫ pt s ≫ P1_to_P2 f g (hr c) hfg = t,
  { apply continuous_map.ext, rintro ⟨⟩, exact hs },
  erw [← pullback.condition, ← P1_to_P2_comp_fst f g (hr c) hfg, category.assoc,
    reassoc_of H, pullback.lift_fst_assoc],
  refl
end

lemma iff_surjective :
  exact_with_constant f g r ↔
  ∃ (hfg : f ≫ g = 0) (hr : ∀ c, c ≤ r c),
    ∀ c, function.surjective (P1_to_P2 f g (hr c) hfg) :=
begin
  split,
  { intro h, obtain ⟨hfg, H⟩ := surjective _ _ h, exact ⟨hfg, h.large, H⟩ },
  { rintro ⟨hfg, hr, h⟩, exact of_surjective f g hfg hr h }
end

end exact_with_constant

namespace exact_with_constant

variables {J : Type u} [small_category J]
variables {A' B' C' : J ⥤ CompHausFiltPseuNormGrp₁.{u}}
variables (f : A' ⟶ B') (g : B' ⟶ C') (r : ℝ≥0 → ℝ≥0) (c : ℝ≥0) (hrc : c ≤ r c)

variables {r c}

@[simps obj obj_obj obj_map map map_app { fully_applied := ff }]
def P1_functor : J ⥤ walking_cospan ⥤ CompHaus.{u} :=
functor.flip $ cospan
  (whisker_left B' (Filtration.map (c_le_rc hrc)))
  (whisker_right f (Filtration.obj (r c)))

@[simps obj obj_obj obj_map map map_app { fully_applied := ff }]
def P2_functor (c : ℝ≥0) : J ⥤ walking_cospan ⥤ CompHaus.{u} :=
functor.flip $ @cospan _ _ _ ((category_theory.functor.const _).obj (⊤_ _)) _
  (whisker_right g (Filtration.obj c))
  { app := λ j, pt (0 : pseudo_normed_group.filtration (C'.obj j) c),
    naturality' := by { intros, ext, exact (C'.map f).map_zero.symm } }

lemma P1_to_P2_nat_trans_aux_1 (hfg : f ≫ g = 0) (X Y : J) (h : X ⟶ Y) (w w') :
  ((P1_functor f hrc ⋙ lim).map h ≫
         lim_map (diagram_iso_cospan ((P1_functor f hrc).obj Y)).hom ≫
           P1_to_P2 (f.app Y) (g.app Y) hrc w ≫
             lim_map
               (𝟙 (cospan ((Filtration.obj c).map (g.app Y)) (pt 0)) ≫
                  (diagram_iso_cospan ((P2_functor g c).obj Y)).inv)) ≫
      limit.π ((P2_functor g c).obj Y) none =
    ((lim_map (diagram_iso_cospan ((P1_functor f hrc).obj X)).hom ≫
            P1_to_P2 (f.app X) (g.app X) hrc w' ≫
              lim_map
                (𝟙 (cospan ((Filtration.obj c).map (g.app X)) (pt 0)) ≫
                   (diagram_iso_cospan ((P2_functor g c).obj X)).inv)) ≫
         (P2_functor g c ⋙ lim).map h) ≫
      limit.π ((P2_functor g c).obj Y) none :=
begin
  dsimp [P1_to_P2],
  simp only [iso.refl_hom, iso.refl_inv, nat_trans.comp_app, eq_to_iso_refl,
    category.id_comp, category.assoc,
    cones.postcompose_obj_π, lim_map_π_assoc, limit.lift_π,
    diagram_iso_cospan_hom_app, diagram_iso_cospan_inv_app,
    pullback_cone.mk_π_app_one, limit.lift_map],
  dsimp,
  simp only [←(Filtration.obj c).map_comp, category.comp_id, category.id_comp,
    nat_trans.naturality],
end

lemma P1_to_P2_nat_trans_aux_2 (hfg : f ≫ g = 0) (X Y : J) (h : X ⟶ Y) (w w') :
  ((P1_functor f hrc ⋙ lim).map h ≫
         lim_map (diagram_iso_cospan ((P1_functor f hrc).obj Y)).hom ≫
           P1_to_P2 (f.app Y) (g.app Y) hrc w ≫
             lim_map
               (𝟙 (cospan ((Filtration.obj c).map (g.app Y)) (pt 0)) ≫
                  (diagram_iso_cospan ((P2_functor g c).obj Y)).inv)) ≫
      limit.π ((P2_functor g c).obj Y) (some walking_pair.left) =
    ((lim_map (diagram_iso_cospan ((P1_functor f hrc).obj X)).hom ≫
            P1_to_P2 (f.app X) (g.app X) hrc w' ≫
              lim_map
                (𝟙 (cospan ((Filtration.obj c).map (g.app X)) (pt 0)) ≫
                   (diagram_iso_cospan ((P2_functor g c).obj X)).inv)) ≫
         (P2_functor g c ⋙ lim).map h) ≫
      limit.π ((P2_functor g c).obj Y) (some walking_pair.left) :=
begin
  dsimp [P1_to_P2],
  simp only [iso.refl_hom ,iso.refl_inv, eq_to_iso_refl, nat_trans.comp_app,
    category.id_comp, category.assoc, pullback_cone.mk_π_app_left,
    cones.postcompose_obj_π, lim_map_π_assoc, limit.lift_π, limit.lift_map,
    diagram_iso_cospan_hom_app, diagram_iso_cospan_inv_app],
  dsimp,
  simp only [category.comp_id, category.id_comp],
end

lemma P1_to_P2_nat_trans_aux_3 (hfg : f ≫ g = 0) (X Y : J) (h : X ⟶ Y) (w w') :
  ((P1_functor f hrc ⋙ lim).map h ≫
         lim_map (diagram_iso_cospan ((P1_functor f hrc).obj Y)).hom ≫
           P1_to_P2 (f.app Y) (g.app Y) hrc w ≫
             lim_map
               (𝟙 (cospan ((Filtration.obj c).map (g.app Y)) (pt 0)) ≫
                  (diagram_iso_cospan ((P2_functor g c).obj Y)).inv)) ≫
      limit.π ((P2_functor g c).obj Y) (some walking_pair.right) =
    ((lim_map (diagram_iso_cospan ((P1_functor f hrc).obj X)).hom ≫
            P1_to_P2 (f.app X) (g.app X) hrc w' ≫
              lim_map
                (𝟙 (cospan ((Filtration.obj c).map (g.app X)) (pt 0)) ≫
                   (diagram_iso_cospan ((P2_functor g c).obj X)).inv)) ≫
         (P2_functor g c ⋙ lim).map h) ≫
      limit.π ((P2_functor g c).obj Y) (some walking_pair.right) :=
begin
  dsimp [P1_to_P2],
  simp only [category.id_comp, category.assoc, eq_to_iso_refl, iso.refl_inv, nat_trans.comp_app,
    pullback_cone.mk_π_app_right, cones.postcompose_obj_π, limit.lift_π, limit.lift_map,
    diagram_iso_cospan_inv_app, eq_iff_true_of_subsingleton],
end

def P1_to_P2_nat_trans (hfg : f ≫ g = 0) :
  (P1_functor f hrc ⋙ lim) ⟶ (P2_functor g c ⋙ lim) :=
{ app := λ j, begin
    refine _ ≫ P1_to_P2 (f.app j) (g.app j) hrc (by { rw [← nat_trans.comp_app, hfg], refl }) ≫ _,
    { refine lim_map (diagram_iso_cospan _).hom, },
    { refine lim_map (_ ≫ (diagram_iso_cospan _).inv), exact 𝟙 _, }
  end,
  naturality' := λ X Y h, begin
    -- It would be nicer to use `pullback.hom_ext` here, but it doesn't unify.
    -- Nevertheless, we can bash out the remaining goals with `simp`.
    apply limit.hom_ext, rintros (⟨⟩|⟨⟨⟩⟩),
    { apply P1_to_P2_nat_trans_aux_1 _ _ _ hfg, },
    { apply P1_to_P2_nat_trans_aux_2 _ _ _ hfg, },
    { apply P1_to_P2_nat_trans_aux_3 _ _ _ hfg, },
  end }

attribute [simps] P1_to_P2_nat_trans

set_option pp.universes true

/-
TODO:

jmc: below is a framework for setting up some canonical isomorphisms between limits.
It really boils down to saying that limits commute.
This shouldn't be so hard...
I'm not convinced that this is the best way to do it,
there should be a more ergonomic approach.

scott: I've replaced the definition of `P1_iso`
with one that uses the general theory for commuting limits.
-/

instance (c : ℝ≥0) : preserves_limits (Filtration.obj c) :=
by { dsimp [Filtration], apply_instance, }

def P1_iso {A B : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) {r : ℝ≥0 → ℝ≥0} {c : ℝ≥0} (hrc : c ≤ r c) (S : Profinite) :
  P1.{u} ((Profinite.extend_nat_trans.{u u+1} f).app S) hrc ≅
    limit (P1_functor.{u} (whisker_left S.fintype_diagram f) hrc ⋙ lim) :=
begin
  refine has_limit.iso_of_nat_iso (_ ≪≫ (cospan_comp_iso _ _ _).symm) ≪≫
    (limit_flip_comp_lim_iso_limit_comp_lim' _).symm,

  -- This next line can be removed later if/when we generalize universe parameters in finite (co)limits
  refine _ ≪≫ (diagram_iso_cospan _).symm,

  refine cospan_ext (preserves_limit_iso _ _) (preserves_limit_iso _ _) (preserves_limit_iso _ _)
    (by { apply limit.hom_ext, intros, ext, simp, })
    (begin
      apply limit.hom_ext,
      intros,
      simp [-category_theory.functor.map_comp, ←(Filtration.obj (r c)).map_comp],
    end)
end

open category_theory.limits

def P2_iso {B C : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (g : B ⟶ C) (c : ℝ≥0) (S : Profinite) :
  P2.{u} ((Profinite.extend_nat_trans.{u u+1} g).app S) c ≅
    limit (P2_functor.{u} (whisker_left S.fintype_diagram g) c ⋙ lim) :=
begin
  refine has_limit.iso_of_nat_iso (_ ≪≫ (cospan_comp_iso _ _ _).symm) ≪≫
    (limit_flip_comp_lim_iso_limit_comp_lim' _).symm,

  -- This next line can be removed later if/when we generalize universe parameters in finite (co)limits
  refine _ ≪≫ (diagram_iso_cospan _).symm,

  refine cospan_ext _ _ _ _ _,
  exact (preserves_limit_iso _ _),
  exact category_theory.limits.limit_const_terminal.symm,
  exact (preserves_limit_iso _ _),
  { apply limit.hom_ext, intros, simp [-category_theory.functor.map_comp, ←(Filtration.obj c).map_comp], },
  { apply limit.hom_ext, intros, ext, simp, },
end

-- move me, generalize
lemma extend_aux {A₁ B₁ A₂ B₂ : CompHaus}
  (e₁ : A₁ ≅ B₁) (e₂ : A₂ ≅ B₂) (f : A₁ ⟶ A₂) (g : B₁ ⟶ B₂) (hf : epi f)
  (H : e₁.inv ≫ f ≫ e₂.hom = g) :
  epi g :=
by { subst H, apply epi_comp _ _, apply_instance, apply epi_comp }

-- move me, generalize
lemma extend_aux' {A₁ B₁ A₂ B₂ : CompHaus}
  (e₁ : A₁ ≅ B₁) (e₂ : A₂ ≅ B₂) (f : A₁ ⟶ A₂) (g : B₁ ⟶ B₂) (hf : epi f)
  (H : f = e₁.hom ≫ g ≫ e₂.inv) :
  epi g :=
by { rw [← iso.inv_comp_eq, iso.eq_comp_inv, category.assoc] at H, apply extend_aux e₁ e₂ f g hf H }

lemma extend_aux_1 {A B C : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}} {r : ℝ≥0 → ℝ≥0} {c : ℝ≥0}
  (S : Profinite.{u}) (f : A ⟶ B) (g : B ⟶ C) (hrc : c ≤ r c) (w w') :
  ((P1_iso.{u} f hrc S).symm.inv ≫
         lim_map.{u u u u+1}
             (P1_to_P2_nat_trans.{u}
                (whisker_left.{u u u+1 u u+1 u} S.fintype_diagram f)
                (whisker_left.{u u u+1 u u+1 u} S.fintype_diagram g) hrc w) ≫
           (P2_iso.{u} g c S).symm.hom) ≫
      pullback.fst.{u u+1} =
    P1_to_P2.{u} ((Profinite.extend_nat_trans.{u u+1} f).app S)
        ((Profinite.extend_nat_trans.{u u+1} g).app S) hrc w' ≫
      pullback.fst.{u u+1} :=
begin
  apply (cancel_mono ((preserves_limit_iso (Filtration.obj _) _).hom)).1,
  apply limit.hom_ext,
  { -- TODO this is not the prettiest proof.
    -- We need some good simp lemmas for `P1_iso`, `P2_iso`, and `P1_to_P2`.
    intro j,
    simp only [P1_to_P2_comp_fst, category_theory.preserves_limits_iso_hom_π, category_theory.category.assoc],
    dsimp [P2_iso],
    simp only [category_theory.iso.symm_inv,
      category_theory.limits.cospan_ext_inv_app_left,
      category_theory.iso.trans_inv,
      category_theory.nat_trans.comp_app,
      category_theory.category.id_comp,
      category_theory.preserves_limits_iso_inv_π,
      category_theory.limits.cospan_comp_iso_hom_app_left,
      category_theory.category.assoc,
      category_theory.limits.has_limit.iso_of_nat_iso_inv_π_assoc],
    erw [limit_flip_comp_lim_iso_limit_comp_lim'_hom_π_π, lim_map_π_assoc],
    simp only [category_theory.category.id_comp,
      CompHausFiltPseuNormGrp₁.exact_with_constant.P1_to_P2_nat_trans_app,
      category_theory.category.assoc],
    erw [lim_map_π],
    dsimp [P1_to_P2],
    simp only [category_theory.category.comp_id,
      category_theory.iso.refl_hom,
      category_theory.eq_to_iso_refl,
      category_theory.limits.lim_map_π,
      category_theory.limits.diagram_iso_cospan_hom_app,
      category_theory.limits.pullback.lift_fst],
    dsimp [P1_iso],
    simp only [category_theory.category.assoc],
    erw [limit_flip_comp_lim_iso_limit_comp_lim'_inv_π_π],
    simp only [category_theory.limits.has_limit.iso_of_nat_iso_hom_π_assoc,
      category_theory.nat_trans.comp_app,
      category_theory.iso.symm_hom,
      category_theory.limits.cospan_comp_iso_inv_app_left,
      category_theory.category.assoc,
      category_theory.iso.trans_hom,
      category_theory.limits.cospan_ext_hom_app_left],
    dsimp,
    simp only [category_theory.preserves_limits_iso_hom_π, category_theory.category.id_comp], },
  all_goals { apply_instance, },
end

lemma extend {A B C : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0)
  (hfg : ∀ S, exact_with_constant (f.app S) (g.app S) r) (S : Profinite) :
  exact_with_constant
    ((Profinite.extend_nat_trans f).app S) ((Profinite.extend_nat_trans g).app S) r :=
begin
  have hr : id ≤ r := (hfg $ Fintype.of punit).large,
  rw exact_with_constant.iff_surjective,
  refine ⟨_, hr, _⟩,
  { rw [← nat_trans.comp_app, ← Profinite.extend_nat_trans_comp],
    apply limit.hom_ext,
    intro X,
    specialize hfg (S.fintype_diagram.obj X),
    erw [zero_comp, limit.lift_π],
    simp only [cones.postcompose_obj_π, whisker_left_comp, nat_trans.comp_app,
      limit.cone_π, whisker_left_app, hfg.comp_eq_zero, comp_zero], },
  intros c,
  have hfg' : whisker_left.{u u u+1 u u+1 u} S.fintype_diagram f ≫
    whisker_left.{u u u+1 u u+1 u} S.fintype_diagram g = 0,
  { ext X : 2,
    simp only [nat_trans.comp_app, whisker_left_app, (hfg (S.fintype_diagram.obj X)).comp_eq_zero],
    refl },
  have key := CompHaus.is_limit.surjective_of_surjective'
    (P1_functor.{u} (whisker_left S.fintype_diagram f) (hr c) ⋙ lim)
    (P2_functor.{u} (whisker_left S.fintype_diagram g) c ⋙ lim)
    (P1_to_P2_nat_trans _ _ _ hfg') _,
  swap,
  { intro X, specialize hfg (S.fintype_diagram.obj X), rw [iff_surjective] at hfg,
    rcases hfg with ⟨aux', hr, hfg⟩, specialize hfg c,
    rw ← CompHaus.epi_iff_surjective at hfg ⊢,
    apply_with epi_comp {instances := ff},
    { show epi ((@limits.lim _ _ _ _ _).map _), apply_instance, },
    apply_with epi_comp {instances := ff},
    { exact hfg },
    { show epi ((@limits.lim _ _ _ _ _).map _), apply_instance, }, },
  rw ← CompHaus.epi_iff_surjective at key ⊢,
  refine extend_aux (P1_iso f (hr c) S).symm (P2_iso g c S).symm _ _ key _,
  apply pullback.hom_ext,
  apply extend_aux_1,
  apply subsingleton.elim,
end

end exact_with_constant

instance has_zero_nat_trans_CHFPNG₁ {𝒞 : Type*} [category 𝒞]
  (A B : 𝒞 ⥤ CompHausFiltPseuNormGrp₁.{u}) :
  has_zero (A ⟶ B) :=
⟨⟨0, λ S T f, by { ext t, exact (B.map f).map_zero.symm }⟩⟩

@[simp] lemma zero_app {𝒞 : Type*} [category 𝒞] (A B : 𝒞 ⥤ CompHausFiltPseuNormGrp₁.{u}) (S) :
  (0 : A ⟶ B).app S = 0 := rfl

@[simp] lemma Profinite.extend_nat_trans_zero (A B : Fintype ⥤ CompHausFiltPseuNormGrp₁.{u}) :
  Profinite.extend_nat_trans (0 : A ⟶ B) = 0 :=
begin
  apply Profinite.extend_nat_trans_ext,
  rw [Profinite.extend_nat_trans_whisker_left],
  ext S : 2,
  simp only [nat_trans.comp_app, whisker_left_app, zero_app, zero_comp, comp_zero],
end

lemma exact_with_constant_extend_zero_left (A B C : Fintype ⥤ CompHausFiltPseuNormGrp₁.{u})
  (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0)
  (hfg : ∀ S, exact_with_constant (0 : A.obj S ⟶ B.obj S) (g.app S) r) (S : Profinite) :
  exact_with_constant (0 : (Profinite.extend A).obj S ⟶ (Profinite.extend B).obj S)
    ((Profinite.extend_nat_trans g).app S) r :=
begin
  have := exact_with_constant.extend (0 : A ⟶ B) g r hfg S,
  simpa,
end

lemma exact_with_constant_extend_zero_right (A B C : Fintype ⥤ CompHausFiltPseuNormGrp₁.{u})
  (f : A ⟶ B) (r : ℝ≥0 → ℝ≥0)
  (hfg : ∀ S, exact_with_constant (f.app S) (0 : B.obj S ⟶ C.obj S) r) (S : Profinite) :
  exact_with_constant ((Profinite.extend_nat_trans f).app S)
    (0 : (Profinite.extend B).obj S ⟶ (Profinite.extend C).obj S) r :=
begin
  have := exact_with_constant.extend f (0 : B ⟶ C) r hfg S,
  simpa,
end

variables (C)

lemma exact_with_constant_of_epi (f : A ⟶ B) (r : ℝ≥0 → ℝ≥0) (hr : id ≤ r)
  (hf : ∀ c, filtration B c ⊆ f '' (filtration A (r c))) :
  exact_with_constant f (0 : B ⟶ C) r :=
begin
  refine ⟨_, _, hr⟩,
  { rw comp_zero },
  { intro c, exact set.subset.trans (set.inter_subset_right _ _) (hf c), }
end

variables (A) {C}

lemma exact_with_constant_of_mono (g : B ⟶ C) [hg : mono ((to_PNG₁ ⋙ PseuNormGrp₁.to_Ab).map g)] :
  exact_with_constant (0 : A ⟶ B) g id :=
begin
  refine ⟨_, _, le_rfl⟩,
  { rw zero_comp },
  { rintro c x ⟨hx, -⟩,
    suffices : x = 0, { subst x, refine ⟨0, zero_mem_filtration _, rfl⟩, },
    simp only [set.mem_preimage, set.mem_singleton_iff] at hx,
    rw [AddCommGroup.mono_iff_injective, injective_iff_map_eq_zero] at hg,
    exact hg _ hx, }
end

end CompHausFiltPseuNormGrp₁

namespace Condensed

open CompHausFiltPseuNormGrp₁

lemma zero_iff_ExtrDisc {A B : Condensed.{u} Ab.{u+1}} (f : A ⟶ B) :
  f = 0 ↔ (∀ S : ExtrDisc, f.val.app (op S.val) = 0) :=
begin
  split,
  { rintros ⟨rfl⟩, simp },
  { intros h,
    apply (Condensed_ExtrSheafProd_equiv Ab).functor.map_injective,
    apply (ExtrSheafProd_to_presheaf Ab).map_injective,
    ext : 2,
    apply h }
end

lemma exact_iff_ExtrDisc {A B C : Condensed.{u} Ab.{u+1}} (f : A ⟶ B) (g : B ⟶ C) :
  exact f g ↔ ∀ (S : ExtrDisc),
    exact (f.1.app $ ExtrDisc_to_Profinite.op.obj (op S))
          (g.1.app $ ExtrDisc_to_Profinite.op.obj (op S)) :=
begin
  simp only [abelian.exact_iff, zero_iff_ExtrDisc, forall_and_distrib],
  refine and_congr iff.rfl _,
  apply forall_congr,
  intro S,
  symmetry,
  rw [← cancel_epi (kernel_iso g S).hom,
    ← cancel_mono (cokernel_iso f S).hom],
  dsimp only [functor.op_obj, ExtrDisc_to_Profinite_obj],
  simp only [category.assoc, zero_comp, comp_zero],
  erw [kernel_iso_hom_assoc, cokernel_iso_hom],
  exact iff.rfl,
end

open comphaus_filtered_pseudo_normed_group
open CompHausFiltPseuNormGrp₁.exact_with_constant (P1 P2 P1_to_P2 P1_to_P2_comp_fst c_le_rc)

lemma exact_of_exact_with_constant {A B C : CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) (g : B ⟶ C) (r : ℝ≥0 → ℝ≥0)
  (hfg : exact_with_constant f g r) :
  exact (to_Condensed.map f) (to_Condensed.map g) :=
begin
  rw exact_iff_ExtrDisc,
  intro S,
  rw exact_with_constant.iff_surjective at hfg,
  rcases hfg with ⟨hfg, hr, H⟩,
  simp only [subtype.val_eq_coe, to_Condensed_map, CompHausFiltPseuNormGrp.Presheaf.map_app,
    whisker_right_app, Ab.exact_ulift_map],
  rw AddCommGroup.exact_iff',
  split,
  { show @CompHausFiltPseuNormGrp.presheaf.map.{u}
      (CHFPNG₁_to_CHFPNGₑₗ.obj A) (CHFPNG₁_to_CHFPNGₑₗ.obj C)
      (@strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.{u u} A C _ _ (f ≫ g))
      (unop.{u+2} (ExtrDisc_to_Profinite.{u}.op.obj (op S))) = 0,
    rw hfg, ext x s, refl, },
  { rintro ⟨_, c, y₀ : S.val → filtration B c, hy₀, rfl⟩ hy,
    dsimp at hy ⊢,
    let y : CompHaus.of S.val ⟶ (Filtration.obj c).obj B := ⟨y₀, hy₀⟩,
    let t : CompHaus.of S.val ⟶ P2 g c := pullback.lift y (terminal.from _) _,
    swap,
    { apply continuous_map.ext, intros a, apply subtype.ext,
      simp only [add_monoid_hom.mem_ker, CompHausFiltPseuNormGrp.presheaf.map_apply] at hy,
      have := congr_arg subtype.val hy,
      exact congr_fun this a },
    let s := ExtrDisc.lift' _ (H c) t,
    have hs : s ≫ P1_to_P2 f g (hr c) hfg = t := ExtrDisc.lift_lifts' _ _ _,
    let π₂ : P1 f (hr c) ⟶ (Filtration.obj (r c)).obj A := pullback.snd,
    let x₀ := (s ≫ π₂).1,
    have hx₀ := (s ≫ π₂).2,
    refine ⟨⟨_, _, x₀, hx₀, rfl⟩, _⟩,
    apply_fun (λ φ, φ ≫ pullback.fst) at hs,
    erw [pullback.lift_fst y (terminal.from _)] at hs,
    rw [category.assoc, P1_to_P2_comp_fst, ← cancel_mono ((Filtration.map (c_le_rc (hr c))).app B),
      category.assoc, pullback.condition] at hs,
    ext z,
    have := fun_like.congr_fun hs z,
    exact congr_arg subtype.val this, }
end
.

@[simp] lemma to_Condensed_map_zero (A B : CompHausFiltPseuNormGrp₁.{u}) :
  to_Condensed.map (0 : A ⟶ B) = 0 :=
by { ext S s x, refl, }

lemma mono_to_Condensed_map {A B : CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) (hf : exact_with_constant (0 : A ⟶ A) f id) :
  mono (to_Condensed.map f) :=
begin
  refine ((abelian.tfae_mono (to_Condensed.obj A) (to_Condensed.map f)).out 2 0).mp _,
  have := exact_of_exact_with_constant (0 : A ⟶ A) f id hf,
  simpa only [to_Condensed_map_zero],
end

lemma epi_to_Condensed_map {A B : CompHausFiltPseuNormGrp₁.{u}}
  (f : A ⟶ B) (r : ℝ≥0 → ℝ≥0) (hf : exact_with_constant f (0 : B ⟶ B) r) :
  epi (to_Condensed.map f) :=
begin
  refine ((abelian.tfae_epi (to_Condensed.obj B) (to_Condensed.map f)).out 2 0).mp _,
  have := exact_of_exact_with_constant f (0 : B ⟶ B) r hf,
  simpa only [to_Condensed_map_zero]
end

end Condensed


import algebra.category.Module.abelian
import algebra.category.Module.adjunctions
import algebra.category.Module.filtered_colimits
import algebra.category.Module.colimits
import condensed.adjunctions

open category_theory
open category_theory.limits

universe u

variables (A : Type (u+1)) [ring A]

abbreviation CondensedMod := Condensed.{u} (Module.{u+1} A)

noncomputable theory

instance forget_Module_preserves_colimits_proetale_topology_cover (X : Profinite.{u}) :
  limits.preserves_colimits_of_shape (proetale_topology.cover X)ᵒᵖ
  (forget (Module.{u+1} A)) := infer_instance

-- TODO: Move this. Also, do we have this somewhere already?
instance forget_Module_reflects_isomorphisms :
  reflects_isomorphisms (forget (Module.{u+1} A)) :=
begin
  constructor,
  introsI M N f h,
  rw is_iso_iff_bijective at *,
  let e := linear_equiv.of_bijective f h.1 h.2,
  use e.symm,
  split,
  { ext t, change e.symm (e t) = t, rw linear_equiv.symm_apply_apply },
  { ext t, change e (e.symm t) = t, rw linear_equiv.apply_symm_apply }
end

-- (AT) I will fix this in mathlib asap...
instance : has_colimits (Module.{u+1} A) :=
Module.colimits.has_colimits_Module.{(u+1) (u+1)}

instance abelian_CondensedMod : abelian (CondensedMod A) :=
begin
  apply @category_theory.Sheaf.abelian.{(u+2) u (u+1)}
    Profinite.{u} _ proetale_topology (Module.{u+1} A) _ _ _ _ _ _ _ _,
end

def CondensedMod_to_CondensedSet : (CondensedMod A) ⥤ CondensedSet :=
Sheaf_compose _ (forget _)

@[simps obj_val map]
def CondensedSet_to_CondensedMod : CondensedSet ⥤ (CondensedMod A) :=
Sheaf.compose_and_sheafify _ (Module.free A)

@[simps unit_app counit_app]
def CondensedMod_CondensedSet_adjunction :
  CondensedSet_to_CondensedMod A ⊣ CondensedMod_to_CondensedSet A :=
Sheaf.adjunction _ (Module.adj A)

@[simp]
lemma CondensedMod_CondensedSet_adjunction_hom_equiv_apply (X : CondensedSet)
  (Y : CondensedMod A) (e : (CondensedSet_to_CondensedMod A).obj X ⟶ Y) :
  ((CondensedMod_CondensedSet_adjunction A).hom_equiv _ _ e).val =
  ((Module.adj A).whisker_right _).hom_equiv _ _ (proetale_topology.to_sheafify _ ≫ e.val) := rfl

@[simp]
lemma CondensedMod_CondensedSet_adjunction_hom_equiv_symm_apply (X : CondensedSet)
  (Y : CondensedMod A) (e : X ⟶ (CondensedMod_to_CondensedSet A).obj Y) :
  (((CondensedMod_CondensedSet_adjunction A).hom_equiv _ _).symm e).val =
  proetale_topology.sheafify_lift
    ((((Module.adj A).whisker_right _).hom_equiv _ _).symm e.val) Y.2 := rfl


constant f (x y : Nat) : Nat
constant g (x : Nat) : Nat

theorem ex1 (x : Nat) (h₁ : f x x = g x) (h₂ : g x = x) : f x (f x x) = x := by
  simp
  simp [*]

theorem ex2 (x : Nat) (h₁ : f x x = g x) (h₂ : g x = x) : f x (f x x) = x := by
  simp [*]

axiom g_ax (x : Nat) : g x = 0

theorem ex3 (x y : Nat) (h₁ : f x x = g x) (h₂ : f x x < 5) : f x x + f x x = 0 := by
  simp [*] at *
  trace_state
  have aux₁ : f x x = g x := h₁
  have aux₂ : g x < 5     := h₂
  simp [g_ax]


-- Copyright 2022-2023 VMware, Inc.
-- SPDX-License-Identifier: BSD-2-Clause

import .relational
import .relational_incremental
import .stream_elim
import logic.function.iterate

open zset

section recursion.

variables {a: Type}.
variables [decidable_eq a].

-- idea is that we're supposed to compute O such that R(O) = O
variables (R: Z[a] → Z[a]).

private def approxs : stream Z[a] :=
  fix (λ (o: stream Z[a]), ↑↑R (z⁻¹ o)).

lemma approxs_unfold :
  approxs R = ↑↑R (z⁻¹ (approxs R)) :=
begin
  unfold approxs,
  apply fix_eq,
  apply causal_strict_strict, swap, simp,
  apply delay_strict,
end

noncomputable def recursive_fixpoint : Z[a] :=
  ∫ (D (approxs R)).

lemma approxs_apply
  (n: ℕ) :
  approxs R n = (R^[n.succ]) 0 :=
begin
  induction n, simp,
  { unfold approxs,
    rw fix_0, simp, },
  { rw approxs_unfold, simp,
    rw n_ih, simp,
    repeat { rw (function.commute.iterate_self R) }, },
end

lemma approxs_unfold_succ
  (n: ℕ) :
  approxs R n.succ = R (approxs R n) :=
begin
  rw approxs_apply,
  rw approxs_apply,
  simp,
  rw function.commute.iterate_self R,
end

private lemma eq_succ_is_fixpoint
  (n: ℕ) (heqn: R^[n.succ] 0 = (R^[n]) 0) :
  ∀ m ≥ n,
  R^[m] 0 = (R^[n]) 0 :=
begin
  intros m hge,
  by_cases (m = n), cc,
  generalize hdiff : m - n - 1 = d,
  have hm : m = (n + d).succ := by omega,
  rw hm, rw hm at *, clear_dependent m, clear hdiff,
  clear hge h,
  induction d,
  { simp, assumption, },
  { have hnsucc : (n + d_n.succ) = (n + d_n).succ := by omega,
    simp, rw function.commute.iterate_self,
    rw [hnsucc, d_ih],
    simp at heqn, rw function.commute.iterate_self at heqn,
    exact heqn,
  },
end

lemma derivative_approx_almost_zero
  (n: ℕ) (heqn: (R^[n.succ]) 0 = (R^[n]) 0) :
  zero_after (D (approxs R)) n.succ :=
begin
  intros m hge,
  rw derivative_difference_t, swap, omega,
  repeat { rw approxs_apply },
  have heq : (m - 1).succ = m := by omega, rw heq, clear heq,
  rw (eq_succ_is_fixpoint _ n heqn m.succ), swap, omega,
  rw (eq_succ_is_fixpoint _ n heqn m), swap, omega,
  simp,
end

theorem recursive_fixpoint_ok
  (n: ℕ) (heqn: (R^[n.succ]) 0 = (R^[n]) 0) :
  recursive_fixpoint R = (R^[n]) 0 :=
begin
  unfold recursive_fixpoint,
  rw (stream_elim_zero_after (D (approxs R)) n.succ),
  { rw <- integral_sum_vals,
    simp,
    rw approxs_apply, dsimp,
    exact heqn, },
  apply (derivative_approx_almost_zero _ n heqn),
end

end recursion.

section seminaive.

variables {a b: Type}.
variables [decidable_eq a] [decidable_eq b].

variables (R: Z[b] → Z[a] → Z[a]).

noncomputable def naive : Z[b] → Z[a] :=
  λ i, ∫ (D (fix (λ (o: stream Z[a]), ↑²R (I (δ0 i)) (z⁻¹ o)))).

noncomputable def seminaive : Z[b] → Z[a] :=
  λ i, ∫ (fix (λ (o: stream Z[a]), ↑²R^Δ2 (δ0 i) (z⁻¹ o))).

-- hack to make the change work (need a better way to introduce incremental)
local attribute [reducible] incremental.

theorem seminaive_equiv :
  seminaive R = naive R :=
begin
  ext x,
  unfold naive seminaive,
  congr' 1,
  congr' 1,
  change (D (fix (λ (o : stream Z[a]), ↑²R (I (δ0 x)) (z⁻¹ o)))) with
    (λ i, (fix (λ (o : stream Z[a]), ↑²R i (z⁻¹ o))))^Δ (δ0 x),
  rw cycle_incremental (λ i o, ↑²R i o),
  dsimp,
  rw uncurry_op_lifting2,
  apply lifting_causal,
end

theorem naive_ok (i: Z[b])
  (n: ℕ) (heqn: (R i)^[n.succ] 0 = ((R i)^[n]) 0) :
  naive R i = ((R i)^[n]) 0 :=
begin
  unfold naive,
  have  heq := (recursive_fixpoint_ok (R i)) _ heqn,
  unfold recursive_fixpoint approxs at heq,
  rw<- heq,
  congr' 3,
  funext o,
  congr' 1,
  funext t, simp,
end

theorem seminaive_ok (i: Z[b])
  (n: ℕ) (heqn: (R i)^[n.succ] 0 = ((R i)^[n]) 0) :
  seminaive R i = ((R i)^[n]) 0 :=
begin
  rw seminaive_equiv,
  apply naive_ok, assumption,
end

end seminaive.