import category_theory.preadditive.additive_functor
import category_theory.limits.preserves.shapes.biproducts

import for_mathlib.derived.les2
import for_mathlib.derived.les_facts
import for_mathlib.derived.Ext_lemmas

import for_mathlib.is_quasi_iso
import for_mathlib.short_exact
import for_mathlib.homology
import for_mathlib.exact_lift_desc
import for_mathlib.additive_functor
import for_mathlib.homotopy_category_lemmas
import for_mathlib.homology_lift_desc

.

noncomputable theory

open category_theory category_theory.limits opposite
open homotopy_category (hiding single)
open bounded_homotopy_category

-- main proof in this file is inspired by https://math.stackexchange.com/a/2118042

section

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

def delta_to_kernel (C : homological_complex 𝓐 c) (i j k : ι) :
  C.X i ⟶ kernel (C.d j k) :=
factor_thru_image _ ≫ image_to_kernel' (C.d i j) _ (C.d_comp_d _ _ _)

def delta_to_kernel_ι (C : homological_complex 𝓐 c) (i j k : ι) :
  delta_to_kernel C i j k ≫ kernel.ι (C.d j k) = C.d i j :=
begin
  delta delta_to_kernel image_to_kernel',
  rw [category.assoc, kernel.lift_ι, image.fac],
end

def d_delta_to_kernel (C : homological_complex 𝓐 c) (h i j k : ι) :
  C.d h i ≫ delta_to_kernel C i j k = 0 :=
begin
  rw [← cancel_mono (kernel.ι (C.d j k)), category.assoc, delta_to_kernel_ι, C.d_comp_d, zero_comp],
end

-- move me
lemma short_exact_comp_iso {A B C D : 𝓐} (f : A ⟶ B) (g : B ⟶ C) (h : C ⟶ D) (hh : is_iso h) :
  short_exact f (g ≫ h) ↔ short_exact f g :=
begin
  split; intro H,
  { haveI : mono f := H.mono,
    haveI : epi g,
    { haveI := H.epi, have := epi_comp (g ≫ h) (inv h), simpa only [category.assoc, is_iso.hom_inv_id, category.comp_id] },
    refine ⟨_⟩, have := H.exact, rwa exact_comp_iso at this, },
  { haveI : mono f := H.mono,
    haveI : epi g := H.epi,
    haveI : epi (g ≫ h) := epi_comp g h,
    refine ⟨_⟩, have := H.exact, rwa exact_comp_iso }
end

lemma is_acyclic_def
  (C : homotopy_category 𝓐 c) :
  is_acyclic C ↔ (∀ i, is_zero (C.as.homology i)) :=
begin
  split,
  { apply is_acyclic.cond },
  { apply is_acyclic.mk }
end

lemma is_acyclic_iff_short_exact_to_cycles
  (C : homotopy_category 𝓐 (complex_shape.up ℤ)) :
  is_acyclic C ↔
  (∀ i, short_exact (kernel.ι (C.as.d i (i+1))) (delta_to_kernel C.as i (i+1) (i+1+1))) :=
begin
  rw is_acyclic_def,
  symmetry,
  apply (equiv.add_right (1 : ℤ)).forall_congr,
  intro i,
  let e := (homology_iso C.as i (i+1) (i+1+1) rfl rfl),
  dsimp [delta_to_kernel] at e ⊢,
  rw [e.is_zero_iff, homology_is_zero_iff_image_to_kernel'_is_iso],
  split,
  { apply iso_of_short_exact_comp_right _ _ _, apply short_exact_kernel_factor_thru_image },
  { intro h, rw short_exact_comp_iso _ _ _ h, apply short_exact_kernel_factor_thru_image }
end

lemma is_acyclic_iff_short_exact_to_cycles'
  (C : homological_complex 𝓐 (complex_shape.down ℤ)) :
  (∀ i, is_zero (C.homology i)) ↔
  (∀ i, short_exact (kernel.ι (C.d (i+1+1) (i+1))) (delta_to_kernel C (i+1+1) (i+1) i)) :=
begin
  symmetry,
  apply (equiv.add_right (1 : ℤ)).forall_congr,
  intro i,
  let e := (homology_iso C (i+1+1) (i+1) i rfl rfl),
  dsimp [delta_to_kernel] at e ⊢,
  rw [e.is_zero_iff, homology_is_zero_iff_image_to_kernel'_is_iso],
  split,
  { apply iso_of_short_exact_comp_right _ _ _, apply short_exact_kernel_factor_thru_image },
  { intro h, rw short_exact_comp_iso _ _ _ h, apply short_exact_kernel_factor_thru_image }
end

end

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

variables (C : cochain_complex 𝓐 ℤ)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj C)]

def category_theory.functor.single (F : bounded_homotopy_category 𝓐 ⥤ 𝓑) (i : ℤ) : 𝓐 ⥤ 𝓑 :=
bounded_homotopy_category.single _ i ⋙ F

-- move me
lemma category_theory.limits.is_zero.biprod {𝓐 : Type*} [category 𝓐] [abelian 𝓐]
  {X Y : 𝓐} (hX : is_zero X) (hY : is_zero Y) :
  is_zero (X ⊞ Y) :=
begin
  rw is_zero_iff_id_eq_zero at hX hY ⊢,
  ext; simp [hX, hY],
end

instance category_theory.limits.preserves_binary_biproduct_of_additive
  {𝓐 𝓑 : Type*} [category 𝓐] [category 𝓑] [abelian 𝓐] [abelian 𝓑]
  (F : 𝓐 ⥤ 𝓑) [functor.additive F] (X Y : 𝓐) :
  preserves_binary_biproduct X Y F :=
preserves_binary_biproduct_of_preserves_biproduct _ _ _

-- move me
@[simp] lemma category_theory.op_neg {𝓐 : Type*} [category 𝓐] [preadditive 𝓐]
  {X Y : 𝓐} (f : X ⟶ Y) : (-f).op = - f.op := rfl

lemma acyclic_left_of_short_exact (B : 𝓐) {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) (hfg : short_exact f g)
  (hY : ∀ i > 0, is_zero (((Ext' i).obj (op $ Y)).obj B))
  (hZ : ∀ i > 0, is_zero (((Ext' i).obj (op $ Z)).obj B)) :
  ∀ i > 0, is_zero (((Ext' i).obj (op $ X)).obj B) :=
begin
  intros i hi,
  have := hfg.Ext'_five_term_exact_seq B i,
  refine (this.drop 1).pair.is_zero_of_is_zero_is_zero (hY _ hi) (hZ _ _),
  transitivity i, { exact lt_add_one i }, { exact hi }
end
.

lemma map_is_acyclic_of_acyclic_aux
  {A B C D X Y Z W : 𝓐} (f : A ⟶ B) (g : C ⟶ D) (π : B ⟶ kernel g)
  {α : X ⟶ B} {β : B ⟶ Y} {γ : Y ⟶ C} {δ : C ⟶ Z} {ε : Z ⟶ D} {ζ : D ⟶ W}
  (hαβ : short_exact α β) (hγδ : short_exact γ δ) (hεζ : short_exact ε ζ)
  (hf : mono f) (hfπ : exact f π)
  (hαπ : α ≫ π = 0) (hγg : γ ≫ g = 0) (hδε : δ ≫ ε = g)
  (hπι : π ≫ kernel.ι g = β ≫ γ) :
  short_exact f π :=
begin
  suffices : epi π, { resetI, exact ⟨hfπ⟩ },
  have hβ : epi β := hαβ.epi,
  have hγ : mono γ := hγδ.mono,
  have hε : mono ε := hεζ.mono,
  resetI,
  have hιδ : kernel.ι g ≫ δ = 0,
  { rw [← cancel_mono ε, category.assoc, hδε, kernel.condition, zero_comp], },
  let e1 : Y ⟶ kernel g := hαβ.exact.epi_desc π hαπ,
  let e2 : Y ⟶ kernel g := kernel.lift g γ hγg,
  let e3 : kernel g ⟶ Y := hγδ.exact.mono_lift (kernel.ι g) hιδ,
  have he12 : e1 = e2,
  { rw [← cancel_epi β, ← cancel_mono (kernel.ι g)],
    simp only [hπι, category.assoc, kernel.lift_ι, exact.comp_epi_desc_assoc], },
  have he13 : e1 ≫ e3 = 𝟙 _,
  { rw [he12, ← cancel_mono γ, category.assoc, exact.mono_lift_comp, kernel.lift_ι, category.id_comp], },
  have he31 : e3 ≫ e1 = 𝟙 _,
  { rw [he12, ← cancel_mono (kernel.ι g), category.assoc, kernel.lift_ι, exact.mono_lift_comp, category.id_comp], },
  let e : Y ≅ kernel g := ⟨e1, e3, he13, he31⟩,
  have hπ : β ≫ e.hom = π := exact.comp_epi_desc _ _ _,
  rw ← hπ, exact epi_comp _ _,
end

lemma short_exact_Ext_of_short_exact_of_acyclic {A B C : 𝓐} (Z : 𝓐) {f : A ⟶ B} {g : B ⟶ C}
  (hfg : short_exact f g) (hC : ∀ i > 0, is_zero (((Ext' i).obj (op $ C)).obj Z)) :
  short_exact (((Ext' 0).flip.obj Z).map g.op) (((Ext' 0).flip.obj Z).map f.op) :=
begin
  have H0 := hfg.Ext'_five_term_exact_seq Z 0,
  apply_with short_exact.mk {instances:=ff},
  { have H := ((hfg.Ext'_five_term_exact_seq Z (-1)).drop 2).pair,
    apply H.mono_of_is_zero,
    apply Ext'_is_zero_of_neg, dec_trivial },
  { apply (H0.drop 1).pair.epi_of_is_zero,
    apply hC, dec_trivial },
  { exact H0.pair }
end

lemma map_is_acyclic_of_acyclic''
  [is_acyclic ((homotopy_category.quotient _ _).obj C)]
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B)) :
  ∀ i, is_zero (((((Ext' 0).flip.obj B).map_homological_complex _).obj C.op).homology i) :=
begin
  rw is_acyclic_iff_short_exact_to_cycles',
  obtain ⟨a, ha⟩ := is_bounded_above.cond ((quotient 𝓐 (complex_shape.up ℤ)).obj C),
  have aux : ((quotient 𝓐 (complex_shape.up ℤ)).obj C).is_acyclic := ‹_›,
  rw is_acyclic_iff_short_exact_to_cycles at aux,
  intro i,
  let K := λ j, kernel (C.d j (j+1)),
  suffices hK : ∀ j, ∀ i > 0, is_zero (((Ext' i).obj (op $ K j)).obj B),
  { have SES1 := short_exact_Ext_of_short_exact_of_acyclic B (aux (i+1+1)) (hK _),
    have SES2 := short_exact_Ext_of_short_exact_of_acyclic B (aux (i+1)) (hK _),
    have SES3 := short_exact_Ext_of_short_exact_of_acyclic B (aux i) (hK _),
    apply map_is_acyclic_of_acyclic_aux _ _ _ SES1 SES2 SES3 infer_instance;
      clear SES1 SES2 SES3 aux,
    { delta delta_to_kernel image_to_kernel',
      apply exact_comp_mono, rw exact_factor_thru_image_iff, exact exact_kernel_ι },
    { rw [← cancel_mono (kernel.ι _), zero_comp, category.assoc, delta_to_kernel_ι],
      swap, apply_instance,
      erw [functor.map_homological_complex_obj_d, ← functor.map_comp],
      dsimp only [homological_complex.op_d, quotient_obj_as],
      rw [← op_comp, d_delta_to_kernel, op_zero, functor.map_zero], },
    { erw [functor.map_homological_complex_obj_d, ← functor.map_comp],
      dsimp only [homological_complex.op_d, quotient_obj_as],
      rw [← op_comp, d_delta_to_kernel, op_zero, functor.map_zero], },
    { rw [← functor.map_comp, ← op_comp, delta_to_kernel_ι], refl, },
    { rw [delta_to_kernel_ι, ← functor.map_comp, ← op_comp, delta_to_kernel_ι], refl, },
    { apply_instance } },
  clear i, intro j,
  have : ∀ j ≥ a, ∀ i > 0, is_zero (((Ext' i).obj (op $ K j)).obj B),
  { intros j hj i hi,
    apply bounded_derived_category.Ext'_zero_left_is_zero,
    apply is_zero.op,
    refine is_zero.of_mono (kernel.ι _) _,
    exact ha j hj },
  apply int.induction_on' j a,
  { exact this _ le_rfl, },
  { intros j hj aux, apply this, exact int.le_add_one hj, },
  { intros j hj IH,
    obtain ⟨j, rfl⟩ : ∃ i, i + 1 = j := ⟨j - 1, sub_add_cancel _ _⟩,
    rw add_sub_cancel,
    apply acyclic_left_of_short_exact B (kernel.ι _) (delta_to_kernel _ _ _ _) _ (hC _) IH,
    exact aux j, }
end

lemma map_is_acyclic_of_acyclic'
  [is_acyclic ((homotopy_category.quotient _ _).obj C)]
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B)) :
  is_acyclic ((((Ext' 0).flip.obj B).right_op.map_homotopy_category _).obj ((homotopy_category.quotient _ _).obj C)) :=
begin
  rw is_acyclic_def,
  intro i,
  have h1 : (complex_shape.up ℤ).rel (i - 1) i, { dsimp, apply sub_add_cancel },
  refine is_zero.of_iso _ (homology_iso' _ (i-1) i (i+1) h1 rfl),
  dsimp only [functor.map_homotopy_category_obj, quotient_obj_as,
    functor.right_op_map, functor.map_homological_complex_obj_d],
  apply exact.homology_is_zero,
  apply exact.op,
  refine exact_of_homology_is_zero _,
  { rw [← category_theory.functor.map_comp, ← op_comp, homological_complex.d_comp_d, op_zero, functor.map_zero], },
  have := map_is_acyclic_of_acyclic'' C B hC i,
  apply this.of_iso _, clear this,
  let C' := (((Ext' 0).flip.obj B).map_homological_complex (complex_shape.up ℤ).symm).obj (homological_complex.op C),
  have h1 : (complex_shape.down ℤ).rel i (i - 1), { dsimp, apply sub_add_cancel },
  exact (homology_iso' C' (i+1) i (i-1) rfl h1).symm,
end

lemma map_is_acyclic_of_acyclic
  [is_acyclic ((homotopy_category.quotient _ _).obj C)]
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B)) :
  is_acyclic (((preadditive_yoneda.obj B).right_op.map_homotopy_category _).obj ((homotopy_category.quotient _ _).obj C)) :=
begin
  have := map_is_acyclic_of_acyclic' C B hC,
  rw is_acyclic_def at this ⊢,
  intro i, specialize this i,
  apply this.of_iso _, clear this,
  have h1 : (complex_shape.up ℤ).rel (i - 1) i, { dsimp, apply sub_add_cancel },
  refine (homology_iso' _ (i-1) i (i+1) h1 rfl) ≪≫ _ ≪≫ (homology_iso' _ (i-1) i (i+1) h1 rfl).symm,
  dsimp only [functor.map_homotopy_category_obj, quotient_obj_as,
    functor.right_op_map, functor.map_homological_complex_obj_d],
  let e := λ i, ((bounded_derived_category.Ext'_zero_flip_iso _ B).app (op $ C.X i)).op,
  refine homology.map_iso _ _ (arrow.iso_mk (e _) (e _) _) (arrow.iso_mk (e _) (e _) _) rfl,
  { simp only [iso.op_hom, iso.app_hom, arrow.mk_hom, functor.flip_obj_map, ← op_comp, ← nat_trans.naturality], },
  { simp only [iso.op_hom, iso.app_hom, arrow.mk_hom, functor.flip_obj_map, ← op_comp, ← nat_trans.naturality], },
end

lemma acyclic_of_projective (P B : 𝓐) [projective P] (i : ℤ) (hi : 0 < i) :
  is_zero (((Ext' i).obj (op P)).obj B) :=
begin
  rw (Ext'_iso (op P) B i _ (𝟙 _) _).is_zero_iff,
  { rcases i with ((_|i)|i),
    { exfalso, revert hi, dec_trivial },
    swap, { exfalso, revert hi, dec_trivial },
    refine is_zero.homology_is_zero _ _ _ _,
    apply AddCommGroup.is_zero_of_eq,
    intros,
    apply is_zero.eq_of_src,
    apply is_zero_zero, },
  { refine ⟨_, _, _⟩,
    { rintro (_|n), { assumption }, { dsimp, apply_instance } },
    { exact exact_zero_mono (𝟙 P) },
    { rintro (_|n); exact exact_of_zero 0 0 } }
end

def Ext_compute_with_acyclic_aux₁
  (B : 𝓐)
  (i : ℤ) :
  ((Ext i).obj (op $ of' C)).obj ((single _ 0).obj B) ≅
  (preadditive_yoneda.obj ((single 𝓐 (-i)).obj B)).obj (op (of' C).replace) :=
(preadditive_yoneda.map_iso $ (shift_single_iso 0 i).app B ≪≫ eq_to_iso (by rw zero_sub)).app _

abbreviation of'_hom {C₁ C₂ : cochain_complex 𝓐 ℤ}
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (f : C₁ ⟶ C₂) :
  of' C₁ ⟶ of' C₂ :=
(homotopy_category.quotient _ _).map f

lemma Ext_compute_with_acyclic_aux₁_naturality
  (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (f : C₁ ⟶ C₂)
  (i : ℤ) :
  ((Ext i).map $ quiver.hom.op $ of'_hom f).app _ ≫
    (Ext_compute_with_acyclic_aux₁ C₁ B i).hom =
  (Ext_compute_with_acyclic_aux₁ C₂ B i).hom ≫
  (preadditive_yoneda.obj _).map (quiver.hom.op $
  bounded_homotopy_category.lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π) :=
begin
  ext F,
  dsimp [Ext, Ext_compute_with_acyclic_aux₁],
  simp only [comp_apply],
  dsimp, simp,
end

def Ext_compute_with_acyclic_aux₂
  (B : 𝓐)
  (i : ℤ) :
  (preadditive_yoneda.obj ((single 𝓐 (-i)).obj B)).obj (op (of' C).replace) ≅
  (((preadditive_yoneda.obj B).map_homological_complex (complex_shape.up ℤ).symm).obj
  ((of' C).replace).val.as.op).homology (-i) :=
  hom_single_iso _ _ _

-- TODO: We should prove naturality of `hom_single_iso` independently!
lemma Ext_compute_with_acyclic_aux₂_naturality
  (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (f : C₁ ⟶ C₂)
  (i : ℤ) :
  (preadditive_yoneda.obj _).map (quiver.hom.op $
    bounded_homotopy_category.lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π) ≫
    (Ext_compute_with_acyclic_aux₂ C₁ B i).hom =
  (Ext_compute_with_acyclic_aux₂ C₂ B i).hom ≫
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op ⋙
      (_root_.homology_functor _ _ (-i)).op).map
      (bounded_homotopy_category.lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π).out).unop :=
hom_single_iso_naturality _ _ _ _ _

def Ext_compute_with_acyclic_HomB
  (B : 𝓐) := (preadditive_yoneda.obj B).right_op.map_homological_complex (complex_shape.up ℤ) ⋙
  homological_complex.unop_functor.right_op

lemma Ext_compute_with_acyclic_is_quasi_iso_aux
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B))
  (i : ℤ) :
  is_quasi_iso ((homotopy_category.quotient _ _).map
    ((Ext_compute_with_acyclic_HomB B).map (of' C).π.out).unop) :=
begin
  let P := (of' C).replace,
  let π : P ⟶ of' C := (of' C).π,
  let HomB := (preadditive_yoneda.obj B).right_op.map_homological_complex (complex_shape.up ℤ) ⋙
    homological_complex.unop_functor.right_op,
  let fq := (homotopy_category.quotient _ _).map (HomB.map π.out).unop,
  apply is_quasi_iso_of_op,
  let f := homological_complex.op_functor.map (HomB.map (quot.out π)),
  have := cone_triangleₕ_mem_distinguished_triangles _ _ f,
  replace := is_quasi_iso_iff_is_acyclic _ this,
  dsimp [homological_complex.cone.triangleₕ] at this,
  erw this, clear this i,
  constructor,
  intro i, obtain ⟨i, rfl⟩ : ∃ j, j + 1 = i := ⟨i - 1, sub_add_cancel _ _⟩,
  refine is_zero.of_iso _ (homology_iso _ i (i+1) (i+1+1) _ _),
  rotate, { dsimp, refl }, { dsimp, refl },
  apply exact.homology_is_zero _,
  dsimp only [homotopy_category.quotient, quotient.functor_obj_as, homological_complex.cone_d],
  have hπ : is_quasi_iso π, { dsimp [π], apply_instance },
  have := cone_triangleₕ_mem_distinguished_triangles _ _ π.out,
  replace := is_quasi_iso_iff_is_acyclic _ this,
  dsimp [homological_complex.cone.triangleₕ] at this,
  simp only [quotient_map_out] at this,
  replace := this.mp _,
  swap, { convert hπ using 1, generalize : P.val = X, cases X, refl, },
  haveI preaux : ((quotient 𝓐 (complex_shape.up ℤ)).obj (homological_complex.cone (quot.out π))).is_bounded_above,
  { constructor,
    obtain ⟨a, ha⟩ := is_bounded_above.cond ((quotient 𝓐 (complex_shape.up ℤ)).obj C),
    obtain ⟨b, hb⟩ := is_bounded_above.cond P.val,
    refine ⟨max a b, _⟩,
    intros k hk,
    refine category_theory.limits.is_zero.biprod _ _,
    { apply hb, refine (le_max_right _ _).trans (hk.trans (lt_add_one _).le) },
    { apply ha, exact (le_max_left _ _).trans hk, } },
  have aux := @map_is_acyclic_of_acyclic _ _ _ _ _ _ this B _,
  { replace := (@is_acyclic.cond _ _ _ _ _ _ aux (i+1)).of_iso (homology_iso _ i (i+1) (i+1+1) _ _).symm,
    rotate, { dsimp, refl }, { dsimp, refl },
    dsimp only [homotopy_category.quotient, quotient.functor_obj_as, homological_complex.cone_d,
      functor.map_homotopy_category_obj, functor.map_homological_complex_obj_d] at this,
    replace := exact_of_homology_is_zero this,
    let e := functor.map_biprod (preadditive_yoneda.obj B).right_op,
    refine preadditive.exact_of_iso_of_exact' _ _ _ _ (e _ _) (e _ _) (e _ _) _ _ this;
    dsimp only [e, functor.map_biprod_hom],
    all_goals
    { ext,
      { simp only [category.assoc, functor.right_op_map, homological_complex.cone.d, biprod.lift_fst,
          eq_self_iff_true, functor.map_homological_complex_obj_d, functor.right_op_map,
          homological_complex.X_eq_to_iso_refl, category.comp_id, dite_eq_ite, if_true,
          biprod.lift_fst, biprod.lift_desc, preadditive.comp_neg, comp_zero, add_zero],
        simp only [functor.map_homological_complex_obj_d, functor.right_op_map, functor.comp_map,
          biprod.lift_desc, preadditive.comp_neg, comp_zero, add_zero,
          ← op_comp, ← category_theory.functor.map_comp, biprod.lift_fst],
        simp only [biprod.desc_eq, comp_zero, add_zero, preadditive.comp_neg,
          category_theory.op_neg, functor.map_neg, op_comp, category_theory.functor.map_comp],
        refl },
      { simp only [category.assoc, functor.right_op_map, homological_complex.cone.d, biprod.lift_snd,
          eq_self_iff_true, functor.map_homological_complex_obj_d, functor.right_op_map,
          functor.map_homological_complex_map_f, homological_complex.X_eq_to_iso_refl,
          category.comp_id, dite_eq_ite, if_true, biprod.lift_snd, biprod.lift_desc],
        simp only [functor.map_homological_complex_obj_d, functor.right_op_map, functor.comp_map,
          biprod.lift_desc, preadditive.comp_neg, comp_zero, add_zero,
          ← op_comp, ← category_theory.functor.map_comp, biprod.lift_snd],
        simp only [biprod.desc_eq, op_add, functor.map_neg, functor.map_add, op_comp,
          category_theory.functor.map_comp],
        refl } } },
  { clear i, intros k i hi,
    let e := functor.map_biprod ((Ext' i).flip.obj B).right_op
      (P.val.as.X (k + 1)) ((of' C).val.as.X k),
    refine is_zero.of_iso (is_zero.unop _) e.symm.unop,
    refine category_theory.limits.is_zero.biprod _ _,
    { simp only [functor.right_op_obj, functor.flip_obj_obj, is_zero_op],
      exact acyclic_of_projective (P.val.as.X (k + 1)) B i hi, },
    { exact (hC k _ hi).op, }, },
end

def Ext_compute_with_acyclic_aux₃
  (B : 𝓐)
  (i : ℤ) :
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _).obj C).unop.homology (-i) ⟶
  (((preadditive_yoneda.obj B).map_homological_complex (complex_shape.up ℤ).symm).obj
  ((of' C).replace).val.as.op).homology (-i) :=
by apply (homotopy_category.homology_functor Ab _ (-i)).map
  (((homotopy_category.quotient _ _).map
    ((Ext_compute_with_acyclic_HomB B).map (of' C).π.out).unop))

-- Are these two lemmas useful? Do we have them?
lemma functor.map_unop {𝓐 : Type*} [category 𝓐] {𝓑 : Type*}
  [category 𝓑] (F : 𝓐 ⥤ 𝓑) {a₁ a₂ : 𝓐ᵒᵖ}
  (f : a₁ ⟶ a₂) : F.map f.unop = (F.op.map f).unop :=
rfl

lemma functor.map_map' {𝓐 : Type*} [category 𝓐] {𝓑 : Type*}
  [category 𝓑] {𝓒 : Type*} [category 𝓒] (F : 𝓐 ⥤ 𝓑) (G : 𝓑 ⥤ 𝓒) {a₁ a₂ : 𝓐}
  (φ : a₁ ⟶ a₂) : G.map (F.map φ) = (F ⋙ G).map φ :=
rfl

namespace Ext_compute_with_acyclic_aux₃_naturality_helpers

variables (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (f : C₁ ⟶ C₂)
  (i : ℤ)

lemma helper₁ (h1 h2) :
  homology.lift ((unop
    (homological_complex.unop_functor.right_op.obj
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
      (complex_shape.up ℤ)).obj C₁))).d_to (-i))
  ((unop (homological_complex.unop_functor.right_op.obj
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
    (complex_shape.up ℤ)).obj C₁))).d_from (-i)) h1
  (kernel.ι ((unop (homological_complex.unop_functor.right_op.obj
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
    (complex_shape.up ℤ)).obj C₂))).d_from (-i)) ≫
    (homological_complex.unop_functor.right_op.map
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
    (complex_shape.up ℤ)).map f)).unop.f (-i) ≫ cokernel.π
    ((unop (homological_complex.unop_functor.right_op.obj
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
    (complex_shape.up ℤ)).obj C₁))).d_to (-i))) h2 =
  kernel.lift _ (kernel.ι _ ≫ (preadditive_yoneda.obj B).map (f.f (-i)).op) begin
    rw category.assoc,
    have aux := ((((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op).map f)).unop.comm_from (-i),
    dsimp at aux,
    erw [aux, kernel.condition_assoc, zero_comp],
  end ≫
  homology.π' _ _ _ :=
begin
  apply homology.hom_to_ext,
  rw [category.assoc, homology.π'_ι, kernel.lift_ι_assoc,
    homology.lift_ι],
  refl,
end

lemma helper₂ (h1 h2) :
  homology.lift ((unop ((Ext_compute_with_acyclic_HomB B).obj (of' C₂).replace.val.as)).d_to (-i))
  ((unop ((Ext_compute_with_acyclic_HomB B).obj (of' C₂).replace.val.as)).d_from (-i))
  h1
  (kernel.ι ((unop ((Ext_compute_with_acyclic_HomB B).obj (of' C₂).val.as)).d_from (-i)) ≫
     ((Ext_compute_with_acyclic_HomB B).map (quot.out (of' C₂).π)).unop.f (-i) ≫
       cokernel.π ((unop ((Ext_compute_with_acyclic_HomB B).obj (of' C₂).replace.val.as)).d_to (-i)))
  h2 =
  kernel.lift _ (kernel.ι _ ≫ begin
    apply homological_complex.hom.f,
    exact (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op).map (of' C₂).π.out).unop,
  end) begin
    rw category.assoc,
    have := (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op).map (of' C₂).π.out).unop.comm_from (-i),
    erw [this, kernel.condition_assoc, zero_comp],
  end ≫ homology.π' _ _ _ :=
begin
  apply homology.hom_to_ext,
  simp only [homology.lift_ι, category.assoc, homology.π'_ι, kernel.lift_ι_assoc],
  refl,
end

end Ext_compute_with_acyclic_aux₃_naturality_helpers

lemma Ext_compute_with_acyclic_aux₃_naturality
  (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (f : C₁ ⟶ C₂)
  (i : ℤ) :
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
    homological_complex.unop_functor.right_op ⋙ (_root_.homology_functor _ _ (-i)).op).map f).unop
    ≫ Ext_compute_with_acyclic_aux₃ C₁ B i =
  Ext_compute_with_acyclic_aux₃ C₂ B i ≫
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op ⋙
      (_root_.homology_functor _ _ (-i)).op).map
      (bounded_homotopy_category.lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π).out).unop :=
begin
  dsimp only [Ext_compute_with_acyclic_aux₃, functor.comp_map,
    _root_.homology_functor, functor.op, homological_complex.hom.sq_from,
    homological_complex.hom.sq_to, homotopy_category.quotient,
    homotopy_category.homology_functor, quotient.functor,
    category_theory.quotient.lift, quot.lift_on, quiver.hom.unop_op],
  simp_rw homology.map_eq_desc'_lift_left,
  apply homology.hom_from_ext,
  simp only [category.assoc, homology.π'_desc'_assoc],
  slice_rhs 1 2
  { erw homology.π'_desc' },
  dsimp only [arrow.hom_mk_left],
  rw Ext_compute_with_acyclic_aux₃_naturality_helpers.helper₁,
  conv_rhs { rw Ext_compute_with_acyclic_aux₃_naturality_helpers.helper₂ },
  simp only [category.assoc],
  slice_lhs 2 3
  { erw homology.π'_desc' },
  slice_rhs 2 3
  { erw homology.π'_desc' },
  apply homology.hom_to_ext,
  slice_lhs 2 3
  { erw homology.lift_ι },
  slice_rhs 2 3
  { erw homology.lift_ι },
  slice_lhs 1 2
  { erw kernel.lift_ι },
  slice_rhs 1 2
  { erw kernel.lift_ι },
  simp only [category.assoc],
  dsimp only [Ext_compute_with_acyclic_HomB, functor.comp_map],
  change _ ≫ (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op).map f).unop.f _ ≫ _ = _,
  slice_lhs 2 3
  { simp only [← homological_complex.comp_f, ← unop_comp],
    simp only [functor.comp_map, ← functor.map_comp] },
  slice_rhs 2 3
  { simp only [← homological_complex.comp_f, ← unop_comp, ← functor.map_comp] },
  apply homotopy.kernel_ι_comp_comp_cokernel_π_of_homotopy,
  apply homotopy.homotopy_unop_functor_right_op_map_unop_of_homotopy,
  apply functor.map_homotopy,
  suffices : (lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π) ≫ (of' C₂).π =
    (of' C₁).π ≫ of'_hom f,
  { apply homotopy_category.homotopy_of_eq,
    convert this.symm,
    { simpa only [functor.map_comp, quotient_map_out], },
    { simpa only [functor.map_comp, quotient_map_out], } },
  simp,
end

lemma Ext_compute_with_acyclic_aux₃_is_iso
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B))
  (i : ℤ) : is_iso (Ext_compute_with_acyclic_aux₃ C B i) :=
begin
  haveI := Ext_compute_with_acyclic_is_quasi_iso_aux C B hC i,
  apply is_quasi_iso.cond,
end

def Ext_compute_with_acyclic
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B))
  (i : ℤ) :
  ((Ext i).obj (op $ of' C)).obj ((single _ 0).obj B) ≅
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _).obj C).unop.homology (-i) :=
Ext_compute_with_acyclic_aux₁ C B i ≪≫
Ext_compute_with_acyclic_aux₂ _ _ _ ≪≫
begin
  haveI := Ext_compute_with_acyclic_aux₃_is_iso C B hC i,
  exact (as_iso (Ext_compute_with_acyclic_aux₃ C B i)).symm,
end

/-
def homological_complex.single_iso (B : 𝓐) {i j : ℤ} (h : j = i) :
  ((homological_complex.single _ (complex_shape.up ℤ) i).obj B).X j ≅ B :=
eq_to_iso (if_pos h)

/-- The morphism in `Ab` which eats a morphism of complexes `C ⟶ B[-i]`
  and returns an element of Extⁱ(C,B[0]). -/
def Ext_compute_with_acyclic_inv_eq_aux (B) (i) :
  AddCommGroup.of (C ⟶ (homological_complex.single _ _ (-i)).obj B) ⟶
  ((Ext i).obj (op (of' C))).obj ((single 𝓐 0).obj B) :=
{ to_fun := λ f, (of' C).π ≫ begin
    refine (homotopy_category.quotient _ _).map _,
    refine _ ≫ (homological_complex.single_shift _ _).inv.app _,
    refine (f : C ⟶ (homological_complex.single 𝓐 (complex_shape.up ℤ) (-i)).obj B) ≫ _,
    refine eq_to_hom _,
    simp,
  end,
  map_zero' := begin
    simp only [zero_comp, functor.map_zero, comp_zero],
  end,
  map_add' := begin
    intros,
    simp only [preadditive.add_comp, functor.map_add, preadditive.comp_add],
  end }

lemma iso_equiv_inv_apply_eq_zero_cancel
  {A B C : AddCommGroup} {a : A} {f : A ⟶ B} {e : C ≅ B}
  (h : (f ≫ e.inv) a = 0) : f a = 0 :=
begin
  rw comp_apply at h,
  apply_fun e.hom at h,
  simpa using h,
end

-- Note: in the application of the below, j = -i
/-- The construction which given something in the kernel of `(Cⱼ ⟶ B) ⟶ (Cⱼ-₁ ⟶ B)`
  constructs a morphism of complexes from C to the "skyscraper complex" B[j]. -/
def kernel_yoneda_complex_to_morphism_to_single (B : 𝓐) (j : ℤ) :
-- we're going from the kernel of `(C.X j ⟶ B) ⟶ (C.X_prev j ⟶ B)` (it's actually `C.symm.X_next`)
kernel ((((preadditive_yoneda.obj B).map_homological_complex _).obj
  (homological_complex.op C)).d_from j)
  -- to the additive group of homs
  ⟶ AddCommGroup.of (
  -- from C to B j
  C ⟶ (homological_complex.single 𝓐 (complex_shape.up ℤ) j).obj B) :=
{ to_fun := λ f, { f := λ k,
  if hk : k = j then
    (eq_to_hom (by rw hk) : C.X k ⟶ C.X j) ≫
    (kernel.ι ((((preadditive_yoneda.obj B).map_homological_complex _).obj
                (homological_complex.op C)).d_from j) f : C.X j ⟶ B) ≫
    (homological_complex.single_obj_X_self 𝓐 (complex_shape.up ℤ) j B).inv ≫
    eq_to_hom (by rw hk)
  else 0,
    comm' := λ i k, begin
      split_ifs with hij hkj hkj,
      { subst hij, subst hkj, simp {contextual := tt}, },
      { simp only [homological_complex.single_obj_d, comp_zero, eq_self_iff_true,
          implies_true_iff] },
      { subst hkj,
        set g := ((kernel.ι ((((preadditive_yoneda.obj B).map_homological_complex
                            (complex_shape.up ℤ).symm).obj
                  (homological_complex.op C)).d_from k)) f) with hg,
        simp only [complex_shape.up_rel, zero_comp, eq_to_hom_refl,
          homological_complex.single_obj_X_self_inv, category.comp_id, category.id_comp],
        rintro hik, clear hij,
        have := kernel.condition ((((preadditive_yoneda.obj B).map_homological_complex _).obj
          (homological_complex.op C)).d_from k),
        replace this := congr_hom this f,
        rw [comp_apply, ← hg, AddCommGroup.zero_apply] at this,
        rw ← category.assoc,
        symmetry,
        convert zero_comp,
        have foo : (complex_shape.up ℤ).symm.rel k i := hik,
        rw homological_complex.d_from_eq _ foo at this,
        exact iso_equiv_inv_apply_eq_zero_cancel this, },
      { simp only [zero_comp, comp_zero, eq_self_iff_true, implies_true_iff]},
    end },
  map_zero' := by {simp only [map_zero, homological_complex.single_obj_X_self_inv,
    eq_to_hom_trans, zero_comp, comp_zero, dite_eq_ite, if_t_t], refl },
  map_add' := by { intros, ext, simp only [map_add, homological_complex.single_obj_X_self_inv,
    eq_to_hom_trans, preadditive.add_comp, preadditive.comp_add, homological_complex.add_f_apply],
    split_ifs,
    { refl },
    { refl },
    { exact (add_zero _).symm, } } }

lemma Ext_compute_with_acylic_inv_eq (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B))
  (i : ℤ) :
  (Ext_compute_with_acyclic _ B hC i).inv =
  homology.desc' _ _ _
  ( kernel_yoneda_complex_to_morphism_to_single C B (-i) ≫
    Ext_compute_with_acyclic_inv_eq_aux C B i)
admit := admit

-- Replacing some `End` with `cend` fixes my bracket pair colorizer!
-- notation `cend` := category_theory.End

-/

lemma Ext_compute_with_acyclic_naturality (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (hC₁ : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C₁.X k)).obj B))
  (hC₂ : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C₂.X k)).obj B))
  (f : C₁ ⟶ C₂)
  (i : ℤ) :
  ((Ext i).flip.obj ((single _ 0).obj B)).map (quiver.hom.op $ of'_hom f) ≫
    (Ext_compute_with_acyclic C₁ B hC₁ i).hom =
  (Ext_compute_with_acyclic C₂ B hC₂ i).hom ≫
    (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op ⋙
      (_root_.homology_functor _ _ (-i)).op).map f).unop :=
begin
  dsimp only [Ext_compute_with_acyclic, iso.trans_hom],
  slice_lhs 1 2
  { erw Ext_compute_with_acyclic_aux₁_naturality },
  slice_lhs 2 3
  { rw Ext_compute_with_acyclic_aux₂_naturality },
  simp only [category.assoc],
  congr' 2,
  dsimp only [iso.symm_hom, as_iso_inv],
  rw [is_iso.eq_inv_comp, ← category.assoc, is_iso.comp_inv_eq],
  symmetry,
  apply Ext_compute_with_acyclic_aux₃_naturality,
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.types
import category_theory.currying
import category_theory.limits.functor_category

/-!
# The morphism comparing a colimit of limits with the corresponding limit of colimits.

For `F : J × K ⥤ C` there is always a morphism $\colim_k \lim_j F(j,k) → \lim_j \colim_k F(j, k)$.
While it is not usually an isomorphism, with additional hypotheses on `J` and `K` it may be,
in which case we say that "colimits commute with limits".

The prototypical example, proved in `category_theory.limits.filtered_colimit_commutes_finite_limit`,
is that when `C = Type`, filtered colimits commute with finite limits.

## References
* Borceux, Handbook of categorical algebra 1, Section 2.13
* [Stacks: Filtered colimits](https://stacks.math.columbia.edu/tag/002W)
-/

universes v₂ v u

open category_theory

namespace category_theory.limits

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

variables (F : J × K ⥤ C)

open category_theory.prod

lemma map_id_left_eq_curry_map {j : J} {k k' : K} {f : k ⟶ k'} :
  F.map ((𝟙 j, f) : (j, k) ⟶ (j, k')) = ((curry.obj F).obj j).map f :=
rfl

lemma map_id_right_eq_curry_swap_map {j j' : J} {f : j ⟶ j'} {k : K} :
  F.map ((f, 𝟙 k) : (j, k) ⟶ (j', k)) = ((curry.obj (swap K J ⋙ F)).obj k).map f :=
rfl

variables [has_limits_of_shape J C]
variables [has_colimits_of_shape K C]

/--
The universal morphism
$\colim_k \lim_j F(j,k) → \lim_j \colim_k F(j, k)$.
-/
noncomputable
def colimit_limit_to_limit_colimit :
  colimit ((curry.obj (swap K J ⋙ F)) ⋙ lim) ⟶ limit ((curry.obj F) ⋙ colim) :=
limit.lift ((curry.obj F) ⋙ colim)
{ X := _,
  π :=
  { app := λ j, colimit.desc ((curry.obj (swap K J ⋙ F)) ⋙ lim)
    { X := _,
      ι :=
      { app := λ k,
          limit.π ((curry.obj (swap K J ⋙ F)).obj k) j ≫ colimit.ι ((curry.obj F).obj j) k,
        naturality' :=
        begin
          dsimp,
          intros k k' f,
          simp only [functor.comp_map, curry.obj_map_app, limits.lim_map_π_assoc, swap_map,
            category.comp_id, map_id_left_eq_curry_map, colimit.w],
        end }, },
    naturality' :=
    begin
      dsimp,
      intros j j' f,
      ext k,
      simp only [limits.colimit.ι_map, curry.obj_map_app, limits.colimit.ι_desc_assoc,
        limits.colimit.ι_desc, category.id_comp, category.assoc, map_id_right_eq_curry_swap_map,
        limit.w_assoc],
    end } }

/--
Since `colimit_limit_to_limit_colimit` is a morphism from a colimit to a limit,
this lemma characterises it.
-/
@[simp, reassoc] lemma ι_colimit_limit_to_limit_colimit_π (j) (k) :
  colimit.ι _ k ≫ colimit_limit_to_limit_colimit F ≫ limit.π _ j =
    limit.π ((curry.obj (swap K J ⋙ F)).obj k) j ≫ colimit.ι ((curry.obj F).obj j) k :=
by { dsimp [colimit_limit_to_limit_colimit], simp, }

@[simp] lemma ι_colimit_limit_to_limit_colimit_π_apply (F : J × K ⥤ Type v) (j) (k) (f) :
   limit.π ((curry.obj F) ⋙ colim) j
     (colimit_limit_to_limit_colimit F (colimit.ι ((curry.obj (swap K J ⋙ F)) ⋙ lim) k f)) =
     colimit.ι ((curry.obj F).obj j) k (limit.π ((curry.obj (swap K J ⋙ F)).obj k) j f) :=
by { dsimp [colimit_limit_to_limit_colimit], simp, }

/-- The map `colimit_limit_to_limit_colimit` realized as a map of cones. -/
@[simps] noncomputable def colimit_limit_to_limit_colimit_cone (G : J ⥤ K ⥤ C) [has_limit G] :
  colim.map_cone (limit.cone G) ⟶ limit.cone (G ⋙ colim) :=
{ hom := colim.map (limit_iso_swap_comp_lim G).hom ≫
    colimit_limit_to_limit_colimit (uncurry.obj G : _) ≫
    lim.map (whisker_right (currying.unit_iso.app G).inv colim),
  w' := λ j,
  begin
    ext1 k,
    simp only [limit_obj_iso_limit_comp_evaluation_hom_π_assoc, iso.app_inv,
      ι_colimit_limit_to_limit_colimit_π_assoc, whisker_right_app,
      colimit.ι_map, functor.map_cone_π_app, category.id_comp,
      eq_to_hom_refl, eq_to_hom_app, colimit.ι_map_assoc, limit.cone_π,
      lim_map_π_assoc, lim_map_π, category.assoc, currying_unit_iso_inv_app_app_app,
      limit_iso_swap_comp_lim_hom_app, lim_map_eq_lim_map],
    erw category.id_comp,
  end }

end category_theory.limits


example (G : Type) [group G] (g h k : G) : (g * h * k⁻¹)⁻¹ = k * h⁻¹ * g⁻¹ :=
begin
  simp [mul_assoc]
end


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.gluing
import category_theory.limits.opposites
import algebraic_geometry.Gamma_Spec_adjunction

/-!
# Fibred products of schemes

In this file we construct the fibred product of schemes via gluing.
We roughly follow [har77] Theorem 3.3.

In particular, the main construction is to show that for an open cover `{ Uᵢ }` of `X`, if there
exist fibred products `Uᵢ ×[Z] Y` for each `i`, then there exists a fibred product `X ×[Z] Y`.

Then, for constructing the fibred product for arbitrary schemes `X, Y, Z`, we can use the
construction to reduce to the case where `X, Y, Z` are all affine, where fibred products are
constructed via tensor products.

-/
universes v u
noncomputable theory

open category_theory category_theory.limits algebraic_geometry
namespace algebraic_geometry.Scheme

namespace pullback

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

variables {X Y Z : Scheme.{u}} (𝒰 : open_cover.{u} X) (f : X ⟶ Z) (g : Y ⟶ Z)
variables [∀ i, has_pullback (𝒰.map i ≫ f) g]

/-- The intersection of `Uᵢ ×[Z] Y` and `Uⱼ ×[Z] Y` is given by (Uᵢ ×[Z] Y) ×[X] Uⱼ -/
def V (i j : 𝒰.J) : Scheme :=
pullback ((pullback.fst : pullback ((𝒰.map i) ≫ f) g ⟶ _) ≫ (𝒰.map i)) (𝒰.map j)

/-- The canonical transition map `(Uᵢ ×[Z] Y) ×[X] Uⱼ ⟶ (Uⱼ ×[Z] Y) ×[X] Uᵢ` given by the fact
that pullbacks are associative and symmetric. -/
def t (i j : 𝒰.J) : V 𝒰 f g i j ⟶ V 𝒰 f g j i :=
begin
  haveI : has_pullback (pullback.snd ≫ 𝒰.map i ≫ f) g :=
    has_pullback_assoc_symm (𝒰.map j) (𝒰.map i) (𝒰.map i ≫ f) g,
  haveI : has_pullback (pullback.snd ≫ 𝒰.map j ≫ f) g :=
    has_pullback_assoc_symm (𝒰.map i) (𝒰.map j) (𝒰.map j ≫ f) g,
  refine (pullback_symmetry _ _).hom ≫ _,
  refine (pullback_assoc _ _ _ _).inv ≫ _,
  change pullback _ _ ⟶ pullback _ _,
  refine _ ≫ (pullback_symmetry _ _).hom,
  refine _ ≫ (pullback_assoc _ _ _ _).hom,
  refine pullback.map _ _ _ _ (pullback_symmetry _ _).hom (𝟙 _) (𝟙 _) _ _,
  rw [pullback_symmetry_hom_comp_snd_assoc, pullback.condition_assoc, category.comp_id],
  rw [category.comp_id, category.id_comp]
end

@[simp, reassoc]
lemma t_fst_fst (i j : 𝒰.J) : t 𝒰 f g i j ≫ pullback.fst ≫ pullback.fst = pullback.snd :=
by { delta t, simp }

@[simp, reassoc]
lemma t_fst_snd (i j : 𝒰.J) :
  t 𝒰 f g i j ≫ pullback.fst ≫ pullback.snd = pullback.fst ≫ pullback.snd :=
by { delta t, simp }

@[simp, reassoc]
lemma t_snd (i j : 𝒰.J) :
  t 𝒰 f g i j ≫ pullback.snd = pullback.fst ≫ pullback.fst :=
by { delta t, simp }

lemma t_id (i : 𝒰.J) : t 𝒰 f g i i = 𝟙 _ :=
begin
  apply pullback.hom_ext; rw category.id_comp,
  apply pullback.hom_ext,
  { rw ← cancel_mono (𝒰.map i), simp [pullback.condition] },
  { simp },
  { rw ← cancel_mono (𝒰.map i), simp [pullback.condition] }
end

/-- The inclusion map of `V i j = (Uᵢ ×[Z] Y) ×[X] Uⱼ ⟶ Uᵢ ×[Z] Y`-/
abbreviation fV (i j : 𝒰.J) : V 𝒰 f g i j ⟶ pullback ((𝒰.map i) ≫ f) g := pullback.fst

/-- The map `((Xᵢ ×[Z] Y) ×[X] Xⱼ) ×[Xᵢ ×[Z] Y] ((Xᵢ ×[Z] Y) ×[X] Xₖ)` ⟶
  `((Xⱼ ×[Z] Y) ×[X] Xₖ) ×[Xⱼ ×[Z] Y] ((Xⱼ ×[Z] Y) ×[X] Xᵢ)` needed for gluing   -/
def t' (i j k : 𝒰.J) :
  pullback (fV 𝒰 f g i j) (fV 𝒰 f g i k) ⟶ pullback (fV 𝒰 f g j k) (fV 𝒰 f g j i) :=
begin
  refine (pullback_right_pullback_fst_iso _ _ _).hom ≫ _,
  refine _ ≫ (pullback_symmetry _ _).hom,
  refine _ ≫ (pullback_right_pullback_fst_iso _ _ _).inv,
  refine pullback.map _ _ _ _ (t 𝒰 f g i j) (𝟙 _) (𝟙 _) _ _,
  { simp [← pullback.condition] },
  { simp }
end

section end

@[simp, reassoc]
lemma t'_fst_fst_fst (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.fst ≫ pullback.fst ≫ pullback.fst = pullback.fst ≫ pullback.snd :=
by { delta t', simp }

@[simp, reassoc]
lemma t'_fst_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.fst ≫ pullback.fst ≫ pullback.snd =
    pullback.fst ≫ pullback.fst ≫ pullback.snd :=
by { delta t', simp }

@[simp, reassoc]
lemma t'_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.fst ≫ pullback.snd = pullback.snd ≫ pullback.snd :=
by { delta t', simp }

@[simp, reassoc]
lemma t'_snd_fst_fst (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.snd ≫ pullback.fst ≫ pullback.fst = pullback.fst ≫ pullback.snd :=
by { delta t', simp }

@[simp, reassoc]
lemma t'_snd_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.snd ≫ pullback.fst ≫ pullback.snd =
    pullback.fst ≫ pullback.fst ≫ pullback.snd :=
by { delta t', simp }

@[simp, reassoc]
lemma t'_snd_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.snd ≫ pullback.snd = pullback.fst ≫ pullback.fst ≫ pullback.fst :=
by { delta t', simp, }

lemma cocycle_fst_fst_fst (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.fst ≫ pullback.fst ≫
  pullback.fst = pullback.fst ≫ pullback.fst ≫ pullback.fst :=
by simp

lemma cocycle_fst_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.fst ≫ pullback.fst ≫
  pullback.snd = pullback.fst ≫ pullback.fst ≫ pullback.snd :=
by simp

lemma cocycle_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.fst ≫ pullback.snd =
    pullback.fst ≫ pullback.snd :=
by simp

lemma cocycle_snd_fst_fst (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.snd ≫ pullback.fst ≫
  pullback.fst = pullback.snd ≫ pullback.fst ≫ pullback.fst :=
by { rw ← cancel_mono (𝒰.map i), simp [pullback.condition_assoc, pullback.condition] }

lemma cocycle_snd_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.snd ≫ pullback.fst ≫
  pullback.snd = pullback.snd ≫ pullback.fst ≫ pullback.snd :=
by { simp [pullback.condition_assoc, pullback.condition] }

lemma cocycle_snd_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.snd ≫ pullback.snd =
    pullback.snd ≫ pullback.snd :=
by simp

-- `by tidy` should solve it, but it times out.
lemma cocycle (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j = 𝟙 _ :=
begin
  apply pullback.hom_ext; rw category.id_comp,
  { apply pullback.hom_ext,
    { apply pullback.hom_ext,
      { simp_rw category.assoc,
        exact cocycle_fst_fst_fst 𝒰 f g i j k },
      { simp_rw category.assoc,
        exact cocycle_fst_fst_snd 𝒰 f g i j k } },
    { simp_rw category.assoc,
      exact cocycle_fst_snd 𝒰 f g i j k } },
  { apply pullback.hom_ext,
    { apply pullback.hom_ext,
      { simp_rw category.assoc,
        exact cocycle_snd_fst_fst 𝒰 f g i j k },
      { simp_rw category.assoc,
        exact cocycle_snd_fst_snd 𝒰 f g i j k } },
    { simp_rw category.assoc,
      exact cocycle_snd_snd 𝒰 f g i j k } }
end

/-- Given `Uᵢ ×[Z] Y`, this is the glued fibered product `X ×[Z] Y`. -/
@[simps]
def gluing : Scheme.glue_data.{u} :=
{ J := 𝒰.J,
  U := λ i, pullback ((𝒰.map i) ≫ f) g,
  V := λ ⟨i, j⟩, V 𝒰 f g i j, -- `p⁻¹(Uᵢ ∩ Uⱼ)` where `p : Uᵢ ×[Z] Y ⟶ Uᵢ ⟶ X`.
  f := λ i j, pullback.fst,
  f_id := λ i, infer_instance,
  f_open := infer_instance,
  t := λ i j, t 𝒰 f g i j,
  t_id := λ i, t_id 𝒰 f g i,
  t' := λ i j k, t' 𝒰 f g i j k,
  t_fac := λ i j k, begin
    apply pullback.hom_ext,
    apply pullback.hom_ext,
    all_goals { simp }
  end,
  cocycle := λ i j k, cocycle 𝒰 f g i j k }

/-- The first projection from the glued scheme into `X`. -/
def p1 : (gluing 𝒰 f g).glued ⟶ X :=
begin
  fapply multicoequalizer.desc,
  exact λ i, pullback.fst ≫ 𝒰.map i,
  rintro ⟨i, j⟩,
  change pullback.fst ≫ _ ≫ 𝒰.map i = (_ ≫ _) ≫ _ ≫ 𝒰.map j,
  rw pullback.condition,
  rw ← category.assoc,
  congr' 1,
  rw category.assoc,
  exact (t_fst_fst _ _ _ _ _).symm
end

/-- The second projection from the glued scheme into `Y`. -/
def p2 : (gluing 𝒰 f g).glued ⟶ Y :=
begin
  fapply multicoequalizer.desc,
  exact λ i, pullback.snd,
  rintro ⟨i, j⟩,
  change pullback.fst ≫ _ = (_ ≫ _) ≫ _,
  rw category.assoc,
  exact (t_fst_snd _ _ _ _ _).symm
end

lemma p_comm : p1 𝒰 f g ≫ f = p2 𝒰 f g ≫ g :=
begin
  apply multicoequalizer.hom_ext,
  intro i,
  erw [multicoequalizer.π_desc_assoc, multicoequalizer.π_desc_assoc],
  rw [category.assoc, pullback.condition]
end

variable (s : pullback_cone f g)

/-- (Implementation)
The canonical map `(s.X ×[X] Uᵢ) ×[s.X] (s.X ×[X] Uⱼ) ⟶ (Uᵢ ×[Z] Y) ×[X] Uⱼ`

This is used in `glued_lift`. -/
def glued_lift_pullback_map (i j : 𝒰.J) :
  pullback ((𝒰.pullback_cover s.fst).map i) ((𝒰.pullback_cover s.fst).map j) ⟶
    (gluing 𝒰 f g).V ⟨i, j⟩ :=
begin
  change pullback pullback.fst pullback.fst ⟶ pullback _ _,
  refine (pullback_right_pullback_fst_iso _ _ _).hom ≫ _,
  refine pullback.map _ _ _ _ _ (𝟙 _) (𝟙 _) _ _,
  { exact (pullback_symmetry _ _).hom ≫
      pullback.map _ _ _ _ (𝟙 _) s.snd f (category.id_comp _).symm s.condition },
  { simpa using pullback.condition },
  { simp }
end

@[reassoc]
lemma glued_lift_pullback_map_fst (i j : 𝒰.J) :
  glued_lift_pullback_map 𝒰 f g s i j ≫ pullback.fst = pullback.fst ≫
    (pullback_symmetry _ _).hom ≫
      pullback.map _ _ _ _ (𝟙 _) s.snd f (category.id_comp _).symm s.condition :=
by { delta glued_lift_pullback_map, simp }

@[reassoc]
lemma glued_lift_pullback_map_snd (i j : 𝒰.J) :
  glued_lift_pullback_map 𝒰 f g s i j ≫ pullback.snd = pullback.snd ≫ pullback.snd :=
by { delta glued_lift_pullback_map, simp }

/--
The lifted map `s.X ⟶ (gluing 𝒰 f g).glued` in order to show that `(gluing 𝒰 f g).glued` is
indeed the pullback.

Given a pullback cone `s`, we have the maps `s.fst ⁻¹' Uᵢ ⟶ Uᵢ` and
`s.fst ⁻¹' Uᵢ ⟶ s.X ⟶ Y` that we may lift to a map `s.fst ⁻¹' Uᵢ ⟶ Uᵢ ×[Z] Y`.

to glue these into a map `s.X ⟶ Uᵢ ×[Z] Y`, we need to show that the maps agree on
`(s.fst ⁻¹' Uᵢ) ×[s.X] (s.fst ⁻¹' Uⱼ) ⟶ Uᵢ ×[Z] Y`. This is achieved by showing that both of these
maps factors through `glued_lift_pullback_map`.
-/
def glued_lift : s.X ⟶ (gluing 𝒰 f g).glued :=
begin
  fapply (𝒰.pullback_cover s.fst).glue_morphisms,
  { exact λ i, (pullback_symmetry _ _).hom ≫
      pullback.map _ _ _ _ (𝟙 _) s.snd f (category.id_comp _).symm s.condition ≫
      (gluing 𝒰 f g).ι i },
  intros i j,
  rw ← glued_lift_pullback_map_fst_assoc,
  have : _ = pullback.fst ≫ _ := (gluing 𝒰 f g).glue_condition i j,
  rw [← this, gluing_to_glue_data_t, gluing_to_glue_data_f],
  simp_rw ← category.assoc,
  congr' 1,
  apply pullback.hom_ext; simp_rw category.assoc,
  { rw [t_fst_fst, glued_lift_pullback_map_snd],
    congr' 1,
    rw [← iso.inv_comp_eq, pullback_symmetry_inv_comp_snd],
    erw pullback.lift_fst,
    rw category.comp_id },
  { rw [t_fst_snd, glued_lift_pullback_map_fst_assoc],
    erw [pullback.lift_snd, pullback.lift_snd],
    rw [pullback_symmetry_hom_comp_snd_assoc, pullback_symmetry_hom_comp_snd_assoc],
    exact pullback.condition_assoc _ }
end

lemma glued_lift_p1 : glued_lift 𝒰 f g s ≫ p1 𝒰 f g = s.fst :=
begin
  rw ← cancel_epi (𝒰.pullback_cover s.fst).from_glued,
  apply multicoequalizer.hom_ext,
  intro b,
  erw [multicoequalizer.π_desc_assoc, multicoequalizer.π_desc_assoc],
  delta glued_lift,
  simp_rw ← category.assoc,
  rw (𝒰.pullback_cover s.fst).ι_glue_morphisms,
  simp_rw category.assoc,
  erw [multicoequalizer.π_desc, pullback.lift_fst_assoc, pullback.condition, category.comp_id],
  rw pullback_symmetry_hom_comp_fst_assoc,
end

lemma glued_lift_p2 : glued_lift 𝒰 f g s ≫ p2 𝒰 f g = s.snd :=
begin
  rw ← cancel_epi (𝒰.pullback_cover s.fst).from_glued,
  apply multicoequalizer.hom_ext,
  intro b,
  erw [multicoequalizer.π_desc_assoc, multicoequalizer.π_desc_assoc],
  delta glued_lift,
  simp_rw ← category.assoc,
  rw (𝒰.pullback_cover s.fst).ι_glue_morphisms,
  simp_rw category.assoc,
  erw [multicoequalizer.π_desc, pullback.lift_snd],
  rw pullback_symmetry_hom_comp_snd_assoc,
  refl
end

/-- (Implementation)
The canonical map `(W ×[X] Uᵢ) ×[W] (Uⱼ ×[Z] Y) ⟶ (Uⱼ ×[Z] Y) ×[X] Uᵢ = V j i` where `W` is
the glued fibred product.

This is used in `lift_comp_ι`. -/
def pullback_fst_ι_to_V (i j : 𝒰.J) :
  pullback (pullback.fst : pullback (p1 𝒰 f g) (𝒰.map i) ⟶ _) ((gluing 𝒰 f g).ι j) ⟶
    V 𝒰 f g j i :=
(pullback_symmetry _ _ ≪≫
  (pullback_right_pullback_fst_iso (p1 𝒰 f g) (𝒰.map i) _)).hom ≫
    (pullback.congr_hom (multicoequalizer.π_desc _ _ _ _ _) rfl).hom

@[simp, reassoc] lemma pullback_fst_ι_to_V_fst (i j : 𝒰.J) :
  pullback_fst_ι_to_V 𝒰 f g i j ≫ pullback.fst = pullback.snd :=
by { delta pullback_fst_ι_to_V, simp }

@[simp, reassoc] lemma pullback_fst_ι_to_V_snd (i j : 𝒰.J) :
  pullback_fst_ι_to_V 𝒰 f g i j ≫ pullback.snd = pullback.fst ≫ pullback.snd :=
by { delta pullback_fst_ι_to_V, simp }

/-- We show that the map `W ×[X] Uᵢ ⟶ Uᵢ ×[Z] Y ⟶ W` is the first projection, where the
first map is given by the lift of `W ×[X] Uᵢ ⟶ Uᵢ` and `W ×[X] Uᵢ ⟶ W ⟶ Y`.

It suffices to show that the two map agrees when restricted onto `Uⱼ ×[Z] Y`. In this case,
both maps factor through `V j i` via `pullback_fst_ι_to_V` -/
lemma lift_comp_ι (i : 𝒰.J) : pullback.lift pullback.snd (pullback.fst ≫ p2 𝒰 f g)
  (by rw [← pullback.condition_assoc, category.assoc, p_comm]) ≫
  (gluing 𝒰 f g).ι i = (pullback.fst : pullback (p1 𝒰 f g) (𝒰.map i) ⟶ _) :=
begin
  apply ((gluing 𝒰 f g).open_cover.pullback_cover pullback.fst).hom_ext,
  intro j,
  dsimp only [open_cover.pullback_cover],
  transitivity pullback_fst_ι_to_V 𝒰 f g i j ≫ fV 𝒰 f g j i ≫ (gluing 𝒰 f g).ι _,
  { rw ← (show _ = fV 𝒰 f g j i ≫ _, from (gluing 𝒰 f g).glue_condition j i),
    simp_rw ← category.assoc,
    congr' 1,
    rw [gluing_to_glue_data_f, gluing_to_glue_data_t],
    apply pullback.hom_ext; simp_rw category.assoc,
    { rw [t_fst_fst, pullback.lift_fst, pullback_fst_ι_to_V_snd] },
    { rw [t_fst_snd, pullback.lift_snd, pullback_fst_ι_to_V_fst_assoc,
        pullback.condition_assoc], erw multicoequalizer.π_desc } },
  { rw [pullback.condition, ← category.assoc],
    congr' 1,
    apply pullback.hom_ext,
    { simp },
    { simp } }
end

/-- The canonical isomorphism between `W ×[X] Uᵢ` and `Uᵢ ×[X] Y`. That is, the preimage of `Uᵢ` in
`W` along `p1` is indeed `Uᵢ ×[X] Y`. -/
def pullback_p1_iso (i : 𝒰.J) :
  pullback (p1 𝒰 f g) (𝒰.map i) ≅ pullback (𝒰.map i ≫ f) g :=
begin
  fsplit,
  exact pullback.lift pullback.snd (pullback.fst ≫ p2 𝒰 f g)
    (by rw [← pullback.condition_assoc, category.assoc, p_comm]),
  refine pullback.lift ((gluing 𝒰 f g).ι i) pullback.fst
    (by erw multicoequalizer.π_desc),
  { apply pullback.hom_ext,
    { simpa using lift_comp_ι 𝒰 f g i },
    { simp } },
  { apply pullback.hom_ext,
    { simp },
    { simp, erw multicoequalizer.π_desc } },
end

@[simp, reassoc] lemma pullback_p1_iso_hom_fst (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).hom ≫ pullback.fst = pullback.snd :=
by { delta pullback_p1_iso, simp }

@[simp, reassoc] lemma pullback_p1_iso_hom_snd (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).hom ≫ pullback.snd = pullback.fst ≫ p2 𝒰 f g :=
by { delta pullback_p1_iso, simp }

@[simp, reassoc] lemma pullback_p1_iso_inv_fst (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).inv ≫ pullback.fst = (gluing 𝒰 f g).ι i :=
by { delta pullback_p1_iso, simp }

@[simp, reassoc] lemma pullback_p1_iso_inv_snd (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).inv ≫ pullback.snd = pullback.fst :=
by { delta pullback_p1_iso, simp }

@[simp, reassoc]
lemma pullback_p1_iso_hom_ι (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).hom ≫ (gluing 𝒰 f g).ι i = pullback.fst :=
by rw [← pullback_p1_iso_inv_fst, iso.hom_inv_id_assoc]

/-- The glued scheme (`(gluing 𝒰 f g).glued`) is indeed the pullback of `f` and `g`. -/
def glued_is_limit : is_limit (pullback_cone.mk _ _ (p_comm 𝒰 f g)) :=
begin
  apply pullback_cone.is_limit_aux',
  intro s,
  refine ⟨glued_lift 𝒰 f g s, glued_lift_p1 𝒰 f g s, glued_lift_p2 𝒰 f g s, _⟩,
  intros m h₁ h₂,
  change m ≫ p1 𝒰 f g = _ at h₁,
  change m ≫ p2 𝒰 f g = _ at h₂,
  apply (𝒰.pullback_cover s.fst).hom_ext,
  intro i,
  rw open_cover.pullback_cover_map,
  have := pullback_right_pullback_fst_iso (p1 𝒰 f g) (𝒰.map i) m
    ≪≫ pullback.congr_hom h₁ rfl,
  erw (𝒰.pullback_cover s.fst).ι_glue_morphisms,
  rw [← cancel_epi (pullback_right_pullback_fst_iso (p1 𝒰 f g) (𝒰.map i) m
    ≪≫ pullback.congr_hom h₁ rfl).hom, iso.trans_hom, category.assoc, pullback.congr_hom_hom,
    pullback.lift_fst_assoc, category.comp_id, pullback_right_pullback_fst_iso_hom_fst_assoc,
    pullback.condition],
  transitivity pullback.snd ≫ (pullback_p1_iso 𝒰 f g _).hom ≫ (gluing 𝒰 f g).ι _,
  { congr' 1, rw ← pullback_p1_iso_hom_ι },
  simp_rw ← category.assoc,
  congr' 1,
  apply pullback.hom_ext,
  { simp only [category.comp_id, pullback_right_pullback_fst_iso_hom_snd, category.assoc,
      pullback_p1_iso_hom_fst, pullback.lift_snd, pullback.lift_fst,
      pullback_symmetry_hom_comp_fst] },
  { simp only [category.comp_id, pullback_right_pullback_fst_iso_hom_fst_assoc,
    pullback_p1_iso_hom_snd, category.assoc, pullback.lift_fst_assoc,
    pullback_symmetry_hom_comp_snd_assoc, pullback.lift_snd],
    rw [← pullback.condition_assoc, h₂] }
end

lemma has_pullback_of_cover : has_pullback f g := ⟨⟨⟨_, glued_is_limit 𝒰 f g⟩⟩⟩

instance : has_limits CommRingᵒᵖ := has_limits_op_of_has_colimits

instance affine_has_pullback {A B C : CommRing}
  (f : Spec.obj (opposite.op A) ⟶ Spec.obj (opposite.op C))
  (g : Spec.obj (opposite.op B) ⟶ Spec.obj (opposite.op C)) : has_pullback f g :=
begin
  rw [← Spec.image_preimage f, ← Spec.image_preimage g],
  exact ⟨⟨⟨_,is_limit_of_has_pullback_of_preserves_limit
    Spec (Spec.preimage f) (Spec.preimage g)⟩⟩⟩
end

instance base_affine_has_pullback {C : CommRing} {X Y : Scheme}
  (f : X ⟶ Spec.obj (opposite.op C))
  (g : Y ⟶ Spec.obj (opposite.op C)) : has_pullback f g :=
@@has_pullback_symmetry _ _ _
  (@@has_pullback_of_cover Y.affine_cover g f
    (λ i, @@has_pullback_symmetry _ _ _ $ affine_affine_has_pullback _ _))

instance left_affine_comp_pullback_has_pullback {X Y Z : Scheme}
  (f : X ⟶ Z) (g : Y ⟶ Z) (i : Z.affine_cover.J) :
    has_pullback ((Z.affine_cover.pullback_cover f).map i ≫ f) g :=
begin
  let Xᵢ := pullback f (Z.affine_cover.map i),
  let Yᵢ := pullback g (Z.affine_cover.map i),
  let W := pullback (pullback.snd : Yᵢ ⟶ _) (pullback.snd : Xᵢ ⟶ _),
  have := big_square_is_pullback (pullback.fst : W ⟶ _) (pullback.fst : Yᵢ ⟶ _)
    (pullback.snd : Xᵢ ⟶ _) (Z.affine_cover.map i) pullback.snd pullback.snd g
    pullback.condition.symm pullback.condition.symm
      (pullback_cone.flip_is_limit $ pullback_is_pullback _ _)
      (pullback_cone.flip_is_limit $ pullback_is_pullback _ _),
  have : has_pullback (pullback.snd ≫ Z.affine_cover.map i : Xᵢ ⟶ _) g :=
    ⟨⟨⟨_,this⟩⟩⟩,
  rw ← pullback.condition at this,
  exact this,
end

instance {X Y Z : Scheme} (f : X ⟶ Z) (g : Y ⟶ Z) : has_pullback f g :=
has_pullback_of_cover (Z.affine_cover.pullback_cover f) f g

instance : has_pullbacks Scheme := has_pullbacks_of_has_limit_cospan _

/-- Given an open cover `{ Xᵢ }` of `X`, then `X ×[Z] Y` is covered by `Xᵢ ×[Z] Y`. -/
@[simps J obj map]
def open_cover_of_left (𝒰 : open_cover X) (f : X ⟶ Z) (g : Y ⟶ Z) : open_cover (pullback f g) :=
begin
  fapply ((gluing 𝒰 f g).open_cover.pushforward_iso
    (limit.iso_limit_cone ⟨_, glued_is_limit 𝒰 f g⟩).inv).copy 𝒰.J
    (λ i, pullback (𝒰.map i ≫ f) g)
    (λ i, pullback.map _ _ _ _ (𝒰.map i) (𝟙 _) (𝟙 _) (category.comp_id _) (by simp))
    (equiv.refl 𝒰.J) (λ _, iso.refl _),
  rintro (i : 𝒰.J),
  change pullback.map _ _ _ _ _ _ _ _ _ = 𝟙 _ ≫ (gluing 𝒰 f g).ι i ≫ _,
  refine eq.trans _ (category.id_comp _).symm,
  apply pullback.hom_ext,
  all_goals
  { dsimp,
    simp only [limit.iso_limit_cone_inv_π, pullback_cone.mk_π_app_left, category.comp_id,
      pullback_cone.mk_π_app_right, category.assoc, pullback.lift_fst, pullback.lift_snd],
    symmetry,
    exact multicoequalizer.π_desc _ _ _ _ _ },
end

/-- Given an open cover `{ Yᵢ }` of `Y`, then `X ×[Z] Y` is covered by `X ×[Z] Yᵢ`. -/
@[simps J obj map]
def open_cover_of_right (𝒰 : open_cover Y) (f : X ⟶ Z) (g : Y ⟶ Z) : open_cover (pullback f g) :=
begin
  fapply ((open_cover_of_left 𝒰 g f).pushforward_iso (pullback_symmetry _ _).hom).copy 𝒰.J
    (λ i, pullback f (𝒰.map i ≫ g))
    (λ i, pullback.map _ _ _ _ (𝟙 _) (𝒰.map i) (𝟙 _) (by simp) (category.comp_id _))
    (equiv.refl _) (λ i, pullback_symmetry _ _),
  intro i,
  dsimp [open_cover.bind],
  apply pullback.hom_ext; simp,
end

/-- (Implementation). Use `open_cover_of_base` instead. -/
def open_cover_of_base' (𝒰 : open_cover Z) (f : X ⟶ Z) (g : Y ⟶ Z) : open_cover (pullback f g) :=
begin
  apply (open_cover_of_left (𝒰.pullback_cover f) f g).bind,
  intro i,
  let Xᵢ := pullback f (𝒰.map i),
  let Yᵢ := pullback g (𝒰.map i),
  let W := pullback (pullback.snd : Yᵢ ⟶ _) (pullback.snd : Xᵢ ⟶ _),
  have := big_square_is_pullback (pullback.fst : W ⟶ _) (pullback.fst : Yᵢ ⟶ _)
    (pullback.snd : Xᵢ ⟶ _) (𝒰.map i) pullback.snd pullback.snd g
    pullback.condition.symm pullback.condition.symm
      (pullback_cone.flip_is_limit $ pullback_is_pullback _ _)
      (pullback_cone.flip_is_limit $ pullback_is_pullback _ _),
  refine open_cover_of_is_iso
    ((pullback_symmetry _ _).hom ≫ (limit.iso_limit_cone ⟨_, this⟩).inv ≫
      pullback.map _ _ _ _ (𝟙 _) (𝟙 _) (𝟙 _) _ _),
  { simpa only [category.comp_id, category.id_comp, ← pullback.condition] },
  { simp only [category.comp_id, category.id_comp] },
  apply_instance
end

/-- Given an open cover `{ Zᵢ }` of `Z`, then `X ×[Z] Y` is covered by `Xᵢ ×[Zᵢ] Yᵢ`, where
  `Xᵢ = X ×[Z] Zᵢ` and `Yᵢ = Y ×[Z] Zᵢ` is the preimage of `Zᵢ` in `X` and `Y`. -/
@[simps J obj map]
def open_cover_of_base (𝒰 : open_cover Z) (f : X ⟶ Z) (g : Y ⟶ Z) : open_cover (pullback f g) :=
begin
  apply (open_cover_of_base' 𝒰 f g).copy
    𝒰.J
    (λ i, pullback (pullback.snd : pullback f (𝒰.map i) ⟶ _)
      (pullback.snd : pullback g (𝒰.map i) ⟶ _))
    (λ i, pullback.map _ _ _ _ pullback.fst pullback.fst (𝒰.map i)
      pullback.condition.symm pullback.condition.symm)
    ((equiv.prod_punit 𝒰.J).symm.trans (equiv.sigma_equiv_prod 𝒰.J punit).symm)
    (λ _, iso.refl _),
  intro i,
  change _ = _ ≫ _ ≫ _,
  refine eq.trans _ (category.id_comp _).symm,
  apply pullback.hom_ext; simp only [category.comp_id, open_cover_of_left_map,
    open_cover.pullback_cover_map, pullback_cone.mk_π_app_left, open_cover_of_is_iso_map,
    limit.iso_limit_cone_inv_π_assoc, category.assoc, pullback.lift_fst_assoc,
    pullback_symmetry_hom_comp_snd_assoc, pullback.lift_fst, limit.iso_limit_cone_inv_π,
    pullback_cone.mk_π_app_right, pullback_symmetry_hom_comp_fst_assoc, pullback.lift_snd],
end

end pullback

end algebraic_geometry.Scheme


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/

import tactic.interactive
import tactic.norm_num

/-!
# `field_simp` tactic

Tactic to clear denominators in algebraic expressions, based on `simp` with a specific simpset.
-/

namespace tactic

/-- Try to prove a goal of the form `x ≠ 0` by calling `assumption`, or `norm_num1` if `x` is
a numeral. -/
meta def field_simp.ne_zero : tactic unit := do
  goal ← tactic.target,
  match goal with
  | `(%%e ≠ 0) := assumption <|> do n ← e.to_rat, `[norm_num1]
  | _ := tactic.fail "goal should be of the form `x ≠ 0`"
  end

namespace interactive
setup_tactic_parser

/--
The goal of `field_simp` is to reduce an expression in a field to an expression of the form `n / d`
where neither `n` nor `d` contains any division symbol, just using the simplifier (with a carefully
crafted simpset named `field_simps`) to reduce the number of division symbols whenever possible by
iterating the following steps:

- write an inverse as a division
- in any product, move the division to the right
- if there are several divisions in a product, group them together at the end and write them as a
  single division
- reduce a sum to a common denominator

If the goal is an equality, this simpset will also clear the denominators, so that the proof
can normally be concluded by an application of `ring` or `ring_exp`.

`field_simp [hx, hy]` is a short form for
`simp [-one_div, -mul_eq_zero, hx, hy] with field_simps {discharger := [field_simp.ne_zero]}`

Note that this naive algorithm will not try to detect common factors in denominators to reduce the
complexity of the resulting expression. Instead, it relies on the ability of `ring` to handle
complicated expressions in the next step.

As always with the simplifier, reduction steps will only be applied if the preconditions of the
lemmas can be checked. This means that proofs that denominators are nonzero should be included. The
fact that a product is nonzero when all factors are, and that a power of a nonzero number is
nonzero, are included in the simpset, but more complicated assertions (especially dealing with sums)
should be given explicitly. If your expression is not completely reduced by the simplifier
invocation, check the denominators of the resulting expression and provide proofs that they are
nonzero to enable further progress.

To check that denominators are nonzero, `field_simp` will look for facts in the context, and
will try to apply `norm_num` to close numerical goals.

The invocation of `field_simp` removes the lemma `one_div` from the simpset, as this lemma
works against the algorithm explained above. It also removes
`mul_eq_zero : x * y = 0 ↔ x = 0 ∨ y = 0`, as `norm_num` can not work on disjunctions to
close goals of the form `24 ≠ 0`, and replaces it with `mul_ne_zero : x ≠ 0 → y ≠ 0 → x * y ≠ 0`
creating two goals instead of a disjunction.

For example,
```lean
example (a b c d x y : ℂ) (hx : x ≠ 0) (hy : y ≠ 0) :
  a + b / x + c / x^2 + d / x^3 = a + x⁻¹ * (y * b / y + (d / x + c) / x) :=
begin
  field_simp,
  ring
end
```

See also the `cancel_denoms` tactic, which tries to do a similar simplification for expressions
that have numerals in denominators.
The tactics are not related: `cancel_denoms` will only handle numeric denominators, and will try to
entirely remove (numeric) division from the expression by multiplying by a factor.
-/
meta def field_simp (no_dflt : parse only_flag) (hs : parse simp_arg_list)
  (attr_names : parse with_ident_list)
  (locat : parse location)
  (cfg : simp_config_ext := {discharger := field_simp.ne_zero}) : tactic unit :=
let attr_names := `field_simps :: attr_names,
    hs := simp_arg_type.except `one_div :: simp_arg_type.except `mul_eq_zero :: hs in
propagate_tags (simp_core cfg.to_simp_config cfg.discharger no_dflt hs attr_names locat >> skip)

add_tactic_doc
{ name       := "field_simp",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.field_simp],
  tags       := ["simplification", "arithmetic"] }

end interactive
end tactic


namespace M4R
  /-- Class defining a membership predicate, allowing the use of `∈` notation. -/
  class Mem (α : outParam (Type u)) (γ : Type v) where
    mem : α → γ → Prop
  infixl:55 " ∈ " => Mem.mem
  notation:55 x:55 " ∉ " s:56 => ¬ (x ∈ s)

  declare_syntax_cat binderterm -- notation for `a` or `a : A` or `a ∈ S`
  syntax ident : binderterm
  syntax ident " ∈ " term : binderterm
  syntax ident " ∉ " term : binderterm

  syntax "∀ " binderterm ", " term : term
  syntax "∃ " binderterm ", " term : term

  macro_rules
  -- ∀ x ∈ s, p := ∀ x, x ∈ s → p
  | `(∀ $x:ident ∈ $s, $p) => `(∀ $x:ident, $x ∈ $s → $p)
  -- ∃ x ∈ s, p := ∃ x, x ∈ s ∧ p
  | `(∃ $x:ident ∈ $s, $p) => `(∃ $x:ident, $x ∈ $s ∧ $p)
  -- ∀ x ∉ s, p := ∀ x, x ∉ s → p
  | `(∀ $x:ident ∉ $s, $p) => `(∀ $x:ident, $x ∉ $s → $p)
  -- ∃ x ∉ s, p := ∃ x, x ∉ s ∧ p
  | `(∃ $x:ident ∉ $s, $p) => `(∃ $x:ident, $x ∉ $s ∧ $p)

  /-- Class defining a subset predicate, allowing the use of `⊆` notation. -/
  class Subset (α : Type u) where
    subset : α → α → Prop
  infix:50 " ⊆ " => Subset.subset

  /-- Class defining a propert subset predicate, allowing the use of `⊊` notation. -/
  class ProperSubset (α : Type u) where
    propersubset : α → α → Prop
  infix:50 " ⊊ " => ProperSubset.propersubset

  /-- Class defining a not subset predicate, allowing the use of `⊈` notation. -/
  class NotSubset (α : Type u) where
     notsubset : α → α → Prop
  infix:50 " ⊈ " => NotSubset.notsubset

  /-- Class defining a union operation, allowing the use of `∪` notation. -/
  class Union (α : Type u) where
    union : α → α → α
  infixl:65 " ∪ " => Union.union

  /-- Class defining an intersection operation, allowing the use of `∩` notation. -/
  class Intersection (α : Type u) where
    intersection : α → α → α
  infixl:70 " ∩ " => Intersection.intersection

  /-- Class defining a set difference operation, allowing the use of `∖` notation. -/
  class SetMinus (α : Type u) where
    setminus : α → α → α
  infix:70 " ∖ " => SetMinus.setminus

  /-- Class defining a complement operation, allowing the use of `ᶜ` notation. -/
  class Complement (α : Type u) where
    complement : α → α
  postfix:max " ᶜ " => Complement.complement

  /- Notation for sets -/
  syntax "{ " ident " | " term " }" : term
  syntax "{ " ident ":" term " | " term " }" : term
  syntax "{ " ident "∈" term " | " term " }" : term
  macro_rules
  -- {a : A | p a}
  | `({ $x:ident : $t | $p }) => `(fun ($x:ident : $t) => $p)
  -- {a | p a}
  | `({ $x:ident | $p }) => `(fun ($x:ident) => $p)
  -- {a ∈ s | p a} := {a | a ∈ s ∧ p a}
  | `({ $x:ident ∈ $s | $p }) => `(fun $x => $x ∈ $s ∧ $p)

  /-- Class defining an inverse operation, allowing the use of `⁻¹` notation. -/
  class Inv (α : Type u) where
    inv : α → α
  postfix:max " ⁻¹ " => Inv.inv

  /-- Class defining a zero element, represented by the notation `0`. -/
  class Zero (α : Type _) where
    zero : α
  /-- Class defining a one element, represented by the notation `1`. -/
  class One  (α : Type _) where
    one  : α
  /-- The natural literal `0` can be interpreted as the element `0` of `Zero α`. -/
  instance Nat0 [Zero α] : OfNat α (nat_lit 0) where
    ofNat := Zero.zero
  /-- The natural literal `1` can be interpreted as the element `1` of `One α`. -/
  instance Nat1 [One  α] : OfNat α (nat_lit 1) where
    ofNat := One.one
  /-- A type with a zero element is inhabited. -/
  instance InhabitedZero [Zero α] : Inhabited α where default := 0
  /-- A type with a one element is inhabited. -/
  instance InhabitedOne  [One α]  : Inhabited α where default := 1
  /-- The natural number `0` is the zero element of `Nat`. -/
  instance NatZero : Zero Nat where zero := 0
  /-- The natural number `1` is the one element of `Nat`. -/
  instance NatOne  : One  Nat where one  := 1
  /-- The integer `0` is the zero element of `Int`. -/
  instance IntZero : Zero Int where zero := 0
  /-- The integer `1` is the one element of `Int`. -/
  instance IntOne  : One  Int where one  := 1

  /-- Class defining a type with a zero and one element which are not equal. -/
  class NonTrivial (α : Type _) [Zero α] [One α] where
    one_neq_zero : (1 : α) ≠ 0
  /-- The zero and one elements of `Nat` are not equal. -/
  instance NatNonTrivial : NonTrivial Nat where one_neq_zero := Nat.one_ne_zero
  /-- The zero and one elements of `Int` are not equal. -/
  instance IntNonTrivial : NonTrivial Int where one_neq_zero := by simp

  /-- Class defining a division predicate, allowing the use of `÷` notation. -/
  class Divides (α : Type u) where
    divides : α → α → Prop
  infix:55 " ÷ " => Divides.divides

  /-- Class defining a "ring equal" predicate, allowing the use of `≗` notation (used for associates). -/
  class RingEq (α : Type u) where
    ringeq : α → α → Prop
  infix:55 " ≗ " => RingEq.ringeq -- ≗ written \=o

  syntax "∑ " term : term
  syntax "∏ " term : term
  syntax "∑ " term " in " term : term
  syntax "∏ " term " in " term : term
  syntax "∑ " ident " in " term ", " term : term
  syntax "∏ " ident " in " term ", " term : term

   macro_rules
  -- ∑ s = s.sum
  | `(∑ $s) => `( ($s).sum )
  -- ∏ s := s.prod
  | `(∏ $s) => `( ($s).prod )
  -- ∑ f in s = s.map_sum f
  | `(∑ $f in $s) => `( ($s).map_sum $f )
  -- ∏ f in s := s.map_prod f
  | `(∏ $f in $s) => `( ($s).map_prod $f )
  -- ∑ x in s, f := s.map_sum fun x => f
  | `(∑ $x:ident in $s, $f) => `( ($s).map_sum fun $x => $f )
  -- ∏ x in s, f := s.map_prod fun x => f
  | `(∏ $x:ident in $s, $f) => `( ($s).map_prod fun $x => $f )

  @[simp] theorem zero_eq [z : Zero α] : z.zero    = 0     := rfl
  @[simp] theorem one_eq  [o : One  α] : o.one     = 1     := rfl
  @[simp] theorem neg_eq  [n : Neg  α] : n.neg x   = - x   := rfl
  @[simp] theorem hadd_eq [a : HAdd α β γ] : a.hAdd x y = x + y := rfl
  @[simp] theorem hsub_eq [s : HSub α β γ] : s.hSub x y = x - y := rfl
  @[simp] theorem hmul_eq [m : HMul α β γ] : m.hMul x y = x * y := rfl
  @[simp] theorem add_eq  [a : Add α] : a.add x y = x + y := rfl
  @[simp] theorem sub_eq  [s : Sub α] : s.sub x y = x - y := rfl
  @[simp] theorem mul_eq  [m : Mul α] : m.mul x y = x * y := rfl

end M4R


import for_mathlib.algebra.homology.trunc_ge

noncomputable theory

open category_theory category_theory.limits category_theory.category
open_locale zero_object

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

namespace category_theory.short_complex

lemma quasi_iso.of_kernel_fork {C : Type*} [category C] [has_zero_morphisms C]
  {S₁ S₂ : short_complex C} (φ : S₁ ⟶ S₂) [S₁.has_homology] [S₂.has_homology]
  [epi φ.τ₁] (hg₁ : S₁.g = 0) (hτ₂ : is_limit (kernel_fork.of_ι φ.τ₂
    (show φ.τ₂ ≫ S₂.g = 0, by rw [φ.comm₂₃, hg₁, zero_comp]))) :
  short_complex.quasi_iso φ :=
begin
  have w : φ.τ₂ ≫ S₂.g = 0 := by rw [φ.comm₂₃, hg₁, zero_comp],
  have h₂ := S₂.some_left_homology_data,
  let e : h₂.K ≅ S₁.X₂ := is_limit.cone_point_unique_up_to_iso h₂.hi hτ₂,
  have he : e.hom ≫ φ.τ₂ = h₂.i :=
    is_limit.cone_point_unique_up_to_iso_hom_comp h₂.hi hτ₂ walking_parallel_pair.zero,
  have wi : e.hom ≫ S₁.g = 0 := by rw [hg₁, comp_zero],
  let hi : is_limit (kernel_fork.of_ι e.hom wi) := kernel_fork.is_limit.of_ι _ _
    (λ A x hx, x ≫ e.inv)
    (λ A x hx, by rw [assoc, e.inv_hom_id, comp_id])
    (λ A x hx b hb, by rw [← hb, assoc, e.hom_inv_id, comp_id]),
  have comm : S₁.f ≫ e.inv = φ.τ₁ ≫ h₂.f',
  { rw [← cancel_mono h₂.i, assoc, assoc, h₂.f'_i, ← he, e.inv_hom_id_assoc, φ.comm₁₂], },
  have wπ : (S₁.f ≫ e.inv) ≫ h₂.π = 0,
  { rw [comm, assoc, h₂.f'_π, comp_zero], },
  have hπ : is_colimit (cokernel_cofork.of_π h₂.π wπ) := cokernel_cofork.is_colimit.of_π _ _
    (λ A x hx, h₂.hπ.desc (cokernel_cofork.of_π _
      (show h₂.f' ≫ x = 0, by rw [← cancel_epi φ.τ₁, ← reassoc_of comm, ← assoc, hx, comp_zero])))
    (λ A x hx, cofork.is_colimit.π_desc h₂.hπ)
    (λ A x hx b hb, by { erw [← cancel_epi h₂.π, hb, cofork.is_colimit.π_desc h₂.hπ], refl, }),
  let h₁ : S₁.left_homology_data :=
  { K := h₂.K,
    H := h₂.H,
    i := e.hom,
    wi := wi,
    hi := hi,
    π := h₂.π,
    wπ := wπ,
    hπ := hπ, },
  let hφ : left_homology_map_data φ h₁ h₂ :=
  { φK := 𝟙 _,
    φH := 𝟙 _,
    commi' := by rw [id_comp, he], },
  rw hφ.quasi_iso_iff,
  dsimp,
  apply_instance,
end

end category_theory.short_complex

namespace cochain_complex

variables (K L : cochain_complex C ℤ)

def trunc_le.X (n : ℤ) (i : ℤ) : C :=
if n < i
  then 0
  else if i = n
    then (homological_complex.short_complex_functor C (complex_shape.up ℤ) i ⋙
      short_complex.cycles_functor C).obj K
    else K.X i

lemma trunc_le.is_zero_X (n : ℤ) (i : ℤ) (hn : n < i) :
  is_zero (trunc_le.X K n i) :=
begin
  dsimp [trunc_le.X],
  simpa only [if_pos hn] using is_zero_zero C,
end

def trunc_le.X_iso_X (n : ℤ) (i : ℤ) (hn : i < n) :
  trunc_le.X K n i ≅ K.X i :=
eq_to_iso begin
  dsimp [trunc_le.X],
  rw [if_neg (show ¬n<i, by linarith), if_neg (show i ≠ n, by linarith)],
end

def trunc_le.X_iso_cycles (n : ℤ) (i : ℤ) (hn : i = n) :
  trunc_le.X K n i ≅ (K.sc' i).cycles :=
eq_to_iso begin
  dsimp [trunc_le.X],
  simpa only [if_neg (show ¬ n<i, by linarith), if_pos hn],
end

def trunc_le.d (n : ℤ) (i j : ℤ) : trunc_le.X K n i ⟶ trunc_le.X K n j :=
begin
  by_cases hij : i+1 = j,
  { by_cases hj₀ : n<j,
    { exact 0, },
    { by_cases hn : j = n,
      { exact ((K.sc' j).lift_cycles ((trunc_le.X_iso_X K n i (by linarith)).hom ≫ K.d i j)
          (by tidy)) ≫ (trunc_le.X_iso_cycles K n j hn).inv, },
      { exact (trunc_le.X_iso_X K n i (by linarith)).hom ≫ K.d i j ≫
          (trunc_le.X_iso_X K n j (by { cases (not_lt.1 hj₀).lt_or_eq; tauto, })).inv, }, }, },
  { exact 0, },
end

def trunc_le.ι_f (n i : ℤ) : trunc_le.X K n i ⟶ K.X i :=
begin
  by_cases hi : n < i,
  { exact 0, },
  { by_cases hn : i = n,
    { exact (trunc_le.X_iso_cycles K n i hn).hom ≫ (K.sc' i).cycles_i, },
    { exact (trunc_le.X_iso_X K n i (by { cases (not_lt.1 hi).lt_or_eq; tauto, })).hom, }, },
end

instance (n i : ℤ) : mono (trunc_le.ι_f K n i) :=
begin
  dsimp [trunc_le.ι_f],
  by_cases h₀ : n < i,
  { rw dif_pos h₀,
    constructor,
    intros Z f₁ f₂ eq,
    apply (trunc_le.is_zero_X K n i h₀).eq_of_tgt, },
  { rw dif_neg h₀,
    by_cases hn : i = n,
    { rw dif_pos hn,
      apply mono_comp, },
    { rw dif_neg hn,
      apply_instance, }, },
end

lemma trunc_le.is_iso_ι_f (n i : ℤ) (hi : i < n) :
  is_iso (trunc_le.ι_f K n i) :=
begin
  dsimp [trunc_le.ι_f],
  simp only [dif_neg (show ¬ n < i, by linarith),
    dif_neg (show i ≠ n, by linarith)],
  apply_instance,
end

lemma trunc_le.ι_f_eq_zero (n i : ℤ) (hi : n < i) :
  trunc_le.ι_f K n i = 0 :=
by { dsimp [trunc_le.ι_f], rw [dif_pos hi], }

lemma trunc_le.ι_f_eq_of_eq (n i : ℤ) (hn : i = n) :
  trunc_le.ι_f K n i = (trunc_le.X_iso_cycles K n i hn).hom ≫ (K.sc' i).cycles_i :=
by { dsimp [trunc_le.ι_f], rw [dif_neg (show ¬n<i, by linarith), dif_pos hn], }

lemma trunc_le.ι_f_eq_X_iso_X_inv (n i : ℤ) (hi : i < n) :
  trunc_le.ι_f K n i = (trunc_le.X_iso_X K n i hi).hom :=
by { dsimp [trunc_le.ι_f], rw [dif_neg, dif_neg]; linarith, }

lemma trunc_le.shape (n i j : ℤ) (hij : i+1 ≠ j) : trunc_le.d K n i j = 0 :=
by { dsimp only [trunc_le.d], rw dif_neg hij, }

lemma trunc_le.d_eq_zero (n : ℤ) (i j : ℤ) (hj : n ≤ i) :
  trunc_le.d K n i j = 0 :=
begin
  by_cases hij : i+1 = j,
  { dsimp [trunc_le.d],
    rw [dif_pos hij, dif_pos],
    linarith, },
  { rw trunc_le.shape K n i j hij, },
end

lemma trunc_le.d_eq_d (n : ℤ) (i j : ℤ) (hij : i + 1 = j) (hj : j < n) :
  trunc_le.d K n i j = (trunc_le.X_iso_X K n i
    (by { rw ← hij at hj, exact (lt_add_one i).trans hj, })).hom ≫ K.d i j ≫
    (trunc_le.X_iso_X K n j hj).inv :=
by { dsimp [trunc_le.d], rw [dif_pos hij, dif_neg, dif_neg]; linarith, }

lemma trunc_le.ι_comp_d_eq_zero (n : ℤ) (i j : ℤ) (hij : i + 1 = j) (hi : i = n) :
   trunc_le.ι_f K n i ≫ K.d i j = 0 :=
begin
  have hj : j = (complex_shape.up ℤ).next i := by { rw [next], linarith, },
  subst hj,
  dsimp [trunc_le.ι_f],
  erw [dif_neg (show ¬n<i, by linarith), dif_pos hi, assoc, (K.sc' i).cycles_i_g, comp_zero],
end

def trunc_le.ι_is_kernel (n i j : ℤ) (hij : i + 1 = j) (hi : i = n) :
  is_limit (kernel_fork.of_ι _ (trunc_le.ι_comp_d_eq_zero K n i j hij hi)) :=
begin
  have hij' : j = (complex_shape.up ℤ).next i := by { rw [next], linarith, },
  subst hij',
  exact is_limit.of_iso_limit (K.sc' i).cycles_is_kernel
    (iso.symm (fork.ext (trunc_le.X_iso_cycles K n i hi)
      (trunc_le.ι_f_eq_of_eq K n i hi).symm)),
end

@[simp, reassoc]
lemma trunc_le.d_comm (n i j : ℤ) :
  trunc_le.d K n i j ≫ trunc_le.ι_f K n j =
     trunc_le.ι_f K n i ≫ K.d i j :=
begin
  by_cases hij : i+1 = j,
  { by_cases hi₀ : n < i,
    { apply (trunc_le.is_zero_X K n i hi₀).eq_of_src, },
    by_cases hi : i = n,
    { simp only [trunc_le.ι_comp_d_eq_zero K n i j hij hi,
        trunc_le.d_eq_zero K n i j (by linarith), zero_comp], },
    by_cases hj : j = n,
    { dsimp [trunc_le.d, trunc_le.ι_f],
      simp only [dif_pos hij, dif_neg (show ¬ n < j, by linarith), dif_pos hj, dif_neg hi₀,
        dif_neg hi, assoc, iso.inv_hom_id_assoc, short_complex.lift_cycles_i], },
    { have hj' : j < n,
      { subst hij,
        cases (not_lt.1 hi₀).lt_or_eq,
        { rw lt_iff_le_and_ne,
          split,
          { linarith, },
          { exact hj, }, },
        { exfalso, exact hi h, }, },
      simp only [trunc_le.d_eq_d K n i j hij hj', trunc_le.ι_f_eq_X_iso_X_inv K n j hj', assoc,
        iso.inv_hom_id, comp_id, trunc_le.ι_f_eq_X_iso_X_inv K n i (by linarith)], }, },
  { rw [trunc_le.shape K n i j hij, K.shape i j hij, zero_comp, comp_zero], },
end

@[simp, reassoc]
lemma trunc_le.d_comp_d (n i j k : ℤ) : trunc_le.d K n i j ≫ trunc_le.d K n j k = 0 :=
by simp only [← cancel_mono (trunc_le.ι_f K n k), assoc, trunc_le.d_comm,
    trunc_le.d_comm_assoc, K.d_comp_d, zero_comp, comp_zero]

@[simps]
def trunc_le (n : ℤ) : cochain_complex C ℤ :=
{ X := trunc_le.X K n,
  d := trunc_le.d K n,
  shape' := trunc_le.shape K n,
  d_comp_d' := λ i j k hij hjk, trunc_le.d_comp_d K n i j k, }

@[simps]
def trunc_le.ι (n : ℤ) : K.trunc_le n ⟶ K :=
{ f := trunc_le.ι_f K n,
  comm' := λ i j hij, (trunc_le.d_comm K n i j).symm, }

variables {K L}

def trunc_le.map_f (φ : K ⟶ L) (n i : ℤ) :
  (K.trunc_le n).X i ⟶ (L.trunc_le n).X i :=
begin
  by_cases hi : i < n,
  { exact (trunc_le.X_iso_X K n i hi).hom ≫ φ.f i ≫
    (trunc_le.X_iso_X L n i hi).inv, },
  { by_cases hn : i = n,
    { exact (trunc_le.X_iso_cycles K n i hn).hom ≫
        (homological_complex.short_complex_functor C (complex_shape.up ℤ) i ⋙
        short_complex.cycles_functor C).map φ≫ (trunc_le.X_iso_cycles L n i hn).inv, },
    { exact 0, }, },
end

lemma trunc_le.map_f_eq_f (φ : K ⟶ L) (n i : ℤ) (hi : i < n) :
  trunc_le.map_f φ n i = (trunc_le.X_iso_X K n i hi).hom ≫ φ.f i ≫
    (trunc_le.X_iso_X L n i hi).inv :=
begin
  dsimp only [trunc_le.map_f],
  simp only [dif_pos hi],
end

@[simp, reassoc]
lemma trunc_le.map_f_comm_ι_f (φ : K ⟶ L) (n i : ℤ) :
  trunc_le.map_f φ n i ≫ trunc_le.ι_f L n i =
    trunc_le.ι_f K n i ≫ φ.f i :=
begin
  by_cases hi : i < n,
  { simp only [trunc_le.ι_f_eq_X_iso_X_inv _ n i hi, trunc_le.map_f_eq_f φ n i hi, assoc,
      iso.inv_hom_id, comp_id], },
  { by_cases hn : i = n,
    { dsimp [trunc_le.map_f, trunc_ge.π_f],
      simp only [dif_neg hi, dif_pos hn, assoc, iso.inv_hom_id_assoc,
        trunc_le.ι_f_eq_of_eq _ n i hn],
      erw (short_complex.cycles_i_nat_trans C).naturality
        ((homological_complex.short_complex_functor C (complex_shape.up ℤ) i).map φ),
      refl,   },
    { refine (trunc_le.is_zero_X K n i _).eq_of_src _ _,
      cases (not_lt.1 hi).lt_or_eq,
      { exact h, },
      { exfalso, exact hn h.symm, }, }, },
end

@[reassoc]
lemma trunc_le.map_comm_f (φ : K ⟶ L) (n i j : ℤ) :
  trunc_le.map_f φ n i ≫ trunc_le.d L n i j =
    trunc_le.d K n i j ≫ trunc_le.map_f φ n j :=
by simp only [← cancel_mono (trunc_le.ι_f L n j), assoc, trunc_le.d_comm,
    trunc_le.map_f_comm_ι_f_assoc, homological_complex.hom.comm, trunc_le.map_f_comm_ι_f,
    trunc_le.d_comm_assoc]

@[simp]
lemma trunc_le.map_id_f (K : cochain_complex C ℤ) (n i : ℤ) :
  trunc_le.map_f (𝟙 K) n i = 𝟙 _ :=
by simp only [← cancel_mono (trunc_le.ι_f K n i),
  trunc_le.map_f_comm_ι_f, homological_complex.id_f, comp_id, id_comp]

@[simp]
lemma trunc_le.map_comp_f {K L M : cochain_complex C ℤ}
  (φ : K ⟶ L) (φ' : L ⟶ M) (n i : ℤ) :
  trunc_le.map_f (φ ≫ φ') n i =
    trunc_le.map_f φ n i ≫ trunc_le.map_f φ' n i :=
by simp only [← cancel_mono (trunc_le.ι_f M n i),
  trunc_le.map_f_comm_ι_f, homological_complex.comp_f, assoc, trunc_le.map_f_comm_ι_f_assoc]

variable (C)

@[simps]
def trunc_le_functor (n : ℤ) :
  cochain_complex C ℤ ⥤ cochain_complex C ℤ :=
{ obj := λ K, K.trunc_le n,
  map := λ K L φ,
  { f := λ i, trunc_le.map_f φ n i,
    comm' := λ i j hij, trunc_le.map_comm_f φ n i j, }, }

@[simps]
def trunc_le.nat_trans_ι (n : ℤ) :
  trunc_le_functor C n ⟶ 𝟭 _ :=
{ app := λ K, trunc_le.ι K n,
  naturality' := λ K L φ, begin
    ext i
    dsimp,
    simp only [functor.id_map, homological_complex.comp_f, trunc_le_functor_map_f],
    dsimp,
    simp only [trunc_le.map_f_comm_ι_f],
  end, }

variables {C} (K)

lemma trunc_le.is_zero_homology (n i : ℤ) (hi : n < i) :
  is_zero ((homology_functor C _ i).obj (K.trunc_le n)) :=
begin
  dsimp [homology_functor],
  rw ← short_complex.exact_iff_is_zero_homology,
  exact short_complex.exact.of_is_zero_X₂ _ (trunc_le.is_zero_X K n i hi),
end

lemma trunc_le.is_iso_homology_map_ι (n i : ℤ) (hi : i ≤ n) :
  is_iso ((homology_functor C _ i).map (trunc_le.ι K n)) :=
begin
  let φ := (homological_complex.short_complex_functor C (complex_shape.up ℤ) i).map
    (trunc_le.ι K n),
  haveI : is_iso φ.τ₁ := trunc_le.is_iso_ι_f K n _ (by { rw [prev], linarith, }),
  cases hi.lt_or_eq,
  { haveI : mono φ.τ₃ := by { dsimp, apply_instance, },
    haveI : is_iso φ.τ₂ := trunc_le.is_iso_ι_f K n i h,
    exact short_complex.quasi_iso.of_epi_of_is_iso_of_mono φ, },
  { exact category_theory.short_complex.quasi_iso.of_kernel_fork φ
    ((trunc_le.is_zero_X K n _ (by { rw [next], linarith, })).eq_of_tgt _ _)
      (trunc_le.ι_is_kernel K n i _ (by { rw [next], }) h), },
end

variables {K L}

lemma trunc_le.map_homology_iso (φ : K ⟶ L) (n i : ℤ) [is_iso (homology_map φ i)] :
  is_iso (homology_map ((trunc_le_functor C n).map φ) i) :=
begin
  by_cases hi : i ≤ n,
  { have eq := (homology_functor C _ i).congr_map ((trunc_le.nat_trans_ι C n).naturality φ),
    simp only [functor.map_comp, functor.id_map, trunc_le.nat_trans_ι_app] at eq,
    change homology_map _ i ≫ homology_map (trunc_le.ι L n) i =
      homology_map (trunc_le.ι K n) i ≫ homology_map φ i at eq,
    haveI : ∀ (M : cochain_complex C ℤ), is_iso (homology_map (trunc_le.ι M n) i) :=
      λ M, trunc_le.is_iso_homology_map_ι M n i hi,
    simp only [← cancel_mono (inv (homology_map (trunc_le.ι L n) i)),
      assoc, is_iso.hom_inv_id, comp_id] at eq,
    rw eq,
    apply_instance, },
  { simp only [not_le] at hi,
    exact ⟨⟨0, (trunc_le.is_zero_homology K n i hi).eq_of_src _ _,
       (trunc_le.is_zero_homology L n i hi).eq_of_src _ _⟩⟩, },
end

instance trunc_le.map_quasi_iso (φ : K ⟶ L) (n : ℤ) [quasi_iso φ] :
  quasi_iso ((trunc_le_functor _ n).map φ) :=
⟨λ i, trunc_le.map_homology_iso φ n i⟩

variable (C)

lemma trunc_le_functor_comp_Q_inverts_quasi_isomorphisms (n : ℤ) :
  (quasi_isomorphisms _ _).is_inverted_by
    (cochain_complex.trunc_le_functor C n ⋙ derived_category.Q) :=
λ K L φ hφ, begin
  haveI : quasi_iso φ := by simpa only [← mem_quasi_isomorphisms_iff] using hφ,
  dsimp,
  apply_instance,
end

variable {C}

class is_strictly_le (K : cochain_complex C ℤ) (n : ℤ) : Prop :=
(is_zero' : ∀ (i : ℤ) (hi : n < i), is_zero (K.X i))

lemma is_strictly_le.is_zero (K : cochain_complex C ℤ) (n i : ℤ) [K.is_strictly_le n]
  (hi : n < i) : is_zero (K.X i) :=
is_strictly_le.is_zero' i hi

lemma is_strictly_le_of_le (K : cochain_complex C ℤ) (n m : ℤ) (hnm : n ≤ m)
  [K.is_strictly_le n] :
  K.is_strictly_le m :=
⟨λ i hi, is_strictly_le.is_zero K n i (by linarith)⟩

lemma is_strictly_le.of_iso {K L : cochain_complex C ℤ} (e : K ≅ L) (n : ℤ)
  [K.is_strictly_le n] : L.is_strictly_le n :=
⟨λ i hi, is_zero.of_iso (is_strictly_le.is_zero K n i hi)
  ((homological_complex.eval _ _ i).map_iso e.symm)⟩

lemma is_strictly_le.iff_of_iso {K L : cochain_complex C ℤ} (e : K ≅ L) (n : ℤ) :
  K.is_strictly_le n ↔ L.is_strictly_le n :=
begin
  split,
  { introI,
    exact is_strictly_le.of_iso e n, },
  { introI,
    exact is_strictly_le.of_iso e.symm n, },
end

class is_le (K : cochain_complex C ℤ) (n : ℤ) : Prop :=
(is_zero' : ∀ (i : ℤ) (hi : n < i), is_zero (K.homology i))

lemma is_le.is_zero (K : cochain_complex C ℤ) (n i : ℤ) [K.is_le n] (hi : n < i) :
  is_zero (K.homology i) :=
is_le.is_zero' i hi

lemma is_le_of_le (K : cochain_complex C ℤ) (n m : ℤ) (hnm : n ≤ m) [K.is_le n] : K.is_le m :=
⟨λ i hi, is_le.is_zero K n i (by linarith)⟩

lemma is_le.of_iso {K L : cochain_complex C ℤ} (e : K ≅ L) (n : ℤ) [K.is_le n] : L.is_le n :=
⟨λ i hi, is_zero.of_iso (is_le.is_zero K n i hi) ((homology_functor _ _ i).map_iso e.symm)⟩

lemma is_le.iff_of_iso {K L : cochain_complex C ℤ} (e : K ≅ L) (n : ℤ) :
  K.is_le n ↔ L.is_le n :=
begin
  split,
  { introI,
    exact is_le.of_iso e n, },
  { introI,
    exact is_le.of_iso e.symm n, },
end

@[priority 100]
instance is_le_of_is_strictly_le (K : cochain_complex C ℤ) (n : ℤ)
  [K.is_strictly_le n] : K.is_le n :=
⟨λ i hi, begin
  rw ← short_complex.exact_iff_is_zero_homology,
  exact short_complex.exact.of_is_zero_X₂ _ (is_strictly_le.is_zero K n i hi),
end⟩

instance trunc_le_is_strictly_le (K : cochain_complex C ℤ) (n : ℤ) :
  (K.trunc_le n).is_strictly_le n :=
⟨trunc_le.is_zero_X K n⟩

instance trunc_le_is_strictly_le' (K : cochain_complex C ℤ) (n : ℤ) :
  ((trunc_le_functor C n).obj K).is_strictly_le n :=
(infer_instance : (K.trunc_le n).is_strictly_le n)

lemma trunc_le.is_iso_ι_f_iff_d_eq_zero (K : cochain_complex C ℤ) (n i j : ℤ)
  (hij : i+1 = j) (hi : i = n) :
  is_iso ((trunc_le.ι K n).f i) ↔ K.d i j = 0 :=
begin
  split,
  { intro h,
    haveI : is_iso (trunc_le.ι_f K n i) := h,
    simp only [← cancel_epi (trunc_le.ι_f K n i),
      trunc_le.ι_comp_d_eq_zero K n i j hij hi, comp_zero], },
  { exact kernel_fork.is_limit.is_iso_ι_of_zero _ (trunc_le.ι_is_kernel K n i j hij hi), },
end

instance (K : cochain_complex C ℤ) (n : ℤ) [K.is_strictly_le n] :
  is_iso (trunc_le.ι K n) :=
begin
  haveI : ∀ (i : ℤ), is_iso ((trunc_le.ι K n).f i),
  { intro i,
    by_cases hi : i < n,
    { exact trunc_le.is_iso_ι_f K n i hi, },
    { cases (not_lt.1 hi).lt_or_eq,
      { refine ⟨⟨0, _, (is_strictly_le.is_zero K n i h).eq_of_tgt _ _⟩⟩,
        rw ← cancel_mono (trunc_le.ι_f K n i),
        apply (is_strictly_le.is_zero K n i h).eq_of_tgt, },
      { rw trunc_le.is_iso_ι_f_iff_d_eq_zero K n i (i+1) (by linarith) h.symm,
        apply (is_strictly_le.is_zero K n (i+1) (by linarith)).eq_of_tgt, }, }, },
  apply homological_complex.hom.is_iso_of_components,
end

end cochain_complex

namespace derived_category

variable (C)

def trunc_le_functor (n : ℤ) : derived_category C ⥤ derived_category C :=
localization.lift _ (cochain_complex.trunc_le_functor_comp_Q_inverts_quasi_isomorphisms C n) Q

instance (n : ℤ) : localization.lifting Q (quasi_isomorphisms _ _)
  (cochain_complex.trunc_le_functor C n ⋙ derived_category.Q) (trunc_le_functor C n) :=
localization.lifting_lift _ _ _

def trunc_le_functor_iso (n : ℤ) :
  Q ⋙ trunc_le_functor C n ≅ (cochain_complex.trunc_le_functor C n ⋙ derived_category.Q) :=
localization.lifting.iso _ (quasi_isomorphisms _ _) _ _

def trunc_le_nat_trans_ι (n : ℤ) : trunc_le_functor C n ⟶ 𝟭 (derived_category C) :=
localization.lift_nat_trans Q (quasi_isomorphisms _ _)
  (cochain_complex.trunc_le_functor C n ⋙ derived_category.Q) Q _ _
  (whisker_right (cochain_complex.trunc_le.nat_trans_ι C n) Q)

@[simp]
lemma trunc_le_nat_trans_ι_app (K : cochain_complex C ℤ) (n : ℤ) :
  (trunc_le_nat_trans_ι C n).app (Q.obj K) =
    (trunc_le_functor_iso C n).hom.app K ≫ Q.map (cochain_complex.trunc_le.ι K n) :=
begin
  dsimp only [trunc_le_nat_trans_ι, trunc_le_functor_iso],
  simp only [localization.lift_nat_trans_app, whisker_right_app,
    cochain_complex.trunc_le.nat_trans_ι_app,
    localization.lifting.id_iso, functor.right_unitor_inv_app, comp_id],
end

variable {C}

class is_le (K : derived_category C) (n : ℤ) : Prop :=
(is_zero' : ∀ (i : ℤ) (hi : n < i), is_zero (K.homology i))

lemma is_le.is_zero (K : derived_category C) (n i : ℤ) [K.is_le n]
  (hi : n < i) : is_zero (K.homology i) :=
is_le.is_zero' i hi

lemma is_le_of_le (K : derived_category C) (n m : ℤ) (hnm : n ≤ m) [K.is_le n] : K.is_le m :=
⟨λ i hi, is_le.is_zero K n i (by linarith)⟩

lemma is_le.of_iso {K L : derived_category C} (e : K ≅ L) (n : ℤ) [K.is_le n] : L.is_le n :=
⟨λ i hi, is_zero.of_iso (is_le.is_zero K n i hi) ((homology_functor _ i).map_iso e.symm)⟩

lemma is_le.iff_of_iso {K L : derived_category C} (e : K ≅ L) (n : ℤ) :
  K.is_le n ↔ L.is_le n :=
begin
  split,
  { introI,
    exact is_le.of_iso e n, },
  { introI,
    exact is_le.of_iso e.symm n, },
end

variable (C)

def Q_comp_trunc_le_functor_comp_homology_functor_iso (n i : ℤ) :
  Q ⋙ trunc_le_functor C n ⋙ homology_functor C i ≅
    cochain_complex.trunc_le_functor C n ⋙ _root_.homology_functor _ _ i :=
(functor.associator _ _ _).symm ≪≫
  iso_whisker_right (trunc_le_functor_iso C n) (homology_functor C i) ≪≫
  functor.associator _ _ _ ≪≫ iso_whisker_left _ (homology_functor_factors C i)

variable {C}

lemma is_zero_homology_trunc_le_of_lt (K : derived_category C) (n i : ℤ) (hi : n < i) :
  is_zero (((trunc_le_functor C n).obj K).homology i) :=
is_zero.of_iso (cochain_complex.is_le.is_zero _ n i hi)
  (((trunc_le_functor C n ⋙ homology_functor C i).map_iso (Q.obj_obj_preimage_iso K)).symm ≪≫
    ((Q_comp_trunc_le_functor_comp_homology_functor_iso C n i).app _))

lemma is_iso_homology_map_trunc_le_nat_trans_ι_of_le (K : derived_category C) (n i : ℤ)
  (hi : i ≤ n) :
  is_iso ((homology_functor C i).map ((trunc_le_nat_trans_ι C n).app K)) :=
begin
  erw ← (Q.obj_obj_preimage_iso K).is_iso_app_iff
    (whisker_right (trunc_le_nat_trans_ι C n) (homology_functor C i)),
  dsimp,
  erw [trunc_le_nat_trans_ι_app, functor.map_comp],
  haveI : ∀ (L : cochain_complex C ℤ), is_iso ((homology_functor C i).map (Q.map
    (cochain_complex.trunc_le.ι L n))),
  { intro L,
    erw nat_iso.is_iso_map_iff (homology_functor_factors C i),
    exact cochain_complex.trunc_le.is_iso_homology_map_ι L n i hi, },
  apply_instance,
end

lemma is_iso_trunc_le_nat_trans_ι_app_iff (K : derived_category C) (n : ℤ) :
  is_iso ((trunc_le_nat_trans_ι C n).app K) ↔ K.is_le n :=
begin
  rw is_iso_iff_is_iso_homology,
  split,
  { introI hK,
    exact ⟨λ i hi, is_zero.of_iso (is_zero_homology_trunc_le_of_lt K n i hi)
      (as_iso ((homology_functor C i).map ((trunc_le_nat_trans_ι C n).app K))).symm⟩, },
  { introI,
    intro i,
    by_cases hi : i ≤ n,
    { exact is_iso_homology_map_trunc_le_nat_trans_ι_of_le K n i hi, },
    { simp only [not_le] at hi,
      exact ⟨⟨0, (is_zero_homology_trunc_le_of_lt K n i hi).eq_of_src _ _,
        (is_le.is_zero K n i hi).eq_of_src _ _⟩⟩, }, },
end

instance is_iso_trunc_le_nat_trans_ι_of_le (K : derived_category C) (n : ℤ) [K.is_le n] :
  is_iso ((trunc_le_nat_trans_ι C n).app K) :=
by { rw is_iso_trunc_le_nat_trans_ι_app_iff, apply_instance, }

end derived_category

namespace cochain_complex

lemma is_le_iff_Q_obj_is_le (K : cochain_complex C ℤ) (n : ℤ) :
  K.is_le n ↔ (derived_category.Q.obj K).is_le n :=
begin
  split,
  { introI,
    exact ⟨λ i hi, by simpa only [← is_zero_homology_iff_is_zero_homology_Q_obj]
      using is_le.is_zero K n i hi⟩, },
  { introI,
    exact ⟨λ i hi, by simpa only [is_zero_homology_iff_is_zero_homology_Q_obj]
      using derived_category.is_le.is_zero (derived_category.Q.obj _) n i hi⟩, },
end

instance Q_obj_is_le_of_is_le (K : cochain_complex C ℤ) (n : ℤ) [K.is_le n] :
  (derived_category.Q.obj K).is_le n :=
begin
  rw ← is_le_iff_Q_obj_is_le,
  apply_instance,
end

lemma is_le_iff_of_quasi_iso {K L : cochain_complex C ℤ} (φ : K ⟶ L) [quasi_iso φ] (n : ℤ) :
  K.is_le n ↔ L.is_le n :=
begin
  simp only [is_le_iff_Q_obj_is_le],
  exact derived_category.is_le.iff_of_iso (as_iso (derived_category.Q.map φ)) n,
end

lemma quasi_iso_trunc_le_ι_iff (K : cochain_complex C ℤ) (n : ℤ) :
  quasi_iso (trunc_le.ι K n) ↔ K.is_le n :=
begin
  rw [is_le_iff_Q_obj_is_le, ← derived_category.is_iso_Q_map_iff,
    ← derived_category.is_iso_trunc_le_nat_trans_ι_app_iff,
    derived_category.trunc_le_nat_trans_ι_app],
  split,
  { introI,
    apply_instance, },
  { apply is_iso.of_is_iso_comp_left, },
end

instance (K : cochain_complex C ℤ) (n : ℤ) [K.is_le n] :
  quasi_iso (trunc_le.ι K n) :=
by { rw quasi_iso_trunc_le_ι_iff, apply_instance, }

end cochain_complex

namespace derived_category

lemma right_factorisation_of_is_le {K L : cochain_complex C ℤ} (φ : Q.obj K ⟶ Q.obj L) (n : ℤ)
  [K.is_le n] :
  ∃ (K' : cochain_complex C ℤ) (hK' : K'.is_strictly_le n) (s : K' ⟶ K) (f : K' ⟶ L) (hs : quasi_iso s),
    φ = (by { haveI := hs, exact inv (Q.map s), }) ≫ Q.map f :=
begin
  obtain ⟨K', s, f, hs, eq⟩ := right_factorisation φ,
  haveI := hs,
  haveI : quasi_iso ((cochain_complex.trunc_le.nat_trans_ι C n).app K'),
  { erw cochain_complex.quasi_iso_trunc_le_ι_iff,
    dsimp,
    rw cochain_complex.is_le_iff_of_quasi_iso s,
    apply_instance, },
  exact ⟨_, infer_instance,
    (cochain_complex.trunc_le.nat_trans_ι _ n).app K' ≫ s,
    (cochain_complex.trunc_le.nat_trans_ι _ n).app K' ≫ f, infer_instance,
    by simp only [eq, functor.map_comp, is_iso.eq_inv_comp, assoc, is_iso.hom_inv_id_assoc]⟩,
end

lemma left_factorisation_of_is_strictly_le {K L : cochain_complex C ℤ} (φ : Q.obj K ⟶ Q.obj L)
  (n : ℤ) [K.is_strictly_le n] [L.is_strictly_le n] :
  ∃ (L' : cochain_complex C ℤ) (hL' : L'.is_strictly_le n) (f : K ⟶ L') (s : L ⟶ L') (hs : quasi_iso s),
    φ = Q.map f ≫ (by { haveI := hs, exact inv (Q.map s), }) :=
begin
  obtain ⟨L', f, s, hs, eq⟩ := left_factorisation φ,
  haveI := hs,
  haveI : quasi_iso (cochain_complex.trunc_le.ι L' n),
  { rw [cochain_complex.quasi_iso_trunc_le_ι_iff, ← cochain_complex.is_le_iff_of_quasi_iso s],
    apply_instance, },
  refine ⟨_, infer_instance,
    category_theory.inv (cochain_complex.trunc_le.ι K n) ≫
      (cochain_complex.trunc_le_functor C n).map f,
    category_theory.inv (cochain_complex.trunc_le.ι L n) ≫
    (cochain_complex.trunc_le_functor C n).map s, infer_instance, _⟩,
  have comms := Q.congr_map ((cochain_complex.trunc_le.nat_trans_ι C n).naturality s),
  have commf := Q.congr_map ((cochain_complex.trunc_le.nat_trans_ι C n).naturality f),
  dsimp at comms commf,
  simp only [Q.map_comp, ← cancel_mono (inv (Q.map ((cochain_complex.trunc_le.ι L' n)))),
    assoc, is_iso.hom_inv_id, comp_id] at comms commf,
  simp only [comms, commf, eq, functor.map_comp, functor.map_inv, is_iso.inv_hom_id_assoc,
    is_iso.inv_comp, is_iso.inv_inv, assoc],
end

lemma exists_iso_Q_obj_of_le (K : derived_category C) (n : ℤ) [K.is_le n] :
  ∃ (K' : cochain_complex C ℤ) (hK' : K'.is_strictly_le n),
    nonempty (K ≅ Q.obj K') :=
begin
  let K' := Q.obj_preimage K,
  haveI : K'.is_le n,
  { rw [cochain_complex.is_le_iff_Q_obj_is_le, is_le.iff_of_iso (Q.obj_obj_preimage_iso K)],
    apply_instance, },
  exact ⟨K'.trunc_le n, infer_instance, ⟨(Q.obj_obj_preimage_iso K).symm ≪≫
    (as_iso ((trunc_le_nat_trans_ι C n).app (Q.obj K'))).symm ≪≫
    (trunc_le_functor_iso C n).app K'⟩⟩,
end

end derived_category


/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison
-/
import category_theory.monoidal.of_chosen_finite_products
import category_theory.limits.shapes.finite_products
import category_theory.limits.shapes.types

/-!
# The category of types is a symmetric monoidal category
-/

open category_theory
open category_theory.limits
open tactic

universes v u

namespace category_theory

instance types_monoidal : monoidal_category.{u} (Type u) :=
monoidal_of_chosen_finite_products (types.terminal_limit_cone) (types.binary_product_limit_cone)

instance types_symmetric : symmetric_category.{u} (Type u) :=
symmetric_of_chosen_finite_products (types.terminal_limit_cone) (types.binary_product_limit_cone)

@[simp] lemma tensor_apply {W X Y Z : Type u} (f : W ⟶ X) (g : Y ⟶ Z) (p : W ⊗ Y) :
  (f ⊗ g) p = (f p.1, g p.2) := rfl

@[simp] lemma left_unitor_hom_apply {X : Type u} {x : X} {p : punit} :
  ((λ_ X).hom : (𝟙_ (Type u)) ⊗ X → X) (p, x) = x := rfl
@[simp] lemma left_unitor_inv_apply {X : Type u} {x : X} :
  ((λ_ X).inv : X ⟶ (𝟙_ (Type u)) ⊗ X) x = (punit.star, x) := rfl

@[simp] lemma right_unitor_hom_apply {X : Type u} {x : X} {p : punit} :
  ((ρ_ X).hom : X ⊗ (𝟙_ (Type u)) → X) (x, p) = x := rfl
@[simp] lemma right_unitor_inv_apply {X : Type u} {x : X} :
  ((ρ_ X).inv : X ⟶ X ⊗ (𝟙_ (Type u))) x = (x, punit.star) := rfl

@[simp] lemma associator_hom_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
  ((α_ X Y Z).hom : (X ⊗ Y) ⊗ Z → X ⊗ (Y ⊗ Z)) ((x, y), z) = (x, (y, z)) := rfl
@[simp] lemma associator_inv_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
  ((α_ X Y Z).inv : X ⊗ (Y ⊗ Z) → (X ⊗ Y) ⊗ Z) (x, (y, z)) = ((x, y), z) := rfl

@[simp] lemma braiding_hom_apply {X Y : Type u} {x : X} {y : Y} :
  ((β_ X Y).hom : X ⊗ Y → Y ⊗ X) (x, y) = (y, x) := rfl
@[simp] lemma braiding_inv_apply {X Y : Type u} {x : X} {y : Y} :
  ((β_ X Y).inv : Y ⊗ X → X ⊗ Y) (y, x) = (x, y) := rfl

open opposite

open monoidal_category

/-- `(𝟙_ C ⟶ -)` is a lax monoidal functor to `Type`. -/
def coyoneda_tensor_unit (C : Type u) [category.{v} C] [monoidal_category C] :
  lax_monoidal_functor C (Type v) :=
{ ε := λ p, 𝟙 _,
  μ := λ X Y p, (λ_ (𝟙_ C)).inv ≫ (p.1 ⊗ p.2),
  μ_natural' := by tidy,
  associativity' := λ X Y Z, begin
    ext ⟨⟨f, g⟩, h⟩, dsimp at f g h,
    dsimp, simp only [iso.cancel_iso_inv_left, category.assoc],
    conv_lhs { rw [←category.id_comp h, tensor_comp, category.assoc, associator_naturality,
      ←category.assoc, unitors_inv_equal, triangle_assoc_comp_right_inv], },
    conv_rhs { rw [←category.id_comp f, tensor_comp], },
  end,
  left_unitality' := by tidy,
  right_unitality' := λ X, begin
    ext ⟨f, ⟨⟩⟩, dsimp at f,
    dsimp, simp only [category.assoc],
    rw [right_unitor_naturality, unitors_inv_equal, iso.inv_hom_id_assoc],
  end,
  ..coyoneda.obj (op (𝟙_ C)) }

end category_theory