(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

Require Import ZArith_base.
Open Local Scope Z_scope.

(** Factorization lemmas *)

Theorem Zred_factor0 : forall n:Z, n = n * 1.
  intro x; rewrite (Zmult_1_r x); reflexivity.
Qed.

Theorem Zred_factor1 : forall n:Z, n + n = n * 2.
Proof.
  exact Zplus_diag_eq_mult_2.
Qed.

Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m).
Proof.
  intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x);
    rewrite <- Zmult_plus_distr_r; trivial with arith.
Qed.

Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m).
Proof.
  intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x);
    rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm;
      trivial with arith.
Qed.

Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p).
Proof.
  intros x y z; symmetry  in |- *; apply Zmult_plus_distr_r.
Qed.

Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m.
Proof.
  intros x y; rewrite <- Zmult_0_r_reverse; auto with arith.
Qed.

Theorem Zred_factor6 : forall n:Z, n = n + 0.
Proof.
  intro; rewrite Zplus_0_r; trivial with arith.
Qed.

(** Other specific variants of theorems dedicated for the Omega tactic *)

Lemma new_var : forall x : Z, exists y : Z, x = y.
intros x; exists x; trivial with arith.
Qed.

Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y.
intros x y H; rewrite H; auto with arith.
Qed.

Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y.
exact Zplus_le_0_compat.
Qed.

Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0.

intros x y k H1 H2 H3; apply (Zmult_integral_l k);
 [ unfold not in |- *; intros H4; absurd (k > 0);
    [ rewrite H4; unfold Zgt in |- *; simpl in |- *; discriminate
    | assumption ]
 | rewrite <- H2; assumption ].
Qed.

Lemma OMEGA4 : forall x y z : Z, x > 0 -> y > x -> z * y + x <> 0.

unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0);
 [ intros H4; cut (0 <= z * y + x);
    [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6;
       absurd (z * y + x > 0);
       [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate
       | apply Zle_gt_trans with x;
          [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x);
             apply Zplus_le_compat_r; rewrite Zmult_comm;
             generalize H4; unfold Zgt in |- *; case y;
             [ simpl in |- *; intros H7; discriminate H7
             | intros p H7; rewrite <- (Zmult_0_r (Zpos p));
                unfold Zle in |- *; rewrite Zcompare_mult_compat;
                exact H6
             | simpl in |- *; intros p H7; discriminate H7 ]
          | assumption ] ]
    | rewrite H3; unfold Zle in |- *; simpl in |- *; discriminate ]
 | apply Zgt_trans with x; [ assumption | assumption ] ].
Qed.

Lemma OMEGA5 : forall x y z : Z, x = 0 -> y = 0 -> x + y * z = 0.

intros x y z H1 H2; rewrite H1; rewrite H2; simpl in |- *; trivial with arith.
Qed.

Lemma OMEGA6 : forall x y z : Z, 0 <= x -> y = 0 -> 0 <= x + y * z.

intros x y z H1 H2; rewrite H2; simpl in |- *; rewrite Zplus_0_r; assumption.
Qed.

Lemma OMEGA7 :
 forall x y z t : Z, z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t.

intros x y z t H1 H2 H3 H4; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat;
 apply Zmult_gt_0_le_0_compat; assumption.
Qed.

Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0.

intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1);
 [ intros H4; absurd (0 < x);
    [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y;
       rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r;
       assumption
    | assumption ]
 | intros H4; rewrite H4; trivial with arith ].
Qed.

Lemma OMEGA9 : forall x y z t : Z, y = 0 -> x = z -> y + (- x + z) * t = 0.

intros x y z t H1 H2; rewrite H2; rewrite Zplus_opp_l; rewrite Zmult_0_l;
 rewrite Zplus_0_r; assumption.
Qed.

Lemma OMEGA10 :
 forall v c1 c2 l1 l2 k1 k2 : Z,
 (v * c1 + l1) * k1 + (v * c2 + l2) * k2 =
 v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2).

intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
 repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
 rewrite (Zplus_permute (l1 * k1) (v * c2 * k2)); trivial with arith.
Qed.

Lemma OMEGA11 :
 forall v1 c1 l1 l2 k1 : Z,
 (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2).

intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
 repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
 trivial with arith.
Qed.

Lemma OMEGA12 :
 forall v2 c2 l1 l2 k2 : Z,
 l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2).

intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
 repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
 rewrite Zplus_permute; trivial with arith.
Qed.

Lemma OMEGA13 :
 forall (v l1 l2 : Z) (x : positive),
 v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2.

intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1);
 rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
 rewrite <- Zopp_neg; rewrite (Zplus_comm (- Zneg x) (Zneg x));
 rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r;
 trivial with arith.
Qed.

Lemma OMEGA14 :
 forall (v l1 l2 : Z) (x : positive),
 v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2.

intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1);
 rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
 rewrite <- Zopp_neg; rewrite Zplus_opp_r; rewrite Zmult_0_r;
 rewrite Zplus_0_r; trivial with arith.
Qed.
Lemma OMEGA15 :
 forall v c1 c2 l1 l2 k2 : Z,
 v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2).

intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
 repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
 rewrite (Zplus_permute l1 (v * c2 * k2)); trivial with arith.
Qed.

Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k.

intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
 repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
 trivial with arith.
Qed.

Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.

unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1;
 apply Zplus_reg_l with (y * z); rewrite Zplus_comm;
 rewrite H3; rewrite H2; auto with arith.
Qed.

Lemma OMEGA18 : forall x y k : Z, x = y * k -> Zne x 0 -> Zne y 0.

unfold Zne, not in |- *; intros x y k H1 H2 H3; apply H2; rewrite H1;
 rewrite H3; auto with arith.
Qed.

Lemma OMEGA19 : forall x : Z, Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1.

unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x);
 [ intros H1; elim Zle_lt_or_eq with (1 := H1);
    [ intros H2; left; change (0 <= Zpred x) in |- *; apply Zsucc_le_reg;
       rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption
    | intros H2; absurd (x = 0); auto with arith ]
 | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm;
    apply Zle_left; apply Zsucc_le_reg; simpl in |- *;
    apply Zlt_le_succ; auto with arith ].
Qed.

Lemma OMEGA20 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.

unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; rewrite H2 in H3;
 simpl in H3; rewrite Zplus_0_r in H3; trivial with arith.
Qed.

Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop)
  (H : P (y + x)) := eq_ind_r P H (Zplus_comm x y).

Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop)
  (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p).

Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop)
  (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p).

Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop)
  (H : P (m + (n + p))) := eq_ind_r P H (Zplus_permute n m p).

Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop)
  (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) :=
  eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2).

Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop)
  (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) :=
  eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1).
Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop)
  (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) :=
  eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2).

Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop)
  (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) :=
  eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2).
Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop)
  (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k).

Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
  (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x).

Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
  (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x).
Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop)
  (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x).

Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop)
  (H : P (x * -1)) := eq_ind_r P H (Zopp_eq_mult_neg_1 x).

Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop)
  (H : P (y * x)) := eq_ind_r P H (Zmult_comm x y).

Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop)
  (H : P (- x + - y)) := eq_ind_r P H (Zopp_plus_distr x y).

Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) :=
  eq_ind_r P H (Zopp_involutive x).

Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop)
  (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y).

Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop)
  (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p).
Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop)
  (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y).

Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop)
  (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p).

Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop)
  (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x).

Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop)
  (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y).

Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop)
  (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y).

Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop)
  (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z).

Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop)
  (H : P y) := eq_ind_r P H (Zred_factor5 x y).

Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop)
  (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x).

Theorem intro_Z :
  forall n:nat,  exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0.
Proof.
  intros n; exists (Z_of_nat n); split; trivial.
  rewrite Zmult_1_r, Zplus_0_r. apply Zle_0_nat.
Qed.


(** * Generalities on the type of integers and integer arithmetic. Vladimir Voevodsky . Aug. - Sep. 2011.

In this file we introduce the type [ hz ] of integers defined as the quotient set of [ dirprod nat nat ] by the standard equivalence relation and develop the main notions of the integer arithmetic using this definition .

*)

(** ** Preamble *)

(** Settings *)

Unset Kernel Term Sharing.

(** Imports *)

Require Export UniMath.Foundations.NaturalNumbers.
Require Import UniMath.MoreFoundations.PartA.
Require Export UniMath.MoreFoundations.NegativePropositions.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.
Require Export UniMath.Algebra.RigsAndRings.
Require Export UniMath.NumberSystems.NaturalNumbersAlgebra.

(** Upstream *)

(** ** The commutative ring [ hz ] of integres *)

(** *** General definitions *)

Definition hz : commring := commrigtocommring natcommrig .
Definition hzaddabgr : abgr := hz .
Definition hzmultabmonoid : abmonoid := ringmultabmonoid hz .

Definition natnattohz : nat -> nat -> hz := λ n m, setquotpr _ ( make_dirprod n m ) .

Definition hzplus : hz -> hz -> hz := @op1 hz.
Definition hzsign : hz -> hz := grinv hzaddabgr .
Definition hzminus : hz -> hz -> hz := λ x y, hzplus x ( hzsign y ) .
Definition hzzero : hz := unel hzaddabgr .

Definition hzmult : hz -> hz -> hz := @op2 hz .
Definition hzone : hz := unel hzmultabmonoid .

Declare Scope hz_scope.
Bind Scope hz_scope with hz .
Notation " x + y " := ( hzplus x y ) : hz_scope .
Notation " 0 " := hzzero : hz_scope .
Notation " 1 " := hzone : hz_scope .
Notation " - x " := ( hzsign x ) : hz_scope .
Notation " x - y " := ( hzminus x y ) : hz_scope .
Notation " x * y " := ( hzmult x y ) : hz_scope .

Delimit Scope hz_scope with hz .

(** *** Properties of equlaity on [ hz ] *)

Theorem isdeceqhz : isdeceq hz .
Proof . change ( isdeceq ( abgrdiff ( rigaddabmonoid natcommrig ) ) ) . apply isdeceqabgrdiff . apply isinclnatplusr .  apply isdeceqnat .  Defined .
Opaque isdeceqhz.

Lemma isasethz : isaset hz .
Proof . apply ( setproperty hzaddabgr ) . Defined .
Opaque isasethz.

Definition hzeq ( x y : hz ) : hProp := make_hProp ( x = y ) ( isasethz _ _  )  .
Definition isdecrelhzeq : isdecrel hzeq  := λ a b, isdeceqhz a b .
Definition hzdeceq : decrel hz := make_decrel isdecrelhzeq .

(* Canonical Structure hzdeceq. *)

Definition hzbooleq := decreltobrel hzdeceq .

Definition hzneq ( x y : hz ) : hProp := make_hProp ( neg ( x = y ) ) ( isapropneg _  )  .
Definition isdecrelhzneq : isdecrel hzneq  := isdecnegrel _ isdecrelhzeq .
Definition hzdecneq : decrel hz := make_decrel isdecrelhzneq .

(* Canonical Structure hzdecneq. *)

Definition hzboolneq := decreltobrel hzdecneq .

Local Open Scope hz_scope .

(** *** [ hz ] is a non-zero ring *)

Lemma isnonzerorighz : isnonzerorig hz .
Proof . apply  ( ct ( hzneq , isdecrelhzneq, 1 , 0 ) ) . Defined .

(** *** Properties of addition and subtraction on [ hz ] *)

Definition hzminuszero : ( - 0 ) = 0 := ringinvunel1 hz .

Lemma hzplusr0 ( x : hz ) : ( x + 0 ) = x .
Proof . apply ( ringrunax1 _ x ) .  Defined .

Lemma hzplusl0 ( x : hz ) : ( 0 + x ) = x .
Proof . apply ( ringlunax1 _ x ) . Defined .

Lemma hzplusassoc ( x y z : hz ) : ( ( x + y ) + z ) = ( x + ( y + z ) ) .
Proof . intros . apply ( ringassoc1 hz x y z ) . Defined .

Lemma hzpluscomm ( x y : hz ) : ( x + y ) = ( y + x ) .
Proof . intros .  apply ( ringcomm1 hz x y ) . Defined .

Lemma hzlminus ( x : hz ) : ( -x + x ) = 0 .
Proof . apply ( ringlinvax1 hz x ) . Defined .

Lemma hzrminus  ( x : hz ) : ( x - x ) = 0 .
Proof . apply ( ringrinvax1 hz x ) . Defined .

Lemma isinclhzplusr ( n : hz ) : isincl ( λ m : hz, m + n ) .
Proof. apply ( pr2 ( weqtoincl ( weqrmultingr hzaddabgr n ) ) ) . Defined.

Lemma isinclhzplusl ( n : hz ) : isincl ( λ m : hz, n + m ) .
Proof. apply ( pr2 ( weqtoincl ( weqlmultingr hzaddabgr n ) ) ) . Defined .

Lemma hzpluslcan ( a b c : hz ) ( is : ( c + a ) = ( c + b ) ) : a = b .
Proof . intros . apply ( @grlcan hzaddabgr a b c is ) .  Defined .

Lemma hzplusrcan ( a b c : hz ) ( is : ( a + c ) = ( b + c ) ) : a = b .
Proof . intros . apply ( @grrcan hzaddabgr a b c is ) .  Defined .

Definition hzinvmaponpathsminus { a b : hz } ( e : ( - a ) = ( - b ) ) : a = b := grinvmaponpathsinv hzaddabgr e .

Lemma hzrplusminus (n m : hz) : n + m - m = n.
Proof.
  unfold hzminus, hzplus, hzplus. rewrite ringassoc1.
  set (tmp := hzrminus m). unfold hzminus, hzplus in tmp. rewrite tmp. clear tmp.
  apply hzplusr0.
Defined.
Opaque hzrplusminus.

Lemma hzrplusminus' (n m : hz) : n = n + m - m.
Proof.
  apply pathsinv0. apply hzrplusminus.
Defined.
Opaque hzrplusminus'.

Lemma hzrminusplus (n m : hz) : n - m + m = n.
Proof.
  unfold hzplus, hzminus. rewrite ringassoc1.
  rewrite hzlminus. apply hzplusr0.
Defined.
Opaque hzrminusplus.

Lemma hzrminusplus' (n m : hz) : n = n - m + m.
Proof.
  apply pathsinv0. apply hzrminusplus.
Defined.
Opaque hzrminusplus'.

(** *** Properties of multiplication on [ hz ] *)

Lemma hzmultr1 ( x : hz ) : ( x * 1 ) = x .
Proof . apply ( ringrunax2 _ x ) .  Defined .

Lemma hzmultl1 ( x : hz ) : ( 1 * x ) = x .
Proof . apply ( ringlunax2 _ x ) . Defined .

Lemma hzmult0x ( x : hz ) : ( 0 * x ) = 0 .
Proof . apply ( ringmult0x _ x ) .  Defined .

Lemma hzmultx0 ( x : hz ) : ( x * 0 ) = 0 .
Proof . apply ( ringmultx0 _ x ) . Defined .

Lemma hzmultassoc ( x y z : hz ) : ( ( x * y ) * z ) = ( x * ( y * z ) ) .
Proof . intros . apply ( ringassoc2 hz x y z ) . Defined .

Lemma hzmultcomm ( x y : hz ) : ( x * y ) = ( y * x ) .
Proof . intros .  apply ( ringcomm2 hz  x y ) . Defined .

Definition hzneq0andmultlinv ( n m : hz ) ( isnm : hzneq ( n * m ) 0 ) : hzneq n 0 := ringneq0andmultlinv hz n m isnm .

Definition hzneq0andmultrinv ( n m : hz ) ( isnm : hzneq ( n * m ) 0 ) : hzneq m 0 := ringneq0andmultrinv hz n m isnm .

(** ** Definition and properties of "greater", "less", "greater or equal" and "less or equal" on [ hz ] . *)

(** *** Definitions and notations *)

Definition hzgth : hrel hz := rigtoringrel natcommrig isplushrelnatgth .

Definition hzlth : hrel hz := λ a b, hzgth b a .

Definition hzleh : hrel hz := λ a b, make_hProp ( neg ( hzgth a b ) ) ( isapropneg _ )  .

Definition hzgeh : hrel hz := λ a b, make_hProp ( neg ( hzgth b a ) ) ( isapropneg _ )  .

(** *** Decidability *)

Lemma isdecrelhzgth : isdecrel hzgth .
Proof . apply ( isdecrigtoringrel natcommrig isplushrelnatgth  ) .  apply isinvplushrelnatgth . apply isdecrelnatgth . Defined .

Definition hzgthdec := make_decrel isdecrelhzgth .

(* Canonical Structure hzgthdec . *)

Definition isdecrelhzlth : isdecrel hzlth := λ x x', isdecrelhzgth x' x .

Definition hzlthdec := make_decrel isdecrelhzlth .

(* Canonical Structure hzlthdec . *)

Definition isdecrelhzleh : isdecrel hzleh := isdecnegrel _ isdecrelhzgth .

Definition hzlehdec := make_decrel isdecrelhzleh .

(* Canonical Structure hzlehdec . *)

Definition isdecrelhzgeh : isdecrel hzgeh := λ x x', isdecrelhzleh x' x .

Definition hzgehdec := make_decrel isdecrelhzgeh .

(* Canonical Structure hzgehdec . *)

(** *** Properties of individual relations *)

(** [ hzgth ] *)

Lemma istranshzgth ( n m k : hz ) : hzgth n m -> hzgth m k -> hzgth n k .
Proof. apply ( istransabgrdiffrel nataddabmonoid isplushrelnatgth )  .  unfold istrans .  apply istransnatgth .  Defined.

Lemma isirreflhzgth ( n : hz ) : neg ( hzgth n n ) .
Proof. apply ( isirreflabgrdiffrel nataddabmonoid isplushrelnatgth )  . unfold isirrefl .  apply isirreflnatgth .   Defined .

Lemma hzgthtoneq ( n m : hz ) ( g : hzgth n m ) : neg ( n = m ) .
Proof . intros . intro e . rewrite e in g . apply ( isirreflhzgth _ g ) . Defined .

Lemma isasymmhzgth ( n m : hz ) : hzgth n m -> hzgth m n -> empty .
Proof. apply ( isasymmabgrdiffrel nataddabmonoid isplushrelnatgth )  . unfold isasymm .  apply isasymmnatgth .  Defined .

Lemma isantisymmneghzgth ( n m : hz ) : neg ( hzgth n m ) -> neg ( hzgth m n ) -> n = m .
Proof . apply ( isantisymmnegabgrdiffrel nataddabmonoid isplushrelnatgth )  . unfold isantisymmneg .  apply isantisymmnegnatgth .   Defined .

Lemma isnegrelhzgth : isnegrel hzgth .
Proof . apply isdecreltoisnegrel . apply isdecrelhzgth . Defined .

Lemma iscoantisymmhzgth ( n m : hz ) : neg ( hzgth n m ) -> ( hzgth m n ) ⨿ ( n = m ) .
Proof . revert n m. apply isantisymmnegtoiscoantisymm . apply isdecrelhzgth .  intros n m . apply isantisymmneghzgth . Defined .

Lemma iscotranshzgth ( n m k : hz ) : hzgth n k -> hdisj ( hzgth n m ) ( hzgth m k ) .
Proof . intros gxz .  destruct ( isdecrelhzgth n m ) as [ gxy | ngxy ] . apply ( hinhpr ( ii1 gxy ) ) . apply hinhpr .   apply ii2 .  destruct ( isdecrelhzgth m n ) as [ gyx | ngyx ] . apply ( istranshzgth _ _ _ gyx gxz ) .  set ( e := isantisymmneghzgth _ _ ngxy ngyx ) . rewrite e in gxz .  apply gxz .  Defined .

(** [ hzlth ] *)

Definition istranshzlth ( n m k  : hz ) : hzlth n m -> hzlth m k -> hzlth n k := λ lnm lmk, istranshzgth _ _ _ lmk lnm .

Definition isirreflhzlth ( n : hz ) : neg ( hzlth n n ) := isirreflhzgth n .

Lemma hzlthtoneq ( n m : hz ) ( g : hzlth n m ) : neg ( n = m ) .
Proof . intros . intro e . rewrite e in g . apply ( isirreflhzlth _ g ) . Defined .

Definition isasymmhzlth ( n m : hz ) : hzlth n m -> hzlth m n -> empty := λ lnm lmn, isasymmhzgth _ _ lmn lnm .

Definition isantisymmneghztth  ( n m : hz ) : neg ( hzlth n m ) -> neg ( hzlth m n ) -> n = m := λ nlnm nlmn, isantisymmneghzgth _ _ nlmn nlnm .

Definition isnegrelhzlth : isnegrel hzlth := λ n m, isnegrelhzgth m n .

Definition iscoantisymmhzlth ( n m : hz ) : neg ( hzlth n m ) -> ( hzlth m n ) ⨿ ( n = m ) .
Proof . intros nlnm . destruct ( iscoantisymmhzgth m n nlnm ) as [ l | e ] . apply ( ii1 l ) . apply ( ii2 ( pathsinv0 e ) ) . Defined .

Definition iscotranshzlth ( n m k : hz ) : hzlth n k -> hdisj ( hzlth n m ) ( hzlth m k ) .
Proof . intros lnk . apply ( ( pr1 islogeqcommhdisj ) ( iscotranshzgth _ _ _ lnk ) )  .  Defined .

(**  [ hzleh ] *)

Definition  istranshzleh ( n m k : hz ) : hzleh n m -> hzleh m k -> hzleh n k .
Proof. apply istransnegrel . unfold iscotrans. apply iscotranshzgth .  Defined.

Definition isreflhzleh ( n : hz ) : hzleh n n := isirreflhzgth n .

Definition isantisymmhzleh ( n m : hz ) : hzleh n m -> hzleh m n -> n = m := isantisymmneghzgth n m .

Definition isnegrelhzleh : isnegrel hzleh .
Proof . apply isdecreltoisnegrel . apply isdecrelhzleh . Defined .

Definition iscoasymmhzleh ( n m : hz ) ( nl : neg ( hzleh n m ) ) : hzleh m n := negf ( isasymmhzgth _ _ ) nl .

Definition istotalhzleh : istotal hzleh .
Proof . intros x y . destruct ( isdecrelhzleh x y ) as [ lxy | lyx ] . apply ( hinhpr ( ii1 lxy ) ) . apply hinhpr .   apply ii2 . apply ( iscoasymmhzleh _ _ lyx ) .   Defined .

(**  [ hzgeh ] . *)

Definition istranshzgeh ( n m k : hz ) : hzgeh n m -> hzgeh m k -> hzgeh n k := λ gnm gmk, istranshzleh _ _ _ gmk gnm .

Definition isreflhzgeh ( n : hz ) : hzgeh n n := isreflhzleh _ .

Definition isantisymmhzgeh ( n m : hz ) : hzgeh n m -> hzgeh m n -> n = m := λ gnm gmn, isantisymmhzleh _ _ gmn gnm .

Definition isnegrelhzgeh : isnegrel hzgeh := λ n m, isnegrelhzleh m n .

Definition iscoasymmhzgeh ( n m : hz ) ( nl : neg ( hzgeh n m ) ) : hzgeh m n := iscoasymmhzleh _ _ nl .

Definition istotalhzgeh : istotal hzgeh := λ n m, istotalhzleh m n .

(** *** Simple implications between comparisons *)

Definition hzgthtogeh ( n m : hz ) : hzgth n m -> hzgeh n m .
Proof. intros g . apply iscoasymmhzgeh . apply ( todneg _ g ) . Defined .

Definition hzlthtoleh ( n m : hz ) : hzlth n m -> hzleh n m := hzgthtogeh _ _ .

Definition hzlehtoneghzgth ( n m : hz ) : hzleh n m -> neg ( hzgth n m )  .
Proof. intros is is' . apply ( is is' ) .  Defined .

Definition  hzgthtoneghzleh ( n m : hz ) : hzgth n m -> neg ( hzleh n m ) := λ g l , hzlehtoneghzgth _ _ l g .

Definition hzgehtoneghzlth ( n m : hz ) : hzgeh n m -> neg ( hzlth n m ) := λ gnm lnm, hzlehtoneghzgth _ _ gnm lnm .

Definition hzlthtoneghzgeh ( n m : hz ) : hzlth n m -> neg ( hzgeh n m ) := λ gnm lnm, hzlehtoneghzgth _ _ lnm gnm .

Definition neghzlehtogth ( n m : hz ) : neg ( hzleh n m ) -> hzgth n m := isnegrelhzgth n m .

Definition neghzgehtolth ( n m : hz ) : neg ( hzgeh n m ) -> hzlth n m := isnegrelhzlth n m .

Definition neghzgthtoleh ( n m : hz ) : neg ( hzgth n m ) -> hzleh n m .
Proof . intros ng . destruct ( isdecrelhzleh n m ) as [ l | nl ] . apply l . destruct ( nl ng ) .  Defined .

Definition neghzlthtogeh ( n m : hz ) : neg ( hzlth n m ) -> hzgeh n m := λ nl, neghzgthtoleh _ _ nl .

(** *** Comparison alternatives *)

Definition hzgthorleh ( n m : hz ) : ( hzgth n m ) ⨿ ( hzleh n m ) .
Proof . intros . apply ( isdecrelhzgth n m ) .  Defined .

Definition hzlthorgeh ( n m : hz ) : ( hzlth n m ) ⨿ ( hzgeh n m ) := hzgthorleh _ _ .

Definition hzneqchoice ( n m : hz ) ( ne : neg ( n = m ) ) : ( hzgth n m ) ⨿ ( hzlth n m ) .
Proof . intros . destruct ( hzgthorleh n m ) as [ g | l ]  .  destruct ( hzlthorgeh n m ) as [ g' | l' ] . destruct ( isasymmhzgth _ _ g g' )  .  apply ( ii1 g ) . destruct ( hzlthorgeh n m ) as [ l' | g' ] . apply ( ii2 l' ) . destruct ( ne ( isantisymmhzleh _ _ l g' ) ) . Defined .

Definition hzlehchoice ( n m : hz ) ( l : hzleh n m ) : ( hzlth n m ) ⨿ ( n = m ) .
Proof .  intros . destruct ( hzlthorgeh n m ) as [ l' | g ] .   apply ( ii1 l' ) . apply ( ii2 ( isantisymmhzleh _ _ l g ) ) . Defined .

Definition hzgehchoice ( n m : hz ) ( g : hzgeh n m ) : ( hzgth n m ) ⨿ ( n = m ) .
Proof .  intros . destruct ( hzgthorleh n m ) as [ g' | l ] .  apply ( ii1 g' ) .  apply ( ii2 ( isantisymmhzleh _ _ l g ) ) .  Defined .

(** *** Mixed transitivities *)

Lemma hzgthgehtrans ( n m k : hz ) : hzgth n m -> hzgeh m k -> hzgth n k .
Proof. intros gnm gmk . destruct ( hzgehchoice m k gmk ) as [ g' | e ] . apply ( istranshzgth _ _ _ gnm g' ) .  rewrite e in gnm  .  apply gnm . Defined.

Lemma hzgehgthtrans ( n m k : hz ) : hzgeh n m -> hzgth m k -> hzgth n k .
Proof. intros gnm gmk . destruct ( hzgehchoice n m gnm ) as [ g' | e ] . apply ( istranshzgth _ _ _ g' gmk ) .  rewrite e .  apply gmk . Defined.

Lemma hzlthlehtrans ( n m k : hz ) : hzlth n m -> hzleh m k -> hzlth n k .
Proof . intros l1 l2 . apply ( hzgehgthtrans k m n l2 l1 ) . Defined .

Lemma hzlehlthtrans ( n m k : hz ) : hzleh n m -> hzlth m k -> hzlth n k .
Proof . intros l1 l2 . apply ( hzgthgehtrans k m n l2 l1 ) . Defined .

(** *** Addition and comparisons  *)

(** [ hzgth ] *)

Definition hzgthandplusl ( n m k : hz ) : hzgth n m -> hzgth ( k + n ) ( k + m ) .
Proof. apply ( pr1 ( isbinopabgrdiffrel nataddabmonoid isplushrelnatgth ) ) .   Defined .

Definition hzgthandplusr ( n m k : hz ) : hzgth n m -> hzgth ( n + k ) ( m + k ) .
Proof. apply ( pr2 ( isbinopabgrdiffrel nataddabmonoid isplushrelnatgth ) ) .  Defined .

Definition hzgthandpluslinv  ( n m k : hz ) : hzgth ( k + n ) ( k + m ) -> hzgth n m  .
Proof. intros g . set ( g' := hzgthandplusl _ _ ( - k ) g ) . clearbody g' . rewrite ( pathsinv0 ( hzplusassoc _ _ n ) ) in g' . rewrite ( pathsinv0 ( hzplusassoc _ _ m ) ) in g' .  rewrite ( hzlminus k ) in g' . rewrite ( hzplusl0 _ ) in g' .   rewrite ( hzplusl0 _ ) in g' . apply g' .  Defined .

Definition hzgthandplusrinv ( n m k : hz ) :  hzgth ( n + k ) ( m + k ) -> hzgth n m  .
Proof. intros l . rewrite ( hzpluscomm n k ) in l . rewrite ( hzpluscomm m k ) in l . apply ( hzgthandpluslinv _ _ _ l )  . Defined .

Lemma hzgthsnn ( n : hz ) : hzgth ( n + 1 ) n .
Proof . set ( int := hzgthandplusl _ _ n ( ct ( hzgth , isdecrelhzgth, 1 , 0 ) ) ) . clearbody int . rewrite ( hzplusr0 _ ) in int .   apply int . Defined .

(** [ hzlth ] *)

Definition hzlthandplusl ( n m k : hz ) : hzlth n m -> hzlth ( k + n ) ( k + m )  := hzgthandplusl _ _ _ .

Definition hzlthandplusr ( n m k : hz ) : hzlth n m -> hzlth ( n + k ) ( m + k ) := hzgthandplusr _ _ _ .

Definition hzlthandpluslinv  ( n m k : hz ) : hzlth ( k + n ) ( k + m ) -> hzlth n m := hzgthandpluslinv _ _ _ .

Definition hzlthandplusrinv ( n m k : hz ) :  hzlth ( n + k ) ( m + k ) -> hzlth n m := hzgthandplusrinv _ _ _ .

Definition hzlthnsn ( n : hz ) : hzlth n ( n + 1 ) := hzgthsnn n .

(** [ hzleh ] *)

Definition hzlehandplusl ( n m k : hz ) : hzleh n m -> hzleh ( k + n ) ( k + m ) := negf ( hzgthandpluslinv n m k )  .

Definition hzlehandplusr ( n m k : hz ) : hzleh n m -> hzleh ( n + k ) ( m + k ) := negf ( hzgthandplusrinv n m k )  .

Definition hzlehandpluslinv  ( n m k : hz ) : hzleh ( k + n ) ( k + m ) -> hzleh n m := negf ( hzgthandplusl n m k )  .

Definition hzlehandplusrinv ( n m k : hz ) :  hzleh ( n + k ) ( m + k ) -> hzleh n m :=  negf ( hzgthandplusr n m k ) .

(** [ hzgeh ] *)

Definition hzgehandplusl ( n m k : hz ) : hzgeh n m -> hzgeh ( k + n ) ( k + m ) := negf ( hzgthandpluslinv m n k ) .

Definition hzgehandplusr ( n m k : hz ) : hzgeh n m -> hzgeh ( n + k ) ( m + k ) := negf ( hzgthandplusrinv m n k )  .

Definition hzgehandpluslinv  ( n m k : hz ) : hzgeh ( k + n ) ( k + m ) -> hzgeh n m := negf ( hzgthandplusl m n k )  .

Definition hzgehandplusrinv ( n m k : hz ) :  hzgeh ( n + k ) ( m + k ) -> hzgeh n m :=  negf ( hzgthandplusr m n k ) .

(** *** Properties of [ hzgth ] in the terminology of  algebra1.v (continued below)

Note: at the moment we do not need properties of [ hzlth ] , [ hzleh ] and [ hzgeh ] in terminology of algebra1 since the corresponding relations on [ hq ] are bulid from [ hqgth ] . *)

Lemma isplushrelhzgth : @isbinophrel hzaddabgr hzgth .
Proof . split . apply  hzgthandplusl .  apply hzgthandplusr .  Defined .

Lemma isinvplushrelhzgth : @isinvbinophrel hzaddabgr hzgth .
Proof . split . apply  hzgthandpluslinv .  apply hzgthandplusrinv .  Defined .

Lemma isringmulthzgth : isringmultgt _ hzgth .
Proof . apply ( isringrigtoringmultgt natcommrig isplushrelnatgth isrigmultgtnatgth )  . Defined .

Lemma  isinvringmulthzgth : isinvringmultgt _ hzgth .
Proof . apply ( isinvringrigtoringmultgt natcommrig isplushrelnatgth isinvplushrelnatgth isinvrigmultgtnatgth ) . Defined .

(** *** Negation and comparisons *)

(** [ hzgth ] *)

Lemma hzgth0andminus  { n : hz } ( is : hzgth n 0 ) : hzlth ( - n ) 0 .
Proof . intros . apply ( ringfromgt0 hz isplushrelhzgth ) . apply is . Defined .

Lemma hzminusandgth0  { n : hz } ( is : hzgth ( - n ) 0 ) : hzlth n 0 .
Proof . intros . apply ( ringtolt0 hz isplushrelhzgth ) . apply is . Defined .

(** [ hzlth ] *)

Lemma hzlth0andminus  { n : hz } ( is : hzlth n 0 ) : hzgth ( - n ) 0 .
Proof . intros . apply ( ringfromlt0 hz isplushrelhzgth ) . apply is . Defined .

Lemma hzminusandlth0  { n : hz } ( is : hzlth ( - n ) 0 ) : hzgth n 0 .
Proof . intros .  apply ( ringtogt0 hz isplushrelhzgth ) . apply is . Defined .

(* ??? Coq slows down on the proofs of these two lemmas for no good reason. *)

(** [ hzleh ] *)

Lemma hzleh0andminus  { n : hz } ( is : hzleh n 0 ) : hzgeh ( - n ) 0 .
Proof . revert is. apply ( negf ( @hzminusandlth0 n ) ) . Defined .

Lemma hzminusandleh0  { n : hz } ( is : hzleh ( - n ) 0 ) : hzgeh n 0 .
Proof . revert is. apply ( negf ( @hzlth0andminus n ) ) . Defined .

(** [ hzgeh ] *)

Lemma hzgeh0andminus  { n : hz } ( is : hzgeh n 0 ) : hzleh ( - n ) 0 .
Proof . revert is . apply ( negf ( @hzminusandgth0 n ) ) . Defined .

Lemma hzminusandgeh0  { n : hz } ( is : hzgeh ( - n ) 0 ) : hzleh n 0 .
Proof . revert is . apply ( negf ( @hzgth0andminus n ) ) . Defined .

(** *** Multiplication and comparisons  *)

(** [ hzgth ] *)

Definition hzgthandmultl ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth n m -> hzgth ( k * n ) ( k * m ) .
Proof. revert n m k is. apply ( isringmultgttoislringmultgt _ isplushrelhzgth isringmulthzgth ) .   Defined .

Definition hzgthandmultr ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth n m -> hzgth ( n * k ) ( m * k )  .
Proof . revert n m k is. apply ( isringmultgttoisrringmultgt _ isplushrelhzgth isringmulthzgth ) . Defined .

Definition  hzgthandmultlinv ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth ( k * n ) ( k * m ) -> hzgth n m .
Proof . intros is' .  apply ( isinvringmultgttoislinvringmultgt hz isplushrelhzgth isinvringmulthzgth n m k is is' ) .  Defined .

Definition hzgthandmultrinv ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth ( n * k ) ( m * k ) -> hzgth n m .
Proof.   intros is' .  apply ( isinvringmultgttoisrinvringmultgt hz isplushrelhzgth isinvringmulthzgth n m k is is' ) .  Defined .

(** [ hzlth ] *)

Definition hzlthandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzlth n m -> hzlth ( k * n ) ( k * m )  := hzgthandmultl _ _ _ is .

Definition hzlthandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzlth n m -> hzlth ( n * k ) ( m * k ) := hzgthandmultr _ _ _ is .

Definition hzlthandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzlth ( k * n ) ( k * m ) -> hzlth n m := hzgthandmultlinv _ _ _ is .

Definition hzlthandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzlth ( n * k ) ( m * k ) -> hzlth n m := hzgthandmultrinv _ _ _ is .

(** [ hzleh ] *)

Definition hzlehandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzleh n m -> hzleh ( k * n ) ( k * m ) := negf ( hzgthandmultlinv _ _ _ is ) .

Definition hzlehandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzleh n m -> hzleh ( n * k ) ( m * k ) := negf ( hzgthandmultrinv _ _ _ is ) .

Definition hzlehandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzleh ( k * n ) ( k * m ) -> hzleh n m := negf ( hzgthandmultl _ _ _ is )  .

Definition hzlehandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzleh ( n * k ) ( m * k ) -> hzleh n m := negf ( hzgthandmultr _ _ _ is ) .

(** [ hzgeh ] *)

Definition hzgehandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh n m -> hzgeh ( k * n ) ( k * m ) := negf ( hzgthandmultlinv _ _ _ is ) .

Definition hzgehandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh n m -> hzgeh ( n * k ) ( m * k )  := negf ( hzgthandmultrinv _ _ _ is ) .

Definition hzgehandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh ( k * n ) ( k * m ) -> hzgeh n m := negf ( hzgthandmultl _ _ _ is )   .

Definition hzgehandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh ( n * k ) ( m * k ) -> hzgeh n m := negf ( hzgthandmultr _ _ _ is )  .

(** Multiplication of positive with positive, positive with negative, negative with positive, two negatives etc. *)

Lemma hzmultgth0gth0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzgth n 0 ) : hzgth ( m * n ) 0 .
Proof . intros . apply isringmulthzgth . apply ism . apply isn . Defined .

Lemma hzmultgth0geh0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzgeh n 0 ) : hzgeh ( m * n ) 0 .
Proof . intros .  destruct ( hzgehchoice _ _ isn ) as [ gn | en ] .

apply ( hzgthtogeh _ _ ( hzmultgth0gth0  ism gn ) ) .

rewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined .

Lemma hzmultgeh0gth0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzgth n 0 ) : hzgeh ( m * n ) 0 .
Proof .  intros .  destruct ( hzgehchoice _ _ ism ) as [ gm | em ] .

apply ( hzgthtogeh _ _ ( hzmultgth0gth0 gm isn ) ) .

rewrite em .  rewrite ( hzmult0x _ ) . apply isreflhzgeh . Defined .

Lemma hzmultgeh0geh0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzgeh n 0 ) : hzgeh ( m * n ) 0 .
Proof . intros .   destruct ( hzgehchoice _ _ isn ) as [ gn | en ] .

apply ( hzmultgeh0gth0 ism gn ) .

rewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined .

Lemma hzmultgth0lth0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzlth n 0 ) : hzlth ( m * n ) 0 .
Proof . intros . apply ( ringmultgt0lt0 hz isplushrelhzgth isringmulthzgth ) . apply ism . apply isn . Defined .

Lemma hzmultgth0leh0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzleh n 0 ) : hzleh ( m * n ) 0 .
Proof . intros .  destruct ( hzlehchoice _ _ isn ) as [ ln | en ] .

apply ( hzlthtoleh _ _ ( hzmultgth0lth0  ism ln ) ) .

rewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzleh . Defined .

Lemma hzmultgeh0lth0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzlth n 0 ) : hzleh ( m * n ) 0 .
Proof .  intros .  destruct ( hzlehchoice _ _ ism ) as [ lm | em ] .

apply ( hzlthtoleh _ _ ( hzmultgth0lth0 lm isn ) ) .

destruct em .  rewrite ( hzmult0x _ ) . apply isreflhzleh . Defined .

Lemma hzmultgeh0leh0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzleh n 0 ) : hzleh ( m * n ) 0 .
Proof . intros .   destruct ( hzlehchoice _ _ isn ) as [ ln | en ] .

apply ( hzmultgeh0lth0 ism ln ) .

rewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzleh . Defined .

Lemma hzmultlth0gth0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzgth n 0 ) : hzlth ( m * n ) 0 .
Proof . intros . rewrite ( hzmultcomm ) .  apply hzmultgth0lth0 . apply isn . apply ism .  Defined .

Lemma hzmultlth0geh0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzgeh n 0 ) : hzleh ( m * n ) 0 .
Proof . intros . rewrite ( hzmultcomm ) .  apply hzmultgeh0lth0 . apply isn . apply ism .  Defined .

Lemma hzmultleh0gth0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzgth n 0 ) : hzleh ( m * n ) 0 .
Proof . intros . rewrite ( hzmultcomm ) .  apply hzmultgth0leh0 . apply isn . apply ism .  Defined .

Lemma hzmultleh0geh0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzgeh n 0 ) : hzleh ( m * n ) 0 .
Proof . intros . rewrite ( hzmultcomm ) .  apply hzmultgeh0leh0 . apply isn . apply ism .  Defined .

Lemma hzmultlth0lth0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzlth n 0 ) : hzgth ( m * n ) 0 .
Proof . intros . assert ( ism' := hzlth0andminus ism ) .  assert ( isn' := hzlth0andminus isn ) . assert ( int := isringmulthzgth _ _ ism' isn' ) . rewrite ( ringmultminusminus hz ) in int .  apply int . Defined .

Lemma hzmultlth0leh0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzleh n 0 ) : hzgeh ( m * n ) 0 .
Proof . intros . intros .  destruct ( hzlehchoice _ _ isn ) as [ ln | en ] .

apply ( hzgthtogeh _ _ ( hzmultlth0lth0  ism ln ) ) .

rewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined .

Lemma hzmultleh0lth0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzlth n 0 ) : hzgeh ( m * n ) 0 .
Proof . intros . destruct ( hzlehchoice _ _ ism ) as [ lm | em ] .

apply ( hzgthtogeh _ _ ( hzmultlth0lth0 lm isn ) ) .

rewrite em .  rewrite ( hzmult0x _ ) . apply isreflhzgeh .  Defined .

Lemma hzmultleh0leh0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzleh n 0 ) : hzgeh ( m * n ) 0 .
Proof . intros .  destruct ( hzlehchoice _ _ isn ) as [ ln | en ] .

apply ( hzmultleh0lth0 ism ln ) .

rewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzgeh .   Defined .

(** *** [ hz ] as an integral domain *)

Lemma isintdomhz : isintdom hz .
Proof . split with isnonzerorighz .  intros a b e0 .  destruct ( isdeceqhz a 0 ) as [ ea | nea ] .  apply ( hinhpr ( ii1 ea ) ) . destruct ( isdeceqhz b 0 ) as [ eb | neb ] . apply ( hinhpr ( ii2 eb ) ) .  destruct ( hzneqchoice _ _ nea ) as [ ga | la ] .  destruct ( hzneqchoice _ _ neb ) as [ gb | lb ] . destruct ( hzgthtoneq _ _ ( hzmultgth0gth0 ga gb ) e0 ) .  destruct ( hzlthtoneq _ _ ( hzmultgth0lth0 ga lb ) e0 ) .  destruct ( hzneqchoice _ _ neb ) as [ gb | lb ] .  destruct ( hzlthtoneq _ _ ( hzmultlth0gth0 la gb ) e0 ) .  destruct ( hzgthtoneq _ _ ( hzmultlth0lth0 la lb ) e0 ) .  Defined .

Definition hzintdom : intdom := tpair _ _ isintdomhz .

Definition hzneq0andmult ( n m : hz ) ( isn : hzneq n 0 ) ( ism : hzneq m 0 ) : hzneq ( n * m ) 0 := intdomneq0andmult hzintdom n m isn ism .

Lemma hzmultlcan ( a b c : hz ) ( ne : neg ( c = 0 ) ) ( e : ( c * a ) = ( c * b ) ) : a = b .
Proof . intros . apply ( intdomlcan hzintdom _ _ _ ne e ) . Defined .

Lemma hzmultrcan ( a b c : hz ) ( ne : neg ( c = 0 ) ) ( e : ( a * c ) = ( b * c ) ) : a = b .
Proof . intros . apply ( intdomrcan hzintdom _ _ _ ne e ) . Defined .

Lemma isinclhzmultl ( n : hz )( ne : neg ( n = 0 ) ) : isincl ( λ m : hz, n * m ) .
Proof.  intros .  apply ( pr1 ( intdomiscancelable hzintdom n ne ) ) . Defined .

Lemma isinclhzmultr ( n : hz )( ne : neg ( n = 0 ) ) : isincl ( λ m : hz, m * n ) .
Proof. intros . apply ( pr2 ( intdomiscancelable hzintdom n ne ) ) . Defined.

(** *** Comparisons and [ n -> n + 1 ] *)

Definition hzgthtogths ( n m : hz ) : hzgth n m -> hzgth ( n + 1 ) m  .
Proof. intros is . apply ( istranshzgth _ _ _ ( hzgthsnn n ) is ) . Defined .

Definition hzlthtolths ( n m : hz ) : hzlth n m -> hzlth n ( m + 1 ) := hzgthtogths _ _ .

Definition hzlehtolehs ( n m : hz ) : hzleh n m -> hzleh n ( m + 1 ) .
Proof . intros is . apply ( istranshzleh _ _ _ is ( hzlthtoleh _ _ ( hzlthnsn _ ) ) ) . Defined .

Definition hzgehtogehs ( n m : hz ) : hzgeh n m -> hzgeh ( n + 1 ) m := hzlehtolehs _ _  .

(** *** Two comparisons and [ n -> n + 1 ] *)

Lemma hzgthtogehsn ( n m : hz ) : hzgth n m -> hzgeh n ( m + 1 ) .
Proof. assert ( int : ∏ n m , isaprop ( hzgth n m -> hzgeh n ( m + 1 )  ) ) .
       { intros . apply impred . intro . apply ( pr2 _ ) . }
       unfold hzgth in * .  apply ( setquotuniv2prop _ ( λ n m, make_hProp _ ( int n m ) ) ) . set ( R := abgrdiffrelint nataddabmonoid natgth ) .
       intros x x' .  change ( R x x' -> ( neg ( R ( @op ( abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig) ) x' ( make_dirprod 1%nat 0%nat ) ) x ) ) ) .
       unfold R . unfold abgrdiffrelint . simpl .
       apply ( @hinhuniv _  (make_hProp ( neg ( ishinh_UU _ ) ) ( isapropneg _ ) ) ) .
       intro t2 . simpl . unfold neg .  apply ( @hinhuniv _ ( make_hProp _ isapropempty ) ) .
       intro t2' .
       set ( x1 := pr1 x ) . set ( a1 := pr2 x ) . set ( x2 := pr1 x' ) .
       set ( a2 := pr2 x' ) . set ( c1 := pr1 t2 ) . assert ( r1 := pr2 t2 ) .
       change ( pr1 (  ( x1 + a2 + c1 ) > (  x2 + a1 + c1 ) ) ) in r1 .
       set ( c2 := pr1 t2' ) . assert ( r2 := pr2 t2' ) .
       change ( pr1 (  ( ( x2 + 1 ) + a1 + c2 ) > ( x1 + ( a2 + 0 ) + c2 ) ) ) in r2 .
       assert ( r1' := natgthandplusrinv _ _ c1 r1 ) .
       assert ( r2' := natgthandplusrinv _ _ c2 r2 ) .
       rewrite ( natplusr0 _ ) in r2' .
       rewrite ( natpluscomm _ 1 ) in r2' .
       rewrite ( natplusassoc _ _ _ ) in r2' .
       change (1 + (x2 + a1) > x1 + a2) with (x1 + a2 ≤ x2 + a1) in r2'.
       contradicts (natlehneggth r2') r1'.
Defined .

Lemma hzgthsntogeh ( n m : hz ) : hzgth ( n + 1 ) m -> hzgeh n m .
Proof. intros a . apply (hzgehandplusrinv n m 1) . apply ( hzgthtogehsn ( n + 1 ) m a ) . Defined. (* PeWa *)

Lemma hzlehsntolth ( n m : hz ) : hzleh ( n + 1 )  m -> hzlth n m .
Proof.  intros X . apply ( hzlthlehtrans _ _ _ ( hzlthnsn n ) X ) .  Defined .

Lemma hzlthtolehsn ( n m : hz ) : hzlth n m -> hzleh ( n + 1 )  m .
Proof. intros X . apply ( hzgthtogehsn m n X ) . Defined .

Lemma hzlthsntoleh ( n m : hz ) : hzlth n ( m + 1 ) -> hzleh n m .
Proof. intros a . apply (hzlehandplusrinv n m 1) . apply ( hzlthtolehsn n ( m + 1 ) a ) . Defined. (* PeWa *)

Lemma hzgehsntogth ( n m : hz ) : hzgeh n ( m + 1 ) -> hzgth n m .
Proof. intros X . apply ( hzlehsntolth m n X ) .  Defined .

(** *** Comparsion alternatives and [ n -> n + 1 ] *)

Lemma hzlehchoice2 ( n m : hz ) : hzleh n m -> coprod ( hzleh ( n + 1 )  m ) ( n = m ) .
Proof . intros l . destruct ( hzlehchoice n m l ) as [ l' | e ] .   apply ( ii1 ( hzlthtolehsn _ _ l' ) ) . apply ( ii2 e ) .  Defined .

Lemma hzgehchoice2 ( n m : hz ) : hzgeh n m -> coprod ( hzgeh n ( m + 1 ) ) ( n = m ) .
Proof . intros g . destruct ( hzgehchoice n m g ) as [ g' | e ] .   apply ( ii1 ( hzgthtogehsn _ _ g' ) ) . apply ( ii2 e ) . Defined .

Lemma hzgthchoice2 ( n m : hz ) : hzgth n m -> coprod ( hzgth n ( m + 1 ) ) ( n = ( m + 1 ) ) .
Proof.  intros g . destruct ( hzgehchoice _ _ ( hzgthtogehsn _ _ g ) ) as [ g' | e ] . apply ( ii1 g' ) .  apply ( ii2 e ) .  Defined .

Lemma hzlthchoice2 ( n m : hz ) : hzlth n m -> coprod ( hzlth ( n + 1 )  m ) ( ( n + 1 ) = m ) .
Proof.  intros l . destruct ( hzlehchoice _ _ ( hzlthtolehsn _ _ l ) ) as [ l' | e ] . apply ( ii1 l' ) .  apply ( ii2 e ) .   Defined .

(** *** Operations and comparisons on [ hz ] and [ natnattohz ] *)

Lemma natnattohzandgth ( xa1 xa2 : dirprod nat nat ) ( is : hzgth ( setquotpr _ xa1 ) ( setquotpr _ xa2 ) ) : natgth ( ( pr1 xa1 ) + ( pr2 xa2 ) ) ( ( pr1 xa2 ) + ( pr2 xa1 ) ) .
Proof . intros . change ( ishinh_UU ( total2  ( λ a0, natgth (pr1 xa1 + pr2 xa2 + a0) (pr1 xa2 + pr2 xa1 + a0) ) ) ) in is .  generalize is .  apply @hinhuniv .  intro t2 .  set ( a0 := pr1 t2 ) . assert ( g := pr2 t2 ) . change ( pr1 ( natgth (pr1 xa1 + pr2 xa2 + a0) (pr1 xa2 + pr2 xa1 + a0) ) ) in g . apply ( natgthandplusrinv _ _ a0 g ) . Defined .

Lemma natnattohzandlth ( xa1 xa2 : dirprod nat nat ) ( is : hzlth ( setquotpr _ xa1 ) ( setquotpr _ xa2 ) ) : natlth ( ( pr1 xa1 ) + ( pr2 xa2 ) ) ( ( pr1 xa2 ) + ( pr2 xa1 ) ) .
Proof . intros . apply ( natnattohzandgth xa2 xa1 is ) .  Defined .

(** *** Canonical rig homomorphism from [ nat ] to [ hz ] *)

Definition nattohz : nat -> hz := λ n, setquotpr _ ( make_dirprod n 0%nat ) .

Definition isinclnattohz : isincl nattohz := isincltoringdiff natcommrig ( λ n, isinclnatplusr n ) .

Definition nattohzandneq ( n m : nat ) ( is : natnegpaths n m ) : hzneq ( nattohz n ) ( nattohz m ) := negf ( invmaponpathsincl _ isinclnattohz n m ) is .

Definition nattohzand0 : ( nattohz 0%nat ) = 0 := idpath _ .

Definition nattohzandS ( n : nat ) : ( nattohz ( S n ) ) = ( 1 + nattohz n ) := isbinop1funtoringdiff natcommrig 1%nat n .

Definition nattohzand1 : ( nattohz 1%nat ) = 1 := idpath _ .

Lemma nattorig_nattohz :
  ∏ n : nat, nattorig (X := hz) n = nattohz n.
Proof.
  induction n as [|n IHn].
  - unfold nattorig, nattohz ; simpl.
    reflexivity.
  - rewrite nattorigS, IHn.
    apply pathsinv0, nattohzandS.
Qed.

Definition nattohzandplus ( n m : nat ) : ( nattohz ( n + m )%nat ) = ( nattohz n + nattohz m ) := isbinop1funtoringdiff natcommrig n m .

Definition nattohzandminus ( n m : nat ) ( is : natgeh n m ) : ( nattohz ( n - m )%nat ) = ( nattohz n - nattohz m ) .
Proof . intros .  apply ( hzplusrcan _ _ ( nattohz m ) ) . unfold hzminus .  rewrite ( hzplusassoc ( nattohz n ) ( - nattohz m ) ( nattohz m ) ) . rewrite ( hzlminus _ ) .   rewrite hzplusr0 .  rewrite ( pathsinv0 ( nattohzandplus _ _ ) ) .  rewrite ( minusplusnmm _ _ is ) . apply idpath . Defined .

Opaque nattohzandminus .

Definition nattohzandmult ( n m : nat ) : ( nattohz ( n * m )%nat ) = ( nattohz n * nattohz m ) .
Proof . intros . simpl . change nattohz with ( toringdiff natcommrig ) . apply ( isbinop2funtoringdiff natcommrig n m ) . Defined .

Definition nattohzandgth ( n m : nat ) ( is : natgth n m ) : hzgth ( nattohz n ) ( nattohz m ) := iscomptoringdiff natcommrig isplushrelnatgth n m is .

Definition nattohzandlth ( n m : nat ) ( is : natlth n m ) : hzlth ( nattohz n ) ( nattohz m ) := nattohzandgth m n is .

Definition nattohzandleh ( n m : nat ) ( is : natleh n m ) : hzleh ( nattohz n ) ( nattohz m ) .
Proof . intros . destruct ( natlehchoice _ _ is ) as [ l | e ] .   apply ( hzlthtoleh _ _ ( nattohzandlth _ _ l ) ) .  rewrite e .  apply ( isreflhzleh ) .  Defined .

Definition nattohzandgeh ( n m : nat ) ( is : natgeh n m ) : hzgeh ( nattohz n ) ( nattohz m ) := nattohzandleh _ _ is .

(** *** Addition and subtraction on [ nat ] and [ hz ] *)

(** *** Absolute value on [ hz ] *)

Definition hzabsvalint : ( dirprod nat nat ) -> nat .
Proof . intro nm . destruct ( natgthorleh ( pr1 nm ) ( pr2  nm ) ) .  apply ( sub ( pr1 nm ) ( pr2 nm ) ) . apply ( sub ( pr2 nm ) ( pr1 nm ) ) . Defined .

Lemma hzabsvalintcomp : @iscomprelfun ( dirprod nat nat ) nat ( hrelabgrdiff nataddabmonoid )  hzabsvalint .
Proof . unfold iscomprelfun .  intros x x' . unfold hrelabgrdiff . simpl . apply ( @hinhuniv _ ( make_hProp _ ( isasetnat (hzabsvalint x) (hzabsvalint x') ) ) ) .  unfold hzabsvalint . set ( n := ( pr1 x ) : nat  ) . set ( m := ( pr2 x ) : nat ) . set ( n' := ( pr1 x' ) : nat ) . set ( m' := ( pr2 x' ) : nat ) .   set ( int := natgthorleh n m ) . set ( int' := natgthorleh n' m' ) .   intro tt0 . simpl .  destruct tt0 as [ x0 eq ] .  simpl in eq .  assert ( e' := invmaponpathsincl _ ( isinclnatplusr x0 ) _ _ eq ) .

destruct int as [isgt | isle ] . destruct int' as [ isgt' | isle' ] .

apply ( invmaponpathsincl _ ( isinclnatplusr ( m + m' ) ) ) .  rewrite ( pathsinv0 ( natplusassoc ( n - m )  m m' ) ) . rewrite ( natpluscomm m m' ) .  rewrite ( pathsinv0 ( natplusassoc ( n' - m' ) m' m ) ) . rewrite ( minusplusnmm n m ( natgthtogeh _ _ isgt ) ) . rewrite ( minusplusnmm n' m' ( natgthtogeh _ _ isgt' ) ) . apply e' .

assert ( e'' := natlehandplusl n' m' n isle' ) .  assert ( e''' :=  natgthandplusr n m n' isgt )  .  assert ( e'''' := natlthlehtrans _ _ _ e''' e'' ) .  rewrite e' in e'''' . rewrite ( natpluscomm m n' ) in e'''' . destruct ( isirreflnatgth _ e'''' ) .

destruct int' as [ isgt' | isle' ] .

destruct ( natpluscomm m n') . set ( e'' := natlehandplusr n m m' isle ) .  set ( e''' :=  natgthandplusl n' m' m isgt' )  .  set ( e'''' := natlehlthtrans _ _ _ e'' e''' ) .  rewrite e' in e'''' . destruct ( isirreflnatgth _ e'''' ) .

apply ( invmaponpathsincl _ ( isinclnatplusr ( n + n') ) ) . rewrite ( pathsinv0 ( natplusassoc ( m - n )  n n' ) ) . rewrite ( natpluscomm n n' ) .  rewrite ( pathsinv0 ( natplusassoc ( m' - n') n' n ) ) .  rewrite ( minusplusnmm m n isle ) . rewrite ( minusplusnmm m' n' isle' ) .  rewrite ( natpluscomm m' n ) .  rewrite ( natpluscomm m n' ) .  apply ( pathsinv0 e' ) .
Defined .

Definition hzabsval : hz -> nat := setquotuniv _ natset hzabsvalint hzabsvalintcomp .

Lemma hzabsval0 : ( hzabsval 0 ) = 0%nat .
Proof .  apply idpath .  Defined .

Lemma hzabsvalgth0 { x : hz } ( is : hzgth x 0 ) : ( nattohz ( hzabsval x ) ) = x .
Proof .
revert x is.
assert ( int : ∏ x : hz , isaprop ( hzgth x 0 -> ( nattohz ( hzabsval x ) ) = x ) ) . intro . apply impred . intro . apply ( setproperty hz ) .  apply ( setquotunivprop _ ( λ x, make_hProp _ ( int x ) ) ) . intros xa g . simpl in xa . assert ( g' := natnattohzandgth _ _ g ) . simpl in g' .  simpl .  change (( setquotpr (eqrelabgrdiff (rigaddabmonoid natcommrig)) ( make_dirprod ( hzabsvalint xa ) 0%nat ) ) = ( setquotpr (eqrelabgrdiff (rigaddabmonoid natcommrig)) xa ) ) . apply weqpathsinsetquot . simpl . apply hinhpr . split with 0%nat .  change ( pr1 ( natgth ( pr1 xa + 0%nat ) ( pr2 xa ) ) ) in g' . rewrite ( natplusr0 _ ) in g' .  change ((hzabsvalint xa + pr2 xa + 0)%nat = (pr1 xa + 0 + 0)%nat ) . rewrite ( natplusr0 _ ) .  rewrite ( natplusr0 _ ) .  rewrite ( natplusr0 _ ) . unfold hzabsvalint .   destruct ( natgthorleh (pr1 xa) (pr2 xa)  ) as [ g'' | l ] .

rewrite ( minusplusnmm _ _ ( natlthtoleh _ _ g'' ) ) . apply idpath .

contradicts (natlehneggth l) g'.
Defined .

Opaque hzabsvalgth0 .

Lemma hzabsvalgeh0 { x : hz } ( is : hzgeh x 0 ) : ( nattohz ( hzabsval x ) ) = x .
Proof .  intros . destruct ( hzgehchoice _ _ is ) as [ g | e ] .  apply ( hzabsvalgth0 g ) . rewrite e .  apply idpath .  Defined .

Lemma hzabsvallth0 { x : hz } ( is : hzlth x 0 ) : ( nattohz ( hzabsval x ) ) = ( - x ) .
Proof .
revert x is.
assert ( int : ∏ x : hz , isaprop ( hzlth x 0 -> ( nattohz ( hzabsval x ) ) = ( - x ) ) ) . intro . apply impred . intro . apply ( setproperty hz ) .  apply ( setquotunivprop _ ( λ x, make_hProp _ ( int x ) ) ) . intros xa l . simpl in xa . assert ( l' := natnattohzandlth _ _ l ) . simpl in l' .  simpl .  change (( setquotpr (eqrelabgrdiff (rigaddabmonoid natcommrig)) ( make_dirprod ( hzabsvalint xa ) 0%nat ) ) = ( setquotpr (eqrelabgrdiff (rigaddabmonoid natcommrig)) ( make_dirprod ( pr2 xa ) ( pr1 xa ) ) ) ) . apply weqpathsinsetquot . simpl . apply hinhpr . split with 0%nat .  change ( pr1 ( natlth ( pr1 xa + 0%nat ) ( pr2 xa ) ) ) in l' . rewrite ( natplusr0 _ ) in l' .  change ((hzabsvalint xa + pr1 xa + 0)%nat = (pr2 xa + 0 + 0)%nat). rewrite ( natplusr0 _ ) .  rewrite ( natplusr0 _ ) .  rewrite ( natplusr0 _ ) . unfold hzabsvalint .   destruct ( natgthorleh (pr1 xa) (pr2 xa)  ) as [ g | l'' ] .

destruct ( isasymmnatgth _ _ g l' ) .

rewrite ( minusplusnmm _ _ l'' ) . apply idpath . Defined .

Opaque hzabsvallth0 .

Lemma hzabsvalleh0 { x : hz } ( is : hzleh x 0 ) : ( nattohz ( hzabsval x ) ) = ( - x ) .
Proof .  intros . destruct ( hzlehchoice _ _ is ) as [ l | e ] .  apply ( hzabsvallth0 l ) . rewrite e .  apply idpath .  Defined .

Lemma hzabsvaleq0 { x : hz } ( e : ( hzabsval x ) = 0%nat ) : x = 0  .
Proof .  intros . destruct ( isdeceqhz x 0 ) as [ e0 | ne0 ] . apply e0 .  destruct ( hzneqchoice _ _ ne0 ) as [ g | l ] .

assert ( e' := hzabsvalgth0 g ) . rewrite e in e' . change ( 0 = x ) in e' .  apply ( pathsinv0 e' ) .

assert ( e' := hzabsvallth0 l ) . rewrite e in e' . change ( 0 = ( - x ) ) in e' . assert ( g := hzlth0andminus l ) .  rewrite e' in g .  destruct ( isirreflhzgth _ g ) . Defined .

Definition hzabsvalneq0 { x : hz } ne := neg_to_negProp (nP := natneq _ _) (negf ( @hzabsvaleq0 x ) ne).

Lemma hzabsvalandmult ( a b : hz ) : ( ( hzabsval a ) * ( hzabsval b ) )%nat = ( hzabsval ( a * b ) ) .
Proof . intros . apply ( invmaponpathsincl _ isinclnattohz ) . rewrite ( nattohzandmult _ _ ) .  destruct ( hzgthorleh a 0 ) as [ ga | lea ] . destruct ( hzgthorleh b 0 ) as [ gb | leb ] .

rewrite ( hzabsvalgth0 ga ) .  rewrite ( hzabsvalgth0 gb ) .  rewrite ( hzabsvalgth0 ( hzmultgth0gth0 ga gb ) ) . apply idpath .

rewrite ( hzabsvalgth0 ga ) .  rewrite ( hzabsvalleh0 leb ) . rewrite ( hzabsvalleh0 ( hzmultgth0leh0 ga leb ) ) .    apply ( ringrmultminus hz ) .  destruct ( hzgthorleh b 0 ) as [ gb | leb ] .

rewrite ( hzabsvalgth0 gb ) .  rewrite ( hzabsvalleh0 lea ) . rewrite ( hzabsvalleh0 ( hzmultleh0gth0 lea gb ) ) . apply ( ringlmultminus hz ) .

rewrite ( hzabsvalleh0 lea ) . rewrite ( hzabsvalleh0 leb ) . rewrite ( hzabsvalgeh0 ( hzmultleh0leh0 lea leb ) ) .  apply (ringmultminusminus hz ) . Defined .

(** *** Some common equalities on integers *)
(** These lemmas are used for example in Complexes.v to construct complexes. *)
Local Opaque hz isdecrelhzeq iscommringops.

Lemma hzeqbooleqii (i : hz) : hzbooleq i i = true.
Proof.
  unfold hzbooleq. unfold decreltobrel. induction (pr2 hzdeceq i i) as [T | F].
  - apply idpath.
  - apply fromempty. apply F. apply idpath.
Qed.

Lemma hzbooleqisi (i : hz) : hzbooleq i (i + 1) = false.
Proof.
  apply negrtopaths.
  apply (negf (λ e, hzpluslcan _ _ _ (! (hzplusr0 i @ e)))); clear i.
  confirm_not_equal isdecrelhzeq.
Qed.

Lemma hzbooleqisi' (i : hz) : hzbooleq i (i + 1) = false.
Proof.
  (* prove it again, to illustrate how to avoid the tactic [confirm_not_equal] *)
  apply negrtopaths.
  apply (negf (λ e, hzpluslcan _ _ _ (! (hzplusr0 i @ e)))); clear i.
  simple refine (confirm_not_equal isdecrelhzeq _ _ _).
  reflexivity.
Qed.

Lemma hzbooleqissi (i : hz) : hzbooleq i (i + 1 + 1) = false.
Proof.
  apply negrtopaths.
  rewrite hzplusassoc.
  apply (negf (λ e, hzpluslcan _ _ _ (! (hzplusr0 i @ e)))); clear i.
  confirm_not_equal isdecrelhzeq.
Qed.

Lemma hzeqeisi {i i0 : hz} (e : hzeq i i0) (e' : hzeq i (i0 + 1)) : empty.
Proof.
  apply nopathstruetofalse.
  use (pathscomp0 _ (hzbooleqisi i0)).
  rewrite <- e'. rewrite <- e.
  apply (! (hzeqbooleqii i)).
Qed.

Lemma hzeqisi {i : hz} (e' : hzeq i (i + 1)) : empty.
Proof.
  apply nopathstruetofalse. rewrite <- (hzbooleqisi i). rewrite <- e'.
  apply (! (hzeqbooleqii i)).
Qed.

Lemma hzeqissi {i : hz} (e : hzeq i (i + 1 + 1)) : empty.
Proof.
  set (tmp := hzbooleqissi i). cbn in e. rewrite <- e in tmp.
  rewrite (hzeqbooleqii i) in tmp. apply nopathstruetofalse. apply tmp.
Qed.

Lemma hzeqeissi {i i0 : hz} (e : hzeq i i0) (e' : hzeq i (i0 + 1 + 1)) : empty.
Proof.
  cbn in e. rewrite e in e'. apply (hzeqissi e').
Qed.

Lemma hzeqsnmnsm {n m : hz} (e : hzeq (n + 1) m) (e' : hzeq n (m + 1)) : empty.
Proof.
  cbn in e. rewrite <- e in e'. apply (hzeqissi e').
Qed.

Lemma hzeqnmplusr {n m i : hz} (e : n = m) (e' : ¬ (n + i = m + i)) : empty.
Proof.
  apply e'. exact (maponpaths_2 _ e _).
Qed.

Lemma hzeqnmplusr' {n m i : hz} (e : ¬ (n = m)) (e' : n + i = m + i) : empty.
Proof.
  apply e. exact (hzplusrcan _ _ i e').
Qed.

Lemma isdecrelhzeqi (i : hz) : isdecrelhzeq i i = ii1 (idpath _).
Proof.
  induction (isdecrelhzeq i i) as [T | F].
  - apply maponpaths. apply isasethz.
  - apply fromempty. apply F. apply idpath.
Qed.

Lemma isdecrelhzeqminusplus (i j : hz) : isdecrelhzeq i (i - j + j) = ii1 (hzrminusplus' i j).
Proof.
  induction (isdecrelhzeq i (i - j + j)) as [T | F].
  - apply maponpaths. apply isasethz.
  - apply fromempty. apply F. apply (hzrminusplus' i j).
Qed.

Lemma isdecrelhzeqminusplus' (i j : hz) : isdecrelhzeq (i - j + j) i = ii1 (hzrminusplus i j).
Proof.
  induction (isdecrelhzeq (i - j + j) i) as [T | F].
  - apply maponpaths. apply isasethz.
  - apply fromempty. apply F. apply (hzrminusplus i j).
Qed.

Lemma hzeqpii {i : hz} : i - 1 != i.
Proof.
  apply (negf (λ e, hzpluslcan _ _ _ (e @ ! hzplusr0 i))); clear i.
  confirm_not_equal isdecrelhzeq.
Qed.

Lemma isdecrelhzeqpii (i : hz) :
  isdecrelhzeq (i - 1) i = ii2 (fun (e : hzeq (i - 1) i) => hzeqpii e).
Proof.
  induction (isdecrelhzeq (i - 1) i) as [e | n].
  - apply fromempty. apply (hzeqpii e).
  - apply maponpaths. apply funextfun. intros e.
    apply fromempty. apply n. apply e.
Qed.

Local Transparent hz isdecrelhzeq iscommringops.

(** *** [hz] is an archimedean ring *)

Local Open Scope hz_scope .

Lemma isarchhz : isarchring (X := hz) hzgth.
Proof.
  simple refine (isarchrigtoring _ _ _ _ _ _).
  - reflexivity.
  - intros n m.
    apply istransnatgth.
  - apply isarchrig_setquot_aux.
    + split.
      * apply natgthandpluslinv.
      * apply natgthandplusrinv.
    + apply isarchnat.
Qed.

Lemma isarchhz_one :
  ∏ x : hz, hzgth x 0 → ∃ n : nat, hzgth (nattohz n * x) 1.
Proof.
  intros x Hx.
  generalize (isarchring_1 _ isarchhz x Hx).
  apply hinhfun.
  intros n.
  exists (pr1 n).
  rewrite <- nattorig_nattohz.
  exact (pr2 n).
Qed.

Lemma isarchhz_gt :
  ∏ x : hz, ∃ n : nat, hzgth (nattohz n) x.
Proof.
  intros x.
  generalize (isarchring_2 _ isarchhz x).
  apply hinhfun.
  intros n.
  exists (pr1 n).
  rewrite <- nattorig_nattohz.
  exact (pr2 n).
Qed.

(** **** hz -> abgr, 1 ↦ x, n ↦ x + x + ... + x  (n times), [hz_abmonoid_monoidfun] *)

Definition nat_to_monoid_fun {X : monoid} (x : X) : natset -> X.
Proof.
  intros n. induction n as [ | n IHn].
  - exact (unel X).
  - exact (@op X x IHn).
Defined.

Lemma nat_to_monoid_fun_unel {X : monoid} (x : X) : nat_to_monoid_fun x O = (unel X).
Proof.
  exact (idpath (unel X)).
Defined.

Lemma nat_to_monoid_fun_S {X : abmonoid} (x : X) (n : nat) :
  nat_to_monoid_fun x (S n) = (nat_to_monoid_fun x n * x)%multmonoid.
Proof.
  induction n as [ | n IHn].
  - exact (commax X x (unel X)).
  - cbn. rewrite (assocax X). use two_arg_paths.
    + use idpath.
    + exact (commax X x _).
Qed.

Lemma nat_to_abmonoid_fun_plus {X : monoid} (x : X) (n m : nat) :
  nat_to_monoid_fun x (n + m)%nat = @op X (nat_to_monoid_fun x n) (nat_to_monoid_fun x m).
Proof.
  revert m. induction n as [ | n IHn].
  - intros m. rewrite (lunax X). use idpath.
  - intros m. cbn. rewrite (assocax X). use two_arg_paths.
    + use idpath.
    + exact (IHn m).
Qed.

Definition nat_nat_to_monoid_fun {X : gr} (x : X) : natset × natset -> X.
Proof.
  intros n.
  exact (@op X (nat_to_monoid_fun x (dirprod_pr1 n))
             (nat_to_monoid_fun (grinv X x) (dirprod_pr2 n))).
Defined.

Lemma nat_to_monoid_unel' {X : abgr} (x : X) (n : nat) :
  ((nat_to_monoid_fun x n) * (nat_to_monoid_fun (grinv X x) n))%multmonoid = (unel X).
Proof.
  induction n as [ | n IHn].
  - use (runax X).
  - Opaque nat_to_monoid_fun. cbn in *.
    rewrite (@nat_to_monoid_fun_S X x). rewrite (@nat_to_monoid_fun_S X (grinv X x)).
    rewrite (commax X _ x). rewrite (assocax X).
    rewrite <- (assocax X (@nat_to_monoid_fun X x n)).
    use (pathscomp0 (maponpaths (λ xx : pr1 X, (x * (xx * (grinv X x))))%multmonoid IHn)).
    clear IHn. use (pathscomp0 _ (grrinvax X x)).
    use two_arg_paths.
    + use idpath.
    + use (lunax X).
Qed.
Transparent nat_to_monoid_fun.

Lemma nat_nat_to_monoid1 {X : gr} (x : X) {n1 n2 m2 : nat} (e : n2 = m2) :
  nat_nat_to_monoid_fun x (make_dirprod n1 n2) = nat_nat_to_monoid_fun x (make_dirprod n1 m2).
Proof.
  induction e. use idpath.
Qed.

Lemma nat_nat_to_monoid2 {X : gr} (x : X) {n1 m1 n2 : nat} (e : n1 = m1) :
  nat_nat_to_monoid_fun x (make_dirprod n1 n2) = nat_nat_to_monoid_fun x (make_dirprod m1 n2).
Proof.
  induction e. use idpath.
Qed.

Definition nataddabmonoid_nataddabmonoid_to_monoid_fun {X : gr} (x : X) :
  abmonoiddirprod nataddabmonoid nataddabmonoid -> X := nat_nat_to_monoid_fun x.

Opaque nat_to_monoid_fun.
Lemma nat_nat_monoid_fun_isbinopfun {X : abgr} (x : X) :
  isbinopfun (nataddabmonoid_nataddabmonoid_to_monoid_fun x).
Proof.
  use make_isbinopfun. intros n m. induction n as [n1 n2]. induction m as [m1 m2]. cbn.
  unfold nataddabmonoid_nataddabmonoid_to_monoid_fun. unfold nat_nat_to_monoid_fun. cbn.
  rewrite nat_to_abmonoid_fun_plus. rewrite nat_to_abmonoid_fun_plus.
  rewrite (assocax X). rewrite (assocax X).
  use two_arg_paths.
  - use idpath.
  - rewrite <- (assocax X). rewrite (commax X (nat_to_monoid_fun (grinv X x) n2) _).
    rewrite (assocax X). rewrite (assocax X).
    use two_arg_paths.
    + use idpath.
    + use (commax X).
Qed.
Transparent nat_to_monoid_fun.

Lemma nat_nat_to_monoid_plus1 {X : abgr} (x : X) {n1 m1 m2: nat} (e : m2 = (m1 + n1)%nat) :
  nat_to_monoid_fun (grinv X x) n1 =
  (nat_to_monoid_fun x m1 * nat_to_monoid_fun (grinv X x) m2)%multmonoid.
Proof.
  rewrite e. clear e. rewrite nat_to_abmonoid_fun_plus.
  rewrite <- (assocax X). use pathsinv0.
  use (pathscomp0 (maponpaths (λ xx : X, (xx * (nat_to_monoid_fun (grinv X x) n1))%multmonoid)
                              (nat_to_monoid_unel' x m1))).
  use (lunax X).
Qed.

Lemma nat_nat_prod_abmonoid_fun_unel {X : abgr} (x : X) :
  (nataddabmonoid_nataddabmonoid_to_monoid_fun x)
    (unel (abmonoiddirprod nataddabmonoid nataddabmonoid)) = (unel X).
Proof.
  use (pathscomp0 (lunax X _)). use idpath.
Qed.

Definition nat_nat_prod_abmonoid_monoidfun {X : abgr} (x : X) :
  monoidfun (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig)) X.
Proof.
  use monoidfunconstr.
  - exact (nataddabmonoid_nataddabmonoid_to_monoid_fun x).
  - use make_ismonoidfun.
    + exact (nat_nat_monoid_fun_isbinopfun x).
    + exact (nat_nat_prod_abmonoid_fun_unel x).
Defined.

Lemma hz_abmonoid_ismonoidfun :
  @ismonoidfun
    (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig))
    hzaddabgr (@setquotpr (abmonoiddirprod (rigaddabmonoid natcommrig)
                                           (rigaddabmonoid natcommrig))
                          (binopeqrelabgrdiff (rigaddabmonoid natcommrig))).
Proof.
  use make_ismonoidfun.
  - use make_isbinopfun. intros x x'. use idpath.
  - use idpath.
Qed.

Definition hz_abmonoid_monoidfun :
  monoidfun (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig)) hzaddabgr.
Proof.
  use monoidfunconstr.
  - use setquotpr.
  - exact hz_abmonoid_ismonoidfun.
Defined.

Definition nat_nat_fun_unel {X : abgr} (x : X) (n : nat) :
  nat_nat_to_monoid_fun x (make_dirprod n n) = unel X.
Proof.
  exact (nat_to_monoid_unel' x n).
Qed.

Opaque nat_to_monoid_fun.
Definition nat_nat_fun_ind {X : abgr} (x : X) (n m : nat) :
  nat_nat_to_monoid_fun x (make_dirprod (n + m)%nat m) = nat_nat_to_monoid_fun x (make_dirprod n O).
Proof.
  use (pathscomp0 (nat_nat_monoid_fun_isbinopfun x (make_dirprod n O) (make_dirprod m m))).
  unfold nataddabmonoid_nataddabmonoid_to_monoid_fun.
  rewrite (nat_nat_fun_unel x m). rewrite (runax X). use idpath.
Qed.
Transparent nat_to_monoid_fun.

Opaque nat_to_monoid_fun.
Definition nat_nat_fun_ind2 {X : abgr} (x : X) (n1 n2 m k : nat) :
  nat_nat_to_monoid_fun x (make_dirprod n1 m) = nat_nat_to_monoid_fun x (make_dirprod n2 k) ->
  nat_nat_to_monoid_fun x (make_dirprod n1 (S m)) = nat_nat_to_monoid_fun x (make_dirprod n2 (S k)).
Proof.
  intros H.
  unfold nat_nat_to_monoid_fun in *. cbn in *.
  rewrite (@nat_to_monoid_fun_S X (grinv X x)).
  rewrite (@nat_to_monoid_fun_S X (grinv X x)).
  rewrite <- (assocax X). rewrite <- (assocax X).
  use two_arg_paths.
  - exact H.
  - use idpath.
Qed.
Transparent nat_to_monoid_fun.

Opaque nat_to_monoid_fun.
Definition abgr_precategory_integer_fun_iscomprelfun {X : abgr} (x : X) :
  iscomprelfun (binopeqrelabgrdiff (rigaddabmonoid natcommrig))
               (nat_nat_prod_abmonoid_monoidfun x).
Proof.
  intros x1. induction x1 as [x1 e1].
  unfold nat_nat_prod_abmonoid_monoidfun. cbn.
  unfold nataddabmonoid_nataddabmonoid_to_monoid_fun.
  unfold nat_nat_to_monoid_fun. cbn.
  induction x1 as [ | x1 IHx1].
  - intros x2 H. use (squash_to_prop H (setproperty X _ _)). intros H'. cbn in H'.
    induction H' as [H1 H2]. clear H. induction x2 as [x2 e2].
    apply natplusrcan in H2. rewrite nat_to_monoid_fun_unel. rewrite (lunax X). cbn. cbn in H2.
    exact (nat_nat_to_monoid_plus1 x H2).
  - intros x2 H. use (squash_to_prop H (setproperty X _ _)). intros H'. cbn in H'.
    induction H' as [H1 H2]. clear H. induction x2 as [x2 e2]. cbn in H2. cbn.
    use (pathscomp0
           (maponpaths (λ xx : X, (xx * (nat_to_monoid_fun (grinv X x) e1))%multmonoid)
                       (@nat_to_monoid_fun_S X x x1))).
    rewrite (commax X _ x). rewrite (assocax X). cbn.
    assert (HH : ishinh_UU(∑ x0 : nat, (x1 + (S e2) + x0)%nat = (x2 + e1 + x0)%nat)).
    {
      use hinhpr. use tpair.
      - exact O.
      - cbn. rewrite natplusr0. rewrite natplusr0. cbn.
        rewrite natplusassoc in H2.
        rewrite plus_n_Sm in H2. rewrite plus_n_Sm in H2.
        rewrite natplusnsm in H2. rewrite <- natplusassoc in H2.
        apply natplusrcan in H2. exact H2.
    }
    set (tmp := IHx1 (make_dirprod x2 (S e2)) HH). cbn in tmp.
    use (pathscomp0 (maponpaths (λ xx : X, (x * xx)%multmonoid) tmp)).
    clear tmp. clear HH. clear H2. clear IHx1. rewrite (commax X x). rewrite (assocax X).
    use two_arg_paths.
    + use idpath.
    + use (pathscomp0
             (maponpaths (λ xx : X, (xx * x)%multmonoid)
                         (@nat_to_monoid_fun_S X (grinv X x) e2))).
      rewrite (assocax X). rewrite (grlinvax X x). use (runax X).
Qed.
Transparent nat_to_monoid_fun.

(** Construction of tha map \mathbb{Z} --> A, 1 ↦ x *)
Definition hz_abgr_fun {X : abgr} (x : X) : hzaddabgr -> X.
Proof.
  use setquotuniv.
  - exact (nat_nat_prod_abmonoid_monoidfun x).
  - exact (abgr_precategory_integer_fun_iscomprelfun x).
Defined.

(** Hide ismonoidfun behind Qed. *)
Definition hz_abgr_fun_ismonoidfun {X : abgr} (x : X) : ismonoidfun (hz_abgr_fun x).
Proof.
  use make_ismonoidfun.
  - use isbinopfun_twooutof3b.
    + use (abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig)).
    + use (hz_abmonoid_monoidfun).
    + use issurjsetquotpr.
    + use binopfunisbinopfun.
    + use binopfunisbinopfun.
  - use (runax X).
Qed.

(** Construction of the monoidfun \mathbb{Z} --> A, 1 ↦ x *)
Definition hz_abgr_fun_monoidfun {X : abgr} (x : X) : monoidfun hzaddabgr X.
Proof.
  use monoidfunconstr.
  - exact (hz_abgr_fun x).
  - exact (hz_abgr_fun_ismonoidfun x).
Defined.

(** Commutativity of the following diagram

                          nat × nat --- nat_nat_prod_abmonoid_monoidfun --->  X
        hz_abgr_fun_monoidfun |                                               ||
                             hz -------- hz_abmonoid_monoidfun -------------> X
 *)
Lemma abgr_natnat_hz_X_comm {X : abgr} (x : X) :
  monoidfuncomp hz_abmonoid_monoidfun (hz_abgr_fun_monoidfun x) =
  nat_nat_prod_abmonoid_monoidfun x.
Proof.
  use monoidfun_paths. use funextfun. intros n. use setquotunivcomm.
Qed.

Opaque nat_to_monoid_fun.
Lemma monoidfun_nat_to_monoid_fun {X Y : abgr} (f : monoidfun X Y) (x : X) (n : nat) :
  pr1 f (nat_to_monoid_fun x n) = nat_to_monoid_fun (f x) n.
Proof.
  induction n as [ | n IHn].
  - use monoidfununel.
  - use (pathscomp0 (maponpaths (pr1 f) (@nat_to_monoid_fun_S X x n))).
    use (pathscomp0 (binopfunisbinopfun f _ _)).
    use (pathscomp0 _ (! (@nat_to_monoid_fun_S Y (f x) n))).
    use two_arg_paths.
    + exact IHn.
    + use idpath.
Qed.
Transparent nat_to_monoid_fun.

(** Some more facts about integers added by D. Grayson  *)

Definition ℤ := hzaddabgr.
Definition toℤ (n:nat) : ℤ := nattohz n.
Definition toℤneg (n:nat) : ℤ := natnattohz O n.
Definition zero := toℤ 0.
Definition one := toℤ 1.

Definition hzabsvalnat n : hzabsval (natnattohz n 0) = n. (* move to hz.v *)
Proof.
  intros. unfold hzabsval. unfold setquotuniv. simpl.
  unfold hzabsvalint. simpl. destruct (natgthorleh n 0).
  { apply natminuseqn. } { exact (! (natleh0tois0 h)). }
Defined.

Lemma hzsign_natnattohz m n : - natnattohz m n = natnattohz n m. (* move to hz.v *)
Proof.
  reflexivity.             (* don't change the proof *)
Defined.

Lemma hzsign_nattohz m : - nattohz m = natnattohz 0 m. (* move to hz.v *)
Proof.
  reflexivity.             (* don't change the proof *)
Defined.

Lemma hzsign_hzsign (i:hz) : - - i = i.
Proof.
  apply (grinvinv ℤ).
Defined.

Definition hz_normal_form (i:ℤ) :=
  coprod (∑ n, natnattohz n 0 = i)
         (∑ n, natnattohz 0 (S n) = i).

Definition hznf_pos n := _,, inl (n,,idpath _) : total2 hz_normal_form.

Definition hznf_neg n := _,, inr (n,,idpath _) : total2 hz_normal_form.

Definition hznf_zero := hznf_pos 0.

Definition hznf_neg_one := hznf_neg 0.

Definition hz_to_normal_form (i:ℤ) : hz_normal_form i.
Proof.
  intros. destruct (hzlthorgeh i 0) as [r|s].
  { apply inr. assert (a := hzabsvallth0 r). assert (b := hzlthtoneq _ _ r).
    assert (c := hzabsvalneq0 b). assert (d := natneq0togth0 _ c).
    assert (f := natgthtogehsn _ _ d). assert (g := minusplusnmm _ _ f).
    rewrite natpluscomm in g. simpl in g. exists (hzabsval i - 1)%nat.
    rewrite g. apply hzinvmaponpathsminus. exact a. }
  { apply inl. exists (hzabsval i). exact (hzabsvalgeh0 s). }
Defined.

Lemma nattohz_inj {m n} : nattohz m = nattohz n -> m = n.
Proof.
  revert m n; exact (invmaponpathsincl _ isinclnattohz).
Defined.

Lemma hzdichot {m n} : neg (nattohz m = - nattohz (S n)).
Proof.
  intros. intro e. assert (d := maponpaths hzsign e); clear e.
  rewrite hzsign_hzsign in d.
  assert( f := maponpaths (λ i, nattohz m + i) d); simpl in f; clear d.
  change (nattohz m + - nattohz m) with (nattohz m - nattohz m) in f.
  rewrite hzrminus in f. change (0 = nattohz (m + S n)) in f.
  assert (g := nattohz_inj f); clear f. rewrite natpluscomm in g.
  exact (negpaths0sx _ g).
Defined.

Definition negpos' : isweq (@pr1 _ hz_normal_form).
Proof.
  apply isweqpr1; intro i.
  exists (hz_to_normal_form i).
  generalize (hz_to_normal_form i) as s.
  intros [[m p]|[m p]] [[n q]|[n q]].
  { apply (maponpaths (@ii1 (∑ n, natnattohz n 0 = i)
                            (∑ n, natnattohz 0 (S n) = i))).
    apply (proofirrelevance _ (isinclnattohz i)). }
  { apply fromempty. assert (r := p@!q); clear p q. apply (hzdichot r). }
  { apply fromempty. assert (r := q@!p); clear p q. apply (hzdichot r). }
  { apply (maponpaths (@ii2 (∑ n, natnattohz n 0 = i)
                            (∑ n, natnattohz 0 (S n) = i))).
    assert (p' := maponpaths hzsign p). assert (q' := maponpaths hzsign q).
    change (- natnattohz O (S m)) with  (nattohz (S m)) in p'.
    change (- natnattohz O (S n)) with  (nattohz (S n)) in q'.
    assert (c := proofirrelevance _ (isinclnattohz (-i)) (S m,,p') (S n,,q')).
    assert (d := maponpaths pr1 c); simpl in d.
    assert (e := invmaponpathsS _ _ d); clear d.
    apply subtypePath.
    - intro; apply setproperty.
    - exact (!e). }
Defined.

Definition negpos_weq := make_weq _ negpos' : weq (total2 hz_normal_form) ℤ.

Definition negpos : weq (coprod nat nat) ℤ. (* ℤ = (-inf,-1) + (0,inf) *)
Proof.
  simple refine (make_weq _ (isweq_iso _ _ _ _)).
  { intros [n'|n].
    { exact (natnattohz 0 (S n')). } { exact (natnattohz n 0). } }
  { intro i. destruct (hz_to_normal_form i) as [[n p]|[m q]].
    { exact (inr n). } { exact (inl m). } }
  { intros [n'|n].
    { simpl. rewrite natminuseqn. reflexivity. }
    { simpl. rewrite hzabsvalnat. reflexivity. } }
  { simpl. intro i.
    destruct (hz_to_normal_form i) as [[n p]|[m q]].
    { exact p. } { exact q. } }
Defined.

Lemma hzminusplus (x y:hz) : -(x+y) = (-x) + (-y). (* move to hz.v *)
Proof.
  intros. apply (hzplusrcan _ _ (x+y)). rewrite hzlminus.
  rewrite (hzpluscomm (-x)). rewrite (hzplusassoc (-y)).
  rewrite <- (hzplusassoc (-x)). rewrite hzlminus. rewrite hzplusl0.
  rewrite hzlminus. reflexivity.
Defined.

Definition loop_power {Y} {y:Y} (l:y = y) (n:ℤ) : y = y.
Proof.
  intros. assert (m := loop_power_nat l (hzabsval n)).
  destruct (hzlthorgeh n 0%hz). { exact (!m). } { exact m. }
Defined.


Lemma all_perm :
 forall (A:Type) (P:A -> A -> Prop),
   (forall x y:A, P x y) -> forall x y:A, P y x.
Proof.
 auto.
Qed.

Lemma all_perm' :
 forall (A:Type) (P:A -> A -> Prop),
   (forall x y:A, P x y) ->
   forall x y:A, P y x.
Proof.
 intros A P H x y; apply H.
Qed.

Print all_perm.
Print all_perm'.

Lemma resolution :
 forall (A:Type) (P Q R S:A -> Prop),
   (forall a:A, Q a -> R a -> S a) ->
   (forall b:A, P b -> Q b) ->
   forall c:A, P c -> R c -> S c.
Proof.
 auto.
Qed.

Lemma resolution' :
 forall (A:Type) (P Q R S:A -> Prop),
   (forall a:A, Q a -> R a -> S a) ->
   (forall b:A, P b -> Q b) -> forall c:A, P c -> R c -> S c.
Proof.
 intros A P Q R S H H0 c H1 H2.
 apply H; try assumption.
 apply H0; assumption.
Qed.

Print resolution.
Print resolution'.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Proof of the axioms of choice                                           *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibEpsilon LibRelation.
Generalizable Variables A B.

(** This files includes several versions of the axiom of choice.
    This "axiom" is actually proved in terms of indefinite description.
    Remark: the choice results contained in this file are not very
    useful in practice since it is usually more convenient to use
    the epsilon operator directly. *)

(* ********************************************************************** *)
(** * Functional choice *)

(* ---------------------------------------------------------------------- *)
(** ** Functional choice *)

(** This result can be used to build a function from a relation that maps
    every input to at least one output. *)

Lemma functional_choice : forall A B (R:A->B->Prop),
  (forall x, exists y, R x y) ->
  (exists f, forall x, R x (f x)).
Proof using.
  intros. exists (fun x => sig_val (indefinite_description (H x))).
  intro x. apply (sig_proof (indefinite_description (H x))).
Qed.
(* --LATER: the premise is called [defined] in LibRelation *)
(* --LATER: functionality -> definedness? *)

(* ---------------------------------------------------------------------- *)
(** ** Dependent functional choice *)

(** It is a generalization of functional choice to dependent functions. *)

Scheme and_indd := Induction for and Sort Prop.
Scheme eq_indd := Induction for eq Sort Prop.

Lemma dependent_functional_choice :
  forall A (B:A->Type) (R:forall x, B x -> Prop),
  (forall x, exists y, R x y) ->
  (exists f, forall x, R x (f x)).
Proof using.
  introv H.
  pose (B' := { x:A & B x }).
  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
  destruct (functional_choice R') as (f,Hf).
    intros x. destruct (H x) as (y,Hy).
     exists (existT (fun x => B x) x y). split~.
  sets proj1_transparent: (fun P Q (p:P/\Q) => let (a,b) := p in a).
  exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_transparent _ _ (Hf x))).
  intros x. destruct (Hf x) as (Heq,HR) using and_indd.
  destruct (f x). simpls. destruct Heq using eq_indd. apply HR.
Qed.

Arguments dependent_functional_choice [A] [B].

(* ---------------------------------------------------------------------- *)
(** ** Guarded functional choice *)

(** Similar to functional choice, except that it targets partial functions *)

Lemma guarded_functional_choice : forall A `{Inhab B} (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists y, R x y) ->
  (exists f, forall x, P x -> R x (f x)).
Proof using.
  intros. apply (functional_choice (fun x y => P x -> R x y)).
  intros. apply~ indep_general_premises.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Omniscient functional choice *)

(** Similar to functional choice except that the proof of functionality
    of the relation is given after the fact, for each argument. *)

Lemma omniscient_functional_choice : forall A `{Inhab B} (R : A->B->Prop),
  exists f, forall x, (exists y, R x y) -> R x (f x).
Proof using. intros. apply~ guarded_functional_choice. Qed.

(* ********************************************************************** *)
(** * Functional unique choice *)

(** This section provides a similar set of results excepts that it is
    specialized for the case where each argument has a unique image. *)

(* ---------------------------------------------------------------------- *)
(** ** Functional unique choice *)

Lemma functional_unique_choice : forall A B (R:A->B->Prop),
  (forall x , exists! y, R x y) ->
  (exists! f, forall x, R x (f x)).
Proof using.
  intros. destruct (functional_choice R) as [f Hf].
  intros. apply (ex_of_ex_unique (H x)).
  exists f. split. auto.
   intros g Hg. apply fun_ext_1. intros y.
   apply~ (at_most_one_of_ex_unique (H y)).
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Dependent functional unique choice *)

Theorem dependent_functional_unique_choice :
  forall (A:Type) (B:A->Type) (R:forall (x:A), B x -> Prop),
  (forall (x:A), exists! y : B x, R x y) ->
  (exists! f : (forall (x:A), B x), forall (x:A), R x (f x)).
Proof using.
  intros. destruct (dependent_functional_choice R) as [f Hf].
  intros. apply (ex_of_ex_unique (H x)).
  exists f. split. auto.
   intros g Hg. extens. intros y.
   apply~ (at_most_one_of_ex_unique (H y)).
 Qed.

Arguments dependent_functional_unique_choice [A] [B].

(* ---------------------------------------------------------------------- *)
(** ** Guarded functional unique choice *)

Lemma guarded_functional_unique_choice :
  forall A `{Inhab B} (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists! y, R x y) ->
  (exists f, forall x, P x -> R x (f x)).
Proof using.
  introv I M. apply (functional_choice (fun x y => P x -> R x y)).
  intros. apply indep_general_premises.
  introv H. destruct* (M _ H) as (y&Hy&_).
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Omniscient functional unique choice *)

Lemma omniscient_functional_unique_choice :
  forall A `{Inhab B} (R : A->B->Prop),
  exists f, forall x, (exists! y, R x y) -> R x (f x).
Proof using.
  intros. destruct (omniscient_functional_choice R) as [f F].
  exists f. introv (y&Hy&Uy). autos*.
Qed.

(* ********************************************************************** *)
(** * Relational choice *)

(** Relational choice can be used to extract from a relation a subrelation
    that describes a function, by mapping every argument to a unique image. *)

(* ---------------------------------------------------------------------- *)
(** ** Relational choice *)

Lemma rel_choice : forall A B (R:A->B->Prop),
  (forall x, exists y, R x y) ->
  (exists R', rel_incl R' R
           /\ forall x, exists! y, R' x y).
Proof using.
  introv H. destruct~ (functional_choice R) as [f Hf].
  exists (fun x y => f x = y). split.
    introv E. simpls. subst~.
    intros x. exists~ (f x).
Qed.

(* --TODO: Dependent relational choice, is it meaningful?, useful? *)

(* ---------------------------------------------------------------------- *)
(** ** Guarded relational choice *)

Lemma guarded_rel_choice : forall A B (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists y, R x y) ->
  (exists R', rel_incl R' R
           /\ forall x, P x -> exists! y, R' x y).
Proof using.
  intros. destruct (rel_choice (fun (x:sig P) (y:B) => R (sig_val x) y))
   as (R',(HR'R,M)).
    intros (x,HPx). destruct (H _ HPx) as (y,HRxy). exists~ y.
  set (R'' := fun (x:A) (y:B) => exists (H : P x), R' (exist P x H) y).
  exists R''. split.
    intros x y (HPx,HR'xy). apply (HR'R _ _ HR'xy).
    intros x HPx. destruct (M (exist P x HPx)) as (y,(HR'xy,Uniq)).
     exists y. split.
       exists~ HPx.
       intros y' (H'Px,HR'xy'). apply Uniq.
        rewrite~ (proof_irrelevance HPx H'Px).
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Omniscient relation choice *)

Lemma omniscient_rel_choice : forall A B (R : A->B->Prop),
  exists R', rel_incl R' R
          /\ forall x, (exists y, R x y) -> (exists! y, R' x y).
Proof using. intros. apply~ guarded_rel_choice. Qed.


(*|
################################################################
Coq: easiest way to construct members of a decidable sigma type?
################################################################

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

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

Consider the following toy development:
|*)

Inductive IsEven : nat -> Prop :=
| is_even_z : IsEven 0
| is_even_S : forall n, IsEven n -> IsEven (S (S n)).

Definition EvenNat := {n | IsEven n}.

(*|
I'd like to create a function that, given a number that I personally
know to be even, returns the corresponding value of type ``EvenNat``
with minimum fuss.

.. code-block:: coq

    Example fortyTwo : EvenNat := mkEven 42.
|*)

(*|
Answer (Théo Winterhalter)
**************************

I don't know exactly what your assumptions are but I would say one way
of doing it is to use the automation capabilities of type classes:
|*)

Reset Initial. (* .none *)
Require Import Coq.Init.Specif.

Inductive IsEven : nat -> Prop :=
| is_even_z : IsEven 0
| is_even_S : forall n, IsEven n -> IsEven (S (S n)).

Class EvenClass n :=
  is_even : IsEven n.

Definition EvenNat := { n | EvenClass n }.

Lemma EvenClass_IsEven :
  forall n, EvenClass n -> IsEven n.
Proof.
  intros n h. exact h.
Qed.

#[export] Hint Extern 1 (EvenClass 0) =>
  apply is_even_z
  : typeclass_instances.

#[export] Hint Extern 1 (EvenClass (S (S ?n))) =>
  apply is_even_S; apply EvenClass_IsEven
    : typeclass_instances.

#[export] Hint Extern 1 (EvenClass (proj1_sig ?x)) =>
  apply proj2_sig
  : typeclass_instances.

Ltac my_decision_procedure := id. (* .none *)
#[export] Hint Extern 4 (EvenClass ?n) =>
  my_decision_procedure
  : typeclass_instances.

(*|
Instead of defining instances, I use the ``Hint Extern`` mechanism to
inject any tactic I want to solve the goal. Assuming you have a tactic
to decide your property you can use it there. The natural number
indicates the "cost" to each hint so the search will try to apply the
hints with the lowest costs first.

Once you have this, the function you want is
|*)

Definition mkEven (n : nat) {h : EvenClass n} : EvenNat :=
  exist _ n h.

(*|
Then just writing ``mkEven n`` will trigger the proof search as
described by the hints above.
|*)

Definition ev := mkEven 42.

(*|
----

To elaborate the difference between Yves's and my answer, I chose to
use hints rather than class instances so that the proof search is not
too greedy.

For instance, I force the search to only use ``is_even_z`` when I
really want to prove ``EvenClass 0``, as exemplified by the example
below:
|*)

Goal exists n, EvenClass n.
Proof.
  eexists. Fail exact _.
Abort.

Instance foo : EvenClass 0.
Proof.
  exact _.
Qed.

Goal exists n, EvenClass n.
Proof.
  eexists. exact _.
Qed.

(*|
As you can see, in the first case, we have ``EvenClass ?n`` as a goal,
and so the proof search does not find any candidate. However, if we
add the ``0`` case as a type class instance, then the proof search
will succeed by unifying ``?n`` with ``0``. It is my belief that this
is doing a bit too much for the case at hand here, but both solutions
have their applications.
|*)

(*|
Answer (Yves)
*************

The question, as originally stated, has an obvious answer.

*Question A*: If you have in your context a number ``n`` of type
``nat`` and a proof ``knowledge`` with statement ``IsEven n``, how do
you construct an object of type ``EvenNat``?

you can simply construct an object of type ``EvenNat`` by writing the
following expression

.. code-block:: coq

    exist _ n knowledge

Or, if you really want to be explicit:

.. code-block:: coq

    exist IsEven n knowledge

This is embodied in the following script
|*)

Reset Initial. (* .none *)
Inductive IsEven : nat -> Prop :=
| is_even_z : IsEven 0
| is_even_S : forall n, IsEven n -> IsEven (S (S n)).

Definition EvenNat := {n | IsEven n}.

Definition mkEven (n : nat) (knowledge : IsEven n) : EvenNat :=
  exist IsEven n knowledge.

(*|
Another reading of the question is as follows:

*Question B*: how do you construct an object of type ``EvenNat`` from
a known constant (like ``42``) which is obviously even to the naked
eye?

Here is my elaboration of a solution sketched by Theo Winterhalter,
using the device of type classes in full.
|*)

Reset Initial. (* .none *)
Require Import Coq.Init.Specif.

Inductive IsEven : nat -> Prop :=
| is_even_z : IsEven 0
| is_even_S : forall n, IsEven n -> IsEven (S (S n)).

Definition EvenNat := {n | IsEven n}.

Definition makeEvenNat (n : nat) (knowledge : IsEven n) : EvenNat :=
  exist IsEven n knowledge.

Class EvenClass n : Prop :=
  is_even : IsEven n.

Instance evenClass0 : EvenClass 0.
Proof.
  apply is_even_z.
Qed.

Instance evenClassS n {h : EvenClass n}  : EvenClass (S (S n)).
Proof.
  apply is_even_S. exact h.
Qed.

(* Using curly braces for the second argument h here deserves an
  explanation. *)
Definition mkEven (n : nat) {h : EvenClass n} : EvenNat :=
  exist IsEven n h.

Definition ev42 := mkEven 42.

Lemma ev42P : proj1_sig ev42 = 42.
Proof. easy. Qed.

Lemma IsEven42 : IsEven 42.
Proof. exact (proj2_sig ev42). Qed.

(*|
The explanation for using curly braces in the definition of ``mkEven``
is that ``mkEven`` actually requires 2 arguments, but the second one
is not written by the user: it must be automatically constructed using
the type class inference mechanism. This proof must succeed for the
object to be actually defined.

The definition of ``ev42`` is the answer of question *B*. Note that a
definition relying on ``mkEven 3`` will fail, because no proof that
``3`` is even can be found.
|*)

Fail Definition ev3 := mkEven 3.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint half (half_arg0 : natural) : natural
           := match half_arg0 with
              | Zero => Zero
              | Succ Zero => Zero
              | Succ (Succ n) => Succ (half n)
              end.

Theorem plus_comm: forall (n m: natural), plus n m = plus m n.
Proof.
   induction n; induction m.
   { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
   { simpl. rewrite IHn. simpl. reflexivity. }
   { simpl. rewrite <- IHm. simpl. reflexivity. }
   { reflexivity. }
Qed.

Theorem theorem0 : forall (x : natural) (y : natural), eq (half (plus x y)) (half (plus y x)).
Proof.
   intros.
lfind.
Admitted.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import Ext_Cons.Arrow.
From Categories Require Import Coq_Cats.Type_Cat.Card_Restriction.
From Categories Require Export NatTrans.NatTrans NatTrans.Operations.
From Categories Require Export KanExt.Local KanExt.Global KanExt.GlobalDuality
        KanExt.GlobaltoLocal KanExt.LocaltoGlobal KanExt.LocalFacts.Main.
From Categories Require Export Cat.Terminal.

Local Open Scope functor_scope.

(** Definition of limits and colimits using right and left kan extensions
    along the functor to the terminal category. *)
Section Limit.
  Context {J C : Category} (D : J –≻ C).

  Definition Cone := LoKan_Cone (Functor_To_1_Cat J) D.

  Definition Cone_Morph Cn Cn' :=
    @LoKan_Cone_Morph _ _ (Functor_To_1_Cat J) _ D Cn Cn'.

  Definition Limit : Type := Local_Right_KanExt (Functor_To_1_Cat J) D.

  Definition limit_to_cone (l : Limit) : Cone := (LRKE l).

  Coercion limit_to_cone : Limit >-> Cone.

  Definition cone_to_obj (cn : Cone) : C := (cone_apex cn) _o tt.

  Coercion cone_to_obj : Cone >-> Obj.

  Definition is_Limit (Cn : Cone) :=
    is_Cone_Local_Right_KanExt (Functor_To_1_Cat J) D Cn.

  Definition is_Limit_Limit {Cn : Cone} (il : is_Limit Cn) : Limit :=
    is_Cone_Local_Right_KanExt_Local_Right_KanExt (Functor_To_1_Cat J) D il.

  Definition Limit_is_Limit {L : Limit} : is_Limit L :=
    Local_Right_KanExt_is_Cone_Local_Right_KanExt (Functor_To_1_Cat J) D L.

End Limit.

(** Limits are unique up to isomorphism. *)
Program Definition Limit_Iso {J C : Category} {D : J –≻ C} (l l' : Limit D) :
  (l ≃≃ l' ::> C)%isomorphism :=
  {|
    iso_morphism :=
      Trans
        (cone_morph (iso_morphism (Local_Right_KanExt_unique _ _ l l')))
        tt;
    inverse_morphism :=
      Trans
        (cone_morph (inverse_morphism (Local_Right_KanExt_unique _ _ l l')))
        tt
  |}.

Next Obligation.
Proof (
    f_equal
      (fun x : LoKan_Cone_Morph l l => Trans (cone_morph x) tt)
      (left_inverse (Local_Right_KanExt_unique _ _ l l'))
  ).

Next Obligation.
Proof (
    f_equal
      (fun x : LoKan_Cone_Morph l' l' => Trans (cone_morph x) tt)
      (right_inverse (Local_Right_KanExt_unique _ _ l l'))
  ).

(** Proposition stating that category C has all limits of cardinality
    specified by P *)
Definition Has_Restr_Limits (C : Category) (P : Card_Restriction) :=
  ∀ {J : Category} (D : J –≻ C), P J → P (Arrow J) → Limit D.

(** A complete category has all limits – here it has global
    right kan extension *)
Definition Complete (C : Category) :=
  ∀ J : Category, Right_KanExt (Functor_To_1_Cat J) C.

Existing Class Complete.

(** If a category is complete, we can produce all limits. *)
Definition LimitOf {C D : Category} {H : Complete D} (F : C –≻ D) : Limit F :=
  Global_to_Local_Right _ _ (H _) F.

(** A category having restricted limitis where the restriction always holds
is just complete. *)
Section Restricted_Limits_to_Complete.
  Context {C : Category} {P : Card_Restriction} (HRL : Has_Restr_Limits C P).

  Definition No_Restriction_Complete : (∀ t, P t) → Complete C :=
    fun All_Ps J => Local_to_Global_Right
                   _ _ (fun D => HRL _ D (All_Ps J) (All_Ps (Arrow J))).

End Restricted_Limits_to_Complete.

(** A complete category has restricted limits for any restriction. *)
Section Complete_to_Restricted_Limits.
  Context (C : Category) {CC : Complete C} (P : Card_Restriction).

  Definition Complete_Has_Restricted_Limits : Has_Restr_Limits C P :=
    fun J D _ _ => Global_to_Local_Right _ _ (CC _) D.

End Complete_to_Restricted_Limits.

(** A functor is continuous if it preserces all limits. *)
Section Continuous.
  Context
    {C D : Category}
    (CC : Complete C)
    (G : (C –≻ D)%functor)
  .

  Section Cone_Conv.
    Context
      {J : Category}
      {F : (J –≻ C)%functor}
      (Cn : Cone F)
    .

    Program Definition Cone_Conv : Cone (G ∘ F)%functor
      :=
        {|
          cone_apex :=
            (G ∘ (cone_apex Cn))%functor;
          cone_edge :=
            (((NatTrans_id G)
                ∘_h (cone_edge Cn)) ∘ (NatTrans_Functor_assoc _ _ _))%nattrans
        |}
    .

  End Cone_Conv.

  Definition Continuous :=
    ∀ (J : Category) (F : (J –≻ C)%functor),
      is_Cone_Local_Right_KanExt _ _ (Cone_Conv (LRKE (LimitOf F)))
  .

End Continuous.

(** CoLimits *)

Section CoLimit.
  Context {J C : Category} (D : J –≻ C).

  Definition CoCone :=
    LoKan_Cone (Functor_To_1_Cat J^op) (D^op).

  Definition CoCone_Morph Cn Cn' :=
    @LoKan_Cone_Morph _ _ (Functor_To_1_Cat J^op) _ (D^op) Cn Cn'.

  Definition CoLimit := Local_Left_KanExt (Functor_To_1_Cat J) D.

  Definition is_CoLimit (Cn : CoCone) :=
    is_Cone_Local_Right_KanExt (Functor_To_1_Cat (J^op)) (D^op) Cn.

  Definition is_CoLimit_CoLimit {Cn : CoCone} (il : is_CoLimit Cn) : CoLimit :=
    is_Cone_Local_Right_KanExt_Local_Right_KanExt
      (Functor_To_1_Cat (J^op)) (D^op) il.

  Definition CoLimit_is_CoLimit {L : CoLimit} : is_CoLimit L :=
    Local_Right_KanExt_is_Cone_Local_Right_KanExt
      (Functor_To_1_Cat (J^op)) (D^op) L.

End CoLimit.

(** Proposition stating that category C has all colimits of
    cardinality specified by P *)
Definition Has_Restr_CoLimits (C : Category) (P : Card_Restriction) :=
  ∀ {J : Category} (D : J –≻ C), P J → P (Arrow J) → CoLimit D.

(** A cocomplete category has all colimits – here it has global
    left kan extension *)
Definition CoComplete (C : Category) :=
  ∀ J : Category, Left_KanExt (Functor_To_1_Cat J) C.

Existing Class CoComplete.

(** If a category is cocomplete, we can produce all colimits. *)
Definition CoLimitOf {C D : Category} {H : CoComplete D} (F : C –≻ D) :
  CoLimit F := Global_to_Local_Left _ _ (H _) F.

(** If a category is complete, its dual is cocomplete *)
Definition Complete_to_CoComplete_Op {C : Category} {CC : Complete C}
  : CoComplete (C ^op) :=
fun D => KanExt_Right_to_Left (Functor_To_1_Cat D ^op) C (CC (D ^op)%category).

(** If a category is cocomplete, its dual is complete *)
Definition CoComplete_to_Complete_Op {C : Category} {CC : CoComplete C}
  : Complete (C ^op) :=
    fun D => KanExt_Left_to_Right (Functor_To_1_Cat D ^op) C (CC (D ^op)%category).

(** A category having restricted colimitis where the restriction always holds
is just cocomplete. *)
Section Restricted_CoLimits_to_CoComplete.
  Context {C : Category} {P : Card_Restriction} (HRL : Has_Restr_CoLimits C P).

  Definition No_Restriction_CoComplete : (∀ t, P t) → CoComplete C :=
    fun All_Ps J =>
      Local_to_Global_Left _ _ (fun D => HRL _ D (All_Ps J) (All_Ps (Arrow J))).

End Restricted_CoLimits_to_CoComplete.

(** A cocomplete category has restricted colimits for any restriction. *)
Section CoComplete_to_Restricted_CoLimits.
  Context (C : Category) {CC : CoComplete C} (P : Card_Restriction).

  Definition CoComplete_Has_Restricted_CoLimits : Has_Restr_CoLimits C P :=
    fun J D _ _ => Global_to_Local_Left _ _ (CC _) D.

End CoComplete_to_Restricted_CoLimits.

(** If a category has restricted limits, its dual has restricted colomits *)
Definition Has_Restr_Limits_to_Has_Restr_CoLimits_Op
        {C : Category} {P : Card_Restriction}
        (HRL : Has_Restr_Limits C P) :
  Has_Restr_CoLimits (C ^op) P :=
  (fun (D : Category)
       (F : D –≻ C ^op)
       (H1 : P D)
       (H2 : P (Arrow D)) =>
     HRL
       (D ^op)%category
       (F ^op)%functor H1
       (Card_Rest_Respect P (Arrow D) (Arrow (D^op)) (Arrow_OP_Iso D) H2)
  ).

(** If a category has restricted colimits, its dual has restricted lomits *)
Definition Has_Restr_CoLimits_to_Has_Restr_Limits_Op
        {C : Category}
        {P : Card_Restriction}
        (HRL : Has_Restr_CoLimits C P) :
  Has_Restr_Limits (C ^op) P :=
  (fun (D : Category)
       (F : D –≻ C ^op)
       (H1 : P D)
       (H2 : P (Arrow D)) =>
     HRL
       (D ^op)%category
       (F ^op)%functor
       H1
       (Card_Rest_Respect P (Arrow D) (Arrow (D^op)) (Arrow_OP_Iso D) H2)
  ).

(** A functor is co-continuous if it preserces all co-limits. *)
Section CoContinuous.
  Context
    {C D : Category}
    (CC : CoComplete C)
    (G : (C –≻ D)%functor)
  .

  Section CoCone_Conv.
    Context
      {J : Category}
      {F : (J –≻ C)%functor}
      (Cn : CoCone F)
    .

    Program Definition CoCone_Conv : CoCone (G ∘ F)%functor
      :=
        {|
          cone_apex :=
            ((G ^op) ∘ (cone_apex Cn))%functor;
          cone_edge := _
                         (((NatTrans_id (G ^op)) ∘_h (cone_edge Cn))
                            ∘ (NatTrans_Functor_assoc _ _ _))%nattrans
        |}
    .

  End CoCone_Conv.

  Definition CoContinuous :=
    ∀ (J : Category) (F : (J –≻ C)%functor),
      is_Cone_Local_Right_KanExt _ _ (CoCone_Conv (LRKE (CoLimitOf F)))
  .

End CoContinuous.