(** * Category of abelian groups *)
(** ** Contents
- Precategory of abelian groups
- Category of abelian groups
- Zero object and Zero arrow
 - Zero object
 - Zero arrow
- Category of abelian groups is preadditive
- Category of abelian groups is additive
- Kernels and Cokernels
 - Kernels
 - Cokernels
- Monics are inclusions and Epis are surjections
 - Epis are surjections
 - Monics are inclusions
- Monics are kernels of their cokernels and epis are cokernels of their kernels
 - Monics are Kernels
 - Epis are Cokernels
- The category of abelian groups is an abelian category
- Corollaries to additive categories
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.UnivalenceAxiom.

Require Import UniMath.Algebra.BinaryOperations.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.Monoids.

Require Import UniMath.NumberSystems.Integers.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.

Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.Epis.

Require Import UniMath.CategoryTheory.CategoriesWithBinOps.
Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops.
Require Import UniMath.CategoryTheory.PreAdditive.
Require Import UniMath.CategoryTheory.Additive.
Require Import UniMath.CategoryTheory.Abelian.

Require Import UniMath.CategoryTheory.limits.zero.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.equalizers.
Require Import UniMath.CategoryTheory.limits.coequalizers.
Require Import UniMath.CategoryTheory.limits.kernels.
Require Import UniMath.CategoryTheory.limits.cokernels.
Require Import UniMath.CategoryTheory.limits.BinDirectSums.

Local Open Scope cat.

(** * Precategory of abelian groups
  - Objects are abelian groups, [abgr].
  - Morphisms are monoidfuns, [monoidfun].
*)
Section def_abgr_precategory.

  (** ** precategory_data *)

  Definition abgr_fun_space (A B : abgr) : hSet := make_hSet (monoidfun A B) (isasetmonoidfun A B).

  Definition abgr_precategory_ob_mor : precategory_ob_mor :=
    tpair (λ ob : UU, ob -> ob -> UU) abgr (λ A B : abgr, abgr_fun_space A B).

  Definition abgr_precategory_data : precategory_data :=
    make_precategory_data
      abgr_precategory_ob_mor (λ (A : abgr), ((idmonoidiso A) : monoidfun A A))
      (fun (A B C : abgr) (f : monoidfun A B) (g : monoidfun B C) => monoidfuncomp f g).

  (** ** is_precategory *)

  Lemma is_precategory_abgr_precategory_data : is_precategory abgr_precategory_data.
  Proof.
    use make_is_precategory_one_assoc.
    - intros a b f. use monoidfunidleft.
    - intros a b f. use monoidfunidright.
    - intros a b c d f g h. use monoidfunassoc.
  Qed.

  (** ** precategory and category *)

  Definition abgr_precategory : precategory :=
    make_precategory abgr_precategory_data is_precategory_abgr_precategory_data.

  Lemma has_homsets_abgr : has_homsets abgr_precategory.
  Proof.
    intros a b. use isasetmonoidfun.
  Qed.

  Definition abgr_category : category := make_category abgr_precategory has_homsets_abgr.

End def_abgr_precategory.

(** * Category of abelian groups
  - (monoidiso X Y) ≃ (iso X Y)
  - Category of abelian groups
*)
Section def_abgr_category.

  (** ** (monoidiso X Y) ≃ (z_iso X Y) *)

  Lemma abgr_z_iso_is_equiv (A B : ob abgr_category) (f : z_iso A B) : isweq (pr1 (pr1 f)).
  Proof.
    use isweq_iso.
    - exact (pr1monoidfun _ _ (inv_from_z_iso f)).
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x).
      intros x0. use isapropismonoidfun.
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x).
      intros x0. use isapropismonoidfun.
  Qed.

  Lemma abgr_z_iso_equiv (X Y : ob abgr_category) : z_iso X Y -> monoidiso (X : abgr) (Y : abgr).
  Proof.
    intro f.
    use make_monoidiso.
    - exact (make_weq (pr1 (pr1 f)) (abgr_z_iso_is_equiv X Y f)).
    - exact (pr2 (pr1 f)).
  Defined.

  Lemma abgr_equiv_is_z_iso (X Y : ob abgr_category) (f : monoidiso (X : abgr) (Y : abgr)) :
    @is_z_isomorphism abgr_category X Y (monoidfunconstr (pr2 f)).
  Proof.
    exists (monoidfunconstr (pr2 (invmonoidiso f))).
    split.
    - use monoidfun_paths. use funextfun. intros x. use homotinvweqweq.
    - use monoidfun_paths. use funextfun. intros y. use homotweqinvweq.
  Qed.

  Definition abgr_equiv_z_iso (X Y : ob abgr_category) (f : monoidiso (X : abgr) (Y : abgr)) :
    z_iso X Y := @make_z_iso' abgr_category X Y (monoidfunconstr (pr2 f)) (abgr_equiv_is_z_iso X Y f).

  Lemma abgr_z_iso_equiv_is_equiv (X Y : abgr_category) : isweq (abgr_z_iso_equiv X Y).
  Proof.
    use isweq_iso.
    - exact (abgr_equiv_z_iso X Y).
    - intros x. use z_iso_eq. use monoidfun_paths. use idpath.
    - intros y. use monoidiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + use idpath.
  Qed.

  Definition abgr_z_iso_equiv_weq (X Y : ob abgr_category) :
    weq (z_iso X Y) (monoidiso (X : abgr) (Y : abgr)).
  Proof.
    use make_weq.
    - exact (abgr_z_iso_equiv X Y).
    - exact (abgr_z_iso_equiv_is_equiv X Y).
  Defined.

  Lemma abgr_equiv_z_iso_is_equiv (X Y : ob abgr_category) : isweq (abgr_equiv_z_iso X Y).
  Proof.
    use isweq_iso.
    - exact (abgr_z_iso_equiv X Y).
    - intros y. use monoidiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + use idpath.
    - intros x. use z_iso_eq. use monoidfun_paths. use idpath.
  Qed.

  Definition abgr_equiv_weq_z_iso (X Y : ob abgr_category) :
    (monoidiso (X : abgr) (Y : abgr)) ≃ (z_iso X Y).
  Proof.
    use make_weq.
    - exact (abgr_equiv_z_iso X Y).
    - exact (abgr_equiv_z_iso_is_equiv X Y).
  Defined.

  (** ** Category of abelian groups *)

  Definition abgr_category_isweq (a b : ob abgr_category) : isweq (λ p : a = b, idtoiso p).
  Proof.
    use (@isweqhomot
           (a = b) (z_iso a b)
           (pr1weq (weqcomp (abgr_univalence a b) (abgr_equiv_weq_z_iso a b)))
           _ _ (weqproperty (weqcomp (abgr_univalence a b) (abgr_equiv_weq_z_iso a b)))).
    intros e. induction e.
    use (pathscomp0 weqcomp_to_funcomp_app).
    use total2_paths_f.
    - use total2_paths_f.
      + use idpath.
      + use proofirrelevance. use isapropismonoidfun.
    - use proofirrelevance. use isaprop_is_z_isomorphism.
  Qed.

  Definition abgr_category_is_univalent : is_univalent abgr_category.
  Proof.
    intros a b. exact (abgr_category_isweq a b).

  Defined.

  Definition abgr_univalent_category : univalent_category :=
    make_univalent_category abgr_category abgr_category_is_univalent.

End def_abgr_category.

(** * Zero object and Zero arrow
   - Zero object is the abelian group which consists of one element, the unit element.
   - The unique morphism to zero object maps every element to the unit element.
   - The unique morphism from the zero object maps unit to unit.
   - The unique morphisms which factors through zero object maps every element to the unit
     element.
   - Computations on zero object
 *)
Section def_abgr_zero.

  (** ** Zero in abelian category *)

  Lemma isconnectedfromunitabgr (a : abgr_category) (t : abgr_category ⟦unitabgr, a⟧):
    (t : monoidfun unitabgr (a : abgr)) = abgrfunfromunit (a : abgr).
  Proof.
    use monoidfun_paths. use funextfun. intros x.
    use (pathscomp0 _ (monoidfununel t)). use maponpaths. use isProofIrrelevantUnit.
  Qed.

  Lemma isconnectedtounitabgr (a : abgr_category) (t : abgr_category ⟦a, unitabgr⟧):
    (t : monoidfun (a : abgr) unitabgr) = abgrfuntounit a.
  Proof.
    use monoidfun_paths. use funextfun. intros x. use isProofIrrelevantUnit.
  Qed.

  Definition abgr_isZero : @isZero abgr_category unitabgr.
  Proof.
    use make_isZero.
    - intros a. use make_iscontr.
      + exact (abgrfunfromunit a).
      + intros t. exact (isconnectedfromunitabgr a t).
    - intros a. use make_iscontr.
      + exact (abgrfuntounit a).
      + intros t. exact (isconnectedtounitabgr a t).
  Defined.

  Definition abgr_Zero : Zero abgr_category := @make_Zero abgr_category unitabgr abgr_isZero.

  (** ** Computations on zero object *)

  Lemma abgr_Zero_comp : ZeroObject (abgr_Zero) = unitabgr.
  Proof.
    use idpath.
  Qed.

  Lemma abgr_Zero_from_comp (A : abgr) :
    @ZeroArrowFrom abgr_category abgr_Zero A = abgrfunfromunit A.
  Proof.
    use idpath.
  Qed.

  Lemma abgr_Zero_to_comp (A : abgr) :
    @ZeroArrowTo abgr_category abgr_Zero A = abgrfuntounit A.
  Proof.
    use idpath.
  Qed.

  Lemma abgr_Zero_arrow_comp (A B : abgr) :
    @ZeroArrow abgr_category abgr_Zero A B = unelabgrfun A B.
  Proof.
    use monoidfun_paths. use funextfun. intros x. use idpath.
  Qed.

End def_abgr_zero.

(** * Preadditive structure on the category of abelian groups
   - Binary operation on homsets.
   - Abelian group structure on homsets
   - PreAdditive structure on the category of abelian groups
*)
Section abgr_preadditive.

  (** ** Binary operations on homsets
      Let f, g : X --> Y be morphisms in the category of abelian groups. Then f + g is defined to be
      the morphism (f + g) x = (f x) + (g x). This gives [precategoryWithBinOps] structure on the
      category.
  *)

  Definition abgr_WithBinOpsData : precategoryWithBinOpsData abgr_category.
  Proof.
    intros X Y. exact (@abmonoidshombinop (X : abgr) (Y : abgr)).
  Defined.

  Definition abgr_WithBinOps : precategoryWithBinOps :=
    make_precategoryWithBinOps abgr_category abgr_WithBinOpsData.

  (** ** [categoryWithAbgrops] structure on the category of abelian groups *)

  Definition abgr_WithAbGrops : categoryWithAbgrops.
  Proof.
    use make_categoryWithAbgrops.
    - exact abgr_WithBinOps.
    - use make_categoryWithAbgropsData.
      intros X Y. exact (@abgrshomabgr_isabgrop X Y).
  Defined.

  (** ** [PreAdditive] structure on the category of abelian groups *)

  Definition abgr_isPreAdditive : isPreAdditive abgr_WithAbGrops.
  Proof.
    use make_isPreAdditive.
    (* Precomposition with morphism is linear *)
    - intros X Y Z f.
      use make_ismonoidfun.
      + use make_isbinopfun. intros g h. use monoidfun_paths. use funextfun. intros x. use idpath.
      + use monoidfun_paths. use funextfun. intros x. use idpath.
    (* Postcomposition with morphism is linear *)
    - intros X Y Z f.
      use make_ismonoidfun.
      + use make_isbinopfun. intros g h. use monoidfun_paths. use funextfun. intros x.
        use (pathscomp0 ((pr1 (pr2 f)) _ _)). use idpath.
      + use monoidfun_paths. use funextfun. intros x. exact (monoidfununel f).
  Qed.

  Definition abgr_PreAdditive : PreAdditive :=
    make_PreAdditive abgr_WithAbGrops abgr_isPreAdditive.

End abgr_preadditive.

(** * Additive structure on the category of abelian groups
   - Direct sums
   - Additive category structure
 *)
Section abgr_additive.

  (** ** Direct sums
     Direct sum of X and Y is given by the direct product abelian group X × Y. The inclusions
     and projections are given by
     - In1 :  x ↦ (x, 0)
     - In2 :  y ↦ (0, y)
     - Pr1 :  (x, y) ↦ x
     - Pr2 :  (x, y) ↦ y
   *)

  Lemma abgr_DirectSumPr1_ismonoidfun (A B : abgr) :
    ismonoidfun (λ X : abgrdirprod A B, dirprod_pr1 X).
  Proof.
    use make_ismonoidfun.
    - use make_isbinopfun. intros x x'. use idpath.
    - use idpath.
  Qed.

  Definition abgr_DirectSumPr1 (A B : abgr) : abgr_category⟦abgrdirprod A B, A⟧ :=
    monoidfunconstr (abgr_DirectSumPr1_ismonoidfun A B).

  Lemma abgr_DirectSumPr2_ismonoidfun (A B : abgr) :
    ismonoidfun (λ X : abgrdirprod A B, dirprod_pr2 X).
  Proof.
    use make_ismonoidfun.
    - use make_isbinopfun. intros x x'. use idpath.
    - use idpath.
  Qed.

  Definition abgr_DirectSumPr2 (A B : abgr) : abgr_category⟦abgrdirprod A B, B⟧ :=
    monoidfunconstr (abgr_DirectSumPr2_ismonoidfun A B).

  Lemma abgr_DirectSumIn1_ismonoidfun (A B : abgr) :
    @ismonoidfun A (abgrdirprod A B) (λ a : A, make_dirprod a (unel B)).
  Proof.
    use make_ismonoidfun.
    - use make_isbinopfun. intros x x'. use dirprod_paths.
      + use idpath.
      + use pathsinv0. use (runax B).
    - use dirprod_paths.
      + use idpath.
      + use idpath.
  Qed.

  Definition abgr_DirectSumIn1 (A B : abgr) : abgr_category⟦A, abgrdirprod A B⟧ :=
    monoidfunconstr (abgr_DirectSumIn1_ismonoidfun A B).

  Lemma abgr_DirectSumIn2_ismonoidfun (A B : abgr) :
    @ismonoidfun B (abgrdirprod A B) (λ b : B, make_dirprod (unel A) b).
  Proof.
    use make_ismonoidfun.
    - use make_isbinopfun. intros x x'. use dirprod_paths.
      + use pathsinv0. use (runax A).
      + use idpath.
    - use dirprod_paths.
      + use idpath.
      + use idpath.
  Qed.

  Definition abgr_DirectSumIn2 (A B : abgr) : abgr_category⟦B, abgrdirprod A B⟧ :=
    monoidfunconstr (abgr_DirectSumIn2_ismonoidfun A B).

  Lemma abgr_DirectSumIdIn1 (A B : abgr) :
    abgr_DirectSumIn1 A B · abgr_DirectSumPr1 A B = (idmonoidiso A : monoidfun A A).
  Proof.
    use monoidfun_paths. use funextfun. intros x. use idpath.
  Qed.

  Lemma abgr_DirectSumIdIn2 (A B : abgr) :
    abgr_DirectSumIn2 A B · abgr_DirectSumPr2 A B = (idmonoidiso B : monoidfun B B).
  Proof.
    use monoidfun_paths. use funextfun. intros x. use idpath.
  Qed.

  Lemma abgr_DirectSumUnel1 (A B : abgr) :
    abgr_DirectSumIn1 A B · abgr_DirectSumPr2 A B = @to_unel abgr_PreAdditive A B.
  Proof.
    use monoidfun_paths. use funextfun. intros x. use idpath.
  Qed.

  Lemma abgr_DirectSumUnel2 (A B : abgr) :
    abgr_DirectSumIn2 A B · abgr_DirectSumPr1 A B = @to_unel abgr_PreAdditive B A.
  Proof.
    use monoidfun_paths. use funextfun. intros x. use idpath.
  Qed.

  Lemma abgr_DirectSumId (A B : abgr) :
    @abmonoidshombinop
      (abgrdirprod A B) (abgrdirprod A B)
      (abgr_DirectSumPr1 A B · abgr_DirectSumIn1 A B)
      (abgr_DirectSumPr2 A B · abgr_DirectSumIn2 A B) =
    ((idmonoidiso (abgrdirprod A B)) : monoidfun (abgrdirprod A B) (abgrdirprod A B)) .
  Proof.
    use monoidfun_paths. use funextfun. intros x. use dirprod_paths.
    - use (runax A).
    - use (lunax B).
  Qed.

  Lemma abgr_isBinDirectSum (X Y : abgr) :
    @isBinDirectSum
      abgr_PreAdditive X Y (abgrdirprod X Y) (abgr_DirectSumIn1 X Y) (abgr_DirectSumIn2 X Y)
      (abgr_DirectSumPr1 X Y) (abgr_DirectSumPr2 X Y).
  Proof.
    use make_isBinDirectSum.
    - exact (abgr_DirectSumIdIn1 X Y).
    - exact (abgr_DirectSumIdIn2 X Y).
    - exact (abgr_DirectSumUnel1 X Y).
    - exact (abgr_DirectSumUnel2 X Y).
    - exact (abgr_DirectSumId X Y).
  Defined.

  Definition abgr_AdditiveStructure : AdditiveStructure abgr_PreAdditive.
  Proof.
    use make_AdditiveStructure.
    - exact abgr_Zero.
    - use make_BinDirectSums. intros X Y. use make_BinDirectSum.
      + exact (abgrdirprod X Y).
      + exact (abgr_DirectSumIn1 X Y).
      + exact (abgr_DirectSumIn2 X Y).
      + exact (abgr_DirectSumPr1 X Y).
      + exact (abgr_DirectSumPr2 X Y).
      + exact (abgr_isBinDirectSum X Y).
  Defined.

  Definition abgr_Additive : CategoryWithAdditiveStructure := make_Additive abgr_PreAdditive abgr_AdditiveStructure.

End abgr_additive.

(** * Kernels and Cokernels
   - Kernels in the category of abelian groups
   - Cokernels in the category of abelian groups
 *)
Section abgr_kernels_and_cokernels.

  Definition abgr_Kernel_monoidfun {A B : abgr} (f : monoidfun A B) :
    abgr_category⟦carrierofasubabgr (abgr_Kernel_subabgr f), A⟧ :=
    monoidincltomonoidfun
      (abgr_Kernel_subabgr f) A
      (@make_monoidmono (abgr_Kernel_subabgr f) A
                       (make_incl (pr1carrier (abgr_kernel_hsubtype f))
                                 (isinclpr1carrier (abgr_kernel_hsubtype f)))
                       (abgr_Kernel_monoidfun_ismonoidfun f)).

  (** *** Composition Kernel f --> X --> Y is the zero arrow *)

  Definition abgr_Kernel_eq {A B : abgr} (f : monoidfun A B) :
    abgr_Kernel_monoidfun f · f = ZeroArrow abgr_Zero (carrierofasubabgr (abgr_Kernel_subabgr f)) B.
  Proof.
    apply monoidfun_paths.
    apply funextfun; intro x.
    apply (pr2 x).
  Qed.

  (** *** KernelIn morphism *)

  Lemma abgr_KernelArrowIn_map_property {A B C : abgr_category} (h : C --> A) (f : A --> B)
             (H : h · f = ZeroArrow abgr_Zero C B) (c : (C : abgr)) :
    (pr1 f (pr1 h c) = 1%multmonoid).
  Proof.
    use (pathscomp0 (toforallpaths _ _ _ (base_paths _ _ H) c)). use idpath.
  Qed.

  Definition abgr_KernelArrowIn_map {A B C : abgr_category} (h : C --> A) (f : A --> B)
             (H : h · f = ZeroArrow abgr_Zero C B) (c : (C : abgr)) : abgr_Kernel_subabgr f.
  Proof.
    use tpair.
    - exact (pr1 h c).
    - exact (abgr_KernelArrowIn_map_property h f H c).
  Defined.

  Lemma abgr_KernelArrowIn_ismonoidfun {A B C : abgr_category} (h : C --> A)
        (f : A --> B) (H : h · f = ZeroArrow abgr_Zero C B) :
    @ismonoidfun (C : abgr) (@abgr_Kernel_subabgr A B f) (@abgr_KernelArrowIn_map A B C h f H).
  Proof.
    use make_ismonoidfun.
    - use make_isbinopfun. intros x x'. use total2_paths_f.
      + exact (binopfunisbinopfun (h : monoidfun (C : abgr) (A : abgr)) x x').
      + use proofirrelevance. use propproperty.
    - use total2_paths_f.
      + exact (monoidfununel h).
      + use proofirrelevance. use propproperty.
  Qed.

  Definition abgr_KernelArrowIn {A B C : abgr_category} (h : C --> A) (f : A --> B)
             (H : h · f = ZeroArrow abgr_Zero C B) :
    abgr_category⟦C, carrierofasubabgr (abgr_Kernel_subabgr f)⟧.
  Proof.
    use monoidfunconstr.
    - exact (abgr_KernelArrowIn_map h f H).
    - exact (abgr_KernelArrowIn_ismonoidfun h f H).
  Defined.

  (** *** Kernels *)

  Definition abgr_Kernel_isKernel_KernelArrrow {A B C : abgr} (f : abgr_category ⟦A, B⟧)
             (h : abgr_category ⟦C, A⟧) (H' : h · f = ZeroArrow abgr_Zero C B) :
    ∑ ψ : abgr_category ⟦C, carrierofasubabgr (abgr_Kernel_subabgr f)⟧,
          ψ · abgr_Kernel_monoidfun f = h.
  Proof.
    use tpair.
    - exact (abgr_KernelArrowIn h f H').
    - use monoidfun_paths. use funextfun. intros x. use idpath.
  Defined.

  Definition abgr_Kernel_isKernel_uniqueness {A B C : abgr} (f : abgr_category ⟦A, B⟧)
             (h : abgr_category ⟦C, A⟧) (H' : h · f = ZeroArrow abgr_Zero C B)
             (t : ∑ (t1 : abgr_category ⟦C, carrierofasubabgr (abgr_Kernel_subabgr f)⟧),
                  t1 · abgr_Kernel_monoidfun f = h) :
    t = abgr_Kernel_isKernel_KernelArrrow f h H'.
  Proof.
    use total2_paths_f.
    - use monoidfun_paths. use funextfun. intros x. use total2_paths_f.
      + exact (toforallpaths _ _ _ (base_paths _ _ (pr2 t)) x).
      + use proofirrelevance. use propproperty.
    - use proofirrelevance. use setproperty.
  Qed.

  Definition abgr_Kernel_isKernel {A B : abgr} (f : abgr_category⟦A, B⟧) :
    isKernel abgr_Zero (abgr_Kernel_monoidfun f) f (abgr_Kernel_eq f).
  Proof.
    use make_isKernel.
    - intros w h H'.
      use make_iscontr.
      + exact (abgr_Kernel_isKernel_KernelArrrow f h H').
      + intros t. exact (abgr_Kernel_isKernel_uniqueness f h H' t).
  Defined.

  Definition abgr_Kernel {A B : abgr} (f : monoidfun A B) :
    Kernel abgr_Zero f :=
    make_Kernel (abgr_Zero) (abgr_Kernel_monoidfun f) f (abgr_Kernel_eq f) (abgr_Kernel_isKernel f).

  Corollary abgr_Kernels : Kernels abgr_Zero.
  Proof.
    intros A B f. exact (abgr_Kernel f).
  Defined.

  (** ** Cokernels
     - Let f : X --> Y be a morphism of abelian groups. A cokernel for f is given by the quotient
       quotient group Y/(Im f) together with the canonical morphism Y --> Y/(Im f).
   *)

  (** *** Subgroup gives an equivalence relation. *)

  Definition abgr_Cokernel_eqrel_istrans {A B : abgr} (f : monoidfun A B) :
    istrans (λ b1 b2 : B, ∃ a : A, f a = (b1 * grinv B b2)%multmonoid).
  Proof.
    intros x1 x2 x3 y1 y2.
    use (hinhuniv _ y1). intros y1'.
    use (hinhuniv _ y2). intros y2'.
    use hinhpr.
    use tpair.
    - exact (@op A (pr1 y1') (pr1 y2')).
    - use (pathscomp0 (binopfunisbinopfun f (pr1 y1') (pr1 y2'))).
      rewrite (pr2 y1'). rewrite (pr2 y2').
      rewrite <- assocax. rewrite (assocax _ _ _ x2). rewrite (grlinvax B). rewrite (runax B).
      use idpath.
  Qed.

  Definition abgr_Cokernel_eqrel_isrefl {A B : abgr} (f : monoidfun A B) :
    isrefl (λ b1 b2 : B, ∃ a : A, f a = (b1 * grinv B b2)%multmonoid).
  Proof.
    intros x1 P X. use X. clear P X.
    use tpair.
    - exact (unel A).
    - cbn. rewrite (grrinvax B). use (monoidfununel f).
  Qed.

  Definition abgr_Cokernel_eqrel_issymm {A B : abgr} (f : monoidfun A B) :
    issymm (λ b1 b2 : B, ∃ a : A, f a = (b1 * grinv B b2)%multmonoid).
  Proof.
    intros x1 x2 x3.
    use (hinhuniv _ x3). intros x3'.
    intros P X. use X. clear P X.
    use tpair.
    - exact (grinv A (pr1 x3')).
    - use (pathscomp0 (monoidfuninvtoinv f (pr1 x3'))).
      rewrite (pr2 x3'). rewrite grinvop. use two_arg_paths.
      + use grinvinv.
      + use idpath.
  Qed.

  Definition abgr_Cokernel_eqrel {A B : abgr} (f : monoidfun A B) : eqrel B :=
    @eqrelconstr B (λ b1 : B, λ b2 : B, ∃ a : A, (f a) = (op b1 (grinv B b2)))
                 (abgr_Cokernel_eqrel_istrans f) (abgr_Cokernel_eqrel_isrefl f)
                 (abgr_Cokernel_eqrel_issymm f).

  (** *** Construction of the quotient abelian group Y/(Im f) *)

  Definition abgr_Cokernel_abgr_isbinoprel {A B : abgr} (f : monoidfun A B) :
    isbinophrel (λ b1 b2 : pr1 B, ∃ a : pr1 A, pr1 f a = (b1 * grinv B b2)%multmonoid).
  Proof.
    use isbinophrelif.
    - exact (commax B).
    - intros x1 x2 x3 y1. use (hinhuniv _ y1). intros y1'. use hinhpr.
      use tpair.
      + exact (pr1 y1').
      + use (pathscomp0 (pr2 y1')). rewrite grinvop.
        rewrite (commax B x3). rewrite (assocax B). rewrite (commax B x3).
        rewrite (assocax B). rewrite (grlinvax B x3). rewrite (runax B). use idpath.
  Qed.

  Definition abgr_Cokernel_abgr {A B : abgr} (f : monoidfun A B) : abgr :=
    @abgrquot B (make_binopeqrel (abgr_Cokernel_eqrel f) (abgr_Cokernel_abgr_isbinoprel f)).

  (** *** The canonical morphism Y --> Y/(Im f) *)

  Lemma abgr_CokernelArrow_ismonoidfun {A B : abgr} (f : monoidfun A B) :
    @ismonoidfun B (@abgr_Cokernel_abgr A B f) (@setquotpr B (@abgr_Cokernel_eqrel A B f)).
  Proof.
    use make_ismonoidfun.
    - use make_isbinopfun. intros x x'. use idpath.
    - use idpath.
  Qed.

  Definition abgr_CokernelArrow {A B : abgr} (f : monoidfun A B) :
    abgr_category⟦B, abgr_Cokernel_abgr f⟧.
  Proof.
    use monoidfunconstr.
    - exact (setquotpr (abgr_Cokernel_eqrel f)).
    - exact (abgr_CokernelArrow_ismonoidfun f).
  Defined.

  (** *** CokernelOut *)

  Lemma abgr_Cokernel_monoidfun_issurjective {A B : abgr} (f : monoidfun A B) :
    issurjective (pr1 (abgr_CokernelArrow f)).
  Proof.
    use issurjsetquotpr.
  Qed.

  Definition abgr_Cokernel_eq {A B : abgr} (f : abgr_category⟦A, B⟧) :
    f · abgr_CokernelArrow f = ZeroArrow abgr_Zero A (abgr_Cokernel_abgr f).
  Proof.
    use monoidfun_paths. use funextfun. intros a.
    use (iscompsetquotpr (abgr_Cokernel_eqrel f)).
    use hinhpr.
    use tpair.
    - exact a.
    - use (pathscomp0 (pathsinv0 (runax B (pr1 f a)))).
      use two_arg_paths.
      + use idpath.
      + use pathsinv0. use (grinvunel B).
  Qed.

  Definition abgr_CokernelArrowOutUniv_iscomprelfun {A B C : abgr_category}
             (f : A --> B) (h : B --> C) (H : f · h = ZeroArrow abgr_Zero A C) :
    iscomprelfun (λ b1 b2 : pr1 B, ∃ a : pr1 A, pr1 f a = (b1 * grinv (abgrtogr B) b2)%multmonoid)
                 (pr1 h).
  Proof.
    intros x x' X.
    use (squash_to_prop X (setproperty (C : abgr) (pr1 h x) (pr1 h x'))). intros X'.
    use (grrcan (abgrtogr C) ((pr1 h) (grinv (abgrtogr B) x'))).
    use (pathscomp0 _ (binopfunisbinopfun
                         (h : monoidfun (B : abgr) (C : abgr)) x' (grinv (B : abgr) x'))).
    use (pathscomp0 _ (! maponpaths (λ xx : (B : abgr), pr1 h xx) (grrinvax (B : abgr) x'))).
    use (pathscomp0 _ (! (monoidfununel h))).
    use (pathscomp0 _ (toforallpaths _ _ _ (base_paths _ _ H) (pr1 X'))).
    use (pathscomp0 (! (binopfunisbinopfun
                          (h : monoidfun (B : abgr) (C : abgr)) x (grinv (B : abgr) x')))).
    use maponpaths. use pathsinv0. exact (pr2 X').
  Qed.

  Definition abgr_CokernelOut_map {A B C : abgr_category} (f : A --> B)
             (h : B --> C) (H : f · h = ZeroArrow abgr_Zero A C) :
    (abgr_Cokernel_abgr f) -> (pr1 C) :=
    setquotuniv (λ b1 b2 : pr1 B, ∃ a : pr1 A, pr1 f a = (b1 * grinv (abgrtogr B) b2)%multmonoid)
                (pr1 C) (pr1 h) (abgr_CokernelArrowOutUniv_iscomprelfun f h H).

  Definition abgr_CokernelOut_ismonoidfun {A B C : abgr} (f : abgr_category ⟦A, B⟧)
             (h : abgr_category ⟦B, C⟧) (H : f · h = ZeroArrow abgr_Zero A C) :
    @ismonoidfun (@abgr_Cokernel_abgr A B f) C (@abgr_CokernelOut_map A B C f h H).
  Proof.
    use make_ismonoidfun.
    - exact (@isbinopfun_twooutof3b
               (pr1 B) (abgr_Cokernel_abgr f) C
               (pr1 (abgr_CokernelArrow f))
               (abgr_CokernelOut_map f h H)
               (abgr_Cokernel_monoidfun_issurjective f)
               (binopfunisbinopfun (h : monoidfun B C))
               (binopfunisbinopfun ((abgr_CokernelArrow f) : monoidfun B _))).
    - exact (monoidfununel (h : monoidfun B C)).
  Qed.

  Definition abgr_CokernelOut {A B C : abgr} (f : abgr_category⟦A, B⟧) (h : abgr_category⟦B, C⟧)
             (H : f · h = ZeroArrow abgr_Zero A C) : monoidfun (abgr_Cokernel_abgr f) C :=
    monoidfunconstr (abgr_CokernelOut_ismonoidfun f h H).

  Lemma abgr_CokernelOut_Comm {A B C : abgr} (f : abgr_category⟦A, B⟧) (h : abgr_category⟦B, C⟧)
        (H : f · h = ZeroArrow abgr_Zero A C) :
    monoidfuncomp (abgr_CokernelArrow f) (abgr_CokernelOut f h H) = h.
  Proof.
    use monoidfun_paths. use funextfun. intros x. use idpath.
  Qed.

  Definition make_abgr_CokernelOut {A B C : abgr} (f : abgr_category ⟦A, B⟧)
             (h : abgr_category ⟦B, C⟧) (H : f · h = ZeroArrow abgr_Zero A C) :
    ∑ ψ : abgr_category⟦abgr_Cokernel_abgr f, C⟧, abgr_CokernelArrow f · ψ = h.
  Proof.
    use tpair.
    - exact (abgr_CokernelOut f h H).
    - exact (abgr_CokernelOut_Comm f h H).
  Defined.

  (** *** Cokernels *)

  Lemma abgr_isCokernel_uniquenss {A B C : abgr} (f : abgr_category⟦A, B⟧) (h : abgr_category⟦B, C⟧)
        (H : f · h = ZeroArrow abgr_Zero A C)
        (t : ∑ ψ : abgr_category ⟦abgr_Cokernel_abgr f, C⟧, abgr_CokernelArrow f · ψ = h) :
    t = make_abgr_CokernelOut f h H.
  Proof.
    use total2_paths_f.
    - use monoidfun_paths. use funextfun. intros x.
      use (squash_to_prop (abgr_Cokernel_monoidfun_issurjective f x) (setproperty C _ _)).
      intros hf. rewrite <- (hfiberpr2 _ _ hf).
      exact (toforallpaths _ _ _ (base_paths _ _ (pr2 t)) (hfiberpr1 _ _ hf)).
    - use proofirrelevance. use homset_property.
  Qed.

  Definition abgr_isCokernel {A B : abgr} (f : abgr_category⟦A, B⟧) :
    isCokernel abgr_Zero f (abgr_CokernelArrow f) (abgr_Cokernel_eq f).
  Proof.
    use make_isCokernel.
    - intros C h H. use make_iscontr.
      + exact (make_abgr_CokernelOut f h H).
      + intros t. exact (abgr_isCokernel_uniquenss f h H t).
  Defined.

  Definition abgr_Cokernel {A B : abgr} (f : abgr_category⟦A, B⟧) : Cokernel abgr_Zero f :=
    make_Cokernel abgr_Zero f (abgr_CokernelArrow f) (abgr_Cokernel_eq f) (abgr_isCokernel f).

  Corollary abgr_Cokernels : Cokernels abgr_Zero.
  Proof.
    intros A B f. exact (abgr_Cokernel f).
  Defined.

End abgr_kernels_and_cokernels.

(** * Monics are injective and epis are surjective
   - Epis are surjective
   - Monics are injective
*)
Section abgr_monics_and_epis.

  (** ** Epis *)

  Definition abgr_epi_hfiber_inhabited
             {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) (b : B)
             (H : setquotpr (abgr_Cokernel_eqrel f) b =
                  setquotpr (abgr_Cokernel_eqrel f) 1%multmonoid) : ∥ hfiber (pr1 f) b ∥.
  Proof.
    set (tmp := weqpathsinsetquot (abgr_Cokernel_eqrel f) b (unel _)).
    use (hinhuniv _ ((invweq tmp) H)). intros Y. use hinhpr. induction Y as [t p].
    rewrite grinvunel in p. rewrite (runax B) in p.
    exact (make_hfiber (pr1 f) t p).
  Qed.

  Definition abgr_epi_issurjective {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) :
    issurjective (pr1 f).
  Proof.
    intros x. use abgr_epi_hfiber_inhabited.
    - exact isE.
    - set (tmp := isE (abgr_Cokernel_abgr f) (abgr_CokernelArrow f)
                      (unelabgrfun B (abgr_Cokernel_abgr f))).
      assert (H : f · abgr_CokernelArrow f = f · unelabgrfun B (abgr_Cokernel_abgr f)).
      {
        rewrite abgr_Cokernel_eq.
        rewrite <- abgr_Zero_arrow_comp.
        rewrite ZeroArrow_comp_right.
        use idpath.
      }
      exact (toforallpaths _ _ _ (base_paths _ _ (tmp H)) x).
  Qed.

  (** ** Monics *)

  Lemma nat_nat_prod_abgr_monoidfun_paths {A B : abgr} (a1 a2 : A) (f : monoidfun A B)
        (H : f a1 = f a2) : monoidfuncomp (nat_nat_prod_abmonoid_monoidfun a1) f =
                            monoidfuncomp (nat_nat_prod_abmonoid_monoidfun a2) f.
  Proof.
    use monoidfun_paths. use funextfun. intros x. induction x as [x1 x2]. cbn.
    unfold nataddabmonoid_nataddabmonoid_to_monoid_fun.
    unfold nat_nat_to_monoid_fun. Opaque nat_to_monoid_fun. cbn.
    use (pathscomp0 (binopfunisbinopfun f _ _)).
    use (pathscomp0 _ (! (binopfunisbinopfun f _ _))). cbn.
    rewrite (monoidfun_nat_to_monoid_fun f a1 x1).
    rewrite (monoidfun_nat_to_monoid_fun f a2 x1).
    rewrite (monoidfun_nat_to_monoid_fun f (grinv A a1) x2).
    rewrite (monoidfun_nat_to_monoid_fun f (grinv A a2) x2).
    use two_arg_paths.
    - induction H. use idpath.
    - assert (e : f (grinv A a1) = f (grinv A a2)). {
        use (@grlcan B _ _ (pr1 f a1)).
        use (pathscomp0 (! binopfunisbinopfun f a1 (grinv A a1))).
        use (pathscomp0 (maponpaths (pr1 f) (grrinvax A a1))).
        cbn in H. rewrite H.
        use (pathscomp0 _ (binopfunisbinopfun f a2 (grinv A a2))).
        use (pathscomp0 _ (! (maponpaths (pr1 f) (grrinvax A a2)))).
        use idpath.
      }
      induction e. use idpath.
  Qed.
  Transparent nat_to_monoid_fun.

  Lemma abgr_monoidfun_precomp {A :abmonoid} {B C : abgr} (f1 f2 : monoidfun B C)
        (g : monoidfun A B) (H : issurjective (pr1 g)) :
    monoidfuncomp g f1 = monoidfuncomp g f2 -> f1 = f2.
  Proof.
    intros e. use monoidfun_paths. use funextfun. intros x.
    use (squash_to_prop (H x) (setproperty C _ _)). intros hf.
    rewrite <- (hfiberpr2 _ _ hf).
    exact (toforallpaths _ _ _ (base_paths _ _ e) (hfiberpr1 _ _ hf)).
  Qed.

  Lemma hz_abgr_fun_monoifun_paths {A B : abgr} (a1 a2 : A) (f : monoidfun A B) (H : f a1 = f a2) :
    monoidfuncomp (hz_abgr_fun_monoidfun a1) f = monoidfuncomp (hz_abgr_fun_monoidfun a2) f.
  Proof.
    use (@abgr_monoidfun_precomp
           (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig))
           hzaddabgr B
           (monoidfuncomp (hz_abgr_fun_monoidfun a1) f)
           (monoidfuncomp (hz_abgr_fun_monoidfun a2) f)
           hz_abmonoid_monoidfun).
    - use issurjsetquotpr.
    - rewrite monoidfunassoc. rewrite monoidfunassoc.
      rewrite abgr_natnat_hz_X_comm. rewrite abgr_natnat_hz_X_comm.
      exact (nat_nat_prod_abgr_monoidfun_paths a1 a2 f H).
  Qed.

  Definition abgr_monic_isincl {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) :
    isincl (pr1 f).
  Proof.
    intros b h1 h2.
    use make_iscontr.
    - use total2_paths_f.
      + set (e := hfiberpr2 _ _ h1 @ (! hfiberpr2 _ _ h2)).
        set (tmp := isM hzaddabgr (hz_abgr_fun_monoidfun (pr1 h1))
                        (hz_abgr_fun_monoidfun (pr1 h2))
                        (hz_abgr_fun_monoifun_paths (pr1 h1) (pr1 h2) f e)).
        set (e' := toforallpaths _ _ _ (base_paths _ _ tmp) hzone).
        use (grrcan A (unel A)). use (grrcan A (unel A)). exact e'.
      + use proofirrelevance. use (setproperty B).
    - intros t. use proofirrelevance. use isaset_hfiber.
      + use setproperty.
      + use setproperty.
  Qed.

  Definition abgr_monic_isInjective {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) :
    isInjective (pr1 f).
  Proof.
    exact (isweqonpathsincl (pr1 f) (abgr_monic_isincl f isM)).
  Qed.

  Lemma abgr_monic_paths {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) (a1 a2 : A) :
    pr1 f a1 = pr1 f a2 -> a1 = a2.
  Proof.
    exact (invweq (make_weq _ (abgr_monic_isInjective f isM a1 a2))).
  Qed.

  Lemma abgr_monoidfun_postcomp {A B C : abgr} (f1 f2 : monoidfun A B) (g : monoidfun B C)
        (isM : isMonic (g : abgr_category⟦B, C⟧)) :
    monoidfuncomp f1 g = monoidfuncomp f2 g -> f1 = f2.
  Proof.
    intros e. use monoidfun_paths. use funextfun. intros x.
    use (invmap (make_weq _ (abgr_monic_isInjective g isM (pr1 f1 x) (pr1 f2 x)))).
    exact (toforallpaths _ _ _ (base_paths _ _ e) x).
  Qed.

End abgr_monics_and_epis.

(** * Monics are kernels of their cokernels and epis are cokernels of their kernels *)
Section abgr_monic_kernels_epi_cokernels.

  (** ** Monics are kernels of their cokernels *)

  Definition abgr_monic_kernel_in_hfiber_iscontr {A B C : abgr} (f : abgr_category⟦A, B⟧)
             (isM : isMonic f) (h : abgr_category⟦C, B⟧)
             (H : h · CokernelArrow (abgr_Cokernel f) =
                  ZeroArrow abgr_Zero C (abgr_Cokernel f)) (c : C) :
    iscontr (hfiber (pr1 f) (pr1 h c)).
  Proof.
    use (squash_to_prop
           ((invweq (weqpathsinsetquot (abgr_Cokernel_eqrel f) (pr1 h c) (unel _)))
              (toforallpaths _ _ _ (base_paths _ _ H) c)) (isapropiscontr _)).
    intros hf.
    use make_iscontr.
    - use make_hfiber.
      + exact (pr1 hf).
      + use (pathscomp0 (pr2 hf)). rewrite grinvunel. use (runax B).
    - intros t. use total2_paths_f.
      + use (invmap (make_weq _ (abgr_monic_isInjective f isM (pr1 t) (pr1 hf)))).
        use (pathscomp0 (hfiberpr2 _ _ t)). use (pathscomp0 _ (! (pr2 hf))).
        rewrite grinvunel. rewrite runax. use idpath.
      + use proofirrelevance. use (setproperty B).
  Qed.

  Lemma abgr_monic_kernel_in_hfiber_mult_eq {A B : abgr} (f : abgr_category⟦A, B⟧)
        (w : abgr) (x x' : w) (h : abgr_category⟦w, B⟧) (X : hfiber (pr1 f) (pr1 h x))
        (X0 : hfiber (pr1 f) (pr1 h x')) :
    pr1 f (pr1 X * pr1 X0)%multmonoid = pr1 h (x * x')%multmonoid.
  Proof.
    rewrite (pr1 (pr2 f)).
    rewrite (pr2 X).
    rewrite (pr2 X0).
    rewrite (pr1 (pr2 h)).
    use idpath.
  Qed.

  Definition abgr_monic_kernel_in_hfiber_mult {A B : abgr} (f : abgr_category⟦A, B⟧)
             (w : abgr) (x x' : w) (h : abgr_category⟦w, B⟧) :
    hfiber (pr1 f) (pr1 h x) -> hfiber (pr1 f) (pr1 h x')
    -> hfiber (pr1 f) (pr1 h (x * x')%multmonoid).
  Proof.
    intros X X0.
    exact (make_hfiber (pr1 f) ((pr1 X) * (pr1 X0))%multmonoid
                      (abgr_monic_kernel_in_hfiber_mult_eq f w x x' h X X0)).
  Defined.

  Lemma abgr_monic_kernel_in_hfiber_unel_eq {A B C : abgr} (f : abgr_category⟦A, B⟧)
        (h : abgr_category⟦C, B⟧) : pr1 f 1%multmonoid = pr1 h 1%multmonoid.
  Proof.
    rewrite (pr2 (pr2 h)). use (pr2 (pr2 f)).
  Qed.

  Definition abgr_monic_kernel_in_hfiber_unel {A B : abgr} (f : abgr_category⟦A, B⟧) (w : abgr)
             (h : abgr_category⟦w, B⟧) : hfiber (pr1 f) (pr1 h 1%multmonoid) :=
    make_hfiber (pr1 f) 1%multmonoid (abgr_monic_kernel_in_hfiber_unel_eq f h).

  Definition abgr_monic_kernel_in {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f)
             (w : abgr) (h: abgr_category⟦w, B⟧)
             (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero _ _) : w -> A.
  Proof.
    intros x.
    exact (hfiberpr1 _ _ (iscontrpr1 (@abgr_monic_kernel_in_hfiber_iscontr A B w f isM h H x))).
  Defined.

  Definition abgr_monic_kernel_in_ismonoidfun {A B : abgr} (f : abgr_category⟦A, B⟧)
             (isM : isMonic f) (w : abgr) (h: abgr_category⟦w, B⟧)
             (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero _ _) :
    ismonoidfun (abgr_monic_kernel_in f isM w h H).
  Proof.
    use make_ismonoidfun.
    - use make_isbinopfun. intros x x'.
      set (t := abgr_monic_kernel_in_hfiber_iscontr f isM h H x).
      set (tmp := abgr_monic_kernel_in_hfiber_mult
                    f w x x' h
                    (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H x))
                    (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H x'))).
      use pathscomp0.
      + exact (hfiberpr1 _ _ tmp).
      + unfold abgr_monic_kernel_in.
        use (invmap (make_weq _ (abgr_monic_isInjective f isM _ _))).
        use (pathscomp0 (hfiberpr2 _ _ (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr
                                                      f isM h H (x * x')%multmonoid)))).
        use pathsinv0.
        exact (hfiberpr2 _ _ tmp).
      + use idpath.
    - assert (e : iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H 1%multmonoid)
                  = (abgr_monic_kernel_in_hfiber_unel f w h)).
      {
        use total2_paths_f.
        - use (invmap (make_weq _ (abgr_monic_isInjective f isM _ _))).
          use (pathscomp0 (hfiberpr2 _ _ (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr
                                                        f isM h H 1%multmonoid)))).
          use pathsinv0.
          exact (hfiberpr2 _ _ (abgr_monic_kernel_in_hfiber_unel f w h)).
        - use proofirrelevance. use setproperty.
      }
      exact (base_paths _ _ e).
  Qed.

  Definition abgr_monic_kernel_in_monoidfun {A B : abgr} (f : abgr_category⟦A, B⟧)
             (isM : isMonic f) (w : abgr) (h: abgr_category⟦w, B⟧)
             (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero _ _) :
    monoidfun w A := monoidfunconstr (abgr_monic_kernel_in_ismonoidfun f isM w h H).

  Definition abgr_monic_Kernel_eq {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) :
    f · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero A (abgr_Cokernel f).
  Proof.
    use CokernelCompZero.
  Qed.

  Lemma abgr_monic_Kernel_isKernel_comm {A B C : abgr} (f : abgr_category⟦A, B⟧)
        (isM : isMonic f) (h : abgr_category⟦C, B⟧)
        (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero C (abgr_Cokernel f)):
    monoidfuncomp (abgr_monic_kernel_in_monoidfun f isM C h H) f = h.
  Proof.
    use monoidfun_paths. use funextfun. intros x.
    exact (hfiberpr2 _ _ (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H x))).
  Qed.

  Definition make_abgr_monic_Kernel_isKernel {A B C : abgr} (f : abgr_category⟦A, B⟧)
             (isM : isMonic f) (h : abgr_category⟦C, B⟧)
             (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero C (abgr_Cokernel f)) :
    ∑ ψ : abgr_category ⟦C, A⟧, ψ · f = h.
  Proof.
    use tpair.
    - exact (abgr_monic_kernel_in_monoidfun f isM C h H).
    - exact (abgr_monic_Kernel_isKernel_comm f isM h H).
  Defined.

  Definition abgr_monic_Kernel_isKernel_uniqueness {A B C : abgr} (f : abgr_category⟦A, B⟧)
             (isM : isMonic f) (h : abgr_category⟦C, B⟧)
             (H : h · CokernelArrow (abgr_Cokernel f) = ZeroArrow abgr_Zero C (abgr_Cokernel f))
             (t : ∑ ψ : abgr_category ⟦C, A⟧, ψ · f = h) :
    t = make_abgr_monic_Kernel_isKernel f isM h H.
  Proof.
    use total2_paths_f.
    - use monoidfun_paths. use funextfun. intros x.
      use (invmap (make_weq _ (abgr_monic_isInjective f isM _ _))).
      use (pathscomp0 (toforallpaths _ _ _ (base_paths _ _ (pr2 t)) x)).
      use pathsinv0.
      exact (hfiberpr2 _ _ (iscontrpr1 (abgr_monic_kernel_in_hfiber_iscontr f isM h H x))).
    - use proofirrelevance. use setproperty.
  Qed.

  Definition abgr_monic_Kernel_isKernel {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) :
    isKernel abgr_Zero f (CokernelArrow (abgr_Cokernel f))
             (CokernelCompZero abgr_Zero (abgr_Cokernel f)).
  Proof.
    use make_isKernel.
    - intros w h H.
      use make_iscontr.
      + exact (make_abgr_monic_Kernel_isKernel f isM h H).
      + exact (abgr_monic_Kernel_isKernel_uniqueness f isM h H).
  Defined.

  Definition abgr_monic_kernel {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) :
    Kernel abgr_Zero (CokernelArrow (abgr_Cokernel f)) :=
    make_Kernel abgr_Zero f (CokernelArrow (abgr_Cokernel f)) (abgr_monic_Kernel_eq f isM)
              (abgr_monic_Kernel_isKernel f isM).

  Lemma abgr_monic_kernel_comp {A B : abgr} (f : abgr_category⟦A, B⟧) (isM : isMonic f) :
    KernelArrow (abgr_monic_kernel f isM) = f.
  Proof.
    use idpath.
  Qed.

  (** ** Epis are cokernels of their kernels *)

  Definition abgr_epi_cokernel_out_kernel_hsubtype {A B : abgr}
             (f : abgr_category⟦A, B⟧) (a : A)
             (H : pr1 f a = 1%multmonoid) : abgr_kernel_hsubtype f.
  Proof.
    exact (a,, H).
  Defined.

  Lemma abgr_epi_cokernel_out_data_eq {A B C : abgr} (f : abgr_category⟦A, B⟧)
        (isE : isEpi f) (h : abgr_category⟦A, C⟧)
        (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero (abgr_Kernel f) C) :
    ∏ x : abgr_kernel_hsubtype f, pr1 h (pr1carrier (abgr_kernel_hsubtype f) x) = 1%multmonoid.
  Proof.
    exact (toforallpaths _ _ _ (base_paths _ _ H)).
  Qed.

  Lemma abgr_epi_cokernel_out_data_hfibers_to_unel {A B : abgr} (f : abgr_category⟦A, B⟧) (b : B)
        (hfib1 hfib2 : hfiber (pr1 f) b) :
    (pr1 f) ((pr1 hfib1) * (grinv A (pr1 hfib2)))%multmonoid = unel B.
  Proof.
    rewrite (pr1 (pr2 f)).
    use (grrcan (abgrtogr B) (pr1 f (pr1 hfib2))).
    rewrite (assocax B). rewrite <- (pr1 (pr2 f)).
    rewrite (grlinvax A). rewrite (pr2 (pr2 f)).
    rewrite (runax B). rewrite (lunax B).
    rewrite (pr2 hfib1). rewrite (pr2 hfib2).
    use idpath.
  Qed.

  Lemma abgr_epi_cokernel_out_data_hfiber_eq {A B C : abgr} (f : abgr_category⟦A, B⟧)
        (isE : isEpi f) (h : abgr_category⟦A, C⟧)
        (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) (b : B)
        (X : hfiber (pr1 f) b) : ∏ hfib : hfiber (pr1 f) b, pr1 h (pr1 hfib) = pr1 h (pr1 X).
  Proof.
    intros hfib.
    use (grrcan C (grinv (abgrtogr C) (pr1 h (pr1 X)))).
    rewrite (grrinvax C).
    set (e1 := abgr_epi_cokernel_out_data_hfibers_to_unel f b hfib X).
    set (tmp1 := ! (monoidfuninvtoinv h (hfiberpr1 _ _ X))). cbn in tmp1.
    use (pathscomp0 (maponpaths (λ k : _, ((pr1 h (pr1 hfib)) * k)%multmonoid) tmp1)).
    rewrite <- (pr1 (pr2 h)).
    set (tmp2 := abgr_epi_cokernel_out_data_eq f isE h H).
    set (tmp3 := abgr_epi_cokernel_out_kernel_hsubtype
                   f (pr1 hfib * grinv A (pr1 X))%multmonoid e1).
    set (tmp4 := tmp2 tmp3). cbn in tmp4. exact tmp4.
  Qed.

  Lemma abgr_epi_CokernelOut_iscontr {A B C : abgr} (f : abgr_category⟦A, B⟧)
        (isE : isEpi f) (h : abgr_category⟦A, C⟧)
        (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) (b : B) :
    iscontr (∑ x : C, ∏ (hfib : hfiber (pr1 f) b), pr1 h (pr1 hfib) = x).
  Proof.
    use (squash_to_prop (abgr_epi_issurjective f isE b) (isapropiscontr _)).
    intros X. use make_iscontr.
    - use tpair.
      + exact (pr1 h (pr1 X)).
      + exact (abgr_epi_cokernel_out_data_hfiber_eq f isE h H b X).
    - intros t. use total2_paths_f.
      + exact (! ((pr2 t) X)).
      + use proofirrelevance. use impred. intros t0. use (setproperty C).
  Defined.

  Definition abgr_epi_CokernelOut_mult_eq {A B C : abgr} (b1 b2 : B)
             (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧)
             (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _)
             (X : ∑ x : C, ∏ hfib : hfiber (pr1 f) b1, pr1 h (pr1 hfib) = x)
             (X0 : ∑ x : C, ∏ hfib : hfiber (pr1 f) b2, pr1 h (pr1 hfib) = x) :
    ∏ hfib : hfiber (pr1 f) (b1 * b2)%multmonoid, pr1 h (pr1 hfib) = (pr1 X * pr1 X0)%multmonoid.
  Proof.
    intros hfib.
    use (squash_to_prop (abgr_epi_issurjective f isE b1) (setproperty C _ _)). intros X1.
    use (squash_to_prop (abgr_epi_issurjective f isE b2) (setproperty C _ _)). intros X2.
    rewrite <- ((pr2 X) X1). rewrite <- ((pr2 X0) X2). rewrite <- (pr1 (pr2 h)).
    exact (abgr_epi_cokernel_out_data_hfiber_eq
             f isE h H (b1 * b2)%multmonoid (hfiberbinop (f : monoidfun _ _) b1 b2 X1 X2) hfib).
  Qed.

  Definition abgr_epi_cokernel_out_data_mult {A B C : abgr} (b1 b2 : B)
             (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧)
             (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) :
    (∑ x : C, ∏ (hfib : hfiber (pr1 f) b1), pr1 h (pr1 hfib) = x) ->
    (∑ x : C, ∏ (hfib : hfiber (pr1 f) b2), pr1 h (pr1 hfib) = x) ->
    (∑ x : C, ∏ (hfib : hfiber (pr1 f) (b1 * b2)%multmonoid), pr1 h (pr1 hfib) = x).
  Proof.
    intros X X0.
    exact (tpair _ ((pr1 X) * (pr1 X0))%multmonoid
                 (abgr_epi_CokernelOut_mult_eq b1 b2 f isE h H X X0)).
  Defined.

  Definition abgr_epi_cokernel_out_data_unel_eq {A B C : abgr}
             (f : abgr_category⟦A, B⟧) (isE : isEpi f) (h : abgr_category⟦A, C⟧)
             (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) :
    ∏ hfib : hfiber (pr1 f) 1%multmonoid, pr1 h (pr1 hfib) = 1%multmonoid.
  Proof.
    intros hfib.
    set (hfib_unel := make_hfiber (pr1 f) 1%multmonoid (pr2 (pr2 f))).
    rewrite (abgr_epi_cokernel_out_data_hfiber_eq f isE h H 1%multmonoid hfib_unel hfib).
    exact (monoidfununel h).
  Qed.

  Definition abgr_epi_cokernel_out_data_unel {A B C : abgr} (f : abgr_category⟦A, B⟧)
             (isE : isEpi f) (h : abgr_category⟦A, C⟧)
             (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) :
    ( ∑ x : C, ∏ (hfib : hfiber (pr1 f) 1%multmonoid),  pr1 h (pr1 hfib) = x) :=
    tpair _ 1%multmonoid (abgr_epi_cokernel_out_data_unel_eq f isE h H).

  Lemma abgr_epi_cokernel_out_ismonoidfun {A B C : abgr} (f : abgr_category⟦A, B⟧)
        (isE : isEpi f) (h : abgr_category⟦A, C⟧)
        (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) :
    ismonoidfun (λ b : B, (pr1 (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H b)))).
  Proof.
    use make_ismonoidfun.
    - use make_isbinopfun. intros x x'.
      set (HH0 := abgr_epi_cokernel_out_data_mult
                    x x' f isE h H
                    (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H x))
                    (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H x'))).
      assert (HH : iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H (x * x')%multmonoid) = HH0).
      {
        set (tmp := abgr_epi_CokernelOut_iscontr f isE h H (x * x')%multmonoid).
        rewrite (pr2 tmp). use pathsinv0. rewrite (pr2 tmp).
        use idpath.
      }
      exact (base_paths _ _ HH).
    - assert (HH : iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H 1%multmonoid)
                   = abgr_epi_cokernel_out_data_unel f isE h H).
      {
        rewrite (pr2 (abgr_epi_CokernelOut_iscontr f isE h H 1%multmonoid)).
        use pathsinv0.
        rewrite (pr2 (abgr_epi_CokernelOut_iscontr f isE h H 1%multmonoid)).
        use idpath.
      }
      exact (base_paths _ _ HH).
  Qed.

  Definition abgr_epi_cokernel_out_monoidfun {A B C : abgr} (f : abgr_category⟦A, B⟧)
             (isE : isEpi f) (h : abgr_category⟦A, C⟧)
             (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero _ _) :
    monoidfun B C := monoidfunconstr (abgr_epi_cokernel_out_ismonoidfun f isE h H).

  Definition abgr_epi_cokernel_eq {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) :
    KernelArrow (abgr_Kernel f) · f = ZeroArrow abgr_Zero _ _.
  Proof.
    use KernelCompZero.
  Qed.

  Lemma abgr_epi_cokernel_isCokernel_comm {A B C : abgr} (f : abgr_category⟦A, B⟧)
             (isE : isEpi f)  (h : abgr_category⟦A, C⟧)
             (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero (abgr_Kernel f) C) :
    f · abgr_epi_cokernel_out_monoidfun f isE h H = h.
  Proof.
    use total2_paths_f.
    - use funextfun. intros x. use pathsinv0.
      exact (pr2 (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H (pr1 f x)))
                 (@make_hfiber _ _ (pr1 f) (pr1 f x) x (idpath _))).
    - use proofirrelevance. use isapropismonoidfun.
  Qed.

  Definition make_abgr_epi_cokernel_isCokernel {A B C : abgr} (f : abgr_category⟦A, B⟧)
             (isE : isEpi f)  (h : abgr_category⟦A, C⟧)
             (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero (abgr_Kernel f) C) :
    ∑ ψ : abgr_category ⟦B, C⟧, f · ψ = h.
  Proof.
    use tpair.
    - exact (abgr_epi_cokernel_out_monoidfun f isE h H).
    - exact (abgr_epi_cokernel_isCokernel_comm f isE h H).
  Defined.

  Lemma abgr_epi_cokernel_isCokernel_uniqueness {A B C : abgr} (f : abgr_category⟦A, B⟧)
        (isE : isEpi f)  (h : abgr_category⟦A, C⟧)
        (H : KernelArrow (abgr_Kernel f) · h = ZeroArrow abgr_Zero (abgr_Kernel f) C)
        (t : ∑ ψ : abgr_category ⟦B, C⟧, f · ψ = h) :
    t = make_abgr_epi_cokernel_isCokernel f isE h H.
  Proof.
    use total2_paths_f.
    - use isE. use (pathscomp0 (pr2 t)). use monoidfun_paths. use funextfun. intros x.
      exact (pr2 (iscontrpr1 (abgr_epi_CokernelOut_iscontr f isE h H (pr1 f x)))
                 (@make_hfiber _ _ (pr1 f) (pr1 f x) x (idpath _))).
    - use proofirrelevance. use setproperty.
  Qed.

  Definition abgr_epi_cokernel_isCokernel {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) :
    isCokernel abgr_Zero (KernelArrow (abgr_Kernel f)) f (abgr_epi_cokernel_eq f isE).
  Proof.
    use make_isCokernel.
    - intros w h H. use make_iscontr.
      + exact (make_abgr_epi_cokernel_isCokernel f isE h H).
      + intros t. exact (abgr_epi_cokernel_isCokernel_uniqueness f isE h H t).
  Defined.

  Definition abgr_epi_cokernel {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) :
    Cokernel abgr_Zero (KernelArrow (abgr_Kernel f)) :=
    make_Cokernel abgr_Zero (KernelArrow (abgr_Kernel f)) f _ (abgr_epi_cokernel_isCokernel f isE).

  Definition abgr_epi_cokernel_comp {A B : abgr} (f : abgr_category⟦A, B⟧) (isE : isEpi f) :
    CokernelArrow (abgr_epi_cokernel f isE) = f.
  Proof.
    use idpath.
  Qed.

End abgr_monic_kernels_epi_cokernels.

(** * Category of abelian groups is an abelian category *)
Section abgr_abelian.

  Definition abgr_Abelian : AbelianPreCat.
  Proof.
    set (BinDS := to_BinDirectSums abgr_Additive).
    use (make_Abelian abgr_category).
    - use make_Data1.
      + exact abgr_Zero.
      + intros X Y. exact (BinDirectSum_BinProduct abgr_Additive (BinDS X Y)).
      + intros X Y. exact (BinDirectSum_BinCoproduct abgr_Additive (BinDS X Y)).
    - use make_AbelianData.
      + use make_Data2.
        * intros A B f. exact (abgr_Kernel f).
        * intros A B f. exact (abgr_Cokernel f).
      + use make_MonicsAreKernels.
        intros x y M.
        exact (KernelisKernel abgr_Zero (abgr_monic_kernel M (MonicisMonic abgr_category M))).
      + use make_EpisAreCokernels.
        intros x y E.
        exact (CokernelisCokernel abgr_Zero (abgr_epi_cokernel E (EpiisEpi abgr_category E))).
  Defined.

End abgr_abelian.

(** * Corollaries to additive categories
   In an additive category the homsets are abelian groups and pre- and postcompositions are
   morphisms of abelian groups. In this section we prove the following lemmas about additive
   categories using the theory of abelian groups developed above
   - A morphism φ in an additive category which gives isomorphisms (φ · _) and (_ · φ) is an
     isomorphism, [abgr_Additive_premor_postmor_is_iso].
   - A criteria of being a kernel in the category of abelian groups which uses only elements
     of abelian groups, [abgr_isKernel_Criteria].
*)
Section abgr_corollaries.

  (** ** Isomorphism criteria *)

  (** *** (_ · ZeroArrow) = ZeroArrow = (ZeroArrow · _) *)

  Lemma AdditiveZeroArrow_postmor_Abelian {Add : CategoryWithAdditiveStructure} (x y z : Add) :
    to_postmor_monoidfun Add x y z (ZeroArrow (Additive.to_Zero Add) y z) =
    ZeroArrow (to_Zero abgr_Abelian) (@to_abgr Add x y) (@to_abgr Add x z).
  Proof.
    rewrite <- PreAdditive_unel_zero.
    use monoidfun_paths. use funextfun. intros f. exact (to_premor_unel Add z f).
  Qed.

  Lemma AdditiveZeroArrow_premor_Abelian {Add : CategoryWithAdditiveStructure} (x y z : Add) :
    to_premor_monoidfun Add x y z (ZeroArrow (Additive.to_Zero Add) x y) =
    ZeroArrow (to_Zero abgr_Abelian) (@to_abgr Add y z) (@to_abgr Add x z).
  Proof.
    rewrite <- PreAdditive_unel_zero.
    use monoidfun_paths. use funextfun. intros f. exact (to_postmor_unel Add x f).
  Qed.

  (** *** f isomorphism ⇒ (f · _) isomorphism *)

  Local Lemma abgr_Additive_is_iso_premor_inverses {Add : CategoryWithAdditiveStructure} (x y z : Add) {f : x --> y}
        (H : is_z_isomorphism f) :
    is_inverse_in_precat ((to_premor_monoidfun Add x y z f) : abgr_Abelian⟦_, _⟧)
                         (to_premor_monoidfun Add y x z (is_z_isomorphism_mor H)).
  Proof.
    use make_is_inverse_in_precat.
    - use monoidfun_paths. use funextfun.
      intros x0. cbn. unfold to_premor. rewrite assoc.
      rewrite (is_inverse_in_precat2 H). use id_left.
    - use monoidfun_paths. use funextfun.
      intros x0. cbn. unfold to_premor. rewrite assoc.
      rewrite (is_inverse_in_precat1 H). use id_left.
  Qed.

  Lemma abgr_Additive_is_iso_premor {Add : CategoryWithAdditiveStructure} (x y z : Add) {f : x --> y}
        (H : is_z_isomorphism f) :
    @is_z_isomorphism abgr_Abelian _ _ (to_premor_monoidfun Add x y z f).
  Proof.
    use make_is_z_isomorphism.
    - exact (to_premor_monoidfun Add _ _ z (is_z_isomorphism_mor H)).
    - exact (abgr_Additive_is_iso_premor_inverses _ _ z H).
  Defined.

  (** *** f isomorphism ⇒ (_ · f) isomorphism *)

  Local Lemma abgr_Additive_is_iso_postmor_inverses {Add : CategoryWithAdditiveStructure} (x y z : Add) {f : y --> z}
        (H : is_z_isomorphism f) :
    is_inverse_in_precat ((to_postmor_monoidfun Add x y z f) : abgr_Abelian⟦_, _⟧)
                         (to_postmor_monoidfun Add x z y (is_z_isomorphism_mor H)).
  Proof.
    use make_is_inverse_in_precat.
    - use monoidfun_paths. use funextfun.
      intros x0. cbn. unfold to_postmor. rewrite <- assoc.
      rewrite (is_inverse_in_precat1 H). use id_right.
    - use monoidfun_paths. use funextfun.
      intros x0. cbn. unfold to_postmor. rewrite <- assoc.
      rewrite (is_inverse_in_precat2 H). use id_right.
  Qed.

  Lemma abgr_Additive_is_iso_postmor {Add : CategoryWithAdditiveStructure} (x y z : Add) {f : y --> z}
        (H : is_z_isomorphism f) :
    @is_z_isomorphism abgr_Abelian _ _ (to_postmor_monoidfun Add x y z f).
  Proof.
    use make_is_z_isomorphism.
    - exact (to_postmor_monoidfun Add x _ _ (is_z_isomorphism_mor H)).
    - exact (abgr_Additive_is_iso_postmor_inverses x _ _ H).
  Defined.

  (** *** Pre- and postcomposition with f is an isomorphism ⇒ f isomorphism *)

  Local Lemma abgr_Additive_premor_postmor_is_iso_inverses {Add : CategoryWithAdditiveStructure} (x y : Add)
        {f : x --> y}
        (H1 : @is_z_isomorphism abgr_Abelian _ _ (to_premor_monoidfun Add x y x f))
        (H2 : @is_z_isomorphism abgr_Abelian _ _ (to_postmor_monoidfun Add y x y f)) :
    is_inverse_in_precat f ((is_z_isomorphism_mor H1 : monoidfun (to_abgr x x) (to_abgr y x))
                              (identity x : to_abgr x x)).
  Proof.
    set (mor1 := ((is_z_isomorphism_mor H1) : (monoidfun (to_abgr x x) (to_abgr y x)))
                   ((identity x) : to_abgr x x)).
    set (mor2 := ((is_z_isomorphism_mor H2) : (monoidfun (to_abgr y y) (to_abgr y x)))
                   ((identity y) : to_abgr y y)).
    assert (Hx : f · mor1 = identity x).
    {
      exact (toforallpaths _ _ _ (base_paths _ _ (is_inverse_in_precat2 H1)) (identity x)).
    }
    assert (Hy : mor2 · f = identity y).
    {
      exact (toforallpaths _ _ _ (base_paths _ _ (is_inverse_in_precat2 H2)) (identity y)).
    }
    assert (H : mor1 = mor2).
    {
      rewrite <- (id_right mor2).
      rewrite <- Hx.
      rewrite assoc.
      rewrite Hy.
      rewrite id_left.
      use idpath.
    }
    use make_is_inverse_in_precat.
    - exact Hx.
    - rewrite H. exact Hy.
  Qed.

  Lemma abgr_Additive_premor_postmor_is_iso {Add : CategoryWithAdditiveStructure} (x y : Add) {f : x --> y}
        (H1 : @is_z_isomorphism abgr_Abelian _ _ (to_premor_monoidfun Add x y x f))
        (H2 : @is_z_isomorphism abgr_Abelian _ _ (to_postmor_monoidfun Add y x y f)) :
    is_z_isomorphism f.
  Proof.
    use make_is_z_isomorphism.
    - exact (((is_z_isomorphism_mor H1) : (monoidfun (to_abgr x x) (to_abgr y x)))
               ((identity x) : to_abgr x x)).
    - exact (abgr_Additive_premor_postmor_is_iso_inverses _ _ H1 H2).
  Defined.

  (** ** A criteria for isKernel which uses only the elements in the abelian group. *)

  Local Opaque ZeroArrow.

  Definition abgr_isKernel_iscontr {X Y Z W : abgr_Abelian} (f : X --> Y) (g : Y --> Z)
             (ZA : f · g = @ZeroArrow abgr_Abelian (to_Zero abgr_Abelian) _ _)
             (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)),
                  ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥)
             (isM : @isMonic abgr_Abelian _ _ f) (h : W --> Y)
             (H' : h · g = @ZeroArrow abgr_Abelian (to_Zero abgr_Abelian) W Z) (w' : pr1 W) :
    iscontr (∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = pr1 h w').
  Proof.
    cbn in H'. rewrite <- (@PreAdditive_unel_zero (abgr_PreAdditive)) in H'.
    unfold to_unel in H'.
    set (e := toforallpaths _ _ _ (base_paths _ _ H') w').
    set (H'' := H (tpair _ (pr1 h w') e)).
    use (squash_to_prop H'' (isapropiscontr _)). intros HH.
    induction HH as [H1 H2]. cbn in H2.
    use tpair.
    - use tpair.
      + exact H1.
      + exact H2.
    - cbn. intros T. induction T as [T1 T2].
      use total2_paths_f.
      + use (abgr_monic_paths f isM T1 H1). cbn in H2. cbn.
        rewrite H2. rewrite T2. use idpath.
      + use proofirrelevance. use setproperty.
  Qed.

  Lemma abgr_isKernel_Criteria_ismonoidfun {X Y Z W : abgr_category} (f : X --> Y) (g : Y --> Z)
             (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _)
             (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)),
                  ∥∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D)∥)
             (isM : @isMonic abgr_category _ _ f) (h : abgr_Abelian ⟦W, Y⟧)
             (H' : h · g = ZeroArrow (to_Zero abgr_Abelian) W Z) :
    ismonoidfun (λ w' : (W : abgr), pr1 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' w'))).
  Proof.
    use make_ismonoidfun.
    - use make_isbinopfun. intros x y. use (abgr_monic_paths f isM).
      use (pathscomp0 _ (! binopfunisbinopfun (f : monoidfun _ _) _ _)).
      use (pathscomp0 (pr2 (iscontrpr1 (abgr_isKernel_iscontr
                                          f g ZA H isM h H' ((x * y)%multmonoid))))).
      use (pathscomp0 (binopfunisbinopfun (h : monoidfun _ _) _ _)).
      use pathsinv0.
      use two_arg_paths.
      + exact (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' (x%multmonoid)))).
      + exact (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' (y%multmonoid)))).
    - use (abgr_monic_paths f isM).
      use (pathscomp0 (pr2 (iscontrpr1 (abgr_isKernel_iscontr
                                          f g ZA H isM h H' (unel (W : abgr)))))).
      use (pathscomp0 (monoidfununel h)). exact (! monoidfununel f).
  Qed.

  Lemma abgr_isKernel_Criteria_comm {X Y Z W : abgr_category} (f : X --> Y) (g : Y --> Z)
             (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _)
             (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)),
                  ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥)
             (isM : @isMonic abgr_category _ _ f) (h : abgr_Abelian ⟦W, Y⟧)
             (H' : h · g = ZeroArrow (to_Zero abgr_Abelian) W Z) :
    monoidfuncomp (monoidfunconstr (abgr_isKernel_Criteria_ismonoidfun f g ZA H isM h H')) f = h.
  Proof.
    use monoidfun_paths. use funextfun. intros x.
    exact (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' (x%multmonoid)))).
  Qed.

  Definition make_abgr_isKernel_Criteria {X Y Z W : abgr_category} (f : X --> Y) (g : Y --> Z)
             (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _)
             (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)),
                  ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥)
             (isM : @isMonic abgr_category _ _ f) (h : abgr_Abelian ⟦W, Y⟧)
             (H' : h · g = ZeroArrow (to_Zero abgr_Abelian) W Z) :
    ∑ ψ : abgr_Abelian ⟦W, X⟧, ψ · f = h.
  Proof.
    use tpair.
    - use monoidfunconstr.
      + intros w'. exact (pr1 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' w'))).
      + exact (abgr_isKernel_Criteria_ismonoidfun f g ZA H isM h H').
    - exact (abgr_isKernel_Criteria_comm f g ZA H isM h H').
  Defined.

  Lemma abgr_isKernel_Criteria_uniqueness {X Y Z W : abgr_category} (f : X --> Y) (g : Y --> Z)
        (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _)
        (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)),
             ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥)
        (isM : @isMonic abgr_category _ _ f) (h : abgr_Abelian ⟦W, Y⟧)
        (H' : h · g = ZeroArrow (to_Zero abgr_Abelian) W Z)
        (t : ∑ ψ : abgr_Abelian ⟦W, X⟧, ψ · f = h) :
    t = make_abgr_isKernel_Criteria f g ZA H isM h H'.
  Proof.
    use total2_paths_f.
    - use monoidfun_paths. use funextfun. intros x.
      use (abgr_monic_paths f isM).
      use (pathscomp0 (toforallpaths _ _ _ (base_paths _ _ (pr2 t)) x)). use pathsinv0.
      exact (pr2 (iscontrpr1 (abgr_isKernel_iscontr f g ZA H isM h H' (x%multmonoid)))).
    - use proofirrelevance. use setproperty.
  Qed.

  Definition abgr_isKernel_Criteria {X Y Z : abgr_category} (f : X --> Y) (g : Y --> Z)
             (ZA : f · g = ZeroArrow (to_Zero abgr_Abelian) _ _)
             (H : ∏ (D : (∑ y : pr1 Y, pr1 g y = 1%multmonoid)),
                  ∥ ∑ (x : abgrtogr X), monoidfuntobinopfun _ _ f x = (pr1 D) ∥)
             (isM : @isMonic abgr_category _ _ f) : isKernel (to_Zero abgr_Abelian) f g ZA.
  Proof.
    use make_isKernel.
    - intros w h H'. use make_iscontr.
      + exact (make_abgr_isKernel_Criteria f g ZA H isM h H').
      + intros t. exact (abgr_isKernel_Criteria_uniqueness f g ZA H isM h H' t).
  Defined.

End abgr_corollaries.


Require Export XR_Rminus.
Require Export XR_Rplus_opp_r.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rminus_diag_eq : forall r1 r2, r1 = r2 -> r1 - r2 = R0.
Proof.
  intros x y heq.
  subst y.
  unfold Rminus.
  rewrite Rplus_opp_r.
  reflexivity.
Qed.


Require Export AggregationDefinitions.
Require Export NameAdjacency.
Require Export TreeAux.
Require Export TreeAggregationStatic.

Require Import ZpCommutativeFinGroup.

Module AggregationGroup <: CommutativeFinGroup.
Definition gT := Zp_commFinGroup 127.
End AggregationGroup.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e255m765_13limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(*|
#############################################################
How to use ``rewrite`` on a subexpression of the current goal
#############################################################

:Link: https://stackoverflow.com/q/13645979
|*)

(*|
Question
********

In Coq, is it somehow possible to apply a lemma or hypothesis to a
subexpression of the current goal? For example I would like to apply
the fact that plus is commutative in order to swap 3 and 4 in this
example.
|*)

Require Import Coq.Arith.Plus.

Inductive foobar : nat -> Prop :=
| foob : forall n : nat, foobar n.

Goal foob (3 + 4) = foob (4 + 3).
Proof.
  Fail apply plus_comm. (* .fails *) (* or maybe rewrite plus_comm *)

(*| gives: |*)

  Fail apply plus_comm. (* .unfold .messages *)

(*|
How can I tell Coq where exactly in this goal to ``apply plus_comm``?
|*)

(*|
Answer
******

In this particular case, ``rewrite`` will work if you define the
inductive type using a constructor parameter instead of an index:
|*)

Reset foobar. (* .none *)
Inductive foobar : Type :=
| foob (n : nat).

(*|
Since there is only one constructor for this type, my understanding
(`from this answer
<https://stackoverflow.com/questions/24600256/difference-between-type-parameters-and-indices>`__)
is that using an index does not provide any benefit but makes it
harder for Coq to pattern-match.

In general, either of the following techniques can achieve the effect
of a targeted ``rewrite``:

assert
======
|*)

Goal foob (3 + 4) = foob (4 + 3). (* .none *)
Proof. (* .none *)
  assert (H: 3 + 4 = 4 + 3). { rewrite <- plus_comm. reflexivity. }

(*|
rewrite
=======
|*)

  Restart. (* .none *)
  (* introduce a new sub-goal where you can prove that the replacement is OK *)
  replace (3 + 4) with (4 + 3).
  (* Coq orders the new goal last. I think it's clearer to tackle it first *)
  2: {
    (* do the rewrite *)
    rewrite <- plus_comm. reflexivity.
  }


Require Import Reals Rpow_facts.
Require Import Rfunction_def Rinterval Rextensionality.
Require Import Ranalysis_def Ranalysis_def_simpl Ranalysis_facts.
Require Import Ranalysis_continuity Ranalysis_derivability Ranalysis_monotonicity.
Require Import Lra MyRIneq.

Require Import Rsequence_facts Rsequence_sums_facts RFsequence RFsequence_facts.
Require Import Rpser_def Rpser_base_facts Rpser_radius_facts Rpser_sums Rpser_sums_facts.

Require Import Tactics.

Local Open Scope R_scope.

(** * Definition of the formal derivative *)

(** Derivability of partial sums *)

Definition Rpser_partial_sum_derive An n x := match n with
     | 0%nat => 0
     | S _      => Rseq_pps (An_deriv An) x (pred n)
end.

Lemma Rpser_partial_sum_derive_pt_lim: forall An n x,
  derivable_pt_lim (fun x => Rseq_pps An x n) x (Rpser_partial_sum_derive An n x).
Proof.
intros ; apply derivable_pt_lim_finite_sum.
Qed.

Lemma Rpser_partial_sum_derive_pt_lim_in: forall c r An n x,
  derivable_pt_lim_in (Rball c r) (fun x => Rseq_pps An x n) x
  (Rpser_partial_sum_derive An n x).
Proof.
intros ; apply derivable_pt_lim_derivable_pt_lim_in, Rpser_partial_sum_derive_pt_lim.
Qed.

Lemma derivable_pt_lim_in_weaksum_r: forall An r (rho : Cv_radius_weak An r)
  (rho' : Cv_radius_weak (An_deriv An) r) x (x_in: Rball 0 r x),
  derivable_pt_lim_in (Rball 0 r) (weaksum_r An r rho) x
  (weaksum_r (An_deriv An) r rho' x).
Proof.
intros An r rho rho' x x_in.
 assert (x_bd : Rabs x < r).
  unfold Rball in x_in ; rewrite Rminus_0_r in x_in ; assumption.
 assert (x_bd' : Rabs x < Rabs r).
  apply Rlt_le_trans with r ; [assumption | right ; symmetry ; apply Rabs_right].
  apply Rle_ge ; apply Rle_trans with (Rabs x) ; [apply Rabs_pos | left ; assumption].
assert (lb_lt_x : - middle (Rabs x) (Rabs r) < x).
  apply Rlt_le_trans with (- Rabs x).
  apply Ropp_gt_lt_contravar ; apply Rlt_gt ;
   apply middle_is_in_the_middle ; assumption.
   apply MyRIneq.Rabs_le.
 assert (x_lt_ub : x < middle (Rabs x) (Rabs r)).
  apply Rle_lt_trans with (Rabs x) ; [apply Rle_abs |
  apply middle_is_in_the_middle] ; assumption.
    pose (r' := middle (middle (Rabs x) (Rabs r)) (Rabs r)).
    assert (r'_bd1 := proj2 (middle_is_in_the_middle _ _ x_bd')).
    replace (middle (Rabs x) (Rabs r)) with (Rabs (middle (Rabs x) (Rabs r))) in r'_bd1 ; [| apply Rabs_right ;
    unfold r' ; apply Rle_ge ; unfold Rdiv ; apply Rle_mult_inv_pos ; [| lra] ;
    apply Rplus_le_le_0_compat ; apply Rabs_pos].
    assert (r'_bd := proj2 (middle_is_in_the_middle _ _ r'_bd1)).
    assert (Temp : middle (Rabs (middle (Rabs x) (Rabs r))) (Rabs r) = r').
     unfold r' ; unfold Rdiv ; apply Rmult_eq_compat_r ; apply Rplus_eq_compat_r ;
     apply Rabs_right ; apply Rle_ge ; apply Rle_mult_inv_pos ; [| lra] ;
     apply Rplus_le_le_0_compat ; apply Rabs_pos.
     rewrite Temp in r'_bd ; clear Temp ;
    fold r' in r'_bd ; replace r' with (Rabs r') in r'_bd ; [| apply Rabs_right ;
    unfold r' ; apply Rle_ge ; unfold Rdiv ; apply Rle_mult_inv_pos ; [| lra] ;
    apply Rplus_le_le_0_compat ; [| apply Rabs_pos] ; unfold Rdiv ;
    apply Rle_mult_inv_pos ; [| lra] ; apply Rplus_le_le_0_compat ; apply Rabs_pos].
    pose (r'' := middle (Rabs x) (Rabs r)).
    assert (r''_pos : 0 < r'').
    unfold r''. apply Rlt_mult_inv_pos ; [| lra] ;
     apply Rplus_le_lt_0_compat ; [| apply Rle_lt_trans with (Rabs x) ; [| assumption]] ;
     apply Rabs_pos.
    assert (r''_bd : r'' < r').
     unfold r'', r'.
     unfold Rdiv ; apply Rmult_lt_compat_r ; [lra |] ; apply Rplus_lt_compat_r.
     apply middle_is_in_the_middle ; assumption.
    pose (myR := mkposreal r'' r''_pos).
    assert (myR_ub : myR < r') by intuition.
    assert (Abel2' := Rpser_abel2 (An_deriv An) r'
         (Cv_radius_weak_derivable_compat An r rho r' r'_bd) myR myR_ub).
   assert (cv_interv : forall y : R, Boule 0 (mkposreal_lb_ub x (- middle (Rabs x) (Rabs r))
         (middle (Rabs x)(Rabs r)) lb_lt_x x_lt_ub) y ->
         {l : R | Un_cv (fun N : nat => SP
         (fun (n : nat) (x : R) => gt_pser (An_deriv An) x n) N y) l}).
    intros y y_bd.
    exists (weaksum_r (An_deriv An) r rho' y).
    assert (y_bd2 : Rabs y < r).
     unfold Boule, mkposreal_lb_ub in y_bd ; rewrite Rminus_0_r in y_bd.
     apply Rlt_trans with (middle (middle (Rabs x) (Rabs r)) (middle (Rabs x) (Rabs r))).
     rewrite (middle_unfold (middle _ _ )), <- Rminus_opp ; assumption.
     apply Rle_lt_trans with (middle (Rabs x) (Rabs r)).
     right ; unfold middle ; field.
     apply Rlt_le_trans with (Rabs r).
      apply middle_is_in_the_middle ; assumption.
      right ; apply Rabs_pos_eq ; left ; apply Rle_lt_trans with (Rabs x) ;
       [apply Rabs_pos |] ; assumption.
   intros alpha alpha_pos ; destruct (weaksum_r_sums (An_deriv An) r rho' y y_bd2
           alpha alpha_pos) as (N, HN) ; exists N ; intros n n_lb ;
           apply HN ; assumption.
   assert (CVN : CVN_r (fun (n : nat) (x : R) => gt_pser (An_deriv An) x n)
         (mkposreal_lb_ub x (- middle (Rabs x) (Rabs r)) (middle (Rabs x) (Rabs r))
         lb_lt_x x_lt_ub)).
    apply Rpser_abel2 with r'.
    apply Cv_radius_weak_derivable_compat with r ; assumption.
    unfold mkposreal_lb_ub.
    apply Rle_lt_trans with r'' ; [| assumption].
    right ; unfold r'' ; intuition.
     assert (Temp : (middle (Rabs x) (Rabs r) - - middle (Rabs x) (Rabs r)) / 2
           = middle (Rabs x) (Rabs r)) by field.
    intuition.
   assert (Main := CVN_CVU_interv (fun n x => gt_pser (An_deriv An) x n)
          (mkposreal_lb_ub x (- middle (Rabs x) (Rabs r)) (middle (Rabs x) (Rabs r))
          lb_lt_x x_lt_ub) cv_interv CVN).
   assert (Main2 : RFseq_cvu (Rpser_partial_sum_derive An) (weaksum_r (An_deriv An) r rho')
          (middle (- middle (Rabs x) (Rabs r)) (middle (Rabs x) (Rabs r)))
          (mkposreal_lb_ub x (- middle (Rabs x) (Rabs r)) (middle (Rabs x) (Rabs r))
          lb_lt_x x_lt_ub)).
    clear -Main x_bd x_bd'; intros eps eps_pos ; destruct (Main eps eps_pos) as (N, HN) ;
    exists (S N) ; intros n y n_lb y_bd.
    assert (y_bd2 : Boule 0
         (mkposreal_lb_ub x (- middle (Rabs x) (Rabs r)) (middle (Rabs x) (Rabs r))
         lb_lt_x x_lt_ub) y).
     unfold Boule in * ; rewrite middle_R0 in y_bd ; assumption.
    assert(n_lb2 : (N <= pred n)%nat) by intuition.
    assert (Temp := HN (pred n) y n_lb2 y_bd2).
    assert (T1 := SFL_interv_right (fun (n : nat) (x : R) => gt_pser (An_deriv An) x n)
            (mkposreal_lb_ub x (- middle (Rabs x) (Rabs r))
            (middle (Rabs x) (Rabs r)) lb_lt_x x_lt_ub) cv_interv y y_bd2).
    assert (y_bd3 : Rabs y < r).
     unfold Boule, mkposreal_lb_ub in y_bd2 ; rewrite Rminus_0_r in y_bd2.
     apply Rlt_trans with ((middle (Rabs x) (Rabs r) - - middle (Rabs x) (Rabs r)) / 2).
     assumption.
     apply Rle_lt_trans with (middle (Rabs x) (Rabs r)).
     right ; field.
     apply Rlt_le_trans with (Rabs r).
      apply middle_is_in_the_middle ; assumption.
      right ; apply Rabs_pos_eq ; apply Rle_trans with (Rabs x) ;
       [apply Rabs_pos | left ; assumption].
    assert (T2 := weaksum_r_sums (An_deriv An) r rho' y y_bd3) ;
     unfold Rpser, Rseq_pps in T2.
    rewrite Rseq_cv_eq_compat with (Vn := fun N => SP (fun (n : nat) (x : R) =>
     gt_pser (An_deriv An) x n) N y) in T2 ; [| intro ; reflexivity].
    assert (Lim_eq := UL_sequence _ _ _ T1 T2).
    rewrite <- Lim_eq.
    unfold SP in Temp ; unfold Rpser_partial_sum_derive.
    assert (Hrew : n = S (pred n)).
     apply S_pred with N ; intuition.
    rewrite Hrew.
    unfold R_dist ; rewrite Rabs_minus_sym ; apply Temp.
  assert (Dfn_eq_fn' : forall (x0 : R) (n : nat), - middle (Rabs x) (Rabs r) < x0 ->
          x0 < middle (Rabs x) (Rabs r) -> derivable_pt_lim
          ((fun (n0 : nat) (x : R) => sum_f_R0 (gt_pser An x) n0) n) x0
          (Rpser_partial_sum_derive An n x0)).
   intros y n y_lb y_ub.
   apply derivable_pt_lim_finite_sum.
  assert (fn_cv_f : RFseq_cv_interv (fun (n : nat) (x : R) => sum_f_R0 (gt_pser An x) n)
          (weaksum_r An r rho) (- middle (Rabs x) (Rabs r)) (middle (Rabs x) (Rabs r))).
   intros y lb_lt_y y_lt_ub eps eps_pos.
    assert(y_bd1 : - Rabs r < y).
     apply Rlt_trans with (- middle (Rabs x) (Rabs r)) ; [| assumption].
     apply Ropp_lt_contravar ; apply middle_is_in_the_middle ; assumption.
    assert(y_bd2 : y < Rabs r).
     apply Rlt_trans with (middle (Rabs x) (Rabs r)) ; [assumption |] ;
      apply middle_is_in_the_middle ; assumption.
   assert (y_bd : Rabs y < Rabs r).
    apply Rabs_def1 ; assumption.
    replace (Rabs r) with r in y_bd ; [| symmetry ; apply Rabs_right ; apply Rle_ge ;
    apply Rle_trans with (Rabs x) ; [apply Rabs_pos | left ; assumption]].
   destruct (weaksum_r_sums An r rho y y_bd eps eps_pos) as (N, HN) ; exists N ;
   intros n n_lb ; apply HN ; assumption.
    apply derivable_pt_lim_derivable_pt_lim_in.
    apply (RFseq_cvu_derivable (fun n x => sum_f_R0 (gt_pser An x) n)
         (Rpser_partial_sum_derive An)
         (weaksum_r An r rho) (weaksum_r (An_deriv An) r rho') x
         (- middle (Rabs x) (Rabs r)) (middle (Rabs x) (Rabs r))
         lb_lt_x x_lt_ub Dfn_eq_fn' fn_cv_f Main2).
   intros y y_lb y_ub.
   apply CVU_continuity with (fn:=Rpser_partial_sum_derive An) (x:=0)
    (r:=(mkposreal_lb_ub x (- middle (Rabs x) (Rabs r))
             (middle (Rabs x) (Rabs r)) lb_lt_x x_lt_ub)).
             intros eps eps_pos ; destruct (Main2 eps eps_pos) as (N, HN) ; exists N ;
             intros n z n_lb z_bd.
             rewrite Rabs_minus_sym ; apply HN.
   assumption.
   replace (middle (- middle (Rabs x) (Rabs r)) (middle (Rabs x) (Rabs r))) with 0
    by (symmetry ; apply middle_R0).
   assumption.
   intros.
   destruct n.
   unfold Rpser_partial_sum_derive.
   apply continuity_const ; unfold constant ; intuition.
   unfold Rpser_partial_sum_derive ; apply continuity_finite_sum.
   unfold Boule ; rewrite Rminus_0_r.
   unfold mkposreal_lb_ub.
   replace ((middle (Rabs x) (Rabs r) - - middle (Rabs x) (Rabs r)) / 2) with
   (middle (Rabs x) (Rabs r)) by field.
   apply Rabs_def1 ; intuition.
Qed.

(* TODO: move this! *)

Lemma included_Rball_radiuses : forall c r r', r' <= r ->
  included (Rball c r') (Rball c r).
Proof.
intros c r r' Hr'r x x_in ; eapply Rlt_le_trans ; eassumption.
Qed.

(* TODO: and move that! *)
Lemma derivable_pt_lim_Rball_change :
  forall c r c' r' f x l, Rball c' r' x ->
  derivable_pt_lim_in (Rball c' r') f x l ->
  derivable_pt_lim_in (Rball c r) f x l.
Proof.
intros ; apply derivable_pt_lim_derivable_pt_lim_in ;
 eapply derivable_pt_lim_Rball_pt_lim ; eassumption.
Qed.

Lemma derivable_pt_lim_in_weaksum_r_strong:
  forall An r r' (rho : Cv_radius_weak An r) (rho' : Cv_radius_weak (An_deriv An) r') x
  (x_in: Rball 0 r x) (x_in': Rball 0 r' x),
  derivable_pt_lim_in (Rball 0 r) (weaksum_r An r rho) x
  (weaksum_r (An_deriv An) r' rho' x).
Proof.
intros An r r' rho rho' x x_in x_in'.
 assert (r_pos : 0 < r) by (eapply Rball_radius_pos ; eassumption) ;
 assert (r'_pos : 0 < r') by (eapply Rball_radius_pos ; eassumption) ;
 assert (min_pos: 0 <= Rmin r r') by (apply MyRIneq.Rmin_pos ; left ; assumption).
 assert (x_in_min: Rball 0 (Rmin r r') x).
  unfold Rmin, Rball ; destruct (Rle_dec r r') ; assumption.
 assert (rho'': Cv_radius_weak An (Rmin r r')).
  apply Cv_radius_weak_le_compat with r.
   rewrite Rabs_right ; [rewrite Rabs_right ; [apply Rmin_l | left] |
   apply Rle_ge ] ; assumption.
  assumption.
 assert (rho2: Cv_radius_weak (An_deriv An) (Rmin r r')).
  apply Cv_radius_weak_le_compat with r'.
   rewrite Rabs_right ; [rewrite Rabs_right ; [apply Rmin_r | left] |
   apply Rle_ge ] ; assumption.
  assumption.
 assert (Heq: weaksum_r (An_deriv An) r' rho' x =
  weaksum_r (An_deriv An) (Rmin r r') rho2 x).
  apply weaksum_r_unique_strong ; [| apply Rmin_glb_lt] ;
   erewrite <- Rball_0_simpl ; eassumption.
  rewrite Heq ; eapply derivable_pt_lim_Rball_change ; [eassumption |].
 apply derivable_pt_lim_in_ext_strong with (weaksum_r An (Rmin r r') rho'').
  assumption.
  intros y y_in ; apply weaksum_r_unique_strong.
   rewrite <- Rball_0_simpl ; eassumption.
   rewrite <- Rball_0_simpl ; eapply Rball_included ;
   [eapply Rmin_l |] ; eassumption.
  apply derivable_pt_lim_in_weaksum_r ; assumption.
Qed.

Lemma derivable_pt_in_weaksum_r: forall An r
  (rho : Cv_radius_weak An r) x (x_in: Rball 0 r x),
  derivable_pt_in (Rball 0 r) (weaksum_r An r rho) x.
Proof.
intros An r rho x x_in ;
 assert (r_pos : 0 <= r) by (left ; eapply Rball_radius_pos ; eassumption) ;
 pose (r' := middle (Rabs x) r) ;
 assert (r'_pos: 0 <= r').
  apply middle_le_le_pos ; [apply Rabs_pos | assumption].
 assert (rho': Cv_radius_weak (An_deriv An) r').
  eapply Cv_radius_weak_derivable_compat ; [eassumption|].
   rewrite Rabs_right ; [rewrite (Rabs_right r) |].
   apply middle_is_in_the_middle ; erewrite <- Rball_0_simpl ; eassumption.
  apply Rle_ge ; assumption.
  apply Rle_ge ; assumption.
 exists (weaksum_r (An_deriv An) r' rho' x).
 apply derivable_pt_lim_in_weaksum_r_strong.
  assumption.
  apply Rball_0_simpl, middle_is_in_the_middle ;
  erewrite <- Rball_0_simpl ; eassumption.
Qed.

Lemma derivable_Rball_weaksum_r:
  forall An r (rho : Cv_radius_weak An r),
  derivable_Rball 0 r (weaksum_r An r rho).
Proof.
intros An r rho x x_in ; apply derivable_pt_in_weaksum_r ; assumption.
Qed.

(** Sum of the formal derivative *)

Definition weaksum_r_derive An r (rho : Cv_radius_weak An r) (x : R) : R.
Proof.
destruct (Rlt_le_dec (Rabs x) r) as [x_bd | x_bd].
apply (weaksum_r (An_deriv An) (middle (Rabs x) r)).
apply Cv_radius_weak_derivable_compat with r.
 assumption.
 rewrite (Rabs_pos_eq r).
 apply Rabs_middle_is_in_the_middle ; [apply Rabs_pos | assumption].
 left ; apply Rle_lt_trans with (Rabs x) ; [apply Rabs_pos | assumption].
 exact x.
exact 0.
Defined.

Definition sum_r_derive An r (rho : finite_cv_radius An r) : R -> R.
Proof.
eapply sum_r, (proj1 (finite_cv_radius_derivable_compat _ _)), rho.
Defined.

Definition sum_derive An (rho : infinite_cv_radius An) : R -> R.
Proof.
eapply sum, (proj1 (infinite_cv_radius_derivable_compat _)), rho.
Defined.

(** Proof that it is really the sum *)

Lemma weaksum_r_derive_sums : forall An r (Pr : Cv_radius_weak An r) x,
  Rabs x < r -> Rpser (An_deriv An) x (weaksum_r_derive An r Pr x).
Proof.
intros An r Pr x x_bd ; unfold weaksum_r_derive ;
destruct (Rlt_le_dec (Rabs x) r) as [H | Hf].
 apply weaksum_r_sums ; apply middle_is_in_the_middle ; assumption.
 exfalso ; lra.
Qed.

Lemma sum_r_derive_sums : forall An r (Pr : finite_cv_radius An r) x,
  Rabs x < r -> Rpser (An_deriv An) x (sum_r_derive An r Pr x).
Proof.
intros ; apply sum_r_sums ; assumption.
Qed.

Lemma sum_derive_sums : forall An (Pr : infinite_cv_radius An) x,
  Rpser (An_deriv An) x (sum_derive An Pr x).
Proof.
intros ; apply sum_sums.
Qed.

(** Proof that this derivative is unique *)

Lemma weaksum_r_derive_unique : forall An r (Pr1 Pr2 : Cv_radius_weak An r) z,
  Rabs z < r -> weaksum_r_derive An r Pr1 z = weaksum_r_derive An r Pr2 z.
Proof.
intros An r Pr1 Pr2 z z_bd ;
 assert (T1 := weaksum_r_derive_sums _ _ Pr1 _ z_bd) ;
 assert (T2 := weaksum_r_derive_sums _ _ Pr2 _ z_bd).
 eapply Rpser_unique ; eassumption.
Qed.

Lemma sum_r_derive_unique : forall An r(Pr1 Pr2 : finite_cv_radius An r) z,
  Rabs z < r -> sum_r_derive An r Pr1 z = sum_r_derive An r Pr2 z .
Proof.
intros An r Pr1 Pr2 z z_bd ;
 assert (T1 := sum_r_derive_sums _ _ Pr1 _ z_bd) ;
 assert (T2 := sum_r_derive_sums _ _ Pr2 _ z_bd).
 eapply Rpser_unique ; eassumption.
Qed.

Lemma sum_derive_unique : forall (An : nat -> R) (Pr1 Pr2 : infinite_cv_radius An) (z : R),
  sum_derive An Pr1 z = sum_derive An Pr2 z .
Proof.
intros An Pr1 Pr2 z ;
 assert (T1 := sum_derive_sums _ Pr1 z) ;
 assert (T2 := sum_derive_sums _ Pr2 z).
 eapply Rpser_unique ; eassumption.
Qed.

(** * The formal derivative is, inside the cv-disk, the actual derivative. *)

(** Weaksum_r's case. *)

Lemma derivable_pt_lim_weaksum_r : forall An r (Pr : Cv_radius_weak An r) x,
  Rabs x < r -> derivable_pt_lim (weaksum_r An r Pr) x (weaksum_r_derive An r Pr x).
Proof.
intros An r rho x x_in ; unfold weaksum_r_derive ;
  assert (r_pos: 0 <= r) by (left ; apply Rle_lt_trans with (Rabs x) ;
   [apply Rabs_pos | assumption]) ; destruct (Rlt_le_dec (Rabs x) r) as [x_bd | x_nbd].
  apply derivable_pt_lim_Rball_pt_lim with 0 r.
   apply Rball_0_simpl ; assumption.
  assert (r'_pos: 0 <= middle (Rabs x) r) by (apply middle_le_le_pos ;
   [apply Rabs_pos | assumption]).
  apply derivable_pt_lim_in_weaksum_r_strong ; rewrite Rball_0_simpl ;
    [| eapply middle_is_in_the_middle] ; assumption.
  exfalso ; apply Rlt_irrefl with (Rabs x), Rlt_le_trans with r ; assumption.
Qed.

(** This implies the derivability & continuity of the weaksum_rs. *)

Lemma derivable_pt_weaksum_r : forall An (r:R) (Pr : Cv_radius_weak An r) x,
  Rabs x < r -> derivable_pt (weaksum_r An r Pr) x.
Proof.
intros An r rho x x_bd ; eexists ; eapply derivable_pt_lim_weaksum_r ; assumption.
Qed.

Lemma derive_Rball_weaksum_r: forall An r (rho : Cv_radius_weak An r) pr,
  (derive_Rball 0 r (weaksum_r An r rho) pr ==
  weaksum_r_derive An r rho)%F.
Proof.
intros An r rho pr x ;
 unfold derive_Rball, weaksum_r_derive.
 destruct (Rlt_le_dec (Rabs x) r) as [x_bd | x_nbd] ;
 destruct (in_Rball_dec 0 r x) as [x_in | x_nin].
  destruct (pr x x_in) as [l Hl] ; simpl.
 assert (r_pos : 0 <= r) by (left ; eapply Rball_radius_pos ; eassumption) ;
 eapply derivable_pt_lim_Rball_uniqueness ; try eassumption.
 assert (mid_pos: 0 <= middle (Rabs x) r) by (apply middle_le_le_pos ;
  [apply Rabs_pos | assumption]).
 apply derivable_pt_lim_in_weaksum_r_strong.
  assumption.
  apply Rball_0_simpl, middle_is_in_the_middle ; assumption.
 exfalso ; apply x_nin, Rball_0_simpl ; assumption.
 exfalso ; apply (Rlt_irrefl (Rabs x)) ; apply Rlt_le_trans with r.
  erewrite <- Rball_0_simpl ; eassumption.
  assumption.
 reflexivity.
Qed.

(* TODO: Lemma derive_pt_weaksum_r (see Lemma derive_pt_sum) *)

Lemma continuity_pt_weaksum_r : forall An r (Pr : Cv_radius_weak An r) x,
  Rabs x < r -> continuity_pt (weaksum_r An r Pr) x.
Proof.
intros An r rho x x_bd ; apply derivable_continuous_pt ; apply derivable_pt_weaksum_r ;
 assumption.
Qed.

(** Sum_r's case. *)

Lemma derivable_pt_lim_sum_r : forall An r (Pr : finite_cv_radius An r) z,
      Rabs z < r -> derivable_pt_lim (sum_r An r Pr) z (sum_r_derive An r Pr z).
Proof.
intros An r rho z z_bd eps eps_pos.
assert (z_bd2 : Rabs z < middle (Rabs z) r) by (apply middle_is_in_the_middle ;
 assumption).
assert (pr : Cv_radius_weak An (middle (Rabs z) r)).
 apply (proj1 rho) ; split ; [left ; apply middle_le_lt_pos_lt |
 apply middle_is_in_the_middle] ; [| apply Rle_lt_trans with (Rabs z) |] ;
 (apply Rabs_pos || assumption).
 destruct (derivable_pt_lim_weaksum_r _ _ pr z z_bd2 eps eps_pos)
 as [d1 Hd1].
 pose (d2 := middle (Rabs z) r - Rabs z).
 assert (d2_pos : 0 < d2).
  unfold d2 ; apply Rlt_Rminus ; apply middle_is_in_the_middle ; assumption.
 pose (d := Rmin d1 d2).
 assert (d_pos : 0 < d).
  unfold d ; apply Rmin_pos_lt ; [apply d1 | assumption].
 pose (delta := mkposreal d d_pos) ; exists delta ; intros h h_neq h_bd.
 assert (Rabs (z + h) < middle (Rabs z) r).
  apply Rle_lt_trans with (Rabs z + Rabs h) ; [apply Rabs_triang |].
  apply Rlt_le_trans with (Rabs z + delta).
  apply Rplus_lt_compat_l ; assumption.
  apply Rle_trans with (Rabs z + (middle (Rabs z) r - Rabs z)).
  apply Rplus_le_compat_l ; unfold delta ; apply Rmin_r.
  right ; ring.
 assert (Rabs (z + h) < r).
  apply Rlt_trans with (middle (Rabs z) r) ;
  [| apply middle_is_in_the_middle] ; assumption.
 specialize (Hd1 h h_neq).
 repeat erewrite sum_r_unfold.
 eapply Rle_lt_trans ; [| eapply Hd1].
 right ; apply Rabs_eq_compat ; apply Rminus_eq_compat.
 reflexivity.
 unfold weaksum_r_derive, sum_r_derive ;
 destruct (Rlt_le_dec (Rabs z) (middle (Rabs z) r)) as [z_bd' | Hf].
 apply sum_r_unfold ; [| do 2 apply middle_is_in_the_middle] ; assumption.
 assert (T := proj1 (middle_is_in_the_middle _ _ z_bd)) ; clear - Hf T ;
 exfalso ; lra.
 apply Rlt_le_trans with delta ; [assumption | unfold delta ; apply Rmin_l].
 assumption.
 assumption.
 assumption.
 assumption.
Qed.

Lemma derivable_pt_lim_in_sum_r: forall An r (rho : finite_cv_radius An r) x,
  Rball 0 r x ->
  derivable_pt_lim_in (Rball 0 r) (sum_r An r rho) x (sum_r_derive An r rho x).
Proof.
intros ; apply derivable_pt_lim_derivable_pt_lim_in, derivable_pt_lim_sum_r ;
 erewrite <- Rball_0_simpl ; eassumption.
Qed.

(** This implies the derivability & continuity of the sum_rs. *)

Lemma derivable_Rball_sum_r: forall An r (rho: finite_cv_radius An r),
  derivable_Rball 0 r (sum_r An r rho).
Proof.
intros An r rho x x_in ; eexists ;
  apply derivable_pt_lim_in_sum_r ; assumption.
Qed.

Lemma derive_Rball_sum_r: forall An r (rho: finite_cv_radius An r)
  (pr: derivable_Rball 0 r (sum_r An r rho)),
  Rball_eq 0 r (derive_Rball 0 r (sum_r An r rho) pr)
  (sum_r_derive An r rho).
Proof.
intros An r rho pr x x_in ;
 eapply derivable_pt_lim_in_derive_Rball, derivable_pt_lim_in_sum_r ;
 eassumption.
Qed.

Lemma derivable_pt_sum_r : forall An r (Pr : finite_cv_radius An r) x,
  Rabs x < r -> derivable_pt (sum_r An r Pr) x.
Proof.
intros An r rho x x_bd ; assert (r_pos: 0 <= r) by (transitivity (Rabs x) ;
 [apply Rabs_pos | left ; assumption]) ; eapply derivable_Rball_derivable_pt ;
 [eapply derivable_Rball_sum_r | eapply Rball_0_simpl ;
 eassumption].
Qed.

(* TODO: Lemma derive_pt_sum_r (see Lemma derive_pt_sum) *)

Lemma continuity_pt_sum_r : forall (An:nat->R) (r:R) (Pr : finite_cv_radius An r) x,
      Rabs x < r -> continuity_pt (sum_r An r Pr) x.
Proof.
intros An r rho x x_bd ; apply derivable_continuous_pt ; apply derivable_pt_sum_r ;
 assumption.
Qed.

(** Sum's case. *)

Lemma derivable_pt_lim_sum : forall An (Pr : infinite_cv_radius An), forall z,
      derivable_pt_lim (sum An Pr) z (sum_derive An Pr z).
Proof.
intros An rho z eps eps_pos.
 assert (z_bd : Rabs z < Rabs z + 1) by lra.
 destruct (derivable_pt_lim_weaksum_r _ _ (rho _) _ z_bd _ eps_pos) as [d Hd].
 pose (d' := Rmin d (1 / 2)).
 assert (d'_pos : 0 < d').
  unfold Rmin ; apply Rmin_pos_lt ; [apply d | lra].
 pose (delta := mkposreal d' d'_pos) ; exists delta ; intros h h_neq h_bd ;
 specialize (Hd h h_neq); eapply Rle_lt_trans ; [| eapply Hd].
 right ; apply Rabs_eq_compat ; apply Rminus_eq_compat.
 unfold Rdiv ; apply Rmult_eq_compat_r ; unfold sum ; apply Rminus_eq_compat ;
 apply weaksum_r_unique_strong ; auto.
 apply Rle_lt_trans with (Rabs (z + h) + 0) ; [right ; ring | lra].
 apply Rle_lt_trans with (Rabs z + Rabs h) ; [apply Rabs_triang |] ;
 apply Rplus_lt_compat_l ; apply Rlt_trans with (1/2) ; [apply Rlt_le_trans with
 delta |] ; [| unfold delta ; apply Rmin_r |] ; lra.
 unfold sum_derive, sum, weaksum_r_derive ;
 destruct (Rlt_le_dec (Rabs z) (Rabs z + 1)) as [H | Hf].
 apply weaksum_r_unique_strong ; [| apply middle_is_in_the_middle] ; assumption.
 exfalso ; apply (Rlt_irrefl (Rabs z)) ; apply Rlt_le_trans with (Rabs z + 1) ;
 lra.
 apply Rlt_le_trans with delta ; [assumption | unfold delta ; apply Rmin_l].
Qed.

(** This implies the derivability & continuity of the sums. *)

Lemma derivable_pt_sum : forall (An : Rseq) (Pr : infinite_cv_radius An) x,
      derivable_pt (sum An Pr) x.
Proof.
intros An rho x.
 exists (sum_derive An rho x) ; apply derivable_pt_lim_sum ; assumption.
Qed.

Lemma derive_pt_sum : forall (An : Rseq)
  (rAn : infinite_cv_radius An) (rdAn : infinite_cv_radius (An_deriv An)) x
  (dAn : derivable_pt (sum An rAn) x),
  derive_pt (sum An rAn) x dAn = sum (An_deriv An) rdAn x.
Proof.
intros ; rewrite derive_pt_eq.
 replace (sum (An_deriv An) rdAn x) with (sum_derive An rAn x).
 apply derivable_pt_lim_sum.
 apply sum_unique.
Qed.

Lemma continuity_pt_sum : forall (An:nat->R) (Pr : infinite_cv_radius An) x,
  continuity_pt (sum An Pr) x.
Proof.
intros An rho x ; apply derivable_continuous_pt ; apply derivable_pt_sum.
Qed.

(** * Derivability / continuity of the sum when the cv disk as an infinite radius *)

Lemma derivable_sum : forall (An:nat->R) (Pr : infinite_cv_radius An),
  derivable (sum An Pr).
Proof.
intros An rho x ; apply derivable_pt_sum.
Qed.

Lemma continuity_sum : forall (An:nat->R) (Pr : infinite_cv_radius An),
  continuity (sum An Pr).
Proof.
intros An rho x ; apply derivable_continuous ; apply derivable_sum.
Qed.


Require Import String List.
Import ListNotations.

(*
  Syntax

  exp corresponds to exp from small-step, without internal-only forms ([Code],
  [Reflect], [LamC], [LetC]). Instead of explicit names, we use de Bruijn levels
  [Var n], hence [Lam e] instead of [Lam f x e].
*)
Inductive exp : Type :=
  | Lit (n : nat)
  | Var (n : nat)
  | Lam (e : exp)
  | App (e1 e2 : exp)
  | Cons (a b : exp)
  | Let (e1 e2 : exp)
  | If (c a b : exp)
  | IsNum (e : exp)
  | IsCons (e : exp)
  | Car (e : exp)
  | Cdr (e : exp)
  | Plus (a b : exp)
  | Minus (a b : exp)
  | Times (a b : exp)
  | Eq (a b : exp)
  | Lift (e : exp)
  | Run (b e : exp).

Inductive val : Type :=
  | Cst (n : nat)
  | Tup (a b : val)
  | Clo (ρ : list val) (e : exp)
  | Code (e : exp).

Definition env : Type := list val.

(* Definition reflect (s : exp) := *)

Reserved Notation "s -->* v" (at level 40).

Inductive evalms : env * exp -> val -> Prop :=
  | M_Lit ρ n :            (ρ, Lit n)                  -->* Cst n
  | M_Var ρ n v :          nth_error ρ n = Some v ->
                           (ρ, Var n)                  -->* v
  | M_Cons ρ e1 e2 v1 v2 : (ρ, e1)                     -->* v1 ->
                           (ρ, e2)                     -->* v2 ->
                           (ρ, Cons e1 e2)             -->* Tup v1 v2
  | M_Lam ρ e :            (ρ, Lam e)                  -->* Clo ρ e
  | M_Let ρ e1 e2 v1 v2 :  (ρ, e1)                     -->* v1 ->
                           (ρ ++ [v1], e2)             -->* v2 ->
                           (ρ, Let e1 e2)              -->* v2
  | M_App_Clo ρ e1 e2 ρ3 e3 v2 v3 :
                           (ρ, e1)                     -->* Clo ρ3 e3 ->
                           (ρ, e2)                     -->* v2 ->
                           (ρ3 ++ [Clo ρ3 e3; v2], e3) -->* v3 ->
                           (ρ, App e1 e2)              -->* v3
  (* | M_App_Code ρ e1 e2 s1 s2 :
                           (ρ, e1)                     -->* Code s1 ->
                           (ρ, e2)                     -->* Code s2 ->
                           (ρ, App e1 e2)              -->* reflectc (App s1 s2) *)
  (* ... *)

  where "s -->* v" := (evalms s v).


(* Avoiding some occur-check *)

(* 1. Original example *)

Inductive eqT {A} (x : A) : A -> Type :=
  reflT : eqT x x.
Definition Bi_inv (A B : Type) (f : (A -> B)) :=
  sigT (fun (g : B -> A) =>
          sigT (fun (h : B -> A) =>
                  sigT (fun (α : forall b : B, eqT (f (g b)) b) =>
                          forall a : A, eqT (h (f a)) a))).
Definition TEquiv (A B : Type) := sigT (fun (f : A -> B) => Bi_inv _ _ f).

Axiom UA : forall (A B : Type), TEquiv (TEquiv A B) (eqT A B).
Definition idtoeqv {A B} (e : eqT A B) : TEquiv A B :=
  sigT_rect (fun _ => TEquiv A B)
            (fun (f : TEquiv A B -> eqT A B) H =>
               sigT_rect _ (* (fun _ => TEquiv A B) *)
                         (fun g _ => g e)
                         H)
            (UA A B).

(* 2. Alternative example by Guillaume *)

Inductive foo (A : Prop) : Prop := Foo : foo A.
Axiom bar : forall (A : Prop) (P : foo A -> Prop), (A -> P (Foo A)) -> Prop.

(* This used to fail with a Not_found, we fail more graciously but a
   heuristic could be implemented, e.g. in some smart occur-check
   function, to find a solution of then form ?P := fun _ => ?P' *)

Fail Check (fun e : ?[T] => bar ?[A] ?[P] (fun g : ?[A'] => g e)).

(* This works and tells which solution we could have inferred *)

Check (fun e : ?[T] => bar ?[A] (fun _ => ?[P]) (fun g : ?[A'] => g e)).

(* For the record, here is the trace in the failing example:

In (fun e : ?T => bar ?[A] ?[P] (fun g : ?A' => g e)), we have the existential variables

e:?T |- ?A : Prop
e:?T |- ?P : foo ?A -> Prop
e:?T |- ?A' : Type

with constraints

?A' == ?A
?A' == ?T -> ?P (Foo ?A)

To type (g e), unification first defines

?A := forall x:?B, ?P'{e:=e,x:=x}
with ?T <= ?B
and ?P'@{e:=e,x:=e} <= ?P@{e:=e} (Foo (forall x:?B, ?P'{e:=e,x:=x}))

Then, since ?P'@{e:=e,x:=e} may use "e" in two different ways, it is
not a pattern and we define a new

e:?T x:?B|- ?P'' : foo (?B' -> ?P''') -> Prop

for some ?B' and ?P''', together with

?P'@{e,x} := ?P''{e:=e,x:=e} (Foo (?B -> ?P')
?P@{e} := ?P''{e:=e,x:=e}

Moreover, ?B' and ?P''' have to satisfy

?B'@{e:=e,x:=e} == ?B@{e:=e}
?P'''@{e:=e,x:=e} == ?P'@{e:=e,x:=x}

and this leads to define ?P' which was the initial existential
variable to define.
*)


Require
  MathClasses.theory.fields MathClasses.implementations.stdlib_rationals MathClasses.theory.int_pow.
Require Import
  Coq.QArith.QArith Coq.Numbers.Rational.SpecViaQ.QSig
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders
  MathClasses.interfaces.integers MathClasses.interfaces.rationals MathClasses.interfaces.additional_operations
  MathClasses.theory.rings MathClasses.theory.rationals.

Module QType_Rationals (Import anyQ: QType).

Module Import props := QProperties anyQ.

Instance QType_equiv: Equiv t := eq.
Instance QType_plus: Plus t := add.
Instance QType_0: Zero t := zero.
Instance QType_1: One t := one.
Instance QType_mult: Mult t := mul.
Instance QType_negate: Negate t := opp.
Instance QType_dec_recip: DecRecip t := inv.

Instance: Setoid t := {}.

Instance: ∀ x y: t, Decision (x = y) := λ x y,
  (match anyQ.eq_bool x y as p return p ≡ Qeq_bool (to_Q x) (to_Q y) → Decision (x = y) with
  | true => λ e, left _
  | false => λ e, right _
  end) (anyQ.spec_eq_bool x y).
    (* hm, do we really need the anyQ.spec_eq_bool in here? *)

Proof with intuition. apply Qeq_bool_iff... apply Qeq_bool_neq... Qed.

  (* We could get the above for free from the fact that anyQ.eq is just projected Qeq,
   but that mean that any comparison would involve two conversion to Q, which is
   a premature pessimization. *)

Ltac unfold_equiv := unfold equiv, QType_equiv, eq.

Add Ring Q : Qsrt.
Lemma anyQ_field_theory: field_theory zero one add mul sub opp anyQ.div inv eq.
  (* No idea why this is missing in QSig. *)
Proof.
 constructor.
    constructor; intros; qify; ring.
   exact neq_1_0.
  exact div_mul_inv.
 exact mul_inv_diag_l.
Qed.

Instance: DecField t.
Proof.
  refine (dec_fields.from_stdlib_field_theory anyQ_field_theory _).
  unfold eq. now rewrite spec_inv, spec_0.
Qed.

(* Type-classified facts about to_Q/of_Q: *)
Instance inject_QType_Q: Cast t Q := to_Q.

Instance: Setoid_Morphism to_Q.
Proof. constructor; try apply _. intros x y. auto. Qed.

Instance: SemiRing_Morphism to_Q.
Proof. repeat (constructor; try apply _); intros; qify; reflexivity. Qed.

Instance inject_Q_QType: Cast Q t := of_Q.
Instance: Inverse to_Q := of_Q.

Instance: Surjective to_Q.
Proof. constructor. intros x y E. rewrite <- E. apply spec_of_Q. apply _. Qed.

Instance: Injective to_Q.
Proof. constructor. auto. apply _. Qed.

Instance: Bijective to_Q := {}.

Instance: Inverse of_Q := to_Q.

Instance: Bijective of_Q.
Proof. apply jections.flip_bijection. Qed.

Instance: SemiRing_Morphism of_Q.
Proof. change (SemiRing_Morphism (to_Q⁻¹)). split; apply _. Qed.

Instance: RationalsToFrac t := iso_to_frac of_Q.
Instance: Rationals t := iso_is_rationals of_Q.

(* Order *)
Instance QType_le: Le t := le.
Instance QType_lt: Lt t := lt.

Instance: Proper ((=) ==> (=) ==> iff) QType_le.
Proof.
  intros ? ? E1 ? ? E2. unfold QType_le, le, equiv, QType_equiv, eq in *.
  now rewrite E1, E2.
Qed.

Instance: SemiRingOrder QType_le.
Proof. now apply (rings.projected_ring_order to_Q). Qed.

Instance: OrderEmbedding to_Q.
Proof. now repeat (split; try apply _). Qed.

Instance: TotalRelation QType_le.
Proof. now apply (maps.projected_total_order to_Q). Qed.

Instance: FullPseudoSemiRingOrder QType_le QType_lt.
Proof.
  rapply semirings.dec_full_pseudo_srorder.
  intros x y.
  change (to_Q x < to_Q y ↔ x ≤ y ∧ x ≠ y).
  now rewrite orders.lt_iff_le_ne.
Qed.

(* Efficient comparison *)
Program Instance: ∀ x y: t, Decision (x ≤ y) := λ x y,
  match compare x y with
  | Gt => right _
  | _ => left _
  end.
Next Obligation.
  rewrite spec_compare in *.
  destruct (Qcompare_spec (to_Q x) (to_Q y)); try discriminate.
  now apply orders.lt_not_le_flip.
Qed.

Next Obligation.
  rewrite spec_compare in *.
  destruct (Qcompare_spec (to_Q x) (to_Q y)); try discriminate; try intuition.
   now apply Zeq_le.
  now apply orders.lt_le.
Qed.

(* Efficient [int_pow] *)
Program Instance QType_Zpow: Pow t Z := power.

Instance: IntPowSpec t Z QType_Zpow.
Proof.
  split; try apply _; unfold_equiv.
    intros. now rewrite spec_power, preserves_1.
   intros. rewrite spec_power, preserves_0.
   now apply int_pow_base_0.
  intros ? ? E. rewrite preserves_mult, 2!spec_power.
  rewrite preserves_0 in E.
  now apply int_pow_S.
Qed.

Program Instance QType_Npow: Pow t N := λ x n, power x (Z_of_N n).

Instance: NatPowSpec t N QType_Npow.
Proof.
  split; unfold "^", QType_Npow.
    solve_proper.
   intros. rewrite preserves_0. apply int_pow_0.
  intros ? ?. rewrite preserves_plus, preserves_1.
  apply int_pow.int_pow_S_nonneg.
  apply nat_int.to_semiring_nonneg.
Qed.

End QType_Rationals.