(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Export ZAdd.

Module ZMulProp (Import Z : ZAxiomsMiniSig').
Include ZAddProp Z.

(** A note on naming: right (correspondingly, left) distributivity
    happens when the sum is multiplied by a number on the right
    (left), not when the sum itself is the right (left) factor in the
    product (see planetmath.org and mathworld.wolfram.com). In the old
    library BinInt, distributivity over subtraction was named
    correctly, but distributivity over addition was named
    incorrectly. The names in Isabelle/HOL library are also
    incorrect. *)

(** Theorems that are either not valid on N or have different proofs
    on N and Z *)

Theorem mul_pred_r : forall n m, n * (P m) == n * m - n.
Proof.
intros n m.
rewrite <- (succ_pred m) at 2.
now rewrite mul_succ_r, <- add_sub_assoc, sub_diag, add_0_r.
Qed.

Theorem mul_pred_l : forall n m, (P n) * m == n * m - m.
Proof.
intros n m; rewrite (mul_comm (P n) m), (mul_comm n m). apply mul_pred_r.
Qed.

Theorem mul_opp_l : forall n m, (- n) * m == - (n * m).
Proof.
intros n m. apply add_move_0_r.
now rewrite <- mul_add_distr_r, add_opp_diag_l, mul_0_l.
Qed.

Theorem mul_opp_r : forall n m, n * (- m) == - (n * m).
Proof.
intros n m; rewrite (mul_comm n (- m)), (mul_comm n m); apply mul_opp_l.
Qed.

Theorem mul_opp_opp : forall n m, (- n) * (- m) == n * m.
Proof.
intros n m; now rewrite mul_opp_l, mul_opp_r, opp_involutive.
Qed.

Theorem mul_sub_distr_l : forall n m p, n * (m - p) == n * m - n * p.
Proof.
intros n m p. do 2 rewrite <- add_opp_r. rewrite mul_add_distr_l.
now rewrite mul_opp_r.
Qed.

Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p.
Proof.
intros n m p; rewrite (mul_comm (n - m) p), (mul_comm n p), (mul_comm m p);
now apply mul_sub_distr_l.
Qed.

End ZMulProp.


(** * Definition of preadditive categories. *)
(** ** Contents
- Definition of preadditive categories [PreAdditive]
- Zero and unit element coincide
- Composition and inverses
- KernelIn, CokernelOut, and binary operations
- Quotient of PreAdditive
 *)

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

Require Import UniMath.MoreFoundations.PartA.

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

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.CategoriesWithBinOps.
Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops.
Require Import UniMath.CategoryTheory.opp_precat.

Require Import UniMath.CategoryTheory.limits.zero.
Require Import UniMath.CategoryTheory.limits.kernels.
Require Import UniMath.CategoryTheory.limits.cokernels.
Import AddNotation.
Local Open Scope addmonoid_scope.

(** * Definition of a PreAdditive precategory
   A preadditive precategory is a precategory such that the sets of morphisms are abelian groups and
   pre- and postcomposing with a morphisms is a monoidfun of the abelian groups. *)
Section def_preadditive.

  (** In preadditive category precomposition and postcomposition for any
      morphism yields a morphism of abelian groups. Classically one says that
      composition is bilinear with respect to the abelian groups? *)
  Definition isPreAdditive (PA : categoryWithAbgrops) : UU :=
    (∏ (x y z : PA) (f : x --> y), ismonoidfun (to_premor z f))
      × (∏ (x y z : PA) (f : y --> z), ismonoidfun (to_postmor x f)).

  Definition make_isPreAdditive (PA : categoryWithAbgrops)
             (H1 : ∏ (x y z : PA) (f : x --> y), ismonoidfun (to_premor z f))
             (H2 : ∏ (x y z : PA) (f : y --> z), ismonoidfun (to_postmor x f)) :
    isPreAdditive PA.
  Proof.
    exact (H1,,H2).
  Defined.

  Definition make_isPreAdditive' (PA : categoryWithAbgrops)
             (H1 : ∏ (x y z : PA) (f : x --> y) (g h : y --> z),
                   f · (to_binop _ _ g h) = to_binop _ _ (f · g) (f · h))
             (H1' : ∏ (x y z : PA) (f : x --> y), to_premor z f (to_unel y z) = to_unel x z)
             (H2 : ∏ (x y z : PA) (f : y --> z) (g h : x --> y),
                   (to_binop _ _ g h) · f = to_binop _ _ (g · f) (h · f))
             (H2' : ∏ (x y z : PA) (f : y --> z), to_premor z (to_unel x y) f = to_unel x z):
    isPreAdditive PA.
  Proof.
    use make_isPreAdditive.
    - intros x y z f.
      use tpair.
      + intros g h. exact (H1 x y z f g h).
      + exact (H1' x y z f).
    - intros x y z f.
      use tpair.
      + intros g h. exact (H2 x y z f g h).
      + exact (H2' x y z f).
  Qed.

  Definition to_premor_monoid {PWA : categoryWithAbgrops} (iPA : isPreAdditive PWA) :
    ∏ (x y z : PWA) (f : x --> y), ismonoidfun (to_premor z f) := dirprod_pr1 iPA.

  Definition to_postmor_monoid {PWA : categoryWithAbgrops} (iPA : isPreAdditive PWA) :
    ∏ (x y z : PWA) (f : y --> z), ismonoidfun (to_postmor x f) := dirprod_pr2 iPA.

  Definition to_premor_monoidfun {PWA : categoryWithAbgrops} (iPA : isPreAdditive PWA)
             (x y z : PWA) (f : x --> y) : monoidfun (to_abgr y z) (to_abgr x z) :=
    monoidfunconstr (to_premor_monoid iPA x y z f).

  Definition to_postmor_monoidfun {PWA : categoryWithAbgrops} (iPA : isPreAdditive PWA)
             (x y z : PWA) (f : y --> z) : monoidfun (to_abgr x y) (to_abgr x z) :=
    monoidfunconstr (to_postmor_monoid iPA x y z f).

  (** Definition of preadditive categories *)
  Definition PreAdditive : UU := ∑ PA : categoryWithAbgrops, isPreAdditive PA.

  Definition PreAdditive_categoryWithAbgrops (A : PreAdditive) : categoryWithAbgrops := pr1 A.
  Coercion PreAdditive_categoryWithAbgrops : PreAdditive >-> categoryWithAbgrops.

  Definition make_PreAdditive (PA : categoryWithAbgrops) (H : isPreAdditive PA) : PreAdditive.
  Proof.
    exact (tpair _ PA H).
  Defined.

  Definition PreAdditive_isPreAdditive (A : PreAdditive) : isPreAdditive A := pr2 A.
  Coercion PreAdditive_isPreAdditive : PreAdditive >-> isPreAdditive.

  Variable A : PreAdditive.

  (** The following give that premor and postmor are linear. *)
  Definition to_premor_linear {x y : A} (z : A) (f : x --> y) :
    isbinopfun (to_premor z f) := dirprod_pr1 (to_premor_monoid A x y z f).

  Definition to_postmor_linear (x : A) {y z : A} (f : y --> z) :
    isbinopfun (to_postmor x f) := dirprod_pr1 (to_postmor_monoid A x y z f).

  (** Following versions are useful when one wants to rewrite equations *)
  Lemma to_premor_linear' {x y z : A} (f : x --> y) (g h : y --> z) :
    f · (to_binop y z g h) = to_binop x z (f · g) (f · h).
  Proof.
    apply to_premor_linear.
  Qed.

  Lemma to_postmor_linear' {x y z : A} (g h : x --> y) (f : y --> z) :
    (to_binop x y g h) · f = to_binop x z (g · f) (h · f).
  Proof.
    apply to_postmor_linear.
  Qed.

  (** The following says that composing with zero object yields a zero object. *)
  Definition to_premor_unel {x y : A} (z : A) (f : x --> y) :
    to_premor z f 1%multmonoid = 1%multmonoid := dirprod_pr2 (to_premor_monoid A x y z f).

  Definition to_postmor_unel (x : A) {y z : A} (f : y --> z) :
    to_postmor x f 1%multmonoid = 1%multmonoid := dirprod_pr2 (to_postmor_monoid A x y z f).

  (** Following versions are useful when one wants to rewrite equations *)
  Lemma to_premor_unel' {x y : A} (z : A) (f : x --> y) : f · (to_unel y z) = to_unel x z.
  Proof.
    apply to_premor_unel.
  Qed.

  Lemma to_postmor_unel' (x : A) {y z : A} (f : y --> z) : (to_unel x y) · f = to_unel x z.
  Proof.
    apply to_postmor_unel.
  Qed.

End def_preadditive.
Arguments to_premor_linear [A] [x] [y] _ _ _ _.
Arguments to_postmor_linear [A] _ [y] [z] _ _ _.
Arguments to_premor_linear' [A] [x] [y] [z] _ _ _.
Arguments to_postmor_linear' [A] [x] [y] [z] _ _ _.

(** * Zero and unit
   In the following section we prove that if a preadditive category has a zero
   object, then in a homset the unit element is given by the zero arrow *)
Section preadditive_with_zero.

  Variable A : PreAdditive.

  (** Proof that the zero arrow and the unit element coincide *)
  Lemma PreAdditive_unel_zero (Z : Zero A) (x y : A) : to_unel x y = ZeroArrow Z x y.
  Proof.
    unfold ZeroArrow.
    rewrite <- (id_left (ZeroArrowFrom y)).
    assert (X : identity Z = to_unel Z Z).
    { apply ZeroEndo_is_identity. }
    rewrite -> X. clear X.

    set (Y := to_postmor_unel A Z (@ZeroArrowFrom A Z y)).
    unfold to_postmor in Y. unfold to_unel.
    rewrite Y. clear Y.

    set (Y' := to_premor_unel A y (@ZeroArrowTo A Z x)).
    unfold to_premor in Y'.
    rewrite Y'. clear Y'.

    apply idpath.
  Qed.

  Lemma to_lunax'' {Z : Zero A} (x y : A) (f : x --> y) : to_binop x y (ZeroArrow Z x y) f = f.
  Proof.
    rewrite <- to_lunax'. apply maponpaths_2, pathsinv0, PreAdditive_unel_zero.
  Qed.

  Lemma to_runax'' {Z : Zero A} (x y : A) (f : x --> y) : to_binop x y f (ZeroArrow Z x y) = f.
  Proof.
    rewrite <- to_runax'. apply maponpaths, pathsinv0, PreAdditive_unel_zero.
  Qed.

  Lemma to_linvax' {Z : Zero A} {x y : A} (f : A⟦x, y⟧) :
    to_binop x y (to_inv f) f = ZeroArrow Z x y.
  Proof.
    rewrite linvax. apply PreAdditive_unel_zero.
  Qed.

  Lemma to_rinvax' {Z : Zero A} {x y : A} (f : A⟦x, y⟧) :
    to_binop x y f (to_inv f) = ZeroArrow Z x y.
  Proof.
    rewrite rinvax. apply PreAdditive_unel_zero.
  Qed.

  Lemma to_inv_zero {Z : Zero A} {x y : A} : to_inv (ZeroArrow Z x y) = ZeroArrow Z x y.
  Proof.
    rewrite <- PreAdditive_unel_zero.
    apply to_inv_unel.
  Qed.

End preadditive_with_zero.

(** * Inverses and composition
   Some equations on inverses in PreAdditive categories *)
Section preadditive_inv_comp.

  Variable A : PreAdditive.

  Lemma PreAdditive_invlcomp {x y z : A} (f : A⟦x, y⟧) (g : A⟦y, z⟧) :
    (to_inv (f · g)) = (to_inv f) · g.
  Proof.
    use (grrcan (to_abgr x z) (f · g)).
    unfold to_inv at 1. rewrite grlinvax.
    use (pathscomp0 _ (to_postmor_linear' (to_inv f) f g)).
    rewrite linvax. rewrite to_postmor_unel'.
    unfold to_unel.
    apply idpath.
  Qed.

  Lemma PreAdditive_invrcomp {x y z : A} (f : A⟦x, y⟧) (g : A⟦y, z⟧) :
    (to_inv (f · g)) = f · (to_inv g).
  Proof.
    use (grrcan (to_abgr x z) (f · g)).
    unfold to_inv at 1. rewrite grlinvax.
    use (pathscomp0 _ (to_premor_linear' f (to_inv g) g)).
    rewrite linvax. rewrite to_premor_unel'.
    unfold to_unel.
    apply idpath.
  Qed.

  Lemma PreAdditive_cancel_inv {x y : A} (f g : A⟦x, y⟧) (H : (to_inv f)  = (to_inv g)) : f = g.
  Proof.
    apply (grinvmaponpathsinv (to_abgr x y) H).
  Qed.

End preadditive_inv_comp.

(** * KernelIn, CokernelOut, and Binary Operations *)
(** ** Introduction
   In this section we show that binop commutes with KernelIn and CokernelOut in a PreAdditive
   category. [KernelInOp] proves commutativity for KernelIn and [CokernelOutOp] proves commutativity
   for CokernelOut.
*)
Section def_additive_kernel_cokernel.

  Variable A : PreAdditive.
  Variable Z : Zero A.

  Local Lemma KernelInOp_Eq {x y z : A} (f1 f2 : A⟦x, y⟧) (g : A⟦y, z⟧)
        (H1 : f1 · g = ZeroArrow Z _ _) (H2 : f2 · g = ZeroArrow Z _ _) :
    (to_binop _ _ f1 f2 · g = ZeroArrow Z _ _).
  Proof.
    rewrite to_postmor_linear'. rewrite H1. rewrite H2.
    rewrite <- PreAdditive_unel_zero.
    rewrite to_lunax'. apply idpath.
  Qed.

  Lemma KernelInOp {x y z : A} (f1 f2 : A⟦x, y⟧) (g : A⟦y, z⟧) (K : Kernel Z g)
        (H1 : f1 · g = ZeroArrow Z _ _) (H2 : f2 · g = ZeroArrow Z _ _) :
    KernelIn Z K _ (to_binop _ _ f1 f2) (KernelInOp_Eq f1 f2 g H1 H2) =
    to_binop _ _ (KernelIn Z K _ f1 H1) (KernelIn Z K _ f2 H2).
  Proof.
    use KernelInsEq.
    rewrite KernelCommutes.
    rewrite (to_postmor_linear' (A:=A)).
    rewrite KernelCommutes.
    rewrite KernelCommutes.
    apply idpath.
  Qed.

  Local Lemma CokernelOutOp_Eq {x y z : A} (f1 f2 : A⟦y, z⟧) (g : A⟦x, y⟧)
        (H1 : g · f1 = ZeroArrow Z _ _) (H2 : g · f2 = ZeroArrow Z _ _) :
    g · (to_binop _ _ f1 f2) = ZeroArrow Z _ _.
  Proof.
    rewrite to_premor_linear'. rewrite H1. rewrite H2.
    rewrite <- PreAdditive_unel_zero.
    rewrite to_lunax'. apply idpath.
  Qed.

  Lemma CokernelOutOp {x y z : A} (f1 f2 : A⟦y, z⟧) (g : A⟦x, y⟧) (CK : Cokernel Z g)
        (H1 : g · f1 = ZeroArrow Z _ _) (H2 : g · f2 = ZeroArrow Z _ _) :
    CokernelOut Z CK _ (to_binop _ _ f1 f2) (CokernelOutOp_Eq f1 f2 g H1 H2) =
    to_binop _ _ (CokernelOut Z CK _ f1 H1) (CokernelOut Z CK _ f2 H2).
  Proof.
    use CokernelOutsEq.
    rewrite CokernelCommutes.
    rewrite to_premor_linear'.
    rewrite CokernelCommutes.
    rewrite CokernelCommutes.
    apply idpath.
  Qed.

End def_additive_kernel_cokernel.

Section monics_and_epis_in_preadditive.

  Variable PA : PreAdditive.

  Lemma to_inv_isMonic {x y : PA} (f : x --> y) (isM : isMonic f) : isMonic (to_inv f).
  Proof.
    use make_isMonic.
    intros x0 g h X.
    rewrite <- (PreAdditive_invrcomp PA) in X. rewrite <- (PreAdditive_invrcomp PA) in X.
    apply cancel_inv in X. use isM. exact X.
  Qed.

  Lemma to_inv_isEpi {x y : PA} (f : x --> y) (isE : isEpi f) : isEpi (to_inv f).
  Proof.
    use make_isEpi.
    intros x0 g h X.
    rewrite <- PreAdditive_invlcomp in X. rewrite <- PreAdditive_invlcomp in X.
    apply cancel_inv in X. use isE. exact X.
  Qed.

End monics_and_epis_in_preadditive.

(** * Quotient of homsets
   Suppose you have a subgroup for each set of morphisms such that pre- and postcompositions map
   morphisms in a subgroup to another subgroup. Then one can form a new Preadditive category by
   taking the same objects and morphisms as elements of the quotient groups. We call this
   [PreAdditiveQuot]. An example of this construction is when one wants to form the naive homotopy
   category from a category of complexes. *)
Section preadditive_quotient.

  Variable PA : PreAdditive.

  Local Opaque ishinh.

  (** For every set morphisms we have a subgroup. *)
  Definition PreAdditiveSubabgrs : UU := ∏ (x y : ob PA), @subabgr (to_abgr x y).

  Hypothesis PAS : PreAdditiveSubabgrs.

  (** Pre- and postcomposing with an element in the subgroups gives an element of a subgroup.
      This is important since we want pre- and postcomposition with unit element to be
      the unit element in the new precategory. *)
  Definition PreAdditiveComps : UU :=
    ∏ (x y : ob PA),
    (∏ (z : ob PA) (f : x --> y)
       (inf : pr1submonoid (@to_abgr PA x y) (PAS x y) f) (g : y --> z),
     pr1submonoid (@to_abgr PA x z) (PAS x z) (f · g))
      × (∏ (z : ob PA) (f : x --> y) (g : y --> z)
           (ing : pr1submonoid (@to_abgr PA y z) (PAS y z) g),
         pr1submonoid (@to_abgr PA x z) (PAS x z) (f · g)).

  Hypothesis PAC : PreAdditiveComps.

  (** ** Here are some random results copied from category_abgr.v.
     Theses should be deleted, removed, renamed, generalized, or ...*)

  (** The hProp which tells if two elements of A belong to the same equivalence class in A/B *)
  Definition subgrhrel_hprop {A : gr} (B : @subgr A) (a1 a2 : A) : hProp :=
    hexists (λ b : B, pr1 b = (a1 * grinv A a2)%multmonoid).

  (** Construct a relation using the above hProp *)
  Definition subgrhrel {A : gr} (B : @subgr A) : @hrel A :=
    (λ a1 : A, λ a2 : A, (subgrhrel_hprop B a1 a2)).

  (** Let B be a subgroup of A. Then the canonical map A -> A/B is a monoidfun. *)
  Local Lemma abgrquotpr_ismonoidfun {A : abgr} (H : @binopeqrel A) :
    @ismonoidfun A (abgrquot H) (λ a : A, setquotpr H a).
  Proof.
    split.
    - split.
    - apply idpath.
  Qed.

  Local Lemma funeqpaths {X Y : UU} {f g : X -> Y} (e : f = g) : ∏ (x : X), f x = g x.
  Proof.
    induction e. intros x. apply idpath.
  Qed.

  Local Definition abgrquotpr_monoidfun {A : abgr} (H : @binopeqrel A) : monoidfun A (abgrquot H) :=
    monoidfunconstr (abgrquotpr_ismonoidfun H).

  Local Lemma monoidfun_inv {A B : abgr} (f : monoidfun A B) (a : A) :
    f (grinv A a) = grinv B (f a).
  Proof.
    apply (grlcan B (f a)). rewrite (grrinvax B).
    use (pathscomp0 (pathsinv0 (((pr1 (pr2 f)) a (grinv A a))))).
    rewrite (grrinvax A). apply (pr2 (pr2 f)).
  Qed.

  (** The relation we defined is an equivalence relation *)
  Lemma iseqrel_subgrhrel (A : gr) (B : @subgr A) : iseqrel (subgrhrel B).
  Proof.
    unfold subgrhrel. unfold subgrhrel_hprop.
    use iseqrelconstr.
    (* istrans *)
    - intros x1 x2 x3 y1 y2. cbn in *. unfold ishinh_UU in *.
      use (squash_to_prop y1 (propproperty _)). intros Y1. clear y1.
      use (squash_to_prop y2 (propproperty _)). intros Y2. clear y2.
      use hinhpr.
      induction Y1 as [t p]. induction Y2 as [t0 p0].
      use tpair.
      + use tpair.
        * exact (op (pr1 t) (pr1 t0)).
        * exact (pr2subsetswithbinop B t t0).
      + cbn. rewrite p. rewrite p0. rewrite <- (assocax A).
        apply maponpaths_2. rewrite assocax. rewrite grlinvax. rewrite runax.
        apply idpath.
    (* isrefl *)
    - intros x.
      use hinhpr.
      use tpair.
      + exact (unel B).
      + cbn. apply pathsinv0. apply (grrinvax A).
    (* issymm *)
    - intros x y. cbn. unfold ishinh_UU. intros H.
      use (squash_to_prop H (propproperty _)). intros H'. clear H.
      use hinhpr.
      induction H' as [t p].
      use tpair.
      + exact (grinv B t).
      + cbn. rewrite p. clear p. rewrite grinvop. rewrite grinvinv. apply idpath.
  Qed.

  (** The relation we defined respects binary operations. Note that we use commax, thus the proof
      does not work for nonabelian groups. *)
  Lemma isbinopeqrel_subgr_eqrel {A : abgr} (B : @subabgr A) :
    isbinophrel (make_eqrel (subgrhrel B) (iseqrel_subgrhrel A B)).
  Proof.
    use isbinophrelif.
    - apply (pr2 (pr2 A)).
    - intros a b c X. cbn in *. unfold ishinh_UU in *.
      use (squash_to_prop X (propproperty _)). intros X''.
      use hinhpr.
      use tpair.
      + exact (pr1 X'').
      + cbn.
        set (tmp := pr2 X''). cbn in tmp. rewrite tmp. clear tmp. clear X''.
        rewrite grinvop. rewrite (commax A c). rewrite (assocax A). rewrite (commax A c).
        rewrite (assocax A). rewrite grlinvax. rewrite runax. apply idpath.
  Qed.

  (** Thus the relation is a binopeqrel *)
  Lemma binopeqrel_subgr_eqrel {A : abgr} (B : @subabgr A) : @binopeqrel A.
  Proof.
    use make_binopeqrel.
    - exact (make_eqrel _ (iseqrel_subgrhrel A B)).
    - exact (isbinopeqrel_subgr_eqrel B).
  Defined.

  (** These are the homsets in our new category. *)
  Definition subabgr_quot {A : abgr} (B : @subabgr A) : abgr :=
    abgrquot (binopeqrel_subgr_eqrel B).

  Definition Quotcategory_homsets (c d : ob PA) : abgr := subabgr_quot (PAS c d).

  Definition Quotcategory_ob_mor : precategory_ob_mor :=
    tpair (λ ob : UU, ob -> ob -> UU) (ob PA) (λ A B : ob PA, Quotcategory_homsets A B).

  Lemma Quotcategory_surj {c d : Quotcategory_ob_mor} (f : Quotcategory_ob_mor⟦c, d⟧) :
    ∥ hfiber (setquotpr (binopeqrel_subgr_eqrel (PAS c d))) f ∥.
  Proof.
    use issurjsetquotpr.
  Qed.

  (** ** Composition of morphisms *)

  (** *** Some lemmas *)

  (** If images of f1 and f2 are equal, then f * inv f2 is mapped to unit. *)
  Local Lemma abgrquotpr_rels_to_unel {A : abgr} {f1 f2 : A} {H : @binopeqrel A} {f : abgrquot H}
             (e1 : setquotpr H f1 = f) (e2 : setquotpr H f2 = f) :
    setquotpr H (f1 * grinv A f2)%multmonoid = setquotpr H 1%multmonoid.
  Proof.
    rewrite <- e2 in e1. clear e2.
    apply (maponpaths (λ f : _, (f * (@grinv (abgrquot H) (setquotpr H f2)))%multmonoid)) in e1.
    rewrite grrinvax in e1. apply e1.
  Qed.

  (** Equality on relation to refl *)
  Local Lemma abgrquotpr_rel_to_refl {A : abgr} {H : @binopeqrel A} {f g : A} (e : H g g = H f g) :
    H f g.
  Proof.
    induction e.
    apply eqrelrefl.
  Qed.

  Lemma abgrquotpr_rel_paths {A : abgr} {H : @binopeqrel A} {f g : A}
        (e : setquotpr H f = setquotpr H g) : H f g.
  Proof.
    exact (abgrquotpr_rel_to_refl (! (funeqpaths (base_paths _ _ e)) g)).
  Qed.

  Lemma abgrquotpr_rel_image {A : abgr} {H : @binopeqrel A} {f g : A}
        (e : H f g) : setquotpr H f = setquotpr H g.
  Proof.
    apply iscompsetquotpr.
    exact e.
  Qed.

  (** *** Morphisms to elements of groups *)
  Local Lemma mor_to_elem {a b : PA} (f : PA⟦a, b⟧) (H : pr1 (PAS a b) f) : carrier (pr1 (PAS a b)).
  Proof.
    use tpair.
    - exact f.
    - exact H.
  Defined.

  Local Lemma to_inv_elem {a b : PA} (f : PA⟦a, b⟧) (H : pr1 (PAS a b) f) : carrier (pr1 (PAS a b)).
  Proof.
    use tpair.
    - exact (@grinv (to_abgr a b) f).
    - apply (pr2 (pr2 (PAS a b))). exact H.
  Defined.

  Local Lemma to_op_elem {A B : PA} (f g : PA⟦A, B⟧) (H1 : pr1 (PAS A B) f) (H2 : pr1 (PAS A B) g) :
    pr1 (PAS A B) (to_binop A B f g).
  Proof.
    set (tmp := pr1 (pr1 (pr2 (PAS A B)))). cbn in tmp. unfold issubsetwithbinop in tmp.
    set (a := mor_to_elem f H1). set (a' := mor_to_elem g H2).
    apply (tmp a a').
  Qed.

  (** *** Composition of morphisms in the quotient precategory *)

  (** **** Structure for composition *)

  Definition QuotcategoryComp {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧)
             (g : Quotcategory_ob_mor⟦B, C⟧) : UU :=
    ∑ h : Quotcategory_ob_mor⟦A, C⟧,
          (∏ (f' : PA⟦A, B⟧) (e1 : setquotpr _ f' = f)
             (g' : PA⟦B, C⟧) (e2 : setquotpr _ g' = g), setquotpr _ (f' · g') = h).

  Definition make_QuotcategoryComp {A B C : ob PA} {f : Quotcategory_ob_mor⟦A, B⟧}
             {g : Quotcategory_ob_mor⟦B, C⟧} (h : Quotcategory_ob_mor⟦A, C⟧)
             (H : ∏ (f' : PA⟦A, B⟧) (e1 : setquotpr _ f' = f)
                    (g' : PA⟦B, C⟧) (e2 : setquotpr _ g' = g), setquotpr _ (f' · g') = h) :
    QuotcategoryComp f g := tpair _ h H.

  Definition QuotcategoryCompMor {A B C : ob PA} {f : Quotcategory_ob_mor⟦A, B⟧}
             {g : Quotcategory_ob_mor⟦B, C⟧} (QPC : QuotcategoryComp f g) :
    Quotcategory_ob_mor⟦A, C⟧ := pr1 QPC.

  Definition QuotcategoryCompEq {A B C : ob PA} {f : Quotcategory_ob_mor⟦A, B⟧}
             {g : Quotcategory_ob_mor⟦B, C⟧} (QPC : QuotcategoryComp f g) :
    ∏ (f' : PA⟦A, B⟧) (e1 : setquotpr _ f' = f) (g' : PA⟦B, C⟧) (e2 : setquotpr _ g' = g),
    setquotpr _ (f' · g') = QuotcategoryCompMor QPC := pr2 QPC.

  (** **** Composition for quotient category *)

  Local Lemma Quotcategory_comp_iscontr_PAS_eq {A : abgr} {a b c : A}
        (e : a = (b * (grinv A c))%multmonoid) : b = (a * c)%multmonoid.
  Proof.
    rewrite e. rewrite assocax. rewrite grlinvax. rewrite runax. apply idpath.
  Qed.

  Lemma Quotcategory_comp_iscontr_PAS {A B C : PA} {t : pr1 (PAS A B)} {t' : pr1 (PAS B C)}
        {f1 f'1 : PA⟦A, B⟧} {g1 g'1 : PA⟦B, C⟧}
        (p : pr1 t = to_binop A B f'1 (grinv (to_abgr A B) f1))
        (p' : pr1 t' = to_binop B C g'1 (grinv (to_abgr B C) g1)) :
    pr1 (PAS A C) (to_binop A C (f1 · g1) (grinv (to_abgr A C) (f'1 · g'1))).
  Proof.
    set (e1 := Quotcategory_comp_iscontr_PAS_eq p).
    set (e2 := Quotcategory_comp_iscontr_PAS_eq p').
    rewrite e1. rewrite e2. clear e1 e2 p p'. cbn.
    rewrite to_premor_linear'. rewrite to_postmor_linear'. rewrite to_postmor_linear'.
    set (ac := assocax (to_abgr A C)). unfold isassoc in ac. cbn in ac.
    set (comm := commax (to_abgr A C)). unfold iscomm in comm. cbn in comm.
    rewrite (comm _ (f1 · g1)). rewrite <- (ac _ (f1 · g1) _).
    rewrite (comm _ (f1 · g1)). rewrite ac. rewrite ac.
    set (i := grinvop (to_abgr A C)). cbn in i. rewrite i. repeat rewrite <- ac.
    rewrite comm. rewrite <- ac.
    set (il := linvax _ (f1 · g1)). unfold to_inv in il. rewrite il. clear il.
    set (lu := to_lunax A C). unfold islunit in lu. cbn in lu. unfold to_unel. rewrite lu.
    set (tmp := pr2 (pr2 (PAS A C))). cbn in tmp. apply tmp. clear tmp.
    use to_op_elem.
    - use to_op_elem.
      + apply (dirprod_pr1 (PAC A B) C (pr1 t) (pr2 t) (pr1 t')).
      + apply (dirprod_pr2 (PAC A B) C f1 (pr1 t') (pr2 t')).
    - apply (dirprod_pr1 (PAC A B) C (pr1 t) (pr2 t) g1).
  Qed.

  Local Lemma Quotcategory_comp_iscontr_eq {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧)
        (g : Quotcategory_ob_mor⟦B, C⟧)  (f'1 : PA ⟦ A, B ⟧) (f''1 : setquotpr _ f'1 = f)
        (g'1 : PA ⟦ B, C ⟧) (g''1 : setquotpr _ g'1 = g) :
    ∏ (f' : PA⟦A, B⟧) (e1 : setquotpr _ f' = f) (g' : PA⟦B, C⟧) (e2 : setquotpr _ g' = g),
    setquotpr _ (f' · g') = setquotpr (binopeqrel_subgr_eqrel (PAS A C)) (f'1 · g'1).
  Proof.
    intros f1 Hf g1 Hg. cbn.
    apply (iscompsetquotpr (make_eqrel _ (iseqrel_subgrhrel (to_abgr A C) (PAS A C)))).
    set (HH := @abgrquotpr_rels_to_unel
                 (to_abgr A B) f'1 f1 (binopeqrel_subgr_eqrel (PAS A B)) f f''1 Hf).
    set (HH' := @abgrquotpr_rels_to_unel
                  (to_abgr B C) g'1 g1 (binopeqrel_subgr_eqrel (PAS B C)) g g''1 Hg).
    apply abgrquotpr_rel_paths in HH. apply abgrquotpr_rel_paths in HH'.
    use (squash_to_prop HH). apply propproperty. intros HHH. clear HH.
    use (squash_to_prop HH'). apply propproperty. intros HHH'. clear HH'.
    cbn in HHH. cbn in HHH'. induction HHH as [t p]. induction HHH' as [t' p'].
    rewrite grinvunel in p. rewrite grinvunel in p'.
    set (tmp := to_runax A B). unfold isrunit in tmp. cbn in tmp. rewrite tmp in p. clear tmp.
    set (tmp := to_runax B C). unfold isrunit in tmp. cbn in tmp. rewrite tmp in p'. clear tmp.
    use hinhpr.
    use tpair.
    + use tpair.
      * exact (to_binop A C (f1 · g1) (grinv (to_abgr A C) (f'1 · g'1))).
      * apply (Quotcategory_comp_iscontr_PAS p p').
    + apply idpath.
  Qed.

  Local Lemma QuotPrecatetgory_comp_iscontr_univ {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧)
             (g : Quotcategory_ob_mor⟦B, C⟧)
             (f' : hfiber (setquotpr (binopeqrel_subgr_eqrel (PAS A B))) f)
             (g' : hfiber (setquotpr (binopeqrel_subgr_eqrel (PAS B C))) g) :
    ∏ t : QuotcategoryComp f g,
          t = make_QuotcategoryComp
                (setquotpr (binopeqrel_subgr_eqrel (PAS A C))
                           (hfiberpr1 _ _ f' · hfiberpr1 _ _ g'))
                (Quotcategory_comp_iscontr_eq
                   f g (hfiberpr1 (setquotpr (binopeqrel_subgr_eqrel (PAS A B))) f f')
                   (hfiberpr2 (setquotpr (binopeqrel_subgr_eqrel (PAS A B))) f f')
                   (hfiberpr1 (setquotpr (binopeqrel_subgr_eqrel (PAS B C))) g g')
                   (hfiberpr2 (setquotpr (binopeqrel_subgr_eqrel (PAS B C))) g g')).
  Proof.
    intros t.
    use total2_paths_f.
    - exact (! (pr2 t (hfiberpr1 _ _ f') (hfiberpr2 _ _ f') (hfiberpr1 _ _ g') (hfiberpr2 _ _ g'))).
    - apply proofirrelevance.
      apply impred. intros t'.
      apply impred. intros H.
      apply impred. intros t0.
      apply impred. intros H0.
      apply isasetsetquot.
  Qed.

  Lemma Quotcategory_comp_iscontr {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧)
             (g : Quotcategory_ob_mor⟦B, C⟧) : iscontr (QuotcategoryComp f g).
  Proof.
    use (squash_to_prop (Quotcategory_surj f) (isapropiscontr _)). intros f'.
    use (squash_to_prop (Quotcategory_surj g) (isapropiscontr _)). intros g'.
    use make_iscontr.
    - use make_QuotcategoryComp.
      + exact (setquotpr
                 (binopeqrel_subgr_eqrel (PAS A C)) ((hfiberpr1 _ _ f') · (hfiberpr1 _ _ g'))).
      + exact (Quotcategory_comp_iscontr_eq
                 f g (hfiberpr1 _ _ f') (hfiberpr2 _ _ f') (hfiberpr1 _ _ g') (hfiberpr2 _ _ g')).
    - exact (QuotPrecatetgory_comp_iscontr_univ f g f' g').
  Defined.

  Definition Quotcategory_comp {A B C : ob PA} (f : Quotcategory_ob_mor⟦A, B⟧)
             (g : Quotcategory_ob_mor⟦B, C⟧) : Quotcategory_ob_mor⟦A, C⟧.
  Proof.
    exact (QuotcategoryCompMor (iscontrpr1 (Quotcategory_comp_iscontr f g))).
  Defined.

  Definition to_quot_mor {x y : ob PA} (f : PA⟦x, y⟧) : Quotcategory_ob_mor⟦x, y⟧.
  Proof.
    use setquotpr. exact f.
  Defined.

  (** ** Some equations on linearity, compositions, and binops *)

  Lemma Quotcategory_comp_linear {x y z : ob PA} (f : PA⟦x, y⟧) (g : PA⟦y, z⟧) :
    Quotcategory_comp (to_quot_mor f) (to_quot_mor g) = to_quot_mor (f · g).
  Proof.
    unfold to_quot_mor. unfold Quotcategory_comp.
    apply pathsinv0.
    use (pr2 (pr1 (Quotcategory_comp_iscontr
                           (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) f)
                           (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) g)))).
    - apply idpath.
    - apply idpath.
  Qed.

  (** Pre- and postcomposition respect binop. *)
  Local Lemma Quotcategory_premor {x y z : PA} (f : PA⟦x, y⟧) (g h : PA⟦y, z⟧) :
    Quotcategory_comp (to_quot_mor f) ((to_quot_mor g * to_quot_mor h)%multmonoid) =
    ((Quotcategory_comp (to_quot_mor f) (to_quot_mor g)) *
     (Quotcategory_comp (to_quot_mor f) (to_quot_mor h)))%multmonoid.
  Proof.
    Local Opaque binopeqrel_subgr_eqrel isabgrquot setquotfun2 Quotcategory_comp.
    apply pathsinv0. cbn.
    eapply pathscomp0.
    - rewrite Quotcategory_comp_linear. rewrite Quotcategory_comp_linear.
      use setquotfun2comm.
    - apply pathsinv0.
      unfold to_quot_mor.
      set (tmp := setquotfun2comm (binopeqrel_subgr_eqrel (PAS y z))
                                  (binopeqrel_subgr_eqrel (PAS y z))
                                  (to_binop y z)
                                  (iscompbinoptransrel
                                     (binopeqrel_subgr_eqrel (PAS y z))
                                     (eqreltrans (binopeqrel_subgr_eqrel (PAS y z)))
                                     (pr2 (binopeqrel_subgr_eqrel (PAS y z))))).
      rewrite tmp. clear tmp.
      rewrite <- to_premor_linear'.
      apply pathsinv0.
      Local Transparent Quotcategory_comp. unfold Quotcategory_comp.
      apply (pr2 (pr1 (Quotcategory_comp_iscontr
                         (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) f)
                         (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) (to_binop y z g h))))).
      + apply idpath.
      + apply idpath.
  Qed.

  Local Lemma Quotcategory_postmor {x y z : PA} (f : PA⟦y, z⟧) (g h : PA⟦x, y⟧) :
    Quotcategory_comp (to_quot_mor g * to_quot_mor h)%multmonoid (to_quot_mor f) =
    ((Quotcategory_comp (to_quot_mor g) (to_quot_mor f)) *
     (Quotcategory_comp (to_quot_mor h) (to_quot_mor f)))%multmonoid.
  Proof.
    Local Opaque Quotcategory_comp.
    apply pathsinv0. cbn.
    eapply pathscomp0.
    - rewrite Quotcategory_comp_linear. rewrite Quotcategory_comp_linear.
      use setquotfun2comm.
    - unfold to_quot_mor. rewrite setquotfun2comm.
      Local Transparent Quotcategory_comp.
      unfold Quotcategory_comp.
      rewrite <- to_postmor_linear'.
      apply (pr2 (pr1 (Quotcategory_comp_iscontr
                         (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) (to_binop x y g h))
                         (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) f)))).
      + apply idpath.
      + apply idpath.
  Qed.

  (** Composing with the unit element gives the unit element. *)
  Local Lemma quot_comp_unel_left {x y z : PA} (f : PA⟦x, y⟧) :
    Quotcategory_comp (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) f)
                         (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) (@to_unel PA y z)) =
    (setquotpr (binopeqrel_subgr_eqrel (PAS x z)) (@to_unel PA x z)).
  Proof.
    rewrite <- (to_premor_unel' _ _ f). apply pathsinv0.
    unfold Quotcategory_comp.
    apply (pr2 (pr1 (Quotcategory_comp_iscontr
                       (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) f)
                       (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) (to_unel y z))))).
    - apply idpath.
    - apply idpath.
  Qed.

  Local Lemma quot_comp_unel_right {x y z : PA} (f : PA⟦y, z⟧) :
    Quotcategory_comp (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) (to_unel x y))
                         (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) f) =
    (setquotpr (binopeqrel_subgr_eqrel (PAS x z)) (to_unel x z)).
  Proof.
    rewrite <- (to_postmor_unel' _ _ f). apply pathsinv0.
    unfold Quotcategory_comp.
    apply (pr2 (pr1 (Quotcategory_comp_iscontr
                       (setquotpr (binopeqrel_subgr_eqrel (PAS x y)) (to_unel x y))
                       (setquotpr (binopeqrel_subgr_eqrel (PAS y z)) f)))).
    - apply idpath.
    - apply idpath.
  Qed.

  (** ** Construction of the Quotcategory *)

  Definition Quotcategory_data : precategory_data :=
    make_precategory_data
      Quotcategory_ob_mor
      (λ (A : ob PA), setquotpr (binopeqrel_subgr_eqrel (PAS A A)) (identity A))
      (fun (A B C : ob PA) (f : Quotcategory_ob_mor⟦A, B⟧)
         (g : Quotcategory_ob_mor⟦B, C⟧) => Quotcategory_comp f g).

  (** The following two lemmas are used to show associaticity of composition in
      Quotcategory. *)
  Local Lemma Quot_assoc1 {a b c d : Quotcategory_data} (f : Quotcategory_data ⟦a, b⟧)
        (g : Quotcategory_data ⟦b, c⟧) (h : Quotcategory_data ⟦c, d⟧)
        (f1 : PA⟦a, b⟧) (f2 : setquotpr (binopeqrel_subgr_eqrel (PAS a b)) f1 = f)
        (g1 : PA⟦b, c⟧) (g2 : setquotpr (binopeqrel_subgr_eqrel (PAS b c)) g1 = g)
        (h1 : PA⟦c, d⟧) (h2 : setquotpr (binopeqrel_subgr_eqrel (PAS c d)) h1 = h) :
    Quotcategory_comp f (Quotcategory_comp g h) =
    setquotpr (binopeqrel_subgr_eqrel (PAS a d)) (f1 · (g1 · h1)).
  Proof.
    apply pathsinv0.
    set (ic2 := Quotcategory_comp_iscontr g h).
    set (ic3 := Quotcategory_comp_iscontr f (pr1 (pr1 ic2))).
    set (tmp := pr2 (pr1 ic3)). cbn beta in tmp. unfold Quotcategory_comp.
    fold ic2. fold ic3. use tmp.
    - exact f2.
    - use (pr2 (pr1 ic2)).
      + exact g2.
      + exact h2.
  Qed.

  Local Lemma Quot_assoc2 {a b c d : Quotcategory_data} (f : Quotcategory_data ⟦a, b⟧)
        (g : Quotcategory_data ⟦b, c⟧) (h : Quotcategory_data ⟦c, d⟧)
        (f1 : PA⟦a, b⟧) (f2 : setquotpr (binopeqrel_subgr_eqrel (PAS a b)) f1 = f)
        (g1 : PA⟦b, c⟧) (g2 : setquotpr (binopeqrel_subgr_eqrel (PAS b c)) g1 = g)
        (h1 : PA⟦c, d⟧) (h2 : setquotpr (binopeqrel_subgr_eqrel (PAS c d)) h1 = h) :
    setquotpr (binopeqrel_subgr_eqrel (PAS a d)) ((f1 · g1) · h1) =
    Quotcategory_comp (Quotcategory_comp f g) h.
  Proof.
    set (ic1 := Quotcategory_comp_iscontr f g).
    set (ic4 := Quotcategory_comp_iscontr (pr1 (pr1 ic1)) h).
    set (tmp := pr2 (pr1 ic4)). cbn beta in tmp. unfold Quotcategory_comp.
    fold ic1. fold ic4. use tmp.
    - use (pr2 (pr1 ic1)).
      + exact f2.
      + exact g2.
    - exact h2.
  Qed.

  (** Quotcategory is a precategory *)
  Lemma is_precategory_Quotcategory_data : is_precategory Quotcategory_data.
  Proof.
    split.
    - split.
      (* id left *)
      + intros a b f. apply pathsinv0. cbn. unfold Quotcategory_comp.
        set (f'' := @issurjsetquotpr (to_abgr a b) (binopeqrel_subgr_eqrel (PAS a b)) f).
        use (squash_to_prop f''). apply isasetsetquot. intros f'. clear f''.
        induction f' as [f1 f2]. rewrite <- f2. cbn in f1, a, b.
        eapply pathscomp0.
        * apply maponpaths. exact (! (id_left f1)).
        * apply (pr2 (pr1 (Quotcategory_comp_iscontr
                             (setquotpr (binopeqrel_subgr_eqrel (PAS a a)) (@identity PA a))
                             (setquotpr (binopeqrel_subgr_eqrel (PAS a b)) f1)))).
          -- apply idpath.
          -- apply idpath.
      (* id right *)
      + intros a b f. apply pathsinv0. cbn. unfold Quotcategory_comp.
        set (f'' := @issurjsetquotpr (to_abgr a b) (binopeqrel_subgr_eqrel (PAS a b)) f).
        use (squash_to_prop f''). apply isasetsetquot. intros f'. clear f''.
        induction f' as [f1 f2]. rewrite <- f2. cbn in f1, a, b.
        eapply pathscomp0.
        * apply maponpaths. exact (! (id_right f1)).
        * apply (pr2 (pr1 (Quotcategory_comp_iscontr
                             (setquotpr (binopeqrel_subgr_eqrel (PAS a b)) f1)
                             (setquotpr (binopeqrel_subgr_eqrel (PAS b b)) (@identity PA b))))).
          -- apply idpath.
          -- apply idpath.
    (* assoc *)
    - split.
      + intros a b c d f g h. cbn.
        set (f'' := @issurjsetquotpr (to_abgr a b) (binopeqrel_subgr_eqrel (PAS a b)) f).
        use (squash_to_prop f''). apply isasetsetquot. intros f'. clear f''.
        set (g'' := @issurjsetquotpr (to_abgr b c) (binopeqrel_subgr_eqrel (PAS b c)) g).
        use (squash_to_prop g''). apply isasetsetquot. intros g'. clear g''.
        set (h'' := @issurjsetquotpr (to_abgr c d) (binopeqrel_subgr_eqrel (PAS c d)) h).
        use (squash_to_prop h''). apply isasetsetquot. intros h'. clear h''.
        induction f' as [f1 f2]. induction g' as [g1 g2]. induction h' as [h1 h2].
        cbn in f1, g1, h1.
        rewrite (Quot_assoc1 f g h f1 f2 g1 g2 h1 h2).
        rewrite <- (Quot_assoc2 f g h f1 f2 g1 g2 h1 h2).
        rewrite assoc. apply idpath.
      + intros a b c d f g h. cbn.
        set (f'' := @issurjsetquotpr (to_abgr a b) (binopeqrel_subgr_eqrel (PAS a b)) f).
        use (squash_to_prop f''). apply isasetsetquot. intros f'. clear f''.
        set (g'' := @issurjsetquotpr (to_abgr b c) (binopeqrel_subgr_eqrel (PAS b c)) g).
        use (squash_to_prop g''). apply isasetsetquot. intros g'. clear g''.
        set (h'' := @issurjsetquotpr (to_abgr c d) (binopeqrel_subgr_eqrel (PAS c d)) h).
        use (squash_to_prop h''). apply isasetsetquot. intros h'. clear h''.
        induction f' as [f1 f2]. induction g' as [g1 g2]. induction h' as [h1 h2].
        cbn in f1, g1, h1.
        rewrite (Quot_assoc1 f g h f1 f2 g1 g2 h1 h2).
        rewrite <- (Quot_assoc2 f g h f1 f2 g1 g2 h1 h2).
        rewrite assoc'. apply idpath.
  Defined.

  Definition Quotprecategory : precategory :=
    tpair _ _ is_precategory_Quotcategory_data.

  Lemma has_homsets_Quotcategory : has_homsets Quotprecategory.
  Proof.
    intros a b. apply isasetsetquot.
  Qed.

  Definition Quotcategory : category := make_category Quotprecategory has_homsets_Quotcategory.

  (** ** Quotient precategory of PreAdditive is PreAdditive *)

  Definition Quotcategory_binops : precategoryWithBinOps.
  Proof.
    use make_precategoryWithBinOps.
    - exact Quotcategory.
    - intros x y. exact (@op (subabgr_quot (PAS x y))).
  Defined.

  Unset Kernel Term Sharing.
  Definition Quotcategory_abgrops : categoryWithAbgrops.
  Proof.
    use make_categoryWithAbgrops.
    - exact Quotcategory_binops.
    - intros x y. exact (pr2 (subabgr_quot (PAS x y))).
  Defined.
  Set Kernel Term Sharing.

  Local Lemma quot_unel {x y : PA} :
    setquotpr (binopeqrel_subgr_eqrel (PAS x y)) (@to_unel PA x y) =
    unel (@to_abgr Quotcategory_abgrops x y).
  Proof.
    apply idpath.
  Qed.

  Local Opaque to_abgr.
  Local Lemma PreAdditive_pre_linear (x y z : ob Quotcategory_abgrops)
    (f : Quotcategory_abgrops⟦x, y⟧) (g h : Quotcategory_abgrops ⟦y, z⟧):
    f · to_binop y z g h = to_binop x z (f · g) (f · h).
  Proof.
    use (squash_to_prop (Quotcategory_surj f)). apply to_has_homsets. intros f'.
    use (squash_to_prop (Quotcategory_surj g)). apply to_has_homsets. intros g'.
    use (squash_to_prop (Quotcategory_surj h)). apply to_has_homsets. intros h'.
    rewrite <- (hfiberpr2 _ _ f'). rewrite <- (hfiberpr2 _ _ g'). rewrite <- (hfiberpr2 _ _ h').
    exact (Quotcategory_premor (hfiberpr1 _ _ f') (hfiberpr1 _ _ g') (hfiberpr1 _ _ h')).
  Qed.

  Local Lemma PreAdditive_pre_unel (x y z : ob Quotcategory_abgrops)
        (f : Quotcategory_abgrops⟦x, y⟧) : f · (@to_unel Quotcategory_abgrops y z) =
                                              @to_unel Quotcategory_abgrops x z.
  Proof.
    use (squash_to_prop (Quotcategory_surj f)). apply (@to_has_homsets Quotcategory_abgrops).
    intros f'. rewrite <- (hfiberpr2 _ _ f').
    exact (@quot_comp_unel_left x y z (hfiberpr1 _ _ f')).
  Qed.

  Local Lemma PreAdditive_post_linear (x y z : ob Quotcategory_abgrops)
    (f : Quotcategory_abgrops⟦y, z⟧) (g h : Quotcategory_abgrops ⟦x, y⟧):
    to_binop x y g h · f = to_binop x z (g · f) (h · f).
  Proof.
    use (squash_to_prop (Quotcategory_surj f)). apply to_has_homsets. intros f'.
    use (squash_to_prop (Quotcategory_surj g)). apply to_has_homsets. intros g'.
    use (squash_to_prop (Quotcategory_surj h)). apply to_has_homsets. intros h'.
    rewrite <- (hfiberpr2 _ _ f'). rewrite <- (hfiberpr2 _ _ g'). rewrite <- (hfiberpr2 _ _ h').
    exact (Quotcategory_postmor (hfiberpr1 _ _ f') (hfiberpr1 _ _ g') (hfiberpr1 _ _ h')).
  Qed.

  Local Lemma PreAdditive_post_unel (x y z : ob Quotcategory_abgrops)
        (f : Quotcategory_abgrops⟦y, z⟧) : (@to_unel Quotcategory_abgrops x y) · f =
                                              @to_unel Quotcategory_abgrops x z.
  Proof.
    use (squash_to_prop (Quotcategory_surj f)). apply (@to_has_homsets Quotcategory_abgrops).
    intros f'. rewrite <- (hfiberpr2 _ _ f').
    exact (@quot_comp_unel_right x y z (hfiberpr1 _ _ f')).
  Qed.

  Lemma Quotcategory_isPreAdditive : isPreAdditive Quotcategory_abgrops.
  Proof.
    use make_isPreAdditive'.
    - intros x y z f g h. exact (PreAdditive_pre_linear x y z f g h).
    - intros x y z f. exact (PreAdditive_pre_unel x y z f).
    - intros x y z f g h. exact (PreAdditive_post_linear x y z f g h).
    - intros x y z f. exact (PreAdditive_post_unel x y z f).
  Qed.

  Definition Quotcategory_PreAdditive : PreAdditive.
  Proof.
    use make_PreAdditive.
    - exact Quotcategory_abgrops.
    - exact Quotcategory_isPreAdditive.
  Defined.

  Lemma setquotpr_linear {x y : PA} (f g : PA⟦x, y⟧) :
    to_quot_mor (@to_binop PA _ _ f g) =
    @to_binop Quotcategory_PreAdditive _ _ (to_quot_mor f) (to_quot_mor g).
  Proof.
    exact (pr1 (abgrquotpr_ismonoidfun (binopeqrel_subgr_eqrel (PAS x y))) f g).
  Qed.

  Lemma comp_eq {x y z : PA} (f : Quotcategory_PreAdditive⟦x, y⟧)
        (g : Quotcategory_PreAdditive⟦y, z⟧) : Quotcategory_comp f g = f · g.
  Proof.
    apply idpath.
  Qed.

  (** ** The canonical functor to Quotcategory *)
  (** This functor is identity on objects and sends morphisms to the equivalence class they
      represent. *)

  Definition QuotcategoryFunctor_data : functor_data PA Quotcategory_PreAdditive.
  Proof.
    use tpair.
    - intros X. exact X.
    - intros X Y f. exact (setquotpr (binopeqrel_subgr_eqrel (PAS X Y)) f).
  Defined.

  Local Lemma QuotcategoryFunctor_isfunctor : is_functor QuotcategoryFunctor_data.
  Proof.
    split.
    - intros X. apply idpath.
    - intros x Y Z f g. exact (! (Quotcategory_comp_linear f g)).
  Qed.

  Definition QuotcategoryFunctor : functor PA Quotcategory_PreAdditive.
  Proof.
    use tpair.
    - exact QuotcategoryFunctor_data.
    - exact QuotcategoryFunctor_isfunctor.
  Defined.

  (** ** If PA has a zero object, then so does Quotcategory of PA *)

  Variable Z : Zero PA.

  Lemma Quotcategory_isZero : isZero (C:=Quotcategory) Z.
  Proof.
    use make_isZero.
    - intros a.
      use tpair.
      + exact (to_quot_mor (@ZeroArrowFrom PA Z a)).
      + cbn beta. intros t.
        set (t'1 := @issurjsetquotpr (to_abgr Z a) (binopeqrel_subgr_eqrel (PAS Z a)) t).
        use (squash_to_prop t'1). apply has_homsets_Quotcategory. intros t1. clear t'1.
        induction t1 as [t1 t2]. rewrite <- t2. unfold to_quot_mor. apply maponpaths.
        apply ArrowsFromZero.
    - intros a.
      use tpair.
      + exact (to_quot_mor (@ZeroArrowTo PA Z a)).
      + cbn beta. intros t.
        set (t'1 := @issurjsetquotpr (to_abgr a Z) (binopeqrel_subgr_eqrel (PAS a Z)) t).
        use (squash_to_prop t'1). apply has_homsets_Quotcategory. intros t1. clear t'1.
        induction t1 as [t1 t2]. rewrite <- t2. unfold to_quot_mor. apply maponpaths.
        apply ArrowsToZero.
  Qed.

  Definition Quotcategory_Zero : @Zero Quotcategory.
  Proof.
    use make_Zero.
    - exact Z.
    - exact Quotcategory_isZero.
  Defined.

End preadditive_quotient.

Definition oppositePreAdditive (M : PreAdditive) : PreAdditive.
Proof.
  exists (oppositeCategoryWithAbgrops M).
  split.
  - exact (λ a b c f, @to_postmor_monoid (pr1 M) (pr2 M) (rm_opp_ob c) (rm_opp_ob b) (rm_opp_ob a) (rm_opp_mor f)).
  - exact (λ a b c f, @to_premor_monoid (pr1 M) (pr2 M) (rm_opp_ob c) (rm_opp_ob b) (rm_opp_ob a) (rm_opp_mor f)).
Defined.

Definition induced_PreAdditive (M : PreAdditive) {X:Type} (j : X -> ob M) : PreAdditive.
Proof.
  exists (induced_categoryWithAbgrops M j).
  split.
  - exact (λ a b c, @to_premor_monoid (pr1 M) (pr2 M) (j a) (j b) (j c)).
  - exact (λ a b c, @to_postmor_monoid (pr1 M) (pr2 M) (j a) (j b) (j c)).
Defined.

Lemma induced_opposite_PreAdditive {M:PreAdditive} {X:Type} (j : X -> ob M) :
  oppositePreAdditive (induced_PreAdditive M j) =
  induced_PreAdditive (oppositePreAdditive M) (λ a, opp_ob (j a)).
Proof.
  intros.
  compute.                    (* the following line bogs down without this one *)
  apply idpath.                (* but the computation may make this proof fragile *)
Defined.

Section RewritingAids.
  Local Open Scope abgrcat.
  Lemma zeroLeft {M:PreAdditive} {a b c : M} (f : b --> c) : ((0 : a --> b) · f = 0)%abgrcat.
  Proof.
    apply to_postmor_unel'.
  Defined.
  Lemma zeroRight {M:PreAdditive} {a b c : M} (f : a --> b) : f · (0 : b --> c) = 0.
  Proof.
    apply to_premor_unel'.
  Defined.
  Definition leftCompIsHomo {M:PreAdditive} {a b : M} (f : a --> b) (c:M) : ismonoidfun (to_premor c f)
    := @to_premor_monoid _ M _ _ _ _.
  Definition rightCompIsHomo {M:PreAdditive} {b c : M} (a:M) (f : b --> c) : ismonoidfun (to_postmor a f)
    := @to_postmor_monoid _ M _ _ _ _.
  Definition leftCompHomo {M:PreAdditive} {a b : M} (f : a --> b) (c:M) : monoidfun (b-->c) (a-->c)
    := to_premor c f,, to_premor_monoid M _ _ _ f.
  Definition rightCompHomo {M:PreAdditive} {b c : M} (a:M) (f : b --> c) : monoidfun (a-->b) (a-->c)
    := to_postmor a f,, to_postmor_monoid M _ _ _ f.
  Lemma rightDistribute {M:PreAdditive} {a b c : M} (f : a --> b) (g h : b --> c) : f · (g + h) = f · g + f · h.
  Proof.
    apply leftCompIsHomo.
  Qed.
  Lemma leftDistribute {M:PreAdditive} {a b c : M} (f g : a --> b) (h : b --> c) : (f + g) · h = f · h + g · h.
  Proof.
    apply rightCompIsHomo.
  Qed.
  Lemma rightMinus {M:PreAdditive} {a b c : M} (f : a --> b) (g : b --> c) : f · (- g) = - (f·g).
  Proof.
    exact (monoidfuninvtoinv (leftCompHomo f c) g).
  Qed.
  Lemma leftMinus {M:PreAdditive} {a b c : M} (f : a --> b) (g : b --> c) : (- f) · g = - (f·g).
  Proof.
    exact (monoidfuninvtoinv (rightCompHomo a g) f).
  Qed.
End RewritingAids.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import znat.
Require Import real.
Require Import realmap.
Require Import realsyntax.
Require Import realprop.
Require Import grid.
Require Import approx.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section FinitizeMap.

(* We use a special case of the compactness theorem for predicate logic to *)
(* extend the four color theorem from finite to arbitrary maps. We can     *)
(* dispense with the axiom of choice because of the local compactness of   *)
(* the plane. This is the only part of the development that is             *)
(* intrinsically classical.                                                *)

Variable R : real_model.

Notation point := (point R).
Notation region := (region R).
Notation map := (map R).
Notation rect := (rect R).
Notation interval := (interval R).

Let Hclassical : excluded_middle := reals_classic R.

Variable nc : nat.
Hypothesis Hfin : forall m : map, finite_simple_map m -> map_colorable nc m.

Variable m0 : map.
Hypothesis Hm0 : simple_map m0.

(* We will deduce an enumeration of regions from a canonical enumeration of *)
(* of grid points.                                                          *)

Definition pairn sn := let: (s, n) := sn in pred (iter s double (S (double n))).

Fixpoint unpairn_rec (s r n : nat) {struct n} : nat * nat :=
  match r, n with
  | S (S r'), S n' => unpairn_rec s r' n'
  | S O, S n' => unpairn_rec (S s) n' n'
  | _, _ => (s, n)
  end.

Definition unpairn m := unpairn_rec 0 m m.

Lemma pairn_unpair : monic unpairn pairn.
Proof.
move=> m; symmetry; transitivity (pred (iter 0 double (S (double m - m)))).
  by rewrite double_addnn subn_addl.
rewrite /unpairn; elim: m {1 4 5}m 0 (leqnn m) => [|n Hrec] [|[|r]] s //= Hr.
case: (unpairn_rec (S s) n n) {Hrec Hr}(Hrec _ (S s) (leqnn _)) => [s' n'] <-.
  by rewrite (double_addnn n) subn_addl -iter_f.
by case: (unpairn_rec s r n) {Hrec Hr}(Hrec r s (leqW Hr)) => [s' n'] <-.
Qed.

Lemma unpairn_pair : monic pairn unpairn.
Proof.
move=> sn; move: (pairn_unpair (pairn sn)).
case: sn (unpairn (pairn sn)) => [s n] [s' n'] /= Ess'.
have Dss': iter s' double (S (double n')) = iter s double (S (double n)).
  have Em: forall s1 m1, let m := iter s1 double (S m1) in S (pred m) = m.
    move=> s1 m1 /=; apply: ltnSpred 0 _; elim: s1 => //= [s1 Hrec].
    by rewrite -double0 ltn_double.
  by rewrite -Em Ess' Em.
elim: s s' Dss' {Ess'} => [|s Hrec] [|s'] H;
 move: {H}(congr1 odd H) (congr1 half H);
 rewrite /= ?odd_double ?half_double ?uphalf_double //; clear; auto.
by case/(Hrec s') => <- <-.
Qed.

Definition injzn m := match m with Zpos n => double n | Zneg n => S (double n) end.

Definition uninjzn n := (if odd n then Zneg else Zpos) (half n).

Lemma uninjzn_inj : monic injzn uninjzn.
Proof.
by case=> *; rewrite /uninjzn /= odd_double ?half_double ?uphalf_double.
Qed.

Lemma injzn_uninj : monic uninjzn injzn.
Proof. by move=> n; rewrite -{2}[n]odd_double_half /uninjzn; case (odd n). Qed.

Definition std_point i : point :=
  let: (s, mxy) := unpairn i in let: (mx, my) := unpairn mxy in
  scale_point R s (Gpoint (uninjzn mx) (uninjzn my)).

Lemma has_std_point : forall z, inmap m0 z -> exists i, m0 z (std_point i).
Proof.
move=> z Hz; case: (map_open Hm0 Hz) => [rr Hrrz Hrrm].
case: (approx_rect Hrrz) => [s [b [p Hp Hbp] Hbr]]; move Dp: p => [mx my].
exists (pairn (s, pairn (injzn mx, injzn my))); apply: Hrrm; apply: Hbr.
rewrite /std_point !unpairn_pair !uninjzn_inj -Dp.
apply: (mem_approx_scale R s b p); apply: (mem_sub_grect Hbp); exact: gtouch_refl.
Qed.

Definition in_partial n : region := fun z => exists2 i, i < n & m0 z (std_point i).

Lemma leq_partial : forall n1 n2, n1 <= n2 ->
  subregion (in_partial n1) (in_partial n2).
Proof.
by move=> n1 n2 Hn12 z [i Hi Hz]; exists i; first exact: leq_trans Hn12.
Qed.

Lemma partial_trans : forall n z, in_partial n z ->
  subregion (m0 z) (in_partial n).
Proof.
move=> n z1 [i Hi Hz1] z2 Hz12; exists i; auto.
apply: (map_trans Hm0) Hz1; exact: (map_sym Hm0).
Qed.

Lemma proper_inmap_r : forall m : map, proper_map m ->
  forall z, subregion (m z) (inmap m).
Proof. move=> m [Sm Tm] z1 z2 Hz12; apply: Tm (Hz12); exact: Sm. Qed.

Lemma proper_inmap_l : forall m : map, proper_map m ->
 forall z, subregion (fun t => m t z) (inmap m).
Proof. move=> m Hm z1 z2; move/(map_sym Hm); exact: proper_inmap_r. Qed.

Definition partial_map n (m : map) : map :=
  fun z1 z2 => and3 (m z1 z2) (in_partial n z1) (in_partial n z2).

Lemma leq_partial_map : forall n1 n2, n1 <= n2 ->
  forall m, covers (partial_map n1 m) (partial_map n2 m).
Proof.
move=> n1 n2; move/leq_partial=> Hn12 m z1 z2 [Hz12 Hz1 Hz2]; split; auto.
Qed.

Lemma covers_partial_map : forall n m, covers (partial_map n m) m.
Proof. by move=> n m z1 z2; case. Qed.

Lemma proper_partial_map : forall n m, proper_map m ->
  proper_map (partial_map n m).
Proof.
move=> n m [Sm Tm]; split; first by move=> z1 z2 [Hz12 Hz1 Hz2]; split; auto.
by move=> z1 z2 [Hz12 Hz1 _] z3 [Hz23 _ Hz3]; split; auto; apply: Tm Hz23.
Qed.

Lemma finite_partial_map : forall n, finite_simple_map (partial_map n m0).
Proof.
move=> n; split.
  split; try exact (proper_partial_map n Hm0).
  move=> z1 z2 [Hz12 Hz1 Hz2]; case: (map_open Hm0 Hz12) => [rr Hrr2 Hrr].
    exists rr; auto; move=> t Ht; split; auto; apply: (partial_trans Hz1); auto.
  move=> z r1 r2 Hrz [z1 [Hr1z1 [Hzz1 Hz _]]] [z2 [Hr2z2 [Hzz2 _ _]]].
  apply: ((map_connected Hm0) z); [ idtac | exists z1 | exists z2 ]; try by split.
  by move=> t Ht; apply Hrz; split; auto; exact: partial_trans Ht.
exists n; exists std_point; move=> z [_ [i Hi Hzi] Hz].
exists i; first exact: ltP.
by split; auto; [ exact: (map_sym Hm0) | exact: (partial_trans Hz) ].
Qed.

Lemma size_partial_map : forall n k, proper_map k -> size_at_most nc k ->
  size_at_most nc (partial_map n k).
Proof.
move=> n m Hk [f Hf].
suffice [f' Hf']: exists f', forall j, j < nc ->
    forall z, in_partial n z -> m (f j) z -> partial_map n m (f' j) z.
- exists f'; move=> z [Hkz Hz _]; case: (Hf _ Hkz) => i; exists i; auto.
  by apply: Hf'; first apply/ltP.
elim: nc => [|i [f' Hf']]; first by exists f.
case: (Hclassical (nonempty (intersect (m (f i)) (in_partial n)))).
  move=> [zi [Hkzi Hzi]]; exists (fun j => if j =d i then zi else f' j).
  move=> j; rewrite ltnS leq_eqVlt; case: (j =P i) => //=; auto.
  move=> -> _ z Hz Hiz; split; auto.
  by apply: (map_trans Hk) Hiz; exact: (map_sym Hk).
move=> Hi; exists f' => j; rewrite ltnS leq_eqVlt; case: (j =P i) => //=; auto.
by move=> -> _ z Hz Hiz; case Hi; exists z; split; auto.
Qed.

Record quasi_coloring (k : map) : Prop := QuasiColoring {
  qc_proper :> proper_map k;
   qc_inmap : subregion (inmap k) (inmap m0);
   qc_size : size_at_most nc k;
   qc_adj : forall z1 z2, k z1 z2 -> adjacent m0 z1 z2 -> m0 z1 z2
}.

Lemma quasi_coloring_partial : forall n k, quasi_coloring k ->
   quasi_coloring (partial_map n k).
Proof.
move=> n m [Hk Hkm0 Hnck Hka]; split.
- exact: proper_partial_map.
- by move=> z [Hz _ _]; auto.
- exact: size_partial_map.
move=> z1 z2 [Hkz12 _ _]; exact: Hka.
Qed.

Definition partial_coloring n k := quasi_coloring k /\ covers (partial_map n m0) k.

Lemma exist_partial_coloring : forall n,
 exists2 k, partial_coloring n k & subregion (inmap k) (in_partial n).
Proof.
move=> n; case: (Hfin (finite_partial_map n)) => [k [Hk Hkn Hnk Hka] Hknc].
exists k; last by move=> z Hz; case (Hkn _ Hz).
do 2 (split; auto); first by move=> z Hz; case (Hkn _ Hz).
have Hb: forall z t, in_partial n z -> closure (m0 z) t ->
    closure (partial_map n m0 z) t.
  move=> z t Hz Hzt r Hr Hrt; case: (Hzt r) => // [] u [Hzu Hru].
  by exists u; repeat split; auto; exact: partial_trans Hzu.
move=> z1 z2 Hk12 [z [[f Hf] [Hzz1 Hzz2]]]; case: (Hka _ _ Hk12) => //.
case: (Hkn _ (proper_inmap_l Hk Hk12)) => [_ Hz1 _].
case: (Hkn _ (proper_inmap_r Hk Hk12)) => [_ Hz2 _].
exists z; split; last by split; auto.
exists f; move=> t [[Ht Htn _] Htz]; case (Hf t).
split; auto; move=> r Hr Hrz; case: (Htz r) => // u [[Htu _ _] Hru].
  by exists u; split.
move=> i Hi [Hit Hiz]; have Hfi: in_partial n (f i).
  by apply (partial_trans Htn); exact: (map_sym Hm0).
exists i; auto; do 2 (split; auto).
Qed.

Lemma leq_partial_coloring : forall n1 n2, n1 <= n2 ->
 forall k, partial_coloring n2 k -> partial_coloring n1 k.
Proof.
move=> n1 n2 Hn12 k [Hk Hkn]; split; auto.
by move=> z1 z2 Hz12; apply: Hkn; exact: (leq_partial_map Hn12).
Qed.

Definition partial_eq n k k' :=
  covers (partial_map n k) k' /\ covers (partial_map n k') k.

Lemma partial_eq_sym : forall n k k', partial_eq n k k' -> partial_eq n k' k.
Proof. by move=> n k k'; case; split. Qed.

Lemma partial_eq_trans : forall n k k' k'',
 partial_eq n k k' -> partial_eq n k' k'' -> partial_eq n k k''.
Proof.
move=> n k1 k2 k3 [Hk12 Hk21] [Hk23 Hk32].
by split; move=> z1 z2 [Hz12 Hz1 Hz2]; [ apply Hk23 | apply Hk21 ]; split; auto;
  [ apply Hk12 | apply Hk32 ]; split.
Qed.

Lemma partial_eq_partial : forall n k, partial_eq n k (partial_map n k).
Proof. by move=> n k; split; move=> z1 z2; last by do 2 case. Qed.

Lemma leq_partial_eq : forall n1 n2, n1 <= n2 ->
 forall k k', partial_eq n2 k k' -> partial_eq n1 k k'.
Proof.
move=> n1 n2; move/leq_partial_map=> Hn12 k k' [Hkk' Hk'k].
by split; move=> z1 z2 Hz12; [ apply: Hkk' | apply: Hk'k ]; exact: Hn12.
Qed.

Definition extensible n k :=
  and3 (quasi_coloring k) (subregion (inmap k) (in_partial n))
       (forall n', exists2 k', partial_coloring n' k' & partial_eq n k k').

Lemma extensible_partial : forall n k, extensible n k -> partial_coloring n k.
Proof.
move=> n k [Hk Ek Xk]; case: {Xk}(Xk n) => [k' [Hk' Hk'n] [Hkk' Hk'k]].
by split; auto; move=> z1 z2 Hz12; apply Hk'k; case Hz12; split; auto; apply Hk'n.
Qed.

Lemma leq_extensible : forall n1 n2, n1 <= n2 ->
  forall k, extensible n2 k -> extensible n1 (partial_map n1 k).
Proof.
move=> n1 n2; move/leq_partial_eq=> Hn12 k [Hk Ek Xk].
split; try by first [ exact: quasi_coloring_partial | move=> z [_ Hz _] ].
move=> n; case: (Xk n) => [k' Hk' Ek']; exists k'; auto.
apply: (partial_eq_trans (partial_eq_sym (partial_eq_partial n1 k))); auto.
Qed.

Definition min_partial1 i k :=
  forall j' k',
    let zi := std_point i in let zj' := std_point j' in
    partial_eq i k k' -> extensible (S i) k' -> k' zj' zi ->
  exists2 j, j <= j' & k (std_point j) zi.

Fixpoint min_partial (n : nat) (k : map) {struct n} : Prop :=
  if n is S i then min_partial1 i k /\ min_partial i k else True.

Definition exact_partial n k := min_partial n k /\ extensible n k.

Lemma exists_exact_partial : forall n, exists k, exact_partial n k.
Proof.
pose ak (k : map) i j := k (std_point i) (std_point j).
pose inm0 j := inmap m0 (std_point j).
have Hinm0: forall i j, j < i -> inm0 j -> in_partial i (std_point j).
  by move=> i j; exists j.
pose akn i i' k k' := partial_eq i k k' /\ partial_coloring i' k'.
pose akm i i' j j' k k' := akn i i' k k' -> ak k' i j' -> j <= j'.
pose akx i j k := exists2 i', i < i' & (forall j' k', akm i i' j j' k k').
elim=> /= [|i [k [Hkm [Hk Hkn Xk]]]].
  exists (fun z1 z2 : point => False); do 2 split; try by move.
    by split; [ split | move | exists std_point | done ].
  move=> n; case: (exist_partial_coloring n) => [k [Hk Hnk] Hkn].
  by exists k; split=> // z1 z2 [] _ [].
case: (Hclassical (akx i (S i) k)).
  case: (Hclassical (inm0 i)) => Hm0i.
    move=> [n' Hin' Hn']; case: (Xk n') => [k' Hk' Ekk']; case/idP: (ltnn i).
    by apply: (Hn' _ k'); [ split | case: Hk' => _; apply; split=> //; exists i ].
  have Ei: subregion (in_partial (S i)) (in_partial i).
    move=> z [j Hj Hz]; rewrite ltnS leq_eqVlt in Hj.
    case/setU1P: Hj => [Dj|Hj]; last by exists j.
    by case: Hm0i; apply: ((proper_inmap_r Hm0) z); rewrite -Dj.
  clear; exists k; split.
    split; last done; move=> j' k' /= _ [[Hk' Hm0k' _ _] _ _] Hj'i.
    case Hm0i; apply: Hm0k'; exact (proper_inmap_r Hk' Hj'i).
  split; auto; first by move=> z Hz; apply (leq_partial (leqnSn i)); auto.
  move=> n'; case: (Xk n') => [k' Hk' [Ekk' Ek'k]]; exists k'; auto.
  split; move=> z1 z2 [Hz12 Hz1 Hz2]; [ apply: Ekk' | apply: Ek'k ]; split; auto.
  elim: {1 3}(S i) (ltnSn i) {Xk} => [|j Hrec] Hj HSj.
  by case HSj; exists (S i); first exact: leqnn.
case: (Hclassical (akx i j k)) => [[n1 Hin1 Hn1]|]; last by apply Hrec; apply ltnW.
clear Hrec; pose extij n2 := exists2 k2, akn i n2 k k2 & ak k2 i j.
have Hxn1: forall n2, n1 <= n2 -> extij n2.
  move=> n2 Hn12; case: (Hclassical (extij n2)) => // Nk2; case: HSj.
  exists n2; [ exact: leq_trans Hn12 | move=> j' k' [Ekk' Hk'] Hk'j' ].
  rewrite ltn_neqAle andbC (Hn1 j' k') //;
    last by split; last exact: (leq_partial_coloring Hn12).
  apply/eqP => Dj'; rewrite -Dj' in Hk'j'.
  by case Nk2; exists k'; first by split.
case: (Hxn1 _ (leqnn n1)) {HSj} => [k1 Hk1 Ek1i].
case: Hk1 (Hn1 _ _ Hk1) => [Ekk1 Hk1] Hk1i.
have [Hm0i Hm0j]: inm0 i /\ inm0 j.
  case: Hk1 => [[Hk1 Hm0k1 _ _] _].
  move: (proper_inmap_l Hk1 Ek1i) (proper_inmap_r Hk1 Ek1i); split; exact: Hm0k1.
pose k2 := partial_map (S i) k1; have HSi := ltnSn i; have HSi' := leqnSn i.
have Ek2i: ak k2 i j by split; auto.
have Ekk2: partial_eq i k k2.
  exact (partial_eq_trans Ekk1 (leq_partial_eq HSi' (partial_eq_partial _ _))).
have Hk2: quasi_coloring k2 by apply: quasi_coloring_partial; case Hk1.
exists k2; do 2 split; auto; try by move=> z; case.
- move=> j' k' /= Ek2k' Hk' Ek'i; exists j; last exact: (map_sym Hk2).
  case: Hk' => [Hk' Hk'i Xk']; case: (Xk' n1) => [k'' Hk'' Ek''].
  apply: (Hn1 _ k'').
    split; auto; apply: (partial_eq_trans Ekk2); apply: (partial_eq_trans Ek2k').
    exact: (leq_partial_eq HSi').
  case: Ek'' => [H _]; apply: H; split; auto; first exact: (map_sym Hk').
  apply Hk'i; exact (proper_inmap_l Hk' Ek'i).
- elim: {-2}i (leqnn i) Hkm => //= [i1 Hrec] Hi1 [Hki1 Hkm].
  split; last by apply: Hrec Hkm; exact: ltnW.
  move=> j' k' /= Ek' Hk' Hk'j'.
  have Ekk': partial_eq i1 k k'.
    by apply: partial_eq_trans Ek'; exact: (leq_partial_eq (ltnW Hi1)).
  case: {Hki1}(Hki1 j' k' Ekk' Hk' Hk'j') => [j1 Hj1j' Ekj1].
  exists j1; first done; move: Ekk2 => [H _]; apply: H.
  suffice: in_partial i (std_point j1) /\ in_partial i (std_point i1).
    by case; split.
  by move: (proper_inmap_l Hk Ekj1) (proper_inmap_r Hk Ekj1); split; exact: Hkn.
move=> n; have [n' Hn1n' Hnn']: exists2 n', n1 <= n' & n <= n'.
  by case (leqP n1 n); [ exists n | exists n1 ]; rewrite ?leqnn // ltnW.
case: (Hxn1 _ Hn1n') => [k' [Ekk' Hk'] Ek'i]; exists k'.
  exact: (leq_partial_coloring Hnn').
apply: (partial_eq_trans (partial_eq_sym (partial_eq_partial _ _))).
case: (partial_eq_trans (partial_eq_sym Ekk1) Ekk') => [Hk1k' Hk'k1].
move/(leq_partial_coloring Hn1n'): Hk' => Hk'.
pose kij k :=
   and3 (partial_coloring (S i) k) (ak k i j) (forall j', ak k i j' -> j <= j').
move/leq_partial_coloring: Hin1 => Hin1.
have Hk1ij: kij k1 by split; auto.
have Hk'ij: kij k' by split; auto; move=> j'; apply Hn1; split.
clear Hkm Hk Hkn Hn1 Hxn1 Ekk1 k2 Ek2i Ekk2 Hk2 n n' Hn1n' Hnn' Ekk'.
clear k akn akm akx extij n1 Hin1 Hk1 Hk' Ek'i Ek1i Hk1i.
suffice: forall k1 k2, kij k1 -> kij k2 -> covers (partial_map i k1) k2 ->
    covers (partial_map (S i) k1) k2.
  by split; auto.
clear k1 k' Hk1k' Hk'k1 Hk1ij Hk'ij.
move=> k k' [[Hk Hik] Eki Hki] [[Hk' Hik'] Ek'i _] Ekk'.
pose zi := std_point i; pose zj := std_point j.
pose a0i z := partial_map (S i) m0 zi z.
have Vm0': forall z, in_partial (S i) z -> in_partial i z \/ a0i z.
  move=> z Hz; case: (Hz) => j'; rewrite ltnS leq_eqVlt.
  case/setU1P=> [Dj'|Hj']; last by left; exists j'.
  by rewrite Dj'; right; split; auto; [ exact: (map_sym Hm0) | exact: Hinm0 ].
have Hm0'i: in_partial (S i) zi by exists i.
have Hizi: forall z, in_partial i z -> k zi z -> k' zi z.
  move=> z Hz Hziz; apply: (map_trans Hk' Ek'i); apply Ekk'; split; auto.
    exact: (map_trans Hk (map_sym Hk Eki)).
  apply: Hinm0; auto; case: (Hz) => [j' Hj' Hzj']; apply: leq_trans (Hj').
  apply: Hki; apply: (map_trans Hk Hziz); apply Hik.
  split=> //; apply: (leq_partial HSi'); exists j' => //.
  exact: (proper_inmap_r Hm0 Hzj').
have Ha0i: forall z z', a0i z -> (k zi z' -> k' zi z') -> k z z' -> k' z z'.
  move=> z z' Hz Hziz' Hzz'; apply (map_trans Hk') with zi.
    by apply (map_sym Hk'); exact: Hik'.
  by apply Hziz'; apply: (map_trans Hk) Hzz'; exact: Hik.
move=> z1 z2 [Hz12 Hz1 Hz2]; case: (Vm0' _ Hz1) => Hz1'.
  apply (map_sym Hk'); move/(map_sym Hk): Hz12 => Hz12.
  by case: (Vm0' _ Hz2) => Hz2'; eauto; apply Ekk'; split.
by apply: Ha0i Hz12 => // Hz12; case: (Vm0' _ Hz2) => Hz2'; auto; exact: Hik'.
Qed.

Lemma leq_exact_partial : forall n1 n2, n1 <= n2 -> forall k1 k2,
  exact_partial n1 k1 -> exact_partial n2 k2 -> covers k1 k2.
Proof.
move=> n1 n2 Hn12 k1 k2 [Mk1 Xk1] [Mk2 Xk2]; suffice: partial_eq n1 k1 k2.
  move: Xk1 {Mk1 Xk2 Mk2} => [Hk1 Hk1n1 _] [Hk12 _] z1 z2 Hz12; apply Hk12.
  by move: (proper_inmap_l Hk1 Hz12) (proper_inmap_r Hk1 Hz12); split; auto.
have Mk21: min_partial n1 k2.
  by elim: (leP Hn12) Mk2 => //= n _ Hrec [_ Hn]; auto.
elim: {-2}n1 (leqnn n1) Mk1 Mk21 {Mk2} => /= [|i Hrec] Hin1.
  by split; move=> z1 z2 [_ [j Hj _] _].
move=> [Hk1i Mk1] [Hk2i Mk2]; move/(leq_trans Hin1): Hn12 => Hin2.
move: {Hrec Mk1 Mk2}(Hrec (ltnW Hin1) Mk1 Mk2) => Ek12.
have Ek21 := partial_eq_sym Ek12.
move: (partial_eq_partial (S i) k1) (partial_eq_partial (S i) k2).
move: {Hin1}(leq_extensible Hin1 Xk1) {Hin2}(leq_extensible Hin2 Xk2).
pose zi := std_point i; set aSi := partial_map (S i).
case: Xk1 Xk2 => [Hk1 _ _] [Hk2 _ _] Xk1 Xk2 Ek1 Ek2.
apply: (partial_eq_trans Ek1 (partial_eq_trans _ (partial_eq_sym Ek2))).
have Ek12' := (partial_eq_trans Ek12 (leq_partial_eq (leqnSn i) Ek2)).
have Ek21' := (partial_eq_trans Ek21 (leq_partial_eq (leqnSn i) Ek1)).
pose ak (k : map) j1 j2 := k (std_point j1) (std_point j2).
pose minki k k' := forall j', ak k' j' i -> exists2 j, j <= j' & ak k j i.
have Hminki: forall k k', partial_eq i k k' -> extensible (S i) k' ->
    quasi_coloring k -> min_partial1 i k -> minki (aSi k) k'.
  move=> k k' Ekk' Hk' Hk Hki j' Hj'i.
  have [Hj' Hi]: in_partial (S i) (std_point j') /\ in_partial (S i) zi.
    move: Hk' => [Hk' Ek' _].
    by move: (proper_inmap_l Hk' Hj'i) (proper_inmap_r Hk' Hj'i); split; apply Ek'.
  have [j1 [Hj1 Hj1j' Hj1i]]: exists j1, and3 (j1 <= i) (j1 <= j') (ak k' j1 i).
    case: (leqP j' i) => Hij'; first by exists j'; split; try apply leqnn.
    move/extensible_partial: Hk' => [Hk' Hik'].
    case: (Hj') => [j1 Hj1 Hj1j']; exists j1; split; auto.
      by apply ltnW; eapply leq_trans; eauto.
    apply: (map_trans Hk') Hj'i; apply (map_sym Hk'); apply Hik'; split; auto.
    by exists j1; last exact: (proper_inmap_r Hm0 Hj1j').
  case: {Hki Ekk' Hk' Hj' Hj'i Hj1i}(Hki _ _ Ekk' Hk' Hj1i) => [j Hj Hji].
  exists j; first by eapply leq_trans; eauto.
  split; auto; exists j; first by apply leq_trans with (S j1).
  by apply (qc_inmap Hk); exact (proper_inmap_l Hk Hji).
have Hk1i': minki (aSi k1) (aSi k2) by auto.
have Hk2i': minki (aSi k2) (aSi k1) by auto.
move/extensible_partial: Xk2 Hk2i' {Hminki}; move/extensible_partial: Xk1 Hk1i'.
move: (partial_eq_trans (partial_eq_sym Ek12') (partial_eq_trans Ek12 Ek21')).
move/aSi: k2 {n1 n2 Hk1i Hk2i Hk1 Hk2 Ek1 Ek2 Ek12' Ek21' Ek12 Ek21}; move/aSi: k1.
suffice: forall k1 k2, partial_coloring (S i) k1 -> minki k1 k2 ->
                   partial_coloring (S i) k2 -> minki k2 k1 ->
      covers (partial_map i k1) k2 -> covers (aSi k1) k2.
- by move=> Xi k1 k2; case; split; apply Xi.
move=> k1 k2 [Hk1 Hik1] Hk21i [Hk2 Hik2] Hk12i Hk12.
have Hk1zi: forall z, in_partial i z -> k1 z zi -> k2 z zi.
  move=> z Hz Hzzi; case: (Hz) => [j Hj]; set zj := std_point j; move=> Hzzj.
  have Hzj: in_partial i zj by exists j; last exact: (proper_inmap_r Hm0 Hzzj).
  have Hzj': aSi m0 z zj by split; auto; exact: (leq_partial (leqnSn i)).
  move: {Hz Hzzj Hzzi}(map_trans Hk1 (map_sym Hk1 (Hik1 _ _ Hzj')) Hzzi) => Hzji.
  apply: (map_trans Hk2 (Hik2 _ _ Hzj')) => {Hzj'}.
  have [j' [Hj' Hj'1 Hj'2]]: exists j', and3 (j' < i) (ak k1 j' i) (ak k2 j' i).
    move: {Hzj}Hzji; rewrite {}/zj; elim: {1 2}i j Hj => //= [i' Hrec] j0 Hi' Hj0.
    case: (Hk12i _ Hj0) => [j1 Hj10 Hj1]; case: (Hk21i _ Hj1) => [j2 Hj21 Hj2].
    rewrite leq_eqVlt in Hj21; case/setU1P: Hj21 => [Dj2|Hj21].
      by rewrite Dj2 in Hj2; exists j1; split; auto; apply: leq_trans Hi'.
    have Hj2': j2 < i'.
      by rewrite ltnS in Hi'; exact: leq_trans (leq_trans Hj10 Hi').
    case: (Hrec _ Hj2' Hj2) => [j' [Hj' Hj'1 Hj'2]].
    by move: (ltnW Hj'); exists j'; split.
  apply: (map_trans Hk2) Hj'2; apply: Hk12; split; auto.
    exact: (map_trans Hk1) (map_sym Hk1 Hj'1).
  exists j'; auto; move: Hk1 => [Hk1 Hm0k1 _ _]; apply: Hm0k1.
  exact (proper_inmap_l Hk1 Hj'1).
have Vm0: forall z, in_partial (S i) z -> in_partial i z \/ aSi m0 zi z.
  move=> z Hz; case: (Hz) => j'; rewrite ltnS leq_eqVlt.
  case/setU1P=> [Dj'|Hj']; last by left; exists j'.
  rewrite Dj'; move=> Hiz; right; split; auto; first exact: (map_sym Hm0).
  exists i; [ exact: leqnn | exact: (proper_inmap_r Hm0 Hiz) ].
move=> z1 z2 [Hz12 Hz1 Hz2]; case/Vm0: Hz1 => Hz1.
  case/Vm0: Hz2 => Hz2; first by apply Hk12; split.
  apply: (map_trans Hk2) (Hik2 _ _ Hz2); apply: Hk1zi => //.
  exact: (map_trans Hk1) (map_sym Hk1 (Hik1 _ _ Hz2)).
apply (map_sym Hk2); apply: (map_trans Hk2) (Hik2 _ _ Hz1).
move: {z1 Hz12 Hz1}(map_sym Hk1 (map_trans Hk1 (Hik1 _ _ Hz1) Hz12)) => Hz2i.
by case/Vm0: Hz2 => Hz2; auto; apply (map_sym Hk2); exact: Hik2.
Qed.

Definition limit_coloring : map :=
  fun z1 z2 => exists2 k : map, k z1 z2 & (exists n, exact_partial n k).

Lemma limit_coloring_coloring : coloring m0 limit_coloring.
Proof.
split.
- split; move=> z1 z2 [k Hz12 [n Hk]].
    by exists k; [ case: Hk => [_ [Hk _ _]]; exact: (map_sym Hk) | exists n ].
  move=> z3 [k3 Hz23 [n3 Hk3]].
  have [k' [Hz12' Hz23' [n' Hk']]]: exists k' : map,
      and3 (k' z1 z2) (k' z2 z3) (exists n', exact_partial n' k').
    case: (leqP n n3) => Hnn3.
      exists k3; split; auto; last by exists n3.
      exact: ((leq_exact_partial Hnn3) k k3).
    exists k; split; auto; last by exists n.
    exact: ((leq_exact_partial (ltnW Hnn3)) k3 k).
  exists k'; last by exists n'.
  case: Hk' => [_ [Hk' _ _]]; exact: (map_trans Hk' Hz12').
- by move=> z [k Hz [n [_ [[_ Hk _ _] _ _]]]]; auto.
- move=> z1 z2 Hz12; move: (has_std_point (proper_inmap_l Hm0 Hz12)) => [i1 Hiz1].
  move: (has_std_point (proper_inmap_r Hm0 Hz12)) => [i2 Hiz2].
  have [n Hni1 Hni2]: exists2 n, i1 < n & i2 < n.
    by case (leqP i1 i2); [exists (S i2) | exists (S i1)]; rewrite ?leqnn // ltnW.
  case: (exists_exact_partial n) => [k Hk]; exists k; last by exists n.
  case: Hk => _; case/extensible_partial=> [Hk Hnk].
  by apply: Hnk; split; [ done | exists i1 | exists i2 ].
by move=> z1 z2 [k Hz12 [n [_ [[_ _ _ Hka] _ _]]]]; auto.
Qed.

Lemma size_limit_coloring : size_at_most nc limit_coloring.
Proof.
pose inmf n k f := forall i, i < n -> inmap k (f i : point).
pose injf n (k : map) f :=  forall i j, i < j -> j < n -> ~ k (f i) (f j).
pose minsize n k := exists2 f, inmf n k f & injf n k f.
case: (Hclassical (minsize (S nc) limit_coloring)).
  move=> [f Hf If].
  have [k Hfk Hk]: exists2 k, inmf (S nc) k f & (exists n, exact_partial n k).
    elim: {-2}(S nc) (ltnSn nc) => [|n Hrec] Hn.
      by case: (exists_exact_partial 0) => [k Hk]; exists k; [ move | exists 0 ].
    case: (Hrec (ltnW Hn)) => [k1 Hk1f [n1 Hk1]].
    case: (Hf _ Hn) => [k2 Hk2f [n2 Hk2]]; case: (ltnP n2 n1) => Hn12.
      exists k1; last by exists n1.
      move=> i; rewrite ltnS leq_eqVlt; case/setU1P=> [Di|Hi]; auto.
      by rewrite Di; exact: ((leq_exact_partial (ltnW Hn12)) k2 k1).
    exists k2; last by exists n2.
    move=> i; rewrite ltnS leq_eqVlt; case/setU1P; first by move ->.
    by move/Hk1f; exact: ((leq_exact_partial Hn12) k1 k2).
  case: (Hk) {Hf} => [nk [_ [[Hk' _ [f' Hf'] _] _ _]]].
  have [s Ls Ds]: exists2 s, size s = S nc
     & forall i, i < S nc -> let j := sub 0 s i in j < nc /\ k (f' j) (f i).
    elim: (S nc) f Hfk {If} => [|n Hrec] f Hf; first by exists (seq0 : natseq).
    case: {Hrec}(Hrec (fun i => f (S i))); first by move=> i Hi; exact: Hf.
    move=> s Ls Hs; case: (Hf' (f 0)); first by apply Hf.
    move=> j Hjnc Hjf'; exists (Adds j s); first by rewrite /= Ls.
    by move=> [|i]; [ split; first by apply/ltP | exact: Hs ].
  clear Hfk Hf'; have Us: uniq s.
    rewrite -[s]take_size; move: (leqnn (size s)).
    elim: {-2}(size s) => [|n Hrec] Hn; first by rewrite take0.
    rewrite (take_sub 0 Hn) uniq_add_last {}Hrec 1?ltnW // andbT.
    apply/(subPx 0 _ _); rewrite size_take Hn; move=> [i Hi Ei].
    rewrite Ls in Hn; case: (If _ _ Hi Hn); exists k; auto.
    case: (Ds _ Hn) => [_]; rewrite -Ei sub_take //; apply: (map_trans Hk').
    by apply (map_sym Hk'); case: (Ds _ (ltn_trans Hi Hn)).
  have [s' Ls' Ds']: exists2 s', size s' = nc & s' =1 (fun i => i < nc).
    exists (traject S 0 nc); first by rewrite size_traject.
    have EitS: forall i, iter i S 0 = i by elim=> //= *; congr S.
    by move=> i; apply/trajectP/idP => [[i' Hi' <-]|]; [ rewrite EitS | exists i ].
  case/idP: (ltnn nc); rewrite -Ls -Ls'; apply: uniq_leq_size => // i.
  by rewrite Ds'; move/(subPx 0)=> [j Hj <-]; rewrite Ls in Hj; case: (Ds _ Hj).
move: limit_coloring => k; elim: nc => [|n Hrec] Hn.
  exists (fun _ : nat => std_point 0); move=> z Hz; case Hn.
  by exists (fun _ : nat => z); move=> i; case.
case: (Hclassical (minsize (S n) k)).
  move{Hrec} => [f Hf Ij]; exists f; move=> z Hz.
  case (Hclassical (exists2 i, (i < S n)%nat & k (f i) z)); auto.
  move=> Hfz; case Hn; exists (fun i => if i < S n then f i else z).
    by move=> i /= _; case Hi: (i < S n); auto.
  move=> j i /= Hj Hi; rewrite ltnS in Hi; rewrite (leq_trans Hj Hi).
  case: (ltnP i (S n)); auto; rewrite leq_eqVlt ltnNge Hi orbF; move/eqP=> Di Hjz.
  by case: Hfz; exists j; first by apply: ltP; rewrite Di.
case/Hrec {Hrec Hn} => [f Hf]; exists f; move=> z; move/(Hf z)=> [i Hi Hz].
by exists i; first by right.
Qed.

Lemma compactness_extension : map_colorable nc m0.
Proof.
by move: limit_coloring_coloring size_limit_coloring; exists limit_coloring.
Qed.

End FinitizeMap.

Set Strict Implicit.
Unset Implicit Arguments.


(* This should be in the Coq library *)
Require Import Coq.Arith.Arith Coq.NArith.NArith Coq.ZArith.ZArith Lia.

Lemma N_to_Z_to_nat: forall (a: N), Z.to_nat (Z.of_N a) = N.to_nat a.
Proof.
  intros. rewrite <- (N2Z.id a) at 2.
  rewrite Z_N_nat. reflexivity.
Qed.

Module N2Nat.

  Lemma inj_mod: forall (a b: N),
      (b <> 0)%N ->
      N.to_nat (a mod b)%N = (N.to_nat a) mod (N.to_nat b).
  Proof.
    intros.
    rewrite <-? N_to_Z_to_nat.
    rewrite N2Z.inj_mod by assumption.
    apply Nat2Z.inj.
    rewrite Zdiv.mod_Zmod.
    - rewrite? Z2Nat.id; try apply N2Z.is_nonneg.
      + reflexivity.
      + pose proof (Z.mod_pos_bound (Z.of_N a) (Z.of_N b)) as Q.
        destruct Q as [Q _].
        * destruct b; try contradiction. simpl. constructor.
        * exact Q.
    - destruct b; try contradiction. simpl.
      pose proof (Pos2Nat.is_pos p) as Q. lia.
  Qed.

End N2Nat.

Module Nat2Z.

  Lemma inj_pow: forall n m : nat,
      Z.of_nat (n ^ m) = (Z.of_nat n ^ Z.of_nat m)%Z.
  Proof.
    intros. induction m.
    - reflexivity.
    - rewrite Nat2Z.inj_succ.
      rewrite Z.pow_succ_r by (apply Nat2Z.is_nonneg).
      rewrite <- IHm.
      rewrite <- Nat2Z.inj_mul.
      reflexivity.
  Qed.

End Nat2Z.

Module Z2Nat.

  Lemma inj_pow: forall n m : Z,
      (0 <= n)%Z ->
      (0 <= m)%Z ->
      Z.to_nat (n ^ m) = Z.to_nat n ^ Z.to_nat m.
  Proof.
    intros.
    pose proof (Nat2Z.inj_pow (Z.to_nat n) (Z.to_nat m)) as P.
    rewrite? Z2Nat.id in P by assumption.
    rewrite <- P.
    apply Nat2Z.id.
  Qed.

End Z2Nat.


Require Import List.
Require Import Tactics.
Require Import Lists.
Require Import Id.
Import ListNotations.
Hint Constructors NoDup.

Fixpoint find_w (n: nat) (key: id) (l: list id) :=
  match l with
    | [] => None
    | (x :: xs) => if beq_id key x
                    then Some n
                    else find_w (S n) key xs
  end.

Definition find_where := (find_w 0).

Lemma notin_findwhere : forall x xs,
  ~In x xs -> find_where x xs = None.
Proof.
  intros. unfold find_where. generalize 0.
  induction xs.
  intros. reflexivity.
  intros.
  simpl in *.
  apply Decidable.not_or in H. destruct H.
  unfold find_where.
  simpl. rewrite not_eq_beq_id_false; auto.
Qed.

Lemma in_findwhere : forall x xs,
  In x xs -> exists i, find_where x xs = Some i.
Proof.
  intros. unfold find_where. generalize 0.
  induction xs.
    - inversion H.
    - intros; simpl. simpl in H. destruct H eqn:Eq.
      rewrite e. rewrite beq_id_refl. eauto.
      case beq_id. eauto. auto.
Qed.

Lemma find_w_S : forall xs n x i,
  find_w n x xs = Some i ->
  find_w (S n) x xs = Some (S i).
Proof.
  induction xs, n; intros; try (inversion H; auto).
  case beq_id eqn:Beq. inversion H1. simpl in *.
  apply beq_id_eq in Beq; rewrite Beq. rewrite beq_id_refl; auto.
  simpl. apply beq_id_false_neq in Beq.
  rewrite not_eq_beq_id_false in *; auto.
  clear H.
  simpl.
  case beq_id eqn:Beq. inversion H1. eauto. apply IHxs. auto.
Qed.

Lemma findwhere_ntherror : forall xs x i,
  NoDup xs ->
  nth_error xs i = Some x ->
  find_where x xs = Some i.
Proof.
  induction xs. intros; rewrite nth_error_nil in H0; inversion H0.
  intros.
  inversion H. clear H. subst.
  unfold find_where; simpl in *.
  case i in *.
    - inversion H0.  rewrite beq_id_refl. auto.
    - simpl in *. case beq_id eqn:Beq. apply beq_id_eq in Beq.
  rewrite Beq in H0. apply False_ind.
  apply H3. apply nth_error_In with i; auto. apply find_w_S. eapply IHxs; auto.
Qed.

Class Referable (A: Set) :={
ref : A -> id;
find: id -> list A -> option A :=
  let fix f (key: id) (l: list A) :=
  match l with
    | [] => None
    | (x :: xs) => if beq_id key (ref x)
                    then Some x
                    else f key xs
  end in f;
}.

Lemma find_deterministic: forall `{R: Referable} d (k1: id) x1 x2,
find k1 d = x1 ->
find k1 d = x2 ->
x1 = x2.
Proof with eauto.
  intros.
  destruct x1, x2;
  destruct (@find A) in *; auto with rewrite.
  rewrite <- H; auto.
  inversion H.
  inversion H0.
  inversion H.
Qed.

Lemma find_dec: forall `{R: Referable} d (k: id),
  {exists x, find k d = Some x} + {find k d = None}.
Proof.
  intros.
  induction d. crush.
  simpl.
  destruct beq_id_dec with (ref a) k.
  rewrite e. rewrite beq_id_refl; eauto.
  rewrite not_eq_beq_id_false; auto.
Qed.

Definition refs {A: Set} {R: Referable A} (x: list A) := (map ref x).

Hint Rewrite map_length.
Lemma refs_lenght: forall  (A: Set) (R: @Referable A) xs,
  length (refs xs) = length xs.
Proof. unfold refs; crush. Qed.
Hint Rewrite refs_lenght.

Inductive findi {A: Set} {R: @Referable A} : id -> list A -> A -> Prop:=
| find_head : forall x xs, findi (ref x) (x :: xs) (x)
| find_step : forall k1 k2 l x,
  k1 <> ref k2 -> findi k1 l x -> findi k1 (k2 :: l) x.

Lemma findi_diff: forall (A: Set) (R: @Referable A) k a v l,
k = ref a -> a <> v -> ~findi k (a :: l) v.
Proof.
  intros.
  intro.
  inversion H1; subst.
  apply H0; auto.
  apply H5; auto.
Qed.

Lemma find_iff_findi: forall (A: Set) (R: @Referable A) d (k1: id) (x1: A),
find k1 d = Some x1 <-> findi k1 d x1.
Proof.
  intros. split.
  intro H.
  induction d.
  inversion H.

  remember (ref a) as r.
  destruct beq_id_dec with (i1:= k1) (i2:= r); rewrite Heqr in *; clear Heqr.
  rewrite e in H; simpl in H. rewrite beq_id_refl in H.
  inversion H.
  rewrite e. rewrite H1.
  constructor.
  unfold find in H.
  rewrite not_eq_beq_id_false in H; auto.
  fold (@find A) in H.
  constructor.
  auto.
  apply IHd; auto.

  intro.
  induction H.
  simpl.
  rewrite beq_id_refl. auto.
  unfold find.
  rewrite not_eq_beq_id_false; auto.
Qed.

Lemma findi_none: forall (A: Set) (R: @Referable A) k l,
  find k l = None <-> (forall x, ~findi k l x).
Proof.
  intros.
  split. intro. intros. intro. destruct H0. simpl in H.
  rewrite beq_id_refl in H. inversion H.
  apply <- find_iff_findi in H1.
  simpl in H. rewrite not_eq_beq_id_false in H; auto. rewrite H1 in H; inversion H.
  intros. induction l. reflexivity.
  simpl in *. destruct beq_id_dec with k (ref a).
  false. subst. destruct H with a. apply find_head.
  rewrite not_eq_beq_id_false; auto. apply IHl.
  intros. intro. destruct H with x. apply find_step; auto.
Qed.

Lemma find_ref_inv: forall `{R: Referable} d (k: id) x,
  find k d = Some x ->
  ref x = k.
Proof.
  intros. apply find_iff_findi in H. induction H; crush.
Qed.

Lemma find_in: forall `{R: Referable} id xs x,
  find id xs = Some x ->
  In x xs.
Proof.
  intros.
  apply find_iff_findi in H. induction H; crush.
Qed.

Lemma Forall_find: forall `{R: Referable} P xs id x,
  Forall P xs ->
  find id xs = Some x ->
  P x.
Proof.
  intros.
  eapply Forall_forall in H; eauto.
  eapply find_in; eauto.
Qed.

Lemma in_imp_inref: forall {T} {H: Referable T} (xs:list T) x,
  In x xs ->
  In (ref x) (refs xs).
Proof.
  induction xs; crush.
Qed.

Lemma ref_noDup_nth_error: forall {T} {H: Referable T} (xs:list T) i i1 x x1,
  nth_error xs i = Some x ->
  nth_error xs i1 = Some x1 ->
  NoDup (refs xs) ->
  ref x = ref x1 ->
  x = x1.
Proof.
  induction xs; crush.
  destruct i; destruct i1; simpl in *; crush.
  rewrite H3 in H2. inversion H2. subst. clear H3.
  false. apply H5. apply nth_error_In in H1. apply in_imp_inref; eauto.
  rewrite <- H3 in H2. inversion H2. subst. false.
  apply H5. apply nth_error_In in H0. apply in_imp_inref; eauto.
  inversion H2.
  eapply IHxs; eauto.
Qed.