import thm95.double_complex
import pseudo_normed_group.homotopy
import rescale.FiltrationPow

/-!
# A complex canonically isomorphic to `row 1` of the double complex

We have
```
lemma double_complex.row_one :
  (double_complex BD κ r r' V Λ M N).row 1 =
  BD.system κ r V r' (Hom ((cosimplicial Λ N).obj (mk 0)) M) := rfl
```

We want to "rewrite" this row in such a way that it is the target
of the homotopies that will be constructed formally from `BD.homotopy`.

Concretely, we want:
```
(((data.mul N).obj BD.data).system (rescale_constants κ N) r V r').obj (op (Hom Λ M)) ≅
  (thm95.double_complex BD.data κ r r' V Λ M N).row 1
```

This means that we need to multiply `BD` by `N`,
and then take the system associated with `rescale N (Hom Λ M)`.

We need the following isomorphisms

* `BD.system M^N = (BD.mul N).system M`
* `Hom (rescale N (Λ^N)) M = (rescale N (Hom Λ M)^N` (2 steps?)
* `(cosimplicial Λ N).obj (mk 0) = rescale N (Λ^N)`

-/

universes u v

noncomputable theory

open_locale nnreal big_operators kronecker

local attribute [instance] type_pow

local attribute [reducible] CLCFPTinv₂ CLCFPTinv₂.res
  breen_deligne.universal_map.eval_CLCFPTinv₂

-- move this
namespace category_theory

namespace arrow

variables {C : Type*} [category C] {X Y Z X' Y' Z' : C}
variables (f : X ⟶ Y) (g : Y ⟶ Z) (f' : X' ⟶ Y') (g' : Y' ⟶ Z')

lemma mk_comp_congr (hf : arrow.mk f = arrow.mk f') (hg : arrow.mk g = arrow.mk g') :
  arrow.mk (f ≫ g) = arrow.mk (f' ≫ g') :=
by { cases hf, cases hg, refl }

end arrow

end category_theory

open category_theory

section rescale

variables {BD : breen_deligne.data}
variables (κ : ℕ → ℝ≥0)
variables [BD.suitable κ]
variables (r : ℝ≥0) (V : SemiNormedGroup.{v}) [normed_with_aut r V] [fact (0 < r)]
variables {r' : ℝ≥0} [fact (0 < r')] [fact (r' ≤ 1)] (c : ℝ≥0)
variables (M : ProFiltPseuNormGrpWithTinv.{u} r')

-- move this
instance rescale_constants_suitable (N : ℝ≥0) :
  BD.suitable (rescale_constants κ N) :=
by { delta rescale_constants, apply_instance }

variables (BD)

open breen_deligne opposite ProFiltPseuNormGrpWithTinv (of)

section

def FiltrationPow_rescale_iso (n : ℕ) (N : ℝ≥0) :
  ((Filtration r').obj c).obj ((ProFiltPseuNormGrpWithTinv.Pow r' n).obj (of r' (rescale N M))) ≅
    ((Filtration r').obj (c * N⁻¹)).obj ((ProFiltPseuNormGrpWithTinv.Pow r' n).obj M) :=
iso.refl _

def complex_rescale_iso (N : ℝ≥0) :
  (BD.complex (rescale_constants κ N) r V r' c).obj (op M) ≅
  (BD.complex κ r V r' c).obj (op $ of r' $ rescale N M) :=
homological_complex.hom.iso_of_components
begin
  intro i,
  refine CLCTinv.map_iso r V _ _ _ _ _ _ _ _,
  { refine (FiltrationPow_rescale_iso _ _ _ _ ≪≫
      Filtration_cast_eq r' _ _ (mul_assoc c (κ i) (N⁻¹)) _).op, },
  { refine (FiltrationPow_rescale_iso _ _ _ _ ≪≫
      Filtration_cast_eq _ (r' * (c * κ i) * N⁻¹) (r' * (c * (κ i * N⁻¹)))
      (by simp only [mul_assoc]) _).op, },
  { refl },
  { refl }
end
begin
  intros i j hij,
  apply arrow.mk_injective,
  dsimp only [data.complex_obj_d, universal_map.eval_CLCFPTinv, universal_map.eval_CLCFPTinv₂,
    _root_.id, SemiNormedGroup.equalizer.map_nat_app, CLCTinv.map_iso_hom, CLCTinv.map, unop_op,
    Filtration_cast_eq, iso.op_hom],
  simp only [SemiNormedGroup.equalizer.map_comp_map, universal_map.eval_CLCFP_rescale,
    ← CLCFP.res_def', nat_iso.app_hom, functor.map_iso_hom, Filtration_map_app,
    FiltrationPow_rescale_iso, iso.refl_trans],
  apply SemiNormedGroup.equalizer.map_congr,
  { have := @universal_map.res_comp_eval_CLCFP V r'
      (c * (κ i * N⁻¹)) (c * κ i * N⁻¹) (c * (κ j * N⁻¹)) (c * κ j * N⁻¹)
      (BD.X j) (BD.X i) (BD.d j i) ⟨(mul_assoc _ _ _).le⟩ _ _ ⟨(mul_assoc _ _ _).le⟩,
    replace := nat_trans.congr_app this.symm (op M),
    replace := congr_arg arrow.mk this,
    refine (this.trans _).symm,
    apply arrow.mk_comp_congr, { refl }, { rw universal_map.eval_CLCFP_rescale } },
  { have := @universal_map.res_comp_eval_CLCFP V r'
      (r' * (c * (κ i * N⁻¹))) (r' * (c * κ i) * N⁻¹) (r' * (c * (κ j * N⁻¹))) (r' * (c * κ j) * N⁻¹)
      (BD.X j) (BD.X i) (BD.d j i) ⟨le_of_eq $ by simp only [mul_assoc]⟩ _ _ ⟨le_of_eq $ by simp only [mul_assoc]⟩,
    replace := nat_trans.congr_app this.symm (op M),
    replace := congr_arg arrow.mk this,
    refine (this.trans _).symm,
    apply arrow.mk_comp_congr, { refl }, { rw universal_map.eval_CLCFP_rescale } },
  any_goals { refl },
end
.

noncomputable
def system_rescale_iso (N : ℝ≥0) :
  (BD.system (rescale_constants κ N) r V r').obj (op M) ≅
  (BD.system κ r V r').obj (op $ of r' $ rescale N M) :=
nat_iso.of_components (λ c, complex_rescale_iso BD κ r V c.unop _ _)
begin
  intros c₁ c₂ h,
  ext i : 2,
  apply arrow.mk_injective,
  erw [homological_complex.comp_f, homological_complex.comp_f],
  dsimp only [data.system_obj, CLCFPTinv₂.res, complex_rescale_iso,
    homological_complex.hom.iso_of_components, CLCTinv.map_iso_hom, CLCTinv.map_nat_app],
  simp only [CLCTinv.map_comp_map],
  refl,
end

end

end rescale

namespace thm95

open breen_deligne polyhedral_lattice opposite

variables (BD : breen_deligne.data) (κ : ℕ → ℝ≥0) [BD.suitable κ]
variables (r : ℝ≥0) (V : SemiNormedGroup.{v}) [normed_with_aut r V] [fact (0 < r)]
variables {r' : ℝ≥0} [fact (0 < r')] [fact (r < r')] [fact (r' ≤ 1)] (c : ℝ≥0)

section

variables {m n : ℕ} (ϕ : universal_map m n) (g : basic_universal_map m n)
variables (c₁ c₂ : ℝ≥0) (N : ℕ) [fact (0 < N)]
variables (M : ProFiltPseuNormGrpWithTinv.{u} r')

lemma eval_FP_mul [g.suitable c₂ c₁] :
  (CLC V).map (FiltrationPow.mul_iso.{u u} r' c₁ M N n).hom.op ≫
    (CLC V).map ((basic_universal_map.eval_FP r' c₂ c₁ g).app (ProFiltPseuNormGrpWithTinv.of r' (M ^ N))).op =
  (CLC V).map ((basic_universal_map.eval_FP r' c₂ c₁ ((basic_universal_map.mul N) g)).app M).op ≫
    (CLC V).map (FiltrationPow.mul_iso.{u u} r' c₂ M N m).hom.op :=
begin
  simp only [← (CLC V).map_comp, ← op_comp], congr' 2,
  rw [← iso.inv_comp_eq, ← category.assoc, ← iso.eq_comp_inv],
  exact basic_universal_map.mul_iso_eval_FP r' c₁ c₂ g N M
end

lemma eval_CLCFP_mul [ϕ.suitable c₂ c₁] {_ : (universal_map.mul N ϕ).suitable c₂ c₁} :
  (((universal_map.mul N ϕ).eval_CLCFP V r' c₁ c₂).app (op M) ≫
    (CLC V).map (FiltrationPow.mul_iso.{u u} r' c₂ M N m).op.hom) =
  ((CLC V).map (FiltrationPow.mul_iso.{u u} r' c₁ M N n).op.hom ≫
   ((ϕ.eval_CLCFP V r' c₁ c₂).app (op (ProFiltPseuNormGrpWithTinv.of r' (M ^ N))) : _)) :=
begin
  dsimp only [universal_map.eval_CLCFP, whisker_right_app],
  simp only [universal_map.eval_LCFP_eq_eval_LCFP', universal_map.eval_LCFP',
    ← nat_trans.app_hom_apply, ← functor.map_add_hom_apply,
    add_monoid_hom.map_sum, add_monoid_hom.map_zsmul],
  rw [preadditive.sum_comp, preadditive.comp_sum],
  symmetry, have hN : 0 < N := fact.out _,
  apply finset.sum_bij (λ g hg, basic_universal_map.mul N g),
  { intros g hg, rw universal_map.mem_support_mul N hN, refine ⟨g, hg, rfl⟩ },
  { intros g hg,
    simp only [preadditive.comp_zsmul, preadditive.zsmul_comp, universal_map.coeff_mul N hN],
    congr' 1,
    have : g.suitable c₂ c₁ := universal_map.suitable_of_mem_support _ _ _ _ hg, resetI,
    rw [← basic_universal_map.eval_LCFP_eq_eval_LCFP' _ _ _ _ g this,
        ← basic_universal_map.eval_LCFP_eq_eval_LCFP'],
    swap, { apply basic_universal_map.mul_suitable },
    dsimp only [basic_universal_map.eval_LCFP, nat_trans.app_hom_apply, functor.map_add_hom_apply,
      whisker_right_app, nat_trans.op_app, unop_op],
    simp only [← functor.comp_map],
    apply eval_FP_mul },
  { intros g₁ g₂ hg₁ hg₂ H, exact basic_universal_map.mul_injective N hN H },
  { intro g, rw universal_map.mem_support_mul N hN, rintro ⟨g', h1, h2⟩, exact ⟨g', h1, h2⟩ }
end

def mul_complex_iso (c : ℝ≥0) :
  (((data.mul N).obj BD).complex κ r V r' c).obj (op M) ≅
  (BD.complex κ r V r' c).obj (op (ProFiltPseuNormGrpWithTinv.of r' $ M^N)) :=
homological_complex.hom.iso_of_components
begin
  intro i,
  refine CLCTinv.map_iso r V _ _ _ _ _ _ _ _,
  { exact (FiltrationPow.mul_iso.{u u} r' (c * κ i) M N (BD.X i)).op },
  { exact (FiltrationPow.mul_iso.{u u} r' (r' * (c * κ i)) M N (BD.X i)).op },
  { refl },
  { refl }
end
begin
  intros i j hij,
  apply arrow.mk_injective,
  dsimp only [data.complex_obj_d, universal_map.eval_CLCFPTinv, universal_map.eval_CLCFPTinv₂,
    _root_.id, SemiNormedGroup.equalizer.map_nat_app, CLCTinv.map_iso_hom, CLCTinv.map,
    data.mul_obj_d],
  simp only [SemiNormedGroup.equalizer.map_comp_map],
  apply SemiNormedGroup.equalizer.map_congr,
  { rw eval_CLCFP_mul },
  { rw eval_CLCFP_mul },
  all_goals { refl }
end

end

def mul_system_iso (N : ℕ) [fact (0 < N)] (M : ProFiltPseuNormGrpWithTinv.{u} r') :
  (((data.mul N).obj BD).system κ r V r').obj (op M) ≅
  (BD.system κ r V r').obj (op (ProFiltPseuNormGrpWithTinv.of r' $ M^N)) :=
nat_iso.of_components (λ c, mul_complex_iso BD κ r V N M c.unop)
begin
  intros c₁ c₂ hc,
  ext i : 2,
  apply arrow.mk_injective,
  erw [homological_complex.comp_f, homological_complex.comp_f],
  dsimp only [data.system_obj, CLCFPTinv₂.res, mul_complex_iso,
    homological_complex.hom.iso_of_components, CLCTinv.map_iso_hom, CLCTinv.map_nat_app],
  simp only [CLCTinv.map_comp_map],
  refl,
end

def mul_rescale_iso_row_one
  (N : ℕ) [fact (0 < N)] (N' : ℝ≥0) (h : N' = N)
  (Λ : PolyhedralLattice.{u}) (M : ProFiltPseuNormGrpWithTinv.{u} r') :
  (((data.mul N).obj BD).system (rescale_constants κ N') r V r').obj (op (Hom Λ M)) ≅
    ((thm95.double_complex BD κ r r' V Λ M N).row 1) :=
(mul_system_iso _ _ r V N _) ≪≫
(system_rescale_iso _ κ r V _ _) ≪≫
((BD.system κ r V r').map_iso $
  (PolyhedralLattice.Hom_cosimplicial_zero_iso Λ N r' M N' h).op)

lemma mul_rescale_iso_row_one_strict
  (N : ℕ) [fact (0 < N)] (N' : ℝ≥0) (h : N' = N)
  (Λ : PolyhedralLattice.{u}) (M : ProFiltPseuNormGrpWithTinv.{u} r')
  (c : ℝ≥0) (i : ℕ)
  (x : (((data.mul N).obj BD).system (rescale_constants κ N') r V r').obj (op (Hom Λ M)) c i) :
  ∥(mul_rescale_iso_row_one BD κ r V N N' h Λ M).hom x∥ = ∥x∥ :=
begin
  apply normed_add_group_hom.norm_eq_of_isometry,
  refine isometry.comp (isometry.comp _ _) _,
  { apply data.system_map_iso_isometry, },
  { dsimp only, apply CLCTinv.map_iso_isometry, },
  { apply CLCTinv.map_iso_isometry, },
end
.

lemma quux (N : ℕ) [fact (0 < N)] (M : ProFiltPseuNormGrpWithTinv.{u} r') (c₁ c₂ : ℝ≥0) (i : ℕ)
  [(universal_map.sum i N).suitable c₂ c₁] {_ : ((finset.univ : finset (fin N)).sum (basic_universal_map.proj i)).suitable c₂ c₁} :
  (universal_map.eval_CLCFP V r' c₁ c₂ (universal_map.sum i N)).app (op M) =
  (CLC V).map ((basic_universal_map.eval_FP r' c₂ c₁ ((finset.univ : finset (fin N)).sum (basic_universal_map.proj i))).app M).op :=
by { dsimp only [universal_map.sum], rw [universal_map.eval_CLCFP_of], refl }

lemma bar (N : ℕ) [fact (0 < N)] (Λ : PolyhedralLattice.{u}) (M : ProFiltPseuNormGrpWithTinv.{u} r')
  (c₁ c₂ : ℝ≥0) (hc : c₁ * N⁻¹ = c₂) (n : ℕ)
  {_ : ((finset.univ : finset (fin N)).sum (basic_universal_map.proj n)).suitable c₂ c₁} :
  (FiltrationPow_rescale_iso c₁ (ProFiltPseuNormGrpWithTinv.of r' ((Hom Λ M) ^ N)) n N ≪≫
     ((Filtration r').map_iso (eq_to_iso hc)).app
       ((ProFiltPseuNormGrpWithTinv.Pow r' n).obj (ProFiltPseuNormGrpWithTinv.of r' ((Hom Λ M) ^ N)))).inv ≫
  ((Filtration r').obj c₁).map ((ProFiltPseuNormGrpWithTinv.Pow r' n).map (Λ.Hom_sum N r' M)) =
  (FiltrationPow.mul_iso.{u u} r' c₂ (Hom.{u u} Λ M) N n).hom ≫
    (basic_universal_map.eval_FP.{u} r' c₂ c₁ (finset.univ.sum (basic_universal_map.proj n))).app (Hom.{u u} Λ M) :=
begin
  dsimp only [FiltrationPow_rescale_iso], rw [iso.refl_trans],
  dsimp only [FiltrationPow.mul_iso_hom, nat_iso.app_inv, functor.map_iso_inv,
    Pow_obj, ProFiltPseuNormGrpWithTinv.coe_of, Filtration_map_app],
  ext x i : 3,
  erw [comp_apply, comp_apply],
  dsimp only [Filtration_obj_map_apply, Pow_Pow_X_hom_apply, continuous_map.coe_mk,
    comphaus_filtered_pseudo_normed_group_with_Tinv_hom.level_coe, subtype.coe_mk,
    Filtration.cast_le_apply, pseudo_normed_group.coe_cast_le,
    basic_universal_map.eval_FP, basic_universal_map.eval_png₀,
    ProFiltPseuNormGrpWithTinv.Pow_map,
    profinitely_filtered_pseudo_normed_group_with_Tinv.pi_map_to_fun],
  rw [← comphaus_filtered_pseudo_normed_group_hom.coe_to_add_monoid_hom,
    ← comphaus_filtered_pseudo_normed_group_hom.to_add_monoid_hom_hom_apply],
  simp only [PolyhedralLattice.Hom_sum_apply, add_monoid_hom.map_sum,
    add_monoid_hom.finset_sum_apply, finset.sum_apply],
  apply fintype.sum_congr,
  intro j,
  simp only [comphaus_filtered_pseudo_normed_group_hom.coe_to_add_monoid_hom,
    comphaus_filtered_pseudo_normed_group_hom.to_add_monoid_hom_hom_apply,
    basic_universal_map.eval_png_apply, ProFiltPseuNormGrpWithTinv.Pow_Pow_X_hom_to_fun,
    ProFiltPseuNormGrpWithTinv.Pow_Pow_X_equiv_symm_apply,
    equiv.inv_fun_as_coe, equiv.symm_symm, equiv.trans_apply, equiv.symm_trans_apply,
    equiv.arrow_congr_apply, function.comp, equiv.refl_apply, equiv.curry_symm_apply,
    function.uncurry, equiv.prod_comm_symm, equiv.prod_comm_apply, prod.fst_swap, prod.snd_swap],
  rw [← fin_prod_fin_equiv.sum_comp], swap, { apply_instance },
  simp only [basic_universal_map.proj,
    matrix.reindex_linear_equiv_apply, matrix.reindex_apply, matrix.submatrix_apply,
    equiv.punit_prod_symm_apply, matrix.kronecker, matrix.one_apply,
    basic_universal_map.proj_aux, equiv.symm_apply_apply,
    boole_mul, ← ite_and, @eq_comm _ i, boole_mul, matrix.kronecker_map, subtype.val_eq_coe],
  simp_rw [ite_smul, one_smul, zero_smul],
  convert (finset.sum_ite_eq' finset.univ (j, i) (λ p, x.val p.2 p.1)).symm using 2,
  { simp only [finset.mem_univ, if_true, subtype.val_eq_coe] },
  { ext ⟨a, b⟩,
    split_ifs,
    any_goals {refl},
    all_goals { rw [← prod.mk.inj_iff, prod.mk.eta] at h, tauto } },
end

lemma foo (N : ℕ) [fact (0 < N)] (Λ : PolyhedralLattice.{u}) (M : ProFiltPseuNormGrpWithTinv.{u} r')
  (c₁ c₂ : ℝ≥0) (hc : c₁ * N⁻¹ = c₂) (i : ℕ) [H : universal_map.suitable c₂ c₁ (universal_map.sum i N)] :
  (CLC V).map ((FiltrationPow r' c₁ i).op.map (Λ.Hom_sum N r' M).op) ≫
    (CLC V).map (FiltrationPow_rescale_iso c₁ ((ProFiltPseuNormGrpWithTinv.of r' ((Hom Λ M) ^ N))) i N ≪≫
      Filtration_cast_eq r' (c₁ * N⁻¹) c₂ hc ((ProFiltPseuNormGrpWithTinv.Pow r' i).obj ((ProFiltPseuNormGrpWithTinv.of r' ((Hom Λ M) ^ N))))).op.inv =
  ((universal_map.eval_CLCFP V r' c₁ c₂ (universal_map.sum i N)).app (op (Hom Λ M)) ≫ (CLC V).map (FiltrationPow.mul_iso.{u u} r' c₂ (Hom Λ M) N i).op.hom) :=
begin
  rw [← (CLC V).map_comp],
  dsimp only [FiltrationPow, category_theory.functor.op_map, category_theory.functor.comp_map,
    Filtration_cast_eq, quiver.hom.unop_op],
  rw [iso.op_inv, quux, ← (CLC V).map_comp, iso.op_hom, ← op_comp, ← op_comp],
  swap, { exact @basic_universal_map.suitable_of_suitable_of _ _ _ _ _ H },
  congr' 2,
  apply bar,
end

lemma row_map_eq_sum_comp
  (N : ℕ) [fact (0 < N)] (N' : ℝ≥0) (h : N' = N)
  [∀ (i : ℕ), universal_map.suitable (rescale_constants κ N' i) (κ i) ((BD.sum N).f i)]
  (Λ : PolyhedralLattice.{u}) (M : ProFiltPseuNormGrpWithTinv.{u} r') :
  (thm95.double_complex BD κ r r' V Λ M N).row_map 0 1 =
    (iso.refl ((BD.system κ r V r').obj (op (Hom Λ M)))).inv ≫
    (BD_system_map (BD.sum N) κ
      (rescale_constants κ N') r V).app (op (Hom Λ M)) ≫
    (thm95.mul_rescale_iso_row_one BD κ r V N N' h Λ M).hom :=
begin
  unfreezingI { subst h },
  dsimp only [iso.refl_inv],
  erw category.id_comp,
  rw [← iso.comp_inv_eq],
  rw [thm95.double_complex.row_map_zero_one],
  dsimp only [mul_rescale_iso_row_one, iso.trans_inv, nat_trans.comp_app, functor.map_iso_inv],
  simp only [← category.assoc, ← (BD.system κ r V r').map_comp, ← nat_trans.comp_app,
    iso.op_inv, ← op_comp, PolyhedralLattice.Cech_augmentation_map_eq_Hom_sum],
  rw [iso.comp_inv_eq],
  ext c i : 4,
  apply arrow.mk_injective,
  erw [nat_trans.comp_app, nat_trans.comp_app,
    homological_complex.comp_f, homological_complex.comp_f],
  dsimp only [BD_system_map_app_app, BD_map_app_f, data.sum_f, data.system_map, data.complex,
    data.complex₂_map_f, mul_system_iso, system_rescale_iso, complex_rescale_iso, mul_complex_iso],
  erw [nat_iso.of_components_hom_app, nat_iso.of_components_inv_app],
  dsimp only [homological_complex.hom.iso_of_components_hom_f,
    homological_complex.hom.iso_of_components_inv_f],
  dsimp only [CLCFPTinv₂, universal_map.eval_CLCFPTinv₂, CLCTinv.map_iso_hom, CLCTinv.map_iso_inv,
    CLCTinv.F_map, _root_.id, CLCTinv.map, SemiNormedGroup.equalizer.map_nat_app, unop_op],
  rw [SemiNormedGroup.equalizer.map_comp_map, SemiNormedGroup.equalizer.map_comp_map],
  apply SemiNormedGroup.equalizer.map_congr,
  { rw foo, refl },
  { rw foo, refl },
  all_goals { refl },
end

end thm95


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default

universes u v w

namespace Mathlib

def stream (α : Type u) :=
  ℕ → α

namespace stream

def cons {α : Type u} (a : α) (s : stream α) : stream α :=
  fun (i : ℕ) => sorry

infixr:67 " :: " => Mathlib.stream.cons

def head {α : Type u} (s : stream α) : α :=
  s 0

def tail {α : Type u} (s : stream α) : stream α :=
  fun (i : ℕ) => s (i + 1)

def drop {α : Type u} (n : ℕ) (s : stream α) : stream α :=
  fun (i : ℕ) => s (i + n)

def nth {α : Type u} (n : ℕ) (s : stream α) : α :=
  s n

protected theorem eta {α : Type u} (s : stream α) : head s :: tail s = s :=
  funext
    fun (i : ℕ) =>
      nat.cases_on i (Eq.refl (cons (head s) (tail s) 0)) fun (i : ℕ) => Eq.refl (cons (head s) (tail s) (Nat.succ i))

theorem nth_zero_cons {α : Type u} (a : α) (s : stream α) : nth 0 (a :: s) = a :=
  rfl

theorem head_cons {α : Type u} (a : α) (s : stream α) : head (a :: s) = a :=
  rfl

theorem tail_cons {α : Type u} (a : α) (s : stream α) : tail (a :: s) = s :=
  rfl

theorem tail_drop {α : Type u} (n : ℕ) (s : stream α) : tail (drop n s) = drop n (tail s) := sorry

theorem nth_drop {α : Type u} (n : ℕ) (m : ℕ) (s : stream α) : nth n (drop m s) = nth (n + m) s :=
  rfl

theorem tail_eq_drop {α : Type u} (s : stream α) : tail s = drop 1 s :=
  rfl

theorem drop_drop {α : Type u} (n : ℕ) (m : ℕ) (s : stream α) : drop n (drop m s) = drop (n + m) s := sorry

theorem nth_succ {α : Type u} (n : ℕ) (s : stream α) : nth (Nat.succ n) s = nth n (tail s) :=
  rfl

theorem drop_succ {α : Type u} (n : ℕ) (s : stream α) : drop (Nat.succ n) s = drop n (tail s) :=
  rfl

protected theorem ext {α : Type u} {s₁ : stream α} {s₂ : stream α} : (∀ (n : ℕ), nth n s₁ = nth n s₂) → s₁ = s₂ :=
  fun (h : ∀ (n : ℕ), nth n s₁ = nth n s₂) => funext h

def all {α : Type u} (p : α → Prop) (s : stream α) :=
  ∀ (n : ℕ), p (nth n s)

def any {α : Type u} (p : α → Prop) (s : stream α) :=
  ∃ (n : ℕ), p (nth n s)

theorem all_def {α : Type u} (p : α → Prop) (s : stream α) : all p s = ∀ (n : ℕ), p (nth n s) :=
  rfl

theorem any_def {α : Type u} (p : α → Prop) (s : stream α) : any p s = ∃ (n : ℕ), p (nth n s) :=
  rfl

protected def mem {α : Type u} (a : α) (s : stream α) :=
  any (fun (b : α) => a = b) s

protected instance has_mem {α : Type u} : has_mem α (stream α) :=
  has_mem.mk stream.mem

theorem mem_cons {α : Type u} (a : α) (s : stream α) : a ∈ a :: s :=
  exists.intro 0 rfl

theorem mem_cons_of_mem {α : Type u} {a : α} {s : stream α} (b : α) : a ∈ s → a ∈ b :: s := sorry

theorem eq_or_mem_of_mem_cons {α : Type u} {a : α} {b : α} {s : stream α} : a ∈ b :: s → a = b ∨ a ∈ s := sorry

theorem mem_of_nth_eq {α : Type u} {n : ℕ} {s : stream α} {a : α} : a = nth n s → a ∈ s :=
  fun (h : a = nth n s) => exists.intro n h

def map {α : Type u} {β : Type v} (f : α → β) (s : stream α) : stream β :=
  fun (n : ℕ) => f (nth n s)

theorem drop_map {α : Type u} {β : Type v} (f : α → β) (n : ℕ) (s : stream α) : drop n (map f s) = map f (drop n s) :=
  stream.ext fun (i : ℕ) => rfl

theorem nth_map {α : Type u} {β : Type v} (f : α → β) (n : ℕ) (s : stream α) : nth n (map f s) = f (nth n s) :=
  rfl

theorem tail_map {α : Type u} {β : Type v} (f : α → β) (s : stream α) : tail (map f s) = map f (tail s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (tail (map f s) = map f (tail s))) (tail_eq_drop (map f s))))
    (Eq.refl (drop 1 (map f s)))

theorem head_map {α : Type u} {β : Type v} (f : α → β) (s : stream α) : head (map f s) = f (head s) :=
  rfl

theorem map_eq {α : Type u} {β : Type v} (f : α → β) (s : stream α) : map f s = f (head s) :: map f (tail s) := sorry

theorem map_cons {α : Type u} {β : Type v} (f : α → β) (a : α) (s : stream α) : map f (a :: s) = f a :: map f s := sorry

theorem map_id {α : Type u} (s : stream α) : map id s = s :=
  rfl

theorem map_map {α : Type u} {β : Type v} {δ : Type w} (g : β → δ) (f : α → β) (s : stream α) : map g (map f s) = map (g ∘ f) s :=
  rfl

theorem map_tail {α : Type u} {β : Type v} (f : α → β) (s : stream α) : map f (tail s) = tail (map f s) :=
  rfl

theorem mem_map {α : Type u} {β : Type v} (f : α → β) {a : α} {s : stream α} : a ∈ s → f a ∈ map f s := sorry

theorem exists_of_mem_map {α : Type u} {β : Type v} {f : α → β} {b : β} {s : stream α} : b ∈ map f s → ∃ (a : α), a ∈ s ∧ f a = b := sorry

def zip {α : Type u} {β : Type v} {δ : Type w} (f : α → β → δ) (s₁ : stream α) (s₂ : stream β) : stream δ :=
  fun (n : ℕ) => f (nth n s₁) (nth n s₂)

theorem drop_zip {α : Type u} {β : Type v} {δ : Type w} (f : α → β → δ) (n : ℕ) (s₁ : stream α) (s₂ : stream β) : drop n (zip f s₁ s₂) = zip f (drop n s₁) (drop n s₂) :=
  stream.ext fun (i : ℕ) => rfl

theorem nth_zip {α : Type u} {β : Type v} {δ : Type w} (f : α → β → δ) (n : ℕ) (s₁ : stream α) (s₂ : stream β) : nth n (zip f s₁ s₂) = f (nth n s₁) (nth n s₂) :=
  rfl

theorem head_zip {α : Type u} {β : Type v} {δ : Type w} (f : α → β → δ) (s₁ : stream α) (s₂ : stream β) : head (zip f s₁ s₂) = f (head s₁) (head s₂) :=
  rfl

theorem tail_zip {α : Type u} {β : Type v} {δ : Type w} (f : α → β → δ) (s₁ : stream α) (s₂ : stream β) : tail (zip f s₁ s₂) = zip f (tail s₁) (tail s₂) :=
  rfl

theorem zip_eq {α : Type u} {β : Type v} {δ : Type w} (f : α → β → δ) (s₁ : stream α) (s₂ : stream β) : zip f s₁ s₂ = f (head s₁) (head s₂) :: zip f (tail s₁) (tail s₂) := sorry

def const {α : Type u} (a : α) : stream α :=
  fun (n : ℕ) => a

theorem mem_const {α : Type u} (a : α) : a ∈ const a :=
  exists.intro 0 rfl

theorem const_eq {α : Type u} (a : α) : const a = a :: const a :=
  stream.ext fun (n : ℕ) => nat.cases_on n (Eq.refl (nth 0 (const a))) fun (n : ℕ) => Eq.refl (nth (Nat.succ n) (const a))

theorem tail_const {α : Type u} (a : α) : tail (const a) = const a :=
  (fun (this : tail (a :: const a) = const a) =>
      eq.mp (Eq._oldrec (Eq.refl (tail (a :: const a) = const a)) (Eq.symm (const_eq a))) this)
    rfl

theorem map_const {α : Type u} {β : Type v} (f : α → β) (a : α) : map f (const a) = const (f a) :=
  rfl

theorem nth_const {α : Type u} (n : ℕ) (a : α) : nth n (const a) = a :=
  rfl

theorem drop_const {α : Type u} (n : ℕ) (a : α) : drop n (const a) = const a :=
  stream.ext fun (i : ℕ) => rfl

def iterate {α : Type u} (f : α → α) (a : α) : stream α :=
  fun (n : ℕ) => nat.rec_on n a fun (n : ℕ) (r : α) => f r

theorem head_iterate {α : Type u} (f : α → α) (a : α) : head (iterate f a) = a :=
  rfl

theorem tail_iterate {α : Type u} (f : α → α) (a : α) : tail (iterate f a) = iterate f (f a) := sorry

theorem iterate_eq {α : Type u} (f : α → α) (a : α) : iterate f a = a :: iterate f (f a) := sorry

theorem nth_zero_iterate {α : Type u} (f : α → α) (a : α) : nth 0 (iterate f a) = a :=
  rfl

theorem nth_succ_iterate {α : Type u} (n : ℕ) (f : α → α) (a : α) : nth (Nat.succ n) (iterate f a) = nth n (iterate f (f a)) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nth (Nat.succ n) (iterate f a) = nth n (iterate f (f a)))) (nth_succ n (iterate f a))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (nth n (tail (iterate f a)) = nth n (iterate f (f a)))) (tail_iterate f a)))
      (Eq.refl (nth n (iterate f (f a)))))

def is_bisimulation {α : Type u} (R : stream α → stream α → Prop) :=
  ∀ {s₁ s₂ : stream α}, R s₁ s₂ → head s₁ = head s₂ ∧ R (tail s₁) (tail s₂)

theorem nth_of_bisim {α : Type u} (R : stream α → stream α → Prop) (bisim : is_bisimulation R) {s₁ : stream α} {s₂ : stream α} (n : ℕ) : R s₁ s₂ → nth n s₁ = nth n s₂ ∧ R (drop (n + 1) s₁) (drop (n + 1) s₂) := sorry

theorem eq_of_bisim {α : Type u} (R : stream α → stream α → Prop) (bisim : is_bisimulation R) {s₁ : stream α} {s₂ : stream α} : R s₁ s₂ → s₁ = s₂ :=
  fun (r : R s₁ s₂) => stream.ext fun (n : ℕ) => and.elim_left (nth_of_bisim R bisim n r)

theorem bisim_simple {α : Type u} (s₁ : stream α) (s₂ : stream α) : head s₁ = head s₂ → s₁ = tail s₁ → s₂ = tail s₂ → s₁ = s₂ := sorry

theorem coinduction {α : Type u} {s₁ : stream α} {s₂ : stream α} : head s₁ = head s₂ → (∀ (β : Type u) (fr : stream α → β), fr s₁ = fr s₂ → fr (tail s₁) = fr (tail s₂)) → s₁ = s₂ := sorry

theorem iterate_id {α : Type u} (a : α) : iterate id a = const a := sorry

theorem map_iterate {α : Type u} (f : α → α) (a : α) : iterate f (f a) = map f (iterate f a) := sorry

def corec {α : Type u} {β : Type v} (f : α → β) (g : α → α) : α → stream β :=
  fun (a : α) => map f (iterate g a)

def corec_on {α : Type u} {β : Type v} (a : α) (f : α → β) (g : α → α) : stream β :=
  corec f g a

theorem corec_def {α : Type u} {β : Type v} (f : α → β) (g : α → α) (a : α) : corec f g a = map f (iterate g a) :=
  rfl

theorem corec_eq {α : Type u} {β : Type v} (f : α → β) (g : α → α) (a : α) : corec f g a = f a :: corec f g (g a) := sorry

theorem corec_id_id_eq_const {α : Type u} (a : α) : corec id id a = const a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (corec id id a = const a)) (corec_def id id a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (map id (iterate id a) = const a)) (map_id (iterate id a))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (iterate id a = const a)) (iterate_id a))) (Eq.refl (const a))))

theorem corec_id_f_eq_iterate {α : Type u} (f : α → α) (a : α) : corec id f a = iterate f a :=
  rfl

def corec' {α : Type u} {β : Type v} (f : α → β × α) : α → stream β :=
  corec (prod.fst ∘ f) (prod.snd ∘ f)

theorem corec'_eq {α : Type u} {β : Type v} (f : α → β × α) (a : α) : corec' f a = prod.fst (f a) :: corec' f (prod.snd (f a)) :=
  corec_eq (prod.fst ∘ f) (prod.snd ∘ f) a

-- corec is also known as unfold

def unfolds {α : Type u} {β : Type v} (g : α → β) (f : α → α) (a : α) : stream β :=
  corec g f a

theorem unfolds_eq {α : Type u} {β : Type v} (g : α → β) (f : α → α) (a : α) : unfolds g f a = g a :: unfolds g f (f a) := sorry

theorem nth_unfolds_head_tail {α : Type u} (n : ℕ) (s : stream α) : nth n (unfolds head tail s) = nth n s := sorry

theorem unfolds_head_eq {α : Type u} (s : stream α) : unfolds head tail s = s :=
  stream.ext fun (n : ℕ) => nth_unfolds_head_tail n s

def interleave {α : Type u} (s₁ : stream α) (s₂ : stream α) : stream α :=
  corec_on (s₁, s₂) (fun (_x : stream α × stream α) => sorry) fun (_x : stream α × stream α) => sorry

infixl:65 "⋈" => Mathlib.stream.interleave

theorem interleave_eq {α : Type u} (s₁ : stream α) (s₂ : stream α) : s₁⋈s₂ = head s₁ :: head s₂ :: (tail s₁⋈tail s₂) := sorry

theorem tail_interleave {α : Type u} (s₁ : stream α) (s₂ : stream α) : tail (s₁⋈s₂) = s₂⋈tail s₁ := sorry

theorem interleave_tail_tail {α : Type u} (s₁ : stream α) (s₂ : stream α) : tail s₁⋈tail s₂ = tail (tail (s₁⋈s₂)) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (tail s₁⋈tail s₂ = tail (tail (s₁⋈s₂)))) (interleave_eq s₁ s₂)))
    (Eq.refl (tail s₁⋈tail s₂))

theorem nth_interleave_left {α : Type u} (n : ℕ) (s₁ : stream α) (s₂ : stream α) : nth (bit0 1 * n) (s₁⋈s₂) = nth n s₁ := sorry

theorem nth_interleave_right {α : Type u} (n : ℕ) (s₁ : stream α) (s₂ : stream α) : nth (bit0 1 * n + 1) (s₁⋈s₂) = nth n s₂ := sorry

theorem mem_interleave_left {α : Type u} {a : α} {s₁ : stream α} (s₂ : stream α) : a ∈ s₁ → a ∈ s₁⋈s₂ := sorry

theorem mem_interleave_right {α : Type u} {a : α} {s₁ : stream α} (s₂ : stream α) : a ∈ s₂ → a ∈ s₁⋈s₂ := sorry

def even {α : Type u} (s : stream α) : stream α :=
  corec (fun (s : stream α) => head s) (fun (s : stream α) => tail (tail s)) s

def odd {α : Type u} (s : stream α) : stream α :=
  even (tail s)

theorem odd_eq {α : Type u} (s : stream α) : odd s = even (tail s) :=
  rfl

theorem head_even {α : Type u} (s : stream α) : head (even s) = head s :=
  rfl

theorem tail_even {α : Type u} (s : stream α) : tail (even s) = even (tail (tail s)) := sorry

theorem even_cons_cons {α : Type u} (a₁ : α) (a₂ : α) (s : stream α) : even (a₁ :: a₂ :: s) = a₁ :: even s := sorry

theorem even_tail {α : Type u} (s : stream α) : even (tail s) = odd s :=
  rfl

theorem even_interleave {α : Type u} (s₁ : stream α) (s₂ : stream α) : even (s₁⋈s₂) = s₁ := sorry

theorem interleave_even_odd {α : Type u} (s₁ : stream α) : even s₁⋈odd s₁ = s₁ := sorry

theorem nth_even {α : Type u} (n : ℕ) (s : stream α) : nth n (even s) = nth (bit0 1 * n) s := sorry

theorem nth_odd {α : Type u} (n : ℕ) (s : stream α) : nth n (odd s) = nth (bit0 1 * n + 1) s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nth n (odd s) = nth (bit0 1 * n + 1) s)) (odd_eq s)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (nth n (even (tail s)) = nth (bit0 1 * n + 1) s)) (nth_even n (tail s))))
      (Eq.refl (nth (bit0 1 * n) (tail s))))

theorem mem_of_mem_even {α : Type u} (a : α) (s : stream α) : a ∈ even s → a ∈ s := sorry

theorem mem_of_mem_odd {α : Type u} (a : α) (s : stream α) : a ∈ odd s → a ∈ s := sorry

def append_stream {α : Type u} : List α → stream α → stream α :=
  sorry

theorem nil_append_stream {α : Type u} (s : stream α) : append_stream [] s = s :=
  rfl

theorem cons_append_stream {α : Type u} (a : α) (l : List α) (s : stream α) : append_stream (a :: l) s = a :: append_stream l s :=
  rfl

infixl:65 "++ₛ" => Mathlib.stream.append_stream

theorem append_append_stream {α : Type u} (l₁ : List α) (l₂ : List α) (s : stream α) : l₁ ++ l₂++ₛs = l₁++ₛ(l₂++ₛs) := sorry

theorem map_append_stream {α : Type u} {β : Type v} (f : α → β) (l : List α) (s : stream α) : map f (l++ₛs) = list.map f l++ₛmap f s := sorry

theorem drop_append_stream {α : Type u} (l : List α) (s : stream α) : drop (list.length l) (l++ₛs) = s := sorry

theorem append_stream_head_tail {α : Type u} (s : stream α) : [head s]++ₛtail s = s :=
  eq.mpr (id (Eq._oldrec (Eq.refl ([head s]++ₛtail s = s)) (cons_append_stream (head s) [] (tail s))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (head s :: ([]++ₛtail s) = s)) (nil_append_stream (tail s))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (head s :: tail s = s)) (stream.eta s))) (Eq.refl s)))

theorem mem_append_stream_right {α : Type u} {a : α} (l : List α) {s : stream α} : a ∈ s → a ∈ l++ₛs := sorry

theorem mem_append_stream_left {α : Type u} {a : α} {l : List α} (s : stream α) : a ∈ l → a ∈ l++ₛs := sorry

def approx {α : Type u} : ℕ → stream α → List α :=
  sorry

theorem approx_zero {α : Type u} (s : stream α) : approx 0 s = [] :=
  rfl

theorem approx_succ {α : Type u} (n : ℕ) (s : stream α) : approx (Nat.succ n) s = head s :: approx n (tail s) :=
  rfl

theorem nth_approx {α : Type u} (n : ℕ) (s : stream α) : list.nth (approx (Nat.succ n) s) n = some (nth n s) := sorry

theorem append_approx_drop {α : Type u} (n : ℕ) (s : stream α) : approx n s++ₛdrop n s = s := sorry

-- Take theorem reduces a proof of equality of infinite streams to an

-- induction over all their finite approximations.

theorem take_theorem {α : Type u} (s₁ : stream α) (s₂ : stream α) : (∀ (n : ℕ), approx n s₁ = approx n s₂) → s₁ = s₂ := sorry

-- auxiliary def for cycle corecursive def

-- auxiliary def for cycle corecursive def

def cycle {α : Type u} (l : List α) : l ≠ [] → stream α :=
  sorry

theorem cycle_eq {α : Type u} (l : List α) (h : l ≠ []) : cycle l h = l++ₛcycle l h := sorry

theorem mem_cycle {α : Type u} {a : α} {l : List α} (h : l ≠ []) : a ∈ l → a ∈ cycle l h :=
  fun (ainl : a ∈ l) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ cycle l h)) (cycle_eq l h))) (mem_append_stream_left (cycle l h) ainl)

theorem cycle_singleton {α : Type u} (a : α) (h : [a] ≠ []) : cycle [a] h = const a := sorry

def tails {α : Type u} (s : stream α) : stream (stream α) :=
  corec id tail (tail s)

theorem tails_eq {α : Type u} (s : stream α) : tails s = tail s :: tails (tail s) := sorry

theorem nth_tails {α : Type u} (n : ℕ) (s : stream α) : nth n (tails s) = drop n (tail s) := sorry

theorem tails_eq_iterate {α : Type u} (s : stream α) : tails s = iterate tail (tail s) :=
  rfl

def inits_core {α : Type u} (l : List α) (s : stream α) : stream (List α) :=
  corec_on (l, s) (fun (_x : List α × stream α) => sorry) fun (p : List α × stream α) => sorry

def inits {α : Type u} (s : stream α) : stream (List α) :=
  inits_core [head s] (tail s)

theorem inits_core_eq {α : Type u} (l : List α) (s : stream α) : inits_core l s = l :: inits_core (l ++ [head s]) (tail s) := sorry

theorem tail_inits {α : Type u} (s : stream α) : tail (inits s) = inits_core [head s, head (tail s)] (tail (tail s)) := sorry

theorem inits_tail {α : Type u} (s : stream α) : inits (tail s) = inits_core [head (tail s)] (tail (tail s)) :=
  rfl

theorem cons_nth_inits_core {α : Type u} (a : α) (n : ℕ) (l : List α) (s : stream α) : a :: nth n (inits_core l s) = nth n (inits_core (a :: l) s) := sorry

theorem nth_inits {α : Type u} (n : ℕ) (s : stream α) : nth n (inits s) = approx (Nat.succ n) s := sorry

theorem inits_eq {α : Type u} (s : stream α) : inits s = [head s] :: map (List.cons (head s)) (inits (tail s)) := sorry

theorem zip_inits_tails {α : Type u} (s : stream α) : zip append_stream (inits s) (tails s) = const s := sorry

def pure {α : Type u} (a : α) : stream α :=
  const a

def apply {α : Type u} {β : Type v} (f : stream (α → β)) (s : stream α) : stream β :=
  fun (n : ℕ) => nth n f (nth n s)

infixl:75 "⊛" => Mathlib.stream.apply

theorem identity {α : Type u} (s : stream α) : pure id⊛s = s :=
  rfl

theorem composition {α : Type u} {β : Type v} {δ : Type w} (g : stream (β → δ)) (f : stream (α → β)) (s : stream α) : pure function.comp⊛g⊛f⊛s = g⊛(f⊛s) :=
  rfl

theorem homomorphism {α : Type u} {β : Type v} (f : α → β) (a : α) : pure f⊛pure a = pure (f a) :=
  rfl

theorem interchange {α : Type u} {β : Type v} (fs : stream (α → β)) (a : α) : fs⊛pure a = (pure fun (f : α → β) => f a)⊛fs :=
  rfl

theorem map_eq_apply {α : Type u} {β : Type v} (f : α → β) (s : stream α) : map f s = pure f⊛s :=
  rfl

def nats : stream ℕ :=
  fun (n : ℕ) => n

theorem nth_nats (n : ℕ) : nth n nats = n :=
  rfl

theorem nats_eq : nats = 0 :: map Nat.succ nats := sorry


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Scott Morrison
-/
import category_theory.limits.exact_functor
import category_theory.limits.preserves.finite
import category_theory.preadditive.biproducts
import category_theory.preadditive.functor_category

/-!
# Additive Functors

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

A functor between two preadditive categories is called *additive*
provided that the induced map on hom types is a morphism of abelian
groups.

An additive functor between preadditive categories creates and preserves biproducts.
Conversely, if `F : C ⥤ D` is a functor between preadditive categories, where `C` has binary
biproducts, and if `F` preserves binary biproducts, then `F` is additive.

We also define the category of bundled additive functors.

# Implementation details

`functor.additive` is a `Prop`-valued class, defined by saying that for every two objects `X` and
`Y`, the map `F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)` is a morphism of abelian groups.

-/

universes v₁ v₂ u₁ u₂

namespace category_theory

/-- A functor `F` is additive provided `F.map` is an additive homomorphism. -/
class functor.additive {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D] (F : C ⥤ D) : Prop :=
(map_add' : Π {X Y : C} {f g : X ⟶ Y}, F.map (f + g) = F.map f + F.map g . obviously)

section preadditive

namespace functor

section
variables {C D : Type*} [category C] [category D] [preadditive C]
  [preadditive D] (F : C ⥤ D) [functor.additive F]

@[simp]

/-- `F.map_add_hom` is an additive homomorphism whose underlying function is `F.map`. -/
@[simps {fully_applied := ff}]
def map_add_hom {X Y : C} : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y) :=
add_monoid_hom.mk' (λ f, F.map f) (λ f g, F.map_add)

lemma coe_map_add_hom {X Y : C} : ⇑(F.map_add_hom : (X ⟶ Y) →+ _) = @map C _ D _ F X Y := rfl

@[priority 100]
instance preserves_zero_morphisms_of_additive : preserves_zero_morphisms F :=
{ map_zero' := λ X Y, F.map_add_hom.map_zero }

instance : additive (𝟭 C) :=
{}

instance {E : Type*} [category E] [preadditive E] (G : D ⥤ E) [functor.additive G] :
  additive (F ⋙ G) :=
{}

@[simp]
lemma map_neg {X Y : C} {f : X ⟶ Y} : F.map (-f) = - F.map f :=
(F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_neg _

@[simp]
lemma map_sub {X Y : C} {f g : X ⟶ Y} : F.map (f - g) = F.map f - F.map g :=
(F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_sub _ _

lemma map_nsmul {X Y : C} {f : X ⟶ Y} {n : ℕ} : F.map (n • f) = n • F.map f :=
(F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_nsmul _ _

-- You can alternatively just use `functor.map_smul` here, with an explicit `(r : ℤ)` argument.
lemma map_zsmul {X Y : C} {f : X ⟶ Y} {r : ℤ} : F.map (r • f) = r • F.map f :=
(F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_zsmul _ _

open_locale big_operators

@[simp]
lemma map_sum {X Y : C} {α : Type*} (f : α → (X ⟶ Y)) (s : finset α) :
  F.map (∑ a in s, f a) = ∑ a in s, F.map (f a) :=
(F.map_add_hom : (X ⟶ Y) →+ _).map_sum f s

end

section induced_category
variables {C : Type*} {D : Type*} [category D] [preadditive D] (F : C → D)

instance induced_functor_additive : functor.additive (induced_functor F) := {}

end induced_category

instance full_subcategory_inclusion_additive
  {C : Type*} [category C] [preadditive C] (Z : C → Prop) :
  (full_subcategory_inclusion Z).additive := {}

section
-- To talk about preservation of biproducts we need to specify universes explicitly.

noncomputable theory

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

open category_theory.limits
open category_theory.preadditive

@[priority 100]
instance preserves_finite_biproducts_of_additive [additive F] : preserves_finite_biproducts F :=
{ preserves := λ J _,
  { preserves := λ f,
    { preserves := λ b hb, by exactI is_bilimit_of_total _
      begin
        simp_rw [F.map_bicone_π, F.map_bicone_ι, ← F.map_comp, ← F.map_sum],
        dsimp only [map_bicone_X],
        simp_rw [← F.map_id],
        refine congr_arg _ (hb.is_limit.hom_ext (λ j, hb.is_colimit.hom_ext (λ j', _))),
        cases j, cases j',
        dsimp only [limits.bicone.to_cone_π_app],
        simp [sum_comp, comp_sum, bicone.ι_π, comp_dite, dite_comp],
      end } } }

lemma additive_of_preserves_binary_biproducts [has_binary_biproducts C] [preserves_zero_morphisms F]
  [preserves_binary_biproducts F] : additive F :=
{ map_add' := λ X Y f g, by rw [biprod.add_eq_lift_id_desc, F.map_comp, ← biprod.lift_map_biprod,
    ← biprod.map_biprod_hom_desc, category.assoc, iso.inv_hom_id_assoc, F.map_id,
    biprod.add_eq_lift_id_desc] }

end

end functor

namespace equivalence

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

instance inverse_additive (e : C ≌ D) [e.functor.additive] : e.inverse.additive :=
{ map_add' := λ X Y f g, by { apply e.functor.map_injective, simp, }, }

end equivalence

section
variables (C D : Type*) [category C] [category D] [preadditive C] [preadditive D]

/-- Bundled additive functors. -/
@[derive category, nolint has_nonempty_instance]
def AdditiveFunctor :=
full_subcategory (λ (F : C ⥤ D), F.additive)

infixr ` ⥤+ `:26 := AdditiveFunctor

instance : preadditive (C ⥤+ D) :=
preadditive.induced_category _

/-- An additive functor is in particular a functor. -/
@[derive full, derive faithful]
def AdditiveFunctor.forget : (C ⥤+ D) ⥤ (C ⥤ D) :=
full_subcategory_inclusion _

variables {C D}

/-- Turn an additive functor into an object of the category `AdditiveFunctor C D`. -/
def AdditiveFunctor.of (F : C ⥤ D) [F.additive] : C ⥤+ D :=
⟨F, infer_instance⟩

@[simp]
lemma AdditiveFunctor.of_fst (F : C ⥤ D) [F.additive] : (AdditiveFunctor.of F).1 = F :=
rfl

@[simp]
lemma AdditiveFunctor.forget_obj (F : C ⥤+ D) : (AdditiveFunctor.forget C D).obj F = F.1 :=
rfl

lemma AdditiveFunctor.forget_obj_of (F : C ⥤ D) [F.additive] :
  (AdditiveFunctor.forget C D).obj (AdditiveFunctor.of F) = F :=
rfl

@[simp]
lemma AdditiveFunctor.forget_map (F G : C ⥤+ D) (α : F ⟶ G) :
  (AdditiveFunctor.forget C D).map α = α :=
rfl

instance : functor.additive (AdditiveFunctor.forget C D) :=
{ map_add' := λ F G α β, rfl }

instance (F : C ⥤+ D) : functor.additive F.1 :=
F.2

end

section exact
open category_theory.limits

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

section
local attribute [instance] preserves_binary_biproducts_of_preserves_binary_products
local attribute [instance] preserves_binary_biproducts_of_preserves_binary_coproducts

/-- Turn a left exact functor into an additive functor. -/
@[derive full, derive faithful]
def AdditiveFunctor.of_left_exact : (C ⥤ₗ D) ⥤ (C ⥤+ D) :=
full_subcategory.map (λ F h, let hF := classical.choice h in
    by exactI functor.additive_of_preserves_binary_biproducts F)

/-- Turn a right exact functor into an additive functor. -/
@[derive full, derive faithful]
def AdditiveFunctor.of_right_exact : (C ⥤ᵣ D) ⥤ (C ⥤+ D) :=
full_subcategory.map (λ F h, let hF := classical.choice h in
  by exactI functor.additive_of_preserves_binary_biproducts F)

/-- Turn an exact functor into an additive functor. -/
@[derive full, derive faithful]
def AdditiveFunctor.of_exact : (C ⥤ₑ D) ⥤ (C ⥤+ D) :=
full_subcategory.map (λ F h, let hF := classical.choice h.1 in
  by exactI functor.additive_of_preserves_binary_biproducts F)

end

variables {C D}

@[simp] lemma AdditiveFunctor.of_left_exact_obj_fst (F : C ⥤ₗ D) :
  ((AdditiveFunctor.of_left_exact C D).obj F).obj = F.obj := rfl
@[simp] lemma AdditiveFunctor.of_right_exact_obj_fst (F : C ⥤ᵣ D) :
  ((AdditiveFunctor.of_right_exact C D).obj F).obj = F.obj := rfl
@[simp] lemma AdditiveFunctor.of_exact_obj_fst (F : C ⥤ₑ D) :
  ((AdditiveFunctor.of_exact C D).obj F).obj = F.obj := rfl

@[simp] lemma Additive_Functor.of_left_exact_map {F G : C ⥤ₗ D} (α : F ⟶ G) :
  (AdditiveFunctor.of_left_exact C D).map α = α := rfl
@[simp] lemma Additive_Functor.of_right_exact_map {F G : C ⥤ᵣ D} (α : F ⟶ G) :
  (AdditiveFunctor.of_right_exact C D).map α = α := rfl
@[simp] lemma Additive_Functor.of_exact_map {F G : C ⥤ₑ D} (α : F ⟶ G) :
  (AdditiveFunctor.of_exact C D).map α = α := rfl

end exact

end preadditive

end category_theory


import Std.Classes.BEq

namespace MWE_eq1

example [BEq α] [LawfulBEq α] {x y : α} (h : ¬(x = y))
  : (match x == y with | true => 0 | false => 1) = 1 := by
  have : (x == y) = false := by simp [beq_eq_false_iff_ne, h]
  simp [this]

end MWE_eq1


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.adjunction.reflective
import category_theory.monad.algebra

namespace category_theory
open category

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

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
variables {L : C ⥤ D} {R : D ⥤ C}

namespace adjunction

/--
For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a monad on
the category `C`.
-/
@[simps]
def to_monad (h : L ⊣ R) : monad C :=
{ to_functor := L ⋙ R,
  η' := h.unit,
  μ' := whisker_right (whisker_left L h.counit) R,
  assoc' := λ X, by { dsimp, rw [←R.map_comp], simp },
  right_unit' := λ X, by { dsimp, rw [←R.map_comp], simp } }

/--
For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a comonad on
the category `D`.
-/
@[simps]
def to_comonad (h : L ⊣ R) : comonad D :=
{ to_functor := R ⋙ L,
  ε' := h.counit,
  δ' := whisker_right (whisker_left R h.unit) L,
  coassoc' := λ X, by { dsimp, rw ← L.map_comp, simp },
  right_counit' := λ X, by { dsimp, rw ← L.map_comp, simp } }

/-- The monad induced by the Eilenberg-Moore adjunction is the original monad.  -/
@[simps]
def adj_to_monad_iso (T : monad C) : T.adj.to_monad ≅ T :=
monad_iso.mk (nat_iso.of_components (λ X, iso.refl _) (by tidy))
  (λ X, by { dsimp, simp })
  (λ X, by { dsimp, simp })

/-- The comonad induced by the Eilenberg-Moore adjunction is the original comonad. -/
@[simps]
def adj_to_comonad_iso (G : comonad C) : G.adj.to_comonad ≅ G :=
comonad_iso.mk (nat_iso.of_components (λ X, iso.refl _) (by tidy))
  (λ X, by { dsimp, simp })
  (λ X, by { dsimp, simp })

end adjunction

/--
Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.monad.comparison R`
sending objects `Y : D` to Eilenberg-Moore algebras for `L ⋙ R` with underlying object `R.obj X`.

We later show that this is full when `R` is full, faithful when `R` is faithful,
and essentially surjective when `R` is reflective.
-/
@[simps]
def monad.comparison (h : L ⊣ R) : D ⥤ h.to_monad.algebra :=
{ obj := λ X,
  { A := R.obj X,
    a := R.map (h.counit.app X),
    assoc' := by { dsimp, rw [← R.map_comp, ← adjunction.counit_naturality, R.map_comp], refl } },
  map := λ X Y f,
  { f := R.map f,
    h' := by { dsimp, rw [← R.map_comp, adjunction.counit_naturality, R.map_comp] } } }.

/--
The underlying object of `(monad.comparison R).obj X` is just `R.obj X`.
-/
@[simps]
def monad.comparison_forget (h : L ⊣ R) :
  monad.comparison h ⋙ h.to_monad.forget ≅ R :=
{ hom := { app := λ X, 𝟙 _, },
  inv := { app := λ X, 𝟙 _, } }

lemma monad.left_comparison (h : L ⊣ R) : L ⋙ monad.comparison h = h.to_monad.free := rfl

instance [faithful R] (h : L ⊣ R) :
  faithful (monad.comparison h) :=
{ map_injective' := λ X Y f g w, R.map_injective (congr_arg monad.algebra.hom.f w : _) }

instance (T : monad C) : full (monad.comparison T.adj) :=
{ preimage := λ X Y f, ⟨f.f, by simpa using f.h⟩ }

instance (T : monad C) : ess_surj (monad.comparison T.adj) :=
{ mem_ess_image := λ X,
  ⟨{ A := X.A, a := X.a, unit' := by simpa using X.unit, assoc' := by simpa using X.assoc },
    ⟨monad.algebra.iso_mk (iso.refl _) (by simp)⟩⟩ }

/--
Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.comonad.comparison L`
sending objects `X : C` to Eilenberg-Moore coalgebras for `L ⋙ R` with underlying object
`L.obj X`.
-/
@[simps]
def comonad.comparison (h : L ⊣ R) : C ⥤ h.to_comonad.coalgebra :=
{ obj := λ X,
  { A := L.obj X,
    a := L.map (h.unit.app X),
    coassoc' := by { dsimp, rw [← L.map_comp, ← adjunction.unit_naturality, L.map_comp], refl } },
  map := λ X Y f,
  { f := L.map f,
    h' := by { dsimp, rw ← L.map_comp, simp } } }

/--
The underlying object of `(comonad.comparison L).obj X` is just `L.obj X`.
-/
@[simps]
def comonad.comparison_forget {L : C ⥤ D} {R : D ⥤ C} (h : L ⊣ R) :
  comonad.comparison h ⋙ h.to_comonad.forget ≅ L :=
{ hom := { app := λ X, 𝟙 _, },
  inv := { app := λ X, 𝟙 _, } }

lemma comonad.left_comparison (h : L ⊣ R) : R ⋙ comonad.comparison h = h.to_comonad.cofree := rfl

instance comonad.comparison_faithful_of_faithful [faithful L] (h : L ⊣ R) :
  faithful (comonad.comparison h) :=
{ map_injective' := λ X Y f g w, L.map_injective (congr_arg comonad.coalgebra.hom.f w : _) }

instance (G : comonad C) : full (comonad.comparison G.adj) :=
{ preimage := λ X Y f, ⟨f.f, by simpa using f.h⟩ }

instance (G : comonad C) : ess_surj (comonad.comparison G.adj) :=
{ mem_ess_image := λ X,
  ⟨{ A := X.A, a := X.a, counit' := by simpa using X.counit, coassoc' := by simpa using X.coassoc },
    ⟨comonad.coalgebra.iso_mk (iso.refl _) (by simp)⟩⟩ }

/--
A right adjoint functor `R : D ⥤ C` is *monadic* if the comparison functor `monad.comparison R`
from `D` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class monadic_right_adjoint (R : D ⥤ C) extends is_right_adjoint R :=
(eqv : is_equivalence (monad.comparison (adjunction.of_right_adjoint R)))

/--
A left adjoint functor `L : C ⥤ D` is *comonadic* if the comparison functor `comonad.comparison L`
from `C` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class comonadic_left_adjoint (L : C ⥤ D) extends is_left_adjoint L :=
(eqv : is_equivalence (comonad.comparison (adjunction.of_left_adjoint L)))

noncomputable instance (T : monad C) : monadic_right_adjoint T.forget :=
⟨(equivalence.of_fully_faithfully_ess_surj _ : is_equivalence (monad.comparison T.adj))⟩

noncomputable instance (G : comonad C) : comonadic_left_adjoint G.forget :=
⟨(equivalence.of_fully_faithfully_ess_surj _ : is_equivalence (comonad.comparison G.adj))⟩

-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
instance μ_iso_of_reflective [reflective R] : is_iso (adjunction.of_right_adjoint R).to_monad.μ :=
by { dsimp, apply_instance }

attribute [instance] monadic_right_adjoint.eqv
attribute [instance] comonadic_left_adjoint.eqv

namespace reflective

instance [reflective R] (X : (adjunction.of_right_adjoint R).to_monad.algebra) :
  is_iso ((adjunction.of_right_adjoint R).unit.app X.A) :=
⟨⟨X.a, ⟨X.unit, begin
    dsimp only [functor.id_obj],
    rw ← (adjunction.of_right_adjoint R).unit_naturality,
    dsimp only [functor.comp_obj, adjunction.to_monad_coe],
    rw [unit_obj_eq_map_unit, ←functor.map_comp, ←functor.map_comp],
    erw X.unit,
    simp,
  end⟩⟩⟩

instance comparison_ess_surj [reflective R] :
  ess_surj (monad.comparison (adjunction.of_right_adjoint R)) :=
begin
  refine ⟨λ X, ⟨(left_adjoint R).obj X.A, ⟨_⟩⟩⟩,
  symmetry,
  refine monad.algebra.iso_mk _ _,
  { exact as_iso ((adjunction.of_right_adjoint R).unit.app X.A) },
  dsimp only [functor.comp_map, monad.comparison_obj_a, as_iso_hom, functor.comp_obj,
    monad.comparison_obj_A, monad_to_functor_eq_coe, adjunction.to_monad_coe],
  rw [←cancel_epi ((adjunction.of_right_adjoint R).unit.app X.A), adjunction.unit_naturality_assoc,
      adjunction.right_triangle_components, comp_id],
  apply (X.unit_assoc _).symm,
end

instance comparison_full [full R] [is_right_adjoint R] :
  full (monad.comparison (adjunction.of_right_adjoint R)) :=
{ preimage := λ X Y f, R.preimage f.f }

end reflective

-- It is possible to do this computably since the construction gives the data of the inverse, not
-- just the existence of an inverse on each object.
/-- Any reflective inclusion has a monadic right adjoint.
    cf Prop 5.3.3 of [Riehl][riehl2017] -/
@[priority 100] -- see Note [lower instance priority]
noncomputable instance monadic_of_reflective [reflective R] : monadic_right_adjoint R :=
{ eqv := equivalence.of_fully_faithfully_ess_surj _ }

end category_theory


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.epi_mono
import category_theory.limits.shapes.strong_epi
import category_theory.lifting_properties.adjunction

/-!
# Preservation and reflection of monomorphisms and epimorphisms

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

We provide typeclasses that state that a functor preserves or reflects monomorphisms or
epimorphisms.
-/

open category_theory

universes v₁ v₂ v₃ u₁ u₂ u₃

namespace category_theory.functor
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
  {E : Type u₃} [category.{v₃} E]

/-- A functor preserves monomorphisms if it maps monomorphisms to monomorphisms. -/
class preserves_monomorphisms (F : C ⥤ D) : Prop :=
(preserves : ∀ {X Y : C} (f : X ⟶ Y) [mono f], mono (F.map f))

instance map_mono (F : C ⥤ D) [preserves_monomorphisms F] {X Y : C} (f : X ⟶ Y) [mono f] :
  mono (F.map f) :=
preserves_monomorphisms.preserves f

/-- A functor preserves epimorphisms if it maps epimorphisms to epimorphisms. -/
class preserves_epimorphisms (F : C ⥤ D) : Prop :=
(preserves : ∀ {X Y : C} (f : X ⟶ Y) [epi f], epi (F.map f))

instance map_epi (F : C ⥤ D) [preserves_epimorphisms F] {X Y : C} (f : X ⟶ Y) [epi f] :
  epi (F.map f) :=
preserves_epimorphisms.preserves f

/-- A functor reflects monomorphisms if morphisms that are mapped to monomorphisms are themselves
    monomorphisms. -/
class reflects_monomorphisms (F : C ⥤ D) : Prop :=
(reflects : ∀ {X Y : C} (f : X ⟶ Y), mono (F.map f) → mono f)

lemma mono_of_mono_map (F : C ⥤ D) [reflects_monomorphisms F] {X Y : C} {f : X ⟶ Y}
  (h : mono (F.map f)) : mono f :=
reflects_monomorphisms.reflects f h

/-- A functor reflects epimorphisms if morphisms that are mapped to epimorphisms are themselves
    epimorphisms. -/
class reflects_epimorphisms (F : C ⥤ D) : Prop :=
(reflects : ∀ {X Y : C} (f : X ⟶ Y), epi (F.map f) → epi f)

lemma epi_of_epi_map (F : C ⥤ D) [reflects_epimorphisms F] {X Y : C} {f : X ⟶ Y}
  (h : epi (F.map f)) : epi f :=
reflects_epimorphisms.reflects f h

instance preserves_monomorphisms_comp (F : C ⥤ D) (G : D ⥤ E) [preserves_monomorphisms F]
  [preserves_monomorphisms G] : preserves_monomorphisms (F ⋙ G) :=
{ preserves := λ X Y f h, by { rw comp_map, exactI infer_instance } }

instance preserves_epimorphisms_comp (F : C ⥤ D) (G : D ⥤ E) [preserves_epimorphisms F]
  [preserves_epimorphisms G] : preserves_epimorphisms (F ⋙ G) :=
{ preserves := λ X Y f h, by { rw comp_map, exactI infer_instance } }

instance reflects_monomorphisms_comp (F : C ⥤ D) (G : D ⥤ E) [reflects_monomorphisms F]
  [reflects_monomorphisms G] : reflects_monomorphisms (F ⋙ G) :=
{ reflects := λ X Y f h, (F.mono_of_mono_map (G.mono_of_mono_map h)) }

instance reflects_epimorphisms_comp (F : C ⥤ D) (G : D ⥤ E) [reflects_epimorphisms F]
  [reflects_epimorphisms G] : reflects_epimorphisms (F ⋙ G) :=
{ reflects := λ X Y f h, (F.epi_of_epi_map (G.epi_of_epi_map h)) }

lemma preserves_epimorphisms_of_preserves_of_reflects (F : C ⥤ D) (G : D ⥤ E)
  [preserves_epimorphisms (F ⋙ G)] [reflects_epimorphisms G] : preserves_epimorphisms F :=
⟨λ X Y f hf, G.epi_of_epi_map $ show epi ((F ⋙ G).map f), by exactI infer_instance⟩

lemma preserves_monomorphisms_of_preserves_of_reflects (F : C ⥤ D) (G : D ⥤ E)
  [preserves_monomorphisms (F ⋙ G)] [reflects_monomorphisms G] : preserves_monomorphisms F :=
⟨λ X Y f hf, G.mono_of_mono_map $ show mono ((F ⋙ G).map f), by exactI infer_instance⟩

lemma reflects_epimorphisms_of_preserves_of_reflects (F : C ⥤ D) (G : D ⥤ E)
  [preserves_epimorphisms G] [reflects_epimorphisms (F ⋙ G)] : reflects_epimorphisms F :=
⟨λ X Y f hf, (F ⋙ G).epi_of_epi_map $ show epi (G.map (F.map f)), by exactI infer_instance⟩

lemma reflects_monomorphisms_of_preserves_of_reflects (F : C ⥤ D) (G : D ⥤ E)
  [preserves_monomorphisms G] [reflects_monomorphisms (F ⋙ G)] : reflects_monomorphisms F :=
⟨λ X Y f hf, (F ⋙ G).mono_of_mono_map $ show mono (G.map (F.map f)), by exactI infer_instance⟩

lemma preserves_monomorphisms.of_iso {F G : C ⥤ D} [preserves_monomorphisms F] (α : F ≅ G) :
  preserves_monomorphisms G :=
{ preserves := λ X Y f h,
  begin
    haveI : mono (F.map f ≫ (α.app Y).hom) := by exactI mono_comp _ _,
    convert (mono_comp _ _ : mono ((α.app X).inv ≫ F.map f ≫ (α.app Y).hom)),
    rw [iso.eq_inv_comp, iso.app_hom, iso.app_hom, nat_trans.naturality]
  end }

lemma preserves_monomorphisms.iso_iff {F G : C ⥤ D} (α : F ≅ G) :
  preserves_monomorphisms F ↔ preserves_monomorphisms G :=
⟨λ h, by exactI preserves_monomorphisms.of_iso α,
 λ h, by exactI preserves_monomorphisms.of_iso α.symm⟩

lemma preserves_epimorphisms.of_iso {F G : C ⥤ D} [preserves_epimorphisms F] (α : F ≅ G) :
  preserves_epimorphisms G :=
{ preserves := λ X Y f h,
  begin
    haveI : epi (F.map f ≫ (α.app Y).hom) := by exactI epi_comp _ _,
    convert (epi_comp _ _ : epi ((α.app X).inv ≫ F.map f ≫ (α.app Y).hom)),
    rw [iso.eq_inv_comp, iso.app_hom, iso.app_hom, nat_trans.naturality]
  end }

lemma preserves_epimorphisms.iso_iff {F G : C ⥤ D} (α : F ≅ G) :
  preserves_epimorphisms F ↔ preserves_epimorphisms G :=
⟨λ h, by exactI preserves_epimorphisms.of_iso α,
 λ h, by exactI preserves_epimorphisms.of_iso α.symm⟩

lemma reflects_monomorphisms.of_iso {F G : C ⥤ D} [reflects_monomorphisms F] (α : F ≅ G) :
  reflects_monomorphisms G :=
{ reflects := λ X Y f h,
  begin
    apply F.mono_of_mono_map,
    haveI : mono (G.map f ≫ (α.app Y).inv) := by exactI mono_comp _ _,
    convert (mono_comp _ _ : mono ((α.app X).hom ≫ G.map f ≫ (α.app Y).inv)),
    rw [← category.assoc, iso.eq_comp_inv, iso.app_hom, iso.app_hom, nat_trans.naturality]
  end }

lemma reflects_monomorphisms.iso_iff {F G : C ⥤ D} (α : F ≅ G) :
  reflects_monomorphisms F ↔ reflects_monomorphisms G :=
⟨λ h, by exactI reflects_monomorphisms.of_iso α,
 λ h, by exactI reflects_monomorphisms.of_iso α.symm⟩

lemma reflects_epimorphisms.of_iso {F G : C ⥤ D} [reflects_epimorphisms F] (α : F ≅ G) :
  reflects_epimorphisms G :=
{ reflects := λ X Y f h,
  begin
    apply F.epi_of_epi_map,
    haveI : epi (G.map f ≫ (α.app Y).inv) := by exactI epi_comp _ _,
    convert (epi_comp _ _ : epi ((α.app X).hom ≫ G.map f ≫ (α.app Y).inv)),
    rw [← category.assoc, iso.eq_comp_inv, iso.app_hom, iso.app_hom, nat_trans.naturality]
  end }

lemma reflects_epimorphisms.iso_iff {F G : C ⥤ D} (α : F ≅ G) :
  reflects_epimorphisms F ↔ reflects_epimorphisms G :=
⟨λ h, by exactI reflects_epimorphisms.of_iso α, λ h, by exactI reflects_epimorphisms.of_iso α.symm⟩

lemma preserves_epimorphsisms_of_adjunction {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) :
 preserves_epimorphisms F :=
{ preserves := λ X Y f hf,
  ⟨begin
    introsI Z g h H,
    replace H := congr_arg (adj.hom_equiv X Z) H,
    rwa [adj.hom_equiv_naturality_left, adj.hom_equiv_naturality_left, cancel_epi,
      equiv.apply_eq_iff_eq] at H
  end⟩ }

@[priority 100]
instance preserves_epimorphisms_of_is_left_adjoint (F : C ⥤ D) [is_left_adjoint F] :
  preserves_epimorphisms F :=
preserves_epimorphsisms_of_adjunction (adjunction.of_left_adjoint F)

@[priority 100]
instance preserves_monomorphisms_of_is_right_adjoint (F : C ⥤ D) [is_right_adjoint F] :
  preserves_monomorphisms F :=
preserves_monomorphisms_of_adjunction (adjunction.of_right_adjoint F)

@[priority 100]
instance reflects_monomorphisms_of_faithful (F : C ⥤ D) [faithful F] : reflects_monomorphisms F :=
{ reflects := λ X Y f hf, ⟨λ Z g h hgh, by exactI F.map_injective ((cancel_mono (F.map f)).1
    (by rw [← F.map_comp, hgh, F.map_comp]))⟩ }

@[priority 100]
instance reflects_epimorphisms_of_faithful (F : C ⥤ D) [faithful F] : reflects_epimorphisms F :=
{ reflects := λ X Y f hf, ⟨λ Z g h hgh, by exactI F.map_injective ((cancel_epi (F.map f)).1
    (by rw [← F.map_comp, hgh, F.map_comp]))⟩ }

section

variables (F : C ⥤ D) {X Y : C} (f : X ⟶ Y)

/-- If `F` is a fully faithful functor, split epimorphisms are preserved and reflected by `F`. -/
def split_epi_equiv [full F] [faithful F] : split_epi f ≃ split_epi (F.map f) :=
{ to_fun := λ f, f.map F,
  inv_fun := λ s, begin
    refine ⟨F.preimage s.section_, _⟩,
    apply F.map_injective,
    simp only [map_comp, image_preimage, map_id],
    apply split_epi.id,
  end,
  left_inv := by tidy,
  right_inv := by tidy, }

@[simp]
lemma is_split_epi_iff [full F] [faithful F] : is_split_epi (F.map f) ↔ is_split_epi f :=
begin
  split,
  { intro h, exact is_split_epi.mk' ((split_epi_equiv F f).inv_fun h.exists_split_epi.some), },
  { intro h, exact is_split_epi.mk' ((split_epi_equiv F f).to_fun h.exists_split_epi.some), },
end

/-- If `F` is a fully faithful functor, split monomorphisms are preserved and reflected by `F`. -/
def split_mono_equiv [full F] [faithful F] : split_mono f ≃ split_mono (F.map f) :=
{ to_fun := λ f, f.map F,
  inv_fun := λ s, begin
    refine ⟨F.preimage s.retraction, _⟩,
    apply F.map_injective,
    simp only [map_comp, image_preimage, map_id],
    apply split_mono.id,
  end,
  left_inv := by tidy,
  right_inv := by tidy, }

@[simp]
lemma is_split_mono_iff [full F] [faithful F] : is_split_mono (F.map f) ↔ is_split_mono f :=
begin
  split,
  { intro h, exact is_split_mono.mk' ((split_mono_equiv F f).inv_fun h.exists_split_mono.some), },
  { intro h, exact is_split_mono.mk' ((split_mono_equiv F f).to_fun h.exists_split_mono.some), },
end

@[simp]
lemma epi_map_iff_epi [hF₁ : preserves_epimorphisms F] [hF₂ : reflects_epimorphisms F] :
  epi (F.map f) ↔ epi f :=
begin
  split,
  { exact F.epi_of_epi_map, },
  { introI h,
    exact F.map_epi f, },
end

@[simp]
lemma mono_map_iff_mono [hF₁ : preserves_monomorphisms F] [hF₂ : reflects_monomorphisms F] :
  mono (F.map f) ↔ mono f :=
begin
  split,
  { exact F.mono_of_mono_map, },
  { introI h,
    exact F.map_mono f, },
end

/-- If `F : C ⥤ D` is an equivalence of categories and `C` is a `split_epi_category`,
then `D` also is. -/
def split_epi_category_imp_of_is_equivalence [is_equivalence F] [split_epi_category C] :
  split_epi_category D :=
⟨λ X Y f, begin
  introI,
  rw ← F.inv.is_split_epi_iff f,
  apply is_split_epi_of_epi,
end⟩

end

end category_theory.functor

namespace category_theory.adjunction

variables {C D : Type*} [category C] [category D] {F : C ⥤ D} {F' : D ⥤ C} {A B : C}

lemma strong_epi_map_of_strong_epi (adj : F ⊣ F') (f : A ⟶ B)
  [h₁ : F'.preserves_monomorphisms] [h₂ : F.preserves_epimorphisms] [strong_epi f] :
  strong_epi (F.map f) :=
⟨infer_instance, λ X Y Z, by { introI, rw adj.has_lifting_property_iff, apply_instance, }⟩

instance strong_epi_map_of_is_equivalence [is_equivalence F] (f : A ⟶ B) [h : strong_epi f] :
  strong_epi (F.map f) :=
F.as_equivalence.to_adjunction.strong_epi_map_of_strong_epi f

end category_theory.adjunction

namespace category_theory.functor

variables {C D : Type*} [category C] [category D] {F : C ⥤ D} {A B : C} (f : A ⟶ B)

@[simp]
lemma strong_epi_map_iff_strong_epi_of_is_equivalence [is_equivalence F] :
  strong_epi (F.map f) ↔ strong_epi f  :=
begin
  split,
  { introI,
    have e : arrow.mk f ≅ arrow.mk (F.inv.map (F.map f)) :=
      arrow.iso_of_nat_iso F.as_equivalence.unit_iso (arrow.mk f),
    rw strong_epi.iff_of_arrow_iso e,
    apply_instance, },
  { introI,
    apply_instance, },
end

end category_theory.functor


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.sheaves.presheaf

/-!
# Presheafed spaces

Introduces the category of topological spaces equipped with a presheaf (taking values in an
arbitrary target category `C`.)

We further describe how to apply functors and natural transformations to the values of the
presheaves.
-/

universes v u

open category_theory
open Top
open topological_space
open opposite
open category_theory.category category_theory.functor

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

local attribute [tidy] tactic.op_induction'

namespace algebraic_geometry

/-- A `PresheafedSpace C` is a topological space equipped with a presheaf of `C`s. -/
structure PresheafedSpace :=
(carrier : Top)
(presheaf : carrier.presheaf C)

variables {C}

namespace PresheafedSpace

attribute [protected] presheaf

instance coe_carrier : has_coe (PresheafedSpace C) Top :=
{ coe := λ X, X.carrier }

@[simp] lemma as_coe (X : PresheafedSpace C) : X.carrier = (X : Top.{v}) := rfl
@[simp] lemma mk_coe (carrier) (presheaf) : (({ carrier := carrier, presheaf := presheaf } :
  PresheafedSpace.{v} C) : Top.{v}) = carrier := rfl

instance (X : PresheafedSpace.{v} C) : topological_space X := X.carrier.str

/-- The constant presheaf on `X` with value `Z`. -/
def const (X : Top) (Z : C) : PresheafedSpace C :=
{ carrier := X,
  presheaf :=
  { obj := λ U, Z,
    map := λ U V f, 𝟙 Z, } }

instance [inhabited C] : inhabited (PresheafedSpace C) := ⟨const (Top.of pempty) (default C)⟩

/-- A morphism between presheafed spaces `X` and `Y` consists of a continuous map
    `f` between the underlying topological spaces, and a (notice contravariant!) map
    from the presheaf on `Y` to the pushforward of the presheaf on `X` via `f`. -/
structure hom (X Y : PresheafedSpace C) :=
(base : (X : Top.{v}) ⟶ (Y : Top.{v}))
(c : Y.presheaf ⟶ base _* X.presheaf)

@[ext] lemma ext {X Y : PresheafedSpace C} (α β : hom X Y)
  (w : α.base = β.base)
  (h : α.c ≫ (whisker_right (nat_trans.op (opens.map_iso _ _ w).inv) X.presheaf) = β.c) :
  α = β :=
begin
  cases α, cases β,
  dsimp [presheaf.pushforward_obj] at *,
  tidy, -- TODO including `injections` would make tidy work earlier.
end
.

/-- The identity morphism of a `PresheafedSpace`. -/
def id (X : PresheafedSpace C) : hom X X :=
{ base := 𝟙 (X : Top.{v}),
  c := (functor.left_unitor _).inv ≫ whisker_right (nat_trans.op (opens.map_id X.carrier).hom) _ }

instance hom_inhabited (X : PresheafedSpace C) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `PresheafedSpace`s. -/
def comp {X Y Z : PresheafedSpace C} (α : hom X Y) (β : hom Y Z) : hom X Z :=
{ base := α.base ≫ β.base,
  c := β.c ≫ (whisker_left (opens.map β.base).op α.c) ≫ (Top.presheaf.pushforward.comp _ _ _).inv }

variables (C)

section
local attribute [simp] id comp

/- The proofs below can be done by `tidy`, but it is too slow,
   and we don't have a tactic caching mechanism. -/
/-- The category of PresheafedSpaces. Morphisms are pairs, a continuous map and a presheaf map
    from the presheaf on the target to the pushforward of the presheaf on the source. -/
instance category_of_PresheafedSpaces : category (PresheafedSpace C) :=
{ hom := hom,
  id := id,
  comp := λ X Y Z f g, comp f g,
  id_comp' := λ X Y f,
  begin
    ext1, swap,
    { dsimp, simp only [id_comp] },  -- See note [dsimp, simp].
    { ext U, op_induction, cases U,
      dsimp,
      simp only [presheaf.pushforward.comp_inv_app, opens.map_iso_inv_app],
      dsimp,
      simp only [comp_id, comp_id, map_id], },
  end,
  comp_id' := λ X Y f,
  begin
    ext1, swap,
    { dsimp, simp only [comp_id] },
    { ext U, op_induction, cases U,
      dsimp,
      simp only [presheaf.pushforward.comp_inv_app, opens.map_iso_inv_app],
      dsimp,
      simp only [id_comp, comp_id, map_id], }
  end,
  assoc' := λ W X Y Z f g h,
  begin
     ext1, swap,
     refl,
     { ext U, op_induction, cases U,
       dsimp,
       simp only [assoc, presheaf.pushforward.comp_inv_app, opens.map_iso_inv_app],
       dsimp,
       simp only [comp_id, id_comp, map_id], }
  end }

end

variables {C}

@[simp] lemma id_base (X : PresheafedSpace C) :
  ((𝟙 X) : X ⟶ X).base = (𝟙 (X : Top.{v})) := rfl

lemma id_c (X : PresheafedSpace C) :
  ((𝟙 X) : X ⟶ X).c =
  (functor.left_unitor _).inv ≫ whisker_right (nat_trans.op (opens.map_id X.carrier).hom) _ := rfl

@[simp] lemma id_c_app (X : PresheafedSpace C) (U) :
  ((𝟙 X) : X ⟶ X).c.app U = eq_to_hom (by { op_induction U, cases U, refl }) :=
by { op_induction U, cases U, simp only [id_c], dsimp, simp, }

@[simp] lemma comp_base {X Y Z : PresheafedSpace C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).base = f.base ≫ g.base := rfl

@[simp] lemma comp_c_app {X Y Z : PresheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z) (U) :
  (α ≫ β).c.app U = (β.c).app U ≫ (α.c).app (op ((opens.map (β.base)).obj (unop U))) ≫
    (Top.presheaf.pushforward.comp _ _ _).inv.app U := rfl

lemma congr_app {X Y : PresheafedSpace C} {α β : X ⟶ Y} (h : α = β) (U) :
  α.c.app U = β.c.app U ≫ X.presheaf.map (eq_to_hom (by subst h)) :=
by { subst h, dsimp, simp, }

section
variables (C)

/-- The forgetful functor from `PresheafedSpace` to `Top`. -/
@[simps]
def forget : PresheafedSpace C ⥤ Top :=
{ obj := λ X, (X : Top.{v}),
  map := λ X Y f, f.base }

end

/--
The restriction of a presheafed space along an open embedding into the space.
-/
@[simps]
def restrict {U : Top} (X : PresheafedSpace C)
  (f : U ⟶ (X : Top.{v})) (h : open_embedding f) : PresheafedSpace C :=
{ carrier := U,
  presheaf := h.is_open_map.functor.op ⋙ X.presheaf }

/--
The map from the restriction of a presheafed space.
-/
@[simps]
def of_restrict (U : Top) (X : PresheafedSpace C)
  (f : U ⟶ (X : Top.{v})) (h : open_embedding f) :
  X.restrict f h ⟶ X :=
{ base := f,
  c := { app := λ V, X.presheaf.map $
      ((h.is_open_map.adjunction.hom_equiv _ _).symm (𝟙 $ (opens.map f).obj $ unop V)).op,
    naturality':= λ U V f, show _ = _ ≫ X.presheaf.map _,
      by { rw [← map_comp, ← map_comp], refl } } }

/--
The map to the restriction of a presheafed space along the canonical inclusion from the top
subspace.
-/
@[simps]
def to_restrict_top (X : PresheafedSpace C) :
  X ⟶ X.restrict (opens.inclusion ⊤) (opens.open_embedding ⊤) :=
{ base := ⟨λ x, ⟨x, trivial⟩, continuous_def.2 $ λ U ⟨S, hS, hSU⟩, hSU ▸ hS⟩,
  c := { app := λ U, X.presheaf.map $ (hom_of_le $ λ x hxU, ⟨⟨x, trivial⟩, hxU, rfl⟩ :
      (opens.map (⟨λ x, ⟨x, trivial⟩, continuous_def.2 $ λ U ⟨S, hS, hSU⟩, hSU ▸ hS⟩ :
          X.1 ⟶ (opens.to_Top X.1).obj ⊤)).obj (unop U) ⟶
        (opens.open_embedding ⊤).is_open_map.functor.obj (unop U)).op,
    naturality':= λ U V f, show X.presheaf.map _ ≫ _ = _ ≫ X.presheaf.map _,
      by { rw [← map_comp, ← map_comp], refl } } }

/--
The isomorphism from the restriction to the top subspace.
-/
@[simps]
def restrict_top_iso (X : PresheafedSpace C) :
  X.restrict (opens.inclusion ⊤) (opens.open_embedding ⊤) ≅ X :=
{ hom := X.of_restrict _ _ _,
  inv := X.to_restrict_top,
  hom_inv_id' := ext _ _ (concrete_category.hom_ext _ _ $ λ ⟨x, _⟩, rfl) $
    nat_trans.ext _ _ $ funext $ λ U, by { op_induction U,
      dsimp only [nat_trans.comp_app, comp_c_app, to_restrict_top, of_restrict,
          whisker_right_app, comp_base, nat_trans.op_app, opens.map_iso_inv_app],
      erw [presheaf.pushforward.comp_inv_app, comp_id, ← X.presheaf.map_comp,
          ← X.presheaf.map_comp, id_c_app],
      exact X.presheaf.map_id _ },
  inv_hom_id' := ext _ _ rfl $ nat_trans.ext _ _ $ funext $ λ U, by { op_induction U,
    dsimp only [nat_trans.comp_app, comp_c_app, of_restrict, to_restrict_top,
        whisker_right_app, comp_base, nat_trans.op_app, opens.map_iso_inv_app],
    erw [← X.presheaf.map_comp, ← X.presheaf.map_comp, ← X.presheaf.map_comp, id_c_app],
    convert eq_to_hom_map X.presheaf _,
    erw [op_obj, id_base, opens.map_id_obj], refl } }

/--
The global sections, notated Gamma.
-/
@[simps]
def Γ : (PresheafedSpace C)ᵒᵖ ⥤ C :=
{ obj := λ X, (unop X).presheaf.obj (op ⊤),
  map := λ X Y f, f.unop.c.app (op ⊤) ≫ (unop Y).presheaf.map (opens.le_map_top _ _).op,
  map_id' := λ X, begin
    op_induction X,
    erw [unop_id_op, id_c_app, eq_to_hom_refl, id_comp],
    exact X.presheaf.map_id _
  end,
  map_comp' := λ X Y Z f g, begin
    rw [unop_comp, comp_c_app],
    simp_rw category.assoc,
    erw [nat_trans.naturality_assoc, presheaf.pushforward.comp_inv_app, id_comp,
        category_theory.functor.comp_map, ← map_comp],
    refl
  end }

lemma Γ_obj_op (X : PresheafedSpace C) : Γ.obj (op X) = X.presheaf.obj (op ⊤) := rfl

lemma Γ_map_op {X Y : PresheafedSpace C} (f : X ⟶ Y) :
  Γ.map f.op = f.c.app (op ⊤) ≫ X.presheaf.map (opens.le_map_top _ _).op := rfl

end PresheafedSpace

end algebraic_geometry

open algebraic_geometry algebraic_geometry.PresheafedSpace

variables {C}

namespace category_theory

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

local attribute [simp] presheaf.pushforward_obj

namespace functor

/-- We can apply a functor `F : C ⥤ D` to the values of the presheaf in any `PresheafedSpace C`,
    giving a functor `PresheafedSpace C ⥤ PresheafedSpace D` -/
def map_presheaf (F : C ⥤ D) : PresheafedSpace C ⥤ PresheafedSpace D :=
{ obj := λ X, { carrier := X.carrier, presheaf := X.presheaf ⋙ F },
  map := λ X Y f, { base := f.base, c := whisker_right f.c F }, }

@[simp] lemma map_presheaf_obj_X (F : C ⥤ D) (X : PresheafedSpace C) :
  ((F.map_presheaf.obj X) : Top.{v}) = (X : Top.{v}) := rfl
@[simp] lemma map_presheaf_obj_presheaf (F : C ⥤ D) (X : PresheafedSpace C) :
  (F.map_presheaf.obj X).presheaf = X.presheaf ⋙ F := rfl
@[simp] lemma map_presheaf_map_f (F : C ⥤ D) {X Y : PresheafedSpace C} (f : X ⟶ Y) :
  (F.map_presheaf.map f).base = f.base := rfl
@[simp] lemma map_presheaf_map_c (F : C ⥤ D) {X Y : PresheafedSpace C} (f : X ⟶ Y) :
  (F.map_presheaf.map f).c = whisker_right f.c F := rfl

end functor

namespace nat_trans

/--
A natural transformation induces a natural transformation between the `map_presheaf` functors.
-/
def on_presheaf {F G : C ⥤ D} (α : F ⟶ G) : G.map_presheaf ⟶ F.map_presheaf :=
{ app := λ X,
  { base := 𝟙 _,
    c := whisker_left X.presheaf α ≫ (functor.left_unitor _).inv ≫
           whisker_right (nat_trans.op (opens.map_id X.carrier).hom) _ }, }

-- TODO Assemble the last two constructions into a functor
--   `(C ⥤ D) ⥤ (PresheafedSpace C ⥤ PresheafedSpace D)`
end nat_trans

end category_theory


example : ∀ a b c : α, a = b → b = c → a = c :=
  fun a b c h1 h2 =>
    match b, h1 with
    | _, Eq.refl a => h2

example : ∀ a b c : α, a = b → b = c → a = c :=
  fun a b c h1 h2 =>
    match h1 with
    | Eq.refl a => h2

example : ∀ a b c : α, a = b → b = c → a = c :=
  fun a b c (Eq.refl a) => fun h2 => h2

example : ∀ a b c : α, a = b → b = c → a = c :=
  fun a b c (Eq.refl a) h2 => h2