import for_mathlib.category_theory.localization.equivalence
import category_theory.products.basic
import for_mathlib.category_theory.functor_misc
import for_mathlib.category_theory.finite_products

noncomputable theory

universes v v' u u'

namespace category_theory

open category

@[simp]
lemma prod.eq_to_hom_fst {C₁ C₂ : Type*} [category C₁] [category C₂]
  {X Y : C₁ × C₂} (eq : X = Y) : (eq_to_hom eq : X ⟶ Y).fst = eq_to_hom (by rw eq) :=
by { subst eq, refl, }

@[simp]
lemma prod.eq_to_hom_snd {C₁ C₂ : Type*} [category C₁] [category C₂]
  {X Y : C₁ × C₂} (eq : X = Y) : (eq_to_hom eq : X ⟶ Y).snd = eq_to_hom (by rw eq) :=
by { subst eq, refl, }

lemma functor.prod.ext {C₁ C₂ E : Type*} [category C₁] [category C₂] [category E]
  {F₁ F₂ : E ⥤ C₁ × C₂} (h₁ : F₁ ⋙ prod.fst _ _ = F₂ ⋙ prod.fst _ _)
  (h₂ : F₁ ⋙ prod.snd _ _ = F₂ ⋙ prod.snd _ _) : F₁ = F₂ :=
begin
  refine functor.ext (λ X, _) (λ X Y f, _),
  { ext,
    exacts [functor.congr_obj h₁ X, functor.congr_obj h₂ X], },
  { ext,
    { simpa only [prod_comp_fst, prod.eq_to_hom_fst] using functor.congr_map_conjugate h₁ f, },
    { simpa only [prod_comp_snd, prod.eq_to_hom_snd] using functor.congr_map_conjugate h₂ f, }, },
end

lemma functor.is_localization.of_is_equivalence {C D : Type*} [category C] [category D]
  (F : C ⥤ D) [is_equivalence F] (W : morphism_property C)
  (hF : W ⊆ morphism_property.isomorphisms C) : F.is_localization W :=
begin
  haveI := localization.id_is_localization W hF,
  exact functor.is_localization.of_equivalence (𝟭 C) W F F.as_equivalence F.left_unitor,
end

lemma morphism_property.of_arrow_eq {C : Type*} [category C] (W : morphism_property C)
  (f₁ f₂ : arrow C) (hf₂ : W f₂.hom) (eq : f₁ = f₂) : W f₁.hom := by { subst eq, exact hf₂, }

lemma morphism_property.of_arrow_mk_eq {C : Type*} [category C] (W : morphism_property C)
  {X₁ Y₁ X₂ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (hf₂ : W f₂) (eq : arrow.mk f₁ = arrow.mk f₂) :
  W f₁ :=
W.of_arrow_eq (arrow.mk f₁) (arrow.mk f₂) hf₂ eq

lemma functor.congr_map_arrow_obj_arrow_mk {C D : Type*} [category C] [category D]
  {F₁ F₂ : C ⥤ D} (eq : F₁ = F₂) {X Y : C} (f : X ⟶ Y) :
  F₁.map_arrow.obj (arrow.mk f) = F₂.map_arrow.obj (arrow.mk f) := by subst eq

section

variables {C₁ D₁ C₂ D₂ : Type*} [category C₁] [category C₂] [category D₁] [category D₂]
  (W₁ : morphism_property C₁) (W₂ : morphism_property C₂) {E : Type*} [category E]

@[simps]
def nat_iso.prod {F F' : C₁ ⥤ D₁} {G G' : C₂ ⥤ D₂} (α : F ≅ F') (β : G ≅ G') :
  F.prod G ≅ F'.prod G' :=
{ hom := α.hom.prod β.hom,
  inv := α.inv.prod β.inv, }

namespace equivalence

def prod (E₁ : C₁ ≌ D₁) (E₂ : C₂ ≌ D₂) : C₁ × C₂ ≌ D₁ × D₂ :=
{ functor := E₁.functor.prod E₂.functor,
  inverse := E₁.inverse.prod E₂.inverse,
  unit_iso := ((functor_prod_functor_equiv (C₁ × C₂) C₁ C₂).counit_iso.app (𝟭 _)).symm
      ≪≫ nat_iso.prod E₁.unit_iso E₂.unit_iso,
  counit_iso := nat_iso.prod E₁.counit_iso E₂.counit_iso ≪≫
      ((functor_prod_functor_equiv (D₁ × D₂) D₁ D₂).counit_iso.app (𝟭 _)), }

end equivalence

namespace functor

@[simps]
def prod_functor : (C₁ ⥤ D₁) × (C₂ ⥤ D₂) ⥤ (C₁ × C₂) ⥤ (D₁ × D₂) :=
{ obj := λ F, F.1.prod F.2,
  map := λ F G φ, φ.1.prod φ.2, }

lemma flip_flip (H : D₁ ⥤ D₂ ⥤ E) : H.flip.flip = H :=
functor.ext (λ X₁, (functor.ext (λ X₂, rfl) (by tidy))) (by tidy)

lemma comp_comp_curry_flip_flip_eq_curry (H : D₁ × D₂ ⥤ E) (F₁ : C₁ ⥤ D₁) (F₂ : C₂ ⥤ D₂) :
  F₁ ⋙ (F₂ ⋙ (curry.obj H).flip).flip = curry.obj (F₁.prod F₂ ⋙ H) :=
functor.ext (λ X₁, (functor.ext (λ Y₁, rfl) (by tidy))) (by tidy)

lemma uncurry_curry (H : D₁ × D₂ ⥤ E) : uncurry.obj (curry.obj H) = H :=
functor.ext (λ X, by { cases X, refl, }) (by tidy)

end functor

namespace morphism_property

class contains_identities {C : Type*} [category C] (W : morphism_property C) : Prop :=
(id [] : ∀ (X : C), W (𝟙 X))

namespace contains_identities

lemma op {C : Type*} [category C] {W : morphism_property C}
  (h : W.contains_identities) : W.op.contains_identities :=
⟨λ X, h.id X.unop⟩

lemma unop {C : Type*} [category C] {W : morphism_property Cᵒᵖ}
  (h : W.contains_identities) : W.unop.contains_identities :=
⟨λ X, h.id (opposite.op X)⟩

instance op' {C : Type*} [category C] {W : morphism_property C} [h : W.contains_identities] :
  W.op.contains_identities := h.op

end contains_identities

def prod : morphism_property (C₁ × C₂) := λ X Y f, W₁ f.fst ∧ W₂ f.snd

variables {W₁ W₂}

lemma is_inverted_by.prod {F₁ : C₁ ⥤ D₁} {F₂ : C₂ ⥤ D₂} (h₁ : W₁.is_inverted_by F₁)
  (h₂ : W₂.is_inverted_by F₂) : (W₁.prod W₂).is_inverted_by (F₁.prod F₂) :=
λ X Y f hf, by { rw is_iso_prod_iff, exact ⟨h₁ f.1 hf.1,h₂ f.2 hf.2⟩, }

end morphism_property

namespace localization

variables [hW₁ : W₁.contains_identities] [hW₂ : W₂.contains_identities]

namespace strict_universal_property_fixed_target

variables  (F : C₁ × C₂ ⥤ E) (hF : (W₁.prod W₂).is_inverted_by F)

@[simps]
def prod.hom_mk {X₁ Y₁ : C₁} {X₂ Y₂ : C₂} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) :
  (⟨X₁, X₂⟩ : C₁ × C₂) ⟶ ⟨Y₁, Y₂⟩ := ⟨f₁, f₂⟩

namespace prod

include hF hW₂
def lift₁ : W₁.localization ⥤ C₂ ⥤ E :=
localization.construction.lift (curry.obj F) (λ X₁ Y₁ f₁ hf₁, begin
  haveI : Π (Z₂ : C₂), is_iso (((curry.obj F).map f₁).app Z₂),
  { intro Z₂,
    apply hF,
    exact ⟨hf₁, morphism_property.contains_identities.id _ _⟩, },
    apply nat_iso.is_iso_of_is_iso_app,
end)

lemma fac₁ : W₁.Q ⋙ (lift₁ W₁ W₂ F hF) = curry.obj F := localization.construction.fac _ _

lemma lift₁_obj_map (X₁ : C₁) {X₂ Y₂ : C₂} (f₂ : X₂ ⟶ Y₂) :
  ((lift₁ W₁ W₂ F hF).obj (W₁.Q.obj X₁)).map f₂ =
    F.map (prod.hom_mk (𝟙 X₁) f₂) := rfl

lemma lift₁_map_app {X₁ Y₁ : C₁} (f₁ : X₁ ⟶ Y₁) (X₂ : C₂) :
  ((lift₁ W₁ W₂ F hF).map (W₁.Q.map f₁)).app X₂ =
    F.map (prod.hom_mk f₁ (𝟙 X₂)) :=
by simpa only [functor.comp_map, eq_to_hom_refl, category.comp_id, category.id_comp,
  curry_obj_map_app] using congr_app (functor.congr_map_conjugate (fac₁ W₁ W₂ F hF) f₁) X₂

include hW₁

def lift₂ : W₂.localization ⥤ W₁.localization ⥤ E :=
localization.construction.lift (lift₁ W₁ W₂ F hF).flip (λ X₂ Y₂ f₂ hf₂, begin
  haveI : ∀ (X₁ : W₁.localization), is_iso (((lift₁ W₁ W₂ F hF).flip.map f₂).app X₁),
  { intro X₁,
    have hF₁ : ∃ (A₁ : C₁), W₁.Q.obj A₁ = X₁ := (construction.obj_equiv W₁).surjective X₁,
    cases hF₁ with A₁ hA₁,
    subst hA₁,
    simp only [functor.flip_map_app, lift₁_obj_map],
    haveI := hF (prod.hom_mk (𝟙 A₁) f₂) ⟨morphism_property.contains_identities.id _ _, hf₂⟩,
    apply_instance, },
  apply nat_iso.is_iso_of_is_iso_app,
end)

lemma fac₂ : W₂.Q ⋙ (lift₂ W₁ W₂ F hF) = (lift₁ W₁ W₂ F hF).flip :=
localization.construction.fac _ _

lemma lift₂_obj_map {X₁ Y₁ : C₁} (f₁ : X₁ ⟶ Y₁) (X₂ : C₂) :
  ((lift₂ W₁ W₂ F hF).obj (W₂.Q.obj X₂)).map (W₁.Q.map f₁) = F.map (prod.hom_mk f₁ (𝟙 X₂)) :=
by simpa only [eq_to_hom_refl, functor.flip_obj_map, category.comp_id,
  category.id_comp, lift₁_map_app] using functor.congr_map_conjugate
    (functor.congr_obj (fac₂ W₁ W₂ F hF) X₂) (W₁.Q.map f₁)

lemma lift₂_map_app (X₁ : C₁) {X₂ Y₂ : C₂} (f₂ : X₂ ⟶ Y₂) :
  ((lift₂ W₁ W₂ F hF).map (W₂.Q.map f₂)).app (W₁.Q.obj X₁) = F.map (prod.hom_mk (𝟙 X₁) f₂) :=
by simpa only [eq_to_hom_refl, category.comp_id, category.id_comp]
  using congr_app (functor.congr_map_conjugate (fac₂ W₁ W₂ F hF) f₂) (W₁.Q.obj X₁)

def lift₃ : W₁.localization × W₂.localization ⥤ E := uncurry.obj (lift₂ W₁ W₂ F hF).flip

lemma fac : W₁.Q.prod W₂.Q ⋙ prod.lift₃ W₁ W₂ F hF = F :=
begin
  refine functor.ext (λ X, by { cases X, refl, }) (λ X Y f, _),
  { rcases X with ⟨X₁, X₂⟩,
    rcases Y with ⟨Y₁, Y₂⟩,
    have eq : f = prod.hom_mk (𝟙 X₁) f.2 ≫ prod.hom_mk f.1 (𝟙 Y₂) :=
      by simp only [prod_comp, hom_mk_fst, category.id_comp, hom_mk_snd, category.comp_id,
        prod.mk.eta],
    nth_rewrite 0 eq,
    dsimp [functor.comp, lift₃],
    simp only [category.id_comp, category.comp_id, nat_trans.naturality,
      lift₂_obj_map, lift₂_map_app, ← F.map_comp],
    congr' 1,
    ext,
    { apply category.comp_id, },
    { apply category.id_comp, }, },
end

omit hF hW₁ hW₂

lemma uniq (H H' : W₁.localization × W₂.localization ⥤ E)
  (eq : W₁.Q.prod W₂.Q ⋙ H = W₁.Q.prod W₂.Q ⋙ H') : H = H' :=
begin
  let G := (curry.obj H).flip,
  let G' := (curry.obj H').flip,
  suffices : G = G',
  { rw [← functor.uncurry_curry H, ← functor.uncurry_curry H'],
    congr' 1,
    rw [← functor.flip_flip (curry.obj H), ← functor.flip_flip (curry.obj H')],
    congr', },
  apply construction.uniq,
  suffices : (W₂.Q ⋙ G).flip = (W₂.Q ⋙ G').flip,
  { rw [← functor.flip_flip (W₂.Q ⋙ G), ← functor.flip_flip (W₂.Q ⋙ G'), this], },
  apply construction.uniq,
  convert congr_arg curry.obj eq,
  all_goals { apply functor.comp_comp_curry_flip_flip_eq_curry, },
end

end prod

include hW₁ hW₂

variable (E)

def prod : strict_universal_property_fixed_target (W₁.Q.prod W₂.Q) (W₁.prod W₂) E :=
{ inverts := (localization.inverts _ _).prod (localization.inverts _ _),
  lift := λ F hF, prod.lift₃ W₁ W₂ F hF,
  fac := λ F hF, prod.fac W₁ W₂ F hF,
  uniq := λ H H' eq, begin
    let G := (curry.obj H).flip,
    let G' := (curry.obj H').flip,
    suffices : G = G',
    { rw [← functor.uncurry_curry H, ← functor.uncurry_curry H'],
      congr' 1,
      rw [← functor.flip_flip (curry.obj H), ← functor.flip_flip (curry.obj H')],
      congr', },
    apply construction.uniq,
    suffices : (W₂.Q ⋙ G).flip = (W₂.Q ⋙ G').flip,
    { rw [← functor.flip_flip (W₂.Q ⋙ G), ← functor.flip_flip (W₂.Q ⋙ G'), this], },
    apply construction.uniq,
    convert congr_arg curry.obj eq,
    all_goals { apply functor.comp_comp_curry_flip_flip_eq_curry, },
  end, }

end strict_universal_property_fixed_target

include hW₁ hW₂

instance prod_construction_is_localization : (W₁.Q.prod W₂.Q).is_localization (W₁.prod W₂) :=
functor.is_localization.mk' _ _
  (strict_universal_property_fixed_target.prod W₁ W₂ _)
  (strict_universal_property_fixed_target.prod W₁ W₂ _)

instance prod_is_localization (L₁ : C₁ ⥤ D₁) (L₂ : C₂ ⥤ D₂)
  [L₁.is_localization W₁] [L₂.is_localization W₂] :
  (L₁.prod L₂).is_localization (W₁.prod W₂) :=
begin
  let E₁ := equivalence_from_model L₁ W₁,
  let E₂ := equivalence_from_model L₂ W₂,
  let e₁ : W₁.Q ⋙ E₁.functor ≅ L₁ := Q_comp_equivalence_from_model_functor_iso _ _,
  let e₂ : W₂.Q ⋙ E₂.functor ≅ L₂ := Q_comp_equivalence_from_model_functor_iso _ _,
  exact functor.is_localization.of_equivalence (W₁.Q.prod W₂.Q) (W₁.prod W₂) (L₁.prod L₂)
    (E₁.prod E₂) (functor.prod_functor.map_iso (e₁.prod e₂)),
end

end localization

variables {J : Type*} (C : J → Type u) [Π j, category (C j)]

def equivalence.pi' {J' : Type*} (α : J' ≃ J) :
  (Π j, C (α j)) ≌ (Π j', C j'):=
{ functor := functor.pi'_ (λ j, functor.pi_.eval _ (α.symm j) ⋙
    (pi.equivalence_of_eq C (show α (α.symm j) = j, by simp)).functor),
  inverse := functor.pi'_ (λ j', functor.pi_.eval _ (α j')),
  unit_iso := functor.pi_.mk_nat_iso (λ j', begin
    calc 𝟭 (Π (j : J'), C (α j)) ⋙ functor.pi_.eval (λ (j : J'), C (α j)) j' ≅ _ :
      functor.left_unitor _
    ... ≅ _ : (functor.pi_.eval_iso_of_eq (λ j, C (α j)) (show α.symm (α j') = j', by simp)).symm
    ... ≅ _ : _
    ... ≅ _ ⋙ functor.pi_.eval _ _ : (functor.pi'__eval_iso _ _).symm
    ... ≅ _ ⋙ _ ⋙ _ : iso_whisker_left _ ((functor.pi'__eval_iso _ _).symm)
    ... ≅ (_ ⋙ _) ⋙ _ : (functor.associator _ _ _).symm,
    { exact iso_whisker_left _ (pi.equivalence_of_eq_functor_iso C α (by simp)), },
  end),
  counit_iso := functor.pi_.mk_nat_iso
    (λ j, functor.associator _ _ _ ≪≫ iso_whisker_left _ (functor.pi'__eval_iso _ _) ≪≫
    (functor.associator _ _ _).symm ≪≫ iso_whisker_right (functor.pi'__eval_iso _ _) _ ≪≫
    functor.pi_.eval_iso_of_eq _ _ ≪≫ (functor.left_unitor _).symm),
  functor_unit_iso_comp' := λ X, begin
    ext j,
    dsimp [iso.refl],
    simp only [assoc, id_comp],
    erw nat_trans.id_app,
    dsimp,
    simp only [id_comp, comp_id, functor.map_id, eq_to_hom_app, functor.map_comp, assoc,
      pi.equivalence_of_eq_functor_iso_hom_app, eq_to_hom_map, eq_to_hom_trans, eq_to_hom_refl],
  end, }

lemma equivalence.pi'_inverse_comp_eval {J' : Type*} (α : J' ≃ J) (j' : J') :
  (equivalence.pi' C α).inverse ⋙ functor.pi_.eval _ j' = functor.pi_.eval _ (α j') := rfl

lemma equivalence.pi'_functor_comp_eval {J' : Type*} (α : J' ≃ J) (j' : J') :
  (equivalence.pi' C α).functor ⋙ functor.pi_.eval _ (α j') = functor.pi_.eval _ j' :=
begin
  dsimp only [equivalence.pi'],
  rw functor.pi'__eval,
  rw ← functor.pi_.eval_eq_of_eq (λ j', C (α j')) (show α.symm (α j') = j', by simp),
  rw pi.equivalence_of_eq_functor_eq C α,
end

variable {C}

@[simps]
def equivalence.pi'' {J' : Type*} (α : J ≃ J') {D : J' → Type*}
  [Π j', category (D j')] (e : Π j, C j ≌ D (α j)) :
  (Π j, C j) ≌ (Π j', D j') :=
(equivalence.pi e).trans (equivalence.pi' D α)

lemma equivalence.pi''_inverse_comp_eval {J' : Type*} (α : J ≃ J') {D : J' → Type*}
  [Π j', category (D j')] (e : Π j, C j ≌ D (α j)) (j : J) :
  (equivalence.pi'' α e).inverse ⋙ functor.pi_.eval _ j =
    functor.pi_.eval _ (α j) ⋙ (e j).inverse := rfl

lemma equivalence.pi''_functor_comp_eval {J' : Type*} (α : J ≃ J') {D : J' → Type*}
  [Π j', category (D j')] (e : Π j, C j ≌ D (α j)) (j : J) :
  (equivalence.pi'' α e).functor ⋙ functor.pi_.eval _ (α j) =
    functor.pi_.eval _ j ⋙ (e j).functor :=
begin
  dsimp only [equivalence.pi'', equivalence.trans],
  rw [functor.assoc, equivalence.pi'_functor_comp_eval],
  refl,
end

lemma is_iso_pi_iff {X Y : Π j, C j} (f : X ⟶ Y) :
  is_iso f ↔ ∀ j, is_iso (f j) :=
begin
  split,
  { introI,
    intro j,
    change is_iso ((functor.pi_.eval C j).map f),
    apply_instance, },
  { introI,
    exact ⟨⟨λ j, inv (f j), by tidy⟩⟩, },
end

def morphism_property.pi (W : Π j, morphism_property (C j)) :
  morphism_property (Π j, C j) := λ X Y f, ∀ j, (W j) (f j)

end

section

variables {J₁ J₂ : Type*} (C₁ : J₁ → Type u) (C₂ : J₂ → Type u)

@[simp]
def sum.desc : sum J₁ J₂ → Type u
|(sum.inl j₁) := C₁ j₁
|(sum.inr j₂) := C₂ j₂

variables [Π j₁, category.{v} (C₁ j₁)] [Π j₂, category.{v} (C₂ j₂)]

instance : Π j, category.{v} (sum.desc C₁ C₂ j) :=
λ j, by { cases j; dsimp only [sum.desc]; apply_instance, }

def equivalence_pi_prod :
  (Π j₁, C₁ j₁) × (Π j₂, C₂ j₂) ≌ (Π j, sum.desc C₁ C₂ j) :=
{ functor := functor.pi'_ (λ j, match j with
    | sum.inl j₁ := category_theory.prod.fst _ _ ⋙ functor.pi_.eval _ j₁
    | sum.inr j₂ := category_theory.prod.snd _ _ ⋙ functor.pi_.eval _ j₂
  end),
  inverse := functor.prod'
    (functor.pi'_ (λ j₁, functor.pi_.eval _ (sum.inl j₁)))
    (functor.pi'_ (λ j₂, functor.pi_.eval _ (sum.inr j₂))),
  unit_iso := eq_to_iso (functor.ext (by tidy) (by tidy)),
  counit_iso := eq_to_iso (functor.ext (by tidy) (by tidy)), }

end

section

variables {J : Type*} {T : Type*} (C : J → T) (C₀ : T)

@[simp]
def option.desc : option J → T
| none := C₀
| (some j) := C j

lemma option.is_desc (f : option J → T) : ∃ (C : J → T) (C₀ : T), f = option.desc C C₀ :=
⟨λ j, f (some j), f none, by { ext j, cases j; refl, }⟩

def option.desc' {C : J → Type u} {C₀ : Type u}
  (f : Π j, C j) (f₀ : C₀) : Π (j : option J), option.desc C C₀ j
| none := f₀
| (some j) := f j

lemma option.is_desc'
  {C : J → Type u} {C₀ : Type u} (g : Π (j : option J), option.desc C C₀ j) :
  ∃ (f : Π j, C j) (f₀ : C₀), g = option.desc' f f₀ :=
⟨λ j, g (some j), g none, by { ext j, cases j; refl,}⟩

end

section

variables {J : Type*} (j : J) [subsingleton J] (C : J → Type*) [Π t, category (C t)]

def equivalence_pi_single :
  (Π t, C t) ≌ C j :=
{ functor := functor.pi_.eval _ j,
  inverse := functor.pi'_ (λ t, begin
    have eq := subsingleton.elim j t,
    subst eq,
    exact 𝟭 _,
  end),
  unit_iso := eq_to_iso begin
    refine functor.ext _ _,
    { intro X,
      ext t,
      have eq := subsingleton.elim j t,
      subst eq,
      refl, },
    { intros X Y f,
      ext t,
      have eq := subsingleton.elim j t,
      subst eq,
      simp, },
  end,
  counit_iso := eq_to_iso rfl, }

end

section

variables {J : Type} (C : option J → Type u) [Π j', category.{v} (C j')]

def equivalence_pi_option : (Π j', C j') ≌ (Π j, C (some j)) × C none :=
{ functor := functor.prod' (functor.pi'_ (λ j, functor.pi_.eval _ (some j))) (functor.pi_.eval _ none),
  inverse := functor.pi'_ (λ j, match j with
    | none := prod.snd _ _
    | (some j) := prod.fst _ _ ⋙ functor.pi_.eval _ j
  end),
  unit_iso := eq_to_iso (functor.pi_.ext (λ j, by { cases j; refl, })),
  counit_iso := eq_to_iso (functor.prod.ext rfl rfl), }

end

section

variables {J : Type*} {C : J → Type*} {D : J → Type*}
  [Π j, category (C j)] [Π j, category (D j)]
  (W : Π j, morphism_property (C j))
  (L : Π j, C j ⥤ D j)

lemma morphism_property.is_inverted_by.pi (h : ∀ j, (W j).is_inverted_by (L j)):
  (morphism_property.pi W).is_inverted_by (functor.pi_ (λ j, L j)) :=
λ X Y f hf, by { rw is_iso_pi_iff, exact λ j, h _ _ (hf j), }

instance [Π j, (W j).contains_identities] :
  morphism_property.contains_identities (morphism_property.pi W) :=
⟨λ X j, morphism_property.contains_identities.id (W j) (X j)⟩

end

namespace localization

variables (J : Type) [finite J] {C : J → Type*} {D : J → Type*}
  [Π j, category (C j)] [Π j, category (D j)]
  (W : Π j, morphism_property (C j))
  [hW : ∀ j, (W j).contains_identities]
  (L : Π j, C j ⥤ D j) [Π j, (L j).is_localization (W j)]

include hW

instance pi_is_localization : ((functor.pi_ L).is_localization (morphism_property.pi W)) :=
begin
  unfreezingI { revert C D, },
  refine finite.induction_empty_option _ _ _ J,
  { intros J₁ J₂ e h₁ C₂ D₂, introI, introI, intros W₂, introI, intro L₂, introI,
    let C₁ := λ j₁, C₂ (e j₁),
    let D₁ := λ j₁, D₂ (e j₁),
    let L₁ : Π j₁, C₁ j₁ ⥤ D₁ j₁ := λ j₁, L₂ (e j₁),
    let W₁ : Π j₁, morphism_property (C₁ j₁) := λ j₁, W₂ (e j₁),
    haveI := h₁ W₁ L₁,
    let E : (Π j₁, C₁ j₁) ≌ (Π j₂, C₂ j₂) := equivalence.pi'' e (λ j₁, by refl),
    let E' : (Π j₁, D₁ j₁) ≌ (Π j₂, D₂ j₂) := equivalence.pi'' e (λ j₁, by refl),
    let Sq : Comm_sq E.symm.functor (functor.pi_ L₂) (functor.pi_ L₁) E'.symm.functor :=
      ⟨eq_to_iso (functor.pi_.ext (λ j₁, begin
        simp only [functor.assoc, functor.pi_eval],
        erw equivalence.pi''_inverse_comp_eval,
        simp only [← functor.assoc],
        erw equivalence.pi''_inverse_comp_eval,
        refl,
    end))⟩,
    have hW₁ : morphism_property.pi W₁ ⊆ (morphism_property.pi W₂).inverse_image' E.symm.inverse,
    { intros X₁ Y₁ f hf,
      refine ⟨X₁, Y₁, iso.refl _, iso.refl _, f, λ j₂, _, by tidy⟩,
      rcases e.surjective j₂ with ⟨j₁, hj₁⟩,
      subst hj₁,
      refine (W₂ (e j₁)).of_arrow_mk_eq _ _ (hf j₁) _,
      exact functor.congr_map_arrow_obj_arrow_mk (equivalence.pi''_functor_comp_eval e _ _) f, },
    exact (functor.is_localization.of_equivalence'' E.symm E'.symm Sq
      (morphism_property.pi W₂) (morphism_property.pi W₁)
      (morphism_property.is_inverted_by.pi W₂ L₂ (λ j₂, localization.inverts _ _)) hW₁), },
  { intros C D, introI, introI, intros W, introI, intro L, introI,
    haveI : is_equivalence (functor.pi_ L) :=
    { inverse :=
      { obj := λ Y j, by induction j,
        map := λ X Y f j, by induction j, },
      unit_iso := eq_to_iso (functor.ext (by tidy) (by tidy)),
      counit_iso := eq_to_iso (functor.ext (by tidy) (by tidy)), },
    apply functor.is_localization.of_is_equivalence (functor.pi_ L) (morphism_property.pi W),
    intros X Y f hf,
    rw morphism_property.isomorphisms.iff,
    rw is_iso_pi_iff,
    intro j,
    induction j, },
  { intro J, introI, intros hJ C' D', introI, introI, intros W' hW' L' hL',
    let W := λ j, W' (some j),
    let W₀ := W' none,
    let L := λ j, L' (some j),
    let L₀ := L' none,
    let E := equivalence_pi_option C',
    let E' := equivalence_pi_option D',
    haveI : L₀.is_localization W₀ := hL' none,
    let H : Comm_sq (equivalence_pi_option C').functor (functor.pi_ L') (functor.prod (functor.pi_ L) L₀) (equivalence_pi_option D').functor := ⟨eq_to_iso rfl⟩,
    have hW₁ := morphism_property.is_inverted_by.pi W' L' (λ j, localization.inverts _ _),
    have hW₂ : (morphism_property.pi W).prod W₀ ⊆ (morphism_property.pi W').inverse_image' E.inverse,
    { intros X Y f hf,
      refine ⟨X, Y, iso.refl X, iso.refl Y, f, _, comm_sq.mk (by simp)⟩,
      rintro (_|j),
      { exact hf.2, },
      { exact hf.1 j, }, },
    exact functor.is_localization.of_equivalence'' E E' H (morphism_property.pi W')
      (morphism_property.prod (morphism_property.pi W) W₀) hW₁ hW₂, },
end

end localization

def morphism_property.functor_category {C : Type*} [category C]
  (W : morphism_property C) (J : Type*) [category J] :
  morphism_property (J ⥤ C) := λ X Y f, ∀ j, W (f.app j)

namespace localization

variables (J : Type) [finite J] {C D : Type*} [category C] [category D]
  (W : morphism_property C)
  [morphism_property.contains_identities W]
  (L : C ⥤ D) [L.is_localization W]

instance whiskering_right_discrete_is_localization :
  ((whiskering_right (discrete J) C D).obj L).is_localization (W.functor_category _) :=
begin
  let E := pi_equivalence_functors_from_discrete C J,
  let E' := pi_equivalence_functors_from_discrete D J,
  let L₁ := (whiskering_right (discrete J) C D).obj L,
  let L₂ := functor.pi_ (λ (j : J), L),
  let H : Comm_sq E.symm.functor L₁ L₂ E'.symm.functor := ⟨iso.refl _⟩,
  refine functor.is_localization.of_equivalence'' E.symm E'.symm H (W.functor_category _)
    (morphism_property.pi (λ j, W)) _ _,
  { intros X Y f hf,
    haveI : ∀ (j : discrete J), is_iso ((((whiskering_right
      (discrete J) C D).obj L).map f).app j),
    { rintro ⟨j⟩,
      dsimp,
      exact localization.inverts L W _ (hf (discrete.mk j)), },
    apply nat_iso.is_iso_of_is_iso_app, },
  { refine has_subset.subset.trans _ (morphism_property.inverse_image_subset_inverse_image' _ _),
    rintros X Y f hf ⟨j⟩,
    exact hf j, },
end

end localization

end category_theory


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.algebra.homology.hom_complex
import for_mathlib.algebra.homology.bounded_above

noncomputable theory

open category_theory category_theory.category category_theory.limits category_theory.preadditive

namespace cochain_complex

namespace hom_complex

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

variables {F G K : cochain_complex C ℤ} {n : ℤ} (z : cocycle F G n) {m : ℤ} [∀ p, has_binary_biproduct (F.X (p+1-n)) (G.X p)]
include z

namespace twist

@[protected, simp]
def δ (p q : ℤ) :
  biprod (F.X (p+1-n)) (G.X p) ⟶ biprod (F.X (q+1-n)) (G.X q) :=
begin
  refine biprod.desc (biprod.lift (ε (n+1) • F.d (p+1-n) (q+1-n)) _) (biprod.lift 0 (G.d p q)),
  by_cases p+1 = q,
  { exact (z : cochain F G n).v (p+1-n) q (show q=(p+1-n)+n, by linarith), },
  { exact 0, },
end

end twist

@[simps]
def twist : cochain_complex C ℤ :=
{ X := λ p, biprod (F.X (p+1-n)) (G.X p),
  d := λ p q, twist.δ z p q,
  shape' := λ p q hpq, begin
    dsimp [twist.δ],
    ext,
    { simp only [biprod.inl_desc, biprod.lift_fst, comp_zero, zero_comp],
      rw [F.shape, smul_zero],
      intro h,
      apply hpq,
      change p+1-n+1=q+1-n at h,
      change p+1=q,
      linarith, },
    { simp only [biprod.inl_desc, biprod.lift_snd, comp_zero, zero_comp],
      split_ifs,
      { exfalso, exact hpq h, },
      { refl, }, },
    { simp only [biprod.inr_desc, biprod.lift_fst, comp_zero, zero_comp], },
    { simp only [biprod.inr_desc, biprod.lift_snd, comp_zero, zero_comp, G.shape p q hpq], },
  end,
  d_comp_d' := λ i j k hij hjk, begin
    change i+1=j at hij,
    subst hij,
    change i+1+1=k at hjk,
    have hjk' : i+2 = k := by linarith,
    subst hjk',
    simp only [twist.δ, dif_pos rfl, dif_pos (show i+1+1 = i+2, by linarith)],
    ext,
    { simp only [add_zero, biprod.inl_desc_assoc, biprod.lift_desc, linear.smul_comp,
        add_comp, assoc, biprod.lift_fst,
        linear.comp_smul, homological_complex.d_comp_d, smul_zero, comp_zero, zero_comp], },
    { simp only [biprod.inl_desc_assoc, biprod.lift_desc, linear.smul_comp,
        add_comp, assoc, biprod.lift_snd, comp_zero, zero_comp],
      have hz₁ := z.2,
      rw cocycle.mem_iff n (n+1) rfl at hz₁,
      have hz₂ := cochain.congr_v hz₁ (i+1-n) (i+2) (by linarith),
      simp only [δ_v n (n+1) rfl _ (i+1-n) (i+2) (by linarith) (i+1) (i+1+1-n)
        (by linarith) (by linarith), cochain.zero_v] at hz₂,
      rw ← hz₂,
      abel, },
    { simp only [zero_add, biprod.inr_desc_assoc, biprod.lift_desc, zero_comp, assoc, biprod.lift_fst, comp_zero], },
    { simp only [zero_add, biprod.inr_desc_assoc, biprod.lift_desc, zero_comp, assoc, biprod.lift_snd, homological_complex.d_comp_d,
  comp_zero], },
  end }

namespace twist

omit z

lemma is_bounded_above (z : cocycle F G n) (hF : F.is_bounded_above) (hG : G.is_bounded_above) :
  (twist z).is_bounded_above :=
begin
  cases hF with r hr,
  cases hG with s hs,
  use max (r+n-1) s,
  intros i hi,
  dsimp only [twist],
  rw is_zero.iff_of_biprod,
  split,
  { apply hr,
    have h := lt_of_le_of_lt (le_max_left _ _) hi,
    linarith, },
  { apply hs,
    exact lt_of_le_of_lt (le_max_right _ _) hi, },
end

include z
def inl {n₀ : ℤ} (hn₀ : n₀+1=n) : cochain F (twist z) n₀ :=
cochain.mk (λ p q hpq, (cochain.of_hom (𝟙 F)).v p (q+1-n) (by linarith) ≫ biprod.inl)

def inr : G ⟶ twist z := { f := λ p, biprod.inr, }

def fst {n₁ : ℤ} (hn₁ : n+n₁=1) : cocycle (twist z) F n₁ :=
cocycle.mk (cochain.mk (λ p q hpq, biprod.fst ≫
  (cochain.of_hom (𝟙 F)).v (p+1-n) q (show q=p+1-n+0, by linarith))) (n₁+1) rfl
begin
  have hn₁' : n₁ = 1-n := by linarith,
  subst hn₁',
  ext1,
  simp only [δ_v (1-n) (1-n+1) rfl _ p q hpq (p+1-n) (p+1) (by linarith) rfl,
    cochain.mk_v, cochain.of_hom_v, homological_complex.id_f, comp_id, twist_d, twist.δ, dif_pos,
      cochain.zero_v],
  ext,
  { have hq : q = p+1+1-n := by linarith,
    subst hq,
    have eq : ε (1-n+1) * ε (n+1) = ε ((1 : ℤ) + 1 + 1) := by { rw ← ε_add, congr' 1, linarith, },
    have eq' : ε ((1 : ℤ)+1+1) = -1 := by { simp only [ε_succ, ε_1, neg_neg], },
    simp only [biprod.inl_fst_assoc, biprod.inl_desc_assoc, biprod.lift_fst, comp_add,
      cochain.of_hom_v, homological_complex.id_f, comp_zsmul, comp_id, comp_zero, smul_smul,
      eq, eq', neg_smul, one_zsmul, add_right_neg], },
  { simp only [zero_add, neg_eq_zero, comp_add, biprod.inr_fst_assoc, zero_comp,
      linear.comp_smul, biprod.inr_desc_assoc, biprod.lift_fst_assoc, smul_zero, comp_zero], },
end

def snd : cochain (twist z) G 0 :=
cochain.mk (λ p q hpq, biprod.snd ≫ (cochain.of_hom (𝟙 G)).v p q hpq)

@[simp]
lemma inl_comp_fst {n₀ n₁ : ℤ} (hn₀ : n₀+1=n) (hn₁ : n+n₁=1) :
  (inl z hn₀).comp ↑(fst z hn₁) (show 0=n₀+n₁, by linarith) = cochain.of_hom (𝟙 F) :=
begin
  ext,
  dsimp [cochain.comp, cochain.mk, cochain.v, cochain.of_hom, cochain.of_homs, inl, fst],
  simp only [id_comp, assoc, biprod.inl_fst_assoc, eq_to_hom_trans, eq_to_hom_refl],
end

@[simp]
lemma inl_comp_snd {n₀ : ℤ} (hn₀ : n₀+1=n) :
  (inl z hn₀).comp (snd z) (add_zero n₀).symm = 0 :=
begin
  ext,
  simp only [inl, snd, cochain.comp, cochain.mk, cochain.v, cochain.of_hom, cochain.of_homs,
    assoc, biprod.inl_snd_assoc, zero_comp, comp_zero, cochain.zero_v],
end

@[simp]
lemma inr_comp_fst {n₁ : ℤ} (hn₁ : n+n₁=1) :
  (cochain.of_hom (inr z)).comp (fst z hn₁ : cochain (twist z) F n₁) (zero_add n₁).symm = 0 :=
begin
  ext,
  simp only [inr, fst, cochain.zero_cochain_comp, cochain.of_hom_v, cocycle.mk_coe,
    cochain.mk_v, biprod.inr_fst_assoc, zero_comp, cochain.zero_v],
end

@[simp]
lemma inr_comp_snd :
  (cochain.of_hom (inr z)).comp (snd z) (add_zero 0).symm = cochain.of_hom (𝟙 G) :=
begin
  ext,
  simp only [inr, snd, cochain.comp_zero_cochain, cochain.mk_v, cochain.of_hom_v,
    homological_complex.id_f, comp_id, biprod.inr_snd],
end

@[simp]
lemma δ_inl {n₀ : ℤ} (hn₀ : n₀+1=n) :
  δ n₀ n (inl z hn₀) = cochain.comp ↑z (cochain.of_hom (inr z)) (add_zero n).symm :=
begin
  ext1,
  simp only [δ_v n₀ n hn₀ (inl z hn₀) p q hpq _ _ rfl rfl, twist_d, twist.δ],
  ext,
  { simp only [← hn₀, inl, cochain.mk_v, ε_succ, neg_neg, assoc, biprod.inl_desc, neg_smul,
      add_comp, biprod.lift_fst, comp_zsmul, cochain.of_hom_v_comp_d,
      homological_complex.id_f, id_comp, neg_comp, zsmul_comp, biprod.inl_fst, comp_id,
      cochain.d_comp_of_hom_v, add_right_neg, cochain.comp_zero_cochain, cochain.of_hom_v,
      inr, biprod.inr_fst, comp_zero], },
  { simp only [inl, inr, add_zero, sub_add_cancel, eq_self_iff_true, cochain.mk_v,
      dif_pos, assoc, biprod.inl_desc, add_comp, biprod.lift_snd,
      linear.smul_comp, biprod.inl_snd, comp_zero, smul_zero, cochain.comp_zero_cochain,
      cochain.of_hom_v, biprod.inr_snd, comp_id, id_comp,
      cochain.zero_cochain_comp' _ _ p (q-1+1-n) q, homological_complex.id_f], },
end

@[simp]
lemma δ_snd {n₁ : ℤ} (hn₁ : n+n₁=1) :
  δ 0 1 (snd z) = -cochain.comp (fst z hn₁ : cochain (twist z) F n₁) (↑z) (show 1 = n₁+n, by rw [← hn₁, add_comm]) :=
begin
  ext1,
  simp only [δ_v 0 1 (zero_add 1) _ p q hpq p q (by linarith) hpq, fst, snd, zero_add, ε_1,
    cochain.mk_v, cochain.of_hom_v, homological_complex.id_f, comp_id, neg_zsmul, one_zsmul,
    cochain.neg_v, cocycle.mk_coe, twist_d, twist.δ,
    cochain.comp_v _ _ (show 1=n₁+n, by linarith) p (p+1-n) q (by linarith) (by linarith)],
  ext,
  { simp only [dif_pos hpq.symm, zero_add, comp_add, biprod.inl_snd_assoc, zero_comp,
      comp_neg, biprod.inl_desc_assoc, biprod.lift_snd, biprod.inl_fst_assoc], },
  { simp only [neg_zero, comp_add, biprod.inr_snd_assoc, comp_neg, biprod.inr_desc_assoc,
      biprod.lift_snd, add_right_neg, biprod.inr_fst_assoc, zero_comp], },
end

lemma id_eq {n₀ n₁ : ℤ} (hn₀ : n₀+1=n)  (hn₁ : n+n₁=1) : cochain.of_hom (𝟙 (twist z)) =
cochain.comp ↑(fst z hn₁) (inl z hn₀) (show 0=n₁+n₀, by linarith) +
cochain.comp (snd z) (cochain.of_hom (inr z)) (zero_add 0).symm :=
begin
  ext1,
  simpa only [fst, inl, snd, inr, cochain.add_v,
    cochain.comp_v _ _ (show 0 = n₁+n₀, by linarith) p (p+1-n) p (by linarith) (by linarith),
    cochain.of_hom_v, homological_complex.id_f, cocycle.mk_coe, cochain.mk_v,
    comp_id, id_comp, cochain.comp_zero_cochain, biprod.total],
end

lemma cochain_ext (y₁ y₂ : cochain (twist z) K m) {n₀ n₁ : ℤ} (hn₀ : n₀+1=n)
  (hn₁ : n₁ = n₀+m) :
  y₁ = y₂ ↔ cochain.comp (inl z hn₀) y₁ hn₁ = cochain.comp (inl z hn₀) y₂ hn₁ ∧
    cochain.comp (cochain.of_hom (inr z)) y₁ (zero_add m).symm =
      cochain.comp (cochain.of_hom (inr z)) y₂ (zero_add m).symm :=
begin
  split,
  { intro h, rw h, tauto, },
  { rintro ⟨hl, hr⟩,
    suffices : cochain.comp (cochain.of_hom (𝟙 _)) y₁ (zero_add m).symm =
      cochain.comp (cochain.of_hom (𝟙 _)) y₂ (zero_add m).symm,
    { ext1,
      simpa only [cochain.id_comp] using cochain.congr_v this p q hpq, },
    simp only [id_eq z hn₀ (show n+(-n₀)=1, by linarith), cochain.add_comp,
      cochain.comp_assoc_of_second_is_zero_cochain,
      cochain.comp_assoc _ _ _ (show 0=-n₀+n₀, by linarith) (show n₁=n₀+m, by linarith)
      (show m=-n₀+n₀+m, by linarith), hl, hr], }
end

def desc_cochain {m m₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : cochain G K m)
  (hm₁ : m₁+1=n+m) : cochain (twist z) K m :=
cochain.comp ↑(fst z (show n+(m-m₁) = 1, by linarith)) y₁ (eq_add_of_sub_eq rfl : m=(m-m₁)+m₁) +
  cochain.comp (snd z) y₂ (zero_add m).symm

lemma desc_cochain_eq {m m₁ n₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : cochain G K m)
  (hm₁ : m₁+1=n+m) (hn₁ : n+n₁=1) : desc_cochain z y₁ y₂ hm₁ =
cochain.comp ↑(fst z hn₁) y₁ (show m = n₁+m₁, begin
  suffices : m+1=n₁+m₁+1,
  { simpa only [add_left_inj] using this, },
  rw [add_assoc, hm₁, ← hn₁, add_comm n₁, add_comm n m, add_assoc],
end) + cochain.comp (snd z) y₂ (zero_add m).symm :=
begin
  have h : n₁ = m-m₁ := by linarith,
  subst h,
  refl,
end

lemma inl_comp_desc_cochain {m m₁ n₀ : ℤ} (y₁ : cochain F K m₁)
  (y₂ : cochain G K m) (hm₁ : m₁+1=n+m) (hn₀ : n₀+1=n) :
  cochain.comp (inl z hn₀) (desc_cochain z y₁ y₂ hm₁) begin
    suffices : m₁+1 = n₀+m+1,
    { simpa only [add_left_inj] using this, },
    rw [add_assoc, hm₁, ← hn₀, add_assoc, add_comm 1 m],
  end = y₁ :=
begin
  simp only [desc_cochain_eq z y₁ y₂ hm₁ (show n+(-n₀)=1, by linarith), cochain.comp_add,
    ← cochain.comp_assoc (inl z hn₀) _ y₁ (show 0=n₀+(-n₀), by linarith)
      (show m= _, by linarith) (show m₁=_, by linarith),
    ← cochain.comp_assoc_of_second_is_zero_cochain, add_zero,
    inl_comp_fst, inl_comp_snd, cochain.id_comp, cochain.zero_comp],
end

lemma inr_comp_desc_cochain {m m₁ : ℤ} (y₁ : cochain F K m₁)
  (y₂ : cochain G K m) (hm₁ : m₁+1=n+m) :
  cochain.comp (cochain.of_hom (inr z)) (desc_cochain z y₁ y₂ hm₁) (zero_add m).symm = y₂ :=
begin
  simp only [desc_cochain_eq z y₁ y₂ hm₁ (show n+(1-n)=1, by linarith), cochain.comp_add,
    ← cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_snd, cochain.id_comp,
    ← cochain.comp_assoc_of_first_is_zero_cochain, inr_comp_fst, cochain.zero_comp, zero_add],
end

lemma δ_desc_cochain {m m₁ m₂ n₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : cochain G K m)
  (hm₁ : m₁+1=n+m) (hn₁ : n+n₁=1) (hm₂ : m₁+1=m₂)
  (m' : ℤ) (hm' : m+1=m') :
  δ m m' (desc_cochain z y₁ y₂ hm₁) =
  cochain.comp (fst z hn₁ : cochain (twist z) F n₁) (δ m₁ m₂ y₁ +
    ε (m+1) • cochain.comp ↑z y₂ (show m₂ = n+m, by linarith)) (show m' = n₁+m₂, by linarith) +
  cochain.comp (snd z) (δ m m' y₂) (zero_add m').symm :=
begin
  simp only [desc_cochain_eq z y₁ y₂ hm₁ hn₁, δ_add, cochain.comp_add,
    δ_comp_of_first_is_zero_cochain _ _ _ hm', δ_snd z hn₁,
    δ_comp ↑(fst z hn₁) y₁ (show m = n₁+m₁, by linarith) _ m₂ m' hm' rfl hm₂,
    cochain.comp_zsmul, cochain.neg_comp, zsmul_neg, ε_add, ε_1, mul_neg, mul_one,
    neg_zsmul, cochain.comp_neg, cocycle.δ_eq_zero, cochain.zero_comp, zsmul_zero, add_zero,
    add_assoc],
  rw cochain.comp_assoc _ _ _ (show 1=n₁+n, by linarith) (show m₂=n+m, by linarith)
    (show m' = n₁+n+m, by linarith),
  conv_rhs { congr, skip, rw add_comm, },
end

@[simps]
def desc_cocycle {m m₁ n₂ : ℤ} (y₁ : cochain F K m₁) (y₂ : cocycle G K m)
  (hm₁ : m₁+1=n+m) (hn₂ : n₂ = n+m)
  (hy : δ m₁ n₂ y₁ = ε m • cochain.comp (z : cochain F G n) (y₂ : cochain G K m) hn₂) :
  cocycle (twist z) K m :=
cocycle.mk (desc_cochain z y₁ ↑y₂ hm₁) _ rfl
begin
  simp only [δ_desc_cochain z y₁ ↑y₂ hm₁ (show n+(1-n)=1, by linarith) (show m₁+1=n₂, by linarith) _ rfl,
    cocycle.δ_eq_zero, cochain.comp_zero, add_zero, hy, ε_add, ε_1, mul_neg, mul_one, neg_zsmul,
    add_right_neg, cochain.comp_zero],
end

lemma inr_comp_desc_cocycle {m m₁ n₂ : ℤ} (y₁ : cochain F K m₁) (y₂ : cocycle G K m)
  (hm₁ : m₁+1=n+m) (hn₂ : n₂ = n+m)
  (hy : δ m₁ n₂ y₁ = ε m • cochain.comp (z : cochain F G n) (y₂ : cochain G K m) hn₂) :
  cochain.comp (cochain.of_hom (inr z)) (desc_cocycle z y₁ y₂ hm₁ hn₂ hy : cochain (twist z) K m)
    (zero_add m).symm = y₂ :=
by simp only [desc_cocycle, cocycle.mk_coe, inr_comp_desc_cochain]

@[simps]
def desc_hom_as_cocycle {m₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : G ⟶ K)(hm₁ : m₁+1=n)
  (hy : δ m₁ n y₁ = cochain.comp (z : cochain F G n) (cochain.of_hom y₂) (add_zero n).symm) :
  cocycle (twist z) K 0 :=
begin
  apply desc_cocycle z y₁ (cocycle.of_hom y₂) (by linarith) (add_zero n).symm,
  simpa only [hy, ε_0, one_zsmul],
end

@[simps]
def desc {m₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : G ⟶ K)
  (hm₁ : m₁+1=n)
  (hy : δ m₁ n y₁ = cochain.comp (z : cochain F G n) (cochain.of_hom y₂) (add_zero n).symm) :
  twist z ⟶ K :=
cocycle.hom_of (desc_hom_as_cocycle z y₁ y₂ hm₁ hy)

@[simp]
lemma inr_comp_desc {m₁ : ℤ} (y₁ : cochain F K m₁) (y₂ : G ⟶ K)
  (hm₁ : m₁+1=n)
  (hy : δ m₁ n y₁ = cochain.comp (z : cochain F G n) (cochain.of_hom y₂) (add_zero n).symm) :
  inr z ≫ desc z y₁ y₂ hm₁ hy = y₂ :=
begin
  apply (cocycle.equiv_hom G K).to_equiv.injective,
  ext1,
  dsimp [cocycle.equiv_hom],
  simp only [cocycle.of_hom, cocycle.mk_coe, cochain.of_hom_comp, desc,
    cocycle.cochain_of_hom_hom_of_eq_coe, desc_hom_as_cocycle_coe, inr_comp_desc_cochain],
end

def lift_cochain {m₁ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m)
  (hm : m+1=m₁+n) : cochain K (twist z) m :=
cochain.comp y₁ (inl z (show (n-1)+1=n, by linarith)) (show m=m₁+(n-1), by linarith) +
  cochain.comp y₂ (cochain.of_hom (inr z)) (add_zero m).symm

lemma lift_cochain_eq {m₁ n₀ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n)
  (hn₀ : n₀+1=n) : lift_cochain z y₁ y₂ hm =
cochain.comp y₁ (inl z hn₀) (begin
  suffices : m+1=m₁+n₀+1,
  { simpa only [add_left_inj] using this, },
  rw [hm, ← hn₀, add_assoc],
end) + cochain.comp y₂ (cochain.of_hom (inr z)) (add_zero m).symm :=
begin
  have eq : n₀ = n-1 := by linarith,
  subst eq,
  refl,
end

lemma lift_cochain_v {m₁ n₀ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m)
  (hm : m+1=m₁+n) (hn₀ : n₀+1 = n) (p q : ℤ) (hpq : q = p + m) (p' : ℤ) (hp' : p' = p + m₁):
  (lift_cochain z y₁ y₂ hm).v p q hpq =
    y₁.v p p' hp' ≫ (inl z hn₀).v p' q (by rw [hpq, hp', add_assoc, add_right_inj,
      ← add_left_inj (1 : ℤ), hm, ← hn₀, add_assoc]) +
    y₂.v p q hpq ≫ (inr z).f q :=
begin
  have hn₀' : n₀ = n-1 := by linarith,
  substs hn₀' hp' hpq,
  dsimp [lift_cochain, cochain.comp],
  simp only [cochain.of_hom_v],
end

@[simp]
lemma lift_cochain_comp_fst {m₁ n₁ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n)
  (hn₁ : n+n₁=1) : cochain.comp (lift_cochain z y₁ y₂ hm) ↑(fst z hn₁)
    (show m₁=m+n₁, by { suffices : m₁+n = m+n₁+n,
    { simpa only [add_left_inj] using this,},
    rw [← hm, ← hn₁, add_comm n, add_assoc]}) = y₁ :=
begin
  simp only [lift_cochain, cochain.add_comp,
    cochain.comp_assoc _ _ _ (show m=m₁+(n-1), by linarith) (show 0=n-1+n₁, by linarith)
    (show m₁=_, by linarith), inl_comp_fst, cochain.comp_id, add_zero,
    cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_fst, cochain.comp_zero],
end

@[simp]
lemma lift_cochain_comp_snd {m₁ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n) :
  cochain.comp (lift_cochain z y₁ y₂ hm) (snd z) (add_zero m).symm = y₂ :=
by simp only [lift_cochain, cochain.add_comp, cochain.comp_assoc_of_third_is_zero_cochain,
    inl_comp_snd, cochain.comp_zero, zero_add, inr_comp_snd, cochain.comp_id]

lemma δ_lift_cochain {m₁ n₀ m₂ : ℤ} (y₁ : cochain K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n)
  (hn₀ : n₀+1=n) (hm₂ : m₁+1=m₂) (m' : ℤ) (hm' : m+1=m') :
  δ m m' (lift_cochain z y₁ y₂ hm) =
    ε n₀ • cochain.comp (δ m₁ m₂ y₁) (inl z hn₀)
    (by rw [← hm', ← hm₂, hm, ← hn₀, add_comm n₀ 1, add_assoc]) +
  cochain.comp (δ m m' y₂ + cochain.comp y₁ ↑z (by rw [← hm', hm]))
    (cochain.of_hom (inr z)) (add_zero m').symm :=
begin
  simp only [lift_cochain_eq z y₁ y₂ hm hn₀, δ_add,
    δ_comp y₁ (inl z hn₀) (show m = m₁+n₀, by linarith) m₂ n m' hm' hm₂ hn₀,
    δ_comp_of_second_is_zero_cochain _ _ _ hm', δ_inl, cocycle.δ_cochain_of_hom,
    cochain.comp_zero, zero_add, cochain.comp_assoc_of_third_is_zero_cochain,
    cochain.add_comp],
  conv_lhs { rw [add_assoc, add_comm, add_assoc], },
end

def lift_cocycle {m₁ n₀ : ℤ} (y₁ : cocycle K F m₁) (y₂ : cochain K G m) (hm : m+1=m₁+n)
  (hn₀ : n₀+1=n) (m' : ℤ) (hm' : m+1=m')
  (hy : δ m m' y₂ + cochain.comp (y₁ : cochain K F m₁) ↑z (show m'=m₁+n, by rw [← hm', hm]) = 0) :
  cocycle K (twist z) m := cocycle.mk (lift_cochain z ↑y₁ y₂ hm) m' hm'
(by simp only [δ_lift_cochain z ↑y₁ y₂ hm hn₀ rfl m' hm', cocycle.δ_eq_zero, cochain.zero_comp,
    zsmul_zero, zero_add, hy])

@[simps]
def lift_hom_as_cocycle {m₁ n₀ : ℤ} (y₁ : cocycle K F m₁) (y₂ : cochain K G 0) (hm : m₁+n=1)
  (hn₀ : n₀+1=n)
  (hy : δ 0 1 y₂ + cochain.comp (y₁ : cochain K F m₁) ↑z hm.symm = 0) : cocycle K (twist z) 0 :=
lift_cocycle z y₁ y₂ (show 0+1 = m₁+n, by linarith) hn₀ 1 (zero_add 1) hy

@[simps]
def lift {m₁ n₀ : ℤ} (y₁ : cocycle K F m₁) (y₂ : cochain K G 0) (hm : m₁+n=1)
  (hn₀ : n₀+1=n)
  (hy : δ 0 1 y₂ + cochain.comp (y₁ : cochain K F m₁) ↑z hm.symm = 0) :
  K ⟶ twist z :=
cocycle.hom_of (lift_hom_as_cocycle z y₁ y₂ hm hn₀ hy)

lemma cochain_ext' (y₁ y₂ : cochain K (twist z) m) {n₁ m₁ : ℤ} (hn₁ : n+n₁=1) (hm₁ : m₁ = m+n₁) :
  y₁ = y₂ ↔ cochain.comp y₁ (fst z hn₁ : cochain (twist z) F n₁) hm₁
      = cochain.comp y₂ (fst z hn₁ : cochain (twist z) F n₁) hm₁ ∧
  cochain.comp y₁ (snd z) (add_zero m).symm =
  cochain.comp y₂ (snd z) (add_zero m).symm :=
begin
  split,
  { intro h, rw h, tauto, },
  { rintro ⟨hl, hr⟩,
    suffices : cochain.comp y₁ (cochain.of_hom (𝟙 _)) (add_zero m).symm =
      cochain.comp y₂ (cochain.of_hom (𝟙 _)) (add_zero m).symm,
    { ext1,
      simpa only [cochain.comp_id] using cochain.congr_v this p q hpq, },
    simp only [id_eq z (show n-1+1=n, by linarith) hn₁, cochain.add_comp,
      cochain.comp_add],
    simp only [← cochain.comp_assoc_of_second_is_zero_cochain,
      ← cochain.comp_assoc _ _ _ hm₁ (show 0=n₁+(n-1), by linarith)
      (show m=m+n₁+(n-1), by linarith), hl, hr], },
end

lemma of_d_eq (n₁ n₂ n₃ : ℤ) (hn₁ : n + n₁ = 1) (hn₂ : n₂ = n₁+1) (hn₃ : n₃+1=n) : cochain.of_d (twist z) =
  ε (n+1) • ((fst z hn₁ : cochain (twist z) F n₁).comp (cochain.of_d F) hn₂).comp (inl z hn₃)
    (by rw [← hn₁, hn₂, ← hn₃, add_comm n₃, add_assoc, add_comm n₃, ← add_assoc, add_comm n₁]) +
    ((fst z hn₁ : cochain (twist z) F n₁).comp (z : cochain F G n) (show 1 = n₁ + n, by rw [← hn₁, add_comm])).comp
      (cochain.of_hom (inr z)) (add_zero 1).symm +
    ((snd z).comp (cochain.of_d G) (zero_add 1).symm).comp (cochain.of_hom (inr z)) (add_zero 1).symm :=
begin
  rw cochain_ext z (cochain.of_d (twist z)) _ hn₃ hn₃.symm,
  split,
  { simp only [cochain.comp_add, cochain.comp_zsmul],
    simp only [← cochain.comp_assoc_of_third_is_zero_cochain,
      ← cochain.comp_assoc_of_second_is_zero_cochain, inl_comp_snd, inl_comp_fst, cochain.id_comp,
      ← cochain.comp_assoc (inl z hn₃) _ _ (show 1 = n₃+n₂, by linarith) _ (show n = n₃+n₂+n₃, by linarith),
      ← cochain.comp_assoc (inl z hn₃) _ _ (show 0 = n₃ + n₁, by linarith) _ (show 1 = n₃ + n₁ + 1, by linarith),
      ← cochain.comp_assoc (inl z hn₃) _ _ (show 0 = n₃ + n₁, by linarith) (show 1 = n₁ + n, by linarith)
      (show n = n₃+n₁+n, by linarith), cochain.zero_comp, add_zero,
      cochain_ext' z _ _ hn₁ (show 1 = n+n₁, by linarith)],
    split,
    { simp only [cochain.add_comp, cochain.zsmul_comp,
        cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_fst, cochain.comp_zero, inl_comp_fst,
        cochain.comp_assoc _ (inl z hn₃) _ (show n = 1+n₃, by linarith) (show 0 = n₃ + n₁, by linarith)
        (show 1 = 1 + n₃ + n₁, by linarith), add_zero, cochain.comp_id],
      ext p q hpq,
      dsimp [inl, fst, cochain.comp],
      simp only [twist.δ, cochain.of_d_v, twist_d, assoc, biprod.inl_desc, biprod.lift_fst_assoc,
        linear.smul_comp, cochain.d_comp_of_hom_v, homological_complex.id_f, comp_id,
        linear.comp_smul, cochain.of_hom_v_comp_d, id_comp], },
    { simp only [cochain.comp_assoc_of_third_is_zero_cochain, cochain.add_comp, cochain.zsmul_comp,
        inl_comp_snd, inr_comp_snd, cochain.comp_zero, zsmul_zero, zero_add, cochain.comp_id],
      ext p q hpq,
      have hp : ∃ (p' : ℤ), p = p' + 1 -n := ⟨p+n-1, by linarith⟩,
      obtain ⟨p', hp'⟩ := hp,
      subst hp',
      rw cochain.comp_v _ _ hn₃.symm (p'+1-n) p' q (by linarith) (by linarith),
      dsimp [inl, snd],
      simp only [cochain.of_hom_v, homological_complex.id_f, id_comp, cochain.comp_zero_cochain,
        twist.δ, cochain.of_d_v, twist_d, cochain.mk_v, comp_id, biprod.inl_desc_assoc,
        biprod.lift_snd, dif_pos (show p'+1 = q, by linarith)], }, },
  { simp only [ε_succ, neg_smul,
      cochain.comp_add, cochain.comp_neg, cochain.comp_zsmul,
      ← cochain.comp_assoc_of_first_is_zero_cochain, inr_comp_fst, cochain.zero_comp, zsmul_zero,
      zero_add, neg_zero, inr_comp_snd, cochain.id_comp,
      cochain_ext' z _ _ hn₁ (show n₂ = 1 + n₁, by linarith)],
    split,
    { rw [cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_fst, cochain.comp_zero],
      ext p q hpq,
      simp only [cochain.comp_assoc_of_first_is_zero_cochain, cochain.zero_cochain_comp,
        cochain.of_hom_v, cochain.zero_v,
        cochain.comp_v _ _ (show n₂ = 1 + n₁, by linarith) p (p+1) q rfl (by linarith)],
      dsimp [inr, fst],
      simp only [twist.δ, cochain.of_d_v, twist_d, biprod.inr_desc_assoc,
        biprod.lift_fst_assoc, zero_comp], },
    { rw [cochain.comp_assoc_of_second_is_zero_cochain, inr_comp_snd, cochain.comp_id],
      ext p q hpq,
      dsimp [inr, snd],
      simp only [cochain.comp_assoc_of_third_is_zero_cochain, cochain.zero_cochain_comp,
        cochain.of_hom_v, cochain.comp_zero_cochain, twist.δ, cochain.of_d_v, twist_d,
        cochain.mk_v, homological_complex.id_f, comp_id, biprod.inr_desc_assoc,
        biprod.lift_snd], }, },
end

end twist

end hom_complex

end cochain_complex


import for_mathlib.derived.bounded_homotopy_category
import for_mathlib.is_quasi_iso_sigma
import for_mathlib.coprod_op
import for_mathlib.derived.example

open category_theory
open category_theory.limits

universes v u
variables {A : Type u} [category.{v} A] [abelian A] [has_coproducts.{v} A]

open_locale zero_object

namespace bounded_homotopy_category

noncomputable
def cofan {α : Type v} (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : cofan X := cofan.mk
{ val := (homotopy_category.colimit_cofan $ λ a : α, (X a).val).X,
  bdd := begin
    obtain ⟨n,hn⟩ := homotopy_category.is_uniformly_bounded_above.cond (val ∘ X),
      use n, intros i hi,
    dsimp [homotopy_category.colimit_cofan],
    let e : (∐ λ (a : α), (X a).val.as).X i ≅
      (∐ λ (a : α), (X a).val.as.X i) := homotopy_category.coproduct_iso _ _,
    refine is_zero_of_iso_of_zero _ e.symm,
    apply category_theory.is_zero_colimit,
    intros j,
    refine hn j.as _ hi,
  end }
(λ a, (homotopy_category.colimit_cofan (λ a : α, (X a).val)).ι.app ⟨a⟩)

noncomputable
def is_colimit_cofan {α : Type v} (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : is_colimit (cofan X) :=
{ desc := λ S, (homotopy_category.is_colimit_cofan
    (λ a : α, (X a).val)).desc ((forget A).map_cocone S),
  fac' := begin
    intros S j,
    erw (homotopy_category.is_colimit_cofan (λ a : α, (X a).val)).fac
      ((forget A).map_cocone S) j, refl,
  end,
  uniq' := begin
    intros S m hm,
    apply (homotopy_category.is_colimit_cofan (λ a : α, (X a).val)).hom_ext,
    intros j,
    specialize hm j,
    erw hm,
    erw (homotopy_category.is_colimit_cofan (λ a : α, (X a).val)).fac,
    refl,
  end }

instance has_coproduct_of_uniform_bound {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] :
  has_coproduct X :=
begin
  constructor, apply nonempty.intro,
  refine ⟨cofan X, is_colimit_cofan X⟩,
end

instance is_K_projective_sigma {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  [∀ a, homotopy_category.is_K_projective (X a).val] :
  homotopy_category.is_K_projective (sigma_obj X).val :=
begin
  let e : (sigma_obj X) ≅ (cofan X).X :=
    (colimit.is_colimit _).cocone_point_unique_up_to_iso (is_colimit_cofan X),
  let ee := (forget A).map_iso e,
  suffices : homotopy_category.is_K_projective ((forget A).obj (cofan X).X),
  { resetI, apply homotopy_category.is_K_projective_of_iso _ _ ee.symm },
  dsimp [forget, cofan],
  apply_instance,
end

noncomputable
instance forget_preserves_coproduct {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] :
  preserves_colimit (discrete.functor X) (forget A) :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone (is_colimit_cofan X),
  let E : (forget A).map_cocone (cofan X) ≅
    homotopy_category.colimit_cofan (val ∘ X) :=
    cocones.ext (iso.refl _) _,
  rotate,
  { intros a, dsimp [forget, cofan], simpa only [category.comp_id] },
  apply is_colimit.of_iso_colimit _ E.symm,
  apply homotopy_category.is_colimit_cofan,
end

lemma is_quasi_iso_sigma
  [AB4 A]
  {α : Type v}
  (X P : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  [uniformly_bounded P]
  (π : Π a, P a ⟶ X a)
  [∀ a, homotopy_category.is_quasi_iso (π a)] :
  homotopy_category.is_quasi_iso
    (sigma.desc $ λ a : α, π a ≫ sigma.ι X a : sigma_obj P ⟶ sigma_obj X) :=
begin
  let t := sigma.desc (λ (a : α), π a ≫ sigma.ι X a),
  change homotopy_category.is_quasi_iso ((forget A).map t),
  let eP : (forget A).obj (∐ P) ≅ ∐ (λ a, (forget A).obj (P a)) :=
    preserves_colimit_iso (forget A) _,
  let eX : (forget A).obj (∐ X) ≅ ∐ (λ a, (forget A).obj (X a)) :=
    preserves_colimit_iso (forget A) _,
  let s : ∐ (λ a, (forget A).obj (P a)) ⟶ ∐ (λ a, (forget A).obj (X a)) :=
    sigma.desc (λ (a : α), π a ≫ sigma.ι (val ∘ X) a),
  suffices : (forget A).map t = eP.hom ≫ s ≫ eX.inv,
  { rw this,
    apply homotopy_category.is_quasi_iso_comp },
  apply (is_colimit_of_preserves (forget A) (colimit.is_colimit _)).hom_ext,
  swap, apply_instance,
  intros a,
  dsimp [t, s, eP, eX, preserves_colimit_iso, is_colimit.cocone_point_unique_up_to_iso],
  rw [← (forget A).map_comp, colimit.ι_desc],
  slice_rhs 0 1
  { erw (is_colimit_of_preserves (forget A) (colimit.is_colimit (discrete.functor P))).fac },
  erw colimit.ι_desc,
  dsimp, simp only [category.assoc], erw colimit.ι_desc,
  dsimp, simp only [functor.map_comp], refl,
end

variables [enough_projectives A]

noncomputable
def uniform_π {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : sigma_obj (replace_uniformly X) ⟶ sigma_obj X :=
sigma.desc $ λ a, π_uniformly _ _ ≫ sigma.ι _ a

instance is_quasi_iso_sigma_map_π_uniformly
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] :
  homotopy_category.is_quasi_iso (uniform_π X) :=
is_quasi_iso_sigma _ _ _

open opposite

noncomputable
def Ext_coproduct_iso
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  (i : ℤ) (Y) :
  ((Ext i).obj (op (sigma_obj X))).obj Y ≅
  pi_obj (λ a : α, ((Ext i).obj (op (X a))).obj Y) :=
Ext_iso i _ _ _ (uniform_π X) ≪≫
category_theory.preadditive_yoneda_coproduct_iso (replace_uniformly X) (Y⟦i⟧) ≪≫
category_theory.pi_iso _ _ (λ a, (Ext_iso i _ _ _ (π_uniformly X a)).symm)

lemma ι_Ext_coprodut_iso
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  (i : ℤ) (Y) (j) :
  (Ext_coproduct_iso X i Y).inv ≫
  ((Ext i).map (sigma.ι X j : X j ⟶ ∐ X).op).app Y =
  pi.π _ _ :=
begin
  rw iso.inv_comp_eq,
  dsimp [Ext_coproduct_iso, pi_iso],
  simp only [category.assoc, limit.lift_π, fan.mk_π_app],
  simp only [← category.assoc], rw iso.eq_comp_inv,
  dsimp [Ext, Ext_iso], --ext t, simp only [comp_apply],
  dsimp [preadditive_yoneda_coproduct_iso, preadditive_yoneda_coproduct_to_product],
  simp only [category.assoc, limit.lift_π],
  ext t, simp only [comp_apply], dsimp,
  simp only [← category.assoc], congr' 1,
  apply lift_ext (∐ X).π, swap, apply_instance,
  dsimp [uniform_π],
  simp,
end

lemma ι_Ext_coproduct_iso'
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  (i : ℤ) (Y) (j) :
  (Ext_coproduct_iso X i Y).hom ≫  pi.π _ _ =
  ((Ext i).map (sigma.ι X j : X j ⟶ ∐ X).op).app Y :=
begin
  rw [← iso.eq_inv_comp, ι_Ext_coprodut_iso],
end

lemma Ext_coproduct_iso_naturality
  [AB4 A]
  {α : Type v}
  (X₁ X₂ : α → bounded_homotopy_category A)
  [uniformly_bounded X₁]
  [uniformly_bounded X₂]
  (g : X₁ ⟶ X₂)
  (i : ℤ) (Y) :
  ((Ext i).map (sigma.desc (λ b, g b ≫ sigma.ι X₂ b) : ∐ X₁ ⟶ ∐ X₂).op).app Y ≫
  (Ext_coproduct_iso _ _ _).hom =
  (Ext_coproduct_iso _ _ _).hom ≫
  pi.lift (λ b, pi.π _ b ≫ ((Ext i).map (g b).op).app Y) :=
begin
  dsimp only [Ext_coproduct_iso, Ext, Ext0, Ext_iso, functor.comp_map, whiskering_left,
    whisker_left, iso.trans_hom, functor.map_iso, preadditive_yoneda_coproduct_iso,
    functor.flip, pi_iso, as_iso, preadditive_yoneda_coproduct_to_product],
  simp only [category.assoc],
  simp only [quiver.hom.unop_op, iso.op_hom, replacement_iso_hom, iso.op_inv,
    replacement_iso_inv, iso.symm_mk],
  apply limit.hom_ext,
  intros j,
  simp only [category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π_assoc],
  simp only [← functor.map_comp, ← op_comp],
  congr' 2,
  simp only [category.assoc],
  apply lift_ext (∐ X₂).π, swap, apply_instance,
  dsimp [quiver.hom.unop_op],
  simp only [category.assoc, lift_lifts, lift_lifts_assoc],
  dsimp [uniform_π],
  simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc, colimit.ι_desc,
    lift_lifts_assoc],
end

lemma Ext_coproduct_iso_naturality'
  [AB4 A]
  {α : Type v}
  (X : α → bounded_homotopy_category A)
  [uniformly_bounded X]
  (i : ℤ) (Y₁ Y₂) (f : Y₁ ⟶ Y₂) :
  ((Ext i).obj (op (sigma_obj X))).map f ≫
  (Ext_coproduct_iso _ _ _).hom =
  (Ext_coproduct_iso _ _ _).hom ≫
  pi.lift (λ a, pi.π _ a ≫ ((Ext i).obj _).map f) :=
begin
  dsimp only [Ext_coproduct_iso, Ext, Ext0, Ext_iso, functor.comp_map, whiskering_left,
    whisker_left, iso.trans_hom, functor.map_iso, preadditive_yoneda_coproduct_iso,
    functor.flip, pi_iso, as_iso, preadditive_yoneda_coproduct_to_product,
    functor.comp_map, functor.comp_obj],
  simp only [category.assoc],
  simp only [quiver.hom.unop_op, iso.op_hom, replacement_iso_hom, iso.op_inv,
    replacement_iso_inv, iso.symm_mk],
  apply limit.hom_ext,
  intros j,
  simp only [category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π_assoc],
  erw nat_trans.naturality,
  erw nat_trans.naturality_assoc,
  erw nat_trans.naturality_assoc,
  refl,
end

end bounded_homotopy_category

-- TODO: find better names... And move this stuff!

instance chain_complex_embed_cofan_uniformly_bounded
  {α : Type v}
  (X : α → chain_complex A ℕ) :
  bounded_homotopy_category.uniformly_bounded
  (λ a, chain_complex.to_bounded_homotopy_category.obj (X a)) :=
begin
  constructor, use 1, intros a i hi,
  rcases i with (_|i)|_,
  { exfalso, revert hi, dec_trivial },
  { exact is_zero_zero _, },
  { exfalso, revert hi, dec_trivial }
end

universe u'

def whisker_discrete_functor {α : Type v}
  {C : Type u} {D : Type u'} [category.{v} C] [category.{v} D] (F : C ⥤ D)
  (X : α → C) : discrete.functor X ⋙ F ≅ discrete.functor (F.obj ∘ X) :=
  discrete.nat_iso (λ i, iso.refl _)

noncomputable
lemma preserves_coproducts_aux
  {α : Type v} {C : Type u} {D : Type u'}
  [category.{v} C] [category.{v} D]
  (F : C ⥤ D)
  [has_coproducts_of_shape α C]
  [∀ (X : α → C), has_coproduct (λ a, F.obj (X a))]
  (e : Π (X : α → C), F.obj (∐ X) ≅ ∐ (λ a, F.obj (X a)))
  (he : ∀ (X : α → C) (a : α), F.map (sigma.ι X a) ≫ (e X).hom = sigma.ι _ a) :
  preserves_colimits_of_shape (discrete α) F :=
begin
  constructor, intros K,
  let E : K ≅ discrete.functor (K.obj ∘ discrete.mk) := discrete.nat_iso (λ ⟨a⟩, iso.refl _),
  apply preserves_colimit_of_iso_diagram _ E.symm,
  apply preserves_colimit_of_preserves_colimit_cocone (colimit.is_colimit _),
  swap, apply_instance,
  let P := _, change is_colimit P,
  let P' := (cocones.precompose (whisker_discrete_functor F _).inv).obj P,
  suffices : is_colimit P',
  { exact is_colimit.precompose_inv_equiv _ _ this },
  apply is_colimit.of_iso_colimit (colimit.is_colimit _), swap,
  change has_colimit (discrete.functor (λ a : α, F.obj (K.obj ⟨a⟩))),
  apply_instance,
  symmetry,
  fapply cocones.ext,
  apply e,
  rintro ⟨a⟩,
  convert (he (λ b, (K.obj ⟨b⟩))) a,
  dsimp [P', whisker_discrete_functor],
  rw category.id_comp,
end

noncomputable
instance homological_complex_embed_preserves_coproducts {α : Type v}
  {M N : Type} (c₁ : complex_shape M) (c₂ : complex_shape N) (e : c₁.embedding c₂) :
  preserves_colimits_of_shape (discrete α)
  (homological_complex.embed e : homological_complex A _ ⥤ _) :=
preserves_coproducts_aux
(homological_complex.embed e : homological_complex A _ ⥤ _)
(λ (X : α → homological_complex A c₁), homological_complex.hom.iso_of_components
(λ i,
begin
  rcases h : e.r i with _ | j,
  { refine homological_complex.embed.X_iso_of_none _ h ≪≫ _,
    refine _ ≪≫ (preserves_colimit_iso (homological_complex.eval A c₂ i) _).symm,
    refine (is_zero.iso_zero _).symm,
    apply is_zero_colimit,
    intros a,
    dsimp,
    exact homological_complex.embed.X_is_zero_of_none _ h },
  { refine homological_complex.embed.X_iso_of_some _ h ≪≫ _,
    refine (preserves_colimit_iso (homological_complex.eval _ _ _) _) ≪≫ _,
    refine _ ≪≫ (preserves_colimit_iso (homological_complex.eval _ _ _) _).symm,
    refine has_colimit.iso_of_nat_iso _,
    refine discrete.nat_iso _,
    intros b,
    dsimp,
    refine (homological_complex.embed.X_iso_of_some _ h).symm }
end) begin
  intros i j h,
  rcases h₁ : e.r i with _ | i';
  rcases h₂ : e.r j with _ | j',
  { apply is_zero.eq_of_src,
    apply homological_complex.embed.X_is_zero_of_none,
    assumption },
  { apply is_zero.eq_of_src,
    apply homological_complex.embed.X_is_zero_of_none,
    assumption },
  { apply is_zero.eq_of_tgt,
    refine is_zero.of_iso _
      (preserves_colimit_iso (homological_complex.eval _ _ _) _),
    apply is_zero_colimit, intros b,
    apply homological_complex.embed.X_is_zero_of_none,
    assumption },
  { simp_rw [h₁, h₂], dsimp,
    simp only [category.assoc],
    rw ← iso.eq_inv_comp,
    dsimp [homological_complex.embed, homological_complex.embed.obj],
    rw homological_complex.embed.d_of_some_of_some (∐ X) h₁ h₂,
    simp only [category.assoc, iso.inv_hom_id_assoc],
    apply (is_colimit_of_preserves (homological_complex.eval A c₁ i') _).hom_ext,
    rintro ⟨a⟩,
    simp only [functor.map_cocone_ι_app, colimit.cocone_ι, homological_complex.eval_map],
    slice_lhs 1 2 {
      erw (is_colimit_of_preserves (homological_complex.eval A c₁ i') _).fac },
    dsimp,
    simp only [has_colimit.iso_of_nat_iso_ι_hom, discrete.nat_iso_hom_app, iso.symm_hom,
      category.assoc, ι_preserves_colimits_iso_inv, homological_complex.eval_map,
      homological_complex.hom.comm, homological_complex.hom.comm_assoc],
    dsimp,
    rw iso.inv_comp_eq,
    slice_rhs 3 4
    { erw (is_colimit_of_preserves (homological_complex.eval A c₁ j') _).fac },
    dsimp,
    simp only [has_colimit.iso_of_nat_iso_ι_hom, discrete.nat_iso_hom_app, iso.symm_hom,
      category.assoc, ι_preserves_colimits_iso_inv, homological_complex.eval_map],
    slice_rhs 1 3
    { erw ← homological_complex.embed.d_of_some_of_some (X a) h₁ h₂ },
    apply colimit.is_colimit,
    apply_instance, }
    -- still annoying
  end)
begin
  intros X a, ext i,
  rcases h : e.r i with _ | i',
  { apply is_zero.eq_of_tgt,
    refine is_zero.of_iso _
      (preserves_colimit_iso (homological_complex.eval _ _ _) _),
    apply is_zero_colimit, intros b,
    apply homological_complex.embed.X_is_zero_of_none,
    exact h },
  dsimp [homological_complex.hom.iso_of_components],
  simp_rw [h], dsimp,
  simp only [← category.assoc, iso.comp_inv_eq],
  simp_rw [← iso.eq_comp_inv, category.assoc],
  slice_rhs 1 2
  { erw (is_colimit_of_preserves (homological_complex.eval A c₂ i) _).fac },
  dsimp,
  simp only [has_colimit.iso_of_nat_iso_ι_inv, discrete.nat_iso_inv_app, iso.symm_inv,
    category.assoc, ι_preserves_colimits_iso_inv, homological_complex.eval_map],
  apply homological_complex.embed.f_of_some,
end

noncomputable
def embed_coproduct_iso
  {α : Type v}
  (X : α → chain_complex A ℕ) :
  (homological_complex.embed complex_shape.embedding.nat_down_int_up).obj (∐ X) ≅
  (∐ λ (a : α), (homological_complex.embed complex_shape.embedding.nat_down_int_up).obj (X a)) :=
preserves_colimit_iso (homological_complex.embed complex_shape.embedding.nat_down_int_up) _ ≪≫
has_colimit.iso_of_nat_iso (whisker_discrete_functor _ _)

noncomputable
def chain_complex_embed_cofan_iso
  {α : Type v}
  (X : α → chain_complex A ℕ) :
  (bounded_homotopy_category.cofan
    (λ a, chain_complex.to_bounded_homotopy_category.obj (X a))) ≅
    ((cocones.precompose (whisker_discrete_functor _ X).inv).obj
    (chain_complex.to_bounded_homotopy_category.map_cocone
      (colimit.cocone (discrete.functor X)))) :=
cocones.ext
(bounded_homotopy_category.mk_iso $
  (homotopy_category.quotient _ _).map_iso $ (embed_coproduct_iso X).symm)
begin
  rintro ⟨a⟩,
  dsimp [bounded_homotopy_category.cofan,
    homotopy_category.colimit_cofan, whisker_discrete_functor],
  erw [category.id_comp, ← functor.map_comp],
  congr' 1,
  dsimp [embed_coproduct_iso],
  simp only [category.assoc],
  erw colimit.ι_desc_assoc,
  rw iso.comp_inv_eq,
  erw (is_colimit_of_preserves
    (homological_complex.embed complex_shape.embedding.nat_down_int_up) _).fac,
  dsimp [whisker_discrete_functor],
  rw category.id_comp,
end

noncomputable
instance chain_complex_to_bounded_homotopy_category_preserves_coproducts
  {α : Type v} :
  preserves_colimits_of_shape (discrete α)
  (chain_complex.to_bounded_homotopy_category : chain_complex A _ ⥤ _) :=
begin
  constructor, intros K,
  let E : K ≅ discrete.functor (K.obj ∘ discrete.mk) := discrete.nat_iso (λ ⟨a⟩, iso.refl _),
  apply preserves_colimit_of_iso_diagram _ E.symm,
  apply preserves_colimit_of_preserves_colimit_cocone (colimit.is_colimit _),
  let Q : α → bounded_homotopy_category A := λ a,
    chain_complex.to_bounded_homotopy_category.obj (K.obj ⟨a⟩),
  let P := _, change is_colimit P,
  let T : discrete.functor (K.obj ∘ discrete.mk) ⋙ chain_complex.to_bounded_homotopy_category ≅
    discrete.functor Q := discrete.nat_iso (λ _, iso.refl _),
  let P' := (cocones.precompose T.inv).obj P,
  suffices : is_colimit P',
  { exact is_colimit.precompose_inv_equiv _ _ this },
  apply is_colimit.of_iso_colimit (bounded_homotopy_category.is_colimit_cofan Q),
  swap, apply_instance,
  apply chain_complex_embed_cofan_iso,
end


import Logic.Predicate.FirstOrder.Semantics

universe u v

section

variable {L : Language.{u}} {μ : Type v}
 {I : Type u} (A : I → Type u) [(ι : I) → Inhabited (A ι)] [s : (ι : I) → FirstOrder.Structure L (A ι)] (𝓤 : Ultrafilter I)

namespace FirstOrder

namespace Structure

structure Uprod (𝓤 : Ultrafilter I) where
  val : (i : I) → A i

instance UprodStruc : Structure.{u,u} L (Uprod A 𝓤) where
  func := fun f v => ⟨fun ι => (s ι).func f (fun i => (v i).val ι)⟩
  rel  := fun r v => {ι | (s ι).rel r (fun i => (v i).val ι)} ∈ 𝓤

instance [Inhabited I] [(ι : I) → Inhabited (A ι)] : Inhabited (Uprod A 𝓤) := ⟨⟨default⟩⟩

@[simp] lemma func_Uprod {k} (f : L.func k) (v : Fin k → Uprod A 𝓤) :
    func f v = ⟨fun ι => (s ι).func f (fun i => (v i).val ι)⟩ := rfl

@[simp] lemma rel_Uprod {k} (r : L.rel k) (v : Fin k → Uprod A 𝓤) :
    rel r v ↔ {ι | (s ι).rel r (fun i => (v i).val ι)} ∈ 𝓤 := of_eq rfl

end Structure

end FirstOrder

namespace SubTerm

open FirstOrder Structure

variable (e : Fin n → Uprod A 𝓤) (ε : μ → Uprod A 𝓤)

lemma val_Uprod (t : SubTerm L μ n) :
    t.val! (Uprod A 𝓤) e ε = ⟨fun ι => t.val (s ι) (fun i => (e i).val ι) (fun i => (ε i).val ι)⟩ :=
  by induction t <;> simp[*, val_func]

end SubTerm

namespace FirstOrder

open Structure

variable {A} {𝓤}

namespace SubFormula
variable {e : Fin n → Uprod A 𝓤} {ε : μ → Uprod A 𝓤}

lemma val_vecCons_val_eq {z : Uprod A 𝓤} {ι : I} :
    (z.val ι :> fun i => (e i).val ι) = (fun i => ((z :> e) i).val ι) :=
  by simp[Matrix.comp_vecCons (Uprod.val · ι), Function.comp]

lemma eval_Uprod {p : SubFormula L μ n} :
    Eval! (Uprod A 𝓤) e ε p ↔ {ι | Eval (s ι) (fun i => (e i).val ι) (fun i => (ε i).val ι) p} ∈ 𝓤 := by
  induction p using rec' <;>
  simp[*, Prop.top_eq_true, Prop.bot_eq_false, eval_rel, eval_nrel, SubTerm.val_Uprod]
  case hverum => exact Filter.univ_mem
  case hnrel k r v =>
    exact Ultrafilter.compl_mem_iff_not_mem.symm
  case hand =>
    exact Filter.inter_mem_iff.symm
  case hor p q ihp ihq =>
    exact Ultrafilter.union_mem_iff.symm
  case hall p _ =>
    constructor
    · intro h
      let z : Uprod A 𝓤 := ⟨fun ι =>
        Classical.epsilon (fun z => ¬Eval (s ι) (z :> fun i => (e i).val ι) (fun i => (ε i).val ι) p)⟩
      exact Filter.mem_of_superset (h z) (by
        intro ι hι a
        have : Eval (s ι) (z.val ι :> fun i => (e i).val ι) (fun i => (ε i).val ι) p :=
          by rw [val_vecCons_val_eq]; exact hι
        by_contra hc
        have : ¬Eval! (A ι) (z.val ι :> fun i => (e i).val ι) (fun i => (ε i).val ι) p :=
          Classical.epsilon_spec (p := fun z => ¬(Eval (s ι) (z :> fun i => (e i).val ι) _ p)) ⟨a, hc⟩
        contradiction)
    · intro h x
      exact Filter.mem_of_superset h (by intro ι h; simpa [val_vecCons_val_eq] using h (x.val ι))
  case hex p _ =>
    constructor
    · rintro ⟨x, hx⟩
      exact Filter.mem_of_superset hx (by intro ι h; use x.val ι; simpa[val_vecCons_val_eq] using h)
    · intro h
      let z : Uprod A 𝓤 := ⟨fun ι =>
        Classical.epsilon (fun z => Eval (s ι) (z :> fun i => (e i).val ι) (fun i => (ε i).val ι) p)⟩
      use z
      exact Filter.mem_of_superset h (by
        intro ι; rintro ⟨x, hx⟩
        have : Eval (s ι) (z.val ι :> fun i => (e i).val ι) (fun i => (ε i).val ι) p :=
          Classical.epsilon_spec (p := fun z => Eval (s ι) (z :> fun i => (e i).val ι) _ p) ⟨x, hx⟩
        rw[val_vecCons_val_eq] at this; exact this)

lemma val_Uprod {p : Formula L μ} :
    Val! (Uprod A 𝓤) ε p ↔ {ι | Val (s ι) (fun i => (ε i).val ι) p} ∈ 𝓤 :=
  by simp[Val, eval_Uprod, Matrix.empty_eq]

end SubFormula

lemma realize_Uprod {σ : Sentence L} :
    (Uprod A 𝓤) ⊧₁ σ ↔ {ι | Semantics.realize (self := semantics) (s ι) σ} ∈ 𝓤 :=
  by simp[realize_def, SubFormula.val_Uprod, Empty.eq_elim]

variable (A)

def SubFormula.domain (σ : Sentence L) := {ι | (A ι) ⊧₁ σ}

end FirstOrder

end

section

namespace FirstOrder

variable {L : Language.{u}} {T : CTheory L}

abbrev FinSubTheory (T : CTheory L) := {t : Finset (Sentence L) // ↑t ⊆ T}

variable (A : FinSubTheory T → Type u) [s : (ι : FinSubTheory T) → Structure L (A ι)]

instance : Inhabited (FinSubTheory T) := ⟨∅, by simp⟩

attribute [instance] Classical.propDecidable in
lemma ultrafilter_exists (H : ∀ (ι : FinSubTheory T), (A ι) ⊧₁* (ι.val : CTheory L)) :
    ∃ 𝓤 : Ultrafilter (FinSubTheory T), Set.image (SubFormula.domain A) T ⊆ 𝓤.sets :=
  Ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ (by
    simp[Finset.subset_image_iff, SubFormula.domain]
    intro t ht
    use t; use ht
    intro σ hσ
    exact H ⟨t, ht⟩ hσ)

theorem compactness :
    Semantics.Satisfiableₛ T ↔ ∀ ι : FinSubTheory T, Semantics.Satisfiableₛ (ι.val : CTheory L) := by
  constructor
  · rintro h ⟨t, ht⟩; exact Semantics.satisfiableₛ_of_subset h ht
  · intro h
    have : ∀ ι : FinSubTheory T, ∃ (M : Type u) (_ : Inhabited M) (_ : Structure L M), M ⊧₁* (ι.val : CTheory L) :=
      by intro ι; exact satisfiableₛ_iff.mp (h ι)
    choose A si s hA using this
    have : ∃ 𝓤 : Ultrafilter (FinSubTheory T), Set.image (SubFormula.domain A) T ⊆ 𝓤.sets := ultrafilter_exists A hA
    rcases this with ⟨𝓤, h𝓤⟩
    have : Structure.Uprod A 𝓤 ⊧₁* T := by intro σ hσ; exact realize_Uprod.mpr (h𝓤 $ Set.mem_image_of_mem (SubFormula.domain A) hσ)
    exact satisfiableₛ_intro (Structure.Uprod A 𝓤) this

end FirstOrder

end


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Patrick Massot, Scott Morrison, Mario Carneiro

import category_theory.full_subcategory
import category_theory.functor_category
import category_theory.natural_isomorphism
import analysis.topology.topological_space
import analysis.topology.continuity

open category_theory
open category_theory.nat_iso

universe u

namespace category_theory.examples

/-- The category of topological spaces and continuous maps. -/
@[reducible] def Top : Type (u+1) := bundled topological_space

instance (x : Top) : topological_space x := x.str

namespace Top
instance : concrete_category @continuous := ⟨@continuous_id, @continuous.comp⟩

-- local attribute [class] continuous
-- instance {R S : Top} (f : R ⟶ S) : continuous (f : R → S) := f.2
end Top

structure open_set (X : Top.{u}) : Type u :=
(s : set X.α)
(is_open : topological_space.is_open X.str s)

variables {X : Top.{u}}

namespace open_set
instance : has_coe (open_set X) (set X.α) := { coe := λ U, U.s }

instance : has_subset (open_set X) :=
{ subset := λ U V, U.s ⊆ V.s }

instance : preorder (open_set X) := by refine { le := (⊇), .. } ; tidy

instance open_sets : small_category (open_set X) := by apply_instance

instance : has_mem X.α (open_set X) :=
{ mem := λ a V, a ∈ V.s }

def nbhd (x : X.α) := { U : open_set X // x ∈ U }
def nbhds (x : X.α) : small_category (nbhd x) := begin unfold nbhd, apply_instance end

/-- `open_set.map f` gives the functor from open sets in Y to open set in X,
    given by taking preimages under f. -/
def map
  {X Y : Top.{u}} (f : X ⟶ Y) : open_set Y ⥤ open_set X :=
{ obj := λ U, ⟨ f.val ⁻¹' U.s, f.property _ U.is_open ⟩,
  map' := λ U V i, ⟨ ⟨ λ a b, i.down.down b ⟩ ⟩ }.

@[simp] lemma map_id_obj (X : Top.{u}) (U : open_set X) : map (𝟙 X) U = U :=
begin
  cases U, tidy
end

@[simp] def map_id (X : Top.{u}) : map (𝟙 X) ≅ functor.id (open_set X) :=
{ hom := { app := λ U, 𝟙 U },
  inv := { app := λ U, 𝟙 U } }

-- We could make f g implicit here, but it's nice to be able to see when they are the identity (often!)
def map_iso {X Y : Top.{u}} (f g : X ⟶ Y) (h : f = g) : map f ≅ map g :=
nat_iso.of_components (λ U, eq_to_iso (congr_fun (congr_arg _ (congr_arg _ h)) _) ) (by obviously)

@[simp] def map_iso_id {X : Top.{u}} (h) : map_iso (𝟙 X) (𝟙 X) h = iso.refl (map _) := rfl

end open_set

end category_theory.examples


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

import category_theory.graphs.category

-- FIXME why do we need this here?
@[obviously] meta def obviously_4 := tactic.tidy { tactics := extended_tidy_tactics }

open category_theory
open category_theory.graphs

universes v₁ v₂ u₁ u₂

namespace category_theory.graphs

def paths (C : Type u₂) := C

instance paths_category (C : Type u₁) [graph.{v₁} C] : category.{(max u₁ v₁)+1} (paths C) :=
{ hom     := λ x y : C, path x y,
  id      := λ x, path.nil x,
  comp    := λ _ _ _ f g, concatenate_paths f g,
  comp_id' := begin
              tidy,
              induction f, -- PROJECT think about how to automate an inductive step. When can you be sure it's a good idea?
              obviously,
             end,
  assoc'  := begin
              tidy,
              induction f,
              obviously,
            end }.

instance paths_small_category (C : Type u₁) [graph.{u₁ u₁} C] : small_category (paths C) := graphs.paths_category C

variables {C : Type u₂} [𝒞 : category.{v₂} C] {G : Type u₁} [𝒢 : graph.{v₁} G]
include 𝒢 𝒞

@[simp] def path_to_morphism
  (H : graph_hom G C)
  : Π {X Y : G}, path X Y → ((H.onVertices X) ⟶ (H.onVertices Y))
| ._ ._ (path.nil Z)              := 𝟙 (H.onVertices Z)
| ._ ._ (@path.cons ._ _ _ _ _ e p) := (H.onEdges e) ≫ (path_to_morphism p)

@[simp] lemma path_to_morphism.comp (H : graph_hom G C) {X Y Z : paths G} (f : X ⟶ Y) (g : Y ⟶ Z) : path_to_morphism H (f ≫ g) = path_to_morphism H f ≫ path_to_morphism H g :=
begin
  induction f,
  obviously,
end

end category_theory.graphs

namespace category_theory.functor

open category_theory.graphs

variables {C : Type u₂} [𝒞 : category.{v₂} C] {G : Type u₁} [𝒢 : graph.{v₁} G]
include 𝒢 𝒞

-- PROJECT obtain this as the left adjoint to the forgetful functor.
@[simp] def of_graph_hom (H : graph_hom G C) : (paths G) ⥤ C :=
{ obj := λ X, (H.onVertices X),
  map := λ _ _ f, (path_to_morphism H f) }

end category_theory.functor


import Duper.MClause
import Duper.RuleM
import Duper.Simp
import Duper.Util.ProofReconstruction

-- LoobHoist          BoolHoist
--             C<u>
-- -----------------------------
-- C<⊤> ∨ u = ⊥     C<⊥> ∨ u = ⊤
--
-- where u is of type Prop, but neither ⊥ nor ⊤, and u is not at the top level of a positive literal.

namespace Duper
open Lean
open RuleM
open Meta
open SimpResult

initialize Lean.registerTraceClass `Rule.identBoolHoist

theorem loob_hoist_proof (f : Prop → Prop) (e : Prop) (H : f e) : f True ∨ e = False :=
  @Classical.byCases e _
    (fun p => have h : e = True := by simp [p];
              Or.inl (h ▸ H))
    (fun np => by simp [np])

theorem bool_hoist_proof (f : Prop → Prop) (e : Prop) (H : f e) : f False ∨ e = True :=
  @Classical.byCases e _
    (fun p => by simp [p])
    (fun np => have h : e = False := by simp [np];
               Or.inl (h ▸ H))

def mkBoolHoistProof (pos : ClausePos) (sgn : Bool) (premises : List Expr)
  (parents : List ProofParent) (transferExprs : Array Expr) (c : Clause) : MetaM Expr :=
  Meta.forallTelescope c.toForallExpr fun xs body => do
    let cLits := c.lits.map (fun l => l.map (fun e => e.instantiateRev xs))
    let (parentsLits, appliedPremises, transferExprs) ← instantiatePremises parents premises xs transferExprs
    let parentLits := parentsLits[0]!
    let appliedPremise := appliedPremises[0]!

    let i := pos.lit
    let ⟨s, p⟩ := pos.toLitPos

    let mut caseProofs := Array.mkEmpty parentLits.size
    for j in [:parentLits.size] do
      let lit := parentLits[j]!
      if j == i then
        let lp : LitPos := ⟨s, p⟩
        let f ← Meta.withLocalDeclD `h (.sort .zero) fun h => do
          let lit' ← lit.replaceAtPos! lp h
          let f := lit'.toExpr
          Meta.mkLambdaFVars #[h] f
        let e ← lit.getAtPos! lp
        let pr ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          let mut pr := h
          if sgn then
            pr ← Meta.mkAppM ``loob_hoist_proof #[f, e, h]
          else
            pr ← Meta.mkAppM ``bool_hoist_proof #[f, e, h]
          Meta.mkLambdaFVars #[h] $ ← orSubclause (cLits.map Lit.toExpr) 2 pr
        caseProofs := caseProofs.push pr
      else
        -- need proof of `L_j → L_1 ∨ ... ∨ L_n`
        let pr ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          let idx := if j ≥ i then j - 1 else j
          Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) idx h
        caseProofs := caseProofs.push pr

    let r ← orCases (parentLits.map Lit.toExpr) caseProofs
    Meta.mkLambdaFVars xs $ mkApp r appliedPremise

def identBoolHoistAtExpr (e : Expr) (pos : ClausePos) (c : MClause) : RuleM (Option (Array (Clause × Proof))) :=
  withoutModifyingMCtx do
    let ty ← inferType e
    if ty == .sort .zero then
      let l := pos.lit
      let ⟨s, p⟩ := pos.toLitPos
      trace[Rule.identBoolHoist] m!"Inspecting position {pos} in clause {c.lits.map Lit.toExpr}"
      let is_true := e == (mkConst ``True)
      let is_false := e == (mkConst ``False)
      let is_top_positive := p.size == 0 ∧ c.lits[l]!.sign
      if is_true ∨ is_false ∨ is_top_positive then
        return none
      else
        trace[Rule.identBoolHoist] m!"BoolHoist at literal {l}, side {s}, position {p} in clause {c.lits.map Lit.toExpr}"
        let litl := c.lits[l]!
        let c_erased := c.eraseLit l
        let nc := c_erased.appendLits
          #[← litl.replaceAtPos! ⟨s, p⟩ (mkConst ``True), Lit.fromSingleExpr e false]
        trace[Rule.identBoolHoist] s!"New Clause: {nc.lits.map Lit.toExpr}"
        let cp1 ← yieldClause nc "identity loobHoist" (some (mkBoolHoistProof pos true))
        let nc := c_erased.appendLits
          #[← litl.replaceAtPos! ⟨s, p⟩ (mkConst ``False), Lit.fromSingleExpr e true]
        trace[Rule.identBoolHoist] s!"New Clause: {nc.lits.map Lit.toExpr}"
        let cp2 ← yieldClause nc "identity boolHoist" (some (mkBoolHoistProof pos false))
        return some #[cp1, cp2]
    else
      return none

def identBoolHoist : MSimpRule := fun c => do
  let c ← loadClause c
  let fold_fn := fun acc e pos => do
    match acc with
    | some res => return some res
    | none => identBoolHoistAtExpr e pos c
  c.foldGreenM fold_fn none


import for_mathlib.derived_functor
import category_theory.abelian.left_derived

universes w v u

noncomputable theory

namespace category_theory.abelian.functor

open category_theory category_theory.functor category_theory.limits
open category_theory.functor.left_derived

variables {C : Type u} {D : Type u} [category.{w} C] [category.{w} D] [enough_projectives C]
variables (F : C ⥤ D) {A₁ A₂ A₃ X : C} {f : A₁ ⟶ A₂} {g : A₂ ⟶ A₃}
variables [abelian C] [abelian D] [additive F] [preserves_finite_colimits F]

section les

def δ₀ (A : short_exact_sequence C) := δ F 0 A ≫ (left_derived_zero_iso_self F).hom.app A.1

lemma seven_term_exact_seq (A : short_exact_sequence C) :
  exact_seq D [
    (F.left_derived 1).map A.f, (F.left_derived 1).map A.g,
    δ₀ F A,
    F.map A.f, F.map A.g, (0 : F.obj A.3 ⟶ F.obj A.3)] :=
begin
  refine exact_seq.cons _ _ (exact_of_short_exact _ _ _) _ (exact_seq.cons _ _ _ _ _),
  { refine preadditive.exact_of_iso_of_exact' ((F.left_derived 1).map A.g) (δ F 0 A) _ _
      (iso.refl _) (iso.refl _) ((left_derived_zero_iso_self F).app A.1) (by simp) _ _,
    { dsimp [δ₀], rw [category.id_comp] },
    { exact (exact_iff_exact_seq _ _).2 ((six_term_exact_seq F 0 A).extract 1 2) } },
  refine exact_seq.cons _ _ _ _ _,
  { refine preadditive.exact_of_iso_of_exact' (δ F 0 A) ((F.left_derived 0).map A.f) _ _
      (iso.refl _) ((left_derived_zero_iso_self F).app A.1) ((left_derived_zero_iso_self F).app A.2)
      _ (by simp) _,
    { dsimp [δ₀], rw [category.id_comp] },
    { exact (exact_iff_exact_seq _ _).2 ((six_term_exact_seq F 0 A).extract 2 2) } },
    apply exact_seq.cons,
    { exact preserves_exact_of_preserves_finite_colimits_of_epi _ A.exact' },
    { rw [← exact_iff_exact_seq],
      exact ((abelian.tfae_epi (F.obj A.3) (F.map A.g)).out 0 2).1 infer_instance, }
end

end les

end category_theory.abelian.functor


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.AffineScheme
import ring_theory.nilpotent
import topology.sheaves.sheaf_condition.sites
import category_theory.limits.constructions.binary_products
import algebra.category.CommRing.constructions
import ring_theory.integral_domain
import ring_theory.local_properties

/-!
# Basic properties of schemes

We provide some basic properties of schemes

## Main definition
* `algebraic_geometry.is_integral`: A scheme is integral if it is nontrivial and all nontrivial
  components of the structure sheaf are integral domains.
* `algebraic_geometry.is_reduced`: A scheme is reduced if all the components of the structure sheaf
  is reduced.
-/

open topological_space opposite category_theory category_theory.limits Top

namespace algebraic_geometry

variable (X : Scheme)

instance : t0_space X.carrier :=
begin
  rw t0_space_iff_distinguishable,
  intros x y h h',
  obtain ⟨U, R, ⟨e⟩⟩ := X.local_affine x,
  have hy := (h' _ U.1.2).mp U.2,
  erw ← subtype_indistinguishable_iff (⟨x, U.2⟩ : U.1.1) (⟨y, hy⟩ : U.1.1) at h',
  let e' : U.1 ≃ₜ prime_spectrum R :=
    homeo_of_iso ((LocallyRingedSpace.forget_to_SheafedSpace ⋙ SheafedSpace.forget _).map_iso e),
  have := t0_space_of_injective_of_continuous e'.injective e'.continuous,
  rw t0_space_iff_distinguishable at this,
  exact this ⟨x, U.2⟩ ⟨y, hy⟩ (by simpa using h) h'
end

instance : quasi_sober X.carrier :=
begin
  apply_with (quasi_sober_of_open_cover
    (set.range (λ x, set.range $ (X.affine_cover.map x).1.base)))
    { instances := ff },
  { rintro ⟨_,i,rfl⟩, exact (X.affine_cover.is_open i).base_open.open_range },
  { rintro ⟨_,i,rfl⟩,
    exact @@open_embedding.quasi_sober _ _ _
      (homeomorph.of_embedding _ (X.affine_cover.is_open i).base_open.to_embedding)
      .symm.open_embedding prime_spectrum.quasi_sober },
  { rw [set.top_eq_univ, set.sUnion_range, set.eq_univ_iff_forall],
    intro x, exact ⟨_, ⟨_, rfl⟩, X.affine_cover.covers x⟩ }
end

/-- A scheme `X` is reduced if all `𝒪ₓ(U)` are reduced. -/
class is_reduced : Prop :=
(component_reduced : ∀ U, _root_.is_reduced (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_reduced.component_reduced

lemma is_reduced_of_stalk_is_reduced [∀ x : X.carrier, _root_.is_reduced (X.presheaf.stalk x)] :
  is_reduced X :=
begin
  refine ⟨λ U, ⟨λ s hs, _⟩⟩,
  apply presheaf.section_ext X.sheaf U s 0,
  intro x,
  rw ring_hom.map_zero,
  change X.presheaf.germ x s = 0,
  exact (hs.map _).eq_zero
end

instance stalk_is_reduced_of_reduced [is_reduced X] (x : X.carrier) :
  _root_.is_reduced (X.presheaf.stalk x) :=
begin
  constructor,
  rintros g ⟨n, e⟩,
  obtain ⟨U, hxU, s, rfl⟩ := X.presheaf.germ_exist x g,
  rw [← map_pow, ← map_zero (X.presheaf.germ ⟨x, hxU⟩)] at e,
  obtain ⟨V, hxV, iU, iV, e'⟩ := X.presheaf.germ_eq x hxU hxU _ 0 e,
  rw [map_pow, map_zero] at e',
  replace e' := (is_nilpotent.mk _ _ e').eq_zero,
  erw ← concrete_category.congr_hom (X.presheaf.germ_res iU ⟨x, hxV⟩) s,
  rw [comp_apply, e', map_zero]
end

lemma is_reduced_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_reduced Y] : is_reduced X :=
begin
  constructor,
  intro U,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  exact is_reduced_of_injective (inv $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U))
    (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) : Y.presheaf.obj _ ≅ _).symm
      .CommRing_iso_to_ring_equiv.injective
end

instance {R : CommRing} [H : _root_.is_reduced R] : is_reduced (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_reduced_of_stalk_is_reduced { instances := ff },
  intro x, dsimp,
  haveI : _root_.is_reduced (CommRing.of $ localization.at_prime (prime_spectrum.as_ideal x)),
  { dsimp, apply_instance },
  exact is_reduced_of_injective (structure_sheaf.stalk_iso R x).hom
    (structure_sheaf.stalk_iso R x).CommRing_iso_to_ring_equiv.injective,
end

lemma affine_is_reduced_iff (R : CommRing) :
  is_reduced (Scheme.Spec.obj $ op R) ↔ _root_.is_reduced R :=
begin
  refine ⟨_, λ h, by exactI infer_instance⟩,
  intro h,
  resetI,
  haveI : _root_.is_reduced (LocallyRingedSpace.Γ.obj (op $ Spec.to_LocallyRingedSpace.obj $ op R)),
  { change _root_.is_reduced ((Scheme.Spec.obj $ op R).presheaf.obj $ op ⊤), apply_instance },
  exact is_reduced_of_injective (to_Spec_Γ R)
    ((as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv.injective)
end

lemma is_reduced_of_is_affine_is_reduced [is_affine X]
  [h : _root_.is_reduced (X.presheaf.obj (op ⊤))] : is_reduced X :=
begin
  haveI : is_reduced (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_reduced_iff, exact h },
  exact is_reduced_of_open_immersion X.iso_Spec.hom,
end

/-- To show that a statement `P` holds for all open subsets of all schemes, it suffices to show that
1. In any scheme `X`, if `P` holds for an open cover of `U`, then `P` holds for `U`.
2. For an open immerison `f : X ⟶ Y`, if `P` holds for the entire space of `X`, then `P` holds for
  the image of `f`.
3. `P` holds for the entire space of an affine scheme.
-/
lemma reduce_to_affine_global (P : ∀ (X : Scheme) (U : opens X.carrier), Prop)
  (h₁ : ∀ (X : Scheme) (U : opens X.carrier),
    (∀ (x : U), ∃ {V} (h : x.1 ∈ V) (i : V ⟶ U), P X V) → P X U)
  (h₂ : ∀ {X Y} (f : X ⟶ Y) [hf : is_open_immersion f], ∃ {U : set X.carrier} {V : set Y.carrier}
    (hU : U = ⊤) (hV : V = set.range f.1.base), P X ⟨U, hU.symm ▸ is_open_univ⟩ →
      P Y ⟨V, hV.symm ▸ hf.base_open.open_range⟩)
  (h₃ : ∀ (R : CommRing), P (Scheme.Spec.obj $ op R) ⊤) :
  ∀ (X : Scheme) (U : opens X.carrier), P X U :=
begin
  intros X U,
  apply h₁,
  intro x,
  obtain ⟨_,⟨j,rfl⟩,hx,i⟩ := X.affine_basis_cover_is_basis.exists_subset_of_mem_open x.prop U.2,
  let U' : opens _ := ⟨_, (X.affine_basis_cover.is_open j).base_open.open_range⟩,
  let i' : U' ⟶ U :=
    hom_of_le i,
  refine ⟨U', hx, i', _⟩,
  obtain ⟨_,_,rfl,rfl,h₂'⟩ := h₂ (X.affine_basis_cover.map j),
  apply h₂',
  apply h₃
end
.

lemma eq_zero_of_basic_open_empty {X : Scheme} [hX : is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj (op U)) (hs : X.basic_open s = ∅) :
  s = 0 :=
begin
  apply Top.presheaf.section_ext X.sheaf U,
  simp_rw ring_hom.map_zero,
  unfreezingI { revert X U hX s },
  refine reduce_to_affine_global _ _ _ _,
  { intros X U hx hX s hs x,
    obtain ⟨V, hx, i, H⟩ := hx x,
    unfreezingI { specialize H (X.presheaf.map i.op s) },
    erw Scheme.basic_open_res at H,
    rw [hs, ← subtype.coe_injective.eq_iff, opens.empty_eq, opens.inter_eq, inf_bot_eq] at H,
    specialize H rfl ⟨x, hx⟩,
    erw Top.presheaf.germ_res_apply at H,
    exact H },
  { rintros X Y f hf,
    have e : (f.val.base) ⁻¹' set.range ⇑(f.val.base) = ⊤,
    { rw [← set.image_univ, set.preimage_image_eq _ hf.base_open.inj, set.top_eq_univ] },
    refine ⟨_, _, e, rfl, _⟩,
    rintros H hX s hs ⟨_, x, rfl⟩,
    unfreezingI { haveI := is_reduced_of_open_immersion f },
    specialize H (f.1.c.app _ s) _ ⟨x, by { change x ∈ (f.val.base) ⁻¹' _, rw e, trivial }⟩,
    { rw [← Scheme.preimage_basic_open, hs], ext1, simp [opens.map] },
    { erw ← PresheafedSpace.stalk_map_germ_apply f.1 ⟨_,_⟩ ⟨x,_⟩ at H,
      apply_fun (inv $ PresheafedSpace.stalk_map f.val x) at H,
      erw [category_theory.is_iso.hom_inv_id_apply, map_zero] at H,
      exact H } },
  { intros R hX s hs x,
    erw [basic_open_eq_of_affine', prime_spectrum.basic_open_eq_bot_iff] at hs,
    replace hs := (hs.map (Spec_Γ_identity.app R).inv),
    -- what the hell?!
    replace hs := @is_nilpotent.eq_zero _ _ _ _ (show _, from _) hs,
    rw coe_hom_inv_id at hs,
    rw [hs, map_zero],
    exact @@is_reduced.component_reduced hX ⊤ }
end

@[simp]
lemma basic_open_eq_bot_iff {X : Scheme} [is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj $ op U) :
  X.basic_open s = ⊥ ↔ s = 0 :=
begin
  refine ⟨eq_zero_of_basic_open_empty s, _⟩,
  rintro rfl,
  simp,
end

/-- A scheme `X` is integral if its carrier is nonempty,
and `𝒪ₓ(U)` is an integral domain for each `U ≠ ∅`. -/
class is_integral : Prop :=
(nonempty : nonempty X.carrier . tactic.apply_instance)
(component_integral : ∀ (U : opens X.carrier) [_root_.nonempty U],
  is_domain (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_integral.component_integral is_integral.nonempty

instance [h : is_integral X] : is_domain (X.presheaf.obj (op ⊤)) :=
@@is_integral.component_integral _ _ (by simp)

@[priority 900]
instance is_reduced_of_is_integral [is_integral X] : is_reduced X :=
begin
  constructor,
  intro U,
  cases U.1.eq_empty_or_nonempty,
  { have : U = ∅ := subtype.eq h,
    haveI := CommRing.subsingleton_of_is_terminal (X.sheaf.is_terminal_of_eq_empty this),
    change _root_.is_reduced (X.sheaf.val.obj (op U)),
    apply_instance },
  { haveI : nonempty U := by simpa, apply_instance }
end

instance is_irreducible_of_is_integral [is_integral X] : irreducible_space X.carrier :=
begin
  by_contradiction H,
  replace H : ¬ is_preirreducible (⊤ : set X.carrier) := λ h,
    H { to_preirreducible_space := ⟨h⟩, to_nonempty := infer_instance },
  simp_rw [is_preirreducible_iff_closed_union_closed, not_forall, not_or_distrib] at H,
  rcases H with ⟨S, T, hS, hT, h₁, h₂, h₃⟩,
  erw not_forall at h₂ h₃,
  simp_rw not_forall at h₂ h₃,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ : opens X.carrier) := ⟨⟨_, h₂.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Tᶜ, hT.1⟩ : opens X.carrier) := ⟨⟨_, h₃.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ ⊔ ⟨Tᶜ, hT.1⟩ : opens X.carrier) :=
    ⟨⟨_, or.inl h₂.some_spec.some_spec⟩⟩,
  let e : X.presheaf.obj _ ≅ CommRing.of _ := (X.sheaf.is_product_of_disjoint ⟨_, hS.1⟩ ⟨_, hT.1⟩ _)
    .cone_point_unique_up_to_iso (CommRing.prod_fan_is_limit _ _),
  apply_with false_of_nontrivial_of_product_domain { instances := ff },
  { exact e.symm.CommRing_iso_to_ring_equiv.is_domain _ },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { ext x,
    split,
    { rintros ⟨hS,hT⟩,
      cases h₁ (show x ∈ ⊤, by trivial),
      exacts [hS h, hT h] },
    { intro x, exact x.rec _ } }
end

lemma is_integral_of_is_irreducible_is_reduced [is_reduced X] [H : irreducible_space X.carrier] :
  is_integral X :=
begin
  split, refine λ U hU, ⟨λ a b e, _,
    (@@LocallyRingedSpace.component_nontrivial X.to_LocallyRingedSpace U hU).1⟩,
  simp_rw [← basic_open_eq_bot_iff, ← opens.not_nonempty_iff_eq_bot],
  by_contra' h,
  obtain ⟨_, ⟨x, hx₁, rfl⟩, ⟨x, hx₂, e'⟩⟩ := @@nonempty_preirreducible_inter _ H.1
    (X.basic_open a).2 (X.basic_open b).2
    h.1 h.2,
  replace e' := subtype.eq e',
  subst e',
  replace e := congr_arg (X.presheaf.germ x) e,
  rw [ring_hom.map_mul, ring_hom.map_zero] at e,
  refine @zero_ne_one (X.presheaf.stalk x.1) _ _ (is_unit_zero_iff.1 _),
  convert hx₁.mul hx₂,
  exact e.symm
end

lemma is_integral_iff_is_irreducible_and_is_reduced :
  is_integral X ↔ irreducible_space X.carrier ∧ is_reduced X :=
⟨λ _, by exactI ⟨infer_instance, infer_instance⟩,
  λ ⟨_, _⟩, by exactI is_integral_of_is_irreducible_is_reduced X⟩

lemma is_integral_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_integral Y] [nonempty X.carrier] : is_integral X :=
begin
  constructor,
  intros U hU,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  haveI : is_domain (Y.presheaf.obj (op (H.base_open.is_open_map.functor.obj U))),
  { apply_with is_integral.component_integral { instances := ff },
    apply_instance,
    refine ⟨⟨_, _, hU.some.prop, rfl⟩⟩ },
  exact (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) :
    Y.presheaf.obj _ ≅ _).symm.CommRing_iso_to_ring_equiv.is_domain _
end

instance {R : CommRing} [H : is_domain R] : is_integral (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_integral_of_is_irreducible_is_reduced { instances := ff },
  { apply_instance },
  { dsimp [Spec.Top_obj],
    apply_instance },
end

lemma affine_is_integral_iff (R : CommRing) :
  is_integral (Scheme.Spec.obj $ op R) ↔ is_domain R :=
⟨λ h, by exactI ring_equiv.is_domain ((Scheme.Spec.obj $ op R).presheaf.obj _)
  (as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv, λ h, by exactI infer_instance⟩

lemma is_integral_of_is_affine_is_domain [is_affine X] [nonempty X.carrier]
  [h : is_domain (X.presheaf.obj (op ⊤))] : is_integral X :=
begin
  haveI : is_integral (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_integral_iff, exact h },
  exact is_integral_of_open_immersion X.iso_Spec.hom,
end

lemma map_injective_of_is_integral [is_integral X] {U V : opens X.carrier} (i : U ⟶ V)
  [H : nonempty U] :
  function.injective (X.presheaf.map i.op) :=
begin
  rw ring_hom.injective_iff,
  intros x hx,
  rw ← basic_open_eq_bot_iff at ⊢ hx,
  rw Scheme.basic_open_res at hx,
  revert hx,
  contrapose!,
  simp_rw [← opens.not_nonempty_iff_eq_bot, not_not],
  apply nonempty_preirreducible_inter U.prop (RingedSpace.basic_open _ _).prop,
  simpa using H
end

end algebraic_geometry