(** * 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 "../hlevel1" .
Add LoadPath "../Generalities".

Require Export 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 *)


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal82.

Set Printing Depth 1000.
Definition lfind_eval  y:=
append (rev y) Nil.

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ Zero))) Nil)).

Compute lfind_eval  (Nil).


(** * The subslist relation
      This file contains the defintion of the sublist relation [is_sublist_id] and its
      lemmas (some of them related to disjoints lists).
    *)

Set Implicit Arguments.

Require Import LibTactics.
Require Import ListIds.
Require Import Context.
Require Import Schemes.
Require Import SubstSchm.
Require Import SimpleTypes.
Require Import Subst.
Require Import MyLtacs.
Require Import Disjoints.
Require Import Arith.Arith_base.
Require Import List.

Inductive is_sublist_id : (list id) -> (list id) -> Prop := is_sublist_intro: forall (l1 l2: (list id)),
      (forall (st: id), in_list_id st l1 = true -> in_list_id st l2 = true) -> is_sublist_id l1 l2.

Hint Constructors is_sublist_id:core.

Lemma sublist_reflexivity: forall l : (list id), (is_sublist_id l l).
Proof.
  intros.
  econstructor; auto.
Qed.

Hint Resolve sublist_reflexivity:core.

Lemma nil_is_sublist : forall l: (list id), (is_sublist_id nil l).
Proof.
  intros.
  econstructor; intros; auto.
  simpl in H. inversion H.
Qed.

Hint Resolve nil_is_sublist:core.

Lemma append_sublist : forall (l l1 l2 : (list id)),
    (is_sublist_id l1 l) -> (is_sublist_id l2 l) ->
    (is_sublist_id (l1 ++ l2) l).
Proof.
  intros.
  econstructor. intros.
  apply in_list_id_or_append_inversion in H1.
  destruct H1.
  inversion H. auto.
  inversion H0. auto.
Qed.

Hint Resolve append_sublist:core.

Lemma sublist_of_append1 : forall (l l1 l2 : (list id)),
    (is_sublist_id l l1) -> (is_sublist_id l (l1 ++ l2)).
Proof.
  intros.
  econstructor. intros.
  inversion H.
  apply in_list_id_append1. auto.
Qed.

Hint Resolve sublist_of_append1:core.

Lemma sublist_of_append2 : forall (l l1 l2 : (list id)),
    (is_sublist_id l l2) -> (is_sublist_id l (l1 ++ l2)).
Proof.
  intros.
  econstructor. intros.
  inversion H.
  apply in_list_id_append2. auto.
Qed.

Hint Resolve sublist_of_append2:core.

Lemma sublist_of_append_inversion1 : forall (l l1 l2: list id),
    (is_sublist_id (l1 ++ l2) l) -> (is_sublist_id l1 l).
Proof.
  intros.
  inversion H.
  pose proof in_list_id_append1 as HH.
  econstructor.
  intros. apply H0.
  auto.
Qed.

Hint Resolve sublist_of_append_inversion1:core.

Lemma sublist_of_append_inversion2 : forall (l l1 l2: list id),
    (is_sublist_id (l1 ++ l2) l) -> (is_sublist_id l2 l).
Proof.
  intros.
  inversion H.
  pose proof in_list_id_append2 as HH.
  econstructor.
  intros. apply H0.
  auto.
Qed.

Hint Resolve sublist_of_append_inversion2:core.

Lemma in_list_id_cons_to_app : forall l i st, in_list_id st (l ++ i :: nil) = true ->
                                         in_list_id st (i::l) = true.
Proof.
  intros.
  induction l; crush.
Qed.

Hint Resolve in_list_id_cons_to_app:core.

Lemma sublist_cons_inv : forall (l l': (list id)) (i: id),
    (is_sublist_id l l') -> (in_list_id i l') = true -> (is_sublist_id (l ++ i::nil) l').
Proof.
  intros.
  econstructor.
  intros.
  inverts* H.
  apply in_list_id_cons_to_app in H1.
  simpl in H1.
  crush.
Qed.

Hint Resolve sublist_cons_inv:core.

Lemma sublist_inv1 : forall (l1 l2 : list id) (st : id), is_sublist_id l1 l2 ->
                                                    in_list_id st l1 = true ->
                                                    in_list_id st l2 = true.
intros.
inversion_clear H; auto.
Qed.

Hint Resolve sublist_inv1:core.

Lemma sublist_cons : forall (l l0: (list id)) (a: id),
    (is_sublist_id (a::l0) l) -> (is_sublist_id l0 l).
Proof.
  intros.
  econstructor.
  intros.
  inversion H. apply H1.
  mysimp.
Qed.

Hint Resolve sublist_cons:core.

Lemma disjoint_list_and_append : forall (l l1 l2: (list id)),
    (are_disjoints l1 l) -> (are_disjoints l2 l) ->
    (are_disjoints (l1 ++ l2) l).
Proof.
  unfold are_disjoints.
  intros.
  apply in_list_id_or_append_inversion in H1.
  destruct H1; auto.
Qed.

Hint Resolve disjoint_list_and_append:core.

Lemma are_disjoints_symetry : forall (l l' : (list id)),
    (are_disjoints l l') -> (are_disjoints l' l).
Proof.
  intros.
  intro. intros.
  eapply disjoint_inversion2.
  apply H. auto.
Qed.

Hint Resolve are_disjoints_symetry:core.

Lemma disjoint_sublist_bis : forall (l1 l2 l: (list id)),
    (are_disjoints l2 l1) -> (is_sublist_id l l2) -> (are_disjoints l1 l).
  intros.
  inversion H0. subst.
  apply are_disjoints_symetry.
  intro. intros.
  auto.
Qed.

Hint Resolve disjoint_sublist_bis:core.

Lemma sublist_FV_type_scheme : forall (s : substitution) (sigma : schm) (i : id),
    (in_list_id i (FV_schm sigma)) = true ->
    (is_sublist_id (ids_ty (apply_subst s (var i)))
                       (FV_schm (apply_subst_schm s sigma))).
Proof.
  intros.
  induction sigma.
  - econstructor. intros.
    simpl in H.
    destruct (eq_id_dec i0 i); intuition.
    subst.
    assert (sc_var i = ty_to_schm (var i)). {reflexivity. }
    rewrite H1.
    rewrite ty_to_subst_schm.
    rewrite FV_type_scheme_type_to_type_scheme. auto.
  - simpl in H. inversion H.
  - simpl in H. inversion H.
  - simpl in H.
    apply in_list_id_or_append_inversion in H.
    destruct H;
      rewrite apply_subst_schm_arrow;
      simpl.
    eapply sublist_of_append1. auto.
    eapply sublist_of_append2. auto.
Qed.

Hint Resolve sublist_FV_type_scheme:core.

Lemma sublist_FV_ctx : forall (G: ctx) (s: substitution) (i : id),
    in_list_id i (FV_ctx G) = true ->
    (is_sublist_id (ids_ty (apply_subst s (var i))) (FV_ctx (apply_subst_ctx s G))).
Proof.
  intros.
  induction G.
  - simpl in H. inversion H.
  - destruct a.
    destruct (in_list_id_or_append_inversion i (FV_schm s0) (FV_ctx G) H).
    eapply sublist_of_append1.
    simpl.
    eapply sublist_FV_type_scheme; auto.
    unfold FV_ctx.
    simpl.
    eapply sublist_of_append2.
    auto.
Qed.

Hint Resolve sublist_FV_ctx:core.

Lemma sublist_of_2_app : forall l l' l1 l2 : list id,
    is_sublist_id l1 l ->
    is_sublist_id l2 l' ->
    is_sublist_id (l1 ++ l2) (l ++ l').
Proof.
  intros.
  econstructor. intros.
  eauto.
Qed.

Hint Resolve sublist_of_2_app:core.


Require Import Arith.
Require Import Omega.
Require Import List.

Section Monoid.
Class Monoid(S:Set) : Type := {
  op : S -> S -> S;
  e : S;
  left_id : forall x, op e x = x;
  right_id : forall x, op x e = x;
  assoc : forall x y z, op (op x y) z = op x (op y z)
}.
Notation "a :+: b" := (op a b)
 (left associativity, at level 50).
Instance nat_monoid:Monoid nat:= {
  op := plus;
  e := O
}.
Proof.
  intros. omega.
 intros. omega.
intros. omega.
Defined.

Eval compute in (2 :+: 3).

Class Monad (M:Type -> Type):Type := {
  return' : forall {A}, A -> M A;
  bind : forall {A B}, M A -> (A -> M B) -> M B;
  left_unit : forall A B (a:A)(f:A -> M B), bind (return' a) f = f a;
  right_unit : forall A (ma:M A), bind ma return' = ma;
  associativity : forall A B C (ma:M A)(f:A->M B)(g:B->M C),
    bind (bind ma f) g = bind ma (fun a => bind (f a) g)
}.

Notation "m >>= f" := (bind m f) (left associativity, at level 49).
Notation "'do' a <- e ; c" := (e >>= (fun a => c)) (at level 59, right associativity).

Definition id'(A:Type):Type := A.

Instance Identity : Monad id' := {
 return' A a := a;
 bind A B ma f := f ma
}.
Proof.
  intros A B a f. auto.
 intros A ma. auto.
intros A B C ma f g. auto.
Defined.

Instance Maybe : Monad option := {
 return' A a := Some a;
 bind A B ma f :=
   match ma with
   | None => None
   | Some a => f a
   end
}.
Proof.
  intros A B a f. auto.
 intros A m. destruct m; auto.
intros A B C m f g. destruct m; simpl; auto.
Defined.

Eval compute in (None >>= (fun x => Some (x + 1))).
Eval compute in (Some 1 >>= (fun x => Some (x + 1))).

Require Import List.

Lemma flat_map_app : forall (A B:Type)(xs ys:list A)(f:A -> list B),
 flat_map f (xs++ys) = flat_map f xs ++ flat_map f ys.
Proof.
induction xs.
 simpl. auto.
simpl. intros. erewrite IHxs. erewrite app_ass. auto.
Qed.

Instance List : Monad list := {
  return' A x := x :: nil;
  bind A B m f := flat_map f m
}.
Proof.
  intros A B a f. simpl. erewrite <- app_nil_end. auto.
 intros A m. induction m.
  simpl. auto.
 simpl. rewrite IHm. auto.
intros A B C m f g. induction m.
 simpl. auto.
simpl. rewrite <- IHm.
erewrite flat_map_app. auto.
Defined.

Class MonadPlus (M:Type -> Type) : Type := {
 (* MonadPlus is Monad *)
  monad :> Monad M ;
 (* field *)
  mzero : forall A, M A;
  mplus : forall A, M A -> M A -> M A;
 (* axiom *)
  mzero_left : forall A f, bind (@mzero A) f = (@mzero A);
  mzero_right : forall A B (ma:M A), bind ma (fun x => (@mzero B)) = (@mzero B);
  monoid_left_unit : forall A (ma:M A), mplus _ (@mzero A) ma = ma;
  monoid_right_unit : forall A (ma:M A), mplus _ ma (@mzero A) = ma;
  monoid_assoc : forall A (ma mb mc:M A), mplus _ (mplus _ ma mb) mc = mplus _ ma (mplus _ mb mc)
}.

Instance MaybePlus : MonadPlus option := {
 monad := Maybe;
 mzero A := @None A;
 mplus A m1 m2 :=
   match m1 with
   | None => m2
   | Some x => m1
   end
}.
Proof.
    intros A f. simpl. auto.
   intros A B ma. simpl. destruct ma; auto.
  intros A ma; auto.
 intros A ma; destruct ma; auto.
intros A ma mb mc.
destruct ma; destruct mb; destruct mc; auto.
Defined.

Instance ListPlus : MonadPlus list := {
 monad := List;
 mzero A := @nil A;
 mplus A m1 m2 := m1 ++ m2
}.
Proof.
    intros A f. simpl. auto.
   intros A B ma. induction ma; simpl; auto.
  intros A ma; auto.
 intros A ma. erewrite <- app_nil_end. auto.
intros A ma mb mc. erewrite app_ass. auto.
Defined.

Require Import Logic.FunctionalExtensionality.

Definition cont (R A:Type):Type := (A->R)->R.

Instance Cont R : Monad (cont R) := {
 return' A a := fun k:A->R => k a;
 bind A B m f := fun k:B->R => m (fun a => f a k)
}.
Proof.
  intros A B a f. unfold cont in *.
  erewrite <- eta_expansion.  reflexivity.
 intros A ma.  unfold cont in *.
 erewrite eta_expansion.  extensionality x.
 erewrite <- eta_expansion.  auto.
intros A B C ma f g.  reflexivity.
Defined.


Inductive ty : Type :=
| TBool : ty
| TNat : ty
| TList : ty -> ty.

Definition eq_ty_dec (x y : ty) : {x = y} + {x <> y}.
  decide equality.
Defined.

Definition env := list ty.

(* Intrinsically typed expression syntax *)
Inductive exp G : ty -> Type :=
(* A variable is a member of the typing context *)
| evar : forall t, member t G -> exp G t
| etrue : exp G TBool
| efalse : exp G TBool
| econst : nat -> exp G TNat
| esucc : exp G TNat -> exp G TNat
| eand : exp G TBool -> exp G TBool -> exp G TBool
| enil : forall t, exp G (TList t)
| econs : forall t, exp G t -> exp G (TList t) -> exp G (TList t)
| elet : forall t1 t2, exp G t1 -> exp (t1 :: G) t2 -> exp G t2
| eappend : forall t, exp G (TList t) -> exp G (TList t) -> exp G (TList t)
| emap : forall t1 t2, exp (t1 :: G) t2 -> exp G (TList t1) -> exp G (TList t2)
| efilter : forall t1, exp (t1 :: G) TBool -> exp G (TList t1) -> exp G (TList t1).

Arguments econst [G].
Arguments etrue [G].
Arguments efalse [G].
Arguments enil [G t].

Notation "[| |]" := enil.
Notation "[| x |]" := (econs x enil).
Notation "[| x ; y ; .. ; z |]" := (econs x (econs y .. (econs z enil) ..)).
Notation "[| x ; .. ; y |]" := (econs x .. (econs y enil) ..).

(* Intrinsically typed values as well *)
Inductive val : ty -> Type :=
| vtrue : val TBool
| vfalse : val TBool
| vconst : nat -> val TNat
| vnil : forall t, val (TList t)
| vcons : forall t, val t -> val (TList t) -> val (TList t).

Arguments vnil [t].

Notation "[|| ||]" := vnil.
Notation "[|| x ||]" := (vcons x vnil).
Notation "[|| x ; y ; .. ; z ||]" := (vcons x (vcons y .. (vcons z vnil) ..)).
Notation "[|| x ; .. ; y ||]" := (vcons x .. (vcons y vnil) ..).


From mathcomp Require Import ssreflect seq ssrfun ssrbool ssrnat.
From mf Require Import all_mf.
Require Import pointwise reals pseudo_metrics pseudo_metric_spaces metrics.
Require Import Reals Psatz Classical ChoiceFacts Morphisms ProofIrrelevance ProofIrrelevanceFacts.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope R_scope.
Local Open Scope metric_scope.
Section MetricSpaces.
  Class MetricSpace :=
    {
      carrier: Type;
      distance: carrier * carrier -> R;
      metric: distance \is_metric;
    }.

  Coercion carrier: MetricSpace >-> Sortclass.
  Context (M: MetricSpace).
  Implicit Types (x y z: M) (xn yn: sequence_in M).

  Global Instance distant_metric: distance \is_metric.
  Proof. exact metric. Qed.

  Global Instance M2PM: PseudoMetricSpace.
    by exists carrier distance; apply m2pm.
  Defined.

  Lemma dst_le x y z r r' q:
    d (x, z) <= r -> d (z, y) <= r' -> r + r' <= q -> d (x, y) <= q.
  Proof. by apply dst_le. Qed.

  Lemma le_dst x y z r r' q: r + r' <= q -> d(x,z) <= r -> d(z,y) <= r' -> d(x,y) <= q.
  Proof. by apply le_dst. Qed.

  Lemma dst_lt x y z r r' q: d(x,z) <= r -> d(z,y) <= r' -> r + r' < q -> d(x,y) < q.
  Proof. by apply dst_lt. Qed.

End MetricSpaces.
Coercion M2PM: MetricSpace >-> PseudoMetricSpace.

Notation "xn ~> x" := (limit xn x) (at level 23): metric_scope.
Notation "x \limit_of xn" := (xn ~> x) (at level 23): metric_scope.
Notation "x \is_limit_of xn" := (xn ~> x) (at level 23): metric_scope.
Section limits.
  Context (M: MetricSpace).
  Implicit Types (x y z: M) (xn yn: sequence_in M).

  Lemma lim_sing: limit \is_singlevalued.
  Proof. exact lim_sing. Qed.

  Definition lim_cnst := @lim_cnst M.

  Lemma lim_tpmn xn x: limit xn x <->
    (forall n, exists N, forall m, (N <= m)%nat -> d(x,xn m) <= /2 ^ n).
  Proof. exact/lim_tpmn. Qed.

  Lemma cond_eq_tpmn x y:
    (forall n, d(x,y) <= / 2 ^ n) -> x = y.
  Proof. by apply cond_eq_tpmn. Qed.

  Lemma lim_lim xnk xn x: FunctionalCountableChoice ->
    (forall n, (xn n) \is_limit_of (xnk n)) -> x \is_limit_of xn ->
    exists mu, x \is_limit_of (fun n => xnk n (mu n)).
  Proof. by move => choice; apply lim_lim. Qed.
End limits.

Notation "A \dense_subset" := (A \dense_subset_wrt d) (at level 35): metric_scope.
Notation "A \is_dense_subset":= (A \dense_subset) (at level 35): metric_scope.
Notation "xn \dense" := (xn \dense_wrt d) (at level 35): metric_scope.
Notation "xn \is_dense" := (xn \dense) (at level 35): metric_scope.
Notation "xn \dense_sequence" := (xn \dense) (at level 35): metric_scope.
Notation "xn \is_dense_sequence" := (xn \dense) (at level 35): metric_scope.
Section sets.
  Context (M: MetricSpace).

  Lemma dns_tpmn (A: subset M):
    A \dense_subset <-> forall x n, exists y, y \from A /\ d(x, y) <= /2^n.
  Proof. exact/dns_tpmn. Qed.

  Lemma dseq_dns (xn: sequence_in M): xn \dense <-> (codom (F2MF xn)) \dense_subset.
  Proof. exact/dseq_dns. Qed.

  Lemma dseq_tpmn (xn: sequence_in M):
    xn \dense <-> forall x n, exists k, d(x, xn k) <= /2^n.
  Proof. exact/dseq_tpmn. Qed.

  Lemma subs_clos A: A \is_subset_of closure A.
  Proof. by apply subs_clos. Qed.

  Lemma clos_spec A x: FunctionalCountableChoice -> x \from closure A <->
                       exists (xn: sequence_in A), x \is_limit_of (ptw sval xn).
  Proof. by move => choice; apply clos_spec. Qed.

  Lemma dns_clos A: A \dense_subset_wrt d <-> closure A === All.
  Proof. exact/dns_clos. Qed.
End sets.

Notation "xn \Cauchy" := (xn \Cauchy_wrt d) (at level 45): metric_scope.
Notation "xn \Cauchy_sequence" := (xn \Cauchy) (at level 45): metric_scope.
Notation "xn \is_Cauchy" := (xn \Cauchy) (at level 45): metric_scope.
Notation "xn \is_Cauchy_sequence" := (xn \Cauchy) (at level 45): metric_scope.
Notation "xn \fast_Cauchy" := (xn \fast_Cauchy_wrt d) (at level 45): metric_scope.
Notation "xn \fast_Cauchy_sequence" := (xn \fast_Cauchy) (at level 45): metric_scope.
Notation "xn \is_fast_Cauchy_sequence" := (xn \fast_Cauchy) (at level 45): metric_scope.
Notation "x \efficient_limit_of xn" := (efficient_limit xn x) (at level 45): metric_scope.
Notation "M \is_complete" := (complete M) (at level 45): metric_scope.
Section Cauchy_sequences.
  Context (M: MetricSpace).
  Implicit Types (x y z: M) (xn yn: sequence_in M).

  Lemma lim_cchy: dom limit \is_subset_of Cauchy_sequences.
  Proof. exact lim_cchy. Qed.

  Lemma fchy_cchy: fast_Cauchy_sequences \is_subset_of Cauchy_sequences.
  Proof. exact/fchy_cchy. Qed.

  Lemma cchy_tpmn xn: xn \Cauchy <->
    (forall k, exists N, forall n m,
            (N <= n <= m)%nat -> d(xn n, xn m) <= /2^k).
  Proof. by apply cchy_tpmn. Qed.

  Lemma lim_evb xn mu (x: M):
    x \is_limit_of xn -> eventually_big mu -> x \is_limit_of (xn \o_f mu).
  Proof. exact/lim_evb. Qed.

  Lemma cchy_evb xn mu: xn \Cauchy -> eventually_big mu -> (xn \o_f mu) \Cauchy.
  Proof. exact/cchy_evb. Qed.

  Lemma cchy_fchy xn: FunctionalCountableChoice_on nat -> xn \Cauchy -> exists mu, (xn \o_f mu) \fast_Cauchy_sequence.
  Proof. by move => choice; apply cchy_fchy. Qed.

  Lemma lim_eff_spec: efficient_limit =~= limit|_fast_Cauchy_sequences.
  Proof. exact lim_eff_spec. Qed.

  Lemma lim_eff_lim : limit \extends efficient_limit.
  Proof. exact lim_eff_lim. Qed.

  Lemma fchy_lim_eff: d \is_complete_metric ->
    fast_Cauchy_sequences === dom efficient_limit.
  Proof. exact fchy_lim_eff. Qed.

  Lemma lim_tight_lim_eff: limit \tightens efficient_limit.
  Proof. exact lim_tight_lim_eff. Qed.

  Lemma lim_eff_sing: efficient_limit \is_singlevalued.
  Proof. exact lim_eff_sing. Qed.

  Lemma cchy_eff_suff xn:
    (forall n m, (n <= m)%nat -> d (xn n, xn m) <= /2^n + /2^m) ->
    xn \fast_Cauchy_sequence_wrt d.
  Proof. by apply cchy_eff_suff. Qed.
End Cauchy_sequences.
Notation "f \continuous_in x" :=
  (continuity_point d d (f: M2PM _ -> M2PM _) x) (at level 35): metric_scope.
Notation d := distance.
Notation continuity_points:= (pseudo_metrics.continuity_points d d).
Notation "f \continuous" := (continuous d d f) (at level 2): metric_scope.
Local Open Scope pseudometric_scope.
Notation "f \is_continuous" := (f \continuous_wrt d \and d) (at level 2): metric_scope.
Notation sequential_continuity_points := (pseudo_metrics.sequential_continuity_points d d).
Notation "f \sequentially_continuous_in x" :=
  (sequential_continuity_point d d f x) (at level 40): metric_scope.
Notation "f \sequentially_continuous" :=
  (f \sequentially_continuous_wrt d \and d) (at level 40): metric_scope.
Notation "f \is_sequentially_continuous" :=
  (f \sequentially_continuous) (at level 40): metric_scope.
Local Close Scope pseudometric_scope.

Section continuity.
  Context (M M': MetricSpace) (f: M -> M').

  Lemma cntp_tpmn x:
    f \continuous_in x <-> forall n, exists m, forall x', d (x, x') <= /2^m -> d (f x, f x') <= /2^n.
  Proof. by apply cntp_tpmn. Qed.

  Lemma cont_tpmn:
    f \is_continuous <-> forall x n, exists m, forall x', d (x, x') <= /2^m -> d (f x, f x') <= /2^n.
  Proof. exact/cont_tpmn. Qed.

  Lemma cntp_scntp: continuity_points f \is_subset_of sequential_continuity_points f.
  Proof. exact/cntp_scntp. Qed.

  Lemma cont_scnt: f \is_continuous -> f \sequentially_continuous.
  Proof. exact/cont_scnt. Qed.

  Lemma scnt_cont: FunctionalCountableChoice_on M -> f \sequentially_continuous -> f \is_continuous.
  Proof. by apply scnt_cont. Qed.
End continuity.

Section subspaces.
  Context (M: MetricSpace).

  Global Instance subspace (A: subset M): MetricSpace.
    exists {x | x \from A} (fun p => d(sval p.1, sval p.2)).
    by apply sub_metric.
  Defined.

  Definition sub_fun S T (A: subset S) (f: S -> T) (a: A) := f (sval a).
  Arguments sub_fun {S} {T} (A).

  Definition sub_mf S T (A: subset S) (f: S ->> T) :=
    make_mf (fun (a: A) t => f (sval a) t).

  Lemma sub_F2MF S T (A: subset S) (f: S -> T):
    F2MF (sub_fun A f) =~= sub_mf A (F2MF f).
  Proof. done. Qed.
End subspaces.
Notation pd:= pseudo_metric_spaces.distance.


Require Export Logics.
Require Export Coq.Setoids.Setoid.

(* Axioms  *)

Axiom set : Type.

Axiom In : set -> set -> Prop.
Notation "x ∈ X" := (In x X)(at level 10).

(*Axioms*)
Axiom Existance :
  exists x : set, x = x.

Axiom Extensionality :
  forall X Y , (forall z, z ∈ X <-> z ∈ Y) -> X = Y.

Axiom Comprehension :
  forall P X, exists Y, forall x, x ∈ Y <-> x ∈ X /\ P x.

Axiom Pair :
  forall X Y, exists U, X ∈ U /\ Y ∈ U.

Axiom Union :
  forall X, exists U, forall Y z, z ∈ Y /\ Y ∈ X -> z ∈ U.

Axiom Replacement :
  forall (P : set -> set -> Prop) (X : set),
  (forall x, x ∈ X -> exists !y, P x y) ->
  exists Y, forall x, x ∈ X -> exists y,y ∈ Y /\  P x y.

Axiom Power :
  forall X, exists U, forall Y, (forall x, x ∈  Y -> x ∈ X)  -> Y ∈ U.

(* Notations *)
Definition exists_class (P : set -> Prop) :=
  exists X, forall x, x ∈ X <-> P x.

Axiom Class :
  forall P, exists_class P -> set.

Axiom class :
  forall P H x, x ∈ (Class P H) <-> P x.

Theorem separate :
  forall P X, exists_class (fun x => x ∈  X /\ P x).
Proof.
  intros P X.
  apply (Comprehension P X).
Qed.

Definition Separation (X : set) (P : set -> Prop) :=
Class (fun x => x ∈ X  /\ P x) (separate P X ).

Notation "{ X ; P }" := (Separation X P)(at level 10).

Theorem separation {X : set} {P : set -> Prop} :
  forall x, x ∈  ({X ; P}) -> P x.
Proof.
  intros x H.
  apply class in H.
  apply H.
Qed.


Require Import HoTT.Basics.
Require Import Types.Universe.
Require Import Metatheory.Core Metatheory.FunextVarieties.

Generalizable All Variables.

(** * Univalence Implies Functional Extensionality *)

Section UnivalenceImpliesFunext.
  Context `{ua : Univalence_type}.

  (** Exponentiation preserves equivalences, i.e., if [e] is an equivalence then so is post-composition by [e]. *)

  (* Should this go somewhere else? *)

  Theorem univalence_isequiv_postcompose `{H0 : IsEquiv A B w} C : IsEquiv (fun (g:C->A) => w o g).
  Proof.
    unfold Univalence_type in *.
    refine (isequiv_adjointify
              (fun (g:C->A) => w o g)
              (fun (g:C->B) => w^-1 o g)
              _
              _);
    intro;
    pose (Build_Equiv _ _ w _) as w';
    change H0 with (@equiv_isequiv _ _ w');
    change w with (@equiv_fun _ _ w');
    clearbody w'; clear H0 w;
    rewrite <- (@eisretr _ _ (@equiv_path A B) (ua A B) w');
    generalize ((@equiv_inv _ _ (equiv_path A B) (ua A B)) w');
    intro p;
    clear w';
    destruct p;
    reflexivity.
  Defined.

  (** We are ready to prove functional extensionality, starting with the naive non-dependent version. *)

  Local Instance isequiv_src_compose A B
  : @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
             (A -> B)
             (fun g => (fst o pr1) o g).
  Proof.
    rapply @univalence_isequiv_postcompose.
    refine (isequiv_adjointify
              (fst o pr1) (fun x => ((x, x); idpath))
              (fun _ => idpath)
              _);
      let p := fresh in
      intros [[? ?] p];
        simpl in p; destruct p;
        reflexivity.
  Defined.

  Local Instance isequiv_tgt_compose A B
  : @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
             (A -> B)
             (fun g => (snd o pr1) o g).
  Proof.
    rapply @univalence_isequiv_postcompose.
    refine (isequiv_adjointify
              (snd o pr1) (fun x => ((x, x); idpath))
              (fun _ => idpath)
              _);
      let p := fresh in
      intros [[? ?] p];
        simpl in p; destruct p;
        reflexivity.
  Defined.

  Theorem Univalence_implies_FunextNondep : NaiveNondepFunext.
  Proof.
    intros A B f g p.
    (** Consider the following maps. *)
    pose (d := fun x : A => exist (fun xy => fst xy = snd xy) (f x, f x) (idpath (f x))).
    pose (e := fun x : A => exist (fun xy => fst xy = snd xy) (f x, g x) (p x)).
    (** If we compose [d] and [e] with [free_path_target], we get [f] and [g], respectively. So, if we had a path from [d] to [e], we would get one from [f] to [g]. *)
    change f with ((snd o pr1) o d).
    change g with ((snd o pr1) o e).
    rapply (ap (fun g => snd o pr1 o g)).
    (** Since composition with [src] is an equivalence, we can freely compose with [src]. *)
    pose (fun A B x y=> @equiv_inv _ _ _ (@isequiv_ap _ _ _ (@isequiv_src_compose A B) x y)) as H'.
    apply H'.
    reflexivity.
  Defined.

End UnivalenceImpliesFunext.

(** Note that only the codomain universe of [NaiveNondepFunext] is required to be univalent. *)
Check @Univalence_implies_FunextNondep@{j jplusone i max j max}
  : Univalence_type@{j jplusone} -> NaiveNondepFunext@{i j max}.

(** Now we use this to prove strong dependent funext.  Again only the codomain universe must be univalent, but the domain universe must be no larger than it is.  Thus practically speaking this means that a univalent universe satisfies funext only for functions between two types in that same universe. *)

Definition Univalence_implies_WeakFunext : Univalence_type -> WeakFunext
  := NaiveNondepFunext_implies_WeakFunext o @Univalence_implies_FunextNondep.

Definition Univalence_type_implies_Funext_type
           `{ua : Univalence_type@{j jplusone} }
  : Funext_type@{i j j}
  := NaiveNondepFunext_implies_Funext
       (@Univalence_implies_FunextNondep ua).

(** The above proof justifies assuming [Univalence -> Funext], which we did axiomatically in [Types/Universe.v]. *)


Require Import leb128.
Require Import Coq.Init.Byte Coq.Numbers.BinNums.
Require Import NArith.BinNat ZArith.ZArith.
From parseque Require Import Running Induction.
Require Import check_toks.

(** Example from Wikipedia article: https://en.wikipedia.org/wiki/LEB128#Unsigned_LEB128
   This is the representation of the number [624485]. **)
Definition test_wikipedia : list Byte.byte :=
  xe5 :: x8e :: x26 :: nil.

Definition encode_unsigned_check (k : N) :=
  Singleton (encode_unsigned k).

Lemma test_wikipedia_encode :
  encode_unsigned_check 624485%N = Singleton test_wikipedia.
Proof.
  vm_compute. reflexivity.
Qed.

Definition test_wikipedia_decode :
  check_toks test_wikipedia parse_unsigned = Singleton 624485%N.
Proof.
  vm_compute. reflexivity.
Qed.

Definition test_wikipedia_signed: list Byte.byte :=
  xc0 :: xbb :: x78 :: nil.

Definition encode_signed_check (k : Z) :=
  Singleton (encode_signed k).

Lemma test_wikipedia_signed_encode:
  encode_signed_check (-123456)%Z = Singleton test_wikipedia_signed.
Proof.
  vm_compute. reflexivity.
Qed.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
Set Implicit Arguments.

Require Import Bvector.
Require Import List.
Require Import Arith.

Definition Blist := list bool.

Fixpoint splitVector(A : Set)(n m : nat) : Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
    | 0 =>
      fun (v : Vector.t A (O + m)) => (@Vector.nil A, v)
    | S n' =>
      fun (v : Vector.t A (S n' + m)) =>
        let (v1, v2) := splitVector _ _ (Vector.tl v) in
          (Vector.cons _ (Vector.hd v) _ v1, v2)
  end.

Section HMAC.

  Variable c p : nat.
  Definition b := c + p.

  (* The compression function *)
  Variable h : Bvector c -> Bvector b -> Bvector c.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Bvector c.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : list (Bvector b)) :=
    fold_left h m k.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  Variable Message : Set.
  Variable splitAndPad : Message -> list (Bvector b).
  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  Variable fpad : Bvector c -> Bvector p.
  Definition app_fpad (x : Bvector c) : Bvector b :=
    (Vector.append x (fpad x)).

  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitVector c c k in
    h k_Out (app_fpad (h_star k_In m)).

  (* The "two-key" version of GHMAC and HMAC. *)
  Definition GHMAC_2K (k : Bvector (b + b)) m :=
    let (k_Out, k_In) := splitVector b b k in
      let h_in := (hash_words (k_In :: m)) in
        hash_words (k_Out :: (app_fpad h_in) :: nil).

  Definition HMAC_2K (k : Bvector (b + b)) (m : Message) :=
    GHMAC_2K k (splitAndPad m).

  (* opad and ipad are constants defined in the HMAC spec. *)
  Variable opad ipad : Bvector b.
  Hypothesis opad_ne_ipad : opad <> ipad.

  Definition GHMAC (k : Bvector b) :=
    GHMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

  Definition HMAC (k : Bvector b) :=
    HMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

End HMAC.


Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Bool.IsTrue.
Require Import Crypto.Util.Bool.
Require Import Crypto.Util.HProp.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Notations.

Delimit Scope zbounded_scope with zbounded.
Local Open Scope Z_scope.
Local Set Primitive Projections.
Record zbounded {r : zrange}
  := { value :> Z ;
       value_bounded : is_true ((upper r <? lower r)
                                || ((lower r <=? value) && (value <=? upper r))) }.
Bind Scope zbounded_scope with zbounded.
Global Arguments Build_zbounded {r} value {_}, {r} value _, r value _.
Global Arguments zbounded r : clear implicits.

Definition adjust_zbounded {r} (v : zbounded r) : zbounded r
  := {| value := value v ;
        value_bounded := adjust_is_true (value_bounded v) |}.

(** ** Equality for [zbounded] *)
Section eq.
  Definition value_path {r} {u v : zbounded r} (p : u = v)
  : value u = value v
    := f_equal (@value _) p.

  Definition value_bounded_path {r} {u v : zbounded r} (p : u = v)
    : eq_rect
        _ (fun v => is_true (_ || ((lower r <=? v) && (v <=? upper r))))
        (value_bounded u) _ (value_path p)
      = value_bounded v.
  Proof.
    destruct p; reflexivity.
  Defined.

  Definition path_zbounded_full {r} (u v : zbounded r)
             (p : value u = value v)
             (q : eq_rect
                    _ (fun v => is_true (_ || ((lower r <=? v) && (v <=? upper r))))
                    (value_bounded u) _ p
                  = value_bounded v)
    : u = v.
  Proof.
    destruct u as [u1 u2], v as [v1 v2]; simpl in *; subst v1 v2; reflexivity.
  Defined.

  Definition path_zbounded {r} (u v : zbounded r)
             (p : value u = value v)
    : u = v.
  Proof.
    apply (path_zbounded_full u v p).
    destruct u as [u1 u2], v as [v1 v2]; simpl in *; subst v1; simpl.
    let P := lazymatch type of u2 with is_true ?P => P end in
    generalize dependent P.
    compute; intros b p q; clear.
    transitivity (adjust_is_true q); clear; subst; reflexivity.
  Defined.

  Definition path_zbounded_rect_full {r} {u v : zbounded r} (Q : u = v -> Type)
             (f : forall p q, Q (path_zbounded_full u v p q))
    : forall p, Q p.
  Proof.
    intro p; specialize (f (value_path p) (value_bounded_path p));
      destruct u as [u0 u1], p; exact f.
  Defined.
  Definition path_zbounded_rec_full {r u v} (Q : u = v :> zbounded r -> Set) := path_zbounded_rect_full Q.
  Definition path_zbounded_ind_full {r u v} (Q : u = v :> zbounded r -> Prop) := path_zbounded_rec_full Q.

  Definition path_zbounded_rect {r} {u v : zbounded r} (Q : u = v -> Type)
             (f : forall p, Q (path_zbounded u v p))
    : forall p, Q p.
  Proof.
    intro p; specialize (f (value_path p));
      destruct u as [u0 u1], p.
    simpl in *.
    generalize dependent (@Build_zbounded r u0); intros.
    let P := lazymatch type of u1 with is_true ?P => P end in
    generalize dependent P; intros.
    unfold is_true in *.
    subst.
    exact f.
  Defined.
  Definition path_zbounded_rec {r u v} (Q : u = v :> zbounded r -> Set) := path_zbounded_rect Q.
  Definition path_zbounded_ind {r u v} (Q : u = v :> zbounded r -> Prop) := path_zbounded_rec Q.

  (** *** η Principle for [zbounded] *)
  Definition sigT_eta {r} (p : zbounded r)
    : p = {| value := value p ; value_bounded := value_bounded p |}
    := eq_refl.
End eq.

Ltac induction_zbounded_in_as_using H H0 H1 rect :=
  induction H as [H0 H1] using (rect _ _ _);
  cbn [value value_bounded] in H0, H1.
Ltac induction_zbounded_in_using H rect :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction_zbounded_in_as_using H H0 H1 rect.
Ltac inversion_zbounded_step :=
  match goal with
  | [ H : _ = @Build_zbounded _ _ _ |- _ ]
    => induction_zbounded_in_using H @path_zbounded_rect_full
  | [ H : @Build_zbounded _ _ _ = _ |- _ ]
    => induction_zbounded_in_using H @path_zbounded_rect_full
  end.
Ltac inversion_zbounded := repeat inversion_zbounded_step.

Lemma is_bounded_by'_zbounded {r} (v : zbounded r) : lower r <= upper r -> is_bounded_by' None r v.
Proof.
  destruct v as [v H]; cbv [is_bounded_by']; simpl.
  apply Bool.orb_true_iff in H; destruct H; split_andb; Z.ltb_to_lt; lia.
Qed.

Global Instance dec_eq_zrange {r} : DecidableRel (@eq (zbounded r)) | 10.
Proof.
  intros [x ?] [y ?].
  destruct (dec (x = y));
    [ left; apply path_zbounded; assumption
    | abstract (right; intro H; inversion_zbounded; tauto) ].
Defined.

Definition modulo (z : Z) (r : zrange) : zbounded r.
Proof.
  refine {| value := if (upper r <? lower r)
                     then z
                     else lower r + Z.modulo (z - lower r) (upper r - lower r + 1) |}.
  abstract (
      destruct (upper r <? lower r) eqn:H; [ reflexivity | ];
      pose proof (Z.mod_pos_bound (z - lower r) (upper r - lower r + 1)) as Hmod;
      destruct r as [l u];
      simpl in *; apply Bool.andb_true_iff; split;
      destruct (l =? u) eqn:H';
      Z.ltb_to_lt; subst;
      repeat rewrite ?Z.sub_diag, ?Zmod_0_r, ?Z.add_0_r, ?Z.add_0_l, ?Z.mod_1_r;
      try reflexivity; try lia
    ).
Defined.

Lemma modulo_value_id {r} (v : zbounded r) : modulo (value v) r = v.
Proof.
  apply path_zbounded; simpl.
  destruct v as [v H]; simpl.
  destruct (upper r <? lower r) eqn:H'; [ reflexivity | ].
  simpl in *; unfold is_true in *; split_andb; Z.ltb_to_lt.
  rewrite Z.mod_small by lia.
  lia.
Qed.

Lemma value_modulo_in_range z r (Hr : lower r <= z <= upper r)
  : value (modulo z r) = z.
Proof.
  simpl.
  destruct (upper r <? lower r) eqn:H'; [ reflexivity | ].
  rewrite Z.mod_small by lia.
  lia.
Qed.


From Hammer Require Import Hammer.

Require Import FunInd MSetInterface MSetGenTree BinInt Int.

Set Implicit Arguments.
Unset Strict Implicit.

Local Unset Elimination Schemes.

Module Ops (Import I:Int)(X:OrderedType) <: MSetInterface.Ops X.
Local Open Scope Int_scope.
Local Notation int := I.t.

Include MSetGenTree.Ops X I.

Definition t := tree.

Definition height (s : t) : int :=
match s with
| Leaf => 0
| Node h _ _ _ => h
end.

Definition singleton x := Node 1 Leaf x Leaf.

Definition create l x r :=
Node (max (height l) (height r) + 1) l x r.

Definition assert_false := create.

Definition bal l x r :=
let hl := height l in
let hr := height r in
if (hr+2) <? hl then
match l with
| Leaf => assert_false l x r
| Node _ ll lx lr =>
if (height lr) <=? (height ll) then
create ll lx (create lr x r)
else
match lr with
| Leaf => assert_false l x r
| Node _ lrl lrx lrr =>
create (create ll lx lrl) lrx (create lrr x r)
end
end
else
if (hl+2) <? hr then
match r with
| Leaf => assert_false l x r
| Node _ rl rx rr =>
if (height rl) <=? (height rr) then
create (create l x rl) rx rr
else
match rl with
| Leaf => assert_false l x r
| Node _ rll rlx rlr =>
create (create l x rll) rlx (create rlr rx rr)
end
end
else
create l x r.

Fixpoint add x s := match s with
| Leaf => Node 1 Leaf x Leaf
| Node h l y r =>
match X.compare x y with
| Lt => bal (add x l) y r
| Eq => Node h l y r
| Gt => bal l y (add x r)
end
end.

Fixpoint join l : elt -> t -> t :=
match l with
| Leaf => add
| Node lh ll lx lr => fun x =>
fix join_aux (r:t) : t := match r with
| Leaf => add x l
| Node rh rl rx rr =>
if (rh+2) <? lh then bal ll lx (join lr x r)
else if (lh+2) <? rh then bal (join_aux rl) rx rr
else create l x r
end
end.

Fixpoint remove_min l x r : t*elt :=
match l with
| Leaf => (r,x)
| Node lh ll lx lr =>
let (l',m) := remove_min ll lx lr in (bal l' x r, m)
end.

Definition merge s1 s2 :=  match s1,s2 with
| Leaf, _ => s2
| _, Leaf => s1
| _, Node _ l2 x2 r2 =>
let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2'
end.

Fixpoint remove x s := match s with
| Leaf => Leaf
| Node _ l y r =>
match X.compare x y with
| Lt => bal (remove x l) y r
| Eq => merge l r
| Gt => bal l y (remove x r)
end
end.

Definition concat s1 s2 :=
match s1, s2 with
| Leaf, _ => s2
| _, Leaf => s1
| _, Node _ l2 x2 r2 =>
let (s2',m) := remove_min l2 x2 r2 in
join s1 m s2'
end.

Record triple := mktriple { t_left:t; t_in:bool; t_right:t }.
Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).

Fixpoint split x s : triple := match s with
| Leaf => << Leaf, false, Leaf >>
| Node _ l y r =>
match X.compare x y with
| Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >>
| Eq => << l, true, r >>
| Gt => let (rl,b,rr) := split x r in << join l y rl, b, rr >>
end
end.

Fixpoint inter s1 s2 := match s1, s2 with
| Leaf, _ => Leaf
| _, Leaf => Leaf
| Node _ l1 x1 r1, _ =>
let (l2',pres,r2') := split x1 s2 in
if pres then join (inter l1 l2') x1 (inter r1 r2')
else concat (inter l1 l2') (inter r1 r2')
end.

Fixpoint diff s1 s2 := match s1, s2 with
| Leaf, _ => Leaf
| _, Leaf => s1
| Node _ l1 x1 r1, _ =>
let (l2',pres,r2') := split x1 s2 in
if pres then concat (diff l1 l2') (diff r1 r2')
else join (diff l1 l2') x1 (diff r1 r2')
end.

Fixpoint union s1 s2 :=
match s1, s2 with
| Leaf, _ => s2
| _, Leaf => s1
| Node _ l1 x1 r1, _ =>
let (l2',_,r2') := split x1 s2 in
join (union l1 l2') x1 (union r1 r2')
end.

Fixpoint filter (f:elt->bool) s := match s with
| Leaf => Leaf
| Node _ l x r =>
let l' := filter f l in
let r' := filter f r in
if f x then join l' x r' else concat l' r'
end.

Fixpoint partition (f:elt->bool)(s : t) : t*t :=
match s with
| Leaf => (Leaf, Leaf)
| Node _ l x r =>
let (l1,l2) := partition f l in
let (r1,r2) := partition f r in
if f x then (join l1 x r1, concat l2 r2)
else (concat l1 r1, join l2 x r2)
end.

End Ops.

Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X.
Include Ops I X.

Include MSetGenTree.Props X I.

Local Hint Immediate MX.eq_sym.
Local Hint Unfold In lt_tree gt_tree Ok.
Local Hint Constructors InT bst.
Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok.
Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
Local Hint Resolve elements_spec2.

Tactic Notation "factornode" ident(s) :=
try clear s;
match goal with
| |- context [Node ?l ?x ?r ?h] =>
set (s:=Node l x r h) in *; clearbody s; clear l x r h
| _ : context [Node ?l ?x ?r ?h] |- _ =>
set (s:=Node l x r h) in *; clearbody s; clear l x r h
end.

Functional Scheme bal_ind := Induction for bal Sort Prop.
Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
Functional Scheme merge_ind := Induction for merge Sort Prop.
Functional Scheme concat_ind := Induction for concat Sort Prop.
Functional Scheme inter_ind := Induction for inter Sort Prop.
Functional Scheme diff_ind := Induction for diff Sort Prop.
Functional Scheme union_ind := Induction for union Sort Prop.

Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope.
Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope.
Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope.

Local Open Scope pair_scope.

Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.singleton_spec".
unfold singleton; intuition_in.
Qed.

Instance singleton_ok x : Ok (singleton x).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.singleton_ok".
unfold singleton; auto.
Qed.

Lemma create_spec :
forall l x r y,  InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.create_spec".
unfold create; split; [ inversion_clear 1 | ]; intuition.
Qed.

Instance create_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
Ok (create l x r).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.create_ok".
unfold create; auto.
Qed.

Lemma bal_spec : forall l x r y,
InT y (bal l x r) <-> X.eq y x \/ InT y l \/ InT y r.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.bal_spec".
intros l x r; functional induction bal l x r; intros; try clear e0;
rewrite !create_spec; intuition_in.
Qed.

Instance bal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
Ok (bal l x r).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.bal_ok".
functional induction bal l x r; intros;
inv; repeat apply create_ok; auto; unfold create;
(apply lt_tree_node || apply gt_tree_node); auto;
(eapply lt_tree_trans || eapply gt_tree_trans); eauto.
Qed.

Lemma add_spec' : forall s x y,
InT y (add x s) <-> X.eq y x \/ InT y s.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.add_spec'".
induct s x; try rewrite ?bal_spec, ?IHl, ?IHr; intuition_in.
setoid_replace y with x'; eauto.
Qed.

Lemma add_spec : forall s x y `{Ok s},
InT y (add x s) <-> X.eq y x \/ InT y s.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.add_spec".   intros; apply add_spec'. Qed.

Instance add_ok s x `(Ok s) : Ok (add x s).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.add_ok".
induct s x; auto; apply bal_ok; auto;
intros y; rewrite add_spec'; intuition; order.
Qed.

Local Open Scope Int_scope.

Ltac join_tac :=
let l := fresh "l" in
intro l; induction l as [| lh ll _ lx lr Hlr];
[ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join;
[ | destruct ((rh+2) <? lh) eqn:LT;
[ match goal with |- context b [ bal ?a ?b ?c] =>
replace (bal a b c)
with (bal ll lx (join lr x (Node rh rl rx rr))); [ | auto]
end
| destruct ((lh+2) <? rh) eqn:LT';
[ match goal with |- context b [ bal ?a ?b ?c] =>
replace (bal a b c)
with (bal (join (Node lh ll lx lr) x rl) rx rr); [ | auto]
end
| ] ] ] ]; intros.

Lemma join_spec : forall l x r y,
InT y (join l x r) <-> X.eq y x \/ InT y l \/ InT y r.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.join_spec".
join_tac.
simpl.
rewrite add_spec'; intuition_in.
rewrite add_spec'; intuition_in.
rewrite bal_spec, Hlr; clear Hlr Hrl; intuition_in.
rewrite bal_spec, Hrl; clear Hlr Hrl; intuition_in.
apply create_spec.
Qed.

Instance join_ok : forall l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r),
Ok (join l x r).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.join_ok".
join_tac; auto with *; inv; apply bal_ok; auto;
clear Hrl Hlr; intro; intros; rewrite join_spec in *.
intuition; [ setoid_replace y with x | ]; eauto.
intuition; [ setoid_replace y with x | ]; eauto.
Qed.

Lemma remove_min_spec : forall l x r y h,
InT y (Node h l x r) <->
X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.remove_min_spec".
intros l x r; functional induction (remove_min l x r); simpl in *; intros.
intuition_in.
rewrite bal_spec, In_node_iff, IHp, e0; simpl; intuition.
Qed.

Instance remove_min_ok l x r : forall h `(Ok (Node h l x r)),
Ok (remove_min l x r)#1.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.remove_min_ok".
functional induction (remove_min l x r); simpl; intros.
inv; auto.
assert (O : Ok (Node _x ll lx lr)) by (inv; auto).
assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto).
specialize IHp with (1:=O); rewrite e0 in IHp; auto; simpl in *.
apply bal_ok; auto.
inv; auto.
intro y; specialize (L y).
rewrite remove_min_spec, e0 in L; simpl in L; intuition.
inv; auto.
Qed.

Lemma remove_min_gt_tree : forall l x r h `{Ok (Node h l x r)},
gt_tree (remove_min l x r)#2 (remove_min l x r)#1.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.remove_min_gt_tree".
intros l x r; functional induction (remove_min l x r); simpl; intros.
inv; auto.
assert (O : Ok (Node _x ll lx lr)) by (inv; auto).
assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto).
specialize IHp with (1:=O); rewrite e0 in IHp; simpl in IHp.
intro y; rewrite bal_spec; intuition;
specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L;
[setoid_replace y with x|inv]; eauto.
Qed.
Local Hint Resolve remove_min_gt_tree.

Lemma merge_spec : forall s1 s2 y,
InT y (merge s1 s2) <-> InT y s1 \/ InT y s2.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.merge_spec".
intros s1 s2; functional induction (merge s1 s2); intros;
try factornode s1.
intuition_in.
intuition_in.
rewrite bal_spec, remove_min_spec, e1; simpl; intuition.
Qed.

Instance merge_ok s1 s2 : forall `(Ok s1, Ok s2)
`(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2),
Ok (merge s1 s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.merge_ok".
functional induction (merge s1 s2); intros; auto;
try factornode s1.
apply bal_ok; auto.
change s2' with ((s2',m)#1); rewrite <-e1; eauto with *.
intros y Hy.
apply H1; auto.
rewrite remove_min_spec, e1; simpl; auto.
change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
Qed.

Lemma remove_spec : forall s x y `{Ok s},
(InT y (remove x s) <-> InT y s /\ ~ X.eq y x).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.remove_spec".
induct s x.
intuition_in.
rewrite merge_spec; intuition; [order|order|intuition_in].
elim H2; eauto.
rewrite bal_spec, IHl; clear IHl IHr; intuition; [order|order|intuition_in].
rewrite bal_spec, IHr; clear IHl IHr; intuition; [order|order|intuition_in].
Qed.

Instance remove_ok s x `(Ok s) : Ok (remove x s).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.remove_ok".
induct s x.
auto.

apply merge_ok; eauto.

apply bal_ok; auto.
intro z; rewrite remove_spec; auto; destruct 1; eauto.

apply bal_ok; auto.
intro z; rewrite remove_spec; auto; destruct 1; eauto.
Qed.

Lemma concat_spec : forall s1 s2 y,
InT y (concat s1 s2) <-> InT y s1 \/ InT y s2.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.concat_spec".
intros s1 s2; functional induction (concat s1 s2); intros;
try factornode s1.
intuition_in.
intuition_in.
rewrite join_spec, remove_min_spec, e1; simpl; intuition.
Qed.

Instance concat_ok s1 s2 : forall `(Ok s1, Ok s2)
`(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2),
Ok (concat s1 s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.concat_ok".
functional induction (concat s1 s2); intros; auto;
try factornode s1.
apply join_ok; auto.
change (Ok (s2',m)#1); rewrite <-e1; eauto with *.
intros y Hy.
apply H1; auto.
rewrite remove_min_spec, e1; simpl; auto.
change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
Qed.

Lemma split_spec1 : forall s x y `{Ok s},
(InT y (split x s)#l <-> InT y s /\ X.lt y x).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.split_spec1".
induct s x.
intuition_in.
intuition_in; order.
specialize (IHl x y).
destruct (split x l); simpl in *. rewrite IHl; intuition_in; order.
specialize (IHr x y).
destruct (split x r); simpl in *. rewrite join_spec, IHr; intuition_in; order.
Qed.

Lemma split_spec2 : forall s x y `{Ok s},
(InT y (split x s)#r <-> InT y s /\ X.lt x y).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.split_spec2".
induct s x.
intuition_in.
intuition_in; order.
specialize (IHl x y).
destruct (split x l); simpl in *. rewrite join_spec, IHl; intuition_in; order.
specialize (IHr x y).
destruct (split x r); simpl in *. rewrite IHr; intuition_in; order.
Qed.

Lemma split_spec3 : forall s x `{Ok s},
((split x s)#b = true <-> InT x s).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.split_spec3".
induct s x.
intuition_in; try discriminate.
intuition.
specialize (IHl x).
destruct (split x l); simpl in *. rewrite IHl; intuition_in; order.
specialize (IHr x).
destruct (split x r); simpl in *. rewrite IHr; intuition_in; order.
Qed.

Lemma split_ok : forall s x `{Ok s}, Ok (split x s)#l /\ Ok (split x s)#r.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.split_ok".
induct s x; simpl; auto.
specialize (IHl x).
generalize (fun y => @split_spec2 l x y _).
destruct (split x l); simpl in *; intuition. apply join_ok; auto.
intros y; rewrite H; intuition.
specialize (IHr x).
generalize (fun y => @split_spec1 r x y _).
destruct (split x r); simpl in *; intuition. apply join_ok; auto.
intros y; rewrite H; intuition.
Qed.

Instance split_ok1 s x `(Ok s) : Ok (split x s)#l.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.split_ok1".   intros; destruct (@split_ok s x); auto. Qed.

Instance split_ok2 s x `(Ok s) : Ok (split x s)#r.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.split_ok2".   intros; destruct (@split_ok s x); auto. Qed.

Ltac destruct_split := match goal with
| H : split ?x ?s = << ?u, ?v, ?w >> |- _ =>
assert ((split x s)#l = u) by (rewrite H; auto);
assert ((split x s)#b = v) by (rewrite H; auto);
assert ((split x s)#r = w) by (rewrite H; auto);
clear H; subst u w
end.

Lemma inter_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.inter_spec_ok".
intros s1 s2; functional induction inter s1 s2; intros B1 B2;
[intuition_in|intuition_in | | ]; factornode s2;
destruct_split; inv;
destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *;
split; intros.
-
apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition.
-
rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
setoid_replace y with x1; auto. rewrite <- split_spec3; auto.
-
apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2;
intuition; order.
-
rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto.
intuition_in.
absurd (InT x1 s2).
rewrite <- split_spec3; auto; congruence.
setoid_replace x1 with y; auto.
Qed.

Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2},
(InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.inter_spec".   intros; destruct (@inter_spec_ok s1 s2); auto. Qed.

Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.inter_ok".   intros; destruct (@inter_spec_ok s1 s2); auto. Qed.

Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.diff_spec_ok".
intros s1 s2; functional induction diff s1 s2; intros B1 B2;
[intuition_in|intuition_in | | ]; factornode s2;
destruct_split; inv;
destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *;
split; intros.
-
apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
-
rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
absurd (InT x1 s2).
+ setoid_replace x1 with y; auto.
+ rewrite <- split_spec3; auto; congruence.
-
apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition.
-
rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *.
intuition_in.
absurd (InT x1 s2); auto.
* rewrite <- split_spec3; auto; congruence.
* setoid_replace x1 with y; auto.
Qed.

Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2},
(InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.diff_spec".   intros; destruct (@diff_spec_ok s1 s2); auto. Qed.

Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.diff_ok".   intros; destruct (@diff_spec_ok s1 s2); auto. Qed.

Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2},
(InT y (union s1 s2) <-> InT y s1 \/ InT y s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.union_spec".
intros s1 s2; functional induction union s1 s2; intros y B1 B2.
intuition_in.
intuition_in.
factornode s2; destruct_split; inv.
rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *.
destruct (X.compare_spec y x1); intuition_in.
Qed.

Instance union_ok s1 s2 : forall `(Ok s1, Ok s2), Ok (union s1 s2).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.union_ok".
functional induction union s1 s2; intros B1 B2; auto.
factornode s2; destruct_split; inv.
apply join_ok; auto with *.
intro y; rewrite union_spec, split_spec1; intuition_in.
intro y; rewrite union_spec, split_spec2; intuition_in.
Qed.

Lemma filter_spec : forall s x f,
Proper (X.eq==>Logic.eq) f ->
(InT x (filter f s) <-> InT x s /\ f x = true).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.filter_spec".
induction s as [ |h l Hl x0 r Hr]; intros x f Hf; simpl.
- intuition_in.
- case_eq (f x0); intros Hx0.
* rewrite join_spec, Hl, Hr; intuition_in.
now setoid_replace x with x0.
* rewrite concat_spec, Hl, Hr; intuition_in.
assert (f x = f x0) by auto. congruence.
Qed.

Lemma filter_weak_spec : forall s x f,
InT x (filter f s) -> InT x s.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.filter_weak_spec".
induction s as [ |h l Hl x0 r Hr]; intros x f; simpl.
- trivial.
- destruct (f x0).
* rewrite join_spec; intuition_in; eauto.
* rewrite concat_spec; intuition_in; eauto.
Qed.

Instance filter_ok s f `(H : Ok s) : Ok (filter f s).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.filter_ok".
induction H as [ | h x l r Hl Hfl Hr Hfr Hlt Hgt ].
- constructor.
- simpl.
assert (lt_tree x (filter f l)) by (eauto using filter_weak_spec).
assert (gt_tree x (filter f r)) by (eauto using filter_weak_spec).
destruct (f x); eauto using concat_ok, join_ok.
Qed.

Lemma partition_spec1' s f : (partition f s)#1 = filter f s.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.partition_spec1'".
induction s as [ | h l Hl x r Hr ]; simpl.
- trivial.
- rewrite <- Hl, <- Hr.
now destruct (partition f l), (partition f r), (f x).
Qed.

Lemma partition_spec2' s f :
(partition f s)#2 = filter (fun x => negb (f x)) s.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.partition_spec2'".
induction s as [ | h l Hl x r Hr ]; simpl.
- trivial.
- rewrite <- Hl, <- Hr.
now destruct (partition f l), (partition f r), (f x).
Qed.

Lemma partition_spec1 s f :
Proper (X.eq==>Logic.eq) f ->
Equal (partition f s)#1 (filter f s).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.partition_spec1".   now rewrite partition_spec1'. Qed.

Lemma partition_spec2 s f :
Proper (X.eq==>Logic.eq) f ->
Equal (partition f s)#2 (filter (fun x => negb (f x)) s).
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.partition_spec2".   now rewrite partition_spec2'. Qed.

Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.partition_ok1".   rewrite partition_spec1'; now apply filter_ok. Qed.

Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2.
Proof. hammer_hook "MSetAVL" "MSetAVL.MakeRaw.partition_ok2".   rewrite partition_spec2'; now apply filter_ok. Qed.

End MakeRaw.

Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
Module Raw := MakeRaw I X.
Include Raw2Sets X Raw.
End IntMake.

Module Make (X: OrderedType) <: S with Module E := X
:=IntMake(Z_as_Int)(X).


From CoqAlgs Require Export Tree.

Inductive isHeap {A : Type} (R : A -> A -> Prop) : Tree A -> Prop :=
    | isHeap_E : isHeap R E
    | isHeap_T :
        forall (v : A) (l : list (Tree A)),
          Forall (fun t : Tree A => forall x : A, Elem x t -> R v x) l ->
          Forall (isHeap R) l ->
            isHeap R (T v l).

#[global] Hint Constructors isHeap : core.

Ltac isHeap :=
repeat match goal with
    | H : isHeap _ E        |- _ => clear H
    | H : isHeap _ (T _ _)  |- _ => inv H
    | H : Forall _ []       |- _ => clear H
    | H : Forall _ (_ :: _) |- _ => inv H
    |                       |- isHeap _ E      => constructor
    |                       |- isHeap _ _ -> _ => intro
    |                       |- Forall _ _ -> _  => intro
end; auto.

Ltac isHeap' :=
repeat match goal with
    | H : isHeap _ E        |- _ => clear H
    | H : isHeap _ (T _ _)  |- _ => inv H
    | H : Forall _ []       |- _ => clear H
    | H : Forall _ (_ :: _) |- _ => inv H
    |                       |- isHeap _ E       => constructor
    |                       |- isHeap _ (T _ _) => constructor
    |                       |- Forall _ []       => constructor
    |                       |- Forall _ (_ :: _) => constructor
    |                       |- isHeap _ _ -> _  => intro
    |                       |- Forall _ _ -> _  => intro
end; eauto.

Inductive OK {A : Type} (R : A -> A -> Prop) (x : A) : Tree A -> Prop :=
    | OK_E : OK R x E
    | OK_N :
        forall (v : A) (l : list (Tree A)),
          R x v -> OK R x (T v l).

Inductive isHeap2 {A : Type} (R : A -> A -> Prop) : Tree A -> Prop :=
    | isHeap2_E : isHeap2 R E
    | isHeap2_T :
        forall (v : A) (l : list (Tree A)),
          Forall (fun t : Tree A => OK R v t) l ->
            Forall (isHeap2 R) l -> isHeap2 R (T v l).

#[global] Hint Constructors isHeap OK isHeap2 : core.

Ltac isHeap2 :=
repeat match goal with
    | H : isHeap2 _ E       |- _ => clear H
    | H : isHeap2 _ (T _ _) |- _ => inv H
    | H : Forall _ []       |- _ => clear H
    | H : Forall _ (_ :: _) |- _ => inv H
    |                       |- isHeap2 _ E      => constructor
    |                       |- isHeap2 _ _ -> _ => intro
    |                       |- Forall _ _ -> _  => intro
end; auto.

Ltac isHeap2' :=
repeat match goal with
    | H : isHeap2 _ E       |- _ => clear H
    | H : isHeap2 _ (T _ _) |- _ => inv H
    | H : Forall _ []       |- _ => clear H
    | H : Forall _ (_ :: _) |- _ => inv H
    |                       |- isHeap2 _ E       => constructor
    |                       |- isHeap2 _ (T _ _) => constructor
    |                       |- Forall _ []       => constructor
    |                       |- Forall _ (_ :: _) => constructor
    |                       |- isHeap2 _ _ -> _  => intro
    |                       |- Forall _ _ -> _  => intro
end; eauto.

Lemma isHeap_isEmpty :
  forall (A : Type) (R : A -> A -> Prop) (t : Tree A),
    isEmpty t = true -> isHeap R t.
Proof. Tree_ind. Qed.