/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.balanced
import category_theory.lifting_properties.basic

/-!
# Strong epimorphisms

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

In this file, we define strong epimorphisms. A strong epimorphism is an epimorphism `f`
which has the (unique) left lifting property with respect to monomorphisms. Similarly,
a strong monomorphisms in a monomorphism which has the (unique) right lifting property
with respect to epimorphisms.

## Main results

Besides the definition, we show that
* the composition of two strong epimorphisms is a strong epimorphism,
* if `f ≫ g` is a strong epimorphism, then so is `g`,
* if `f` is both a strong epimorphism and a monomorphism, then it is an isomorphism

We also define classes `strong_mono_category` and `strong_epi_category` for categories in which
every monomorphism or epimorphism is strong, and deduce that these categories are balanced.

## TODO

Show that the dual of a strong epimorphism is a strong monomorphism, and vice versa.

## References

* [F. Borceux, *Handbook of Categorical Algebra 1*][borceux-vol1]
-/

universes v u

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

variables {P Q : C}

/-- A strong epimorphism `f` is an epimorphism which has the left lifting property
with respect to monomorphisms. -/
class strong_epi (f : P ⟶ Q) : Prop :=
(epi : epi f)
(llp : ∀ ⦃X Y : C⦄ (z : X ⟶ Y) [mono z], has_lifting_property f z)

lemma strong_epi.mk' {f : P ⟶ Q} [epi f]
  (hf : ∀ (X Y : C) (z : X ⟶ Y) (hz : mono z) (u : P ⟶ X) (v : Q ⟶ Y)
    (sq : comm_sq u f z v), sq.has_lift) : strong_epi f :=
{ epi := infer_instance,
  llp := λ X Y z hz, ⟨λ u v sq, hf X Y z hz u v sq⟩, }

/-- A strong monomorphism `f` is a monomorphism which has the right lifting property
with respect to epimorphisms. -/
class strong_mono (f : P ⟶ Q) : Prop :=
(mono : mono f)
(rlp : ∀ ⦃X Y : C⦄ (z : X ⟶ Y) [epi z], has_lifting_property z f)

lemma strong_mono.mk' {f : P ⟶ Q} [mono f]
  (hf : ∀ (X Y : C) (z : X ⟶ Y) (hz : epi z) (u : X ⟶ P) (v : Y ⟶ Q)
    (sq : comm_sq u z f v), sq.has_lift) : strong_mono f :=
{ mono := infer_instance,
  rlp := λ X Y z hz, ⟨λ u v sq, hf X Y z hz u v sq⟩, }

attribute [instance, priority 100] strong_epi.llp
attribute [instance, priority 100] strong_mono.rlp

@[priority 100]
instance epi_of_strong_epi (f : P ⟶ Q) [strong_epi f] : epi f := strong_epi.epi

@[priority 100]
instance mono_of_strong_mono (f : P ⟶ Q) [strong_mono f] : mono f := strong_mono.mono

section
variables {R : C} (f : P ⟶ Q) (g : Q ⟶ R)

/-- The composition of two strong epimorphisms is a strong epimorphism. -/
lemma strong_epi_comp [strong_epi f] [strong_epi g] : strong_epi (f ≫ g) :=
{ epi := epi_comp _ _,
  llp := by { introsI, apply_instance, }, }

/-- The composition of two strong monomorphisms is a strong monomorphism. -/
lemma strong_mono_comp [strong_mono f] [strong_mono g] : strong_mono (f ≫ g) :=
{ mono := mono_comp _ _,
  rlp := by { introsI, apply_instance, }, }

/-- If `f ≫ g` is a strong epimorphism, then so is `g`. -/
lemma strong_epi_of_strong_epi [strong_epi (f ≫ g)] : strong_epi g :=
{ epi := epi_of_epi f g,
  llp := begin
    introsI,
    constructor,
    intros u v sq,
    have h₀ : (f ≫ u) ≫ z = (f ≫ g) ≫ v, by simp only [category.assoc, sq.w],
    exact comm_sq.has_lift.mk' ⟨(comm_sq.mk h₀).lift,
      by simp only [← cancel_mono z, category.assoc, comm_sq.fac_right, sq.w], by simp⟩,
  end, }

/-- If `f ≫ g` is a strong monomorphism, then so is `f`. -/

/-- An isomorphism is in particular a strong epimorphism. -/
@[priority 100] instance strong_epi_of_is_iso [is_iso f] : strong_epi f :=
{ epi := by apply_instance,
  llp := λ X Y z hz, has_lifting_property.of_left_iso _ _, }

/-- An isomorphism is in particular a strong monomorphism. -/
@[priority 100] instance strong_mono_of_is_iso [is_iso f] : strong_mono f :=
{ mono := by apply_instance,
  rlp := λ X Y z hz, has_lifting_property.of_right_iso _ _, }

lemma strong_epi.of_arrow_iso {A B A' B' : C} {f : A ⟶ B} {g : A' ⟶ B'}
  (e : arrow.mk f ≅ arrow.mk g) [h : strong_epi f] : strong_epi g :=
{ epi := begin
    rw arrow.iso_w' e,
    haveI := epi_comp f e.hom.right,
    apply epi_comp,
  end,
  llp := λ X Y z, by { introI, apply has_lifting_property.of_arrow_iso_left e z, }, }

lemma strong_mono.of_arrow_iso {A B A' B' : C} {f : A ⟶ B} {g : A' ⟶ B'}
  (e : arrow.mk f ≅ arrow.mk g) [h : strong_mono f] : strong_mono g :=
{ mono := begin
    rw arrow.iso_w' e,
    haveI := mono_comp f e.hom.right,
    apply mono_comp,
  end,
  rlp := λ X Y z, by { introI, apply has_lifting_property.of_arrow_iso_right z e, }, }

lemma strong_epi.iff_of_arrow_iso {A B A' B' : C} {f : A ⟶ B} {g : A' ⟶ B'}
  (e : arrow.mk f ≅ arrow.mk g) : strong_epi f ↔ strong_epi g :=
by { split; introI, exacts [strong_epi.of_arrow_iso e, strong_epi.of_arrow_iso e.symm], }

lemma strong_mono.iff_of_arrow_iso {A B A' B' : C} {f : A ⟶ B} {g : A' ⟶ B'}
  (e : arrow.mk f ≅ arrow.mk g) : strong_mono f ↔ strong_mono g :=
by { split; introI, exacts [strong_mono.of_arrow_iso e, strong_mono.of_arrow_iso e.symm], }

end

/-- A strong epimorphism that is a monomorphism is an isomorphism. -/
lemma is_iso_of_mono_of_strong_epi (f : P ⟶ Q) [mono f] [strong_epi f] : is_iso f :=
⟨⟨(comm_sq.mk (show 𝟙 P ≫ f = f ≫ 𝟙 Q, by simp)).lift, by tidy⟩⟩

/-- A strong monomorphism that is an epimorphism is an isomorphism. -/
lemma is_iso_of_epi_of_strong_mono (f : P ⟶ Q) [epi f] [strong_mono f] : is_iso f :=
⟨⟨(comm_sq.mk (show 𝟙 P ≫ f = f ≫ 𝟙 Q, by simp)).lift, by tidy⟩⟩

section
variables (C)

/-- A strong epi category is a category in which every epimorphism is strong. -/
class strong_epi_category : Prop :=
(strong_epi_of_epi : ∀ {X Y : C} (f : X ⟶ Y) [epi f], strong_epi f)

/-- A strong mono category is a category in which every monomorphism is strong. -/
class strong_mono_category : Prop :=
(strong_mono_of_mono : ∀ {X Y : C} (f : X ⟶ Y) [mono f], strong_mono f)

end

lemma strong_epi_of_epi [strong_epi_category C] (f : P ⟶ Q) [epi f] : strong_epi f :=
strong_epi_category.strong_epi_of_epi _

lemma strong_mono_of_mono [strong_mono_category C] (f : P ⟶ Q) [mono f] : strong_mono f :=
strong_mono_category.strong_mono_of_mono _

section
local attribute [instance] strong_epi_of_epi

@[priority 100]
instance balanced_of_strong_epi_category [strong_epi_category C] : balanced C :=
{ is_iso_of_mono_of_epi := λ _ _ _ _ _, by exactI is_iso_of_mono_of_strong_epi _ }

end

section
local attribute [instance] strong_mono_of_mono

@[priority 100]
instance balanced_of_strong_mono_category [strong_mono_category C] : balanced C :=
{ is_iso_of_mono_of_epi := λ _ _ _ _ _, by exactI is_iso_of_epi_of_strong_mono _ }

end

end category_theory


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Johan Commelin, Scott Morrison

! This file was ported from Lean 3 source module category_theory.abelian.basic
! leanprover-community/mathlib commit 8c75ef3517d4106e89fe524e6281d0b0545f47fc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Constructions.Pullbacks
import Mathbin.CategoryTheory.Preadditive.Biproducts
import Mathbin.CategoryTheory.Limits.Shapes.Images
import Mathbin.CategoryTheory.Limits.Constructions.LimitsOfProductsAndEqualizers
import Mathbin.CategoryTheory.Abelian.NonPreadditive

/-!
# Abelian categories

This file contains the definition and basic properties of abelian categories.

There are many definitions of abelian category. Our definition is as follows:
A category is called abelian if it is preadditive,
has a finite products, kernels and cokernels,
and if every monomorphism and epimorphism is normal.

It should be noted that if we also assume coproducts, then preadditivity is
actually a consequence of the other properties, as we show in
`non_preadditive_abelian.lean`. However, this fact is of little practical
relevance, since essentially all interesting abelian categories come with a
preadditive structure. In this way, by requiring preadditivity, we allow the
user to pass in the "native" preadditive structure for the specific category they are
working with.

## Main definitions

* `abelian` is the type class indicating that a category is abelian. It extends `preadditive`.
* `abelian.image f` is `kernel (cokernel.π f)`, and
* `abelian.coimage f` is `cokernel (kernel.ι f)`.

## Main results

* In an abelian category, mono + epi = iso.
* If `f : X ⟶ Y`, then the map `factor_thru_image f : X ⟶ image f` is an epimorphism, and the map
  `factor_thru_coimage f : coimage f ⟶ Y` is a monomorphism.
* Factoring through the image and coimage is a strong epi-mono factorisation. This means that
  * every abelian category has images. We provide the isomorphism
    `image_iso_image : abelian.image f ≅ limits.image f`.
  * the canonical morphism `coimage_image_comparison : coimage f ⟶ image f`
    is an isomorphism.
* We provide the alternate characterisation of an abelian category as a category with
  (co)kernels and finite products, and in which the canonical coimage-image comparison morphism
  is always an isomorphism.
* Every epimorphism is a cokernel of its kernel. Every monomorphism is a kernel of its cokernel.
* The pullback of an epimorphism is an epimorphism. The pushout of a monomorphism is a monomorphism.
  (This is not to be confused with the fact that the pullback of a monomorphism is a monomorphism,
  which is true in any category).

## Implementation notes

The typeclass `abelian` does not extend `non_preadditive_abelian`,
to avoid having to deal with comparing the two `has_zero_morphisms` instances
(one from `preadditive` in `abelian`, and the other a field of `non_preadditive_abelian`).
As a consequence, at the beginning of this file we trivially build
a `non_preadditive_abelian` instance from an `abelian` instance,
and use this to restate a number of theorems,
in each case just reusing the proof from `non_preadditive_abelian.lean`.

We don't show this yet, but abelian categories are finitely complete and finitely cocomplete.
However, the limits we can construct at this level of generality will most likely be less nice than
the ones that can be created in specific applications. For this reason, we adopt the following
convention:

* If the statement of a theorem involves limits, the existence of these limits should be made an
  explicit typeclass parameter.
* If a limit only appears in a proof, but not in the statement of a theorem, the limit should not
  be a typeclass parameter, but instead be created using `abelian.has_pullbacks` or a similar
  definition.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]
* [P. Aluffi, *Algebra: Chapter 0*][aluffi2016]

-/

noncomputable section

open CategoryTheory

open CategoryTheory.Preadditive

open CategoryTheory.Limits

universe v u

namespace CategoryTheory

variable {C : Type u} [Category.{v} C]

variable (C)

/-- A (preadditive) category `C` is called abelian if it has all finite products,
all kernels and cokernels, and if every monomorphism is the kernel of some morphism
and every epimorphism is the cokernel of some morphism.

(This definition implies the existence of zero objects:
finite products give a terminal object, and in a preadditive category
any terminal object is a zero object.)
-/
class Abelian extends Preadditive C, NormalMonoCategory C, NormalEpiCategory C where
  [HasFiniteProducts : HasFiniteProducts C]
  [HasKernels : HasKernels C]
  [HasCokernels : HasCokernels C]
#align category_theory.abelian CategoryTheory.Abelian

attribute [instance] abelian.has_finite_products

attribute [instance] abelian.has_kernels abelian.has_cokernels

end CategoryTheory

open CategoryTheory

/-!
We begin by providing an alternative constructor:
a preadditive category with kernels, cokernels, and finite products,
in which the coimage-image comparison morphism is always an isomorphism,
is an abelian category.
-/

namespace CategoryTheory.Abelian

variable {C : Type u} [Category.{v} C] [Preadditive C]

variable [Limits.HasKernels C] [Limits.HasCokernels C]

namespace OfCoimageImageComparisonIsIso

/-- The factorisation of a morphism through its abelian image. -/
@[simps]
def imageMonoFactorisation {X Y : C} (f : X ⟶ Y) : MonoFactorisation f
    where
  i := Abelian.image f
  m := kernel.ι _
  m_mono := inferInstance
  e := kernel.lift _ f (cokernel.condition _)
  fac := kernel.lift_ι _ _ _
#align category_theory.abelian.of_coimage_image_comparison_is_iso.image_mono_factorisation CategoryTheory.Abelian.OfCoimageImageComparisonIsIso.imageMonoFactorisation

theorem imageMonoFactorisation_e' {X Y : C} (f : X ⟶ Y) :
    (imageMonoFactorisation f).e = cokernel.π _ ≫ Abelian.coimageImageComparison f :=
  by
  ext
  simp only [abelian.coimage_image_comparison, image_mono_factorisation_e, category.assoc,
    cokernel.π_desc_assoc]
#align category_theory.abelian.of_coimage_image_comparison_is_iso.image_mono_factorisation_e' CategoryTheory.Abelian.OfCoimageImageComparisonIsIso.imageMonoFactorisation_e'

/-- If the coimage-image comparison morphism for a morphism `f` is an isomorphism,
we obtain an image factorisation of `f`. -/
def imageFactorisation {X Y : C} (f : X ⟶ Y) [IsIso (Abelian.coimageImageComparison f)] :
    ImageFactorisation f where
  f := imageMonoFactorisation f
  IsImage :=
    { lift := fun F => inv (Abelian.coimageImageComparison f) ≫ cokernel.desc _ F.e F.kernel_ι_comp
      lift_fac := fun F =>
        by
        simp only [image_mono_factorisation_m, is_iso.inv_comp_eq, category.assoc,
          abelian.coimage_image_comparison]
        ext
        simp only [cokernel.π_desc_assoc, mono_factorisation.fac, image.fac] }
#align category_theory.abelian.of_coimage_image_comparison_is_iso.image_factorisation CategoryTheory.Abelian.OfCoimageImageComparisonIsIso.imageFactorisation

instance [HasZeroObject C] {X Y : C} (f : X ⟶ Y) [Mono f]
    [IsIso (Abelian.coimageImageComparison f)] : IsIso (imageMonoFactorisation f).e :=
  by
  rw [image_mono_factorisation_e']
  exact is_iso.comp_is_iso

instance [HasZeroObject C] {X Y : C} (f : X ⟶ Y) [Epi f] : IsIso (imageMonoFactorisation f).m :=
  by
  dsimp
  infer_instance

variable [∀ {X Y : C} (f : X ⟶ Y), IsIso (Abelian.coimageImageComparison f)]

/-- A category in which coimage-image comparisons are all isomorphisms has images. -/
theorem hasImages : HasImages C :=
  { HasImage := fun X Y f => { exists_image := ⟨imageFactorisation f⟩ } }
#align category_theory.abelian.of_coimage_image_comparison_is_iso.has_images CategoryTheory.Abelian.OfCoimageImageComparisonIsIso.hasImages

variable [Limits.HasFiniteProducts C]

attribute [local instance] limits.has_finite_biproducts.of_has_finite_products

/-- A category with finite products in which coimage-image comparisons are all isomorphisms
is a normal mono category.
-/
def normalMonoCategory : NormalMonoCategory C
    where normalMonoOfMono X Y f m :=
    { z := _
      g := cokernel.π f
      w := by simp
      IsLimit := by
        haveI : limits.has_images C := has_images
        haveI : has_equalizers C := preadditive.has_equalizers_of_has_kernels
        haveI : has_zero_object C := limits.has_zero_object_of_has_finite_biproducts _
        have aux : _ := _
        refine' is_limit_aux _ (fun A => limit.lift _ _ ≫ inv (image_mono_factorisation f).e) aux _
        · intro A g hg
          rw [kernel_fork.ι_of_ι] at hg
          rw [← cancel_mono f, hg, ← aux, kernel_fork.ι_of_ι]
        · intro A
          simp only [kernel_fork.ι_of_ι, category.assoc]
          convert limit.lift_π _ _ using 2
          rw [is_iso.inv_comp_eq, eq_comm]
          exact (image_mono_factorisation f).fac }
#align category_theory.abelian.of_coimage_image_comparison_is_iso.normal_mono_category CategoryTheory.Abelian.OfCoimageImageComparisonIsIso.normalMonoCategory

/-- A category with finite products in which coimage-image comparisons are all isomorphisms
is a normal epi category.
-/
def normalEpiCategory : NormalEpiCategory C
    where normalEpiOfEpi X Y f m :=
    { w := kernel f
      g := kernel.ι _
      w := kernel.condition _
      IsColimit := by
        haveI : limits.has_images C := has_images
        haveI : has_equalizers C := preadditive.has_equalizers_of_has_kernels
        haveI : has_zero_object C := limits.has_zero_object_of_has_finite_biproducts _
        have aux : _ := _
        refine'
          is_colimit_aux _
            (fun A =>
              inv (image_mono_factorisation f).m ≫
                inv (abelian.coimage_image_comparison f) ≫ colimit.desc _ _)
            aux _
        · intro A g hg
          rw [cokernel_cofork.π_of_π] at hg
          rw [← cancel_epi f, hg, ← aux, cokernel_cofork.π_of_π]
        · intro A
          simp only [cokernel_cofork.π_of_π, ← category.assoc]
          convert colimit.ι_desc _ _ using 2
          rw [is_iso.comp_inv_eq, is_iso.comp_inv_eq, eq_comm, ← image_mono_factorisation_e']
          exact (image_mono_factorisation f).fac }
#align category_theory.abelian.of_coimage_image_comparison_is_iso.normal_epi_category CategoryTheory.Abelian.OfCoimageImageComparisonIsIso.normalEpiCategory

end OfCoimageImageComparisonIsIso

variable [∀ {X Y : C} (f : X ⟶ Y), IsIso (Abelian.coimageImageComparison f)]
  [Limits.HasFiniteProducts C]

attribute [local instance] of_coimage_image_comparison_is_iso.normal_mono_category

attribute [local instance] of_coimage_image_comparison_is_iso.normal_epi_category

/-- A preadditive category with kernels, cokernels, and finite products,
in which the coimage-image comparison morphism is always an isomorphism,
is an abelian category.

The Stacks project uses this characterisation at the definition of an abelian category.
See <https://stacks.math.columbia.edu/tag/0109>.
-/
def ofCoimageImageComparisonIsIso : Abelian C where
#align category_theory.abelian.of_coimage_image_comparison_is_iso CategoryTheory.Abelian.ofCoimageImageComparisonIsIso

end CategoryTheory.Abelian

namespace CategoryTheory.Abelian

variable {C : Type u} [Category.{v} C] [Abelian C]

/-- An abelian category has finite biproducts. -/
instance (priority := 100) hasFiniteBiproducts : HasFiniteBiproducts C :=
  Limits.HasFiniteBiproducts.of_hasFiniteProducts
#align category_theory.abelian.has_finite_biproducts CategoryTheory.Abelian.hasFiniteBiproducts

instance (priority := 100) hasBinaryBiproducts : HasBinaryBiproducts C :=
  Limits.hasBinaryBiproducts_of_finite_biproducts _
#align category_theory.abelian.has_binary_biproducts CategoryTheory.Abelian.hasBinaryBiproducts

instance (priority := 100) hasZeroObject : HasZeroObject C :=
  hasZeroObject_of_hasInitial_object
#align category_theory.abelian.has_zero_object CategoryTheory.Abelian.hasZeroObject

section ToNonPreadditiveAbelian

/-- Every abelian category is, in particular, `non_preadditive_abelian`. -/
def nonPreadditiveAbelian : NonPreadditiveAbelian C :=
  { ‹Abelian C› with }
#align category_theory.abelian.non_preadditive_abelian CategoryTheory.Abelian.nonPreadditiveAbelian

end ToNonPreadditiveAbelian

section

/-! We now promote some instances that were constructed using `non_preadditive_abelian`. -/

attribute [local instance] non_preadditive_abelian

variable {P Q : C} (f : P ⟶ Q)

/-- The map `p : P ⟶ image f` is an epimorphism -/
instance : Epi (Abelian.factorThruImage f) := by infer_instance

instance isIso_factorThruImage [Mono f] : IsIso (Abelian.factorThruImage f) := by infer_instance
#align category_theory.abelian.is_iso_factor_thru_image CategoryTheory.Abelian.isIso_factorThruImage

/-- The canonical morphism `i : coimage f ⟶ Q` is a monomorphism -/
instance : Mono (Abelian.factorThruCoimage f) := by infer_instance

instance isIso_factorThruCoimage [Epi f] : IsIso (Abelian.factorThruCoimage f) := by infer_instance
#align category_theory.abelian.is_iso_factor_thru_coimage CategoryTheory.Abelian.isIso_factorThruCoimage

end

section Factor

attribute [local instance] non_preadditive_abelian

variable {P Q : C} (f : P ⟶ Q)

section

theorem mono_of_kernel_ι_eq_zero (h : kernel.ι f = 0) : Mono f :=
  mono_of_kernel_zero h
#align category_theory.abelian.mono_of_kernel_ι_eq_zero CategoryTheory.Abelian.mono_of_kernel_ι_eq_zero

theorem epi_of_cokernel_π_eq_zero (h : cokernel.π f = 0) : Epi f :=
  by
  apply normal_mono_category.epi_of_zero_cokernel _ (cokernel f)
  simp_rw [← h]
  exact is_colimit.of_iso_colimit (colimit.is_colimit (parallel_pair f 0)) (iso_of_π _)
#align category_theory.abelian.epi_of_cokernel_π_eq_zero CategoryTheory.Abelian.epi_of_cokernel_π_eq_zero

end

section

variable {f}

theorem image_ι_comp_eq_zero {R : C} {g : Q ⟶ R} (h : f ≫ g = 0) : Abelian.image.ι f ≫ g = 0 :=
  zero_of_epi_comp (Abelian.factorThruImage f) <| by simp [h]
#align category_theory.abelian.image_ι_comp_eq_zero CategoryTheory.Abelian.image_ι_comp_eq_zero

theorem comp_coimage_π_eq_zero {R : C} {g : Q ⟶ R} (h : f ≫ g = 0) : f ≫ Abelian.coimage.π g = 0 :=
  zero_of_comp_mono (Abelian.factorThruCoimage g) <| by simp [h]
#align category_theory.abelian.comp_coimage_π_eq_zero CategoryTheory.Abelian.comp_coimage_π_eq_zero

end

/-- Factoring through the image is a strong epi-mono factorisation. -/
@[simps]
def imageStrongEpiMonoFactorisation : StrongEpiMonoFactorisation f
    where
  i := Abelian.image f
  m := image.ι f
  m_mono := by infer_instance
  e := Abelian.factorThruImage f
  e_strongEpi := strongEpi_of_epi _
#align category_theory.abelian.image_strong_epi_mono_factorisation CategoryTheory.Abelian.imageStrongEpiMonoFactorisation

/-- Factoring through the coimage is a strong epi-mono factorisation. -/
@[simps]
def coimageStrongEpiMonoFactorisation : StrongEpiMonoFactorisation f
    where
  i := Abelian.coimage f
  m := Abelian.factorThruCoimage f
  m_mono := by infer_instance
  e := coimage.π f
  e_strongEpi := strongEpi_of_epi _
#align category_theory.abelian.coimage_strong_epi_mono_factorisation CategoryTheory.Abelian.coimageStrongEpiMonoFactorisation

end Factor

section HasStrongEpiMonoFactorisations

/-- An abelian category has strong epi-mono factorisations. -/
instance (priority := 100) : HasStrongEpiMonoFactorisations C :=
  HasStrongEpiMonoFactorisations.mk fun X Y f => imageStrongEpiMonoFactorisation f

-- In particular, this means that it has well-behaved images.
example : HasImages C := by infer_instance

example : HasImageMaps C := by infer_instance

end HasStrongEpiMonoFactorisations

section Images

variable {X Y : C} (f : X ⟶ Y)

/-- The coimage-image comparison morphism is always an isomorphism in an abelian category.
See `category_theory.abelian.of_coimage_image_comparison_is_iso` for the converse.
-/
instance : IsIso (coimageImageComparison f) :=
  by
  convert is_iso.of_iso
      (is_image.iso_ext (coimage_strong_epi_mono_factorisation f).toMonoIsImage
        (image_strong_epi_mono_factorisation f).toMonoIsImage)
  ext
  change _ = _ ≫ (image_strong_epi_mono_factorisation f).m
  simp [-image_strong_epi_mono_factorisation_to_mono_factorisation_m]

/-- There is a canonical isomorphism between the abelian coimage and the abelian image of a
    morphism. -/
abbrev coimageIsoImage : Abelian.coimage f ≅ Abelian.image f :=
  asIso (coimageImageComparison f)
#align category_theory.abelian.coimage_iso_image CategoryTheory.Abelian.coimageIsoImage

/-- There is a canonical isomorphism between the abelian coimage and the categorical image of a
    morphism. -/
abbrev coimageIsoImage' : Abelian.coimage f ≅ image f :=
  IsImage.isoExt (coimageStrongEpiMonoFactorisation f).toMonoIsImage (Image.isImage f)
#align category_theory.abelian.coimage_iso_image' CategoryTheory.Abelian.coimageIsoImage'

theorem coimageIsoImage'_hom :
    (coimageIsoImage' f).Hom =
      cokernel.desc _ (factorThruImage f) (by simp [← cancel_mono (limits.image.ι f)]) :=
  by
  ext
  simp only [← cancel_mono (limits.image.ι f), is_image.iso_ext_hom, cokernel.π_desc,
    category.assoc, is_image.lift_ι, coimage_strong_epi_mono_factorisation_to_mono_factorisation_m,
    limits.image.fac]
#align category_theory.abelian.coimage_iso_image'_hom CategoryTheory.Abelian.coimageIsoImage'_hom

theorem factorThruImage_comp_coimageIsoImage'_inv :
    factorThruImage f ≫ (coimageIsoImage' f).inv = cokernel.π _ := by
  simp only [is_image.iso_ext_inv, image.is_image_lift, image.fac_lift,
    coimage_strong_epi_mono_factorisation_to_mono_factorisation_e]
#align category_theory.abelian.factor_thru_image_comp_coimage_iso_image'_inv CategoryTheory.Abelian.factorThruImage_comp_coimageIsoImage'_inv

/-- There is a canonical isomorphism between the abelian image and the categorical image of a
    morphism. -/
abbrev imageIsoImage : Abelian.image f ≅ image f :=
  IsImage.isoExt (imageStrongEpiMonoFactorisation f).toMonoIsImage (Image.isImage f)
#align category_theory.abelian.image_iso_image CategoryTheory.Abelian.imageIsoImage

theorem imageIsoImage_hom_comp_image_ι : (imageIsoImage f).Hom ≫ Limits.image.ι _ = kernel.ι _ := by
  simp only [is_image.iso_ext_hom, is_image.lift_ι,
    image_strong_epi_mono_factorisation_to_mono_factorisation_m]
#align category_theory.abelian.image_iso_image_hom_comp_image_ι CategoryTheory.Abelian.imageIsoImage_hom_comp_image_ι

theorem imageIsoImage_inv :
    (imageIsoImage f).inv =
      kernel.lift _ (Limits.image.ι f) (by simp [← cancel_epi (factor_thru_image f)]) :=
  by
  ext
  simp only [is_image.iso_ext_inv, image.is_image_lift, limits.image.fac_lift,
    image_strong_epi_mono_factorisation_to_mono_factorisation_e, category.assoc, kernel.lift_ι,
    limits.image.fac]
#align category_theory.abelian.image_iso_image_inv CategoryTheory.Abelian.imageIsoImage_inv

end Images

section CokernelOfKernel

variable {X Y : C} {f : X ⟶ Y}

attribute [local instance] non_preadditive_abelian

/-- In an abelian category, an epi is the cokernel of its kernel. More precisely:
    If `f` is an epimorphism and `s` is some limit kernel cone on `f`, then `f` is a cokernel
    of `fork.ι s`. -/
def epiIsCokernelOfKernel [Epi f] (s : Fork f 0) (h : IsLimit s) :
    IsColimit (CokernelCofork.ofπ f (KernelFork.condition s)) :=
  NonPreadditiveAbelian.epiIsCokernelOfKernel s h
#align category_theory.abelian.epi_is_cokernel_of_kernel CategoryTheory.Abelian.epiIsCokernelOfKernel

/-- In an abelian category, a mono is the kernel of its cokernel. More precisely:
    If `f` is a monomorphism and `s` is some colimit cokernel cocone on `f`, then `f` is a kernel
    of `cofork.π s`. -/
def monoIsKernelOfCokernel [Mono f] (s : Cofork f 0) (h : IsColimit s) :
    IsLimit (KernelFork.ofι f (CokernelCofork.condition s)) :=
  NonPreadditiveAbelian.monoIsKernelOfCokernel s h
#align category_theory.abelian.mono_is_kernel_of_cokernel CategoryTheory.Abelian.monoIsKernelOfCokernel

variable (f)

/-- In an abelian category, any morphism that turns to zero when precomposed with the kernel of an
    epimorphism factors through that epimorphism. -/
def epiDesc [Epi f] {T : C} (g : X ⟶ T) (hg : kernel.ι f ≫ g = 0) : Y ⟶ T :=
  (epiIsCokernelOfKernel _ (limit.isLimit _)).desc (CokernelCofork.ofπ _ hg)
#align category_theory.abelian.epi_desc CategoryTheory.Abelian.epiDesc

@[simp, reassoc.1]
theorem comp_epiDesc [Epi f] {T : C} (g : X ⟶ T) (hg : kernel.ι f ≫ g = 0) :
    f ≫ epiDesc f g hg = g :=
  (epiIsCokernelOfKernel _ (limit.isLimit _)).fac (CokernelCofork.ofπ _ hg) WalkingParallelPair.one
#align category_theory.abelian.comp_epi_desc CategoryTheory.Abelian.comp_epiDesc

/-- In an abelian category, any morphism that turns to zero when postcomposed with the cokernel of a
    monomorphism factors through that monomorphism. -/
def monoLift [Mono f] {T : C} (g : T ⟶ Y) (hg : g ≫ cokernel.π f = 0) : T ⟶ X :=
  (monoIsKernelOfCokernel _ (colimit.isColimit _)).lift (KernelFork.ofι _ hg)
#align category_theory.abelian.mono_lift CategoryTheory.Abelian.monoLift

@[simp, reassoc.1]
theorem monoLift_comp [Mono f] {T : C} (g : T ⟶ Y) (hg : g ≫ cokernel.π f = 0) :
    monoLift f g hg ≫ f = g :=
  (monoIsKernelOfCokernel _ (colimit.isColimit _)).fac (KernelFork.ofι _ hg)
    WalkingParallelPair.zero
#align category_theory.abelian.mono_lift_comp CategoryTheory.Abelian.monoLift_comp

end CokernelOfKernel

section

instance (priority := 100) hasEqualizers : HasEqualizers C :=
  Preadditive.hasEqualizers_of_hasKernels
#align category_theory.abelian.has_equalizers CategoryTheory.Abelian.hasEqualizers

/-- Any abelian category has pullbacks -/
instance (priority := 100) hasPullbacks : HasPullbacks C :=
  hasPullbacks_of_hasBinaryProducts_of_hasEqualizers C
#align category_theory.abelian.has_pullbacks CategoryTheory.Abelian.hasPullbacks

end

section

instance (priority := 100) hasCoequalizers : HasCoequalizers C :=
  Preadditive.hasCoequalizers_of_hasCokernels
#align category_theory.abelian.has_coequalizers CategoryTheory.Abelian.hasCoequalizers

/-- Any abelian category has pushouts -/
instance (priority := 100) hasPushouts : HasPushouts C :=
  hasPushouts_of_hasBinaryCoproducts_of_hasCoequalizers C
#align category_theory.abelian.has_pushouts CategoryTheory.Abelian.hasPushouts

instance (priority := 100) hasFiniteLimits : HasFiniteLimits C :=
  Limits.hasFiniteLimits_of_hasEqualizers_and_finite_products
#align category_theory.abelian.has_finite_limits CategoryTheory.Abelian.hasFiniteLimits

instance (priority := 100) hasFiniteColimits : HasFiniteColimits C :=
  Limits.hasFiniteColimits_of_hasCoequalizers_and_finite_coproducts
#align category_theory.abelian.has_finite_colimits CategoryTheory.Abelian.hasFiniteColimits

end

namespace PullbackToBiproductIsKernel

variable [Limits.HasPullbacks C] {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)

/-! This section contains a slightly technical result about pullbacks and biproducts.
    We will need it in the proof that the pullback of an epimorphism is an epimorpism. -/

/-- The canonical map `pullback f g ⟶ X ⊞ Y` -/
abbrev pullbackToBiproduct : pullback f g ⟶ X ⊞ Y :=
  biprod.lift pullback.fst pullback.snd
#align category_theory.abelian.pullback_to_biproduct_is_kernel.pullback_to_biproduct CategoryTheory.Abelian.PullbackToBiproductIsKernel.pullbackToBiproduct

/-- The canonical map `pullback f g ⟶ X ⊞ Y` induces a kernel cone on the map
    `biproduct X Y ⟶ Z` induced by `f` and `g`. A slightly more intuitive way to think of
    this may be that it induces an equalizer fork on the maps induced by `(f, 0)` and
    `(0, g)`. -/
abbrev pullbackToBiproductFork : KernelFork (biprod.desc f (-g)) :=
  KernelFork.ofι (pullbackToBiproduct f g) <| by
    rw [biprod.lift_desc, comp_neg, pullback.condition, add_right_neg]
#align category_theory.abelian.pullback_to_biproduct_is_kernel.pullback_to_biproduct_fork CategoryTheory.Abelian.PullbackToBiproductIsKernel.pullbackToBiproductFork

/-- The canonical map `pullback f g ⟶ X ⊞ Y` is a kernel of the map induced by
    `(f, -g)`. -/
def isLimitPullbackToBiproduct : IsLimit (pullbackToBiproductFork f g) :=
  Fork.IsLimit.mk _
    (fun s =>
      pullback.lift (Fork.ι s ≫ biprod.fst) (Fork.ι s ≫ biprod.snd) <|
        sub_eq_zero.1 <| by
          rw [category.assoc, category.assoc, ← comp_sub, sub_eq_add_neg, ← comp_neg, ←
            biprod.desc_eq, kernel_fork.condition s])
    (fun s => by
      ext <;> rw [fork.ι_of_ι, category.assoc]
      · rw [biprod.lift_fst, pullback.lift_fst]
      · rw [biprod.lift_snd, pullback.lift_snd])
    fun s m h => by ext <;> simp [← h]
#align category_theory.abelian.pullback_to_biproduct_is_kernel.is_limit_pullback_to_biproduct CategoryTheory.Abelian.PullbackToBiproductIsKernel.isLimitPullbackToBiproduct

end PullbackToBiproductIsKernel

namespace BiproductToPushoutIsCokernel

variable [Limits.HasPushouts C] {W X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z)

/-- The canonical map `Y ⊞ Z ⟶ pushout f g` -/
abbrev biproductToPushout : Y ⊞ Z ⟶ pushout f g :=
  biprod.desc pushout.inl pushout.inr
#align category_theory.abelian.biproduct_to_pushout_is_cokernel.biproduct_to_pushout CategoryTheory.Abelian.BiproductToPushoutIsCokernel.biproductToPushout

/-- The canonical map `Y ⊞ Z ⟶ pushout f g` induces a cokernel cofork on the map
    `X ⟶ Y ⊞ Z` induced by `f` and `-g`. -/
abbrev biproductToPushoutCofork : CokernelCofork (biprod.lift f (-g)) :=
  CokernelCofork.ofπ (biproductToPushout f g) <| by
    rw [biprod.lift_desc, neg_comp, pushout.condition, add_right_neg]
#align category_theory.abelian.biproduct_to_pushout_is_cokernel.biproduct_to_pushout_cofork CategoryTheory.Abelian.BiproductToPushoutIsCokernel.biproductToPushoutCofork

/-- The cofork induced by the canonical map `Y ⊞ Z ⟶ pushout f g` is in fact a colimit cokernel
    cofork. -/
def isColimitBiproductToPushout : IsColimit (biproductToPushoutCofork f g) :=
  Cofork.IsColimit.mk _
    (fun s =>
      pushout.desc (biprod.inl ≫ Cofork.π s) (biprod.inr ≫ Cofork.π s) <|
        sub_eq_zero.1 <| by
          rw [← category.assoc, ← category.assoc, ← sub_comp, sub_eq_add_neg, ← neg_comp, ←
            biprod.lift_eq, cofork.condition s, zero_comp])
    (fun s => by ext <;> simp) fun s m h => by ext <;> simp [← h]
#align category_theory.abelian.biproduct_to_pushout_is_cokernel.is_colimit_biproduct_to_pushout CategoryTheory.Abelian.BiproductToPushoutIsCokernel.isColimitBiproductToPushout

end BiproductToPushoutIsCokernel

section EpiPullback

variable [Limits.HasPullbacks C] {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)

/-- In an abelian category, the pullback of an epimorphism is an epimorphism.
    Proof from [aluffi2016, IX.2.3], cf. [borceux-vol2, 1.7.6] -/
instance epi_pullback_of_epi_f [Epi f] : Epi (pullback.snd : pullback f g ⟶ Y) :=
  -- It will suffice to consider some morphism e : Y ⟶ R such that
    -- pullback.snd ≫ e = 0 and show that e = 0.
    epi_of_cancel_zero
    _ fun R e h =>
    by
    -- Consider the morphism u := (0, e) : X ⊞ Y⟶ R.
    let u := biprod.desc (0 : X ⟶ R) e
    -- The composite pullback f g ⟶ X ⊞ Y ⟶ R is zero by assumption.
    have hu : pullback_to_biproduct_is_kernel.pullback_to_biproduct f g ≫ u = 0 := by simpa
    -- pullback_to_biproduct f g is a kernel of (f, -g), so (f, -g) is a
    -- cokernel of pullback_to_biproduct f g
    have :=
      epi_is_cokernel_of_kernel _
        (pullback_to_biproduct_is_kernel.is_limit_pullback_to_biproduct f g)
    -- We use this fact to obtain a factorization of u through (f, -g) via some d : Z ⟶ R.
    obtain ⟨d, hd⟩ := cokernel_cofork.is_colimit.desc' this u hu
    change Z ⟶ R at d
    change biprod.desc f (-g) ≫ d = u at hd
    -- But then f ≫ d = 0:
    have : f ≫ d = 0;
    calc
      f ≫ d = (biprod.inl ≫ biprod.desc f (-g)) ≫ d := by rw [biprod.inl_desc]
      _ = biprod.inl ≫ u := by rw [category.assoc, hd]
      _ = 0 := biprod.inl_desc _ _

    -- But f is an epimorphism, so d = 0...
    have : d = 0 := (cancel_epi f).1 (by simpa)
    -- ...or, in other words, e = 0.
    calc
      e = biprod.inr ≫ u := by rw [biprod.inr_desc]
      _ = biprod.inr ≫ biprod.desc f (-g) ≫ d := by rw [← hd]
      _ = biprod.inr ≫ biprod.desc f (-g) ≫ 0 := by rw [this]
      _ = (biprod.inr ≫ biprod.desc f (-g)) ≫ 0 := by rw [← category.assoc]
      _ = 0 := has_zero_morphisms.comp_zero _ _

#align category_theory.abelian.epi_pullback_of_epi_f CategoryTheory.Abelian.epi_pullback_of_epi_f

/-- In an abelian category, the pullback of an epimorphism is an epimorphism. -/
instance epi_pullback_of_epi_g [Epi g] : Epi (pullback.fst : pullback f g ⟶ X) :=
  -- It will suffice to consider some morphism e : X ⟶ R such that
    -- pullback.fst ≫ e = 0 and show that e = 0.
    epi_of_cancel_zero
    _ fun R e h =>
    by
    -- Consider the morphism u := (e, 0) : X ⊞ Y ⟶ R.
    let u := biprod.desc e (0 : Y ⟶ R)
    -- The composite pullback f g ⟶ X ⊞ Y ⟶ R is zero by assumption.
    have hu : pullback_to_biproduct_is_kernel.pullback_to_biproduct f g ≫ u = 0 := by simpa
    -- pullback_to_biproduct f g is a kernel of (f, -g), so (f, -g) is a
    -- cokernel of pullback_to_biproduct f g
    have :=
      epi_is_cokernel_of_kernel _
        (pullback_to_biproduct_is_kernel.is_limit_pullback_to_biproduct f g)
    -- We use this fact to obtain a factorization of u through (f, -g) via some d : Z ⟶ R.
    obtain ⟨d, hd⟩ := cokernel_cofork.is_colimit.desc' this u hu
    change Z ⟶ R at d
    change biprod.desc f (-g) ≫ d = u at hd
    -- But then (-g) ≫ d = 0:
    have : (-g) ≫ d = 0;
    calc
      (-g) ≫ d = (biprod.inr ≫ biprod.desc f (-g)) ≫ d := by rw [biprod.inr_desc]
      _ = biprod.inr ≫ u := by rw [category.assoc, hd]
      _ = 0 := biprod.inr_desc _ _

    -- But g is an epimorphism, thus so is -g, so d = 0...
    have : d = 0 := (cancel_epi (-g)).1 (by simpa)
    -- ...or, in other words, e = 0.
    calc
      e = biprod.inl ≫ u := by rw [biprod.inl_desc]
      _ = biprod.inl ≫ biprod.desc f (-g) ≫ d := by rw [← hd]
      _ = biprod.inl ≫ biprod.desc f (-g) ≫ 0 := by rw [this]
      _ = (biprod.inl ≫ biprod.desc f (-g)) ≫ 0 := by rw [← category.assoc]
      _ = 0 := has_zero_morphisms.comp_zero _ _

#align category_theory.abelian.epi_pullback_of_epi_g CategoryTheory.Abelian.epi_pullback_of_epi_g

theorem epi_snd_of_isLimit [Epi f] {s : PullbackCone f g} (hs : IsLimit s) : Epi s.snd :=
  by
  convert epi_of_epi_fac (is_limit.cone_point_unique_up_to_iso_hom_comp (limit.is_limit _) hs _)
  · rfl
  · exact abelian.epi_pullback_of_epi_f _ _
#align category_theory.abelian.epi_snd_of_is_limit CategoryTheory.Abelian.epi_snd_of_isLimit

theorem epi_fst_of_isLimit [Epi g] {s : PullbackCone f g} (hs : IsLimit s) : Epi s.fst :=
  by
  convert epi_of_epi_fac (is_limit.cone_point_unique_up_to_iso_hom_comp (limit.is_limit _) hs _)
  · rfl
  · exact abelian.epi_pullback_of_epi_g _ _
#align category_theory.abelian.epi_fst_of_is_limit CategoryTheory.Abelian.epi_fst_of_isLimit

/-- Suppose `f` and `g` are two morphisms with a common codomain and suppose we have written `g` as
    an epimorphism followed by a monomorphism. If `f` factors through the mono part of this
    factorization, then any pullback of `g` along `f` is an epimorphism. -/
theorem epi_fst_of_factor_thru_epi_mono_factorization (g₁ : Y ⟶ W) [Epi g₁] (g₂ : W ⟶ Z) [Mono g₂]
    (hg : g₁ ≫ g₂ = g) (f' : X ⟶ W) (hf : f' ≫ g₂ = f) (t : PullbackCone f g) (ht : IsLimit t) :
    Epi t.fst := by
  apply epi_fst_of_is_limit _ _ (pullback_cone.is_limit_of_factors f g g₂ f' g₁ hf hg t ht)
#align category_theory.abelian.epi_fst_of_factor_thru_epi_mono_factorization CategoryTheory.Abelian.epi_fst_of_factor_thru_epi_mono_factorization

end EpiPullback

section MonoPushout

variable [Limits.HasPushouts C] {W X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z)

instance mono_pushout_of_mono_f [Mono f] : Mono (pushout.inr : Z ⟶ pushout f g) :=
  mono_of_cancel_zero _ fun R e h =>
    by
    let u := biprod.lift (0 : R ⟶ Y) e
    have hu : u ≫ biproduct_to_pushout_is_cokernel.biproduct_to_pushout f g = 0 := by simpa
    have :=
      mono_is_kernel_of_cokernel _
        (biproduct_to_pushout_is_cokernel.is_colimit_biproduct_to_pushout f g)
    obtain ⟨d, hd⟩ := kernel_fork.is_limit.lift' this u hu
    change R ⟶ X at d
    change d ≫ biprod.lift f (-g) = u at hd
    have : d ≫ f = 0;
    calc
      d ≫ f = d ≫ biprod.lift f (-g) ≫ biprod.fst := by rw [biprod.lift_fst]
      _ = u ≫ biprod.fst := by rw [← category.assoc, hd]
      _ = 0 := biprod.lift_fst _ _

    have : d = 0 := (cancel_mono f).1 (by simpa)
    calc
      e = u ≫ biprod.snd := by rw [biprod.lift_snd]
      _ = (d ≫ biprod.lift f (-g)) ≫ biprod.snd := by rw [← hd]
      _ = (0 ≫ biprod.lift f (-g)) ≫ biprod.snd := by rw [this]
      _ = 0 ≫ biprod.lift f (-g) ≫ biprod.snd := by rw [category.assoc]
      _ = 0 := zero_comp

#align category_theory.abelian.mono_pushout_of_mono_f CategoryTheory.Abelian.mono_pushout_of_mono_f

instance mono_pushout_of_mono_g [Mono g] : Mono (pushout.inl : Y ⟶ pushout f g) :=
  mono_of_cancel_zero _ fun R e h =>
    by
    let u := biprod.lift e (0 : R ⟶ Z)
    have hu : u ≫ biproduct_to_pushout_is_cokernel.biproduct_to_pushout f g = 0 := by simpa
    have :=
      mono_is_kernel_of_cokernel _
        (biproduct_to_pushout_is_cokernel.is_colimit_biproduct_to_pushout f g)
    obtain ⟨d, hd⟩ := kernel_fork.is_limit.lift' this u hu
    change R ⟶ X at d
    change d ≫ biprod.lift f (-g) = u at hd
    have : d ≫ (-g) = 0;
    calc
      d ≫ (-g) = d ≫ biprod.lift f (-g) ≫ biprod.snd := by rw [biprod.lift_snd]
      _ = u ≫ biprod.snd := by rw [← category.assoc, hd]
      _ = 0 := biprod.lift_snd _ _

    have : d = 0 := (cancel_mono (-g)).1 (by simpa)
    calc
      e = u ≫ biprod.fst := by rw [biprod.lift_fst]
      _ = (d ≫ biprod.lift f (-g)) ≫ biprod.fst := by rw [← hd]
      _ = (0 ≫ biprod.lift f (-g)) ≫ biprod.fst := by rw [this]
      _ = 0 ≫ biprod.lift f (-g) ≫ biprod.fst := by rw [category.assoc]
      _ = 0 := zero_comp

#align category_theory.abelian.mono_pushout_of_mono_g CategoryTheory.Abelian.mono_pushout_of_mono_g

theorem mono_inr_of_isColimit [Mono f] {s : PushoutCocone f g} (hs : IsColimit s) : Mono s.inr :=
  by
  convert mono_of_mono_fac
      (is_colimit.comp_cocone_point_unique_up_to_iso_hom hs (colimit.is_colimit _) _)
  · rfl
  · exact abelian.mono_pushout_of_mono_f _ _
#align category_theory.abelian.mono_inr_of_is_colimit CategoryTheory.Abelian.mono_inr_of_isColimit

theorem mono_inl_of_isColimit [Mono g] {s : PushoutCocone f g} (hs : IsColimit s) : Mono s.inl :=
  by
  convert mono_of_mono_fac
      (is_colimit.comp_cocone_point_unique_up_to_iso_hom hs (colimit.is_colimit _) _)
  · rfl
  · exact abelian.mono_pushout_of_mono_g _ _
#align category_theory.abelian.mono_inl_of_is_colimit CategoryTheory.Abelian.mono_inl_of_isColimit

/-- Suppose `f` and `g` are two morphisms with a common domain and suppose we have written `g` as
    an epimorphism followed by a monomorphism. If `f` factors through the epi part of this
    factorization, then any pushout of `g` along `f` is a monomorphism. -/
theorem mono_inl_of_factor_thru_epi_mono_factorization (f : X ⟶ Y) (g : X ⟶ Z) (g₁ : X ⟶ W) [Epi g₁]
    (g₂ : W ⟶ Z) [Mono g₂] (hg : g₁ ≫ g₂ = g) (f' : W ⟶ Y) (hf : g₁ ≫ f' = f)
    (t : PushoutCocone f g) (ht : IsColimit t) : Mono t.inl := by
  apply mono_inl_of_is_colimit _ _ (pushout_cocone.is_colimit_of_factors _ _ _ _ _ hf hg t ht)
#align category_theory.abelian.mono_inl_of_factor_thru_epi_mono_factorization CategoryTheory.Abelian.mono_inl_of_factor_thru_epi_mono_factorization

end MonoPushout

end CategoryTheory.Abelian

namespace CategoryTheory.NonPreadditiveAbelian

variable (C : Type u) [Category.{v} C] [NonPreadditiveAbelian C]

/-- Every non_preadditive_abelian category can be promoted to an abelian category. -/
def abelian : Abelian C :=
  {/- We need the `convert`s here because the instances we have are slightly different from the
       instances we need: `has_kernels` depends on an instance of `has_zero_morphisms`. In the
       case of `non_preadditive_abelian`, this instance is an explicit argument. However, in the case
       of `abelian`, the `has_zero_morphisms` instance is derived from `preadditive`. So we need to
       transform an instance of "has kernels with non_preadditive_abelian.has_zero_morphisms" to an
       instance of "has kernels with non_preadditive_abelian.preadditive.has_zero_morphisms". Luckily,
       we have a `subsingleton` instance for `has_zero_morphisms`, so `convert` can immediately close
       the goal it creates for the two instances of `has_zero_morphisms`, and the proof is complete. -/
    NonPreadditiveAbelian.preadditive with
    HasFiniteProducts := by infer_instance
    HasKernels := by convert(by infer_instance : limits.has_kernels C)
    HasCokernels := by convert(by infer_instance : limits.has_cokernels C)
    normalMonoOfMono := by
      intros
      convert normal_mono_of_mono f
    normalEpiOfEpi := by
      intros
      convert normal_epi_of_epi f }
#align category_theory.non_preadditive_abelian.abelian CategoryTheory.NonPreadditiveAbelian.abelian

end CategoryTheory.NonPreadditiveAbelian


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.multiset.nodup

/-!
# The cartesian product of multisets
-/

namespace multiset

section pi
variables {α : Type*}
open function

/-- Given `δ : α → Type*`, `pi.empty δ` is the trivial dependent function out of the empty
multiset. -/
def pi.empty (δ : α → Type*) : (Πa∈(0:multiset α), δ a) .

variables [decidable_eq α] {δ : α → Type*}

/-- Given `δ : α → Type*`, a multiset `m` and a term `a`, as well as a term `b : δ a` and a
function `f` such that `f a' : δ a'` for all `a'` in `m`, `pi.cons m a b f` is a function `g` such
that `g a'' : δ a''` for all `a''` in `a ::ₘ m`. -/
def pi.cons (m : multiset α) (a : α) (b : δ a) (f : Πa∈m, δ a) : Πa'∈a ::ₘ m, δ a' :=
λa' ha', if h : a' = a then eq.rec b h.symm else f a' $ (mem_cons.1 ha').resolve_left h

lemma pi.cons_same {m : multiset α} {a : α} {b : δ a} {f : Πa∈m, δ a} (h : a ∈ a ::ₘ m) :
  pi.cons m a b f a h = b :=
dif_pos rfl

lemma pi.cons_ne {m : multiset α} {a a' : α} {b : δ a} {f : Πa∈m, δ a}
  (h' : a' ∈ a ::ₘ m) (h : a' ≠ a) :
  pi.cons m a b f a' h' = f a' ((mem_cons.1 h').resolve_left h) :=
dif_neg h

lemma pi.cons_swap {a a' : α} {b : δ a} {b' : δ a'} {m : multiset α} {f : Πa∈m, δ a} (h : a ≠ a') :
  pi.cons (a' ::ₘ m) a b (pi.cons m a' b' f) == pi.cons (a ::ₘ m) a' b' (pi.cons m a b f) :=
begin
  apply hfunext, { refl }, intros a'' _ h, subst h,
  apply hfunext, { rw [cons_swap] }, intros ha₁ ha₂ h,
  by_cases h₁ : a'' = a; by_cases h₂ : a'' = a';
    simp [*, pi.cons_same, pi.cons_ne] at *,
  { subst h₁, rw [pi.cons_same, pi.cons_same] },
  { subst h₂, rw [pi.cons_same, pi.cons_same] }
end

/-- `pi m t` constructs the Cartesian product over `t` indexed by `m`. -/
def pi (m : multiset α) (t : Πa, multiset (δ a)) : multiset (Πa∈m, δ a) :=
m.rec_on {pi.empty δ} (λa m (p : multiset (Πa∈m, δ a)), (t a).bind $ λb, p.map $ pi.cons m a b)
begin
  intros a a' m n,
  by_cases eq : a = a',
  { subst eq },
  { simp [map_bind, bind_bind (t a') (t a)],
    apply bind_hcongr, { rw [cons_swap a a'] },
    intros b hb,
    apply bind_hcongr, { rw [cons_swap a a'] },
    intros b' hb',
    apply map_hcongr, { rw [cons_swap a a'] },
    intros f hf,
    exact pi.cons_swap eq }
end

@[simp] lemma pi_zero (t : Πa, multiset (δ a)) : pi 0 t = pi.empty δ ::ₘ 0 := rfl

@[simp] lemma pi_cons (m : multiset α) (t : Πa, multiset (δ a)) (a : α) :
  pi (a ::ₘ m) t = ((t a).bind $ λb, (pi m t).map $ pi.cons m a b) :=
rec_on_cons a m

lemma pi_cons_injective {a : α} {b : δ a} {s : multiset α} (hs : a ∉ s) :
  function.injective (pi.cons s a b) :=
assume f₁ f₂ eq, funext $ assume a', funext $ assume h',
have ne : a ≠ a', from assume h, hs $ h.symm ▸ h',
have a' ∈ a ::ₘ s, from mem_cons_of_mem h',
calc f₁ a' h' = pi.cons s a b f₁ a' this : by rw [pi.cons_ne this ne.symm]
  ... = pi.cons s a b f₂ a' this : by rw [eq]
  ... = f₂ a' h' : by rw [pi.cons_ne this ne.symm]

lemma card_pi (m : multiset α) (t : Πa, multiset (δ a)) :
  card (pi m t) = prod (m.map $ λa, card (t a)) :=
multiset.induction_on m (by simp) (by simp [mul_comm] {contextual := tt})

lemma nodup_pi {s : multiset α} {t : Πa, multiset (δ a)} :
  nodup s → (∀a∈s, nodup (t a)) → nodup (pi s t) :=
multiset.induction_on s (assume _ _, nodup_singleton _)
begin
  assume a s ih hs ht,
  have has : a ∉ s, by simp at hs; exact hs.1,
  have hs : nodup s, by simp at hs; exact hs.2,
  simp,
  split,
  { assume b hb,
    from nodup_map (pi_cons_injective has) (ih hs $ assume a' h', ht a' $ mem_cons_of_mem h') },
  { apply pairwise_of_nodup _ (ht a $ mem_cons_self _ _),
    from assume b₁ hb₁ b₂ hb₂ neb, disjoint_map_map.2 (assume f hf g hg eq,
      have pi.cons s a b₁ f a (mem_cons_self _ _) = pi.cons s a b₂ g a (mem_cons_self _ _),
        by rw [eq],
      neb $ show b₁ = b₂, by rwa [pi.cons_same, pi.cons_same] at this) }
end

lemma mem_pi (m : multiset α) (t : Πa, multiset (δ a)) :
  ∀f:Πa∈m, δ a, (f ∈ pi m t) ↔ (∀a (h : a ∈ m), f a h ∈ t a) :=
begin
  refine multiset.induction_on m (λ f, _) (λ a m ih f, _),
  { simpa using show f = pi.empty δ, by funext a ha; exact ha.elim },
  simp only [mem_bind, exists_prop, mem_cons, pi_cons, mem_map], split,
  { rintro ⟨b, hb, f', hf', rfl⟩ a' ha',
    rw [ih] at hf',
    by_cases a' = a,
    { subst h, rwa [pi.cons_same] },
    { rw [pi.cons_ne _ h], apply hf' } },
  { intro hf,
    refine ⟨_, hf a (mem_cons_self a _), λa ha, f a (mem_cons_of_mem ha),
      (ih _).2 (λ a' h', hf _ _), _⟩,
    funext a' h',
    by_cases a' = a,
    { subst h, rw [pi.cons_same] },
    { rw [pi.cons_ne _ h] } }
end

end pi

end multiset


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Monad encapsulating continuation passing programming style, similar to
Haskell's `Cont`, `ContT` and `MonadCont`:
http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Cont.html
-/

import tactic.interactive

universes u v w

structure monad_cont.label (α : Type w) (m : Type u → Type v) (β : Type u) :=
(apply : α → m β)

def monad_cont.goto {α β} {m : Type u → Type v} (f : monad_cont.label α m β) (x : α) := f.apply x

class monad_cont (m : Type u → Type v)
extends monad m :=
(call_cc : Π {α β}, ((monad_cont.label α m β) → m α) → m α)

open monad_cont

class is_lawful_monad_cont (m : Type u → Type v) [monad_cont m]
extends is_lawful_monad m :=
(call_cc_bind_right {α ω γ} (cmd : m α) (next : (label ω m γ) → α → m ω) :
  call_cc (λ f, cmd >>= next f) = cmd >>= λ x, call_cc (λ f, next f x))
(call_cc_bind_left {α} (β) (x : α) (dead : label α m β → β → m α) :
  call_cc (λ f : label α m β, goto f x >>= dead f) = pure x)
(call_cc_dummy {α β} (dummy : m α) :
  call_cc (λ f : label α m β, dummy) = dummy)

export is_lawful_monad_cont

def cont_t (r : Type u) (m : Type u → Type v) (α : Type w) := (α → m r) → m r

namespace cont_t

export monad_cont (label goto)

variables {r : Type u} {m : Type u → Type v} {α β γ ω : Type w}

def run : cont_t r m α → (α → m r) → m r := id

def map (f : m r → m r) (x : cont_t r m α) : cont_t r m α := f ∘ x

lemma run_cont_t_map_cont_t (f : m r → m r) (x : cont_t r m α) :
  run (map f x) = f ∘ run x := rfl

def with_cont_t (f : (β → m r) → α → m r) (x : cont_t r m α) : cont_t r m β :=
λ g, x $ f g

lemma run_with_cont_t (f : (β → m r) → α → m r) (x : cont_t r m α) :
  run (with_cont_t f x) = run x ∘ f := rfl

instance : monad (cont_t r m) :=
{ pure := λ α x f, f x,
  bind := λ α β x f g, x $ λ i, f i g }

instance : is_lawful_monad (cont_t r m) :=
{ id_map := by { intros, refl },
  pure_bind := by { intros, ext, refl },
  bind_assoc := by { intros, ext, refl } }

instance [monad m] : has_monad_lift m (cont_t r m) :=
{ monad_lift := λ a x f, x >>= f }

lemma monad_lift_bind [monad m] [is_lawful_monad m] {α β} (x : m α) (f : α → m β) :
  (monad_lift (x >>= f) : cont_t r m β) = monad_lift x >>= monad_lift ∘ f :=
by { ext, simp only [monad_lift,has_monad_lift.monad_lift,(∘),(>>=),bind_assoc,id.def] }

instance : monad_cont (cont_t r m) :=
{ call_cc := λ α β f g, f ⟨λ x h, g x⟩ g }

instance : is_lawful_monad_cont (cont_t r m) :=
{ call_cc_bind_right := by intros; ext; refl,
  call_cc_bind_left := by intros; ext; refl,
  call_cc_dummy := by intros; ext; refl }

end cont_t


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

/-!
# Free groupoid on a quiver

This file defines the free groupoid on a quiver, the lifting of a prefunctor to its unique
extension as a functor from the free groupoid, and proves uniqueness of this extension.

## Main results

Given the type `V` and a quiver instance on `V`:

- `free_groupoid V`: a type synonym for `V`.
- `free_groupoid_groupoid`: the `groupoid` instance on `free_groupoid V`.
- `lift`: the lifting of a prefunctor from `V` to `V'` where `V'` is a groupoid, to a functor.
  `free_groupoid V ⥤ V'`.
- `lift_spec` and `lift_unique`: the proofs that, respectively, `lift` indeed is a lifting
  and is the unique one.

## Implementation notes

The free groupoid is first defined by symmetrifying the quiver, taking the induced path category
and finally quotienting by the reducibility relation.

-/

open set classical function
local attribute [instance] prop_decidable

namespace category_theory
namespace groupoid
namespace free

universes u v u' v' u'' v''

variables {V : Type u} [quiver.{v+1} V]

/-- Shorthand for the "forward" arrow corresponding to `f` in `paths $ symmetrify V` -/
abbreviation quiver.hom.to_pos_path {X Y : V} (f : X ⟶ Y) :
  ((category_theory.paths.category_paths $ quiver.symmetrify V).hom X Y) := f.to_pos.to_path

/-- Shorthand for the "forward" arrow corresponding to `f` in `paths $ symmetrify V` -/
abbreviation quiver.hom.to_neg_path {X Y : V} (f : X ⟶ Y) :
  ((category_theory.paths.category_paths $ quiver.symmetrify V).hom Y X) := f.to_neg.to_path

/-- The "reduction" relation -/
inductive red_step : hom_rel (paths (quiver.symmetrify V))
| step (X Z : quiver.symmetrify V) (f : X ⟶ Z) :
    red_step (𝟙 X) (f.to_path ≫ (quiver.reverse f).to_path)

/-- The underlying vertices of the free groupoid -/
def _root_.category_theory.free_groupoid (V) [Q : quiver V] := quotient (@red_step V Q)

instance {V} [Q : quiver V] [h : nonempty V] : nonempty (free_groupoid V) := ⟨⟨h.some⟩⟩

lemma congr_reverse {X Y : paths $ quiver.symmetrify V} (p q : X ⟶ Y) :
  quotient.comp_closure red_step p q →
  quotient.comp_closure red_step (p.reverse) (q.reverse) :=
begin
  rintro ⟨XW, pp, qq, WY, _, Z, f⟩,
  have : quotient.comp_closure red_step (WY.reverse ≫ 𝟙 _ ≫ XW.reverse)
    (WY.reverse ≫ (f.to_path ≫ (quiver.reverse f).to_path) ≫ XW.reverse),
  { apply quotient.comp_closure.intro,
    apply red_step.step, },
  simpa only [category_struct.comp, category_struct.id, quiver.path.reverse, quiver.path.nil_comp,
    quiver.path.reverse_comp, quiver.reverse_reverse, quiver.path.reverse_to_path,
    quiver.path.comp_assoc] using this,
end

lemma congr_comp_reverse {X Y : paths $ quiver.symmetrify V} (p : X ⟶ Y) :
  quot.mk (@quotient.comp_closure _ _ red_step _ _) (p ≫ p.reverse) =
  quot.mk (@quotient.comp_closure _ _ red_step _ _) (𝟙 X) :=
begin
  apply quot.eqv_gen_sound,
  induction p with _ _ q f ih,
  { apply eqv_gen.refl, },
  { simp only [quiver.path.reverse],
    fapply eqv_gen.trans,
    { exact q ≫ q.reverse, },
    { apply eqv_gen.symm, apply eqv_gen.rel,
      have : quotient.comp_closure
               red_step (q ≫ (𝟙 _) ≫ q.reverse)
               (q ≫ (f.to_path ≫ (quiver.reverse f).to_path) ≫ q.reverse), by
      { apply quotient.comp_closure.intro, apply red_step.step, },
      have that : q.cons f = q.comp f.to_path, by refl, rw that,
      simp only [category.assoc, category.id_comp] at this ⊢,
      simp only [category_struct.comp, quiver.path.comp_assoc] at this ⊢,
      exact this, },
    { exact ih }, },
end

lemma congr_reverse_comp {X Y : paths $ quiver.symmetrify V} (p : X ⟶ Y) :
  quot.mk (@quotient.comp_closure _ _ red_step _ _) (p.reverse ≫ p) =
  quot.mk (@quotient.comp_closure _ _ red_step _ _) (𝟙 Y) :=
begin
  nth_rewrite 1 ←quiver.path.reverse_reverse p,
  apply congr_comp_reverse,
end

instance : category (free_groupoid V) := quotient.category red_step

/-- The inverse of an arrow in the free groupoid -/
def quot_inv {X Y : free_groupoid V} (f : X ⟶ Y) : Y ⟶ X :=
quot.lift_on f
            (λ pp, quot.mk _ $ pp.reverse)
            (λ pp qq con, quot.sound $ congr_reverse pp qq con)

instance : groupoid (free_groupoid V) :=
{ inv := λ X Y f, quot_inv f,
  inv_comp' := λ X Y p, quot.induction_on p $ λ pp, congr_reverse_comp pp,
  comp_inv' := λ X Y p, quot.induction_on p $ λ pp, congr_comp_reverse pp }

/-- The inclusion of the quiver on `V` to the underlying quiver on `free_groupoid V`-/
def of (V) [quiver V] : V ⥤q (free_groupoid V) :=
{ obj := λ X, ⟨X⟩,
  map := λ X Y f, quot.mk _ f.to_pos_path }

lemma of_eq : of V =
  (quiver.symmetrify.of ⋙q paths.of).comp (quotient.functor $ @red_step V _).to_prefunctor :=
begin
  apply prefunctor.ext, rotate,
  { rintro X, refl, },
  { rintro X Y f, refl, }
end

section universal_property

variables {V' : Type u'} [groupoid V'] (φ : V ⥤q V')

/-- The lift of a prefunctor to a groupoid, to a functor from `free_groupoid V` -/
def lift (φ : V ⥤q V') : free_groupoid V ⥤ V' :=
quotient.lift _
  (paths.lift $ quiver.symmetrify.lift φ)
  (by
    { rintros _ _ _ _ ⟨X,Y,f⟩,
      simp only [quiver.symmetrify.lift_reverse, paths.lift_nil, quiver.path.comp_nil,
                 paths.lift_cons, paths.lift_to_path],
      symmetry,
      apply groupoid.comp_inv, })

lemma lift_spec (φ : V ⥤q V') : of V ⋙q (lift φ).to_prefunctor = φ :=
begin
  rw [of_eq, prefunctor.comp_assoc, prefunctor.comp_assoc, functor.to_prefunctor_comp],
  dsimp [lift],
  rw [quotient.lift_spec, paths.lift_spec, quiver.symmetrify.lift_spec],
end

lemma lift_unique (φ : V ⥤q V') (Φ : free_groupoid V ⥤ V')
  (hΦ : of V ⋙q Φ.to_prefunctor = φ) : Φ = lift φ :=
begin
  apply quotient.lift_unique,
  apply paths.lift_unique,
  fapply @quiver.symmetrify.lift_unique _ _ _ _ _ _ _ _ _,
  { rw ←functor.to_prefunctor_comp, exact hΦ, },
  { constructor, rintros X Y f,
    simp only [←functor.to_prefunctor_comp,prefunctor.comp_map, paths.of_map, inv_eq_inv],
    change Φ.map (inv ((quotient.functor red_step).to_prefunctor.map f.to_path)) =
           inv (Φ.map ((quotient.functor red_step).to_prefunctor.map f.to_path)),
    have := functor.map_inv Φ ((quotient.functor red_step).to_prefunctor.map f.to_path),
    convert this; simp only [inv_eq_inv], },
end

end universal_property

section functoriality

variables {V' : Type u'} [quiver.{v'+1} V'] {V'' : Type u''} [quiver.{v''+1} V'']

/-- The functor of free groupoid induced by a prefunctor of quivers -/
def _root_.category_theory.free_groupoid_functor (φ : V ⥤q V') :
  free_groupoid V ⥤ free_groupoid V' := lift (φ ⋙q of V')

lemma free_groupoid_functor_comp
  (φ : V ⥤q V') (φ' : V' ⥤q V'') :
  free_groupoid_functor (φ ⋙q φ') = free_groupoid_functor φ ⋙ free_groupoid_functor φ' :=
begin
  dsimp only [free_groupoid_functor], symmetry,
  apply lift_unique, refl,
end

end functoriality

end free
end groupoid
end category_theory


-- Iteration of equivalences over the integers

-- Idea -- if f is a bijection then we can talk about f^n for n an integer,
-- because f⁻¹ is just the inverse bijection

import tactic

namespace int

-- First we define f^n as a function
-- This is the n'th iterate of f as a function from X to X

-- honest approach via iterations needs big API before
-- you can make ℤ → ≃ → ≃

-- there is already the notation `f^[n]` when f is a function and
-- n is a natural. I will steal their binding power.

-- _ `^[`:1 _:1 `]`:0 := nat.iterate #1 #0

-- here is some cool notation (hopefully with the correct binding power)

def iterate {X : Type} (n : ℤ) (f : X ≃ X) : X ≃ X := f^n

-- make a definition for iterate
-- Not sure what we need

-- currently: no interface at all for `iterate`.

-- I mean that there are functions in the iterate namespace.
-- For example

-- notation might have to be changed but all I care about is
-- that n must be to left of f. No arguments until it
-- turns out rubbish
--notation `⦃`:1 n `⦄^`:1 f := int.iterate n f

namespace iterate

variables {X : Type} (m n : ℤ) (f : X ≃ X) (x : X)

lemma comp : int.iterate m f (int.iterate n f x) = int.iterate (m + n) f x :=
begin
  suffices : (f ^ m * f ^ n) x = (f ^ (m + n)) x,
    convert this,
  rw gpow_add,
end

@[simp] lemma zero : iterate 0 f = equiv.refl X := rfl
@[simp] lemma one : iterate 1 f = f := by { ext x, refl }
@[simp] lemma neg_one : iterate (-1) f = f.symm := by { ext x, refl }

lemma neg (a : ℤ) : iterate (-a) f = iterate a f.symm :=
by show f^(-a) = f⁻¹^a; group

lemma succ : iterate n f (f x) = iterate (n + 1) f x := comp n 1 f x

lemma succ' : f (iterate n f x) = iterate (n + 1) f x :=
by rw add_comm; exact comp 1 n f x

theorem mul (f : X ≃ X) (a b : ℤ) (x : X) : iterate a (iterate b f) =
int.iterate (a * b) f := by show (f ^ b) ^ a = f ^ (a * b); group

end iterate

end int


import applications.functor_category
import grothendieck
import sheaf
import category.element
import tactic.equiv_rw
import data.quot
import pullback_colimit
import category.colimits

namespace category_theory

universes v u

variables {C : Type u} [small_category C] (J : sieve_set C) [grothendieck J]

open classifier limits category

noncomputable theory

@[ext]
structure closure_operator (α : Type*) [has_le α] :=
(to_fun : α → α)
(ord' : ∀ {x y : α}, x ≤ y → to_fun x ≤ to_fun y)
(inflate' : ∀ x, x ≤ to_fun x)
(idem' : ∀ x, to_fun (to_fun x) = to_fun x)

instance (α : Type*) [has_le α] : has_coe_to_fun (closure_operator α) :=
⟨_, closure_operator.to_fun⟩

instance (α : Type*) [has_le α] : has_le (closure_operator α) :=
⟨λ c₁ c₂, ∀ x, c₁ x ≤ c₂ x⟩

lemma closure_operator.ord {α : Type*} [has_le α] (c : closure_operator α) {x y : α} (h : x ≤ y) :
  c x ≤ c y :=
c.ord' h

lemma closure_operator.inflate {α : Type*} [has_le α] (c : closure_operator α) (x : α) :
  x ≤ c x := c.inflate' x

lemma closure_operator.idem {α : Type*} [has_le α] (c : closure_operator α) (x : α) :
  c (c x) = c x := c.idem' x

/-- The sieve-set induced by a closure operator on sieves. -/
def grothendieck_from_natural_operator (c : Π (X : C), closure_operator (sieve X)) :
  sieve_set C :=
λ X S, c X S = ⊤

/-- If a closure operator on sieves is natural, it induces a Grothendieck topology. -/
instance natural_operator_is_grothendieck (c : Π (X : C), closure_operator (sieve X))
  (hc : ∀ (X Y : C) (f : X ⟶ Y) (S : sieve Y), (c Y S).pullback f = c _ (S.pullback f)) :
grothendieck (grothendieck_from_natural_operator c) :=
{ max := λ X,
  begin
    apply top_unique,
    apply (c _).inflate,
  end,
  stab := λ X Y S hS f,
  begin
    change _ = _ at hS,
    change _ = _,
    rw [← hc, hS, sieve.pullback_top],
  end,
  trans := λ X S hS T hT,
  begin
    change _ = _,
    rw ← (c X).idem,
    apply top_unique,
    change _ = _ at hS,
    rw ← hS,
    apply (c _).ord,
    intros Y g hg,
    rw sieve.pullback_eq_top_iff_mem,
    rw hc,
    apply hT g hg,
  end }

@[simps]
def close {c : C} (S : sieve c) : sieve c :=
{ arrows := λ g, grothendieck.covers J S g.hom,
  subs := λ d e f h k,
  begin
    change S.pullback (h ≫ f) ∈ J e,
    change S.pullback f ∈ J d at k,
    rw sieve.pullback_comp,
    apply grothendieck.stab (S.pullback f) k h,
  end }

lemma close_preserves_order {c : C} {S T : sieve c} (h : S ≤ T) :
  close J S ≤ close J T :=
begin
  intros d g hg,
  change S.pullback g ∈ J d at hg,
  apply grothendieck.superset_covering (sieve.pullback_le_map h g) hg,
end

lemma close_inflationary {c : C} (S : sieve c) :
  S ≤ close J S :=
begin
  intros d g hg,
  change S.pullback g ∈ J d,
  rw sieve.pullback_eq_top_iff_mem at hg,
  rw hg,
  apply grothendieck.max,
end

lemma close_idem (c : C) (S : sieve c) :
  close J (close J S) = close J S :=
begin
  apply le_antisymm,
    intros d g hg,
    change (close J S).pullback g ∈ J d at hg,
    apply grothendieck.trans _ hg,
    intros e g' hg',
    change (S.pullback g).pullback g' ∈ J e,
    rw ← S.pullback_comp,
    exact hg',
  apply close_preserves_order J (close_inflationary _ _),
end

lemma close_inter (c : C) (S T : sieve c) :
  close J (S ⊓ T) = close J S ⊓ close J T :=
begin
  apply le_antisymm,
  { refine le_inf (close_preserves_order _ inf_le_left) (close_preserves_order _ inf_le_right) },
  rintros d g ⟨hg₁, hg₂⟩,
  change S.pullback g ∈ J d at hg₁,
  change (S ⊓ T).pullback g ∈ J d,
  rw sieve.pullback_inter,
  apply grothendieck.intersection_covering hg₁ hg₂,
end

lemma close_pullback (c d : C) (S : sieve c) (f : d ⟶ c) :
  close J (S.pullback f) = (close J S).pullback f :=
begin
  ext e g,
  change (S.pullback f).pullback g ∈ J e ↔ S.pullback (g ≫ f) ∈ J e,
  rw S.pullback_comp,
end

lemma incl_iff_closure_eq_top (c : C) (S : sieve c) : S ∈ J c ↔ close J S = ⊤ :=
begin
  split,
    intro h,
    ext d f,
    change S.pullback f ∈ J d ↔ true,
    simpa using grothendieck.stab S h f,
  rw [close],
  intro q,
  refine grothendieck.trans ⊤ (grothendieck.max _) _ _,
  intros d g hg,
  rw ← q at hg,
  exact hg,
end

/-- Natural closure operators on the set of sieves are the same thing as Grothendieck topologies. -/
def operators_equiv_topology :
  {c : Π (X : C), closure_operator (sieve X) // ∀ X Y f S, (c Y S).pullback f = c X (S.pullback f)}
≃ {J : sieve_set C // grothendieck J} :=
{ to_fun := λ c, ⟨grothendieck_from_natural_operator c.1, category_theory.natural_operator_is_grothendieck _ c.2⟩,
  inv_fun := λ J, by { haveI := J.2, refine ⟨λ X, ⟨close J.1, λ x y, close_preserves_order _, close_inflationary _, close_idem _ _⟩, λ X Y f S, _⟩, symmetry, apply close_pullback, },
  left_inv :=
  begin
    rintro ⟨c₁, c₂⟩,
    ext x S y f,
    dsimp [close, grothendieck.covers, grothendieck_from_natural_operator],
    change c₁ y (S.pullback f) = ⊤ ↔ over.mk f ∈ (c₁ x S).arrows,
    rw ← c₂,
    rw sieve.pullback_eq_top_iff_mem,
  end,
  right_inv :=
  begin
    rintro ⟨J, _⟩,
    resetI,
    ext c S,
    apply (incl_iff_closure_eq_top J c S).symm,
  end }

@[simps]
def j : Ω (Cᵒᵖ ⥤ Type u) ⟶ Ω (Cᵒᵖ ⥤ Type u) :=
{ app := λ c S, close J S,
  naturality' := λ c c' f,
  begin
    ext1 S,
    change sieve c.unop at S,
    apply close_pullback,
  end }

lemma yoneda_generates (X Y : Cᵒᵖ ⥤ Type u) (f g : X ⟶ Y)
  (h : ∀ (c : Cᵒᵖ) (k : yoneda.obj c.unop ⟶ X), k ≫ f = k ≫ g) :
  f = g :=
begin
  ext c t,
  specialize h c ((yoneda_sections_small c.unop X).inv t),
  have := congr_arg (λ i, nat_trans.app i c) h,
  dsimp [yoneda_lemma, ulift_trivial] at this,
  have z := congr_fun this (has_hom.hom.unop (𝟙 _)),
  dsimp at z,
  rw [X.map_id] at z,
  exact z,
end

def sieve_equiv_arrow (c : C) : sieve c ≃ (yoneda.obj c ⟶ Ω _) :=
(yoneda_sections_small c (Ω _)).to_equiv.symm

lemma equiv_close (c : C) (S : sieve c) :
  sieve_equiv_arrow _ (close J S) = sieve_equiv_arrow _ S ≫ j J :=
begin
  ext d f : 3,
  symmetry,
  apply close_pullback,
end

def sub_repr (c : C) : sieve c ≃ subq (yoneda.obj c) :=
(sieve_equiv_arrow c).trans classification

lemma sub_repr_eq (c : C) (S : sieve c) : sub_repr c S = subq.mk S.functor_inclusion :=
begin
  change classification _ = _,
  rw ← classification.eq_symm_apply,
  ext c' f c'' g,
  change over.mk (g ≫ f) ∈ S.arrows ↔ ∃ (x : {h // over.mk h ∈ S.arrows}), x.1 = g ≫ f,
  rw [subtype.exists],
  simp,
end

def sieve_subq (c : C) :
sieve c ≃o subq (yoneda.obj c) :=
{ to_equiv := sub_repr c,
  map_rel_iff' :=
  begin
    intros S T,
    rw [sub_repr_eq, sub_repr_eq],
    change S ≤ T ↔ nonempty (_ ⟶ _),
    split,
    intro h,
      exact ⟨sub.hom_mk (sieve.le_as_functor h) (sieve.le_as_functor_comm h)⟩,
    rintro ⟨a⟩ d f hf,
    let f' := a.left.app (opposite.op d) ⟨f, hf⟩,
    have := sub.w a,
    dsimp at *,
    have q := congr_arg (λ t, nat_trans.app t (opposite.op d)) this,
    dsimp at q,
    replace q := congr_fun q ⟨f, hf⟩,
    dsimp at q,
    rw ← q,
    apply (a.left.app (opposite.op d) ⟨f, hf⟩).2,
  end }

lemma inclusion_inter (c : C) (S T : sieve c) :
  sieve_subq _ (S ⊓ T) = sieve_subq _ S ⊓ sieve_subq _ T :=
order_iso.map_inf _ _ _

@[reassoc]
lemma and_arrow_sieve (c : C) (S T : sieve c) :
  (prod.lift (sieve_equiv_arrow _ S) (sieve_equiv_arrow _ T) ≫ and_arrow _) = sieve_equiv_arrow _ (S ⊓ T) :=
begin
  have : ∀ (S : sieve _), sieve_equiv_arrow c S = classify (sieve_subq _ S),
    intro S,
    change _ = classify (classification (sieve_equiv_arrow c S)),
    symmetry,
    apply classification.left_inv,
  rw [this, this, this],
  rw and_property,
  rw inclusion_inter,
end

instance : topology (j J) :=
{ ax1 :=
  begin
    ext c ⟨⟩ d f,
    change J d ((⊤ : sieve _).pullback f) ↔ true,
    rw sieve.pullback_top,
    simp only [iff_true],
    exact grothendieck.max d,
  end,
  ax2 :=
  begin
    ext c S : 3,
    apply close_idem,
  end,
  ax3 :=
  begin
    apply yoneda_generates,
    intros c k,
    equiv_rw prod.equiv (yoneda.obj c.unop) (Ω _) (Ω _) at k,
    cases k with k₁ k₂,
    change prod.lift k₁ k₂ ≫ _ = prod.lift k₁ k₂ ≫ _ ≫ _,
    rw prod.lift_map_assoc,
    equiv_rw (sieve_equiv_arrow c.unop).symm at k₁,
    equiv_rw (sieve_equiv_arrow c.unop).symm at k₂,

    rw [← equiv_close, ← equiv_close, and_arrow_sieve, and_arrow_sieve_assoc, ← equiv_close],
    rw (sieve_equiv_arrow _).apply_eq_iff_eq,
    rw close_inter,
  end }.

def dense_inclusion (c : C) (S : sieve c) (h : S ∈ J c) : closure.dense (j J) S.functor_inclusion :=
begin
  constructor,
  change classification (classify (subq.mk _) ≫ _) = _,
  rw ← sub_repr_eq,
  dsimp only [sub_repr, equiv.trans],
  change classification (classification.symm (classification _) ≫ _) = _,
  rw classification.symm_apply_apply,
  erw ← equiv_close,
  change sieve_subq _ _ = _,
  rw ← order_iso.map_top (sieve_subq c),
  congr' 1,
  ext d f,
  change S.pullback f ∈ J d ↔ true,
  simpa using grothendieck.stab S h f,
end

lemma dense_inclusion_iff (c : C) (S : sieve c) (h : closure.dense (j J) S.functor_inclusion) :
  S ∈ J c :=
begin
  have := h.closure_eq_top,
  change classification (classify (subq.mk _) ≫ _) = _ at this,
  rw ← sub_repr_eq at this,
  dsimp only [sub_repr, equiv.trans] at this,
  change classification (classification.symm (classification _) ≫ _) = _ at this,
  rw classification.symm_apply_apply at this,
  erw ← equiv_close at this,
  change sieve_subq _ _ = _ at this,
  rw ← order_iso.map_top (sieve_subq c) at this,
  erw (sieve_subq c).to_equiv.apply_eq_iff_eq at this,
  rw close at this,
  refine grothendieck.trans ⊤ (grothendieck.max _) _ _,
  intros d g hg,
  rw ← this at hg,
  exact hg,
end

def jsheaf_is_Jsheaf (P : Cᵒᵖ ⥤ Type u) (h : sheaf_condition (j J) P) : grothendieck.sheaf_condition J P :=
begin
  intros c S γ hS,
  change S.as_functor ⟶ _ at γ,
  haveI : closure.dense (j J) S.functor_inclusion := dense_inclusion _ _ _ hS,
  apply h S.functor_inclusion γ,
end

-- This can be generalised to show it suffices to check the sheaf condition on a
-- generating set (in the sense of colimits).
def sheaf.yoneda_mk (P : Cᵒᵖ ⥤ Type u)
  (h : Π c S f' (m : S ⟶ yoneda.obj c) [closure.dense (j J) m], {f : yoneda.obj c ⟶ P // m ≫ f = f' ∧ ∀ a, m ≫ a = f' → a = f}) :
  sheaf_condition (j J) P :=
sheaf_condition.mk' _ _
begin
  introsI E A m σ _,
  let A' : (E.elements)ᵒᵖ → (Cᵒᵖ ⥤ Type u) := λ i, pullback ((the_cocone E).ι.app i) m,
  let m' : Π (i : E.elementsᵒᵖ), A' i ⟶ yoneda.obj i.unop.1.unop := λ i, pullback.fst,
  let top_map : Π (i : E.elementsᵒᵖ), A' i ⟶ A := λ i, pullback.snd,
  have pb : ∀ (i : E.elementsᵒᵖ), m' i ≫ _ = top_map i ≫ m := λ i, pullback.condition,
  let A'diagram : E.elementsᵒᵖ ⥤ (Cᵒᵖ ⥤ Type u),
  { refine { functor . obj := A',
             map := λ i j f,
              pullback.lift (m' i ≫ yoneda.map f.unop.1.unop) (top_map i)
                (by erw [← pb i, assoc, (the_cocone E).w f]), map_id' := _, map_comp' := _},
    { intro j,
      apply pullback.hom_ext;
      simp },
    { intros i₁ i₂ i₃ f g,
      apply pullback.hom_ext; simp } },
  let τ : A'diagram ⟶ ((category_of_elements.π E).left_op ⋙ yoneda) :=
    { nat_trans . app := m', naturality' := λ i j f, pullback.lift_fst _ _ _ },
  let A'cocone : cocone A'diagram,
    refine ⟨A, λ i, top_map i, _⟩,
    intros i j f,
    rw pullback.lift_snd,
    apply (comp_id _).symm,
  let A'colimit := pullback_colimit A'cocone (is_a_limit E) τ m pb (λ i, cone_is_pullback _ _),
  let h' : Π (i : E.elementsᵒᵖ), {f // m' i ≫ f = top_map i ≫ σ ∧ ∀ a, m' i ≫ a = top_map i ≫ σ → a = f} :=
    λ i, (h _ _ (top_map i ≫ σ) (m' i)),
  let h'₁ : Π (i : E.elementsᵒᵖ), yoneda.obj i.unop.1.unop ⟶ P := λ i, (h' i).1,
  have h'₂ : ∀ (i : E.elementsᵒᵖ), m' i ≫ h'₁ i = top_map i ≫ σ := λ i, (h' i).2.1,
  have h'₃ : ∀ (i : E.elementsᵒᵖ) a, m' i ≫ a = top_map i ≫ σ → a = h'₁ i := λ i, (h' i).2.2,
  have legs : ∀ (i j : E.elementsᵒᵖ) (f : i ⟶ j), yoneda.map (has_hom.hom.unop f).1.unop ≫ h'₁ j = h'₁ i ≫ 𝟙 P,
  { intros,
    rw comp_id,
    apply h'₃ i,
    let hf : A' i ⟶ A' j := pullback.lift (m' i ≫ yoneda.map f.unop.1.unop) (top_map i)
                              (by erw [← pb i, assoc, (the_cocone E).w f]),
    have : hf ≫ m' j = m' i ≫ yoneda.map _ := pullback.lift_fst _ _ _,
    rw ← reassoc_of this,
    rw h'₂ j,
    apply pullback.lift_snd_assoc },
  refine ⟨(is_a_limit E).desc ⟨P, h'₁, legs⟩, _, _⟩,
  { apply A'colimit.hom_ext,
    intro i,
    rw ← pullback.condition_assoc,
    rw (is_a_limit E).fac,
    apply h'₂ },
  { intros q hq,
    apply (is_a_limit E).hom_ext,
    intro i,
    rw (is_a_limit E).fac,
    apply h'₃ i,
    rw pullback.condition_assoc,
    rw hq }
end.

def Jsheaf_is_jsheaf (P : Cᵒᵖ ⥤ Type u) (h : grothendieck.sheaf_condition J P) : sheaf_condition (j J) P :=
sheaf.yoneda_mk J P
begin
  introsI c S' f' m hm,
  let S := (sub_repr _).symm ⟦sub.mk' m⟧,
  have same_class := sub_repr_eq _ S,
  rw (sub_repr _).apply_symm_apply at same_class,
  have : closure.dense (j J) S.functor_inclusion,
  refine ⟨_⟩,
  change closure.operator _ (subq.mk _) = _,
  rw ← same_class,
  apply hm.closure_eq_top,
  have := dense_inclusion_iff J _ S this,
  have : classifier_of m = classifier_of S.functor_inclusion,
    change classify ⟦sub.mk' m⟧ = classify ⟦sub.mk' S.functor_inclusion⟧,
    rw same_class,
  let i := how_inj_is_classifier m S.functor_inclusion this,
  have hi : i.hom ≫ _ = _ := c_very_inj this,
  refine ⟨(h _ S (i.inv ≫ f') ‹S ∈ J c›).1.1.1, _, _⟩,
  rw [← hi, assoc, (h _ S (i.inv ≫ f') ‹S ∈ J c›).1.1.2], simp,
  intros a ha,
  apply subtype.ext_iff.1 ((h _ S (i.inv ≫ f') ‹S ∈ J c›).2 ⟨a, _⟩),
  rw iso.eq_inv_comp,
  rw reassoc_of hi,
  rw ha,
end

def equivalent_sheaf_conditions (P : Cᵒᵖ ⥤ Type u) :
  grothendieck.sheaf_condition J P ≃ sheaf_condition (j J) P :=
{ to_fun := Jsheaf_is_jsheaf _ _,
  inv_fun := jsheaf_is_Jsheaf _ _,
  left_inv := λ _, subsingleton.elim _ _,
  right_inv := λ _, subsingleton.elim _ _ }

end category_theory


import TBA.Eulerian.Nat

open Nat List

namespace Eq

protected theorem symm_iff {a b : α} : b = a ↔ a = b := ⟨Eq.symm, Eq.symm⟩

end Eq

namespace List

@[simp] theorem length_append {as bs : List α} :
  length (as ++ bs) = length as + length bs :=
  match as with
  | []      => by simp
  | a :: as => by simp [Nat.succ_add, length_append]

theorem length_zero_iff_nil {as : List α} : length as = 0 ↔ as = [] :=
⟨fun e => by cases as; rfl; simp [length_cons] at e, fun e => by rw [e]; rfl⟩

theorem length_cons_ne_zero {as : List α} {a : α} : length (a :: as) ≠ 0 := by
  rw [List.length_cons]; exact Nat.succNeZero _

-- Some lemmas about filters

@[simp] theorem filter_nil {p : α → Bool} : filter p [] = [] := by
  simp [filter, filterAux, reverse, reverseAux]

theorem cons_eq_append (a : α) (as : List α) : a :: as = [a] ++ as := rfl

theorem reverseAux_append {rs as : List α} : reverseAux rs as = reverseAux rs [] ++ as :=
  match rs with
  | []      => rfl
  | r :: rs => by
    simp only [reverseAux]
    rw [reverseAux_append, reverseAux_append (as := [r]), cons_eq_append r as, append_assoc]

theorem filterAux_aux {p : α → Bool} (as : List α) :
  (rs : List α) → filterAux p as rs = rs.reverse ++ (filterAux p as []) :=
  match as with
  | [] => by intros; simp [filterAux, reverse, reverseAux];
  | a :: as => by
    intro rs
    simp only [filterAux]
    cases p a
    case false => simp [filterAux_aux as rs]
    case true =>
      rw [filterAux_aux as (a :: rs), filterAux_aux as [a]]
      simp only [reverse, reverseAux, List.append, List.cons_append, List.nil_append]
      rw [reverseAux_append, cons_eq_append _ (filterAux p as []), append_assoc]

theorem filter_cons (a : α) (as : List α) :
  filter p (a :: as) = if p a then a :: filter p as else filter p as := by
  simp only [filter, filterAux]
  cases p a
  simp
  rw [filterAux_aux]; simp [reverse, reverseAux]

@[simp] theorem filter_append {as bs : List α} {p : α → Bool} :
  filter p (as ++ bs) = filter p as ++ filter p bs := by
  induction as with
  | nil      => simp
  | cons a as ih =>
    rw [filter_cons, cons_append, filter_cons]
    cases p a <;> simp [ih]

-- A membership predicate

inductive Mem : α → List α → Prop where
  | head (a : α) (as : List α)   : Mem a (a::as)
  | tail (a b : α) (bs : List α) : Mem a bs → Mem a (b::bs)

infix:50 " ∈ " => Mem

class IsBEqEq (α : Type) [BEq α] : Prop where
  beq_is_eq {a b : α} : (a == b) = (a = b)

instance [DecidableEq α] : IsBEqEq α where
  beq_is_eq := @fun a b => by byCases h : a = b <;> simp_all [BEq.beq, decideEqTrue, decideEqFalse]

instance [DecidableEq α] : IsBEqEq (α × α) where
  beq_is_eq := @fun (a₁, a₂) (b₁, b₂) => by byCases h₁ : a₁ = b₁ <;> byCases h₂ : a₂ = b₂ <;> simp_all [BEq.beq, decideEqTrue, decideEqFalse]

export IsBEqEq (beq_is_eq)

attribute [local simp] beq_is_eq

@[simp] theorem beq_refl [BEq α] [IsBEqEq α] : ((a : α) == a) = true := by
  simp

@[simp] theorem beq_neq [BEq α] [IsBEqEq α] {a b : α} (h : ¬ a = b) : (a == b) = false := by
   cases hbeq : a == b <;> simp_all

theorem length_erase_mem [BEq α] [IsBEqEq α] {a : α} {as : List α} (h : a ∈ as) :
  length (List.erase as a) + 1 = length as :=
  match a, as, h with
  | _, _, Mem.head a bs => by simp [List.erase]
  | _, _, Mem.tail a b bs h => by
    simp only [List.erase]
    match b == a with
    | true => simp
    | false => { simp only [length_cons]; rw [←length_erase_mem h] }

theorem mem_singleton [BEq α] [IsBEqEq α] {a b : α} (h : a ∈ [b]) : a = b := by
  cases h with
  | head h       => rfl
  | tail _ _ _ h => cases h

def mem_of_nonzero_length [BEq α] [IsBEqEq α] {as : List α} :
  (h : length as > 0) → { a // a ∈ as } :=
  match as with
  | []      => by { simp only [length_nil]; intro fa; cases fa }
  | a :: as => by { intros; apply Subtype.mk; apply Mem.head }

theorem mem_append {as bs : List α} : ∀ a, a ∈ (as ++ bs) → a ∈ as ∨ a ∈ bs :=
  match as with
  | [] => by intros; apply Or.inr; assumption
  | a :: as => by
    simp only [List.cons_append]
    intros a h
    cases h with
    | head h => apply Or.inl; apply Mem.head
    | tail _ _ _ h =>
      cases mem_append (as := as) (bs := bs) a h
      case inl => apply Or.inl; apply Mem.tail; assumption
      case inr => apply Or.inr; assumption

theorem mem_of_mem_filter {as : List α} {a : α} {p : α → Bool} : a ∈ filter p as → a ∈ as :=
  match as with
  | [] => by intros; assumption
  | a' :: as => by
      rw [filter_cons]; cases p a'
      case false => intro h; apply Mem.tail; apply mem_of_mem_filter h
      case true =>
        intro h
        cases h with
        | head => apply Mem.head
        | tail _ _ _ h => apply Mem.tail; apply mem_of_mem_filter h

theorem mem_filter_of_prop {as : List α} {a : α} {p : α → Bool} (ha : a ∈ as) (hpa : p a = true) :
  a ∈ filter p as := by
  induction ha with
  | head a as => rw [filter_cons, hpa]; simp; apply Mem.head
  | tail a b as ha' ih =>
    rw [filter_cons]
    cases hpb : p b
    case false => simp; exact ih hpa
    case true  => simp; apply Mem.tail; exact ih hpa

theorem filterProp_of_mem {as : List α} {p : α → Bool} {a : α} : a ∈ filter p as → p a = true :=
  match as with
  | [] => by intro h; cases h
  | a' :: as => by
      rw [filter_cons]; byCases hpa : p a'
      case inr => simp [hpa]; exact filterProp_of_mem
      case inl => simp [hpa]; intro h; cases h; assumption; apply filterProp_of_mem; assumption

theorem mem_split {a : α} {as : List α} (h : a ∈ as) : ∃ s t, as = s ++ a :: t :=
  match a, as, h with
  | _, _, Mem.head a bs     => ⟨[], ⟨bs, rfl⟩⟩
  | _, _, Mem.tail a b bs h =>
    match bs, mem_split h with
    | _, ⟨s, ⟨t, rfl⟩⟩ => ⟨b::s, ⟨t, List.cons_append .. ▸ rfl⟩⟩

-- Couting elements

section Count
variable [BEq α] [IsBEqEq α] (as bs as' bs' : List α) (a b : α)

def count : Nat := (as.filter $ fun b => b == a).length

@[simp] theorem count_empty : count [] a = 0 := by simp [count]

@[simp] theorem count_self_cons : (a :: as).count a = Nat.succ (as.count a) := by
  simp [count, filter_cons]

theorem count_neq_cons {as} {a b : α} (h : ¬ b = a) : (b :: as).count a = as.count a := by
  simp [count, filter_cons, h]

@[simp] theorem count_append : (as ++ bs).count a = as.count a + bs.count a :=
  by simp [count]

--set_option trace.Meta.Tactic.simp true
theorem count_erase {as : List α} {a b : α} :
  (as.erase a).count b = if (a == b) then (as.count b) - 1 else as.count b :=
  match as with
  | [] => by simp only [List.erase]; cases (a == b) <;> simp
  | a' :: as => by
    simp only [List.erase]
    byCases h : a' = a
    case inl =>
      cases h
      simp only [beq_refl]
      byCases h' : a = b
      case inl => cases h'; simp only [beq_refl, Lean.Simp.ite_True, Nat.succ_sub_succ, count_self_cons]; apply Nat.sub_zero
      case inr => rw [beq_neq h']; simp [count_neq_cons h']
    case inr =>
      rw [beq_neq h]
      byCases h' : a' = b
      case inl => cases h'; simp [count_erase (as := as), beq_neq (Ne.symm h)]
      case inr => simp [count_neq_cons h', count_neq_cons h', count_erase]

theorem count_le_cons : as.count a ≤ (b :: as).count a := by
  byCases h : (b = a)
  case inl => cases h; simp [count_self_cons, Nat.leSucc]
  case inr => rw [count_neq_cons h]; simp [Nat.leRefl]

theorem mem_nonzeroCount {as : List α} {a : α}: a ∈ as ↔ as.count a > 0 := by
  apply Iff.intro
  case mp =>
    intro h
    induction h with
    | head a => simp [Nat.zeroLtSucc]
    | tail _ _ _ h ih => apply Nat.ltOfLtOfLe ih; apply count_le_cons
  case mpr =>
    intro h
    let ⟨a', ha'⟩ := mem_of_nonzero_length h
    let foo := filterProp_of_mem ha'
    rw [←beq_is_eq.mp foo]
    apply mem_of_mem_filter ha'

-- Erasing elements from lists

theorem erase_comm {as : List α} : (as.erase a).erase b  = (as.erase b).erase a :=
  match as with
  | [] => rfl
  | a' :: as => by
    byCases h : a' = a
    case inl =>
      cases h; simp only [List.erase]
      byCases h' : b = a
      case inl => cases h'; simp
      case inr => rw [beq_neq (Ne.symm h')]; simp [List.erase]
    case inr =>
      simp only [List.erase]
      rw [beq_neq h]
      byCases h' : a' = b
      case inl => cases h'; simp [List.erase]
      case inr => simp [List.erase, beq_neq h', beq_neq h, erase_comm (as := as)]

theorem filter_erase_false {as : List α} {a : α} {p : α → Bool} (h : p a = false) :
  filter p (as.erase a) = filter p as :=
  match as with
  | [] => by simp [List.erase]
  | b :: as => by
    simp only [List.erase, filter_cons]
    byCases h' : b = a
    case inl => cases h'; simp [h]
    case inr => simp [h', filter_cons]; rw [filter_erase_false h]

theorem filter_erase_true {as : List α} {a : α} {p : α → Bool} (hpa : p a = true) :
  filter p (as.erase a) = (filter p as).erase a :=
  match as with
  | [] => rfl
  | b :: as => by
    simp
    byCases h : b = a
    case inl => cases h; simp [List.erase, filter_cons, hpa]
    case inr =>
      simp only [List.erase, beq_neq h, filter_cons]
      cases hpb : p b
      case false => exact filter_erase_true hpa
      case true => rw [filter_erase_true hpa]; simp [List.erase, h]

def eraseAll (as bs : List α) : List α :=
  match bs with
  | []      => as
  | b :: bs => eraseAll (as.erase b) bs

infixl:55 " -l " => eraseAll

theorem erase_eraseAll {as bs : List α} {a : α} : (as.erase a) -l bs = (as -l bs).erase a :=
  match bs with
  | [] => rfl
  | b :: bs => by simp only [eraseAll]; rw [←erase_eraseAll, erase_comm]

@[simp] theorem count_eraseAll (as bs : List α) (a : α) :
  (as -l bs).count a = as.count a - bs.count a :=
  match bs with
  | [] => rfl
  | b :: bs => by
    simp only [eraseAll]; rw [erase_eraseAll]; simp
    byCases hba : b = a;
    case inl => cases hba; rw [count_self_cons, count_erase, count_eraseAll as bs a, beq_refl]; rfl
    case inr => rw [count_erase, beq_neq hba, count_eraseAll as bs a, count_neq_cons]; repeat simp_all

-- Lists which are permutations of each other, and sublists modulo permutation

def isPermEqvTo : Prop := ∀ a, as.count a = bs.count a
infixl:50 " ≃ " => isPermEqvTo -- Type as \simeq

def isPermSubOf : Prop := ∀ a, as.count a ≤ bs.count a
infixl:50 " ⊆ " => isPermSubOf -- Type as \sub

theorem permSubOfEraseSub : (as -l bs) ⊆ as := fun a => by simp [Nat.subLe]

theorem mem_of_mem_eraseAll {as bs : List α} {a : α} : a ∈ (as -l bs) → a ∈ as := by
  rw [mem_nonzeroCount, mem_nonzeroCount, count_eraseAll]
  intro h; exact Nat.ltOfLtOfLe h (Nat.subLe _ _)

theorem permSubEraseAllLength {as bs : List α} : bs ⊆ as → length (as -l bs) = length as - length bs :=
  match bs with
  | [] => fun _ => rfl
  | b :: bs => fun hsub => by
    simp only [eraseAll, length_cons]
    have hbas : b ∈ as := by
      have hb := hsub b
      rw [count_self_cons] at hb
      rw [mem_nonzeroCount]
      exact Nat.ltOfLeOfLt (zeroLe _) (ltOfSuccLe hb)
    have hsub' : bs.isPermSubOf (as.erase b) := fun c => by
      have hc := hsub c
      byCases h : b = c
      case inl =>
        cases h
        rw [count_self_cons] at hc
        rw [count_erase]
        simp [leOfSuccLeSucc (Nat.leTrans hc leSuccSubOne)]
      case inr =>
        rw [count_neq_cons h] at hc
        apply Nat.leTrans hc
        rw [count_erase, beq_neq h]
        simp [Nat.leRefl]
    rw [permSubEraseAllLength hsub', ←length_erase_mem hbas, Nat.succ_sub_succ]

theorem permSubExtend {as bs : List α} {b} (hsub : bs ⊆ as) (ha : b ∈ (as -l bs)) : (b :: bs) ⊆ as := by
  intro a
  rw [mem_nonzeroCount, count_eraseAll, ←zeroLtIffSub] at ha
  byCases h : b = a
  case inl => cases h; simp; assumption
  case inr => rw [count_neq_cons h]; apply hsub

def permSubObtainComplement {as bs : List α} (hsub : bs ⊆ as)
    (hlength : bs.length < as.length) : { e // e ∈ as -l bs} := by
  have hl : (as -l bs).length > 0 := by rw [permSubEraseAllLength hsub, ←zeroLtIffSub]; assumption
  revert hl; cases as -l bs
  case nil => simp only [length_nil]; intro hl'; cases hl'
  case cons => intros; exact ⟨_, Mem.head _ _⟩

theorem permSubEqvClosed {as bs bs' : List α} (heqv : bs ≃ bs') (hsub : bs ⊆ as) : bs' ⊆ as :=
  fun a => by rw [←heqv a]; exact hsub a

theorem permSubSingleton {as : List α} {a : α} : a ∈ as → [a] ⊆ as := by
  intros ha b
  rw [mem_nonzeroCount] at ha
  byCases h : a = b
  case inl => cases h; simp [count_self_cons]; assumption
  case inr => rw [count_neq_cons h]; simp [Nat.zeroLe]

theorem permEqvRotate : (as ++ bs) ≃ (bs ++ as) :=
  fun a => by simp [Nat.add_comm];

theorem permEqvRefl {as : List α} : as ≃ as :=
  fun a => rfl

theorem permEqvTrans {as bs cs : List α} (h : as ≃ bs) (h' : bs ≃ cs) : as ≃ cs :=
  fun a => Eq.trans (h a) (h' a)

theorem permEqvSymm {as bs : List α} (h : as ≃ bs) : bs ≃ as :=
  fun a => by simp [Nat.add_comm, h a]

theorem permEqvToEraseAppend {as bs : List α} (ps : bs ⊆ as) : as ≃ ((as -l bs) ++ bs) :=
  fun a => by simp only [count_append, count_eraseAll]; rw [←Nat.le_subAdd (ps a)]

theorem permEqvToEraseCons {as : List α} {a : α} (h : a ∈ as) : as ≃ (a :: (as.erase a)) := by
  exact permEqvTrans (permEqvToEraseAppend (permSubSingleton h)) (permEqvRotate _ _)

theorem permEqvCons {as bs : List α} {a : α} (h : as ≃ bs) : (a :: as) ≃ (a :: bs) := by
  intro b
  byCases hba : (a = b)
  case inl => cases hba; simp [count_self_cons, h a];
  case inr => rw [count_neq_cons hba, count_neq_cons hba, h b]

theorem permSubEraseOfpermEqvCons {as bs : List α} {a : α} (h : (a :: as) ⊆ bs) :
  as ⊆ (bs.erase a) := fun b => by
  let ha := h a
  byCases h' : a = b
  case inl =>
    cases h'
    rw [count_erase]
    rw [count_self_cons] at ha
    simp [Nat.leOfSuccLeSucc (Nat.leTrans ha leSuccSubOne)]
  case inr =>
    let hb := h b
    rw [count_neq_cons h'] at hb
    rw [count_erase, beq_neq h']
    exact hb

theorem permEqvOfPermSub {as bs : List α} : as ⊆ bs → as.length = bs.length → as ≃ bs :=
  match as with
  | [] => fun hsub hl => by
    rw [length_nil, Eq.symm_iff, length_zero_iff_nil] at hl
    rw [hl]; intro b; rfl
  | a :: as => fun hsub hl => by
    have habs : a ∈ bs := by
      rw [mem_nonzeroCount]
      let hsuba := hsub a
      simp only [count_self_cons] at hsuba
      exact Nat.ltOfLtOfLe (Nat.zeroLtSucc _) hsuba
    have hsub' : as.isPermSubOf (bs.erase a) := permSubEraseOfpermEqvCons hsub
    have hl' : as.length = (bs.erase a).length := by
      apply Nat.add_right_cancel (m := 1)
      rw [length_erase_mem habs, ←hl, length_cons]
    have hp : bs.isPermEqvTo (a :: (bs.erase a)) := permEqvToEraseCons habs
    exact permEqvTrans (permEqvCons (permEqvOfPermSub hsub' hl')) (permEqvSymm hp)

theorem permEqvMemClosed {as bs : List α} {a : α} (hp : as ≃ bs) : a ∈ as → a ∈ bs := by
  rw [mem_nonzeroCount, mem_nonzeroCount, hp a]; intros; assumption

theorem permEqvEraseOfpermEqvCons {as bs : List α} {a : α} (h : (a :: as) ≃ bs) : as ≃ (bs.erase a) := fun a' => by
  let ha := h a
  byCases h' : a = a'
  case inl =>
    cases h'
    rw [count_erase]
    simp only [beq_refl, Lean.Simp.ite_True]
    rw [←ha, count_self_cons, succ_sub_succ,  Nat.sub_zero]
  case inr =>
    let ha' := h a'
    rw [count_neq_cons h'] at ha'
    rw [count_erase, beq_neq h']
    exact ha'

theorem permEqvLength {as bs : List α} : as ≃ bs → as.length = bs.length :=
  match as with
  | [] =>
    match bs with
    | [] => fun _ => rfl
    | b :: bs => fun h => by
      let hb := h b
      simp only [count] at hb; rw [filter_cons, beq_refl] at hb
      simp at hb
  | a :: as => fun h => by
    let ha := h a
    rw [count_self_cons] at ha
    rw [length_cons, permEqvLength (permEqvEraseOfpermEqvCons h)]
    exact length_erase_mem (mem_nonzeroCount.mpr (Nat.ltOfLtOfEq (Nat.zeroLtSucc (count as a)) ha))

theorem permEqv_filter_erase_true {as : List α} {a : α} {p : α → Bool} (hpa : p a = true) (ha : a ∈ as) :
  (a :: filter p (List.erase as a)) ≃ (filter p as) := by
  intro b
  byCases h : a = b
  case inl =>
    cases h
    rw [count_self_cons, filter_erase_true hpa, count_erase]
    simp only [beq_refl, Lean.Simp.ite_True]
    have h' : 1 ≤ count (filter p as) a := by
      apply Nat.succLeOfLt
      apply mem_nonzeroCount.mp
      apply mem_filter_of_prop ha hpa
    exact Eq.symm (le_subAdd h')
  case inr =>
    rw [count_neq_cons h, filter_erase_true hpa, count_erase, beq_neq h]
    simp

theorem permEqvFilter {as bs : List α} (p : α → Bool) : as ≃ bs → (filter p as) ≃ (filter p bs) :=
  match as with
  | [] => by
    intro h
    rw [length_zero_iff_nil.mp $ Eq.symm (permEqvLength h)]
    exact permEqvRefl
  | a :: as => by
    intro h
    rw [filter_cons]
    have h' := permEqvFilter p (permEqvEraseOfpermEqvCons h)
    cases hpa : p a with
    | true =>
      simp only [beq_refl, Lean.Simp.ite_True]
      apply permEqvTrans (permEqvCons h')
      have ha : a ∈ bs := by rw [mem_nonzeroCount, ←h a]; simp [zeroLtSucc]
      exact permEqv_filter_erase_true (as := bs) hpa ha
    | false =>
      refine permEqvTrans h' ?_
      rw [filter_erase_false hpa]
      exact permEqvRefl

end Count

end List


/-
Author: <Redacted for anonymized submission>
-/
-- import snarks.groth16.declarations
import ...attributes
import ...integral_domain_tactic
import ...general_lemmas.polynomial_degree
import data.mv_polynomial.basic
import data.mv_polynomial.funext
import data.polynomial.field_division
import algebra.polynomial.big_operators
-- import ...attributes
import .vars

/-!
# Knowledge Soundness

This file proves the knowledge-soundness property of the Groth16 system for type III pairings, as
presented in "Another Look at Extraction and Randomization of Groth’s zk-SNARK" by
[Baghery et al.](https://eprint.iacr.org/2020/811.pdf).

-/

open_locale big_operators classical

section groth16

open mv_polynomial groth16

noncomputable theory

universes u

/-- The finite field parameter of our SNARK -/
parameter {F : Type u}
parameter [field F]

/-- The naturals representing:
  n_stmt - the statement size,
  n_wit - the witness size -/
parameters {n_stmt n_wit n_var : ℕ}

/-- u_stmt and u_wit are fin-indexed collections of polynomials from the square span program -/
parameter {u_stmt : fin n_stmt → (polynomial F) }
parameter {u_wit : fin n_wit → (polynomial F) }
parameter {v_stmt : fin n_stmt → (polynomial F) }
parameter {v_wit : fin n_wit → (polynomial F) }
parameter {w_stmt : fin n_stmt → (polynomial F) }
parameter {w_wit : fin n_wit → (polynomial F) }

/-- The roots of the polynomial t -/
parameter {r : fin n_wit → F}
/-- t is the polynomial divisibility by which is used to verify satisfaction of the SSP -/
def t : polynomial F := ∏ i in (finset.fin_range n_wit), (polynomial.X - polynomial.C (r i))
-- TODO this could potentially be spun off into a mathlib definition

/-- Checks whether a statement witness pair satisfies the SSP -/
def satisfying (a_stmt : fin n_stmt → F ) (a_wit : fin n_wit → F) :=
((∑ i in (finset.fin_range n_stmt), a_stmt i • u_stmt i
  + (∑ i in (finset.fin_range n_wit), a_wit i • u_wit i))
  *
(∑ i in (finset.fin_range n_stmt), a_stmt i • v_stmt i
  + (∑ i in (finset.fin_range n_wit), a_wit i • v_wit i))
  -
(∑ i in (finset.fin_range n_stmt), a_stmt i • w_stmt i
  + (∑ i in (finset.fin_range n_wit), a_wit i • w_wit i)))
   %ₘ t = 0

run_cmd mk_simp_attr `crs
run_cmd tactic.add_doc_string `simp_attr.crs "Attribute for defintions of CRS elements"

/-- The crs elements
These funtions are actually multivariate Laurent polynomials of the toxic waste samples,
but we represent them here as functions on assignments of the variables to values.
-/
@[crs]
def crs_α  (f : groth16.vars → F) : polynomial F := polynomial.C (f vars.α)
@[crs]
def crs_β (f : groth16.vars → F) : polynomial F := polynomial.C (f vars.β)
@[crs]
def crs_γ (f : groth16.vars → F) : polynomial F := polynomial.C (f vars.γ)
@[crs]
def crs_δ (f : groth16.vars → F) : polynomial F := polynomial.C (f vars.δ)
@[crs]
def crs_powers_of_x (i : fin n_var) (f : groth16.vars → F) : polynomial F := ((polynomial.X)^(i : ℕ))
@[crs]
def crs_l (i : fin n_stmt) (f : groth16.vars → F) : polynomial F :=
polynomial.C (1 / f vars.γ) * (polynomial.C (f vars.β / f vars.γ) * u_stmt i
+
polynomial.C  (f vars.α / f vars.γ) * v_stmt i
+
(w_stmt i))
@[crs]
def crs_m (i : fin n_wit) (f : groth16.vars → F) : polynomial F :=
polynomial.C (1 / f vars.δ) * (polynomial.C  (f vars.β / f vars.δ) * (u_wit i)
+
polynomial.C  (f vars.α / f vars.δ) * (v_wit i)
+
(w_wit i))
@[crs]
def crs_n (i : fin (n_var - 1)) (f : groth16.vars → F) : polynomial F :=
(polynomial.X)^(i : ℕ) * t * polynomial.C (1 / f vars.δ)

/-- The coefficients of the CRS elements in the algebraic adversary's representation -/
parameters {A_α A_β A_γ A_δ B_α B_β B_γ B_δ C_α C_β C_γ C_δ  : F}
parameters {A_x B_x C_x : fin n_var → F}
parameters {A_l B_l C_l : fin n_stmt → F}
parameters {A_m B_m C_m : fin n_wit → F}
parameters {A_h B_h C_h : fin (n_var-1) → F}

/-- Polynomial forms of the adversary's proof representation -/
def A : (groth16.vars → F) -> polynomial F := λ f,
  polynomial.C A_α * (crs_α f)

def B : (groth16.vars → F) -> polynomial F  :=  λ f,
  polynomial.C B_β * crs_β f

def C : (groth16.vars → F) -> polynomial F  :=  λ f,
  polynomial.C C_α * crs_α f

local notation `groth16polynomial` := mv_polynomial vars (polynomial F)

/-- The modified crs elements
these are multivariate (non-Laurent!) polynomials of the toxic waste samples,
obtained by multiplying the Laurent polynomial forms of the CRS through by γδ.
We will later prove that the laurent polynomial equation is equivalent to a similar equation of the modified crs elements, allowing us to construct a proof in terms of polynomials -/
@[crs]
def crs'_α  : groth16polynomial := X vars.α * X vars.γ * X vars.δ
@[crs]
def crs'_β : groth16polynomial := X vars.β * X vars.γ * X vars.δ
@[crs]
def crs'_γ : groth16polynomial := X vars.γ * X vars.γ * X vars.δ
@[crs]
def crs'_δ : groth16polynomial := X vars.δ * X vars.γ * X vars.δ
@[crs]
def crs'_powers_of_x (i : fin n_var) : (groth16polynomial) := mv_polynomial.C (polynomial.X ^ (i : ℕ)) * X vars.γ * X vars.δ
-- I define prodcuts of these crs elements without the division, then later claim identities. Is this right?
@[crs]
def crs'_l (i : fin n_stmt) : (groth16polynomial) :=
(X vars.β * X vars.δ) * mv_polynomial.C (u_stmt i)
+
(X vars.α * X vars.δ) * mv_polynomial.C (v_stmt i)
+
X vars.δ * mv_polynomial.C (w_stmt i)
@[crs]
def crs'_m (i : fin n_wit) : (groth16polynomial) :=
(X vars.β * X vars.γ) * mv_polynomial.C (u_wit i)
+
(X vars.α * X vars.γ) * mv_polynomial.C (v_wit i)
+
X vars.γ * mv_polynomial.C (w_wit i)
@[crs]
def crs'_t (i : fin (n_var - 1)) : (groth16polynomial) :=
X vars.γ * mv_polynomial.C ((polynomial.X)^(i : ℕ) * t)

/-- Polynomial form of A in the adversary's proof representation -/
def A'  : groth16polynomial :=
  crs'_α * mv_polynomial.C (polynomial.C (A_α))
  +
  crs'_β * mv_polynomial.C (polynomial.C (A_β))

/-- Polynomial form of B in the adversary's proof representation -/
def B'  : groth16polynomial :=
  crs'_β * mv_polynomial.C (polynomial.C (B_β))

/-- Polynomial form of C in the adversary's proof representation -/
def C'  : groth16polynomial :=
  crs'_α * mv_polynomial.C (polynomial.C (C_α))
  +
  crs'_β * mv_polynomial.C (polynomial.C (C_β))
  +
  crs'_δ * mv_polynomial.C (polynomial.C (C_δ))

lemma modification_equivalence (a_stmt : fin n_stmt → F ) :
  A * B = C -> A' * B' = C'
:=
begin
  -- TODO different now that we switch to mv_poly vars (poly F)
  -- rw verified,
  -- rw verified',
  intro h,
  -- Apply functional extensionality
  simp [A', B', C'],
  rw function.funext_iff at h,
  simp [A, B, C] at h,

end

end groth16


lemma contrapositive2 (P Q : Prop) : (¬ Q → ¬ P) → (P → Q) :=
begin
by_cases p : P; by_cases q : Q,
intros h p2,
exact q,
repeat { tauto! },
end