import category_theory.abelian.homology

import for_mathlib.exact_seq3
import for_mathlib.homology_exact
import for_mathlib.homology_iso
import for_mathlib.sum_str
.

noncomputable theory

open category_theory category_theory.limits

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]

variables {A₁₁ A₁₂ A₁₃ A₁₄ A₁₅ : 𝓐}
variables {A₂₁ A₂₂ A₂₃ A₂₄ A₂₅ : 𝓐}
variables {A₃₁ A₃₂ A₃₃ A₃₄ A₃₅ : 𝓐}
variables {A₄₁ A₄₂ A₄₃ A₄₄ A₄₅ : 𝓐}
variables {A₅₁ A₅₂ A₅₃ A₅₄ A₅₅ : 𝓐}

variables {f₁₁ : A₁₁ ⟶ A₁₂} {f₁₂ : A₁₂ ⟶ A₁₃} {f₁₃ : A₁₃ ⟶ A₁₄} {f₁₄ : A₁₄ ⟶ A₁₅}
variables {g₁₁ : A₁₁ ⟶ A₂₁} {g₁₂ : A₁₂ ⟶ A₂₂} {g₁₃ : A₁₃ ⟶ A₂₃} {g₁₄ : A₁₄ ⟶ A₂₄} {g₁₅ : A₁₅ ⟶ A₂₅}
variables {f₂₁ : A₂₁ ⟶ A₂₂} {f₂₂ : A₂₂ ⟶ A₂₃} {f₂₃ : A₂₃ ⟶ A₂₄} {f₂₄ : A₂₄ ⟶ A₂₅}
variables {g₂₁ : A₂₁ ⟶ A₃₁} {g₂₂ : A₂₂ ⟶ A₃₂} {g₂₃ : A₂₃ ⟶ A₃₃} {g₂₄ : A₂₄ ⟶ A₃₄} {g₂₅ : A₂₅ ⟶ A₃₅}
variables {f₃₁ : A₃₁ ⟶ A₃₂} {f₃₂ : A₃₂ ⟶ A₃₃} {f₃₃ : A₃₃ ⟶ A₃₄} {f₃₄ : A₃₄ ⟶ A₃₅}
variables {g₃₁ : A₃₁ ⟶ A₄₁} {g₃₂ : A₃₂ ⟶ A₄₂} {g₃₃ : A₃₃ ⟶ A₄₃} {g₃₄ : A₃₄ ⟶ A₄₄} {g₃₅ : A₃₅ ⟶ A₄₅}
variables {f₄₁ : A₄₁ ⟶ A₄₂} {f₄₂ : A₄₂ ⟶ A₄₃} {f₄₃ : A₄₃ ⟶ A₄₄} {f₄₄ : A₄₄ ⟶ A₄₅}
variables {g₄₁ : A₄₁ ⟶ A₅₁} {g₄₂ : A₄₂ ⟶ A₅₂} {g₄₃ : A₄₃ ⟶ A₅₃} {g₄₄ : A₄₄ ⟶ A₅₄} {g₄₅ : A₄₅ ⟶ A₅₅}
variables {f₅₁ : A₅₁ ⟶ A₅₂} {f₅₂ : A₅₂ ⟶ A₅₃} {f₅₃ : A₅₃ ⟶ A₅₄} {f₅₄ : A₅₄ ⟶ A₅₅}

section

variables (f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)

/-- A *local bicomplex* is a commutative diagram of the following shape
```
A₁₁ --- f₁₁ --> A₁₂
 |               |
g₁₁             g₁₂
 |               |
 v               v
A₂₁ --- f₂₁ --> A₂₂ --- f₂₂ --> A₂₃
                 |               |
                g₂₂             g₂₃
                 |               |
                 v               v
                A₃₂ --- f₃₂ --> A₃₃

```
whose rows and columns are complexes. -/
@[ext] structure LBC :=
(hw : f₂₁ ≫ f₂₂ = 0)
(vw : g₁₂ ≫ g₂₂ = 0)
(diag_in : A₁₁ ⟶ A₂₂)
(diag_out : A₂₂ ⟶ A₃₃)
(diag_in_tr₁ : g₁₁ ≫ f₂₁ = diag_in)
(diag_in_tr₂ : f₁₁ ≫ g₁₂ = diag_in)
(diag_out_tr₁ : g₂₂ ≫ f₃₂ = diag_out)
(diag_out_tr₂ : f₂₂ ≫ g₂₃ = diag_out)
(X Y : 𝓐)
(sum₁ : sum_str A₁₂ A₂₁ X)
(sum₂ : sum_str A₂₃ A₃₂ Y)
(π : X ⟶ A₂₂)
(ι : A₂₂ ⟶ Y)
(inl_π : sum₁.inl ≫ π = g₁₂)
(inr_π : sum₁.inr ≫ π = f₂₁)
(ι_fst : ι ≫ sum₂.fst = f₂₂)
(ι_snd : ι ≫ sum₂.snd = g₂₂)

structure LBC.core :=
(hw : f₂₁ ≫ f₂₂ = 0)
(vw : g₁₂ ≫ g₂₂ = 0)
(sq₁ : f₁₁ ≫ g₁₂ = g₁₁ ≫ f₂₁)
(sq₂ : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂)

end

namespace LBC

attribute [reassoc] LBC.hw LBC.vw

@[reassoc] lemma sq₁ (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) : f₁₁ ≫ g₁₂ = g₁₁ ≫ f₂₁ :=
by rw [lbc.diag_in_tr₁, diag_in_tr₂]

@[reassoc] lemma sq₂ (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂ :=
by rw [lbc.diag_out_tr₁, diag_out_tr₂]

@[simps]
def of_core (lbc : core f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂ :=
{ hw := lbc.hw,
  vw := lbc.vw,
  diag_in := g₁₁ ≫ f₂₁,
  diag_out := g₂₂ ≫ f₃₂,
  diag_in_tr₁ := rfl,
  diag_in_tr₂ := lbc.sq₁,
  diag_out_tr₁ := rfl,
  diag_out_tr₂ := lbc.sq₂,
  X := A₁₂ ⊞ A₂₁,
  Y := A₂₃ ⊞ A₃₂,
  sum₁ := sum_str.biprod _ _,
  sum₂ := sum_str.biprod _ _,
  π := biprod.desc g₁₂ f₂₁,
  ι := biprod.lift f₂₂ g₂₂,
  inl_π := biprod.inl_desc _ _,
  inr_π := biprod.inr_desc _ _,
  ι_fst := biprod.lift_fst _ _,
  ι_snd := biprod.lift_snd _ _, }

@[simps]
def symm (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  LBC g₁₁ f₁₁ f₂₁ g₁₂ g₂₂ f₂₂ f₃₂ g₂₃ :=
{ hw := lbc.vw,
  vw := lbc.hw,
  diag_in := lbc.diag_in,
  diag_out := lbc.diag_out,
  diag_in_tr₁ := lbc.diag_in_tr₂,
  diag_in_tr₂ := lbc.diag_in_tr₁,
  diag_out_tr₁ := lbc.diag_out_tr₂,
  diag_out_tr₂ := lbc.diag_out_tr₁,
  X := lbc.X,
  Y := lbc.Y,
  sum₁ := lbc.sum₁.symm,
  sum₂ := lbc.sum₂.symm,
  π := lbc.π,
  ι := lbc.ι,
  inl_π := lbc.inr_π,
  inr_π := lbc.inl_π,
  ι_fst := lbc.ι_snd,
  ι_snd := lbc.ι_fst }

section
open opposite

@[simps]
protected def op (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  LBC f₃₂.op g₂₃.op g₂₂.op f₂₂.op f₂₁.op g₁₂.op g₁₁.op f₁₁.op :=
{ hw := by { rw [← op_comp, lbc.hw, op_zero] },
  vw := by { rw [← op_comp, lbc.vw, op_zero] },
  diag_in := lbc.diag_out.op,
  diag_out := lbc.diag_in.op,
  diag_in_tr₁ := by { rw [← op_comp, lbc.diag_out_tr₂] },
  diag_in_tr₂ := by { rw [← op_comp, lbc.diag_out_tr₁] },
  diag_out_tr₁ := by { rw [← op_comp, lbc.diag_in_tr₂] },
  diag_out_tr₂ := by { rw [← op_comp, lbc.diag_in_tr₁] },
  X := op lbc.Y,
  Y := op lbc.X,
  sum₁ := lbc.symm.sum₂.op,
  sum₂ := lbc.symm.sum₁.op,
  π := lbc.ι.op,
  ι := lbc.π.op,
  inl_π := by { dsimp, rw [← op_comp, lbc.ι_snd], },
  inr_π := by { dsimp, rw [← op_comp, lbc.ι_fst], },
  ι_fst := by { dsimp, rw [← op_comp, lbc.inr_π], },
  ι_snd := by { dsimp, rw [← op_comp, lbc.inl_π], } }

variables {A'₁₁ A'₁₂ A'₁₃ A'₁₄ A'₁₅ : 𝓐ᵒᵖ}
variables {A'₂₁ A'₂₂ A'₂₃ A'₂₄ A'₂₅ : 𝓐ᵒᵖ}
variables {A'₃₁ A'₃₂ A'₃₃ A'₃₄ A'₃₅ : 𝓐ᵒᵖ}
variables {A'₄₁ A'₄₂ A'₄₃ A'₄₄ A'₄₅ : 𝓐ᵒᵖ}
variables {A'₅₁ A'₅₂ A'₅₃ A'₅₄ A'₅₅ : 𝓐ᵒᵖ}

variables {f'₁₁ : A'₁₁ ⟶ A'₁₂} {f'₁₂ : A'₁₂ ⟶ A'₁₃} {f'₁₃ : A'₁₃ ⟶ A'₁₄} {f'₁₄ : A'₁₄ ⟶ A'₁₅}
variables {g'₁₁ : A'₁₁ ⟶ A'₂₁} {g'₁₂ : A'₁₂ ⟶ A'₂₂} {g'₁₃ : A'₁₃ ⟶ A'₂₃} {g'₁₄ : A'₁₄ ⟶ A'₂₄} {g'₁₅ : A'₁₅ ⟶ A'₂₅}
variables {f'₂₁ : A'₂₁ ⟶ A'₂₂} {f'₂₂ : A'₂₂ ⟶ A'₂₃} {f'₂₃ : A'₂₃ ⟶ A'₂₄} {f'₂₄ : A'₂₄ ⟶ A'₂₅}
variables {g'₂₁ : A'₂₁ ⟶ A'₃₁} {g'₂₂ : A'₂₂ ⟶ A'₃₂} {g'₂₃ : A'₂₃ ⟶ A'₃₃} {g'₂₄ : A'₂₄ ⟶ A'₃₄} {g'₂₅ : A'₂₅ ⟶ A'₃₅}
variables {f'₃₁ : A'₃₁ ⟶ A'₃₂} {f'₃₂ : A'₃₂ ⟶ A'₃₃} {f'₃₃ : A'₃₃ ⟶ A'₃₄} {f'₃₄ : A'₃₄ ⟶ A'₃₅}
variables {g'₃₁ : A'₃₁ ⟶ A'₄₁} {g'₃₂ : A'₃₂ ⟶ A'₄₂} {g'₃₃ : A'₃₃ ⟶ A'₄₃} {g'₃₄ : A'₃₄ ⟶ A'₄₄} {g'₃₅ : A'₃₅ ⟶ A'₄₅}
variables {f'₄₁ : A'₄₁ ⟶ A'₄₂} {f'₄₂ : A'₄₂ ⟶ A'₄₃} {f'₄₃ : A'₄₃ ⟶ A'₄₄} {f'₄₄ : A'₄₄ ⟶ A'₄₅}
variables {g'₄₁ : A'₄₁ ⟶ A'₅₁} {g'₄₂ : A'₄₂ ⟶ A'₅₂} {g'₄₃ : A'₄₃ ⟶ A'₅₃} {g'₄₄ : A'₄₄ ⟶ A'₅₄} {g'₄₅ : A'₄₅ ⟶ A'₅₅}
variables {f'₅₁ : A'₅₁ ⟶ A'₅₂} {f'₅₂ : A'₅₂ ⟶ A'₅₃} {f'₅₃ : A'₅₃ ⟶ A'₅₄} {f'₅₄ : A'₅₄ ⟶ A'₅₅}

@[simps]
protected def unop (lbc : LBC f'₁₁ g'₁₁ g'₁₂ f'₂₁ f'₂₂ g'₂₂ g'₂₃ f'₃₂) :
  LBC f'₃₂.unop g'₂₃.unop g'₂₂.unop f'₂₂.unop f'₂₁.unop g'₁₂.unop g'₁₁.unop f'₁₁.unop :=
{ hw := by { rw [← unop_comp, lbc.hw, unop_zero] },
  vw := by { rw [← unop_comp, lbc.vw, unop_zero] },
  diag_in := lbc.diag_out.unop,
  diag_out := lbc.diag_in.unop,
  diag_in_tr₁ := by { rw [← unop_comp, lbc.diag_out_tr₂] },
  diag_in_tr₂ := by { rw [← unop_comp, lbc.diag_out_tr₁] },
  diag_out_tr₁ := by { rw [← unop_comp, lbc.diag_in_tr₂] },
  diag_out_tr₂ := by { rw [← unop_comp, lbc.diag_in_tr₁] },
  X := unop lbc.Y,
  Y := unop lbc.X,
  sum₁ := lbc.symm.sum₂.unop,
  sum₂ := lbc.symm.sum₁.unop,
  π := lbc.ι.unop,
  ι := lbc.π.unop,
  inl_π := by { dsimp, rw [← unop_comp, lbc.ι_snd], },
  inr_π := by { dsimp, rw [← unop_comp, lbc.ι_fst], },
  ι_fst := by { dsimp, rw [← unop_comp, lbc.inr_π], },
  ι_snd := by { dsimp, rw [← unop_comp, lbc.inl_π], } }
.

lemma unop_op (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) : lbc.op.unop = lbc :=
begin
  cases lbc, ext; try { refl },
  { dsimp, rw [← sum_str.op_symm, sum_str.unop_op, sum_str.symm_symm], },
  { dsimp, rw [← sum_str.op_symm, sum_str.unop_op, sum_str.symm_symm], },
end

lemma op_unop (lbc : LBC f'₁₁ g'₁₁ g'₁₂ f'₂₁ f'₂₂ g'₂₂ g'₂₃ f'₃₂) : lbc.unop.op = lbc :=
begin
  cases lbc, ext; try { refl },
  { dsimp, rw [← sum_str.unop_symm, sum_str.op_unop, sum_str.symm_symm], },
  { dsimp, rw [← sum_str.unop_symm, sum_str.op_unop, sum_str.symm_symm], },
end

end

@[reassoc] lemma diag_in_r (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  lbc.diag_in ≫ f₂₂ = 0 :=
by rw [← lbc.diag_in_tr₁, category.assoc, lbc.hw, comp_zero]

@[reassoc] lemma diag_in_d (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  lbc.diag_in ≫ g₂₂ = 0 :=
by rw [← lbc.diag_in_tr₂, category.assoc, lbc.vw, comp_zero]

@[reassoc] lemma r_diag_out (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  f₂₁ ≫ lbc.diag_out = 0 :=
by rw [← lbc.diag_out_tr₂, ← category.assoc, lbc.hw, zero_comp]

@[reassoc] lemma d_diag_out (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  g₁₂ ≫ lbc.diag_out = 0 :=
by rw [← lbc.diag_out_tr₁, ← category.assoc, lbc.vw, zero_comp]

lemma π_eq (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  lbc.π = lbc.sum₁.fst ≫ g₁₂ + lbc.sum₁.snd ≫ f₂₁ :=
by rw [← category.id_comp lbc.π, ← lbc.sum₁.total, preadditive.add_comp,
  category.assoc, category.assoc, lbc.inl_π, lbc.inr_π]

lemma ι_eq (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  lbc.ι = f₂₂ ≫ lbc.sum₂.inl + g₂₂ ≫ lbc.sum₂.inr :=
by rw [← category.comp_id lbc.ι, ← lbc.sum₂.total, preadditive.comp_add,
  ← category.assoc, ← category.assoc, lbc.ι_fst, lbc.ι_snd]

lemma diag_in_ι (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  lbc.diag_in ≫ lbc.ι = 0 :=
by simp only [lbc.ι_eq, preadditive.comp_add, category.assoc, zero_comp, add_zero,
    reassoc_of lbc.ι_fst, reassoc_of lbc.ι_snd, lbc.diag_in_r_assoc, lbc.diag_in_d_assoc]

lemma π_diag_out (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  lbc.π ≫ lbc.diag_out = 0 :=
by simp only [lbc.π_eq, preadditive.add_comp, category.assoc, comp_zero, add_zero,
    reassoc_of lbc.inl_π, reassoc_of lbc.inr_π, lbc.r_diag_out, lbc.d_diag_out]

lemma drd₁ (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  g₁₁ ≫ f₂₁ ≫ g₂₂ = 0 :=
by rw [← lbc.sq₁_assoc, lbc.vw, comp_zero]

lemma drd₂ (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  g₁₂ ≫ f₂₂ ≫ g₂₃ = 0 :=
by rw [lbc.sq₂, lbc.vw_assoc, zero_comp]

lemma rdr₁ (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  f₁₁ ≫ g₁₂ ≫ f₂₂ = 0 :=
by rw [lbc.sq₁_assoc, lbc.hw, comp_zero]

lemma rdr₂ (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) :
  f₂₁ ≫ g₂₂ ≫ f₃₂ = 0 :=
by rw [← lbc.sq₂, lbc.hw_assoc, zero_comp]

/-- The *receptor* of a local bicomplex. -/
def rcp (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) : 𝓐 :=
homology lbc.diag_in lbc.ι lbc.diag_in_ι

/-- The *donor* of a local bicomplex. -/
def don (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) : 𝓐 :=
homology lbc.π lbc.diag_out lbc.π_diag_out

/-- The *horizontal homology* of a local bicomplex. -/
def H (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) : 𝓐 :=
homology f₂₁ f₂₂ lbc.hw

/-- The *vertical homology* of a local bicomplex. -/
def V (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂) : 𝓐 :=
homology g₁₂ g₂₂ lbc.vw

variables (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)

lemma H_is_zero_iff : is_zero lbc.H ↔ exact f₂₁ f₂₂ :=
begin
  rw preadditive.exact_iff_homology_zero,
  simp only [lbc.hw, eq_self_iff_true, exists_true_left],
  split,
  refine λ h, ⟨h.iso_zero⟩,
  rintro ⟨i⟩, exact is_zero_of_iso_of_zero (is_zero_zero _) i.symm
end

lemma V_is_zero_iff : is_zero lbc.V ↔ exact g₁₂ g₂₂ :=
lbc.symm.H_is_zero_iff

/-- The intramural map from the receptor to the horizontal homology. -/
def rcp_to_H : lbc.rcp ⟶ lbc.H :=
homology.map _ _
  { left := g₁₁,
    right := 𝟙 _,
    w' := by { dsimp, rw [category.comp_id, lbc.diag_in_tr₁], } }
  { left := 𝟙 _,
    right := lbc.sum₂.fst,
    w' := by { dsimp, rw [category.id_comp, lbc.ι_fst], } }
  rfl

/-- The intramural map from the receptor to the vertical homology. -/
def rcp_to_V : lbc.rcp ⟶ lbc.V :=
homology.map _ _
  { left := f₁₁,
    right := 𝟙 _,
    w' := by { dsimp, rw [category.comp_id, lbc.diag_in_tr₂], } }
  { left := 𝟙 _,
    right := lbc.sum₂.snd,
    w' := by { dsimp, rw [category.id_comp, lbc.ι_snd], } }
  rfl

/-- The intramural map from the horizontal homology to the donor. -/
def H_to_don : lbc.H ⟶ lbc.don :=
homology.map _ _
  { left := lbc.sum₁.inr,
    right := 𝟙 _,
    w' := by { dsimp, rw [category.comp_id, lbc.inr_π], } }
  { left := 𝟙 _,
    right := g₂₃,
    w' := by { dsimp, rw [category.id_comp, lbc.diag_out_tr₂], } }
  rfl

/-- The intramural map from the vertical homology to the donor. -/
def V_to_don : lbc.V ⟶ lbc.don :=
homology.map _ _
  { left := lbc.sum₁.inl,
    right := 𝟙 _,
    w' := by { dsimp, rw [category.comp_id, lbc.inl_π], } }
  { left := 𝟙 _,
    right := f₃₂,
    w' := by { dsimp, rw [category.id_comp, lbc.diag_out_tr₁], } }
  rfl

lemma rcp_to_H_comp_H_to_don : lbc.rcp_to_H ≫ lbc.H_to_don = lbc.rcp_to_V ≫ lbc.V_to_don :=
begin
  delta rcp_to_H H_to_don rcp_to_V V_to_don,
  rw [homology.map_comp, homology.map_comp],
  refl,
end

/-- The horizontal extramural map. -/
def ex_h
  (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
  (lbc₂ : LBC f₁₂ g₁₂ g₁₃ f₂₂ f₂₃ g₂₃ g₂₄ f₃₃) :
  lbc₁.don ⟶ lbc₂.rcp :=
homology.map _ _
  { left := lbc₁.sum₁.fst,
    right := f₂₂,
    w' := by { dsimp, rw [lbc₁.π_eq, preadditive.add_comp, category.assoc, category.assoc,
      lbc₁.hw, comp_zero, add_zero, lbc₂.diag_in_tr₁], } }
  { left := f₂₂,
    right := lbc₂.sum₂.inr,
    w' := by { dsimp, rw [lbc₂.ι_eq, preadditive.comp_add, ← category.assoc, ← category.assoc,
      lbc₂.hw, zero_comp, zero_add, lbc₁.diag_out_tr₂], } }
  rfl
.

lemma V_to_don_comp_ex_h_comp_rcp_to_V
  (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
  (lbc₂ : LBC f₁₂ g₁₂ g₁₃ f₂₂ f₂₃ g₂₃ g₂₄ f₃₃) :
  lbc₁.V_to_don ≫ ex_h lbc₁ lbc₂ ≫ lbc₂.rcp_to_V =
  homology.map _ _ ⟨f₁₂, f₂₂, lbc₂.sq₁⟩ ⟨f₂₂, f₃₂, lbc₁.sq₂⟩ rfl :=
begin
  delta V_to_don ex_h rcp_to_V,
  rw [homology.map_comp, homology.map_comp],
  congr' 1; apply category_theory.comma_morphism.ext; dsimp;
  simp only [sum_str.inl_fst, sum_str.inl_fst_assoc, sum_str.inr_snd, sum_str.inr_snd_assoc,
    category.id_comp, category.comp_id],
end

/-- The vertical extramural map. -/
def ex_v
  (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
  (lbc₂ : LBC f₂₁ g₂₁ g₂₂ f₃₁ f₃₂ g₃₂ g₃₃ f₄₂) :
  lbc₁.don ⟶ lbc₂.rcp :=
homology.map _ _
  { left := lbc₁.sum₁.snd,
    right := g₂₂,
    w' := by { dsimp, rw [lbc₁.π_eq, preadditive.add_comp, category.assoc, category.assoc,
      lbc₁.vw, comp_zero, zero_add, lbc₂.diag_in_tr₂], } }
  { left := g₂₂,
    right := lbc₂.sum₂.inl,
    w' := by { dsimp, rw [lbc₂.ι_eq, preadditive.comp_add, ← category.assoc, ← category.assoc,
      lbc₂.vw, zero_comp, add_zero, lbc₁.diag_out_tr₁], } }
  rfl
.

lemma H_to_don_comp_ex_v_comp_rcp_to_H
  (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
  (lbc₂ : LBC f₂₁ g₂₁ g₂₂ f₃₁ f₃₂ g₃₂ g₃₃ f₄₂) :
  lbc₁.H_to_don ≫ ex_v lbc₁ lbc₂ ≫ lbc₂.rcp_to_H =
  homology.map _ _ ⟨g₂₁, g₂₂, lbc₂.sq₁.symm⟩ ⟨g₂₂, g₂₃, lbc₁.sq₂.symm⟩ rfl :=
begin
  delta H_to_don ex_v rcp_to_H,
  rw [homology.map_comp, homology.map_comp],
  congr' 1; apply category_theory.comma_morphism.ext; dsimp;
  simp only [sum_str.inl_fst, sum_str.inl_fst_assoc, sum_str.inr_snd, sum_str.inr_snd_assoc,
    category.id_comp, category.comp_id],
end
.

/-
#############################################
#
# The rest of this file is very interesting in its own right,
# but we don't need it for LTE, and it contains some annoying sorries
#
#############################################
-/

-- open_locale pseudoelement
-- open category_theory.abelian

-- section

-- variables {A'₁₁ A'₁₂ A'₁₃ A'₁₄ A'₁₅ : 𝓐ᵒᵖ}
-- variables {A'₂₁ A'₂₂ A'₂₃ A'₂₄ A'₂₅ : 𝓐ᵒᵖ}
-- variables {A'₃₁ A'₃₂ A'₃₃ A'₃₄ A'₃₅ : 𝓐ᵒᵖ}
-- variables {A'₄₁ A'₄₂ A'₄₃ A'₄₄ A'₄₅ : 𝓐ᵒᵖ}
-- variables {A'₅₁ A'₅₂ A'₅₃ A'₅₄ A'₅₅ : 𝓐ᵒᵖ}

-- variables {f'₁₁ : A'₁₁ ⟶ A'₁₂} {f'₁₂ : A'₁₂ ⟶ A'₁₃} {f'₁₃ : A'₁₃ ⟶ A'₁₄} {f'₁₄ : A'₁₄ ⟶ A'₁₅}
-- variables {g'₁₁ : A'₁₁ ⟶ A'₂₁} {g'₁₂ : A'₁₂ ⟶ A'₂₂} {g'₁₃ : A'₁₃ ⟶ A'₂₃} {g'₁₄ : A'₁₄ ⟶ A'₂₄} {g'₁₅ : A'₁₅ ⟶ A'₂₅}
-- variables {f'₂₁ : A'₂₁ ⟶ A'₂₂} {f'₂₂ : A'₂₂ ⟶ A'₂₃} {f'₂₃ : A'₂₃ ⟶ A'₂₄} {f'₂₄ : A'₂₄ ⟶ A'₂₅}
-- variables {g'₂₁ : A'₂₁ ⟶ A'₃₁} {g'₂₂ : A'₂₂ ⟶ A'₃₂} {g'₂₃ : A'₂₃ ⟶ A'₃₃} {g'₂₄ : A'₂₄ ⟶ A'₃₄} {g'₂₅ : A'₂₅ ⟶ A'₃₅}
-- variables {f'₃₁ : A'₃₁ ⟶ A'₃₂} {f'₃₂ : A'₃₂ ⟶ A'₃₃} {f'₃₃ : A'₃₃ ⟶ A'₃₄} {f'₃₄ : A'₃₄ ⟶ A'₃₅}
-- variables {g'₃₁ : A'₃₁ ⟶ A'₄₁} {g'₃₂ : A'₃₂ ⟶ A'₄₂} {g'₃₃ : A'₃₃ ⟶ A'₄₃} {g'₃₄ : A'₃₄ ⟶ A'₄₄} {g'₃₅ : A'₃₅ ⟶ A'₄₅}
-- variables {f'₄₁ : A'₄₁ ⟶ A'₄₂} {f'₄₂ : A'₄₂ ⟶ A'₄₃} {f'₄₃ : A'₄₃ ⟶ A'₄₄} {f'₄₄ : A'₄₄ ⟶ A'₄₅}
-- variables {g'₄₁ : A'₄₁ ⟶ A'₅₁} {g'₄₂ : A'₄₂ ⟶ A'₅₂} {g'₄₃ : A'₄₃ ⟶ A'₅₃} {g'₄₄ : A'₄₄ ⟶ A'₅₄} {g'₄₅ : A'₄₅ ⟶ A'₅₅}
-- variables {f'₅₁ : A'₅₁ ⟶ A'₅₂} {f'₅₂ : A'₅₂ ⟶ A'₅₃} {f'₅₃ : A'₅₃ ⟶ A'₅₄} {f'₅₄ : A'₅₄ ⟶ A'₅₅}

-- open opposite

-- lemma op_H_to_don (lbc : LBC f'₁₁ g'₁₁ g'₁₂ f'₂₁ f'₂₂ g'₂₂ g'₂₃ f'₃₂) :
--   lbc.H_to_don = (homology_unop_iso _ _ _).hom ≫ lbc.unop.rcp_to_H.op ≫
--     (homology_unop_iso _ _ lbc.π_diag_out).inv :=
-- begin
--   ext,
--   simp only [category.assoc, H_to_don, rcp_to_H,
--     homology_unop_iso_hom, homology_unop_iso_inv,
--     unop_sum₂, symm_sum₁, sum_str.unop_fst, sum_str.symm_inl, homology.map_ι,
--     homology.π'_ι_assoc, cokernel.π_desc,
--     homology_iso_cokernel_lift, homology_iso_kernel_desc,
--     homology_iso_cokernel_image_to_kernel',
--     cokernel_epi_comp_hom, cokernel_epi_comp_inv,
--     category_theory.limits.cokernel.map_desc_assoc,
--     cokernel_iso_of_eq_hom_comp_desc_assoc,
--     iso.trans_hom, iso.trans_inv, iso.symm_hom],
--   admit
-- end

-- lemma op_rcp_to_H (lbc : LBC f'₁₁ g'₁₁ g'₁₂ f'₂₁ f'₂₂ g'₂₂ g'₂₃ f'₃₂) :
--   lbc.rcp_to_H = (homology_unop_iso _ _ lbc.diag_in_ι).hom ≫
--     lbc.unop.H_to_don.op ≫ (homology_unop_iso _ _ _).inv :=
-- begin
--   admit
-- end

-- lemma op_V_to_don (lbc : LBC f'₁₁ g'₁₁ g'₁₂ f'₂₁ f'₂₂ g'₂₂ g'₂₃ f'₃₂) :
--   lbc.V_to_don = (homology_unop_iso _ _ _).hom ≫ lbc.unop.rcp_to_V.op ≫
--     (homology_unop_iso _ _ lbc.π_diag_out).inv :=
-- lbc.symm.op_H_to_don

-- lemma op_rcp_to_V (lbc : LBC f'₁₁ g'₁₁ g'₁₂ f'₂₁ f'₂₂ g'₂₂ g'₂₃ f'₃₂) :
--   lbc.rcp_to_V = (homology_unop_iso _ _ lbc.diag_in_ι).hom ≫
--     lbc.unop.V_to_don.op ≫ (homology_unop_iso _ _ _).inv :=
-- lbc.symm.op_rcp_to_H

-- lemma op_ex_h
--   (lbc₁ : LBC f'₁₁ g'₁₁ g'₁₂ f'₂₁ f'₂₂ g'₂₂ g'₂₃ f'₃₂)
--   (lbc₂ : LBC f'₁₂ g'₁₂ g'₁₃ f'₂₂ f'₂₃ g'₂₃ g'₂₄ f'₃₃) :
--   lbc₁.ex_h lbc₂ = (homology_unop_iso _ _ lbc₁.π_diag_out).hom ≫
--     (lbc₂.unop.ex_h lbc₁.unop).op ≫ (homology_unop_iso _ _ lbc₂.diag_in_ι).inv :=
-- admit

-- lemma op_ex_v
--   (lbc₁ : LBC f'₁₁ g'₁₁ g'₁₂ f'₂₁ f'₂₂ g'₂₂ g'₂₃ f'₃₂)
--   (lbc₂ : LBC f'₂₁ g'₂₁ g'₂₂ f'₃₁ f'₃₂ g'₃₂ g'₃₃ f'₄₂) :
--   lbc₁.ex_v lbc₂ = (homology_unop_iso _ _ lbc₁.π_diag_out).hom ≫
--     (lbc₂.unop.ex_v lbc₁.unop).op ≫ (homology_unop_iso _ _ lbc₂.diag_in_ι).inv  :=
-- by convert lbc₁.symm.op_ex_h lbc₂.symm using 1

-- end

-- lemma exact_aux_1
--   (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (lbc₂ : LBC f₂₁ g₂₁ g₂₂ f₃₁ f₃₂ g₃₂ g₃₃ f₄₂) :
--   exact (lbc₁.ex_v lbc₂ ≫ lbc₂.rcp_to_H) lbc₂.H_to_don :=
-- begin
--   -- apply pseudoelement.exact_of_pseudo_exact,
--   -- split,
--   -- { suffices : lbc₁.ex_v lbc₂ ≫ lbc₂.rcp_to_V = 0,
--   --   { intro x,
--   --     rw [← pseudoelement.comp_apply, category.assoc, rcp_to_H_comp_H_to_don,
--   --       ← category.assoc, this, zero_comp, pseudoelement.zero_apply] },
--   --   rw pseudoelement.eq_zero_iff,
--   --   intro x,
--   --   delta ex_v rcp_to_V,
--   --  },

--   -- refine preadditive.exact_of_iso_of_exact'
--   --   (cokernel.desc _ _ _) _ _ _
--   --   (homology_iso_cokernel_lift _ _ _).symm
--   --   (homology_iso_cokernel_lift _ _ _).symm
--   --   (homology_iso_cokernel_lift _ _ _).symm _ _ _,

--   -- rw abelian.exact_iff, split,
--   -- { suffices : lbc₁.ex_v lbc₂ ≫ lbc₂.rcp_to_V = 0,
--   --   rw [category.assoc, rcp_to_H_comp_H_to_don, ← category.assoc, this, zero_comp],
--   --   delta ex_v rcp_to_V,
--   --   rw [homology.map_comp],
--   --   apply homology.ext,
--   --   rw [homology.π_map, comp_zero],
--   --   dsimp [kernel_subobject_map, homology.π],
--   --   simp only [category.comp_id],
--   --   admit },
--   admit
-- end

-- lemma exact_aux_2
--   (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (lbc₂ : LBC f₁₂ g₁₂ g₁₃ f₂₂ f₂₃ g₂₃ g₂₄ f₃₃) :
--   exact lbc₁.H_to_don (lbc₁.ex_h lbc₂) :=
-- begin
--   admit
-- end

-- lemma salamander_v
--   (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (lbc₂ : LBC f₂₁ g₂₁ g₂₂ f₃₁ f₃₂ g₃₂ g₃₃ f₄₂)
--   (lbc₃ : LBC f₂₂ g₂₂ g₂₃ f₃₂ f₃₃ g₃₃ g₃₄ f₄₃)
--   (lbc₄ : LBC f₃₂ g₃₂ g₃₃ f₄₂ f₄₃ g₄₃ g₄₄ f₅₃) :
--   exact_seq 𝓐 [
--     lbc₁.ex_v lbc₂ ≫ lbc₂.rcp_to_H,
--     lbc₂.H_to_don,
--     lbc₂.ex_h lbc₃,
--     lbc₃.rcp_to_H,
--     lbc₃.H_to_don ≫ lbc₃.ex_v lbc₄] :=
-- begin
--   refine (exact_aux_1 lbc₁ lbc₂).cons _,
--   refine (exact_aux_2 lbc₂ lbc₃).cons _,
--   have aux1 := (exact_aux_2 lbc₃.op lbc₂.op).unop,
--   simp only [op_H_to_don, op_ex_h, unop_comp, ← iso.unop_hom, ← iso.unop_inv,
--     exact_comp_iso, exact_iso_comp, exact_comp_hom_inv_comp_iff, quiver.hom.unop_op] at aux1,
--   refine aux1.cons _,
--   have aux2 := (exact_aux_1 lbc₄.op lbc₃.op).unop,
--   simp only [op_H_to_don, op_ex_v, op_rcp_to_H, category.assoc, iso.inv_hom_id_assoc,
--     unop_comp, ← iso.unop_hom, ← iso.unop_inv, quiver.hom.unop_op,
--     exact_iso_comp, exact_comp_hom_inv_comp_iff] at aux2,
--   simp only [← category.assoc, exact_comp_iso] at aux2,
--   exact aux2.exact_seq,
-- end

-- lemma salamander_h
--   (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (lbc₂ : LBC f₁₂ g₁₂ g₁₃ f₂₂ f₂₃ g₂₃ g₂₄ f₃₃)
--   (lbc₃ : LBC f₂₂ g₂₂ g₂₃ f₃₂ f₃₃ g₃₃ g₃₄ f₄₃)
--   (lbc₄ : LBC f₂₃ g₂₃ g₂₄ f₃₃ f₃₄ g₃₄ g₃₅ f₄₄) :
--   exact_seq 𝓐 [
--     lbc₁.ex_h lbc₂ ≫ lbc₂.rcp_to_V,
--     lbc₂.V_to_don,
--     lbc₂.ex_v lbc₃,
--     lbc₃.rcp_to_V,
--     lbc₃.V_to_don ≫ lbc₃.ex_h lbc₄] :=
-- by convert salamander_v lbc₁.symm lbc₂.symm lbc₃.symm lbc₄.symm using 1

-- open_locale zero_object

-- section
-- /-!
-- ## Extramural isomorphisms
-- -/

-- lemma iso_ex_h
--   (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (lbc₂ : LBC f₁₂ g₁₂ g₁₃ f₂₂ f₂₃ g₂₃ g₂₄ f₃₃)
--   (h₁ : f₁₁ ≫ f₁₂ = 0) (h₂ : f₃₂ ≫ f₃₃ = 0)
--   (H₁ : is_zero lbc₁.H) (H₂ : is_zero lbc₂.H) :
--   is_iso (lbc₁.ex_h lbc₂) :=
-- begin
--   have := (salamander_v _ lbc₁ lbc₂ _).drop 1, any_goals { exact 0 },
--   rotate,
--   { exact LBC.of_core ⟨h₁, zero_comp, zero_comp.trans zero_comp.symm, lbc₂.sq₁⟩, },
--   { exact LBC.of_core ⟨h₂, comp_zero, lbc₁.sq₂, comp_zero.trans comp_zero.symm⟩, },
--   exact this.is_iso_of_zero_of_zero (H₁.eq_of_src _ _) (H₂.eq_of_tgt _ _),
-- end

-- lemma iso_ex_v
--   (lbc₁ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (lbc₂ : LBC f₂₁ g₂₁ g₂₂ f₃₁ f₃₂ g₃₂ g₃₃ f₄₂)
--   (h₁ : g₁₁ ≫ g₂₁ = 0) (h₂ : g₂₃ ≫ g₃₃ = 0)
--   (H₁ : is_zero lbc₁.V) (H₂ : is_zero lbc₂.V) :
--   is_iso (lbc₁.ex_v lbc₂) :=
-- by convert lbc₁.symm.iso_ex_h lbc₂.symm h₁ h₂ H₁ H₂ using 1

-- end

-- section intramural_isos

-- /-!
-- ## Intramural isomorphisms

-- The subscripts at the end of the names indicate where the `0`s in the diagram are located:
-- `ₗ` = left, `ᵤ` = up, `ᵣ` = right, and `ₛ` down (south, thanks unicode).

-- -/

-- lemma iso_rcp_to_Hₗ
--   (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (H₂₁ : is_zero A₂₁) (H₃₁ : is_zero A₃₁) (h : exact f₃₁ f₃₂) :
--   is_iso lbc.rcp_to_H :=
-- begin
--   have lbc₄ : LBC f₂₁ 0 g₂₂ f₃₁ f₃₂ 0 (0 : _ ⟶ 0) (0 : 0 ⟶ 0) :=
--   LBC.of_core ⟨H₃₁.eq_of_src _ _, comp_zero, H₂₁.eq_of_src _ _, comp_zero.trans comp_zero.symm⟩,
--   have lbc₃ : LBC 0 0 0 0 f₃₁ 0 0 0 :=
--   LBC.of_core ⟨zero_comp, comp_zero, zero_comp.trans zero_comp.symm, comp_zero.trans comp_zero.symm⟩,
--   haveI aux := iso_ex_h lbc₃ lbc₄ zero_comp zero_comp _ _, any_goals { exact 0 },
--   rotate,
--   { apply H₃₁.homology_is_zero, },
--   { exact exact.homology_is_zero _ _ h, },
--   have := (salamander_v _ _ lbc lbc₄).drop 2, any_goals { exact 0 },
--   rotate,
--   { exact LBC.of_core ⟨zero_comp, zero_comp, zero_comp.trans zero_comp.symm, lbc.sq₁⟩, },
--   { exact LBC.of_core ⟨zero_comp, comp_zero, zero_comp.trans zero_comp.symm, H₂₁.eq_of_src _ _⟩, },
--   refine this.is_iso_of_zero_of_zero _ _,
--   { refine is_zero.eq_of_src _ _ _, apply H₂₁.homology_is_zero },
--   { refine is_zero.eq_of_tgt _ _ _,
--     apply is_zero_of_iso_of_zero _ (as_iso (lbc₃.ex_h lbc₄)),
--     apply H₃₁.homology_is_zero, },
-- end

-- lemma iso_V_to_donₗ
--   (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (H₂₁ : is_zero A₂₁) (H₃₁ : is_zero A₃₁) (h : exact f₃₁ f₃₂) :
--   is_iso lbc.V_to_don :=
-- begin
--   have lbc₄ : LBC f₂₁ 0 g₂₂ f₃₁ f₃₂ 0 (0 : _ ⟶ 0) (0 : 0 ⟶ 0) :=
--   LBC.of_core ⟨H₃₁.eq_of_src _ _, comp_zero, H₂₁.eq_of_src _ _, comp_zero.trans comp_zero.symm⟩,
--   have lbc₃ : LBC 0 0 0 0 f₃₁ 0 0 0 :=
--   LBC.of_core ⟨zero_comp, comp_zero, zero_comp.trans zero_comp.symm, comp_zero.trans comp_zero.symm⟩,
--   haveI aux := iso_ex_h lbc₃ lbc₄ zero_comp zero_comp _ _, any_goals { exact 0 },
--   rotate,
--   { apply H₃₁.homology_is_zero, },
--   { exact exact.homology_is_zero _ _ h, },
--   have := salamander_h _ lbc lbc₄ _, any_goals { exact 0 },
--   rotate,
--   { exact LBC.of_core ⟨zero_comp, comp_zero, zero_comp.trans zero_comp.symm, H₂₁.eq_of_src _ _⟩, },
--   { exact LBC.of_core ⟨comp_zero, comp_zero, lbc.sq₂, comp_zero.trans comp_zero.symm⟩, },
--   refine this.is_iso_of_zero_of_zero _ _,
--   { refine is_zero.eq_of_src _ _ _, apply H₂₁.homology_is_zero },
--   { refine is_zero.eq_of_tgt _ _ _,
--     apply is_zero_of_iso_of_zero _ (as_iso (lbc₃.ex_h lbc₄)),
--     apply H₃₁.homology_is_zero, },
-- end

-- lemma iso_rcp_to_Vᵤ
--   (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (H₁₂ : is_zero A₁₂) (H₁₃ : is_zero A₁₃) (h : exact g₁₃ g₂₃) :
--   is_iso lbc.rcp_to_V :=
-- lbc.symm.iso_rcp_to_Hₗ H₁₂ H₁₃ h

-- lemma iso_H_to_donᵤ
--   (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (H₁₂ : is_zero A₁₂) (H₁₃ : is_zero A₁₃) (h : exact g₁₃ g₂₃) :
--   is_iso lbc.H_to_don :=
-- lbc.symm.iso_V_to_donₗ H₁₂ H₁₃ h

-- lemma iso_H_to_donᵣ
--   (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (H₁₂ : is_zero A₂₃) (H₁₃ : is_zero A₁₃) (h : exact f₁₁ f₁₂) :
--   is_iso lbc.H_to_don :=
-- begin
--   have aux := iso_rcp_to_Hₗ lbc.op H₁₂.op H₁₃.op h.op,
--   simp only [op_rcp_to_H] at aux,
--   replace aux := @is_iso.of_is_iso_comp_left _ _ _ _ _ _ _ _ aux,
--   replace aux := @is_iso.of_is_iso_comp_right _ _ _ _ _ _ _ _ aux,
--   rwa is_iso_op_iff at aux,
-- end

-- lemma iso_rcp_to_Vᵣ
--   (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (H₁₂ : is_zero A₂₃) (H₁₃ : is_zero A₁₃) (h : exact f₁₁ f₁₂) :
--   is_iso lbc.rcp_to_V :=
-- begin
--   have aux := iso_V_to_donₗ lbc.op H₁₂.op H₁₃.op h.op,
--   simp only [op_V_to_don] at aux,
--   replace aux := @is_iso.of_is_iso_comp_left _ _ _ _ _ _ _ _ aux,
--   replace aux := @is_iso.of_is_iso_comp_right _ _ _ _ _ _ _ _ aux,
--   rwa is_iso_op_iff at aux,
-- end

-- lemma iso_rcp_to_Hₛ
--   (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (H₃₁ : is_zero A₃₁) (H₃₂ : is_zero A₃₂) (h : exact g₁₁ g₂₁) :
--   is_iso lbc.rcp_to_H :=
-- lbc.symm.iso_rcp_to_Vᵣ H₃₂ H₃₁ h

-- lemma iso_V_to_donₛ
--   (lbc : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂)
--   (H₃₁ : is_zero A₃₁) (H₃₂ : is_zero A₃₂) (h : exact g₁₁ g₂₁) :
--   is_iso lbc.V_to_don :=
-- lbc.symm.iso_H_to_donᵣ H₃₂ H₃₁ h

-- end intramural_isos

-- section three_x_three

-- /-!
-- ## The 3×3 lemma
-- -/

-- -- move me
-- theorem _root_.list.tfae.mp {l} (h : tfae l) (n₁ n₂) {a b}
--   (h₁ : list.nth l n₁ = some a . tactic.interactive.refl)
--   (h₂ : list.nth l n₂ = some b . tactic.interactive.refl) :
--   a → b :=
-- (h.out n₁ n₂ h₁ h₂).mp

-- lemma three_x_three_top_row
--   (Hr2 : exact f₂₁ f₂₂) (Hr3 : exact f₃₁ f₃₂)
--   (Hc1 : exact g₁₁ g₂₁) (Hc2 : exact g₁₂ g₂₂) (Hc3 : exact g₁₃ g₂₃)
--   (sq₁₁ : f₁₁ ≫ g₁₂ = g₁₁ ≫ f₂₁) (sq₁₂ : f₁₂ ≫ g₁₃ = g₁₂ ≫ f₂₂)
--   (sq₂₁ : f₂₁ ≫ g₂₂ = g₂₁ ≫ f₃₁) (sq₂₂ : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂)
--   [mono f₂₁] [mono f₃₁] [mono g₁₁] [mono g₁₂] [mono g₁₃] :
--   exact f₁₁ f₁₂ ∧ mono f₁₁ :=
-- begin
--   have w : f₁₁ ≫ f₁₂ = 0,
--   { rw [← cancel_mono g₁₃, zero_comp, category.assoc, sq₁₂, reassoc_of sq₁₁, Hr2.w, comp_zero], },
--   let lbc₁₁ : LBC (0 : 0 ⟶ 0) (0 : 0 ⟶ 0) 0 0 f₁₁ g₁₁ g₁₂ f₂₁ :=
--     LBC.of_core ⟨zero_comp, zero_comp, (is_zero_zero _).eq_of_src _ _, sq₁₁⟩,
--   let lbc₁₂ : LBC (0 : 0 ⟶ 0) 0 0 f₁₁ f₁₂ g₁₂ g₁₃ f₂₂ :=
--     LBC.of_core ⟨w, zero_comp, (is_zero_zero _).eq_of_src _ _, sq₁₂⟩,
--   let lbc₂₁ : LBC 0 (0 : 0 ⟶ 0) g₁₁ 0 f₂₁ g₂₁ g₂₂ f₃₁ :=
--     LBC.of_core ⟨zero_comp, Hc1.w, (is_zero_zero _).eq_of_src _ _, sq₂₁⟩,
--   let lbc₂₂ : LBC f₁₁ g₁₁ g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂ :=
--     LBC.of_core ⟨Hr2.w, Hc2.w, sq₁₁, sq₂₂⟩,
--   suffices : is_zero lbc₁₁.H ∧ is_zero lbc₁₂.H,
--   { refine ⟨exact_of_homology_is_zero this.2, _⟩,
--     apply (tfae_mono (0:𝓐) f₁₁).mp 2 0,
--     exact exact_of_homology_is_zero this.1, },
--   split,
--   { haveI e1 := lbc₁₁.iso_rcp_to_Hₗ (is_zero_zero _) (is_zero_zero _)
--       ((tfae_mono (0:𝓐) f₂₁).mp 0 2 rfl rfl infer_instance),
--     haveI e2 := lbc₁₁.iso_rcp_to_Vᵤ (is_zero_zero _) (is_zero_zero _)
--       ((tfae_mono (0:𝓐) g₁₂).mp 0 2 rfl rfl infer_instance),
--     refine is_zero_of_iso_of_zero _
--       (as_iso $ inv lbc₁₁.rcp_to_V ≫ lbc₁₁.rcp_to_H),
--     refine exact.homology_is_zero _ _ _,
--     apply exact_zero_left_of_mono },
--   { haveI e1 := lbc₁₂.iso_H_to_donᵤ (is_zero_zero _) (is_zero_zero _)
--       ((tfae_mono (0:𝓐) g₁₃).mp 0 2 rfl rfl infer_instance),
--     haveI e2 := lbc₁₂.iso_ex_v lbc₂₂ zero_comp Hc3.w
--       (exact.homology_is_zero _ _ _) (Hc2.homology_is_zero _ _),
--     swap, { apply exact_zero_left_of_mono },
--     haveI e3 := lbc₂₁.iso_ex_h lbc₂₂ zero_comp Hr3.w
--       (exact.homology_is_zero _ _ _) (Hr2.homology_is_zero _ _),
--     swap, { apply exact_zero_left_of_mono },
--     haveI e4 := lbc₂₁.iso_V_to_donₗ (is_zero_zero _) (is_zero_zero _)
--       ((tfae_mono (0:𝓐) f₃₁).mp 0 2 rfl rfl infer_instance),
--     have aux : is_zero lbc₂₁.V := Hc1.homology_is_zero _ _,
--     apply is_zero_of_iso_of_zero aux,
--     exact as_iso
--       (lbc₂₁.V_to_don ≫ lbc₂₁.ex_h lbc₂₂ ≫ inv (lbc₁₂.ex_v lbc₂₂) ≫ inv lbc₁₂.H_to_don) }
-- end

-- lemma three_x_three_left_col
--   (Hr1 : exact f₁₁ f₁₂) (Hr2 : exact f₂₁ f₂₂) (Hr3 : exact f₃₁ f₃₂)
--   (Hc2 : exact g₁₂ g₂₂) (Hc3 : exact g₁₃ g₂₃)
--   (sq₁₁ : f₁₁ ≫ g₁₂ = g₁₁ ≫ f₂₁) (sq₁₂ : f₁₂ ≫ g₁₃ = g₁₂ ≫ f₂₂)
--   (sq₂₁ : f₂₁ ≫ g₂₂ = g₂₁ ≫ f₃₁) (sq₂₂ : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂)
--   [mono f₁₁] [mono f₂₁] [mono f₃₁] [mono g₁₂] [mono g₁₃] :
--   exact g₁₁ g₂₁ ∧ mono g₁₁ :=
-- three_x_three_top_row Hc2 Hc3 Hr1 Hr2 Hr3 sq₁₁.symm sq₂₁.symm sq₁₂.symm sq₂₂.symm

-- lemma three_x_three_bot_row
--   (Hr1 : exact f₁₁ f₁₂) (Hr2 : exact f₂₁ f₂₂)
--   (Hc1 : exact g₁₁ g₂₁) (Hc2 : exact g₁₂ g₂₂) (Hc3 : exact g₁₃ g₂₃)
--   (sq₁₁ : f₁₁ ≫ g₁₂ = g₁₁ ≫ f₂₁) (sq₁₂ : f₁₂ ≫ g₁₃ = g₁₂ ≫ f₂₂)
--   (sq₂₁ : f₂₁ ≫ g₂₂ = g₂₁ ≫ f₃₁) (sq₂₂ : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂)
--   [epi f₁₂] [epi f₂₂] [epi g₂₁] [epi g₂₂] [epi g₂₃] :
--   exact f₃₁ f₃₂ ∧ epi f₃₂ :=
-- begin
--   have : exact f₃₂.op f₃₁.op ∧ mono f₃₂.op :=
--     three_x_three_top_row Hr2.op Hr1.op Hc3.op Hc2.op Hc1.op _ _ _ _,
--   { refine ⟨this.1.unop, _⟩, haveI := this.2, exact category_theory.unop_epi_of_mono f₃₂.op },
--   all_goals { simp only [← op_comp, sq₁₁, sq₁₂, sq₂₁, sq₂₂] },
-- end

-- lemma three_x_three_right_col
--   (Hr1 : exact f₁₁ f₁₂) (Hr2 : exact f₂₁ f₂₂) (Hr3 : exact f₃₁ f₃₂)
--   (Hc1 : exact g₁₁ g₂₁) (Hc2 : exact g₁₂ g₂₂)
--   (sq₁₁ : f₁₁ ≫ g₁₂ = g₁₁ ≫ f₂₁) (sq₁₂ : f₁₂ ≫ g₁₃ = g₁₂ ≫ f₂₂)
--   (sq₂₁ : f₂₁ ≫ g₂₂ = g₂₁ ≫ f₃₁) (sq₂₂ : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂)
--   [epi f₁₂] [epi f₂₂] [epi f₃₂] [epi g₂₁] [epi g₂₂] :
--   exact g₁₃ g₂₃ ∧ epi g₂₃ :=
-- three_x_three_bot_row Hc1 Hc2 Hr1 Hr2 Hr3 sq₁₁.symm sq₂₁.symm sq₁₂.symm sq₂₂.symm

-- end three_x_three

-- section four

-- /-!
-- ## The four lemma

-- We prove a version of the four lemma that is slightly more general than the usual version.
-- -/

-- lemma four_lemma_top_epi
--   (Hr1 : exact_seq 𝓐 [f₂₁, f₂₂, f₂₃]) (Hr2 : exact_seq 𝓐 [f₃₁, f₃₂, f₃₃])
--   (Hc1 : exact g₁₂ g₂₂) (Hc2 : exact g₁₃ g₂₃)
--   (sq₁₂ : f₁₂ ≫ g₁₃ = g₁₂ ≫ f₂₂)
--   (sq₂₁ : f₂₁ ≫ g₂₂ = g₂₁ ≫ f₃₁) (sq₂₂ : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂)
--   (sq₂₃ : f₂₃ ≫ g₂₄ = g₂₃ ≫ f₃₃)
--   [mono g₁₃] [epi g₂₁] [mono g₂₄] :
--   epi f₁₂ :=
-- begin
--   rw epi_iff_exact_zero_right,
--   let lbc₁₃ : LBC (0 : 0 ⟶ 0) 0 0 f₁₂ (0 : _ ⟶ 0) g₁₃ 0 f₂₃ :=
--     LBC.of_core ⟨comp_zero, zero_comp, (is_zero_zero _).eq_of_src _ _, _⟩,
--   swap, { simp only [← cancel_mono g₂₄, zero_comp, category.assoc, sq₂₃, reassoc_of Hc2.w], },
--   let lbc₂₂ : LBC (0 : 0 ⟶ _) 0 g₁₂ f₂₁ f₂₂ g₂₂ g₂₃ f₃₂ :=
--     LBC.of_core ⟨Hr1.pair.w, Hc1.w, (is_zero_zero _).eq_of_src _ _, sq₂₂⟩,
--   let lbc₂₃ : LBC f₁₂ g₁₂ g₁₃ f₂₂ f₂₃ g₂₃ g₂₄ f₃₃ :=
--     LBC.of_core ⟨(Hr1.drop 1).pair.w, Hc2.w, sq₁₂, sq₂₃⟩,
--   let lbc₃₁ : LBC 0 (0 : 0 ⟶ _) g₂₁ (kernel.ι f₃₁) f₃₁ 0 (cokernel.π g₂₂) (0 : 0 ⟶ _) :=
--     LBC.of_core ⟨kernel.condition _, comp_zero, (is_zero_zero _).eq_of_src _ _, _⟩,
--   swap, { simp only [← cancel_epi g₂₁, comp_zero, ← reassoc_of sq₂₁, cokernel.condition] },
--   let lbc₃₂ : LBC f₂₁ g₂₁ g₂₂ f₃₁ f₃₂ (cokernel.π g₂₂) 0 (0 : _ ⟶ 0) :=
--     LBC.of_core ⟨Hr2.pair.w, cokernel.condition _, sq₂₁, (is_zero_zero _).eq_of_tgt _ _⟩,
--   let lbc₄₁ : LBC (kernel.ι f₃₁) 0 0 (0 : 0 ⟶ 0) (0 : 0 ⟶ cokernel g₂₂) 0 0 (0 : 0 ⟶ 0) :=
--     LBC.of_core ⟨comp_zero, comp_zero,
--       (is_zero_zero _).eq_of_tgt _ _, (is_zero_zero _).eq_of_src _ _⟩,
--   have e1 := lbc₁₃.iso_H_to_donᵤ (is_zero_zero _) (is_zero_zero _) (exact_of_zero 0 0),
--   have e2 := lbc₁₃.iso_ex_v lbc₂₃ zero_comp zero_comp
--     (exact.homology_is_zero _ _ $ exact_zero_left_of_mono _) (Hc2.homology_is_zero _ _),
--   have e3 := lbc₂₂.iso_ex_h lbc₂₃ zero_comp (Hr2.drop 1).pair.w
--     (Hr1.pair.homology_is_zero _ _) ((Hr1.drop 1).pair.homology_is_zero _ _),
--   have e3 := lbc₂₂.iso_ex_v lbc₃₂ zero_comp comp_zero
--     (Hc1.homology_is_zero _ _) ((abelian.exact_cokernel _).homology_is_zero _ _),
--   have e4 := lbc₃₁.iso_ex_h lbc₃₂ zero_comp zero_comp
--     (exact_kernel_ι.homology_is_zero _ _) (Hr2.pair.homology_is_zero _ _),
--   have e5 := lbc₃₁.iso_ex_v lbc₄₁ comp_zero comp_zero
--     (exact.homology_is_zero _ _ _) ((is_zero_zero _).homology_is_zero _ _ _),
--   swap, { rwa ← epi_iff_exact_zero_right, },
--   have aux : is_zero lbc₄₁.rcp := (is_zero_zero _).homology_is_zero _ _ _,
--   suffices : is_zero lbc₁₃.H, { exact exact_of_homology_is_zero this },
--   refine is_zero_of_iso_of_zero aux _,
--   resetI,
--   exact as_iso (inv (lbc₃₁.ex_v lbc₄₁) ≫ lbc₃₁.ex_h lbc₃₂ ≫ inv (lbc₂₂.ex_v lbc₃₂) ≫
--     lbc₂₂.ex_h lbc₂₃ ≫ inv (lbc₁₃.ex_v lbc₂₃) ≫ inv lbc₁₃.H_to_don),
-- end

-- -- move me
-- lemma sq_op (sq : f₁₁ ≫ g₁₂ = g₁₁ ≫ f₂₁) :
--   f₂₁.op ≫ g₁₁.op = g₁₂.op ≫ f₁₁.op :=
-- by simp only [← op_comp, sq]

-- lemma four_lemma_bot_mono
--   (Hr1 : exact_seq 𝓐 [f₂₁, f₂₂, f₂₃]) (Hr2 : exact_seq 𝓐 [f₃₁, f₃₂, f₃₃])
--   (Hc1 : exact g₂₂ g₃₂) (Hc2 : exact g₂₃ g₃₃)
--   (sq₂₁ : f₂₁ ≫ g₂₂ = g₂₁ ≫ f₃₁) (sq₂₂ : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂)
--   (sq₂₃ : f₂₃ ≫ g₂₄ = g₂₃ ≫ f₃₃) (sq₃₂ : f₃₂ ≫ g₃₃ = g₃₂ ≫ f₄₂)
--   [epi g₂₁] [mono g₂₄] [epi g₃₂] :
--   mono f₄₂ :=
-- begin
--   haveI : epi f₄₂.op := four_lemma_top_epi Hr2.op Hr1.op Hc2.op Hc1.op
--     (sq_op sq₃₂) (sq_op sq₂₃) (sq_op sq₂₂) (sq_op sq₂₁),
--   exact category_theory.unop_mono_of_epi f₄₂.op
-- end

-- lemma four_lemma_left_epi
--   (Hc1 : exact_seq 𝓐 [g₁₂, g₂₂, g₃₂]) (Hc2 : exact_seq 𝓐 [g₁₃, g₂₃, g₃₃])
--   (Hr1 : exact f₂₁ f₂₂) (Hr2 : exact f₃₁ f₃₂)
--   (sq₁₂ : f₁₂ ≫ g₁₃ = g₁₂ ≫ f₂₂)
--   (sq₂₁ : f₂₁ ≫ g₂₂ = g₂₁ ≫ f₃₁) (sq₂₂ : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂)
--   (sq₃₂ : f₃₂ ≫ g₃₃ = g₃₂ ≫ f₄₂)
--   [epi f₁₂] [mono f₄₂] [mono f₃₁] :
--   epi g₂₁ :=
-- four_lemma_top_epi Hc1 Hc2 Hr1 Hr2 sq₂₁.symm sq₁₂.symm sq₂₂.symm sq₃₂.symm

-- lemma four_lemma_right_mono
--   (Hc1 : exact_seq 𝓐 [g₁₂, g₂₂, g₃₂]) (Hc2 : exact_seq 𝓐 [g₁₃, g₂₃, g₃₃])
--   (Hr1 : exact f₂₂ f₂₃) (Hr2 : exact f₃₂ f₃₃)
--   (sq₁₂ : f₁₂ ≫ g₁₃ = g₁₂ ≫ f₂₂)
--   (sq₂₂ : f₂₂ ≫ g₂₃ = g₂₂ ≫ f₃₂) (sq₂₃ : f₂₃ ≫ g₂₄ = g₂₃ ≫ f₃₃)
--   (sq₃₂ : f₃₂ ≫ g₃₃ = g₃₂ ≫ f₄₂)
--   [epi f₁₂] [mono f₄₂] [epi f₂₃] :
--   mono g₂₄ :=
-- four_lemma_bot_mono Hc1 Hc2 Hr1 Hr2 sq₁₂.symm sq₂₂.symm sq₃₂.symm sq₂₃.symm

-- end four

end LBC


import data.part
import data.pfun

/-! Random lemmas, some may already be in mathlib -/

namespace part

@[simp] lemma mk_none {α : Type*} {dom : Prop} (v : dom → α) (h : ¬dom) :
  mk dom v = none := eq_none_iff'.mpr h

@[simp] lemma mk_some {α : Type*} {dom : Prop} (v : dom → α) (h : dom) :
  mk dom v = some (v h) := get_eq_iff_eq_some.mp rfl

/-- TODO: why is this not marked simp? Does something break? -/
attribute [simp] bind_some_eq_map

end part

namespace pfun

lemma fix_diverge {α β : Type*} {f : α →. β ⊕ α} (a : α) (ha : ¬(f a).dom) : f.fix a = part.none :=
by { rw part.eq_none_iff, intros b hb, exact ha (dom_of_mem_fix hb), }

lemma fix_iterate' {α β : Type*} {f : α →. β ⊕ α} (a : α) (a' : part α) (ha' : f a = a'.map sum.inr) :
  f.fix a = a' >>= λ r, f.fix r :=
begin
  cases a' with d₁ v₁, by_cases h₁ : d₁,
  { simp only [h₁, part.mk_some] at ⊢ ha', rw fix_fwd a (v₁ h₁), { simp, }, simpa [part.eq_some_iff] using ha', },
  rw fix_diverge, { simp [h₁], }, simpa [h₁, part.eq_none_iff'] using ha',
end

end pfun


/-
Copyright (c) 2022 Rémi Bottinelli. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémi Bottinelli
-/
import category_theory.groupoid
import combinatorics.quiver.basic

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

This file defines a few basic properties of groupoids.
-/

namespace category_theory

namespace groupoid

variables (C : Type*) [groupoid C]

section thin

lemma is_thin_iff : quiver.is_thin C ↔ ∀ c : C, subsingleton (c ⟶ c) :=
begin
  refine ⟨λ h c, h c c, λ h c d, subsingleton.intro $ λ f g, _⟩,
  haveI := h d,
  calc f = f ≫ (inv g ≫ g) : by simp only [inv_eq_inv, is_iso.inv_hom_id, category.comp_id]
     ... = f ≫ (inv f ≫ g) : by congr
     ... = g               : by simp only [inv_eq_inv, is_iso.hom_inv_id_assoc],
end

end thin

section disconnected

/-- A subgroupoid is totally disconnected if it only has loops. -/
def is_totally_disconnected := ∀ (c d : C), (c ⟶ d) → c = d

end disconnected

end groupoid

end category_theory


import for_mathlib.algebra.homology.derived_category_plus
import for_mathlib.algebra.homology.k_injective
import category_theory.preadditive.injective

noncomputable theory

open category_theory category_theory.category category_theory.limits
open_locale zero_object

namespace category_theory.morphism_property

instance isomorphism_contains_identities {C : Type*} [category C] :
  (isomorphisms C).contains_identities :=
{ id := λ X, by { rw isomorphisms.iff, apply_instance, }, }

instance isomorphism_multiplicative {C : Type*} [category C] :
  (isomorphisms C).multiplicative :=
{ contains_identities := infer_instance,
  comp := λ X Y Z f g hf hg, begin
    rw isomorphisms.iff at hf hg ⊢,
    haveI := hf,
    haveI := hg,
    apply_instance,
  end, }

end category_theory.morphism_property

variables {C ι : Type*} [category C] [abelian C] {c : complex_shape ι}

namespace homological_complex

class is_termwise_injective (K : homological_complex C c) : Prop :=
(X_injective [] : ∀ (n : ι), injective (K.X n))

instance (K : homological_complex C c) (n : ι) [K.is_termwise_injective] : injective (K.X n) :=
is_termwise_injective.X_injective K n

instance zero_is_termwise_injective :
  (0 : homological_complex C c).is_termwise_injective :=
⟨λ n, injective.of_iso (homological_complex.eval C c n).map_zero_object.symm
  infer_instance⟩

instance single_is_termwise_injective (X : C) (n : ι) [decidable_eq ι] [injective X]:
  ((homological_complex.single C c n).obj X).is_termwise_injective :=
⟨λ i, begin
  dsimp,
  split_ifs; apply_instance,
end⟩

end homological_complex

namespace cochain_complex

@[simp]
lemma shift_is_termwise_injective_iff
  (K : cochain_complex C ℤ) (n : ℤ) :
  homological_complex.is_termwise_injective (K⟦n⟧) ↔
  homological_complex.is_termwise_injective K :=
begin
  split,
  { introI,
    refine ⟨λ i, _⟩,
    obtain ⟨m, rfl⟩ : ∃ (m : ℤ), i = m+n := ⟨i-n, by simp⟩,
    have h := homological_complex.is_termwise_injective.X_injective (K⟦n⟧) m,
    exact h, },
  { introI,
    refine ⟨λ i, _⟩,
    apply homological_complex.is_termwise_injective.X_injective K _, },
end

instance mapping_cone_is_termwise_injective {K L : cochain_complex C ℤ} (f : K ⟶ L)
  [K.is_termwise_injective] [L.is_termwise_injective] :
  (mapping_cone f).is_termwise_injective :=
⟨λ n, by { dsimp [mapping_cone], apply_instance, }⟩

end cochain_complex

namespace homotopy_category

namespace plus

variables (C)

abbreviation termwise_injective :=
  full_subcategory (λ (K : homotopy_category.plus C), K.obj.as.is_termwise_injective)

namespace termwise_injective

variable {C}

abbreviation ι : termwise_injective C ⥤ homotopy_category.plus C :=
full_subcategory_inclusion _

instance is_triangulated_subcategory' :
  triangulated.is_triangulated_subcategory'
    (λ (K : homotopy_category.plus C), K.obj.as.is_termwise_injective) :=
{ zero := begin
    refine ⟨⟨⟨0⟩, ⟨0, infer_instance⟩⟩, _, homological_complex.zero_is_termwise_injective⟩,
    rw limits.is_zero.iff_id_eq_zero,
    change (homotopy_category.quotient C (complex_shape.up ℤ)).map (𝟙 0) = 0,
    simp only [limits.id_zero, functor.map_zero],
  end,
  shift := begin
    rintro ⟨⟨K⟩, hK⟩ n h,
    change K⟦n⟧.is_termwise_injective,
    simpa only [cochain_complex.shift_is_termwise_injective_iff] using h,
  end,
  distinguished_cocone_triangle' := begin
    rintro ⟨⟨K : cochain_complex C ℤ⟩, hK⟩ ⟨⟨L : cochain_complex C ℤ⟩, hL⟩ hK' hL',
    haveI : K.is_termwise_injective := hK',
    haveI : L.is_termwise_injective := hL',
    rintro (f : (homotopy_category.quotient _ _).obj K ⟶ (homotopy_category.quotient _ _).obj L),
    obtain ⟨f, rfl⟩ := (homotopy_category.quotient _ _).map_surjective f,
    exact ⟨⟨(homotopy_category.quotient _ _).obj (cochain_complex.mapping_cone f),
      cochain_complex.mapping_cone_is_plus f hK hL⟩,
      (infer_instance : (cochain_complex.mapping_cone f).is_termwise_injective),
      (homotopy_category.quotient _ _).map (cochain_complex.mapping_cone.inr f),
      (homotopy_category.quotient _ _).map (cochain_complex.mapping_cone.δ f),
      by { erw triangle_distinguished_iff, exact ⟨_, _, f, ⟨iso.refl _⟩⟩, }⟩,
  end, }

def Φ : localizor_morphism (morphism_property.isomorphisms (termwise_injective C))
  (triangulated.subcategory.W (homotopy_category.plus.acyclic C)) :=
{ functor := termwise_injective.ι,
  mapW := λ X Y f hf, begin
    rw morphism_property.isomorphisms.iff at hf,
    haveI := hf,
    rw ← triangulated.subcategory.is_iso_map_iff (acyclic C) derived_category.plus.Qh,
    apply_instance,
  end, }

instance Φ_functor_has_comm_shift :
  (Φ : localizor_morphism (morphism_property.isomorphisms
    (termwise_injective C)) _).functor.has_comm_shift ℤ :=
by { dsimp only [Φ], apply_instance, }

instance Φ_functor_is_triangulated :
  (Φ : localizor_morphism (morphism_property.isomorphisms
    (termwise_injective C)) _).functor.is_triangulated :=
by { dsimp only [Φ], apply_instance, }

def Qh : termwise_injective C ⥤ derived_category.plus C :=
termwise_injective.ι ⋙ derived_category.plus.Qh

instance Qh_has_comm_shift : (Qh : _ ⥤ derived_category.plus C).has_comm_shift ℤ :=
by { dsimp only [Qh], apply_instance, }

instance Qh_is_triangulated : (Qh : _ ⥤ derived_category.plus C).is_triangulated :=
by { dsimp only [Qh], apply_instance, }

instance is_K_injective_of_termwise_injective_of_is_plus (K : termwise_injective C) :
  K.obj.obj.is_K_injective :=
begin
  rw is_K_injective_iff',
  haveI := K.property,
  obtain ⟨n, hn⟩ := K.obj.property,
  haveI := hn,
  exact cochain_complex.is_K_injective_of_bounded_below_of_injective K.obj.obj.as n,
end

instance : faithful (Qh : _ ⥤ derived_category.plus C) :=
⟨λ K L, (derived_category.Qh_map_bijective_of_is_K_injective K.obj.obj L.obj.obj).1⟩

instance : full (Qh : _ ⥤ derived_category.plus C) :=
functor.full_of_surjective _
  (λ K L, (derived_category.Qh_map_bijective_of_is_K_injective K.obj.obj L.obj.obj).2)

variable [enough_injectives C]

lemma right_resolution_exists (Y : cochain_complex C ℤ)
  (n : ℤ) [Y.is_strictly_ge n] :
  ∃ (Z : cochain_complex C ℤ) (hZ : Z.is_strictly_ge n) (f : Y ⟶ Z)
    (hf : quasi_iso f), Z.is_termwise_injective := sorry

instance (Y : homotopy_category.plus C) :
  nonempty (Φ.right_resolution Y) :=
begin
  obtain ⟨n, hn⟩ := Y.property,
  haveI := hn,
  obtain ⟨Z, hZ, f, hf, hZ'⟩ := right_resolution_exists Y.obj.as n,
  exact ⟨localizor_morphism.right_resolution.mk Φ
    ⟨⟨(homotopy_category.quotient _ _).obj Z, ⟨n, hZ⟩⟩, hZ'⟩
    ((homotopy_category.quotient _ _).map f)
    (by simpa only [mem_acyclic_W_iff, ← mem_quasi_isomorphisms_iff] using hf)⟩,
end

instance : ess_surj (Qh : _ ⥤ derived_category.plus C) :=
⟨λ Z, begin
  have R : Φ.right_resolution (derived_category.plus.Qh.obj_preimage Z) :=
    nonempty.some infer_instance,
  refine ⟨R.right.obj, ⟨_ ≪≫ derived_category.plus.Qh.obj_obj_preimage_iso Z⟩⟩,
  haveI := localization.inverts derived_category.plus.Qh _ _ R.hom.hf,
  exact (as_iso (derived_category.plus.Qh.map (R.hom.f))).symm,
end⟩

instance : is_equivalence (Qh : _ ⥤ derived_category.plus C) :=
equivalence.of_fully_faithfully_ess_surj _

instance Qh_is_localization : Qh.is_localization
  (morphism_property.isomorphisms (termwise_injective C)) :=
begin
  haveI : (𝟭 _).is_localization (morphism_property.isomorphisms (termwise_injective C)) :=
    functor.is_localization.for_id _ (by refl),
  refine functor.is_localization.of_equivalence_target (𝟭 _) _ Qh
    (functor.as_equivalence Qh) (functor.left_unitor _),
end

instance Φ_is_localization_equivalence :
  (Φ : localizor_morphism (morphism_property.isomorphisms (termwise_injective C)) _).is_localization_equivalence :=
begin
  rw localizor_morphism.is_localization_equivalence.iff_is_localization Φ
    (derived_category.plus.Qh : plus C ⥤ _),
  change Qh.is_localization _,
  apply_instance,
end

instance (Y : homotopy_category.plus C) (X : Φ.right_resolution Y) :
  is_iso (derived_category.plus.Qh.map X.hom.f) :=
localization.inverts derived_category.plus.Qh _ _ X.hom.hf

lemma lift_map {Y₁ Y₂ : homotopy_category.plus C} (f : Y₁ ⟶ Y₂)
  (X₁ : Φ.right_resolution Y₁) (X₂ : Φ.right_resolution Y₂) :
  ∃ (f' : X₁.right.obj ⟶ X₂.right.obj), X₁.hom.f ≫ Φ.functor.map f' = f ≫ X₂.hom.f :=
begin
  haveI h : (Φ.functor.obj X₂.right.obj).obj.is_K_injective :=
    termwise_injective.is_K_injective_of_termwise_injective_of_is_plus X₂.right.obj,
  haveI : (homotopy_category.plus.ι.obj (Φ.induced_functor.obj X₂.right).obj).is_K_injective := h,
  let f'' := inv (derived_category.plus.Qh.map (X₁.hom.f)) ≫
    derived_category.plus.Qh.map (f ≫ X₂.hom.f),
  obtain ⟨f', hf'⟩ := (derived_category.Qh_map_bijective_of_is_K_injective _ _).2 (derived_category.plus.ι.map f''),
  refine ⟨f', (derived_category.Qh_map_bijective_of_is_K_injective _ _).1 _⟩,
  dsimp only [Φ, f''] at hf' ⊢,
  erw [functor.map_comp, hf'],
  change derived_category.plus.ι.map (derived_category.plus.Qh.map X₁.hom.f) ≫ _ ≫ _ = _,
  apply is_iso.hom_inv_id_assoc,
end

instance (Y : homotopy_category.plus C) :
  is_preconnected' (Φ.right_resolution Y) :=
⟨⟨begin
  rintro ⟨X₁⟩ ⟨X₂⟩,
  obtain ⟨g, hg⟩ := lift_map (𝟙 Y) X₁ X₂,
  dsimp at hg,
  rw id_comp at hg,
  haveI : is_iso (Qh.map g),
  { replace hg := derived_category.plus.Qh.congr_map hg,
    rw functor.map_comp at hg,
    change is_iso (derived_category.plus.Qh.map (Φ.functor.map g)),
    exact is_iso.of_is_iso_fac_left hg, },
  exact quot.sound ⟨structured_arrow.hom_mk ⟨g, is_iso_of_reflects_iso g termwise_injective.Qh⟩
    (by { ext, exact hg, })⟩,
end⟩⟩

def right_derivability_structure :
  right_derivability_structure.basic (Φ : localizor_morphism (morphism_property.isomorphisms (termwise_injective C)) _) :=
{ right_resolution_connected := λ Y, { },
  nonempty_arrow_right_resolution := λ Y₁ Y₂ f, begin
    let X₁ : Φ.right_resolution Y₁ := nonempty.some infer_instance,
    let X₂ : Φ.right_resolution Y₂ := nonempty.some infer_instance,
    obtain ⟨f', fac⟩ := lift_map f X₁ X₂,
    exact ⟨X₁, X₂, f', fac⟩,
  end, }

instance Φ_functor_comp_Qh_ess_surj_on_dist_triang : (Φ.functor ⋙
  derived_category.plus.Qh : _ ⥤ derived_category.plus C).ess_surj_on_dist_triang :=
begin
  haveI : (derived_category.plus.Qh : _ ⥤ derived_category.plus C).ess_surj_on_dist_triang := sorry,
  exact right_derivability_structure.Φ_functor_comp_L_ess_surj_on_dist_triang _,
end

section

variables {D : Type*} [category D]
  (F : homotopy_category.plus C ⥤ D)

instance existence_right_derived_functor :
  F.has_right_derived_functor (triangulated.subcategory.W (acyclic C)) :=
right_derivability_structure.basic.existence_derived_functor
  termwise_injective.right_derivability_structure F (morphism_property.isomorphisms.is_inverted_by _)

lemma is_iso_app (RF : derived_category.plus C ⥤ D)
  (α : F ⟶ derived_category.plus.Qh ⋙ RF)
  [RF.is_right_derived_functor α]
  (K : homotopy_category.plus C) [K.obj.as.is_termwise_injective] :
  is_iso (α.app K) :=
right_derivability_structure.basic.is_iso_app
  termwise_injective.right_derivability_structure derived_category.plus.Qh F
  (morphism_property.isomorphisms.is_inverted_by _) RF α ⟨K, infer_instance⟩

instance (K : homotopy_category.plus C) [K.obj.as.is_termwise_injective] :
  is_iso ((F.right_derived_functor_α derived_category.plus.Qh
    (triangulated.subcategory.W (acyclic C))).app K) :=
is_iso_app _ _ _ _

section

variables [has_zero_object D] [has_shift D ℤ] [preadditive D]
  [∀ (n : ℤ), (shift_functor D n).additive] [pretriangulated D]
  [F.has_comm_shift ℤ] [functor.is_triangulated F]

instance right_derived_functor_is_triangulated :
  (F.right_derived_functor derived_category.plus.Qh
    (triangulated.subcategory.W (acyclic C))).is_triangulated :=
right_derivability_structure.basic.derived_functor_is_triangulated'
    termwise_injective.right_derivability_structure F derived_category.plus.Qh
    (morphism_property.isomorphisms.is_inverted_by _)

end

end

end termwise_injective

end plus

end homotopy_category


inductive E where
  | mk : E → E

inductive F : E → Prop
  | mk : F e → F (E.mk e)

theorem dec (x : F (E.mk e)) : F e ∧ True :=
  match x with
  | F.mk h => ⟨h, trivial⟩

def mkNat (e : E) (x : F e) : Nat :=
  match e with
  | E.mk e' =>
    match dec x with
    | ⟨h, _⟩ => mkNat e' h

theorem fail (e : E) (x₁ : F e) (x₂ : F (E.mk e)) : mkNat e x₁ = mkNat (E.mk e) x₂ :=
  /- The following rfl was succeeding in the elaborator but failing in the kernel because
     of a discrepancy in the implementation for Eta-for-structures. -/
  rfl -- should fail


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import combinatorics.simplicial_complex.dump
import combinatorics.simplicial_complex.extreme
import combinatorics.simplicial_complex.finite
import combinatorics.simplicial_complex.boundary
import combinatorics.simplicial_complex.skeleton

namespace affine

open_locale classical affine big_operators
open set
variables {m n : ℕ} {E : Type*} [normed_group E] [normed_space ℝ E] {S : simplicial_complex E}
  {X : finset E}

lemma boundary_space_eq_space_frontier_of_full_dimensional (hS : S.full_dimensional) :
  S.boundary.space = frontier S.space :=
begin
  ext x,
  split,
  {
    sorry,
  },
  {
    sorry
  }
end

lemma boundary_face_iff_subset_space_frontier_of_full_dimensional (hS : S.full_dimensional) :
  X ∈ S.boundary.faces ↔ X ∈ S.faces ∧ ↑X ⊆ frontier S.space :=
begin
  split,
  { rintro ⟨Y, hY, hXY, Z, hZ, hYZ, hZunique⟩,
    use S.down_closed hY hXY,
    sorry
  },
  { rintro ⟨hX, hXspace⟩,
    sorry
  }
end

lemma closed_space_of_locally_finite (hS : S.locally_finite) :
  is_closed S.space :=
begin
  sorry
end

lemma space_frontier_eq :
  frontier S.space = (⋃ (X ∈ S.facets) (H : (X : finset E).card ≤ finite_dimensional.finrank ℝ E),
  convex_hull ↑X) ∪ (⋃ (X ∈ S.boundary.faces), combi_interior X) :=
begin
  sorry
end

lemma boundary_space_eq_of_full_dimensional (hS : S.full_dimensional) :
  frontier S.space = S.boundary.space :=
begin
  rw space_frontier_eq,
  rw combi_interiors_cover,
  ext x,
  split,
  {
    sorry
  },
  sorry
end

/-A simplicial complex is connected iff its space is-/
def simplicial_complex.connected (S : simplicial_complex E) :
  Prop :=
connected_space S.space

/-A simplicial complex is connected iff its 1-skeleton is-/
lemma connected_iff_one_skeleton_connected :
  S.connected ↔ (S.skeleton 1).connected :=
begin
  split,
  { rintro h,
    unfold simplicial_complex.connected,
    sorry
  },
  {
    sorry
  }
end

lemma locally_compact_realisation_iff_locally_finite :
  S.locally_finite ↔ locally_compact_space S.space :=
begin
  rw locally_finite_iff_mem_finitely_many_faces,
  split,
  {
    rintro hS,
    apply locally_compact_of_compact_nhds,
    rintro ⟨x, hx⟩,
    specialize hS x,
    sorry
  },
  {
    rintro hS x,
    --obtain ⟨a, b⟩ := hS x,
    sorry
  }
end

--def simplicial_complex.nonsingular (S : simplicial_complex E) {X : finset (fin m → ℝ)} : Prop :=
--  homeomorph (S.link {X}).space (metric.ball (0 : E) 1)

end affine


import unitb.category.basic

universes u u₀ u₁ u₂ v w

variable {k : Sort u₀}

variable {k}

variable {σ : Type u₀}

open predicate unitb

structure invariant (inv : pred' σ) (cat : pred' σ → pred' σ → Sort v) (p q : pred' σ) :=
  (run : cat (inv ⋀ p) (inv ⋀ q))

structure except
     (excp : pred' σ)
     (cat : pred' σ → pred' σ → Sort v)
     (p q : pred' σ) : Type v :=
  (run : cat p (q ⋁ excp))

variables {cat : pred' σ → pred' σ → Sort u}

def except_lift [lifted_pred cat]
  (e : pred' σ)
  {α β : pred' σ}
  (x : cat α β)
: except e cat α β :=
⟨ begin
    apply lifted_pred.mono_right _ _ _ x,
    apply p_or_intro_left,
  end ⟩

instance except_finite_disjunctive (e : pred' σ)
  [finite_disjunctive cat]
: finite_disjunctive (except e cat) :=
 { ident := by { intro, apply except.mk, apply lifted_pred.imp, apply p_or_intro_left }
 , comp  :=
   begin
     introv h₀ h₁,
     apply except.mk,
     apply cancellation,
     apply h₁.run,
     apply h₀.run,
   end
 , assoc :=
   begin
     intros, cases x, cases y, cases z,
     unfold has_comp.comp,
     apply congr_arg,
     apply cancellation_assoc cat,
   end
 , left_ident  :=
   begin
     introv, cases x with x,
     have h : cat α (β ⋁ e) :=
        cancellation cat β x (lifted_pred.weaken _ _),
     { unfold has_comp.comp except.run,
       apply congr_arg,
       unfold cancellation,
       simp [disj_imp_imp,imp_self_eq_ident] },
     apply p_or_intro_left
   end
 , right_ident :=
   begin
     introv, cases x with x,
     have h : cat α (β ⋁ e) :=
        cancellation cat β x (lifted_pred.weaken _ _),
     { unfold has_comp.comp except.run,
       apply congr_arg,
       unfold cancellation,
       simp [select_left_disj], },
       apply p_or_intro_left
   end
 , imp := assume p q,
   except.mk ∘ lifted_pred.imp cat p (q ⋁ e) ∘ entails_p_or_of_entails_left
 , disj :=
   begin
     introv h₀ h₁,
     apply except.mk,
     apply disj,
     apply h₀.run,
     apply h₁.run
   end
 , disj_imp_imp := by { introv,
                        apply congr_arg,
                        simp [function.comp,disj_imp_imp], }
 , select_left_disj := by { introv, cases Pp,
                            simp [cancellation,function.comp],
                            rw [disj.select_left_disj',select_left_disj] }
 , comp_over_disj_right := by { introv, simp [cancellation,comp_over_disj_right], }
 , imp_comp_imp_eq_imp_trans :=
   begin
     introv,
     simp [function.comp,has_comp.comp,except.run,cancellation],
     apply congr_arg,
     rw [disj_imp_imp,imp_comp_imp_eq_imp_trans],
   end
 , imp_self_eq_ident := by { introv, refl }
 , disj_flip :=
   begin
     introv, cases P₀ with P₀, cases P₁ with P₁,
     unfold has_comp.comp except.run cancellation function.comp,
     apply congr_arg,
     rw [disj.select_left_disj',disj_flip],
   end }

instance except_disjunctive (e : pred' σ)
  [disjunctive cat]
: disjunctive (except e cat) :=
 { (_ : finite_disjunctive (except e cat)) with
  disj' := by { introv h, apply except.mk, apply disj', intro, apply (h x).run, } }

@[trans]
def except_trans [finite_disjunctive cat]
  {e : pred' σ}
  {α} (β) {γ : pred' σ}
  (h₀ : except e cat α β)
  (h₁ : except e cat β γ)
: except e cat α γ :=
h₁ <<< h₀

instance inv_cat (inv : pred' σ)
  [category cat]
: category (invariant inv cat) :=
 { ident := assume p, ⟨ ident cat ⟩
 , comp := assume p q r m₀ m₁, ⟨ m₀.run <<< m₁.run ⟩
 , left_ident  := by { intros, cases x, simp [has_comp.comp] }
 , right_ident := by { intros, cases x, simp [has_comp.comp] }
 , assoc := by { intros, cases x, simp [has_comp.comp] }
 }

instance inv_lifted (inv : pred' σ)
  [lifted_pred cat]
: lifted_pred (invariant inv cat) :=
 { (_ : category (invariant inv cat)) with
   imp := assume p q Hpq, ⟨ lifted_pred.imp _ _ _ (p_and_entails_p_and_right _ Hpq) ⟩
 , imp_comp_imp_eq_imp_trans := by { introv, simp [has_comp.comp,imp_comp_imp_eq_imp_trans] }
 , imp_self_eq_ident := by { introv, simp [ident,imp_self_eq_ident] }
 }

lemma hcongr_arg
: ∀ {p q : Prop} {Hp : p} {Hq : q}, p = q → Hp == Hq
  | p ._ Hp Hq rfl := heq.rfl

lemma hcongr₁ {α : Sort u} {β : α → Sort v}
  {t : Π x : α, β x → Sort u₂}
  (f : Π (x : α) (y : β x), t x y)
: Π {x₀ x₁ : α} {y₀ : β x₀} {y₁ : β x₁}, x₀ = x₁ → y₀ == y₁ → f x₀ y₀ == f x₁ y₁
 | x₀ ._ y₀ ._ rfl heq.rfl := heq.rfl

lemma hcongr₂ {α : Sort u} {β : α → Sort v} {γ : Π x : α, β x → Sort u₁}
  {t : Π (x : α) (y : β x), γ x y → Sort u₂}
  (f : Π (x : α) (y : β x) (z : γ x y), t x y z)
: Π {x₀ x₁ : α} {y₀ : β x₀} {y₁ : β x₁} {z₀ : γ x₀ y₀} {z₁ : γ x₁ y₁},
   x₀ = x₁ → y₀ == y₁ → z₀ == z₁ → f x₀ y₀ z₀ == f x₁ y₁ z₁
 | x₀ ._ y₀ ._ z₀ ._ rfl heq.rfl heq.rfl := heq.rfl

lemma mpr_eq_comp_imp [lifted_pred cat] {p p' q : pred' σ}
  (P : cat p q)
  (H : p' = p)
: eq.mpr (by subst p) P = (P <<< lifted_pred.imp cat p' p (by subst p)) :=
by { subst p, simp [imp_self_eq_ident,eq.mpr], }

instance inv_fin_disj (inv : pred' σ) {cat : pred' σ → pred' σ → Sort u}
  [finite_disjunctive cat]
: finite_disjunctive (invariant inv cat) :=
 { inv_lifted inv with
   disj :=
   begin
     introv h₀ h₁,
     apply invariant.mk,
     rw p_and_over_or_left,
     apply disj _ h₀.run h₁.run,
   end
 , disj_imp_imp :=
   begin
     introv, simp [lifted_pred.imp,disj_imp_imp,eq.mpr],
     apply congr_arg,
     apply eq_of_heq,
     transitivity,
     apply cast_heq,
     have h := p_and_over_or_left inv p q,
     symmetry,
     apply hcongr₂ (@lifted_pred.imp σ cat _) h _,
     simp [h],
   end
 , select_left_disj :=
   begin
     introv,
     cases Pp with Pp,
     unfold has_comp.comp invariant.run,
     apply congr_arg,
     rw [mpr_eq_comp_imp, ← category.assoc, imp_comp_imp_eq_imp_trans, select_left_disj],
     { simp [p_and_over_or_left] },
   end
 , comp_over_disj_right :=
   begin
     introv,
     unfold has_comp.comp invariant.run,
     rw [mpr_eq_comp_imp, category.assoc,comp_over_disj_right, mpr_eq_comp_imp],
     all_goals { simp [p_and_over_or_left] },
   end
 , disj_flip :=
   begin
     introv,
     unfold has_comp.comp invariant.run,
     apply congr_arg,
     rw [disj_flip,mpr_eq_comp_imp, ← category.assoc, imp_comp_imp_eq_imp_trans],
     rw [@mpr_eq_comp_imp _ cat, ← category.assoc, imp_comp_imp_eq_imp_trans],
     all_goals { simp [p_and_over_or_left] },
   end
 }

instance inv_disj (inv : pred' σ) {cat : pred' σ → pred' σ → Sort u}
  [disjunctive cat]
: disjunctive (invariant inv cat) :=
 { inv_fin_disj inv with
   disj' :=
   begin
     introv H,
     apply invariant.mk,
     simp [p_and_over_p_exists_left],
     apply disj', intro,
     apply invariant.run (H x),
   end }


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.hom_functor
import category_theory.currying
import category_theory.products.basic

/-!
# The Yoneda embedding

The Yoneda embedding as a functor `yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁)`,
along with an instance that it is `fully_faithful`.

Also the Yoneda lemma, `yoneda_lemma : (yoneda_pairing C) ≅ (yoneda_evaluation C)`.

## References
* [Stacks: Opposite Categories and the Yoneda Lemma](https://stacks.math.columbia.edu/tag/001L)
-/

namespace category_theory
open opposite

universes v₁ u₁ u₂-- morphism levels before object levels. See note [category_theory universes].

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

/--
The Yoneda embedding, as a functor from `C` into presheaves on `C`.

See https://stacks.math.columbia.edu/tag/001O.
-/
@[simps]
def yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁) :=
{ obj := λ X,
  { obj := λ Y, unop Y ⟶ X,
    map := λ Y Y' f g, f.unop ≫ g,
    map_comp' := λ _ _ _ f g, begin ext, dsimp, erw [category.assoc] end,
    map_id' := λ Y, begin ext, dsimp, erw [category.id_comp] end },
  map := λ X X' f, { app := λ Y g, g ≫ f } }

/--
The co-Yoneda embedding, as a functor from `Cᵒᵖ` into co-presheaves on `C`.
-/
@[simps] def coyoneda : Cᵒᵖ ⥤ (C ⥤ Type v₁) :=
{ obj := λ X,
  { obj := λ Y, unop X ⟶ Y,
    map := λ Y Y' f g, g ≫ f },
  map := λ X X' f, { app := λ Y g, f.unop ≫ g } }

namespace yoneda

lemma obj_map_id {X Y : C} (f : op X ⟶ op Y) :
  (yoneda.obj X).map f (𝟙 X) = (yoneda.map f.unop).app (op Y) (𝟙 Y) :=
by { dsimp, simp }

@[simp] lemma naturality {X Y : C} (α : yoneda.obj X ⟶ yoneda.obj Y)
  {Z Z' : C} (f : Z ⟶ Z') (h : Z' ⟶ X) : f ≫ α.app (op Z') h = α.app (op Z) (f ≫ h) :=
(functor_to_types.naturality _ _ α f.op h).symm

/--
The Yoneda embedding is full.

See https://stacks.math.columbia.edu/tag/001P.
-/
instance yoneda_full : full (yoneda : C ⥤ Cᵒᵖ ⥤ Type v₁) :=
{ preimage := λ X Y f, f.app (op X) (𝟙 X) }

/--
The Yoneda embedding is faithful.

See https://stacks.math.columbia.edu/tag/001P.
-/
instance yoneda_faithful : faithful (yoneda : C ⥤ Cᵒᵖ ⥤ Type v₁) :=
{ map_injective' := λ X Y f g p, by convert (congr_fun (congr_app p (op X)) (𝟙 X)); dsimp; simp }

/-- Extensionality via Yoneda. The typical usage would be
```
-- Goal is `X ≅ Y`
apply yoneda.ext,
-- Goals are now functions `(Z ⟶ X) → (Z ⟶ Y)`, `(Z ⟶ Y) → (Z ⟶ X)`, and the fact that these
functions are inverses and natural in `Z`.
```
-/
def ext (X Y : C)
  (p : Π {Z : C}, (Z ⟶ X) → (Z ⟶ Y)) (q : Π {Z : C}, (Z ⟶ Y) → (Z ⟶ X))
  (h₁ : Π {Z : C} (f : Z ⟶ X), q (p f) = f) (h₂ : Π {Z : C} (f : Z ⟶ Y), p (q f) = f)
  (n : Π {Z Z' : C} (f : Z' ⟶ Z) (g : Z ⟶ X), p (f ≫ g) = f ≫ p g) : X ≅ Y :=
@preimage_iso _ _ _ _ yoneda _ _ _ _
  (nat_iso.of_components (λ Z, { hom := p, inv := q, }) (by tidy))

/--
If `yoneda.map f` is an isomorphism, so was `f`.
-/
lemma is_iso {X Y : C} (f : X ⟶ Y) [is_iso (yoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful yoneda f

end yoneda

namespace coyoneda

@[simp] lemma naturality {X Y : Cᵒᵖ} (α : coyoneda.obj X ⟶ coyoneda.obj Y)
  {Z Z' : C} (f : Z' ⟶ Z) (h : unop X ⟶ Z') : (α.app Z' h) ≫ f = α.app Z (h ≫ f) :=
(functor_to_types.naturality _ _ α f h).symm

instance coyoneda_full : full (coyoneda : Cᵒᵖ ⥤ C ⥤ Type v₁) :=
{ preimage := λ X Y f, (f.app _ (𝟙 X.unop)).op }

instance coyoneda_faithful : faithful (coyoneda : Cᵒᵖ ⥤ C ⥤ Type v₁) :=
{ map_injective' := λ X Y f g p,
  begin
    have t := congr_fun (congr_app p X.unop) (𝟙 _),
    simpa using congr_arg quiver.hom.op t,
  end }

/--
If `coyoneda.map f` is an isomorphism, so was `f`.
-/
lemma is_iso {X Y : Cᵒᵖ} (f : X ⟶ Y) [is_iso (coyoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful coyoneda f

/-- The identity functor on `Type` is isomorphic to the coyoneda functor coming from `punit`. -/
def punit_iso : coyoneda.obj (opposite.op punit) ≅ 𝟭 (Type v₁) :=
nat_iso.of_components
  (λ X, { hom := λ f, f ⟨⟩, inv := λ x _, x })
  (by tidy)

end coyoneda

namespace functor

/--
A functor `F : Cᵒᵖ ⥤ Type v₁` is representable if there is object `X` so `F ≅ yoneda.obj X`.

See https://stacks.math.columbia.edu/tag/001Q.
-/
class representable (F : Cᵒᵖ ⥤ Type v₁) : Prop :=
(has_representation : ∃ X (f : yoneda.obj X ⟶ F), is_iso f)

instance {X : C} : representable (yoneda.obj X) :=
{ has_representation := ⟨X, 𝟙 _, infer_instance⟩ }

/--
A functor `F : C ⥤ Type v₁` is corepresentable if there is object `X` so `F ≅ coyoneda.obj X`.

See https://stacks.math.columbia.edu/tag/001Q.
-/
class corepresentable (F : C ⥤ Type v₁) : Prop :=
(has_corepresentation : ∃ X (f : coyoneda.obj X ⟶ F), is_iso f)

instance {X : Cᵒᵖ} : corepresentable (coyoneda.obj X) :=
{ has_corepresentation := ⟨X, 𝟙 _, infer_instance⟩ }

-- instance : corepresentable (𝟭 (Type v₁)) :=
-- corepresentable_of_nat_iso (op punit) coyoneda.punit_iso

section representable
variables (F : Cᵒᵖ ⥤ Type v₁)
variable [F.representable]

/-- The representing object for the representable functor `F`. -/
noncomputable def repr_X : C :=
(representable.has_representation : ∃ X (f : _ ⟶ F), _).some

/-- The (forward direction of the) isomorphism witnessing `F` is representable. -/
noncomputable def repr_f : yoneda.obj F.repr_X ⟶ F :=
representable.has_representation.some_spec.some

/--
The representing element for the representable functor `F`, sometimes called the universal
element of the functor.
-/
noncomputable def repr_x : F.obj (op F.repr_X) :=
F.repr_f.app (op F.repr_X) (𝟙 F.repr_X)

instance : is_iso F.repr_f :=
representable.has_representation.some_spec.some_spec

/--
An isomorphism between `F` and a functor of the form `C(-, F.repr_X)`.  Note the components
`F.repr_w.app X` definitionally have type `(X.unop ⟶ F.repr_X) ≅ F.obj X`.
-/
noncomputable def repr_w : yoneda.obj F.repr_X ≅ F := as_iso F.repr_f

@[simp] lemma repr_w_hom : F.repr_w.hom = F.repr_f := rfl

lemma repr_w_app_hom (X : Cᵒᵖ) (f : unop X ⟶ F.repr_X) :
  (F.repr_w.app X).hom f = F.map f.op F.repr_x :=
begin
  change F.repr_f.app X f = (F.repr_f.app (op F.repr_X) ≫ F.map f.op) (𝟙 F.repr_X),
  rw ←F.repr_f.naturality,
  dsimp,
  simp
end

end representable

section corepresentable

variables (F : C ⥤ Type v₁)
variable [F.corepresentable]

/-- The representing object for the corepresentable functor `F`. -/
noncomputable def corepr_X : C :=
(corepresentable.has_corepresentation : ∃ X (f : _ ⟶ F), _).some.unop

/-- The (forward direction of the) isomorphism witnessing `F` is corepresentable. -/
noncomputable def corepr_f : coyoneda.obj (op F.corepr_X) ⟶ F :=
corepresentable.has_corepresentation.some_spec.some

/--
The representing element for the corepresentable functor `F`, sometimes called the universal
element of the functor.
-/
noncomputable def corepr_x : F.obj F.corepr_X :=
F.corepr_f.app F.corepr_X (𝟙 F.corepr_X)

instance : is_iso F.corepr_f :=
corepresentable.has_corepresentation.some_spec.some_spec

/--
An isomorphism between `F` and a functor of the form `C(F.corepr X, -)`. Note the components
`F.corepr_w.app X` definitionally have type `F.corepr_X ⟶ X ≅ F.obj X`.
-/
noncomputable def corepr_w : coyoneda.obj (op F.corepr_X) ≅ F := as_iso F.corepr_f

lemma corepr_w_app_hom (X : C) (f : F.corepr_X ⟶ X) :
  (F.corepr_w.app X).hom f = F.map f F.corepr_x :=
begin
  change F.corepr_f.app X f = (F.corepr_f.app F.corepr_X ≫ F.map f) (𝟙 F.corepr_X),
  rw ←F.corepr_f.naturality,
  dsimp,
  simp
end

end corepresentable

end functor

lemma representable_of_nat_iso (F : Cᵒᵖ ⥤ Type v₁) {G} (i : F ≅ G) [F.representable] :
  G.representable :=
{ has_representation := ⟨F.repr_X, F.repr_f ≫ i.hom, infer_instance⟩ }

lemma corepresentable_of_nat_iso (F : C ⥤ Type v₁) {G} (i : F ≅ G) [F.corepresentable] :
  G.corepresentable :=
{ has_corepresentation := ⟨op F.corepr_X, F.corepr_f ≫ i.hom, infer_instance⟩ }

instance : functor.corepresentable (𝟭 (Type v₁)) :=
corepresentable_of_nat_iso (coyoneda.obj (op punit)) coyoneda.punit_iso

open opposite

variables (C)

-- We need to help typeclass inference with some awkward universe levels here.
instance prod_category_instance_1 : category ((Cᵒᵖ ⥤ Type v₁) × Cᵒᵖ) :=
category_theory.prod.{(max u₁ v₁) v₁} (Cᵒᵖ ⥤ Type v₁) Cᵒᵖ

instance prod_category_instance_2 : category (Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) :=
category_theory.prod.{v₁ (max u₁ v₁)} Cᵒᵖ (Cᵒᵖ ⥤ Type v₁)

open yoneda

/--
The "Yoneda evaluation" functor, which sends `X : Cᵒᵖ` and `F : Cᵒᵖ ⥤ Type`
to `F.obj X`, functorially in both `X` and `F`.
-/
def yoneda_evaluation : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
evaluation_uncurried Cᵒᵖ (Type v₁) ⋙ ulift_functor.{u₁}

@[simp] lemma yoneda_evaluation_map_down
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (x : (yoneda_evaluation C).obj P) :
  ((yoneda_evaluation C).map α x).down = α.2.app Q.1 (P.2.map α.1 x.down) := rfl

/--
The "Yoneda pairing" functor, which sends `X : Cᵒᵖ` and `F : Cᵒᵖ ⥤ Type`
to `yoneda.op.obj X ⟶ F`, functorially in both `X` and `F`.
-/
def yoneda_pairing : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
functor.prod yoneda.op (𝟭 (Cᵒᵖ ⥤ Type v₁)) ⋙ functor.hom (Cᵒᵖ ⥤ Type v₁)

@[simp] lemma yoneda_pairing_map
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (β : (yoneda_pairing C).obj P) :
  (yoneda_pairing C).map α β = yoneda.map α.1.unop ≫ β ≫ α.2 := rfl

/--
The Yoneda lemma asserts that that the Yoneda pairing
`(X : Cᵒᵖ, F : Cᵒᵖ ⥤ Type) ↦ (yoneda.obj (unop X) ⟶ F)`
is naturally isomorphic to the evaluation `(X, F) ↦ F.obj X`.

See https://stacks.math.columbia.edu/tag/001P.
-/
def yoneda_lemma : yoneda_pairing C ≅ yoneda_evaluation C :=
{ hom :=
  { app := λ F x, ulift.up ((x.app F.1) (𝟙 (unop F.1))),
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      erw [category.id_comp, ←functor_to_types.naturality],
      simp only [category.comp_id, yoneda_obj_map],
    end },
  inv :=
  { app := λ F x,
    { app := λ X a, (F.2.map a.op) x.down,
      naturality' :=
      begin
        intros X Y f, ext, dsimp,
        rw [functor_to_types.map_comp_apply]
      end },
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      rw [←functor_to_types.naturality, functor_to_types.map_comp_apply]
    end },
  hom_inv_id' :=
  begin
    ext, dsimp,
    erw [←functor_to_types.naturality,
         obj_map_id],
    simp only [yoneda_map_app, quiver.hom.unop_op],
    erw [category.id_comp],
  end,
  inv_hom_id' :=
  begin
    ext, dsimp,
    rw [functor_to_types.map_id_apply]
  end }.

variables {C}

/--
The isomorphism between `yoneda.obj X ⟶ F` and `F.obj (op X)`
(we need to insert a `ulift` to get the universes right!)
given by the Yoneda lemma.
-/
@[simps] def yoneda_sections (X : C) (F : Cᵒᵖ ⥤ Type v₁) :
  (yoneda.obj X ⟶ F) ≅ ulift.{u₁} (F.obj (op X)) :=
(yoneda_lemma C).app (op X, F)

/--
We have a type-level equivalence between natural transformations from the yoneda embedding
and elements of `F.obj X`, without any universe switching.
-/
def yoneda_equiv {X : C} {F : Cᵒᵖ ⥤ Type v₁} : (yoneda.obj X ⟶ F) ≃ F.obj (op X) :=
(yoneda_sections X F).to_equiv.trans equiv.ulift

@[simp]
lemma yoneda_equiv_apply {X : C} {F : Cᵒᵖ ⥤ Type v₁} (f : yoneda.obj X ⟶ F) :
  yoneda_equiv f = f.app (op X) (𝟙 X) :=
rfl

@[simp]
lemma yoneda_equiv_symm_app_apply {X : C} {F : Cᵒᵖ ⥤ Type v₁} (x : F.obj (op X))
  (Y : Cᵒᵖ) (f : Y.unop ⟶ X) :
  (yoneda_equiv.symm x).app Y f = F.map f.op x :=
rfl

lemma yoneda_equiv_naturality {X Y : C} {F : Cᵒᵖ ⥤ Type v₁} (f : yoneda.obj X ⟶ F) (g : Y ⟶ X) :
  F.map g.op (yoneda_equiv f) = yoneda_equiv (yoneda.map g ≫ f) :=
begin
  change (f.app (op X) ≫ F.map g.op) (𝟙 X) = f.app (op Y) (𝟙 Y ≫ g),
  rw ←f.naturality,
  dsimp,
  simp,
end

/--
When `C` is a small category, we can restate the isomorphism from `yoneda_sections`
without having to change universes.
-/
def yoneda_sections_small {C : Type u₁} [small_category C] (X : C)
  (F : Cᵒᵖ ⥤ Type u₁) :
  (yoneda.obj X ⟶ F) ≅ F.obj (op X) :=
yoneda_sections X F ≪≫ ulift_trivial _

@[simp]
lemma yoneda_sections_small_hom {C : Type u₁} [small_category C] (X : C)
  (F : Cᵒᵖ ⥤ Type u₁) (f : yoneda.obj X ⟶ F) :
  (yoneda_sections_small X F).hom f = f.app _ (𝟙 _) :=
rfl

@[simp]
lemma yoneda_sections_small_inv_app_apply {C : Type u₁} [small_category C] (X : C)
  (F : Cᵒᵖ ⥤ Type u₁) (t : F.obj (op X)) (Y : Cᵒᵖ) (f : Y.unop ⟶ X) :
  ((yoneda_sections_small X F).inv t).app Y f = F.map f.op t :=
rfl

local attribute[ext] functor.ext

/-- The curried version of yoneda lemma when `C` is small. -/
def curried_yoneda_lemma {C : Type u₁} [small_category C] :
  (yoneda.op ⋙ coyoneda : Cᵒᵖ ⥤ (Cᵒᵖ ⥤ Type u₁) ⥤ Type u₁) ≅ evaluation Cᵒᵖ (Type u₁) :=
eq_to_iso (by tidy) ≪≫ curry.map_iso (yoneda_lemma C ≪≫
  iso_whisker_left (evaluation_uncurried Cᵒᵖ (Type u₁)) ulift_functor_trivial) ≪≫
    eq_to_iso (by tidy)

/-- The curried version of yoneda lemma when `C` is small. -/
def curried_yoneda_lemma' {C : Type u₁} [small_category C] :
  yoneda ⋙ (whiskering_left Cᵒᵖ (Cᵒᵖ ⥤ Type u₁)ᵒᵖ (Type u₁)).obj yoneda.op ≅ 𝟭 (Cᵒᵖ ⥤ Type u₁) :=
eq_to_iso (by tidy) ≪≫ curry.map_iso (iso_whisker_left (prod.swap _ _)
  (yoneda_lemma C ≪≫ iso_whisker_left
    (evaluation_uncurried Cᵒᵖ (Type u₁)) ulift_functor_trivial : _)) ≪≫ eq_to_iso (by tidy)

end category_theory


import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.reflexive
import category_theory.limits.opposites
import category_theory.closed.cartesian
import category_theory.adjunction.basic
import category_theory.functor.epi_mono
import category_theory.monad.basic
import category_theory.monad.monadicity
import category_theory.functor.basic

import topos
import direct_image

open category_theory category_theory.category category_theory.limits category_theory.cartesian_closed topos classifier opposite

universes v u

noncomputable theory

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

-- We follow McLane and describe the chain of natural iso to prove
-- P_op ⊣ P of Theorem IV.5.1
-- There should definitely be a clever way

def prod_yoneda_Ω : (Cᵒᵖ × Cᵒᵖ) ⥤ Type v :=
{ obj := λ x, (yoneda.obj (Ω C)).obj (op (x.1.unop ⨯ x.2.unop)),
  map := λ x y f, (yoneda.obj (Ω C)).map (limits.prod.map f.1.unop f.2.unop).op,
  map_id' := λ x, by simp,
  map_comp' := λ x y z f g,
  begin
    rw ←functor.map_comp, congr,
    rw [←op_comp, limits.prod.map_map, ←unop_comp, ←unop_comp],
    congr
   end }

def prod_yoneda_iso_right_hom : prod_yoneda_Ω C ≅ right_hom (P C) :=
{ hom :=
  { app := λ x f, curry ((prod.braiding x.1.unop x.2.unop).inv ≫ f),
    naturality' := λ x y f,
    begin
      ext g, repeat {rw [types_comp_apply, prod.braiding_inv]},
      rw curry_eq_iff,
      dunfold right_hom P, simp only,
      rw [←assoc, uncurry_natural_left, uncurry_pre, ←assoc, limits.prod.map_map, id_comp, comp_id,
          ←comp_id f.snd.unop, ←limits.prod.map_map, assoc, ←uncurry_eq, uncurry_curry],
      dunfold prod_yoneda_Ω yoneda, simp only, rw quiver.hom.unop_op,
      erw [←assoc, ←assoc, braid_natural, ←braid_natural]
     end },
  inv :=
  { app := λ x f, (prod.braiding x.1.unop x.2.unop).hom ≫ uncurry f,
    naturality' := λ x y f,
    begin
      ext g, repeat {rw [types_comp_apply, prod.braiding_hom]},
      dunfold right_hom P, simp only,
      rw [←assoc, uncurry_natural_left, uncurry_pre],
      nth_rewrite 1 ←assoc,
      rw [limits.prod.map_map, id_comp, comp_id, ←comp_id f.snd.unop,
          ←limits.prod.map_map, assoc, ←uncurry_eq, ←assoc],
      erw ←braid_natural,
      dunfold prod_yoneda_Ω yoneda, simp only,
      rw [prod.braiding_hom, assoc, quiver.hom.unop_op],
    end },
  hom_inv_id' :=
  begin
    ext x f,
    simp only [prod.braiding_inv, uncurry_curry, prod.braiding_hom,
               functor_to_types.comp, nat_trans.id_app, types_id_apply],
    rw [←assoc, prod.symmetry'], apply id_comp,
  end,
  inv_hom_id' :=
  begin
    ext x f,
    simp only [prod.braiding_inv, prod.braiding_hom, functor_to_types.comp,
               nat_trans.id_app, types_id_apply],
    erw [←assoc, prod.symmetry', id_comp (uncurry f), curry_uncurry]
  end }

def left_hom_iso_prod_yoneda : left_hom (P_op C) ≅ prod_yoneda_Ω C :=
{ hom :=
  { app := λ x f, uncurry f.unop,
    naturality' := λ x y f,
    begin
      ext g, simp, dunfold left_hom prod_yoneda_Ω P_op P,
      simp only [functor.right_op_map, quiver.hom.op_unop, unop_comp,
                 quiver.hom.unop_op, assoc, yoneda_obj_map],
      erw [←assoc, uncurry_natural_left, uncurry_pre, ←assoc ,uncurry_eq, limits.prod.map_map,
           id_comp, comp_id, ←assoc, limits.prod.map_map],
      congr, rw comp_id,
    end},
  inv :=
  { app := λ x f, (curry f).op,
    naturality' := λ x y f,
    begin
      ext g, dunfold left_hom prod_yoneda_Ω P_op P,
      simp only [types_comp_apply, yoneda_obj_map, quiver.hom.unop_op,
                 functor.right_op_map],
      nth_rewrite 1 ←quiver.hom.op_unop f.snd,
      rw [←op_comp, ←op_comp],
      congr,
      rw [curry_eq_iff, uncurry_natural_left, uncurry_pre, ←assoc,
          limits.prod.map_map, id_comp,  ←comp_id f.fst.unop],
      nth_rewrite 2 comp_id,
      rw [←limits.prod.map_map, assoc],
      change op (unop x.fst) with x.fst,
      rw [←uncurry_eq (curry g), comp_id, uncurry_curry],
    end },
  hom_inv_id' := by { ext, simp },
  inv_hom_id' := by { ext, simp },}

def P_op_P_hom_equiv : P_op C ⊣ P C :=
adjunction_of_left_hom_iso_right (left_hom_iso_prod_yoneda C ≪≫ prod_yoneda_iso_right_hom C)

instance : is_right_adjoint (P C) := is_right_adjoint.mk _ (P_op_P_hom_equiv C)

-- Now we will follow IV.5.3 to prove that P is monadic
-- As a corollary, we have all finite colimits
variable {C}
lemma uncurry_singleton_P_map_simp {d c : C} (f : d ⟶ c) :
  uncurry (singleton_map c ≫ (P C).map f.op) = limits.prod.map f (𝟙 _) ≫ δ c :=
begin
  dunfold P, simp,
  rw [uncurry_natural_left,uncurry_pre, ←assoc, limits.prod.map_map],
  change (unop (op c)) with c,
  rw [id_comp, comp_id, ←id_comp (singleton_map c), ←comp_id f,
      ←limits.prod.map_map, assoc],
  erw [←uncurry_eq, uncurry_curry, comp_id],
end

instance P_faithful : faithful (P C) :=
{ map_injective' :=
  begin
    intros c d h k heq,
    have eq := congr_arg uncurry (whisker_eq (singleton_map c.unop) heq),
    rw [←quiver.hom.op_unop h, ←quiver.hom.op_unop k,
        uncurry_singleton_P_map_simp h.unop,  uncurry_singleton_P_map_simp k.unop,
        ←delta.classifies, ←delta.classifies, delta.cancel_classifier] at eq,
    apply quiver.hom.unop_inj eq
  end }

instance P_reflects_iso : reflects_isomorphisms (P C) :=
begin
  haveI : balanced Cᵒᵖ := balanced_opposite,
  apply_instance,
end

namespace preserves

variables {a b : Cᵒᵖ} {h k : a ⟶ b}

def fork_of_op_cofork (cof : cofork h k) : fork h.unop k.unop :=
fork.of_ι cof.π.unop (by { rw [←unop_comp, cof.condition, unop_comp] })

def op_cofork_of_fork (f : fork h.unop k.unop) : cofork h k :=
cofork.of_π f.ι.op
begin
  change h with h.unop.op,
  rw [←op_comp, f.condition, op_comp],
  refl,
end

lemma is_limit_fork_of_is_limit_op_cofork {cof : cofork h k} (coeq : is_colimit cof) :
  is_limit (fork_of_op_cofork cof) :=
begin
  apply fork.is_limit.of_exists_unique,
  intro s,
  let s_op := op_cofork_of_fork s,
  cases cofork.is_colimit.exists_unique coeq s_op.π s_op.condition with d hd,
  use d.unop,
  simp only at *,
  erw [fork.ι_of_ι, ←unop_comp, hd.left, cofork.π_of_π],
  split, refl,
  intro y,
  change y with y.op.unop,
  rw ←unop_comp,
  intro hf,
  change s.ι with s_op.π.unop at hf,
  rw hd.right y.op (quiver.hom.unop_inj hf),
end

instance coreflexive_of_unop_reflexive {a b : Cᵒᵖ} (h k : a ⟶ b) [is_reflexive_pair h k] :
  is_coreflexive_pair k.unop h.unop :=
{ common_retraction := ⟨(common_section h k).unop,
    by { rw [←unop_id, ←unop_comp, ←unop_comp, section_comp_left,
             section_comp_right, and_self] }⟩ }

lemma preserves_reflexive_coeq_aux {a b : Cᵒᵖ} {h k : a ⟶ b} [is_reflexive_pair h k]
  (coeq : cofork h k) (is_colim : is_colimit coeq) :
  is_colimit (cofork.of_π ((P C).map coeq.π) (by { rw [←category_theory.functor.map_comp,
    coeq.condition, category_theory.functor.map_comp] }) : cofork ((P C).map h) ((P C).map k)) :=
begin
  let d := common_section h k,
  let g := fork_of_op_cofork coeq,
  have g_lim := is_limit_fork_of_is_limit_op_cofork is_colim,
  haveI : mono h.unop :=
  { right_cancellation :=
    begin
      intros c u v heq,
      have sec := section_comp_left h k,
      rw [←comp_id u, ←unop_id, ←sec, unop_comp, ←assoc, heq,
          assoc, ←unop_comp, sec, unop_id, comp_id],
    end },
  haveI : mono k.unop :=
  { right_cancellation :=
    begin
      intros c u v heq,
      have sec := section_comp_right h k,
      rw [←comp_id u, ←unop_id, ←sec, unop_comp, ←assoc, heq,
          assoc, ←unop_comp, sec, unop_id, comp_id],
    end },
  haveI : mono g.ι :=
  { right_cancellation :=
    begin
      intros c u v heq,
      apply fork.is_limit.hom_ext g_lim heq
    end },
  haveI : is_coreflexive_pair k.unop h.unop := by apply_instance,
  have square := direct_image.curried_beck_chevalley
    (is_pullback_of_equalizer_coreflexive_pair g_lim),
  simp only [pullback_cone.mk_fst, quiver.hom.op_unop, pullback_cone.mk_snd] at square,
  have g_id := direct_image.id_beck_chevalley g.ι,
  have h_id := direct_image.id_beck_chevalley h.unop,
  apply cofork.is_colimit.mk; intro s,
  swap 3,
  { exact direct_image.curried g.ι ≫ s.π },
  { erw [←assoc, ←square, assoc, ←s.condition, ←assoc, h_id, id_comp] },
  { intros m hm, simp at hm,
    rw [←hm, ←assoc],
    erw [g_id, id_comp] }
end

variables {a b} {h k} [is_reflexive_pair h k]

def colimit_desc {coeq : cocone (parallel_pair h k)} (is_colim : is_colimit coeq)
  (s : cocone (parallel_pair h k ⋙ P C)) :=
(cofork.is_colimit.exists_unique (preserves_reflexive_coeq_aux coeq is_colim) (cofork.of_cocone s).π
  (cofork.of_cocone s).condition)

variables (h k)

-- Is there a better way than to manually construct the whole colimit
-- and more directly use the coequalizer in the previous lemma
instance preserves_reflexive_coeq ⦃a b: Cᵒᵖ⦄ (h k : a ⟶ b) [is_reflexive_pair h k]  :
  preserves_colimit (parallel_pair h k) (P C) :=
{ preserves :=
  begin
    intros coeq is_colim,
    apply is_colimit.of_exists_unique, intro s,
    rcases colimit_desc is_colim s with ⟨w, ⟨hwl, hwr⟩⟩,
    simp only at hwr,
    use w,
    split,
    { simp only, rintro j, cases j; rw [←id_comp (s.ι.app _), ←eq_to_hom_refl _ (eq.refl _)],
      { erw ←cofork.of_cocone_ι s walking_parallel_pair.zero,
        rw ←(cofork.of_cocone s).w walking_parallel_pair_hom.left,
        change (cofork.of_cocone s).ι.app walking_parallel_pair.one with (cofork.of_cocone s).π,
        rw [←hwl,  ←assoc, ←((P C).map_cocone coeq).w walking_parallel_pair_hom.left],
        refl },
      { erw ←cofork.of_cocone_ι s walking_parallel_pair.one,
        change (cofork.of_cocone s).ι.app walking_parallel_pair.one with (cofork.of_cocone s).π,
        rw ←hwl, refl }
    },
    intros l hl,
    apply hwr,
    erw hl walking_parallel_pair.one,
    change (cofork.of_cocone s).π with (cofork.of_cocone s).ι.app walking_parallel_pair.one,
    rw [cofork.of_cocone_ι s walking_parallel_pair.one, eq_to_hom_refl, id_comp],
  end }

end preserves

variable C

instance monadic_P : monadic_right_adjoint (P C) :=
@monad.monadic_of_has_preserves_reflexive_coequalizers_of_reflects_isomorphisms
  _ _ _ _ (P C) _ _ _ preserves.preserves_reflexive_coeq

namespace finite_colimits

variable C

def P_monad : monad C := (P_op_P_hom_equiv C).to_monad

def eilenberg_moore_has_finite_limits : has_finite_limits ((P_monad C).algebra) :=
{ out := λ J inst1 inst2,
  begin
  resetI,
  haveI : has_limits_of_shape J C := by apply_instance,
  haveI : has_limits_of_shape J (P_monad C).algebra :=
    has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape (P_monad C).forget,
  exactI has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape (P_monad C).forget,
  end }

instance : is_equivalence (monad.comparison (P_op_P_hom_equiv C)) := (monadic_P C).eqv

lemma C_op_equiv_eilenberg_moore : Cᵒᵖ ≌ (P_monad C).algebra :=
category_theory.functor.as_equivalence (monad.comparison (P_op_P_hom_equiv C))

instance has_finite_limits_C_op : has_finite_limits Cᵒᵖ :=
{ out := λ J inst1 inst2,
  begin
    resetI,
    haveI : has_limits_of_shape J (P_op_P_hom_equiv C).to_monad.algebra :=
      (eilenberg_moore_has_finite_limits C).out J,
    exact adjunction.has_limits_of_shape_of_equivalence (monad.comparison (P_op_P_hom_equiv C))
  end }

instance has_finite_colimits_C_opop : has_finite_colimits Cᵒᵖᵒᵖ :=
{ out := λ J _ _, by exactI has_colimits_of_shape_op_of_has_limits_of_shape }

lemma has_finite_colimits_C : has_finite_colimits C :=
{ out := λ J _ _, by exactI adjunction.has_colimits_of_shape_of_equivalence
  (op_op_equivalence C).inverse}

end finite_colimits

instance has_finite_colimits (C : Type u) [category.{v} C] [topos C] : has_finite_colimits C :=
finite_colimits.has_finite_colimits_C C


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import category_theory.eq_to_hom

/-!
# Cartesian products of categories

We define the category instance on `C × D` when `C` and `D` are categories.

We define:
* `sectl C Z` : the functor `C ⥤ C × D` given by `X ↦ ⟨X, Z⟩`
* `sectr Z D` : the functor `D ⥤ C × D` given by `Y ↦ ⟨Z, Y⟩`
* `fst`       : the functor `⟨X, Y⟩ ↦ X`
* `snd`       : the functor `⟨X, Y⟩ ↦ Y`
* `swap`      : the functor `C × D ⥤ D × C` given by `⟨X, Y⟩ ↦ ⟨Y, X⟩`
    (and the fact this is an equivalence)

We further define `evaluation : C ⥤ (C ⥤ D) ⥤ D` and `evaluation_uncurried : C × (C ⥤ D) ⥤ D`,
and products of functors and natural transformations, written `F.prod G` and `α.prod β`.
-/

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

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

/--
`prod C D` gives the cartesian product of two categories.

See <https://stacks.math.columbia.edu/tag/001K>.
-/
@[simps {not_recursive := []}] -- the generates simp lemmas like `id_fst` and `comp_snd`
instance prod : category.{max v₁ v₂} (C × D) :=
{ hom     := λ X Y, ((X.1) ⟶ (Y.1)) × ((X.2) ⟶ (Y.2)),
  id      := λ X, ⟨ 𝟙 (X.1), 𝟙 (X.2) ⟩,
  comp    := λ _ _ _ f g, (f.1 ≫ g.1, f.2 ≫ g.2) }

/-- Two rfl lemmas that cannot be generated by `@[simps]`. -/
@[simp] lemma prod_id (X : C) (Y : D) : 𝟙 (X, Y) = (𝟙 X, 𝟙 Y) := rfl
@[simp] lemma prod_comp {P Q R : C} {S T U : D} (f : (P, S) ⟶ (Q, T)) (g : (Q, T) ⟶ (R, U)) :
  f ≫ g = (f.1 ≫ g.1, f.2 ≫ g.2) := rfl

lemma is_iso_prod_iff {P Q : C} {S T : D} {f : (P, S) ⟶ (Q, T)} :
  is_iso f ↔ is_iso f.1 ∧ is_iso f.2 :=
begin
  split,
  { rintros ⟨g, hfg, hgf⟩,
    simp at hfg hgf,
    rcases hfg with ⟨hfg₁, hfg₂⟩,
    rcases hgf with ⟨hgf₁, hgf₂⟩,
    exact ⟨⟨⟨g.1, hfg₁, hgf₁⟩⟩, ⟨⟨g.2, hfg₂, hgf₂⟩⟩⟩ },
  { rintros ⟨⟨g₁, hfg₁, hgf₁⟩, ⟨g₂, hfg₂, hgf₂⟩⟩,
    dsimp at hfg₁ hgf₁ hfg₂ hgf₂,
    refine ⟨⟨(g₁, g₂), _, _⟩⟩; { simp; split; assumption } }
end

section
variables {C D}

/-- Construct an isomorphism in `C × D` out of two isomorphisms in `C` and `D`. -/
@[simps]
def iso.prod {P Q : C} {S T : D} (f : P ≅ Q) (g : S ≅ T) : (P, S) ≅ (Q, T) :=
{ hom := (f.hom, g.hom),
  inv := (f.inv, g.inv), }

end

end

section
variables (C : Type u₁) [category.{v₁} C] (D : Type u₁) [category.{v₁} D]
/--
`prod.category.uniform C D` is an additional instance specialised so both factors have the same
universe levels. This helps typeclass resolution.
-/
instance uniform_prod : category (C × D) := category_theory.prod C D
end

-- Next we define the natural functors into and out of product categories. For now this doesn't
-- address the universal properties.
namespace prod

/-- `sectl C Z` is the functor `C ⥤ C × D` given by `X ↦ (X, Z)`. -/
@[simps] def sectl
  (C : Type u₁) [category.{v₁} C] {D : Type u₂} [category.{v₂} D] (Z : D) : C ⥤ C × D :=
{ obj := λ X, (X, Z),
  map := λ X Y f, (f, 𝟙 Z) }

/-- `sectr Z D` is the functor `D ⥤ C × D` given by `Y ↦ (Z, Y)` . -/
@[simps] def sectr
  {C : Type u₁} [category.{v₁} C] (Z : C) (D : Type u₂) [category.{v₂} D] : D ⥤ C × D :=
{ obj := λ X, (Z, X),
  map := λ X Y f, (𝟙 Z, f) }

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

/-- `fst` is the functor `(X, Y) ↦ X`. -/
@[simps] def fst : C × D ⥤ C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.1 }

/-- `snd` is the functor `(X, Y) ↦ Y`. -/
@[simps] def snd : C × D ⥤ D :=
{ obj := λ X, X.2,
  map := λ X Y f, f.2 }

/-- The functor swapping the factors of a cartesian product of categories, `C × D ⥤ D × C`. -/
@[simps] def swap : C × D ⥤ D × C :=
{ obj := λ X, (X.2, X.1),
  map := λ _ _ f, (f.2, f.1) }

/--
Swapping the factors of a cartesion product of categories twice is naturally isomorphic
to the identity functor.
-/
@[simps] def symmetry : swap C D ⋙ swap D C ≅ 𝟭 (C × D) :=
{ hom := { app := λ X, 𝟙 X },
  inv := { app := λ X, 𝟙 X } }

/--
The equivalence, given by swapping factors, between `C × D` and `D × C`.
-/
@[simps]
def braiding : C × D ≌ D × C :=
equivalence.mk (swap C D) (swap D C)
  (nat_iso.of_components (λ X, eq_to_iso (by simp)) (by tidy))
  (nat_iso.of_components (λ X, eq_to_iso (by simp)) (by tidy))

instance swap_is_equivalence : is_equivalence (swap C D) :=
(by apply_instance : is_equivalence (braiding C D).functor)

end prod

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

/--
The "evaluation at `X`" functor, such that
`(evaluation.obj X).obj F = F.obj X`,
which is functorial in both `X` and `F`.
-/
@[simps] def evaluation : C ⥤ (C ⥤ D) ⥤ D :=
{ obj := λ X,
  { obj := λ F, F.obj X,
    map := λ F G α, α.app X, },
  map := λ X Y f,
  { app := λ F, F.map f,
    naturality' := λ F G α, eq.symm (α.naturality f) } }

/--
The "evaluation of `F` at `X`" functor,
as a functor `C × (C ⥤ D) ⥤ D`.
-/
@[simps] def evaluation_uncurried : C × (C ⥤ D) ⥤ D :=
{ obj := λ p, p.2.obj p.1,
  map := λ x y f, (x.2.map f.1) ≫ (f.2.app y.1),
  map_comp' := λ X Y Z f g,
  begin
    cases g, cases f, cases Z, cases Y, cases X,
    simp only [prod_comp, nat_trans.comp_app, functor.map_comp, category.assoc],
    rw [←nat_trans.comp_app, nat_trans.naturality, nat_trans.comp_app,
        category.assoc, nat_trans.naturality],
  end }

end

variables {A : Type u₁} [category.{v₁} A]
          {B : Type u₂} [category.{v₂} B]
          {C : Type u₃} [category.{v₃} C]
          {D : Type u₄} [category.{v₄} D]

namespace functor
/-- The cartesian product of two functors. -/
@[simps] def prod (F : A ⥤ B) (G : C ⥤ D) : A × C ⥤ B × D :=
{ obj := λ X, (F.obj X.1, G.obj X.2),
  map := λ _ _ f, (F.map f.1, G.map f.2) }

/- Because of limitations in Lean 3's handling of notations, we do not setup a notation `F × G`.
   You can use `F.prod G` as a "poor man's infix", or just write `functor.prod F G`. -/

/-- Similar to `prod`, but both functors start from the same category `A` -/
@[simps] def prod' (F : A ⥤ B) (G : A ⥤ C) : A ⥤ (B × C) :=
{ obj := λ a, (F.obj a, G.obj a),
  map := λ x y f, (F.map f, G.map f), }

section
variable (C)

/-- The diagonal functor. -/
def diag : C ⥤ C × C := (𝟭 C).prod' (𝟭 C)

@[simp] lemma diag_obj (X : C) : (diag C).obj X = (X, X) := rfl

@[simp] lemma diag_map {X Y : C} (f : X ⟶ Y) : (diag C).map f = (f, f) := rfl

end

end functor

namespace nat_trans

/-- The cartesian product of two natural transformations. -/
@[simps] def prod {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) :
  F.prod H ⟶ G.prod I :=
{ app         := λ X, (α.app X.1, β.app X.2),
  naturality' := λ X Y f,
  begin
    cases X, cases Y,
    simp only [functor.prod_map, prod.mk.inj_iff, prod_comp],
    split; rw naturality
  end }

/- Again, it is inadvisable in Lean 3 to setup a notation `α × β`;
   use instead `α.prod β` or `nat_trans.prod α β`. -/

end nat_trans

/-- `F.flip` composed with evaluation is the same as evaluating `F`. -/
@[simps]
def flip_comp_evaluation (F : A ⥤ B ⥤ C) (a) :
  F.flip ⋙ (evaluation _ _).obj a ≅ F.obj a :=
nat_iso.of_components (λ b, eq_to_iso rfl) $ by tidy

end category_theory


import for_mathlib.split_exact
import category_theory.limits.preserves.shapes.biproducts
import category_theory.limits.constructions.finite_products_of_binary_products

noncomputable theory

universes v u₁ u₂
open_locale tensor_product

open category_theory category_theory.limits opposite

section
variables {𝓐 : Type u₁} {𝓑 : Type u₂} [category.{v} 𝓐] [category.{v} 𝓑] (F : 𝓐 ⥤ 𝓑)
variables [abelian 𝓐] [abelian 𝓑]

def preserves_limits_of_shape_pempty_of_preserves_terminal
  [preserves_limit (functor.empty.{0} 𝓐) F] : preserves_limits_of_shape (discrete pempty) F :=
{ preserves_limit := λ K,
    preserves_limit_of_iso_diagram.{0 0} F (functor.empty_ext (functor.empty 𝓐) _) }

def preserves_terminal_object_of_preserves_zero_morphisms
  [functor.preserves_zero_morphisms F] : preserves_limit (functor.empty.{0} 𝓐) F :=
preserves_terminal_of_iso F $
  (F.map_iso has_zero_object.zero_iso_terminal.symm).trans $
  (functor.map_zero_object F).trans $
  has_zero_object.zero_iso_terminal

def iso_of_ι {X Y : 𝓐} (f g : X ⟶ Y) (c : cone (parallel_pair f g)) :
  c ≅ fork.of_ι (fork.ι c) (fork.condition c) :=
fork.ext (iso.refl _) (by tidy)

def preserves_equalizer_of_preserves_kernels [F.additive]
  [∀ {X Y} (f : X ⟶ Y), preserves_limit (parallel_pair f 0) F] {X Y : 𝓐}
  (f g : X ⟶ Y) : preserves_limit (parallel_pair f g) F :=
begin
  constructor, intros c i,
  let c' := preadditive.is_limit_kernel_fork_of_fork (i.of_iso_limit (iso_of_ι _ _ c)),
  let iFc := is_limit_fork_map_of_is_limit' F (by simp) c',
  apply is_limit.of_iso_limit _ ((cones.functoriality _ F).map_iso (iso_of_ι _ _ c).symm),
  apply (is_limit_map_cone_fork_equiv F (fork.condition c)).inv_fun,
  let p : parallel_pair (F.map (f - g)) 0 ≅ parallel_pair (F.map f - F.map g) 0,
  { exact parallel_pair.ext (iso.refl _) (iso.refl _) (by simp) (by simp) },
  refine is_limit.of_iso_limit (preadditive.is_limit_fork_of_kernel_fork
    ((is_limit.postcompose_hom_equiv p _).symm iFc)) _,
  refine fork.ext (iso.refl _) _,
  dsimp only [p, preadditive.fork_of_kernel_fork, cones.postcompose, ← fork.app_zero_eq_ι],
  simp [- fork.app_zero_eq_ι]
end

def preserves_equalizers_of_preserves_kernels [F.additive]
  [∀ {X Y} (f : X ⟶ Y), preserves_limit (parallel_pair f 0) F] :
  preserves_limits_of_shape walking_parallel_pair F :=
{ preserves_limit := λ K,
  begin
    letI := preserves_equalizer_of_preserves_kernels F
      (K.map walking_parallel_pair_hom.left) (K.map walking_parallel_pair_hom.right),
    apply preserves_limit_of_iso_diagram F (diagram_iso_parallel_pair K).symm
  end }

-- todo: unify with `exact_comp_mono_iff`
lemma exact_comp_mono_iff' {X Y Z A : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) (h : Z ⟶ A) [mono h]:
  exact f (g ≫ h) ↔ exact f g :=
begin
  refine ⟨λ hfg, ⟨zero_of_comp_mono h (by rw [category.assoc, hfg.1]), _⟩, λ h, exact_comp_mono h⟩,
  rw ← (iso.eq_comp_inv _).1 (image_to_kernel_comp_mono _ _ h hfg.1),
  haveI := hfg.2, apply epi_comp
end

end

set_option pp.universes true
lemma preserves_finite_limits_of_preserves_mono_preserves_finite_colimits
  {𝓐 : Type u₁} {𝓑 : Type u₂} [category.{v} 𝓐] [category.{v} 𝓑] [abelian 𝓐] [abelian 𝓑]
  (F : 𝓐 ⥤ 𝓑) (h1 : ∀ ⦃X Y : 𝓐⦄ (f : X ⟶ Y), mono f → mono (F.map f))
  [preserves_finite_colimits F] :
  preserves_finite_limits F :=
begin
  haveI : preserves_binary_biproducts F,
  { apply preserves_binary_biproducts_of_preserves_binary_coproducts },
  haveI : preserves_limits_of_shape (discrete walking_pair) F,
  { apply preserves_binary_products_of_preserves_binary_biproducts },
  haveI : F.additive,
  { apply functor.additive_of_preserves_binary_biproducts },
  haveI : ∀ {X Y} (f : X ⟶ Y), preserves_limit (parallel_pair f 0) F,
  { intros X Y f,
    constructor,
    intros c hc,
    suffices hF : exact (F.map (fork.ι c)) (F.map f),
    { haveI : mono (F.map (fork.ι c)),
      { apply h1,
        exact limits.mono_of_is_limit_fork hc },
      let := abelian.is_limit_of_exact_of_mono _ _ hF,
      let α : parallel_pair f 0 ⋙ F ≅ parallel_pair (F.map f) 0,
      { refine diagram_iso_parallel_pair _ ≪≫ _,
        refine parallel_pair.ext (iso.refl _) (iso.refl _) (by simp) (by simp) },
      refine is_limit.postcompose_hom_equiv α _ _,
      refine this.of_iso_limit (cones.ext (iso.refl _) _),
      rintro (_|_),
      { simp, dsimp, simp },
      { simp } },
    let hc' := hc.of_iso_limit (iso_of_ι _ _ _),
    have := abelian.exact_of_is_kernel _ _ (kernel_fork.condition c) hc',
    simp_rw ← image.fac f at this,
    rw exact_comp_mono_iff' at this,
    let := abelian.is_colimit_of_exact_of_epi _ _ this,
    let q := is_colimit_cofork_map_of_is_colimit' F _ this,
    haveI : mono (F.map (image.ι f)),
    { apply h1, apply_instance },
    simp_rw ← image.fac f,
    rw [functor.map_comp, exact_comp_mono_iff'],
    exact abelian.exact_of_is_cokernel _ _ _ q },
  haveI : preserves_limits_of_shape walking_parallel_pair F,
  { apply preserves_equalizers_of_preserves_kernels },
  haveI : preserves_limit (functor.empty.{0} 𝓐) F,
  { apply preserves_terminal_object_of_preserves_zero_morphisms },
  haveI : preserves_limits_of_shape (discrete.{0} pempty) F,
  { apply limits.preserves_limits_of_shape_pempty_of_preserves_terminal, },
  haveI p := preserves_finite_products_of_preserves_binary_and_terminal F,
  exact @preserves_finite_limits_of_preserves_equalizers_and_finite_products
    _ _ _ _ _ _ _ _ p,
end