(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat div fintype connect.
Require Import finset groups cyclic ssralg.

Import GroupScope.

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

Definition involg (gT : finGroupType) (a : gT) := involutive (mulg a).

Lemma involgKP : forall (gT : finGroupType) (a : gT),
  reflect (involg a) (a * a == 1).
Proof.
move=> gT a; apply:(iffP eqP)=> Ha; first by move=> x; rewrite mulgA Ha mul1g.
by rewrite -{2}(mulg1 a).
Qed.

Lemma invol_conjg_expn : forall (gT:finGroupType) (a t:gT),
  (involg t) -> forall n, a ^+ n ^t = (a ^ t) ^+n.
Proof.
move=> gT a t Hi; move/involgKP: Hi=> Heq.
elim =>[|n IHn]; first by rewrite !expg0 conj1g.
by rewrite !expgS conjMg IHn.
Qed.

Lemma involgen_order : forall (gT: finGroupType) (t: gT),
  (involg t) -> t !=1 -> #[t] = 2.
move=> gT t Hi; have:= (trivg_card1 <[t]>); rewrite cycle_eq1=>-> /=.
move/involgKP: Hi; have:= (expgS t 1); rewrite expg1=> <-.
move/order_inf;move: (order_gt0 t); rewrite /order /=.
case : #|<[t]>| => [|n0] ; first by rewrite ltn0.
by case :n0=> [|n1] // _; rewrite !ltnS leq_eqVlt ltn0 orbF; move/eqP->.
Qed.

Lemma involgen_group2 : forall (gT:finGroupType) (t:gT),
  (involg t) -> t != 1 -> <[t]> = [set 1;t].
Proof.
move=> gT t Hi Hn1; apply/eqP.
rewrite eqEsubset subUset !sub1set group1 cycle_id !andbT.
have G1t: (group_set [set 1; t]).
apply/group_setP; split; first by apply/setUP; left; apply/set1P.
move=> x y; move/setUP; case; move/set1P->; move/setUP; case; move/set1P->;
  rewrite ?mul1g ?mulg1 inE !in_set1 ?eq_refl ?orbT //.
  by move/involgKP: Hi->.
by rewrite -[[set 1; t]]/(gval (group G1t)) gen_subG /= sub1set inE !in_set1 eq_refl ?orbT.
Qed.

Module Type  Dihedral.
Parameter gT : finGroupType.
Parameter D : {group gT}.
Parameter c : gT.
Axiom dhntriv : (cycle c) != 1.
Axiom dhsub : c \in D.
Axiom dhindex : #|D : (cycle c)| = 2.
Axiom dhinvol : forall t, (t \in (D:\: (cycle c))) -> involg t.
End Dihedral.

Section Involutions.
Variable gT : finGroupType.
Variable D : {group gT}.
Variable c : gT.
Hypothesis dhsub : c \in D.
Hypothesis dhindex : #|D : (cycle c)| = 2.

Notation Local C := (cycle c).

Lemma D_order : (#|C| * 2 = #|D|)%nat.
Proof.
move: dhsub; rewrite -cycle_subG; move/LaGrange.
by rewrite dhindex.
Qed.

Variable t :gT.
Variable Ht : t \in D:\:C.
Hypothesis Hit : involg t.

Lemma DmC_coset : D :\: C = C :* t.
Proof.
apply/eqP; rewrite eq_sym eqEcard card_rcoset.
have:= (cardsID C D); rewrite setIC; move: dhsub.
rewrite -cycle_subG; move/setIidPl ->; move/eqP.
rewrite -D_order mulnSr muln1 eqn_addl; move/eqP ->; rewrite leqnn andbT.
apply/subsetP=> x Hx; rewrite inE andbC; apply/andP; split;
move/rcosetP:Hx=> [a Heq] ->; move: Ht; rewrite inE; move/andP=> [HnC].
  move: dhsub; rewrite -cycle_subG; move/subsetP; move/(_ _ Heq).
  by move/groupMl ->.
by move=> [_]; rewrite (groupMl _ Heq).
Qed.

Lemma DmC_involP :
 reflect (forall u, (u \in D:\:C) -> involg u)
 (c ^ t == c ^-1).
Proof.
rewrite DmC_coset; apply:(iffP eqP).
  move=> Heq x; move/rcosetP=> [a Ha]->.
  move/cycleP: Ha => [n ->]; apply/involgKP; move/involgKP: Hit.
  rewrite  -{2}(invgK t) -eq_mulgV1 =>Hti.
  rewrite {1}(eqP Hti) -mulgA -/(conjg (c ^+ n) t).
  by rewrite (invol_conjg_expn _ Hit) Heq expVgn mulgV.
move=> Hix; apply/eqP; rewrite eq_sym eq_mulVg1 invgK conjgE; move: Hit.
move/involgKP; rewrite -{2}(invgK t) -eq_mulgV1 mulgA; move/eqP<-.
apply/involgKP; apply: (Hix (c * t)); apply/rcosetP; exists c => //.
by apply:cycle_id.
Qed.

End Involutions.

Module DihedralTheory (Dh:Dihedral).

Notation Local gT := Dh.gT.
Notation Local D := Dh.D.
Notation Local c := Dh.c.
Notation Local dhntriv := Dh.dhntriv.
Notation Local dhsub := Dh.dhsub.
Notation Local dhindex := Dh.dhindex.
Notation Local dhinvol := Dh.dhinvol.

Notation Local C := (cycle c).

Lemma DmCJ : forall a y, a \in C -> y \in D:\:C -> a ^ y = a ^-1.
Proof.
move=> a y Ha Hy; move/cycleP:Ha=> [n] ->; move/involgKP:(dhinvol Hy) => Heq.
apply/eqP; rewrite eq_sym eq_mulVg1 invgK conjgE mulgA.
move: Heq; rewrite -{2}(invgK y) -eq_mulgV1; move/eqP<-.
apply/involgKP; apply:dhinvol; rewrite (DmC_coset dhsub dhindex Hy).
apply/rcosetP; exists (c^+n) => //; apply:mem_cycle.
Qed.

Lemma Dgen : forall t, t\in D:\:C -> <<[set c * t; t]>> = D.
Proof.
move=> t Ht; apply/eqP; rewrite eqEcard.
have c2sub : <<[set c * t; t]>> \subset D.
  rewrite gen_subG subUset !sub1set (groupMl _ dhsub).
  by move:Ht; rewrite inE; move/andP=>[_] ->.
rewrite c2sub /=.
have: C \proper <<[set c* t; t]>>.
  rewrite properE gen_subG sub1set; apply/andP; split.
    apply/generatedP=> G; rewrite subUset !sub1set; move/andP=> [Gct Gt].
    rewrite -(mulg1 c); move/involgKP: (dhinvol Ht); move/eqP <-; rewrite mulgA.
    by rewrite (groupMl _ Gct).
  apply/subsetPn; exists t; first by apply:mem_gen; rewrite !inE eq_refl orbT.
  by move: Ht; rewrite inE; move/andP=> [H].
rewrite properEcard; move/andP=> [HCsub HCcard].
rewrite -(D_order dhsub dhindex); move: (cardSg HCsub).
move/dvdnP=> [k Hk]; rewrite Hk mulnC leq_mul2r.
move/eqP: Hk; rewrite -(LaGrange HCsub) mulnC /= eqn_mul2r.
move:(cardG_gt0 [group of C]); rewrite eqn0Ngt /= => -> /=.
move/eqP<-.
case e: #|<<[set c * t; t]>> : C|=>[|n0];
  first by move/eqP: e; rewrite eqn0Ngt indexg_gt0.
rewrite ltnS; move:e; case n0=>[|n1]; last by rewrite ltn0Sn.
by move/(index1g HCsub)=>Hcsub; move:HCcard; injection Hcsub=>->; rewrite ltnn.
Qed.

End DihedralTheory.

Section InvoGen.

Variable gT :finGroupType.
Variables s t : gT.
Hypothesis His : involg s.
Hypothesis Hit: involg t.
Hypothesis Hdistinct: s != t.
Hypothesis Htn1 : t != 1.
Hypothesis Hsn1 : s != 1.

Notation Local D := <<[set s; t]>>.
Notation Local C := (cycle (s * t)).

Lemma Cntriv : C != 1.
Proof.
apply/eqP; apply/trivgP; rewrite gen_subG sub1set inE; move: (His 1); move/eqP.
by rewrite mulg1 -{2}(invgK s) -eq_mulgV1; move/eqP->; rewrite -eq_mulVg1.
Qed.

Lemma DC_invol : (s * t) ^ t = (s * t) ^-1.
Proof.
apply/eqP; move/involgKP: Hit; rewrite conjgE -mulgA invMg; move/eqP->.
by move/involgKP: His; rewrite mulg1 -{2}(invgK s) -eq_mulgV1; move/eqP<-.
Qed.

Lemma DC_norm : t \in 'N_D(C).
Proof.
rewrite inE; apply/andP; split.
  by apply/generatedP=> G; rewrite subUset !sub1set; move/andP=> [_].
rewrite -sub1set; apply/normsP => x; move/set1P->.
rewrite -genJ conjg_set1 DC_invol; exact: cycleV.
Qed.

Lemma DCt : C * (cycle t) = D.
Proof.
suff : (s \in C * (cycle t)) && (t \in C * (cycle t)).
  move=> Hst; apply/eqP; rewrite eqEsubset.
  apply/andP; split; last first.
  have GCt : (group_set (C * <[t]>)).
    apply/comm_group_setP; apply:commute_sym; apply:normC; move: DC_norm.
    by move/setIP=>[_]; rewrite -sub1set -gen_subG.
  by rewrite -[C * <[t]>]/(gval (group GCt)) gen_subG subUset !sub1set /=.
by apply: mul_subG; rewrite gen_subG ?subUset sub1set ?groupM ?mem_gen //
  in_setU !in_set1 eq_refl ?orbT.
rewrite -{1}(mulg1 s) -(mulgV t) -{5}(mul1g t).
move/involgKP: Hit; rewrite -{2}(invgK t) -eq_mulgV1 mulgA; move/eqP<-.
by rewrite !mem_mulg ?group1 ?mem_gen ?inE ?eq_refl.
Qed.

Lemma Cnotst : ~~ ((s \in C) || (t \in C)).
Proof.
apply/negP =>H; have {H}Hboth: (s \in C) && (t\in C).
  by case/orP: H=> H; move: (cycle_id (s * t));
    rewrite ?(groupMl _ H) ?(groupMr _ H) => Hcyc; rewrite H Hcyc.
case e: (2 %| #[s * t]); move/andP:Hboth=> [Hsin]; move/cycleP=>[n0 H];
move: (cycleX (s * t) n0); rewrite -H; last first.
  by move/cardSg; rewrite [#|_|]involgen_order // e.
move/cycleP:Hsin =>[n1 H1]; move: (cycleX (s * t) n1); rewrite -H1=> sCsub tCsub.
set SG := [set H : {group gT} | (H \subset C) && (#|H| == 2)].
rewrite /= in SG; have :[group of <[s]>] \in SG.
by rewrite inE /= sCsub; move: (involgen_order His Hsn1); rewrite /order => ->.
have :[group of <[t]>] \in SG.
by rewrite inE /= tCsub; move: (involgen_order Hit Htn1); rewrite /order => ->.
rewrite /SG (cycle_sub_group e) !in_set1.
move/eqP<-; move/eqP; rewrite /= /group =>Hst.
have {Hst}: <[s]> = <[t]> by rewrite -![<[_]>]/(gval _) /cycle_group Hst /=.
rewrite (involgen_group2 Hit Htn1) (involgen_group2 His Hsn1); move/eqP.
rewrite eqEsubset !subUset !sub1set !inE eq_refl (negbTE Hsn1) (negbTE Htn1) /=.
by rewrite (negbTE Hdistinct).
Qed.

Lemma Ctcap : C :&: <[t]> = 1.
Proof.
move: Cnotst; rewrite negb_or; move/andP=>[_] HtnC.
rewrite (involgen_group2 Hit Htn1) setIUr.
move: (group1 [group of C]); rewrite -sub1set /=.
move/setIidPr->; move: (subsetIr C [set t]).
rewrite subset1; case/orP; last by move/eqP=>->; rewrite setU0.
by move/eqP; move/setIidPr; rewrite sub1set=>H; move: HtnC; rewrite H.
Qed.

Lemma DCindex : #|D : C| = 2.
Proof.
move: (divgI [group of D] [group of C]).
rewrite /= -DCt -group_modl ?subset_refl // -(setIC C <[t]>) Ctcap mulg1.

rewrite (TI_cardMg Ctcap) mulKn ?order_gt0 // =><- /=.
by rewrite [#|<[_]>|](involgen_order Hit Htn1).
Qed.

End InvoGen.

Module Involuted : Dihedral.
Variable gT :finGroupType.
Variables s t : gT.
Hypothesis His : involg s.
Hypothesis Hit: involg t.
Hypothesis Hdistinct: s != t.
Hypothesis Htn1 : t != 1.
Hypothesis Hsn1 : s != 1.

Definition D := [group of <<[set s; t]>>].
Definition c := (s * t).
Definition dhntriv : (cycle c) != 1 := (Cntriv His Hdistinct).
Lemma dhsub : c \in D.
Proof.
apply/generatedP=> G; rewrite subUset !sub1set; move/andP=>[Gs Gt].
by apply:groupM.
Qed.
Definition dhindex : #|D : (cycle c)| = 2 :=
  DCindex His Hit Hdistinct Htn1 Hsn1.
Lemma dhinvol : forall t, (t \in (D:\: (cycle c))) -> involg t.
Proof.
apply/(DmC_involP dhsub dhindex _ Hit ); last first.
  apply/eqP; apply:DC_invol; [exact:His|exact:Hit].
have:= (Cnotst His Hit Hdistinct Htn1 Hsn1); rewrite negb_or inE.
move/andP=> [_] -> /=; rewrite -(DCt His Hit) -{1}(mul1g t).
by apply:mem_mulg; rewrite ?group1 ?cycle_id.
Qed.
End Involuted.


(** * 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 .

*)

(** ** Preambule *)

(** Settings *)

Unset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)

(** Imports *)

Add LoadPath "../.." .

Require Export Foundations.hlevel2.hnat .

(** Upstream *)

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

(** *** General definitions *)

Definition hz : commrng := commrigtocommrng natcommrig .
Definition hzaddabgr : abgr := rngaddabgr hz .
Definition hzmultabmonoid : abmonoid := rngmultabmonoid hz .

Definition natnattohz : nat -> nat -> hz := fun n m => setquotpr _ ( dirprodpair n m ) .

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

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

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 ( abgrfrac ( rigaddabmonoid natcommrig ) ) ) . apply isdeceqabgrfrac . apply isinclnatplusr .  apply isdeceqnat .  Defined .

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

Definition hzeq ( x y : hz ) : hProp := hProppair ( paths x y ) ( isasethz _ _  )  .
Definition isdecrelhzeq : isdecrel hzeq  := fun a b => isdeceqhz a b .
Definition hzdeceq : decrel hz := decrelpair isdecrelhzeq .

(* Canonical Structure hzdeceq. *)

Definition hzbooleq := decreltobrel hzdeceq .

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

(* Canonical Structure hzdecneq. *)

Definition hzboolneq := decreltobrel hzdecneq .

Open Local Scope hz_scope .

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

Lemma isnonzerornghz : isnonzerorng hz .
Proof . apply  ( ct ( hzneq , isdecrelhzneq, 1 , 0 ) ) . Defined .

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

Definition hzminuszero : paths ( - 0 ) 0 := rnginvunel1 hz .

Lemma hzplusr0 ( x : hz ) : paths ( x + 0 ) x .
Proof . intro . apply ( rngrunax1 _ x ) .  Defined .

Lemma hzplusl0 ( x : hz ) : paths ( 0 + x ) x .
Proof . intro . apply ( rnglunax1 _ x ) . Defined .

Lemma hzplusassoc ( x y z : hz ) : paths ( ( x + y ) + z ) ( x + ( y + z ) ) .
Proof . intros . apply ( rngassoc1 hz x y z ) . Defined .

Lemma hzpluscomm ( x y : hz ) : paths ( x + y ) ( y + x ) .
Proof . intros .  apply ( rngcomm1 hz x y ) . Defined .

Lemma hzlminus ( x : hz ) : paths ( -x + x ) 0 .
Proof . intro. apply ( rnglinvax1 hz x ) . Defined .

Lemma hzrminus  ( x : hz ) : paths ( x - x ) 0 .
Proof . intro. apply ( rngrinvax1 hz x ) . Defined .

Lemma isinclhzplusr ( n : hz ) : isincl ( fun m : hz => m + n ) .
Proof. intro . apply ( pr2 ( weqtoincl _ _ ( weqrmultingr hzaddabgr n ) ) ) . Defined.

Lemma isinclhzplusl ( n : hz ) : isincl ( fun m : hz => n + m ) .
Proof.  intro.  apply ( pr2 ( weqtoincl _ _ ( weqlmultingr hzaddabgr n ) ) ) . Defined .

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

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

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

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

Lemma hzmultr1 ( x : hz ) : paths ( x * 1 ) x .
Proof . intro . apply ( rngrunax2 _ x ) .  Defined .

Lemma hzmultl1 ( x : hz ) : paths ( 1 * x ) x .
Proof . intro . apply ( rnglunax2 _ x ) . Defined .

Lemma hzmult0x ( x : hz ) : paths ( 0 * x ) 0 .
Proof . intro . apply ( rngmult0x _ x ) .  Defined .

Lemma hzmultx0 ( x : hz ) : paths ( x * 0 ) 0 .
Proof . intro . apply ( rngmultx0 _ x ) . Defined .

Lemma hzmultassoc ( x y z : hz ) : paths ( ( x * y ) * z ) ( x * ( y * z ) ) .
Proof . intros . apply ( rngassoc2 hz x y z ) . Defined .

Lemma hzmultcomm ( x y : hz ) : paths ( x * y ) ( y * x ) .
Proof . intros .  apply ( rngcomm2 hz  x y ) . Defined .

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

Definition hzneq0andmultrinv ( n m : hz ) ( isnm : hzneq ( n * m ) 0 ) : hzneq m 0 := rngneq0andmultrinv 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 := rigtorngrel natcommrig isplushrelnatgth .

Definition hzlth : hrel hz := fun a b => hzgth b a .

Definition hzleh : hrel hz := fun a b => hProppair ( neg ( hzgth a b ) ) ( isapropneg _ )  .

Definition hzgeh : hrel hz := fun a b => hProppair ( neg ( hzgth b a ) ) ( isapropneg _ )  .

(** *** Decidability *)

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

Definition hzgthdec := decrelpair isdecrelhzgth .

(* Canonical Structure hzgthdec . *)

Definition isdecrelhzlth : isdecrel hzlth := fun x x' => isdecrelhzgth x' x .

Definition hzlthdec := decrelpair isdecrelhzlth .

(* Canonical Structure hzlthdec . *)

Definition isdecrelhzleh : isdecrel hzleh := isdecnegrel _ isdecrelhzgth .

Definition hzlehdec := decrelpair isdecrelhzleh .

(* Canonical Structure hzlehdec . *)

Definition isdecrelhzgeh : isdecrel hzgeh := fun x x' => isdecrelhzleh x' x .

Definition hzgehdec := decrelpair 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 ( istransabgrfracrel nataddabmonoid isplushrelnatgth )  .  unfold istrans .  apply istransnatgth .  Defined.

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

Lemma hzgthtoneq ( n m : hz ) ( g : hzgth n m ) : neg ( paths 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 ( isasymmabgrfracrel nataddabmonoid isplushrelnatgth )  . unfold isasymm .  apply isasymmnatgth .  Defined .

Lemma isantisymmneghzgth ( n m : hz ) : neg ( hzgth n m ) -> neg ( hzgth m n ) -> paths n m .
Proof . apply ( isantisymmnegabgrfracrel 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 ) -> coprod ( hzgth m n ) ( paths n m ) .
Proof . 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 x y z gxz .  destruct ( isdecrelhzgth x y ) as [ gxy | ngxy ] . apply ( hinhpr _ ( ii1 gxy ) ) . apply hinhpr .   apply ii2 .  destruct ( isdecrelhzgth y x ) 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 := fun 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 ( paths 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 := fun lnm lmn => isasymmhzgth _ _ lmn lnm .

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

Definition isnegrelhzlth : isnegrel hzlth := fun n m => isnegrelhzgth m n .

Definition iscoantisymmhzlth ( n m : hz ) : neg ( hzlth n m ) -> coprod ( hzlth m n ) ( paths n m ) .
Proof . intros n m 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 n m k 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 -> paths 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 := fun gnm gmk => istranshzleh _ _ _ gmk gnm .

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

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

Definition isnegrelhzgeh : isnegrel hzgeh := fun n m => isnegrelhzleh m n .

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

Definition istotalhzgeh : istotal hzgeh := fun n m => istotalhzleh m n .

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

Definition hzgthtogeh ( n m : hz ) : hzgth n m -> hzgeh n m .
Proof. intros n m 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 n m is is' . apply ( is is' ) .  Defined .

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

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

Definition hzlthtoneghzgeh ( n m : hz ) : hzlth n m -> neg ( hzgeh n m ) := fun 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 n m 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 := fun nl => neghzgthtoleh _ _ nl .

(** *** Comparison alternatives *)

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

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

Definition hzneqchoice ( n m : hz ) ( ne : neg ( paths n m ) ) : coprod ( 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 ) : coprod ( hzlth n m ) ( paths 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 ) : coprod ( hzgth n m ) ( paths 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 n m k 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 n m k 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 n m k 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 n m k 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 ( isbinopabgrfracrel nataddabmonoid isplushrelnatgth ) ) .   Defined .

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

Definition hzgthandpluslinv  ( n m k : hz ) : hzgth ( k + n ) ( k + m ) -> hzgth n m  .
Proof. intros n m k 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 n m k 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 . intro . 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 isrngmulthzgth : isrngmultgt _ hzgth .
Proof . apply ( isrngrigtorngmultgt natcommrig isplushrelnatgth isrigmultgtnatgth )  . Defined .

Lemma  isinvrngmulthzgth : isinvrngmultgt _ hzgth .
Proof . apply ( isinvrngrigtorngmultgt natcommrig isplushrelnatgth isinvplushrelnatgth isinvrigmultgtnatgth ) . Defined .

(** *** Negation and comparisons *)

(** [ hzgth ] *)

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

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

(** [ hzlth ] *)

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

Lemma hzminusandlth0  { n : hz } ( is : hzlth ( - n ) 0 ) : hzgth n 0 .
Proof . intros .  apply ( rngtogt0 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 . intro n . apply ( negf ( @hzminusandlth0 n ) ) . Defined .

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

(** [ hzgeh ] *)

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

Lemma hzminusandgeh0  { n : hz } ( is : hzgeh ( - n ) 0 ) : hzleh n 0 .
Proof . intro n . 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. apply ( isrngmultgttoislrngmultgt _ isplushrelhzgth isrngmulthzgth ) .   Defined .

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

Definition  hzgthandmultlinv ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth ( k * n ) ( k * m ) -> hzgth n m .
Proof . intros n m k is is' .  apply ( isinvrngmultgttoislinvrngmultgt hz isplushrelhzgth isinvrngmulthzgth 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 n m k is is' .  apply ( isinvrngmultgttoisrinvrngmultgt hz isplushrelhzgth isinvrngmulthzgth 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 isrngmulthzgth . 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 ( rngmultgt0lt0 hz isplushrelhzgth isrngmulthzgth ) . 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 := isrngmulthzgth _ _ ism' isn' ) . rewrite ( rngmultminusminus 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 isnonzerornghz .  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 ( paths c 0 ) ) ( e : paths ( c * a ) ( c * b ) ) : paths a b .
Proof . intros . apply ( intdomlcan hzintdom _ _ _ ne e ) . Defined .

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

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

Lemma isinclhzmultr ( n : hz )( ne : neg ( paths n 0 ) ) : isincl ( fun 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 n m 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 n m 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 : forall n m , isaprop ( hzgth n m -> hzgeh n ( m + 1 )  ) ) . intros . apply impred . intro . apply ( pr2 _ ) .  unfold hzgth in * .  apply ( setquotuniv2prop _ ( fun n m => hProppair _ ( int n m ) ) ) . set ( R := abgrfracrelint nataddabmonoid natgth ) . intros x x' .  change ( R x x' -> ( neg ( R ( @op ( abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig) ) x' ( dirprodpair 1%nat 0%nat ) ) x ) ) ) .  unfold R . unfold abgrfracrelint . simpl . apply ( @hinhuniv _  (hProppair ( neg ( ishinh_UU _ ) ) ( isapropneg _ ) ) ) .  intro t2 . simpl . unfold neg .  apply ( @hinhuniv _ ( hProppair _ isapropempty ) ) .  intro t2' . set ( x1 := pr1 x ) . set ( a1 := pr2 x ) . set ( x2 := pr1 x' ) . set ( a2 := pr2 x' ) . set ( c1 := pr1 t2 ) . set ( r1 := pr2 t2 ) . clearbody r1 . change ( pr1 ( natgth ( x1 + a2 + c1 ) (  x2 + a1 + c1 ) ) ) in r1 . set ( c2 := pr1 t2' ) . set ( r2 := pr2 t2' ) . clearbody r2 .  change ( pr1 ( natgth ( ( x2 + 1 ) + a1 + c2 ) ( x1 + ( a2 + 0 ) + c2 ) ) ) in r2 .  set ( r1' := natgthandplusrinv _ _ c1 r1 ) .  set ( r2' := natgthandplusrinv _ _ c2 r2 ) .  rewrite ( natplusr0 _ ) in r2' . rewrite ( natpluscomm _ 1 ) in r2' .  rewrite ( natplusassoc _ _ _ ) in r2' . apply ( natgthtogehsn _ _ r1' r2' ) . Defined .

Lemma hzgthsntogeh ( n m : hz ) : hzgth ( n + 1 ) m -> hzgeh n m .
Proof. intros n m 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 n m X . apply ( hzlthlehtrans _ _ _ ( hzlthnsn n ) X ) .  Defined .

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

Lemma hzlthsntoleh ( n m : hz ) : hzlth n ( m + 1 ) -> hzleh n m .
Proof. intros n m 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 n m 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 ) ( paths n m ) .
Proof . intros n m 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 ) ) ( paths n m ) .
Proof . intros n m 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 ) ) ( paths n ( m + 1 ) ) .
Proof.  intros n m 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 ) ( paths ( n + 1 )  m ) .
Proof.  intros n m 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  ( fun 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 := fun n => setquotpr _ ( dirprodpair n 0%nat ) .

Definition isinclnattohz : isincl nattohz := isincltorngdiff natcommrig ( fun n => isinclnatplusr n ) .

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

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

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

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

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

Definition nattohzandminus ( n m : nat ) ( is : natgeh n m ) : paths ( 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 ) : paths ( nattohz ( n * m )%nat ) ( nattohz n * nattohz m ) .
Proof . intros . simpl . change nattohz with ( torngdiff natcommrig ) . apply ( isbinop2funtorngdiff natcommrig n m ) . Defined .

Definition nattohzandgth ( n m : nat ) ( is : natgth n m ) : hzgth ( nattohz n ) ( nattohz m ) := iscomptorngdiff 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 ( minus ( pr1 nm ) ( pr2 nm ) ) . apply ( minus ( pr2 nm ) ( pr1 nm ) ) . Defined .

Lemma hzabsvalintcomp : @iscomprelfun ( dirprod nat nat ) nat ( hrelabgrfrac nataddabmonoid )  hzabsvalint .
Proof . unfold iscomprelfun .  intros x x' . unfold hrelabgrfrac . simpl . apply ( @hinhuniv _ ( hProppair _ ( 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 : paths ( hzabsval 0 ) 0%nat .
Proof .  apply idpath .  Defined .

Lemma hzabsvalgth0 { x : hz } ( is : hzgth x 0 ) : paths ( nattohz ( hzabsval x ) ) x .
Proof . assert ( int : forall x : hz , isaprop ( hzgth x 0 ->  paths ( nattohz ( hzabsval x ) ) x ) ) . intro . apply impred . intro . apply ( setproperty hz ) .  apply ( setquotunivprop _ ( fun x => hProppair _ ( int x ) ) ) . intros xa g . simpl in xa . assert ( g' := natnattohzandgth _ _ g ) . simpl in g' .  simpl .  change ( paths ( setquotpr (eqrelabgrfrac (rigaddabmonoid natcommrig)) ( dirprodpair ( hzabsvalint xa ) 0%nat ) ) ( setquotpr (eqrelabgrfrac (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 ( paths  (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 .

destruct ( l g' ) .  Defined .

Opaque hzabsvalgth0 .

Lemma hzabsvalgeh0 { x : hz } ( is : hzgeh x 0 ) : paths ( 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 ) : paths ( nattohz ( hzabsval x ) ) ( - x ) .
Proof . assert ( int : forall x : hz , isaprop ( hzlth x 0 ->  paths ( nattohz ( hzabsval x ) ) ( - x ) ) ) . intro . apply impred . intro . apply ( setproperty hz ) .  apply ( setquotunivprop _ ( fun x => hProppair _ ( int x ) ) ) . intros xa l . simpl in xa . assert ( l' := natnattohzandlth _ _ l ) . simpl in l' .  simpl .  change ( paths ( setquotpr (eqrelabgrfrac (rigaddabmonoid natcommrig)) ( dirprodpair ( hzabsvalint xa ) 0%nat ) ) ( setquotpr (eqrelabgrfrac (rigaddabmonoid natcommrig)) ( dirprodpair ( 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 ( paths  (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 ) : paths ( 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 :  paths ( hzabsval x ) 0%nat ) : paths 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 ( paths 0 x ) in e' .  apply ( pathsinv0 e' ) .

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

Definition hzabsvalneq0 { x : hz } := negf ( @hzabsvaleq0 x ) .

Lemma hzabsvalandmult ( a b : hz ) : paths ( ( 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 ( rngrmultminus hz ) .  destruct ( hzgthorleh b 0 ) as [ gb | leb ] .

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

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

Eval lazy in ( hzbooleq ( natnattohz 3 4 ) ( natnattohz 17 18 ) ) .
Eval lazy in ( hzbooleq ( natnattohz 3 4 ) ( natnattohz 17 19 ) ) .

Eval lazy in ( hzabsval ( natnattohz 58 332 ) ) .
Eval lazy in ( hzabsval ( hzplus ( natnattohz 2 3 ) ( natnattohz 3 2 ) ) ) .
Eval lazy in ( hzabsval ( hzminus ( natnattohz 2 3 ) ( natnattohz 3 2 ) ) ) .

Eval lazy in  ( hzabsval ( hzmult ( natnattohz 20 50 ) ( natnattohz 30 20 ) ) ) .

(* End of the file hz.v *)


Require Export GeoCoq.Elements.OriginalProofs.lemma_midpointunique.
Require Export GeoCoq.Elements.OriginalProofs.lemma_collinear4.

Section Euclid.
Context `{Ax:euclidean_neutral_ruler_compass}.
Lemma lemma_rightangleNC :
   forall A B C,
   Per A B C ->
   nCol A B C.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists D, (BetS A B D /\ Cong A B D B /\ Cong A C D C /\ neq B C)) by (conclude_def Per );destruct Tf as [D];spliter.
assert (Cong A B B D) by (forward_using lemma_congruenceflip).
assert (Midpoint A B D) by (conclude_def Midpoint ).
assert (~ BetS A C D).
 {
 intro.
 assert (Cong A C C D) by (forward_using lemma_congruenceflip).
 assert (Midpoint A C D) by (conclude_def Midpoint ).
 assert (eq B C) by (conclude lemma_midpointunique).
 contradict.
 }
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (~ eq C A).
 {
 intro.
 assert (Cong C C D C) by (conclude cn_equalitysub).
 assert (Cong D C C C) by (conclude lemma_congruencesymmetric).
 assert (~ neq D C).
  {
  intro.
  assert (neq C C) by (conclude axiom_nocollapse).
  assert (eq C C) by (conclude cn_equalityreflexive).
  contradict.
  }
 assert (eq A C) by (conclude lemma_equalitysymmetric).
 assert (eq D A) by (conclude cn_equalitytransitive).
 assert (eq A D) by (conclude lemma_equalitysymmetric).
 assert (neq A D) by (forward_using lemma_betweennotequal).
 contradict.
 }
assert (~ eq C D).
 {
 intro.
 assert (Cong A C D D) by (conclude cn_equalitysub).
 assert (~ neq A C).
  {
  intro.
  assert (neq D D) by (conclude axiom_nocollapse).
  assert (eq D D) by (conclude cn_equalityreflexive).
  contradict.
  }
 assert (eq C A) by (conclude lemma_equalitysymmetric).
 contradict.
 }
assert (~ BetS C A D).
 {
 intro.
 assert (Cong C A C D) by (forward_using lemma_congruenceflip).
 assert (~ Cong C A C D) by (conclude lemma_partnotequalwhole).
 contradict.
 }
assert (~ BetS A D C).
 {
 intro.
 assert (BetS C D A) by (conclude axiom_betweennesssymmetry).
 assert (Cong C D C A) by (forward_using lemma_doublereverse).
 assert (~ Cong C D C A) by (conclude lemma_partnotequalwhole).
 contradict.
 }
assert (~ Col A B C).
 {
 intro.
 assert (Col A B D) by (conclude_def Col ).
 assert (Col B A C) by (forward_using lemma_collinearorder).
 assert (Col B A D) by (forward_using lemma_collinearorder).
 assert (neq B A) by (conclude lemma_inequalitysymmetric).
 assert (Col A C D) by (conclude lemma_collinear4).
 assert ((eq A C \/ eq A D \/ eq C D \/ BetS C A D \/ BetS A C D \/ BetS A D C)) by (conclude_def Col ).
 assert (nCol A B C).
 by cases on (eq A C \/ eq A D \/ eq C D \/ BetS C A D \/ BetS A C D \/ BetS A D C).
 {
  assert (~ Col A B C).
   {
   intro.
   assert (neq A C) by (conclude lemma_inequalitysymmetric).
   contradict.
   }
  close.
  }
 {
  assert (~ Col A B C).
   {
   intro.
   assert (neq A D) by (forward_using lemma_betweennotequal).
   contradict.
   }
  close.
  }
 {
  assert (~ Col A B C).
   {
   intro.
   contradict.
   }
  close.
  }
 {
  assert (~ Col A B C).
   {
   intro.
   contradict.
   }
  close.
  }
 {
  assert (~ Col A B C).
   {
   intro.
   contradict.
   }
  close.
  }
 {
  assert (~ Col A B C).
   {
   intro.
   contradict.
   }
  close.
  }
(* cases *)
 contradict.
 }
close.
Qed.

End Euclid.


(*
Chapter 8
Typed Arithmetic Expressions
*)

Require Import TLC.LibLN.

Inductive trm : Set :=
  | tru  : trm
  | fls  : trm
  | cond : trm -> trm -> trm -> trm
  | O    : trm
  | succ : trm -> trm
  | pred : trm -> trm
  | iszero : trm -> trm.

Inductive value : trm -> Prop :=
  | val_tru : value tru
  | val_fls : value fls
  | val_zro : value O
  | val_succ : forall v, value v -> value (succ v).

Inductive typ : Set :=
  | typ_bool : typ
  | typ_nat  : typ.

Inductive typing : trm -> typ -> Prop :=
  | t_tru : typing tru typ_bool
  | t_fls : typing fls typ_bool
  | t_cond : forall t1 t2 t3 T,
       typing t1 typ_bool ->
       typing t2 T ->
       typing t3 T ->
       typing (cond t1 t2 t3) T
  | t_O : typing O typ_nat
  | t_succ : forall t1,
       typing t1 typ_nat ->
       typing (succ t1) typ_nat
  | t_pred : forall t1,
       typing t1 typ_nat ->
       typing (pred t1) typ_nat
  | t_iszero : forall t1,
       typing t1 typ_nat ->
       typing (iszero t1) typ_bool.

(*
Inversion Lemmas
*)

Lemma one : forall T, typing tru T -> T = typ_bool.
Proof.
  intros. inverts* H.
Qed.

Lemma two : forall T, typing fls T -> T = typ_bool.
Proof.
  intros. inverts* H.
Qed.

Lemma three : forall t1 t2 t3 T,
  typing (cond t1 t2 t3) T ->
  typing t1 typ_bool /\ typing t2 T /\ typing t3 T.
Proof.
  intros. inverts* H.
Qed.

Lemma typ_unique : forall t T1 T2,
  typing t T1 ->
  typing t T2 ->
  T1 = T2.
Proof.
  induction 1; intros; try solve [inverts* H].
  inverts* H2.
  inverts* H0.
  inverts* H0.
  inverts* H0.
Qed.

Inductive step : trm -> trm -> Prop :=
  | step_tru : forall t2 t3,
         step (cond tru t2 t3) t2
  | step_fls : forall t2 t3,
         step (cond fls t2 t3) t3
  | step_if : forall t1 t1' t2 t3,
         step t1 t1' ->
         step (cond t1 t2 t3) (cond t1' t2 t3)
  | step_succ : forall t1 t1',
         step t1 t1' ->
         step (succ t1) (succ t1')
  | step_pred_O :
         step (pred O) O
  | step_pred_succ : forall t,
         value t ->
         step (pred (succ t)) t
  | step_pred : forall t t',
         step t t' ->
         step (pred t) (pred t')
  | step_iszerozero :
         step (iszero O) tru
  | step_iszerosucc : forall v,
         value v ->
         step (iszero (succ v)) fls
  | step_iszero : forall t1 t1',
         step t1 t1' ->
         step (iszero t1) (iszero t1').

Lemma canonical_forms_bool : forall v,
  value v ->
  typing v typ_bool ->
  v = tru \/ v = fls.
Proof.
  induction 1; intros; auto.
  inverts H. inverts H0.
Qed.

Lemma canonical_forms_nat : forall v,
  value v ->
  typing v typ_nat ->
  v = O \/ exists v', v = (succ v').
Proof.
  induction 1; intros; auto.
  inverts H. inverts H.
  inverts H0.
  forwards*: IHvalue H2.
Qed.

Hint Constructors value typing step.

Lemma progress : forall t T,
  typing t T ->
  value t \/ exists t', step t t'.
Proof.
  induction 1; try solve [left*].
  right. destruct IHtyping1.
  inverts* H. inverts H2. inverts H2.
  destruct H2 as [t'].
  exists* (cond t' t2 t3).
  destruct~ IHtyping.
  destruct H0 as [t'].
  right. exists* (succ t').
  destruct IHtyping.
  apply canonical_forms_nat in H; auto.
  destruct~ H. subst.
  right. exists* O.
  right. destruct H as [v']. subst~.
  inverts H0. exists* v'.
  destruct H0 as [t'].
  right. exists* (pred t').
  right. destruct IHtyping.
  apply canonical_forms_nat in H; auto.
  destruct H. subst. exists* tru.
  destruct H as [v']. subst.
  inverts H0. exists* fls.
  destruct H0 as [t'].
  exists*.
Qed.

Lemma preservation : forall t T t',
  typing t T ->
  step t t' ->
  typing t' T.
Proof.
  introv Typ Red. gen t'.
  induction Typ; intros; try solve [inverts Red].
  inverts* Red.
  inverts* Red.
  inverts* Red. inverts* Typ.
  inverts* Red.
Qed.


Require Export Regular ListUtils MSetRBT MSetProperties MSetInterface.
Import ListNotations.

(** * Technicalities about regexps

    - RE : decidable comparisons
    - REs : finite sets of regexps
    - and also: remove in a list, sorted lists, merge of lists, etc
*)

Module RegOrd (Letter : FiniteOrderedType).
 Include Regexps(Letter).

 (** Properties about the comparisons on Letter *)
 Module LetterF := OrderedTypeFacts Letter.

 (** Regexps : decidable comparisons *)
 Module RE <: UsualOrderedType.

 Definition t := re.

 Definition eq := @eq re.
 Definition eq_equiv : Equivalence eq := @eq_equivalence re.

 Fixpoint compare r r' :=
 match r, r' with
 | Void, Void
 | Epsilon, Epsilon => Eq
 | Letter a, Letter b => Letter.compare a b
 | Cat r1 r2, Cat r1' r2'
 | Or r1 r2, Or r1' r2'
 | And r1 r2, And r1' r2' =>
    match compare r1 r1' with
    | Eq => compare r2 r2'
    | c => c
    end
 | Star r, Star r'
 | Not r, Not r' => compare r r'
 | Void, _ => Lt | _, Void => Gt
 | Epsilon, _ => Lt | _, Epsilon => Gt
 | Letter _, _ => Lt | _, Letter _ => Gt
 | Cat _ _, _ => Lt | _, Cat _ _ => Gt
 | Star _, _ => Lt | _, Star _ => Gt
 | Or _ _, _ => Lt | _, Or _ _ => Gt
 | And _ _, _ => Lt | _, And _ _ => Gt
 end.

 Definition lt r r' := compare r r' = Lt.

 Lemma compare_refl r : compare r r = Eq.
 Proof.
 induction r; simpl; auto using LetterF.compare_refl;
  now rewrite IHr1, IHr2.
 Qed.

 Lemma compare_eq r r' : compare r r' = Eq <-> r = r'.
 Proof.
 revert r'; induction r; destruct r'; simpl; auto;
 rewrite ?IHr, ?LetterF.compare_eq_iff; try (split; congruence);
 destruct compare eqn:?; auto;
 rewrite ?IHr1, ?IHr2 in *; split; try congruence;
 intros [= <- <-]; now rewrite compare_refl in *.
 Qed.

 Lemma compare_antisym r r' : compare r' r = CompOpp (compare r r').
 Proof.
 revert r'. induction r; destruct r'; simpl; auto;
 apply LetterF.compare_antisym ||
 (rewrite IHr1; destruct compare; simpl; auto).
 Qed.

 Lemma compare_spec r r' :
  CompareSpec (r = r') (lt r r') (lt r' r) (compare r r').
 Proof.
 unfold lt.
 rewrite (compare_antisym r r').
 generalize (compare_eq r r').
 destruct compare; constructor; intuition.
 Qed.

 Lemma lt_irrefl r : ~lt r r.
 Proof.
 unfold complement, lt.
 induction r; simpl; try easy;
  rewrite ?LetterF.compare_lt_iff; try LetterF.order;
  now destruct compare.
 Qed.

 Lemma lt_trans : Transitive lt.
 Proof.
  unfold lt. intro r.
  induction r; intros [ ] [ ]; simpl; eauto; try easy;
  rewrite ?LetterF.compare_lt_iff; try LetterF.order;
  destruct compare eqn:E; auto; try easy;
  rewrite ?compare_eq in *; subst;
  destruct (compare r) eqn:E'; eauto; try easy;
  rewrite ?compare_eq in *; subst; intro; rewrite ?E; try easy;
  now rewrite (IHr1 _ _ E E').
 Qed.

 Lemma lt_strorder : StrictOrder lt.
 Proof.
 split. exact lt_irrefl. exact lt_trans.
 Qed.

 Lemma lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt.
 Proof. intuition auto with *. Qed.

 Definition eq_dec (r r' : re) : {r = r'} + { r <> r' }.
 Proof.
 destruct (compare r r') eqn:E; [left|right|right].
 - now apply compare_eq.
 - intros <-. now rewrite compare_refl in *.
 - intros <-. now rewrite compare_refl in *.
 Qed.

 Definition eqb r r' :=
  match compare r r' with Eq => true | _ => false end.

 Lemma eqb_eq r r' : eqb r r' = true <-> r = r'.
 Proof.
 rewrite <- compare_eq. unfold eqb. now destruct compare.
 Qed.

 Lemma eqb_spec r r' : reflect (r = r') (eqb r r').
 Proof.
 apply iff_reflect. symmetry. apply eqb_eq.
 Qed.

 Lemma eqb_neq r r' : eqb r r' = false <-> r <> r'.
 Proof.
 rewrite <- eqb_eq. now destruct eqb.
 Qed.

 Lemma eqb_refl r : eqb r r = true.
 Proof.
 unfold eqb. now rewrite compare_refl.
 Qed.

 End RE.

 (** Finite sets of regexps *)

 Set Inline Level 30.
 Module REs := MSetRBT.Make RE.
 Module REsP := MSetProperties.WProperties REs.
 Ltac REsdec := REsP.Dec.fsetdec.

 Lemma REs_elements_spec x set :
  In x (REs.elements set) <-> REs.In x set.
 Proof.
 rewrite <- REs.elements_spec1, InA_alt. firstorder; subst; auto.
 Qed.

 (** From a list of regexps to a set of regexps *)

 Fixpoint list2set l : REs.t :=
  match l with
  | [] => REs.empty
  | r::l => REs.add r (list2set l)
  end.

 Lemma list2set_in x l : REs.In x (list2set l) <-> In x l.
 Proof.
 induction l; simpl; rewrite <- ?IHl; REsdec.
 Qed.

 (** Results on lists of regexps, using the boolean equality
     [RE.eqb] or the decidable equality [RE.eq_dec]. *)

 (** First, we can decide whether a regexp is in a list or not *)

 Lemma in_or_not r (l:list re) : In r l \/ ~In r l.
 Proof.
 Admitted.

 (** [remove] : similar to Coq standard [List.remove], but with [RE.eqb]
     instead of a generic [eq_dec] argument. *)

 Fixpoint remove x l :=
  match l with
  | [] => []
  | y :: tl => if RE.eqb x y then remove x tl else y :: remove x tl
  end.

 Lemma in_remove x a l : In x (remove a l) <-> In x l /\ a<>x.
 Proof.
 Admitted.

 Lemma remove_id a l : ~In a l -> remove a l = l.
 Proof.
 Admitted.

 Lemma remove_eqlist a l :
  In a l -> eqlist l (a::remove a l).
 Proof.
 Admitted.

 Lemma eqlist_remove a l l' :
  eqlist (a::l) l' -> ~In a l -> eqlist l (remove a l').
 Proof.
 Admitted.

 Lemma remove_nil a l :
  eqlist l [a] -> remove a l = nil.
 Proof.
 Admitted.

 Lemma remove_subset a l l' :
  Subset l (a::l') -> Subset (remove a l) l'.
 Proof.
 Admitted.

 (** Thanks to [remove], we can turn a [subset] list into
     an equivalent [Incl] one. Tricky *)

 Lemma subset_eqlist_Incl (u v : list re) :
  Subset u v -> exists u', eqlist u u' /\ Incl u' v.
 Proof.
 Admitted.

 (** From two [Incl] sublists, we can find a third one equivalent
     to the concatenation of the first two. *)

 Lemma Incl_app (l1 l2 l : list re) :
  Incl l1 l -> Incl l2 l ->
  exists l', eqlist (l1++l2) l' /\ Incl l' l.
 Proof.
 Admitted.

 (** Sorted lists of regexps *)

 Definition Sorted := Sorted.Sorted RE.lt. (* See Coq stdlib *)
 Global Hint Constructors Sorted.Sorted NoDup : core.
 Global Hint Unfold Sorted : core.

 Lemma Sorted_in_lt l x y : Sorted (x::l) -> In y l -> RE.lt x y.
 Proof.
 Admitted.

 Lemma Sorted_not_in l x : Sorted (x::l) -> ~In x l.
 Proof.
 Admitted.

 Lemma Sorted_NoDup l : Sorted l -> NoDup l.
 Proof.
 Admitted.

 (** Two equivalent strictly sorted lists are actually equal. Tricky. *)

 Lemma sorted_unique l l' :
  eqlist l l' -> Sorted l -> Sorted l' -> l = l'.
 Proof.
 Admitted.

 (** Merge lists of regexp. Since we implement this via finite sets,
     we obtain a sorted result for free :-). *)

 Definition merge l1 l2 :=
  REs.elements (REs.union (list2set l1) (list2set l2)).

 Lemma merge_eqlist l l' : eqlist (merge l l') (l++l').
 Proof.
 Admitted.

 Lemma merge_nonnil l l' : l <> [] -> merge l l' <> [].
 Proof.
 Admitted.

 Lemma merge_sorted l l' : Sorted (merge l l').
 Proof.
 Admitted.

 Lemma merge_idem l : Sorted l -> merge l l = l.
 Proof.
 Admitted.

 Lemma merge_sym l l' : merge l l' = merge l' l.
 Proof.
 Admitted.

 Lemma merge_assoc l1 l2 l3 :
  merge l1 (merge l2 l3) = merge (merge l1 l2) l3.
 Proof.
 Admitted.

End RegOrd.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a5_ : Universe.
Variable a4_ : Universe.
Variable a3_ : Universe.
Variable a2_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ a4_ /\ dom_ a5_)))).
Variable ax2_2 : (forall A1 A2 A3 A4 A5 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ (dom_ A4 /\ dom_ A5)))) -> p_ A1 A2 A3 A4 A5)).
Variable ax3_3 : (p_ a5_ a4_ a3_ a2_ a1_ -> goal_).

Theorem lemma5_4 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.ZArith.BinInt.
Require Import riscv.Utility.Encode.
Require Import coqutil.Z.BitOps.
Require Import coqutil.Z.prove_Zeq_bitwise.

Lemma invert_encode_FenceI: forall {opcode rd rs1 funct3 imm12},
  verify_FenceI opcode rd rs1 funct3 imm12 ->
  forall inst,
  encode_FenceI opcode rd rs1 funct3 imm12 = inst ->
  opcode = bitSlice inst 0 7 /\
  funct3 = bitSlice inst 12 15 /\
  rd = bitSlice inst 7 12 /\
  rs1 = bitSlice inst 15 20 /\
  imm12 = signExtend 12 (bitSlice inst 20 32).
Proof. intros. unfold encode_FenceI, verify_FenceI in *. prove_Zeq_bitwise. Qed.


Require Export CartCR.
Require Export CartIR.

Set Implicit Arguments.

Definition tiff (A B : Type):= (A → B) × (B → A).

Notation " A  ⇔ B" := (tiff A B) (at level 100).

Lemma RingPlusCommutative  `{Ring A} :
  forall (x y:A), x + y= y + x.
Proof.
  intros.
  apply ring_group in H.
  apply abgroup_commutative in H.
  apply H.
Qed.

Class StrongLess (A : Type ):= strongLess : A -> A -> Type.

Notation " a <ᵀ b" := (strongLess a b) (at level 110).

Instance StrongLess_instance_IR : StrongLess IR
    := (@cof_less IR).

Instance StrongLess_instance_CR : StrongLess CR
    := (CRltT).

(** Coqand defined much of the theory for ringish
    things that dont need to have an identity.
    However, for defining probabilities, we need it anyway.
    As we will see later, for probability,
      1 is like the event \Omega, the
    one with probability 1.
    0 represents the "empty-set" event*)

Section BoolRing.
Variable A : CRing.

Require Export CRRing2MCRing.

Require Export MCMisc.BooleanRing.

(** make sure that A4 and A5 are provable.
    if not, add A4 and change type of [MeasureRing_mult_ext]
    to be A5 *)

Definition MeasurePropM1
     (μ : A -> IR) : Prop :=
  ∀ x y, μ (x ∪ y) = μ x + μ y - μ (x ∩ y).

Notation "a ≷ b" := (cs_ap a b) (at level 100).

Definition MeasurePropM2
     (μ : A -> IR) : Type :=
∀ x,   (0 <ᵀ (μ x)) →  (x ≷ 0).

Definition MeasureNonZero
     (μ : A -> IR) : Prop := ∀ x,  0 ≤ μ x.

Definition MeasurePropM23
     (μ : A -> IR) : Type:=
  ∀ x,  (0 <ᵀ(μ x)) ⇔  (x ≷ 0).

Class MeasureAlgebra  (μ : CSetoid_fun A  IR)
  := {
  mpmboolean :>  BooleanRing A;
  mpm0 : MeasureNonZero μ;
  mpm1 : MeasurePropM1 μ;
  mpm2 : MeasurePropM23 μ
}.

Lemma MeasurePropM23Implies2 : ∀ (μ : A → IR) ,
  MeasurePropM23 μ
  → MeasurePropM2 μ.
Proof.
  unfold MeasurePropM23, MeasurePropM2.
  intros ? X x.
  destruct (X x).
  assumption.
Qed.

Hint Resolve mpm0 mpm1 mpm2 MeasurePropM23Implies2: Alg.

Lemma MeasurePropM2Implies : ∀ (μ : A → IR) ,
  MeasurePropM2 μ
  → MeasureNonZero μ
  → μ 0 = 0.
Proof.
  intros μ Hm Hp.
  unfold MeasurePropM2 in Hp.
  apply not_ap_imp_eq.
  intro Hc.
  apply ap_imp_less in Hc.
  specialize (Hp 0).
  destruct Hc as [Hc|Hc];
    [ apply leEq_def in Hp;contradiction|].
  apply Hm in Hc.
  apply ap_irreflexive in Hc.
  contradiction.
Qed.

Class CMeasure (T : CSetoid) := μ : CSetoid_fun T ℝ.

Class ProbabilityAlgebra `{CMeasure A}
  `{MeasureAlgebra μ}
 :=  probWholeSpace1 : μ 1 = 1.

Section MetricSpace.
Context `{ProbabilityAlgebra}.
Require Export CoRN.metrics.CMetricSpaces.

(** The goal is to create an instance of [CMetricSpace]
    based on Lemma 1.4 *)

Add Ring  stdlib_ring_theoryldsIR :
  (rings.stdlib_ring_theory IR).

Lemma MeasurePropM1RW :
  ∀ x y, μ (x ∪ y) + μ (x ∩ y) = μ x + μ y .
Proof.
  intros ? ?.
  rewrite mpm1.
  ring.
Qed.

Add Ring  stdlib_ring_theorylds :
  (rings.stdlib_ring_theory A).

Definition distance : CSetoid_bin_fun A A IR :=
  compose_CSetoid_un_bin_fun ℝ A A csg_op μ.

Hint Unfold Plus_instance_TContR Mult_instance_TContR
Zero_instance_TContR Negate_instance_TContR: IRMC.

Lemma plusAssocUnfolded `{SemiRing R}:
  ∀ (a b c : R), a + b + c = a + (b + c).
Proof.
  intros. rewrite (plus_assoc a b c).
  reflexivity.
Qed.

(** For a proof in classical measure theory,
    See page 11 of undergrad Prob. Th. course notebook*)

Lemma measureMonotone : ∀ a b : A,
  a ⊆ b → μ a ≤ μ b.
Proof.
  intros ? ? Hs.
  unfold setSubset in Hs.
  assert (b = a ∪ (b*(b+a))) as Hu.
  - unfold setUnion, BooleanAlgUnion.
    ring_simplify.
    rewrite boolean_mult.
    rewrite <- (mult_assoc b a a).
    rewrite boolean_mult.
    assert (b * a + b + b * a + b * a + a =
             a +  b + b * a + (b * a + b * a)) as Hr by ring.
    rewrite BooleanRingXplusX in Hr.
    rewrite Hr.
    autounfold with IRMC.
    rewrite cm_rht_unit_unfolded.
    clear Hr. rewrite mult_commutes.
    assert (a[+]b[+]a[*]b = a ∪ b) as Hr by reflexivity.
    rewrite Hr.
    rewrite subsetUnionMeasure.
    reflexivity. exact Hs.
  - rewrite Hu.
    rewrite mpm1.
    unfold setIntersection, BooleanAlgIntersection.
    assert (a * (b * (b + a)) = a * (b * b) + a * a * b)
      as Hr by ring; rewrite Hr; clear Hr.
    rewrite boolean_mult.
    rewrite boolean_mult.
    rewrite BooleanRingXplusX.
    rewrite  MeasurePropM2Implies; auto with Alg.
    rewrite minus_0_r.
    autounfold with IRMC.
    apply addNNegLeEq.
    apply mpm0.
Qed.

Lemma measurePlusPropAux : ∀ x1 x2 y1 y2,
  μ (x1+ y1 + (x2 + y2)) ≤ μ (x1 + x2) + μ (y1 + y2).
Proof.
  intros.
  rewrite <-  MeasurePropM1RW.
  rewrite  <- cm_rht_unit_unfolded.
  apply plus_resp_leEq_both;
    [| apply mpm0].
  apply measureMonotone.
  apply paperEq1.
Qed.

Definition ProbAlgebraPsMSP : CPsMetricSpace.
  eapply Build_CPsMetricSpace with (cms_crr:=A)
    (cms_d := distance). split.
- unfold com. intros ? ?. unfold distance.
  simpl. apply csf_wd.
  apply cag_commutes_unfolded.
- unfold nneg.
  simpl.
  intros ? ?. apply mpm0.
- unfold pos_imp_ap.
  simpl. intros  ? ? Hgt.
  apply mpm2 in Hgt.
  apply plus_cancel_ap_rht with (z:= y).
  eapply ap_wdr_unfolded;[apply Hgt|].
  symmetry.
  apply BooleanRingXplusX.
- unfold tri_ineq. intros ? ? ?.
  simpl. simpl.
  assert (x + (y + y) + z = (x + y) + (y + z)) as Hr by ring.
  rewrite BooleanRingXplusX in Hr.
  autounfold with IRMC in Hr.
(* Add Ring RisaRing1: (CRing_Ring A). *)
  rewrite  cm_rht_unit_unfolded in Hr.
  rewrite Hr.
  apply measurePlusPropAux.
Defined.

(** also lemma 1.4.i in the paper *)
Definition ProbAlgebraMSP : CMetricSpace.
  eapply Build_CMetricSpace with (scms_crr:=ProbAlgebraPsMSP).
  unfold apdiag_imp_grzero.
  simpl.
  intros ? ? Hap.
  apply mpm2.
  apply op_rht_resp_ap with (z:=y) in Hap.
  eapply ap_wdr_unfolded in Hap;[exact Hap|].
  apply BooleanRingXplusX.
Defined.

Notation "a -ᵈ b" := (cms_d a b) (at level 90).

(** similar to
    CoRN.metric2.UniformContinuity.UniformlyContinuousFunction *)

Definition uniformlyCont {X Y Z : CPsMetricSpace}
  (f : CSetoid_bin_fun X Y Z) : Type :=
∀ (eps : Qpos), {δx : Qpos | { δy :Qpos | ∀ (x1 x2 : X) (y1 y2 : Y),
      ((x1 -ᵈ x2) ≤ δx)
      → ((y1 -ᵈ y2) ≤ δy)
      → ((f x1 y1 -ᵈ f x2 y2) ≤ eps) } }.

Definition MSplus : CSetoid_bin_op ProbAlgebraMSP.
  apply csg_op.
Defined.

Definition MSmult : CSetoid_bin_op ProbAlgebraMSP.
  apply cr_mult.
Defined.

Definition qposHalf : Qpos := QposMake 1 2.

Lemma qposHalfPlus : ∀ (eps : Qpos),
  QposEq  (eps * qposHalf + eps * qposHalf)  eps.
Proof.
  intros eps.
  destruct eps.
  unfold QposEq.
  simpl.
  ring.
Qed.

Lemma qposHalfPlusQeq : ∀ (eps : Qpos),
  Qeq  (eps * qposHalf + eps * qposHalf)  eps.
Proof.
  apply qposHalfPlus.
Qed.

Require Export ROSCOQ.IRMisc.CoRNMisc.
Theorem paper1_4_ii_a_aux : uniformlyCont MSplus.
Proof.
  intros eps.
  unfold MSplus.
  simpl.
  exists (eps * qposHalf) .
  exists (eps * qposHalf) .
  intros ? ? ? ? Hx Hy.
  pose proof (plus_resp_leEq_both _ _ _ _ _ Hx Hy) as Hadd.
  clear Hx Hy.
  rewrite <- inj_Q_plus in Hadd.
  pose proof (qposHalfPlusQeq eps).
  apply (inj_Q_wd IR) in H2.
  rewrite H2 in Hadd.
  clear H2.
  eapply leEq_transitive;[|apply Hadd].
  clear Hadd.
  apply measurePlusPropAux.
Qed.

Theorem paper1_4_ii_b_aux : uniformlyCont MSmult.
Proof.
  intros eps.
  unfold MSmult.
  simpl.
  exists (eps * qposHalf) .
  exists (eps * qposHalf) .
  intros ? ? ? ? Hx Hy.
  pose proof (plus_resp_leEq_both _ _ _ _ _ Hx Hy) as Hadd.
  clear Hx Hy.
  rewrite <- inj_Q_plus in Hadd.
  pose proof (qposHalfPlusQeq eps).
  apply (inj_Q_wd IR) in H2.
  rewrite H2 in Hadd.
  clear H2.
  eapply leEq_transitive;[|apply Hadd].
  clear Hadd.
  pose proof  MeasurePropM1RW as Hh.
  unfold plus, Plus_instance_TContR in Hh.
  rewrite <- Hh. clear Hh.
  rewrite  <- cm_rht_unit_unfolded.
  apply plus_resp_leEq_both;
    [| apply mpm0].
  apply measureMonotone.
  apply paperEq2.
Qed.

Require Import CRMisc.OldMetricAsNew.

(* now we get access to the completion operation.
    metric2/ seems to be more developed
    than metrics/
    for efficiency, it might be better to shortcuit
   the proof of new metric space by getting
   rid of the old metric space altogether
   also, the codomain of μ can be AR or CR *)
Definition AMS : MetricSpace :=
  fromOldMetricTheory ProbAlgebraMSP.

Require Export CoRN.metric2.Complete.

Open Scope uc_scope.

(* need to redeclare the ring over AMS
Lemma Atranslate_uc_prf (a:AMS) : is_UniformlyContinuousFunction
    (fun b:AMS => (a [+] b)) Qpos2QposInf.
Proof.
 intros e b0 b1 H.
 simpl in *.
 unfold Qball in *.
 stepr (b0-b1).
  assumption.
 simpl; ring.
Qed.

Definition Qtranslate_uc (a:AMS) : AMS --> AMS :=
Build_UniformlyContinuousFunction (Qtranslate_uc_prf a).

Definition translate (a:Q) : CR --> CR := Cmap QPrelengthSpace (Qtranslate_uc a).

Lemma translate_ident : forall x:CR, (translate 0 x==x)%CR.
Proof.
 intros x.
 unfold translate.
 assert (H:st_eq (Qtranslate_uc 0) (uc_id _)).
  intros a.
  simpl.
  ring.
 simpl.
 rewrite -> H.
 rewrite -> Cmap_fun_correct.
 apply: MonadLaw1.
Qed.

(** Lifting translate yields binary addition over CR. *)
Lemma Qplus_uc_prf :  is_UniformlyContinuousFunction Qtranslate_uc Qpos2QposInf.
Proof.
 intros e a0 a1 H b.
 simpl in *.
 repeat rewrite -> (fun x => Qplus_comm x b).
 apply Qtranslate_uc_prf.
 assumption.
Qed.

Definition Qplus_uc : Q_as_MetricSpace --> Q_as_MetricSpace --> Q_as_MetricSpace :=
Build_UniformlyContinuousFunction Qplus_uc_prf.
Definition PlusSlow_uc : (AMS --> AMS --> AMS).
Admitted.

Definition PlusSlowUC : (AMSC --> AMSC --> AMSC) :=
   Cmap2_slow PlusSlow_uc.

(* general definition of a completion of a
    metric ring? generalize the development of CR
      (e.g. [CRPlus_uc])
    Make it fast by assuming [PrelengthSpace]
      and then using [Cmap] instead of [Cmap2_slow].
    Do we need more axioms to prove that [AMS]
    is a prelengthspace?
*)
*)

Require Export CoRN.metric2.Compact.

Definition MetricallyComplete : CProp :=
  CompleteSubset AMS (λ x, True).

Definition AMSC : MetricSpace := Complete AMS.

End MetricSpace.
End BoolRing.

(*An (isometric) embedding f between measure rings (A, µ) and (B, ν) is a ring
homomorphism which is measure preserving, i.e. *)

Require Export CoRN.algebra.CRing_Homomorphisms.
Definition MeasurePreserving
  {A B : CSetoid} `{CMeasure A} `{CMeasure B}
  (f : A -> B) :=
  ∀ x,  μ (f x) = μ x.

Record IsometricProbEmbedding
  (A B : CRing) `{CMeasure A} `{CMeasure B}
    :=  mkIsometricProbEmbedding
{
  fIsoProbEmb :> RingHom A B;
  fMeassurePres : MeasurePreserving fIsoProbEmb
}.


(**  Pierre Castéran, LaBRI and University of Bordeaux  *)

From hydras Require Import Epsilon0_Needed_Generic.
Import Hydra_Lemmas Epsilon0 Canon Paths Relation_Operators.
Import O2H.

(** We generalize the results of libraries Omega_Small and Omega2_Small:
   We prove that no ordinal strictly less than epsilon0 can be used as a variant
   for proving the termination of all hydra battles.
We use the so-called "Ketonen-Solovay machinery" for building
a proof that shares the same structure as for the libraries above, but is much
longer
 *)

(** **  Bounded variants *)

Open Scope t1_scope.

(* begin snippet theContext:: no-out *)
Section Impossibility_Proof.

  Context (mu: T1)
          (Hmu: nf mu)
          (m : Hydra -> T1)
          (Var : Hvariant  T1_wf free m)
          (Hy : BoundedVariant Var mu).

  Let big_h := big_h mu.
  Let small_h := small_h mu m.
  (* end snippet theContext *)

  #[local] Hint Resolve nf_m : hydra.

  (* begin snippet mGe:: no-out *)

  Lemma m_ge : m big_h t1<= m small_h.
  Proof.
    apply m_ge_generic with (1 := Hy).
    (* ... *)
  (* end snippet mGe *)
   intros i h h' H; generalize Var; destruct 1.
    apply variant_decr with i.
    intro H0; subst; now apply (head_no_round_n _  _ H).
    exists i; apply H.
  Qed.

  (** ** Proof of the inequality m small_h t1< m big_h
   *)

  Lemma m_variant_LT : forall h h', h -+-> h' -> m h' t1< m h.
  Proof.
    intros h h' H;eapply m_strict_mono with (1 := Var)(2:= H).
  Qed.

  (* begin snippet bigToSmall *)

  (*| .. coq:: no-out |*)
  Lemma  big_to_small : big_h  -+-> small_h.
  Proof.
    unfold big_h, small_h. apply LT_to_round_plus; auto.
    unfold beta_h. apply (m_bounded big_h); auto.
  Qed.
  (*||*)
  (* end snippet bigToSmall *)

   (* begin snippet mLt *)

  (*| .. coq:: no-out |*)
  Lemma m_lt : m small_h  t1< m big_h.
  Proof. apply m_variant_LT,  big_to_small. Qed.
  (*||*)
  (* end snippet mLt *)

  (* begin snippet ImpossibilityFree *)

  (*| .. coq:: no-out |*)

  Fact self_lt_free : m big_h  t1<  m big_h .
  Proof.
    apply LE_LT_trans with (m small_h).
    - apply m_ge.
    - apply m_lt.
  Qed.

  Theorem Impossibility_free : False.
  Proof.  apply (LT_irrefl self_lt_free).  Qed.

End Impossibility_Proof.
 (*||*)
(* end snippet ImpossibilityFree *)

(* begin snippet CheckDemo *)

Check Impossibility_free.
(* end snippet CheckDemo *)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski and Johannes Waldmann, 2010-04
*)

Set Implicit Arguments.

From CoLoR Require Import ATropicalBasedInt Matrix OrdSemiRing VecUtil AMonAlg
     SN RelUtil NatUtil AWFMInterpretation LogicUtil AMatrixBasedInt BoolUtil
     ListUtil.
From Coq Require Import Structures.Equalities.

(* TODO: this should be moved to Matrix.v *)
Module Import TropicalMatrix := Matrix TropicalOrdSemiRingT.

Definition matrixInt := @matrixInt A matrix.
Definition mkMatrixInt := @mkMatrixInt A matrix.

(***********************************************************************)
(** Condition for a tropical interpretation to be valid *)

Section Somewhere_tfinite.

  Variable dim : nat.
  Variable dim_pos : dim > 0.

  Definition somewhere_tfinite n (fi : matrixInt dim n) :=
    Vexists (fun m => get_elem m dim_pos dim_pos <> PlusInf) (args fi)
    \/ Vnth (const fi) dim_pos <> PlusInf.

  Definition bsomewhere_tfinite n (fi : matrixInt dim n) :=
    bVexists
    (fun m => tropical_is_finite (get_elem m dim_pos dim_pos)) (args fi)
    || tropical_is_finite (Vnth (const fi) dim_pos).

  Lemma bsomewhere_tfinite_ok : forall n (fi : matrixInt dim n),
    bsomewhere_tfinite fi = true <-> somewhere_tfinite fi.

  Proof.
    intros. unfold bsomewhere_tfinite, somewhere_tfinite.
    rewrite orb_eq, tropical_is_finite_ok, bVexists_ok. refl.
    intro. apply tropical_is_finite_ok.
  Qed.

  Variable sig : Signature.
  Variable trsInt : forall f : sig, matrixInt dim (arity f).

  Variable Fs : list sig.
  Variable Fs_ok : forall f : sig, In f Fs.

  Lemma fin_somewhere_tfinite :
    forallb (fun f => bsomewhere_tfinite (trsInt f)) Fs = true ->
    forall f : sig, somewhere_tfinite (trsInt f).

  Proof.
    rewrite forallb_forall. intros H f. rewrite <- bsomewhere_tfinite_ok.
    apply H. apply Fs_ok.
  Qed.

End Somewhere_tfinite.

Arguments fin_somewhere_tfinite [dim] _ [sig] _ [Fs] _ _ _.

Ltac somewhere_tfinite Fs_ok :=
  apply (fin_somewhere_tfinite _ _ Fs_ok);
    (check_eq || fail 10 "invalid tropical interpretation").

(***********************************************************************)
(** Module type for proving termination with a tropical interpretation *)

Module Type TTropicalInt.

  Parameter sig : Signature.
  Parameter dim : nat.
  Parameter dim_pos : dim > 0.
  Parameter trsInt : forall f : sig, matrixInt dim (arity f).
  Parameter trsIntOk : forall f : sig, somewhere_tfinite dim_pos (trsInt f).

End TTropicalInt.

Module TropicalInt (Import AI : TTropicalInt).

  Module AB <: TTropicalBasedInt.

    Module OSR := TropicalOrdSemiRingT.
    Module M := TropicalMatrix.
    Definition sig := sig.
    Definition dim := dim.
    Definition dim_pos := dim_pos.
    Definition trsInt := trsInt.

  End AB.

  Module Export AIBase := TropicalBasedInt AB.

  Module Export MonotoneAlgebra <: MonotoneAlgebraType.

    Definition Sig := Sig.

    Lemma mat_times_vec_at0_positive n (m : matrix n n)
      (v : vector A n) (dim_pos : n > 0) :
      get_elem m dim_pos dim_pos <> PlusInf ->
      Vnth v dim_pos <> PlusInf ->
      Vnth (mat_vec_prod m v) dim_pos <> PlusInf.

    Proof.
      destruct n; intros. lia.
      VSntac v. unfold matrix in m. VSntac m.
      unfold mat_vec_prod, col_mat_to_vec, get_col. rewrite Vnth_map.
      set (w := mat_mult_spec). unfold get_elem, get_row in w. rewrite w.
      simpl. VSntac (Vhead m). unfold dot_product.
      simpl. rewrite Aplus_comm. apply tropical_plus_notInf_left.
      apply tropical_mult_notInf.
      rewrite H2 in H. unfold get_elem in H. simpl in H.
      rewrite Vhead_nth, <- (Vnth_eq (Vhead m) dim_pos (lt_O_Sn n)); trivial.
      rewrite H1 in H0. hyp.
    Qed.

    Notation mat_times_vec := (@mat_vec_prod dim dim).
    Notation mint := (matrixInt dim).

    Notation "x >_0 y" := (gtx x y) (at level 70).

    Lemma gtx_plus_compat : forall m m' n n',
      m >_0 m' -> n >_0 n' -> m + n >_0 m' + n'.

    Proof.
      intros. destruct H. destruct H0.
      left. apply plus_gt_compat; hyp.
      destruct H0. rewrite H0, H1, !Aplus_0_r. left. hyp.
      destruct H. rewrite H, H1, !Aplus_0_l. hyp.
    Qed.

    Lemma gtx_mult_compat : forall m m' n n',
      m >_0 m' -> n >>= n' -> m * n >_0 m' * n'.

    Proof.
      intros.
      destruct m; destruct m'; destruct n; destruct n';
        destruct H; destruct H0; simpl;
        try solve
          [ exfalso; auto
          | intuition; discr
          | left; simpl; auto
          | left; simpl in *; lia
          | right; auto
          ].
      left. simpl. injection H0. intro. subst n. simpl in H. lia.
    Qed.

    Lemma eval_some_notInf : forall n (mi : mint n) (v : vector dom n),
      Vexists (fun m => get_elem m dim_pos dim_pos <> PlusInf) (args mi) ->
      Vfold_left_rev Aplus A0
      (Vmap (fun v => Vnth v dim_pos)
        (Vmap2 mat_times_vec (args mi) (Vmap dom2vec v))) <> PlusInf.

    Proof.
      induction n; intros; simpl; destruct mi.
      VOtac. auto.
      simpl in H. VSntac args. rewrite H0 in H; simpl. destruct H.
      rewrite Aplus_comm. apply tropical_plus_notInf_left.
      apply (@mat_times_vec_at0_positive dim). hyp.
      VSntac v. simpl. destruct (Vhead v).
      unfold vec_invariant, Conf.vec_at0 in v0. simpl in *.
       (* TODO... change - specific to tropical... *)
      intuition. clear H1. rewrite H2 in v0. contr.
      apply tropical_plus_notInf_left.
      rewrite <- Vmap_tail.
      apply (IHn (mkMatrixInt const (Vtail args))). hyp.
    Qed.

    Lemma mi_eval_at0 : forall n (mi : matrixInt dim n) (v : vector dom n),
      somewhere_tfinite dim_pos mi ->
      vec_at0 (mi_eval_aux mi (Vmap dom2vec v)) <> PlusInf.

    Proof.
      intros. unfold mi_eval_aux, vec_at0.
      rewrite vector_plus_nth. destruct H.
      rewrite add_vectors_nth. apply tropical_plus_notInf_left.
      apply eval_some_notInf. hyp.
      rewrite Aplus_comm. apply tropical_plus_notInf_left. hyp.
    Qed.

    Lemma mi_eval_ok : forall f v,
      vec_invariant (mi_eval_aux (trsInt f) (Vmap dom2vec v)).

    Proof.
      intros. unfold vec_invariant, Conf.vec_at0.
      apply tropical_plus_inf_max.
      set (w := mi_eval_at0). unfold vec_at0 in w. apply w.
      apply trsIntOk.
    Qed.

    Definition I := I mi_eval_ok.

    Definition succ := AIBase.succ.
    Definition succ' := AIBase.succ'.
    Definition succ'_sub := @AIBase.succ'_sub gtx_plus_compat gtx_mult_compat
      mi_eval_ok.
    Definition succ'_dec := AIBase.succ'_dec.

    Definition succeq := MBI.succeq.
    Definition succeq' := MBI.succeq'.
    Definition succeq'_sub := @MBI.succeq'_sub mi_eval_ok.
    Definition succeq'_dec := MBI.succeq'_dec.

    Definition refl_succeq := MBI.refl_succeq.
    Definition monotone_succeq := @MBI.monotone_succeq mi_eval_ok.
    Definition trans_succeq := MBI.trans_succeq.

    Definition succ_succeq_compat := AIBase.succ_succeq_compat ge_gt_eq.

    Lemma succ_wf : WF succ.

    Proof.
      apply WF_incl with
        (fun x y => vec_at0 (dom2vec x) >> vec_at0 (dom2vec y)).
      intros x y xy.
      destruct (@Vforall2_elim_nth _ _ gtx _ (dom2vec x) (dom2vec y) _ dim_pos xy).
      hyp.
      destruct H. destruct x.
       (* TODO: change, specific for tropical *)
      absurd (A0 = Vnth x dim_pos).
      unfold vec_invariant in v.
      intro eq. clear H xy. rewrite eq in v. exact (gt_irrefl _ v).
      intuition.
      fold (@Rof dom A gt (fun v => vec_at0 (dom2vec v))).
      apply WF_inverse. apply gt_WF.
    Qed.

    Global Instance trans_succ : Transitive succ.

    Proof.
      change (transitive (Rof succ_vec dom2vec)). apply Rof_trans.
      apply Vforall2_trans. class.
    Qed.

  End MonotoneAlgebra.

  Ltac prove_cc_succ Fs_ok :=
    fail 10 "tropical matrices cannot be used for proving total termination".

End TropicalInt.