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

In this file we introduce the type [ hq ] of rationals defined as the quotient set of [ dirprod nat nat ] by the standard equivalence relation and develop the main notions of the rational 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 "../.." .
Add LoadPath "../Generalities".

Require Export Foundations.hlevel2.hz .

Opaque hz .

(** Upstream *)

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

(** *** General definitions *)

Definition hq : fld := fldfrac hzintdom isdeceqhz .
Definition hqaddabgr : abgr := rngaddabgr hq .
Definition hqmultabmonoid : abmonoid := rngmultabmonoid hq .
Definition hqtype : UU := hq .

Definition hzhztohq : hz -> ( intdomnonzerosubmonoid hzintdom ) -> hq := fun x a => setquotpr _ ( dirprodpair x a ) .

Definition hqplus : hq -> hq -> hq := @op1 hq.
Definition hqsign : hq -> hq := grinv hqaddabgr .
Definition hqminus : hq -> hq -> hq := fun x y => hqplus x ( hqsign y ) .
Definition hqzero : hq := unel hqaddabgr .

Definition hqmult : hq -> hq -> hq := @op2 hq .
Definition hqone : hq := unel hqmultabmonoid .

Bind Scope hq_scope with hq .
Notation " x + y " := ( hqplus x y ) : hq_scope .
Notation " 0 " := hqzero : hq_scope .
Notation " 1 " := hqone : hq_scope .
Notation " - x " := ( hqsign x ) : hq_scope .
Notation " x - y " := ( hqminus x y ) : hq_scope .
Notation " x * y " := ( hqmult x y ) : hq_scope .

Delimit Scope hq_scope with hq .

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

Definition isdeceqhq : isdeceq hq := isdeceqfldfrac hzintdom isdeceqhz .

Definition isasethq := setproperty hq .

Definition hqeq ( x y : hq ) : hProp := hProppair ( paths x y ) ( isasethq _ _  )  .
Definition isdecrelhqeq : isdecrel hqeq  := fun a b => isdeceqhq a b .
Definition hqdeceq : decrel hq := decrelpair isdecrelhqeq .

(* Canonical Structure hqdeceq. *)

Definition hqbooleq := decreltobrel hqdeceq .

Definition hqneq ( x y : hq ) : hProp := hProppair ( neg ( paths x y ) ) ( isapropneg _  )  .
Definition isdecrelhqneq : isdecrel hqneq  := isdecnegrel _ isdecrelhqeq .
Definition hqdecneq : decrel hq := decrelpair isdecrelhqneq .

(* Canonical Structure hqdecneq. *)

Definition hqboolneq := decreltobrel hqdecneq .

(** Computation test *)

Open Local Scope hz_scope .

Transparent hz .

Eval lazy in ( hqbooleq ( hzhztohq ( natnattohz 4 0 ) ( tpair _ ( natnattohz 3 0 ) ( ct ( hzneq , isdecrelhzneq, ( natnattohz 3 0 ) , 0 ) ) ) )  ( hzhztohq ( natnattohz 13 1 ) ( tpair _ ( natnattohz 11 2 ) ( ct ( hzneq , isdecrelhzneq , ( natnattohz 11 2 ) , 0 ) ) ) ) ) .

Opaque hz .

(** *)

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

Open Local Scope hq_scope .

Lemma hqplusr0 ( x : hq ) : paths ( x + 0 ) x .
Proof . intro . apply ( rngrunax1 _ x ) .  Defined .

Lemma hqplusl0 ( x : hq ) : paths ( 0 + x ) x .
Proof . intro . apply ( rnglunax1 _ x ) . Defined .

Lemma hqplusassoc ( x y z : hq ) : paths ( ( x + y ) + z ) ( x + ( y + z ) ) .
Proof . intros . apply ( rngassoc1 hq x y z ) . Defined .

Lemma hqpluscomm ( x y : hq ) : paths ( x + y ) ( y + x ) .
Proof . intros .  apply ( rngcomm1 hq x y ) . Defined .

Lemma hqlminus ( x : hq ) : paths ( -x + x ) 0 .
Proof . intro. apply ( rnglinvax1 hq x ) . Defined .

Lemma hqrminus  ( x : hq ) : paths ( x - x ) 0 .
Proof . intro. apply ( rngrinvax1 hq x ) . Defined .

Lemma isinclhqplusr ( n : hq ) : isincl ( fun m : hq => m + n ) .
Proof. intro . apply ( pr2 ( weqtoincl _ _ ( weqrmultingr hqaddabgr n ) ) ) . Defined.

Lemma isinclhqplusl ( n : hq ) : isincl ( fun m : hq => n + m ) .
Proof.  intro.  apply ( pr2 ( weqtoincl _ _ ( weqlmultingr hqaddabgr n ) ) ) . Defined .

Lemma hqpluslcan ( a b c : hq ) ( is : paths ( c + a ) ( c + b ) ) : paths a b .
Proof . intros . apply ( @grlcan hqaddabgr a b c is ) .  Defined .

Lemma hqplusrcan ( a b c : hq ) ( is : paths ( a + c ) ( b + c ) ) : paths a b .
Proof . intros . apply ( @grrcan hqaddabgr a b c is ) .  Defined .

Definition hqinvmaponpathsminus { a b : hq } ( e :  paths ( - a ) ( - b ) ) : paths a b := grinvmaponpathsinv hqaddabgr e .

(** *** Proparties of multiplication on [ hq ] *)

Lemma hqmultr1 ( x : hq ) : paths ( x * 1 ) x .
Proof . intro . apply ( rngrunax2 _ x ) .  Defined .

Lemma hqmultl1 ( x : hq ) : paths ( 1 * x ) x .
Proof . intro . apply ( rnglunax2 _ x ) . Defined .

Lemma hqmult0x ( x : hq ) : paths ( 0 * x ) 0 .
Proof . intro . apply ( rngmult0x _ x ) .  Defined .

Lemma hqmultx0 ( x : hq ) : paths ( x * 0 ) 0 .
Proof . intro . apply ( rngmultx0 _ x ) . Defined .

Lemma hqmultassoc ( x y z : hq ) : paths ( ( x * y ) * z ) ( x * ( y * z ) ) .
Proof . intros . apply ( rngassoc2 hq x y z ) . Defined .

Lemma hqmultcomm ( x y : hq ) : paths ( x * y ) ( y * x ) .
Proof . intros .  apply ( rngcomm2 hq  x y ) . Defined .

(** *** Multiplicative inverse and division on [ hq ]

Note : in our definition it is possible to divide by 0 . The result in this case is 0 . *)

Definition hqmultinv : hq -> hq := fun x => fldfracmultinv0 hzintdom isdeceqhz x .

Lemma hqislinvmultinv ( x : hq ) ( ne : hqneq x 0 ) : paths ( ( hqmultinv x ) * x ) 1 .
Proof. intros .  apply ( islinvinfldfrac hzintdom isdeceqhz x ne ) . Defined .

Lemma hqisrinvmultinv ( x : hq ) ( ne : hqneq x 0 ) : paths (  x * ( hqmultinv x ) ) 1 .
Proof. intros .  apply ( isrinvinfldfrac hzintdom isdeceqhz x ne ) . Defined .

Definition hqdiv ( x y : hq ) : hq := hqmult x ( hqmultinv y ) .

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

(** *** Definitions and notations *)

Definition hqgth : hrel hq := fldfracgt hzintdom isdeceqhz isplushrelhzgth isrngmulthzgth ( ct ( hzgth , isdecrelhzgth,  1%hz , 0%hz ) ) hzneqchoice .

Definition hqlth : hrel hq := fun a b => hqgth b a .

Definition hqleh : hrel hq := fun a b => hProppair ( neg ( hqgth a b ) ) ( isapropneg _ )  .

Definition hqgeh : hrel hq := fun a b => hProppair ( neg ( hqgth b a ) ) ( isapropneg _ )  .

(** *** Decidability *)

Lemma isdecrelhqgth : isdecrel hqgth .
Proof . apply isdecfldfracgt . exact isasymmhzgth .   apply isdecrelhzgth . Defined .

Definition hqgthdec := decrelpair isdecrelhqgth .

(* Canonical Structure hqgthdec . *)

Definition isdecrelhqlth : isdecrel hqlth := fun x x' => isdecrelhqgth x' x .

Definition hqlthdec := decrelpair isdecrelhqlth .

(* Canonical Structure hqlthdec . *)

Definition isdecrelhqleh : isdecrel hqleh := isdecnegrel _ isdecrelhqgth .

Definition hqlehdec := decrelpair isdecrelhqleh .

(* Canonical Structure hqlehdec . *)

Definition isdecrelhqgeh : isdecrel hqgeh := fun x x' => isdecrelhqleh x' x .

Definition hqgehdec := decrelpair isdecrelhqgeh .

(* Canonical Structure hqgehdec . *)

(** Computation test *)

Transparent hz .

Eval lazy in ( decreltobrel hqgthdec ( hzhztohq ( natnattohz 5 0 ) ( tpair _ ( natnattohz 3 0 ) ( ct ( hzneq , isdecrelhzneq , ( natnattohz 3 0 ) , hzzero ) ) ) )  ( hzhztohq ( natnattohz 13 1 ) ( tpair _ ( natnattohz 11 2 ) ( ct ( hzneq , isdecrelhzneq , ( natnattohz 11 2 ) , hzzero ) ) ) ) ) .

Opaque hz .

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

(** [ hqgth ] *)

Lemma istranshqgth ( n m k : hq ) : hqgth n m -> hqgth m k -> hqgth n k .
Proof. apply istransfldfracgt . exact istranshzgth .  Defined .

Lemma isirreflhqgth ( n : hq ) : neg ( hqgth n n ) .
Proof. apply isirreflfldfracgt . exact isirreflhzgth .   Defined .

Lemma isasymmhqgth ( n m : hq ) : hqgth n m -> hqgth m n -> empty .
Proof. apply isasymmfldfracgt .  exact isasymmhzgth .  Defined .

Lemma isantisymmneghqgth ( n m : hq ) : neg ( hqgth n m ) -> neg ( hqgth m n ) -> paths n m .
Proof . apply isantisymmnegfldfracgt . exact isirreflhzgth . exact isantisymmneghzgth .   Defined .

Lemma isnegrelhqgth : isnegrel hqgth .
Proof . apply isdecreltoisnegrel . apply isdecrelhqgth . Defined .

Lemma iscoantisymmhqgth ( n m : hq ) : neg ( hqgth n m ) -> coprod ( hqgth m n ) ( paths n m ) .
Proof . apply isantisymmnegtoiscoantisymm . apply isdecrelhqgth .  intros n m . apply isantisymmneghqgth . Defined .

Lemma iscotranshqgth ( n m k : hq ) : hqgth n k -> hdisj ( hqgth n m ) ( hqgth m k ) .
Proof . intros x y z gxz .  destruct ( isdecrelhqgth x y ) as [ gxy | ngxy ] . apply ( hinhpr _ ( ii1 gxy ) ) . apply hinhpr .   apply ii2 .  destruct ( isdecrelhqgth y x ) as [ gyx | ngyx ] . apply ( istranshqgth _ _ _ gyx gxz ) .  set ( e := isantisymmneghqgth _ _ ngxy ngyx ) . rewrite e in gxz .  apply gxz .  Defined .

(** [ hqlth ] *)

Definition istranshqlth ( n m k  : hq ) : hqlth n m -> hqlth m k -> hqlth n k := fun lnm lmk => istranshqgth _ _ _ lmk lnm .

Definition isirreflhqlth ( n : hq ) : neg ( hqlth n n ) := isirreflhqgth n .

Definition isasymmhqlth ( n m : hq ) : hqlth n m -> hqlth m n -> empty := fun lnm lmn => isasymmhqgth _ _ lmn lnm .

Definition isantisymmneghqtth  ( n m : hq ) : neg ( hqlth n m ) -> neg ( hqlth m n ) -> paths n m := fun nlnm nlmn => isantisymmneghqgth _ _ nlmn nlnm .

Definition isnegrelhqlth : isnegrel hqlth := fun n m => isnegrelhqgth m n .

Definition iscoantisymmhqlth ( n m : hq ) : neg ( hqlth n m ) -> coprod ( hqlth m n ) ( paths n m ) .
Proof . intros n m nlnm . destruct ( iscoantisymmhqgth m n nlnm ) as [ l | e ] . apply ( ii1 l ) . apply ( ii2 ( pathsinv0 e ) ) . Defined .

Definition iscotranshqlth ( n m k : hq ) : hqlth n k -> hdisj ( hqlth n m ) ( hqlth m k ) .
Proof . intros n m k lnk . apply ( ( pr1 islogeqcommhdisj ) ( iscotranshqgth _ _ _ lnk ) )  .  Defined .

(**  [ hqleh ] *)

Definition  istranshqleh ( n m k : hq ) : hqleh n m -> hqleh m k -> hqleh n k .
Proof. apply istransnegrel . unfold iscotrans. apply iscotranshqgth .  Defined.

Definition isreflhqleh ( n : hq ) : hqleh n n := isirreflhqgth n .

Definition isantisymmhqleh ( n m : hq ) : hqleh n m -> hqleh m n -> paths n m := isantisymmneghqgth n m .

Definition isnegrelhqleh : isnegrel hqleh .
Proof . apply isdecreltoisnegrel . apply isdecrelhqleh . Defined .

Definition iscoasymmhqleh ( n m : hq ) ( nl : neg ( hqleh n m ) ) : hqleh m n := negf ( isasymmhqgth _ _ ) nl .

Definition istotalhqleh : istotal hqleh .
Proof . intros x y . destruct ( isdecrelhqleh x y ) as [ lxy | lyx ] . apply ( hinhpr _ ( ii1 lxy ) ) . apply hinhpr .   apply ii2 . apply ( iscoasymmhqleh _ _ lyx ) .   Defined .

(**  [ hqgeh ] . *)

Definition istranshqgeh ( n m k : hq ) : hqgeh n m -> hqgeh m k -> hqgeh n k := fun gnm gmk => istranshqleh _ _ _ gmk gnm .

Definition isreflhqgeh ( n : hq ) : hqgeh n n := isreflhqleh _ .

Definition isantisymmhqgeh ( n m : hq ) : hqgeh n m -> hqgeh m n -> paths n m := fun gnm gmn => isantisymmhqleh _ _ gmn gnm .

Definition isnegrelhqgeh : isnegrel hqgeh := fun n m => isnegrelhqleh m n .

Definition iscoasymmhqgeh ( n m : hq ) ( nl : neg ( hqgeh n m ) ) : hqgeh m n := iscoasymmhqleh _ _ nl .

Definition istotalhqgeh : istotal hqgeh := fun n m => istotalhqleh m n .

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

Definition hqgthtogeh ( n m : hq ) : hqgth n m -> hqgeh n m .
Proof. intros n m g . apply iscoasymmhqgeh . apply ( todneg _ g ) . Defined .

Definition hqlthtoleh ( n m : hq ) : hqlth n m -> hqleh n m := hqgthtogeh _ _ .

Definition hqlehtoneghqgth ( n m : hq ) : hqleh n m -> neg ( hqgth n m )  .
Proof. intros n m is is' . apply ( is is' ) .  Defined .

Definition  hqgthtoneghqleh ( n m : hq ) : hqgth n m -> neg ( hqleh n m ) := fun g l  => hqlehtoneghqgth _ _ l g .

Definition hqgehtoneghqlth ( n m : hq ) : hqgeh n m -> neg ( hqlth n m ) := fun gnm lnm => hqlehtoneghqgth _ _ gnm lnm .

Definition hqlthtoneghqgeh ( n m : hq ) : hqlth n m -> neg ( hqgeh n m ) := fun gnm lnm => hqlehtoneghqgth _ _ lnm gnm .

Definition neghqlehtogth ( n m : hq ) : neg ( hqleh n m ) -> hqgth n m := isnegrelhqgth n m .

Definition neghqgehtolth ( n m : hq ) : neg ( hqgeh n m ) -> hqlth n m := isnegrelhqlth n m .

Definition neghqgthtoleh ( n m : hq ) : neg ( hqgth n m ) -> hqleh n m .
Proof . intros n m ng . destruct ( isdecrelhqleh n m ) as [ l | nl ] . apply l . destruct ( nl ng ) .  Defined .

Definition neghqlthtogeh ( n m : hq ) : neg ( hqlth n m ) -> hqgeh n m := fun nl => neghqgthtoleh _ _ nl .

(** *** Comparison alternatives *)

Definition hqgthorleh ( n m : hq ) : coprod ( hqgth n m ) ( hqleh n m ) .
Proof . intros . apply ( isdecrelhqgth n m ) .  Defined .

Definition hqlthorgeh ( n m : hq ) : coprod ( hqlth n m ) ( hqgeh n m ) := hqgthorleh _ _ .

Definition hqneqchoice ( n m : hq ) ( ne : neg ( paths n m ) ) : coprod ( hqgth n m ) ( hqlth n m ) .
Proof . intros . destruct ( hqgthorleh n m ) as [ g | l ]  .  destruct ( hqlthorgeh n m ) as [ g' | l' ] . destruct ( isasymmhqgth _ _ g g' )  .  apply ( ii1 g ) . destruct ( hqlthorgeh n m ) as [ l' | g' ] . apply ( ii2 l' ) . destruct ( ne ( isantisymmhqleh _ _ l g' ) ) . Defined .

Definition hqlehchoice ( n m : hq ) ( l : hqleh n m ) : coprod ( hqlth n m ) ( paths n m ) .
Proof .  intros . destruct ( hqlthorgeh n m ) as [ l' | g ] .   apply ( ii1 l' ) . apply ( ii2 ( isantisymmhqleh _ _ l g ) ) . Defined .

Definition hqgehchoice ( n m : hq ) ( g : hqgeh n m ) : coprod ( hqgth n m ) ( paths n m ) .
Proof .  intros . destruct ( hqgthorleh n m ) as [ g' | l ] .  apply ( ii1 g' ) .  apply ( ii2 ( isantisymmhqleh _ _ l g ) ) .  Defined .

(** *** Mixed transitivities *)

Lemma hqgthgehtrans ( n m k : hq ) : hqgth n m -> hqgeh m k -> hqgth n k .
Proof. intros n m k gnm gmk . destruct ( hqgehchoice m k gmk ) as [ g' | e ] . apply ( istranshqgth _ _ _ gnm g' ) .  rewrite e in gnm  .  apply gnm . Defined.

Lemma hqgehgthtrans ( n m k : hq ) : hqgeh n m -> hqgth m k -> hqgth n k .
Proof. intros n m k gnm gmk . destruct ( hqgehchoice n m gnm ) as [ g' | e ] . apply ( istranshqgth _ _ _ g' gmk ) .  rewrite e .  apply gmk . Defined.

Lemma hqlthlehtrans ( n m k : hq ) : hqlth n m -> hqleh m k -> hqlth n k .
Proof . intros n m k l1 l2 . apply ( hqgehgthtrans k m n l2 l1 ) . Defined .

Lemma hqlehlthtrans ( n m k : hq ) : hqleh n m -> hqlth m k -> hqlth n k .
Proof . intros n m k l1 l2 . apply ( hqgthgehtrans k m n l2 l1 ) . Defined .

(** *** Addition and comparisons  *)

(** [ gth ] *)

Definition isrngaddhzgth : @isbinophrel hqaddabgr hqgth .
Proof . apply isrngaddfldfracgt . exact isirreflhzgth . Defined .

Definition hqgthandplusl ( n m k : hq ) : hqgth n m -> hqgth ( k + n ) ( k + m ) := fun g => ( pr1 isrngaddhzgth ) n m k g .

Definition hqgthandplusr ( n m k : hq ) : hqgth n m -> hqgth ( n + k ) ( m + k ) := fun g => ( pr2 isrngaddhzgth ) n m k g .

Definition hqgthandpluslinv  ( n m k : hq ) : hqgth ( k + n ) ( k + m ) -> hqgth n m  .
Proof. intros n m k g . set ( g' := hqgthandplusl _ _ ( - k ) g ) . clearbody g' . rewrite ( pathsinv0 ( hqplusassoc _ _ n ) ) in g' . rewrite ( pathsinv0 ( hqplusassoc _ _ m ) ) in g' .  rewrite ( hqlminus k ) in g' . rewrite ( hqplusl0 _ ) in g' .   rewrite ( hqplusl0 _ ) in g' . apply g' .  Defined .

Definition hqgthandplusrinv ( n m k : hq ) :  hqgth ( n + k ) ( m + k ) -> hqgth n m  .
Proof. intros n m k l . rewrite ( hqpluscomm n k ) in l . rewrite ( hqpluscomm m k ) in l . apply ( hqgthandpluslinv _ _ _ l )  . Defined .

Lemma hqgthsnn ( n : hq ) : hqgth ( n + 1 ) n .
Proof . intro . set ( int := hqgthandplusl _ _ n ( ct ( hqgth , isdecrelhqgth , 1 , 0 ) ) ) . clearbody int . rewrite ( hqplusr0 n ) in int .   apply int . Defined .

(** [ lth ] *)

Definition hqlthandplusl ( n m k : hq ) : hqlth n m -> hqlth ( k + n ) ( k + m )  := hqgthandplusl _ _ _ .

Definition hqlthandplusr ( n m k : hq ) : hqlth n m -> hqlth ( n + k ) ( m + k ) := hqgthandplusr _ _ _ .

Definition hqlthandpluslinv  ( n m k : hq ) : hqlth ( k + n ) ( k + m ) -> hqlth n m := hqgthandpluslinv _ _ _ .

Definition hqlthandplusrinv ( n m k : hq ) :  hqlth ( n + k ) ( m + k ) -> hqlth n m := hqgthandplusrinv _ _ _ .

Definition hqlthnsn ( n : hq ) : hqlth n ( n + 1 ) := hqgthsnn n .

(** [ leh ] *)

Definition hqlehandplusl ( n m k : hq ) : hqleh n m -> hqleh ( k + n ) ( k + m ) := negf ( hqgthandpluslinv n m k )  .

Definition hqlehandplusr ( n m k : hq ) : hqleh n m -> hqleh ( n + k ) ( m + k ) := negf ( hqgthandplusrinv n m k )  .

Definition hqlehandpluslinv  ( n m k : hq ) : hqleh ( k + n ) ( k + m ) -> hqleh n m := negf ( hqgthandplusl n m k )  .

Definition hqlehandplusrinv ( n m k : hq ) :  hqleh ( n + k ) ( m + k ) -> hqleh n m :=  negf ( hqgthandplusr n m k ) .

(** [ geh ] *)

Definition hqgehandplusl ( n m k : hq ) : hqgeh n m -> hqgeh ( k + n ) ( k + m ) := negf ( hqgthandpluslinv m n k ) .

Definition hqgehandplusr ( n m k : hq ) : hqgeh n m -> hqgeh ( n + k ) ( m + k ) := negf ( hqgthandplusrinv m n k )  .

Definition hqgehandpluslinv  ( n m k : hq ) : hqgeh ( k + n ) ( k + m ) -> hqgeh n m := negf ( hqgthandplusl m n k )  .

Definition hqgehandplusrinv ( n m k : hq ) :  hqgeh ( n + k ) ( m + k ) -> hqgeh n m :=  negf ( hqgthandplusr m n k ) .

(** *** Properties of [ hqgth ] in the terminology of  algebra1.v *)

Definition isplushrelhqgth : @isbinophrel hqaddabgr hqgth := isrngaddhzgth .

Lemma isinvplushrelhqgth : @isinvbinophrel hqaddabgr hqgth .
Proof . split . apply  hqgthandpluslinv .  apply hqgthandplusrinv .  Defined .

Lemma isrngmulthqgth : isrngmultgt _ hqgth .
Proof . apply  isrngmultfldfracgt .  exact isirreflhzgth .  Defined .

Lemma  isinvrngmulthqgth : isinvrngmultgt _ hqgth .
Proof . apply isinvrngmultgtif .  apply isplushrelhqgth .  apply isrngmulthqgth . exact hqneqchoice . exact isasymmhqgth . Defined .

(** *** Negation and comparisons *)

(** [ hqgth ] *)

Lemma hqgth0andminus { n : hq } ( is : hqgth n 0 ) : hqlth ( - n ) 0 .
Proof . intros . unfold hqlth . apply ( rngfromgt0 hq isplushrelhqgth is ) .  Defined .

Lemma hqminusandgth0 { n : hq } ( is : hqgth ( - n ) 0 ) : hqlth n 0 .
Proof . intros . unfold hqlth . apply ( rngtolt0 hq isplushrelhqgth is ) .  Defined .

(** [ hqlth ] *)

Lemma hqlth0andminus { n : hq } ( is : hqlth n 0 ) : hqgth ( - n ) 0 .
Proof . intros .  unfold hqlth . apply ( rngfromlt0 hq isplushrelhqgth is ) .  Defined .

Lemma hqminusandlth0 { n : hq } ( is : hqlth ( - n ) 0 ) : hqgth n 0 .
Proof . intros . unfold hqlth . apply ( rngtogt0 hq isplushrelhqgth is ) .  Defined .

(* ??? Coq slows down for no good reason at Defined in the previous four lemmas. *)

(** [ hqleh ] *)

Lemma hqleh0andminus { n : hq } ( is : hqleh n 0 ) : hqgeh ( - n ) 0 .
Proof . intro n . apply ( negf ( @hqminusandlth0 n ) ) . Defined .

Lemma hqminusandleh0 { n : hq } ( is : hqleh ( - n ) 0 ) : hqgeh n 0 .
Proof . intro n . apply ( negf ( @hqlth0andminus n ) ) . Defined .

(** [ hqgeh ] *)

Lemma hqgeh0andminus { n : hq } ( is : hqgeh n 0 ) : hqleh ( - n ) 0 .
Proof . intro n . apply ( negf ( @hqminusandgth0 n ) ) . Defined .

Lemma hqminusandgeh0 { n : hq } ( is : hqgeh ( - n ) 0 ) : hqleh n 0 .
Proof . intro n . apply ( negf ( @hqgth0andminus n ) ) . Defined .

(** *** Multiplication and comparisons  *)

(** [ gth ] *)

Definition hqgthandmultl ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth n m -> hqgth ( k * n ) ( k * m ) .
Proof. apply ( isrngmultgttoislrngmultgt _ isplushrelhqgth isrngmulthqgth ) .   Defined .

Definition hqgthandmultr ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth n m -> hqgth ( n * k ) ( m * k )  .
Proof . apply ( isrngmultgttoisrrngmultgt _ isplushrelhqgth isrngmulthqgth ) . Defined .

Definition  hqgthandmultlinv ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth ( k * n ) ( k * m ) -> hqgth n m .
Proof . intros n m k is is' .  apply ( isinvrngmultgttoislinvrngmultgt hq isplushrelhqgth isinvrngmulthqgth n m k is is' ) .  Defined .

Definition hqgthandmultrinv ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth ( n * k ) ( m * k ) -> hqgth n m .
Proof.   intros n m k is is' .  apply ( isinvrngmultgttoisrinvrngmultgt hq isplushrelhqgth isinvrngmulthqgth n m k is is' ) .  Defined .

(** [ lth ] *)

Definition hqlthandmultl ( n m k : hq ) ( is : hqgth k 0 ) : hqlth n m -> hqlth ( k * n ) ( k * m )  := hqgthandmultl _ _ _ is .

Definition hqlthandmultr ( n m k : hq ) ( is : hqgth k 0 ) : hqlth n m -> hqlth ( n * k ) ( m * k ) := hqgthandmultr _ _ _ is .

Definition hqlthandmultlinv ( n m k : hq ) ( is : hqgth k 0 ) : hqlth ( k * n ) ( k * m ) -> hqlth n m := hqgthandmultlinv _ _ _ is .

Definition hqlthandmultrinv ( n m k : hq ) ( is : hqgth k 0 ) : hqlth ( n * k ) ( m * k ) -> hqlth n m := hqgthandmultrinv _ _ _ is .

(** [ leh ] *)

Definition hqlehandmultl ( n m k : hq ) ( is : hqgth k 0 ) : hqleh n m -> hqleh ( k * n ) ( k * m ) := negf ( hqgthandmultlinv _ _ _ is ) .

Definition hqlehandmultr ( n m k : hq ) ( is : hqgth k 0 ) : hqleh n m -> hqleh ( n * k ) ( m * k ) := negf ( hqgthandmultrinv _ _ _ is ) .

Definition hqlehandmultlinv ( n m k : hq ) ( is : hqgth k 0 ) : hqleh ( k * n ) ( k * m ) -> hqleh n m := negf ( hqgthandmultl _ _ _ is )  .

Definition hqlehandmultrinv ( n m k : hq ) ( is : hqgth k 0 ) : hqleh ( n * k ) ( m * k ) -> hqleh n m := negf ( hqgthandmultr _ _ _ is ) .

(** [ geh ] *)

Definition hqgehandmultl ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh n m -> hqgeh ( k * n ) ( k * m ) := negf ( hqgthandmultlinv _ _ _ is ) .

Definition hqgehandmultr ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh n m -> hqgeh ( n * k ) ( m * k )  := negf ( hqgthandmultrinv _ _ _ is ) .

Definition hqgehandmultlinv ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh ( k * n ) ( k * m ) -> hqgeh n m := negf ( hqgthandmultl _ _ _ is )   .

Definition hqgehandmultrinv ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh ( n * k ) ( m * k ) -> hqgeh n m := negf ( hqgthandmultr _ _ _ is )  .

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

Lemma hqmultgth0gth0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqgth n 0 ) : hqgth ( m * n ) 0 .
Proof . intros . apply isrngmulthqgth . apply ism . apply isn . Defined .

Lemma hqmultgth0geh0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqgeh n 0 ) : hqgeh ( m * n ) 0 .
Proof . intros .  destruct ( hqgehchoice _ _ isn ) as [ gn | en ] .

apply ( hqgthtogeh _ _ ( hqmultgth0gth0  ism gn ) ) .

rewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined .

Lemma hqmultgeh0gth0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqgth n 0 ) : hqgeh ( m * n ) 0 .
Proof .  intros .  destruct ( hqgehchoice _ _ ism ) as [ gm | em ] .

apply ( hqgthtogeh _ _ ( hqmultgth0gth0 gm isn ) ) .

rewrite em .  rewrite ( hqmult0x _ ) . apply isreflhqgeh . Defined .

Lemma hqmultgeh0geh0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqgeh n 0 ) : hqgeh ( m * n ) 0 .
Proof . intros .   destruct ( hqgehchoice _ _ isn ) as [ gn | en ] .

apply ( hqmultgeh0gth0 ism gn ) .

rewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined .

Lemma hqmultgth0lth0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqlth n 0 ) : hqlth ( m * n ) 0 .
Proof . intros . apply ( rngmultgt0lt0 hq isplushrelhqgth isrngmulthqgth ) . apply ism . apply isn . Defined .

Lemma hqmultgth0leh0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqleh n 0 ) : hqleh ( m * n ) 0 .
Proof . intros .  destruct ( hqlehchoice _ _ isn ) as [ ln | en ] .

apply ( hqlthtoleh _ _ ( hqmultgth0lth0  ism ln ) ) .

rewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqleh . Defined .

Lemma hqmultgeh0lth0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqlth n 0 ) : hqleh ( m * n ) 0 .
Proof .  intros .  destruct ( hqlehchoice _ _ ism ) as [ lm | em ] .

apply ( hqlthtoleh _ _ ( hqmultgth0lth0 lm isn ) ) .

destruct em .  rewrite ( hqmult0x _ ) . apply isreflhqleh . Defined .

Lemma hqmultgeh0leh0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqleh n 0 ) : hqleh ( m * n ) 0 .
Proof . intros .   destruct ( hqlehchoice _ _ isn ) as [ ln | en ] .

apply ( hqmultgeh0lth0 ism ln ) .

rewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqleh . Defined .

Lemma hqmultlth0gth0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqgth n 0 ) : hqlth ( m * n ) 0 .
Proof . intros . rewrite ( hqmultcomm ) .  apply hqmultgth0lth0 . apply isn . apply ism .  Defined .

Lemma hqmultlth0geh0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqgeh n 0 ) : hqleh ( m * n ) 0 .
Proof . intros . rewrite ( hqmultcomm ) .  apply hqmultgeh0lth0 . apply isn . apply ism .  Defined .

Lemma hqmultleh0gth0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqgth n 0 ) : hqleh ( m * n ) 0 .
Proof . intros . rewrite ( hqmultcomm ) .  apply hqmultgth0leh0 . apply isn . apply ism .  Defined .

Lemma hqmultleh0geh0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqgeh n 0 ) : hqleh ( m * n ) 0 .
Proof . intros . rewrite ( hqmultcomm ) .  apply hqmultgeh0leh0 . apply isn . apply ism .  Defined .

Lemma hqmultlth0lth0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqlth n 0 ) : hqgth ( m * n ) 0 .
Proof . intros . assert ( ism' := hqlth0andminus ism ) .  assert ( isn' := hqlth0andminus isn ) . assert ( int := isrngmulthqgth _ _ ism' isn' ) . rewrite ( rngmultminusminus hq ) in int .  apply int . Defined .

Lemma hqmultlth0leh0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqleh n 0 ) : hqgeh ( m * n ) 0 .
Proof . intros . intros .  destruct ( hqlehchoice _ _ isn ) as [ ln | en ] .

apply ( hqgthtogeh _ _ ( hqmultlth0lth0  ism ln ) ) .

rewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined .

Lemma hqmultleh0lth0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqlth n 0 ) : hqgeh ( m * n ) 0 .
Proof . intros . destruct ( hqlehchoice _ _ ism ) as [ lm | em ] .

apply ( hqgthtogeh _ _ ( hqmultlth0lth0 lm isn ) ) .

rewrite em .  rewrite ( hqmult0x _ ) . apply isreflhqgeh .  Defined .

Lemma hqmultleh0leh0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqleh n 0 ) : hqgeh ( m * n ) 0 .
Proof . intros .  destruct ( hqlehchoice _ _ isn ) as [ ln | en ] .

apply ( hqmultleh0lth0 ism ln ) .

rewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqgeh .   Defined .

(** *** Cancellation properties of multiplication on [ hq ] *)

Lemma hqmultlcan ( a b c : hq ) ( ne : neg ( paths c 0 ) ) ( e : paths ( c * a ) ( c * b ) ) : paths a b .
Proof . intros . apply ( intdomlcan hq _ _ _ ne e ) . Defined .

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

(** *** Positive rationals *)

Definition hqpos : @subabmonoids hqmultabmonoid .
Proof . split with ( fun x => hqgth x 0 ) . split .  intros x1 x2 . apply ( isrngmulthqgth ) . apply ( pr2 x1 ) .  apply ( pr2 x2 ) .  apply ( ct ( hqgth , isdecrelhqgth , 1 , 0 ) ) . Defined .

(** *** Canonical ring homomorphism from [ hz ] to [ hq ] *)

Definition hztohq : hz -> hq := tofldfrac hzintdom isdeceqhz.

Definition isinclhztohq : isincl hztohq := isincltofldfrac hzintdom isdeceqhz .

Definition hztohqandneq ( n m : hz ) ( is : hzneq n m ) : hqneq ( hztohq n ) ( hztohq m ) := negf ( invmaponpathsincl _ isinclhztohq n m ) is .

Definition hztohqand0 : paths ( hztohq 0%hz ) 0 := idpath _ .

Definition hztohqand1 : paths ( hztohq 1%hz ) 1 := idpath _ .

Definition hztohqandplus ( n m : hz ) : paths ( hztohq ( n + m )%hz ) ( hztohq n + hztohq m ) := isbinop1funtofldfrac hzintdom isdeceqhz n m .

Definition hztohqandminus ( n m : hz ) : paths ( hztohq ( n - m )%hz ) ( hztohq n - hztohq m ) := tofldfracandminus hzintdom isdeceqhz n m .

Definition hztohqandmult ( n m : hz ) : paths ( hztohq ( n * m )%hz ) ( hztohq n * hztohq m ) := isbinop2funtofldfrac hzintdom isdeceqhz n m .

Definition hztohqandgth ( n m : hz ) ( is : hzgth n m ) : hqgth ( hztohq n ) ( hztohq m ) := iscomptofldfrac hzintdom isdeceqhz isplushrelhzgth isrngmulthzgth ( ct ( hzgth , isdecrelhzgth , 1 , 0 )%hz ) ( hzneqchoice ) ( isasymmhzgth ) n m is .

Definition hztohqandlth ( n m : hz ) ( is : hzlth n m ) : hqlth ( hztohq n ) ( hztohq m ) := hztohqandgth m n is .

Definition hztohqandleh ( n m : hz ) ( is : hzleh n m ) : hqleh ( hztohq n ) ( hztohq m ) .
Proof . intros . destruct ( hzlehchoice _ _ is ) as [ l | e ] .   apply ( hqlthtoleh _ _ ( hztohqandlth _ _ l ) ) .  rewrite e .  apply ( isreflhqleh ) .  Defined .

Definition hztohqandgeh ( n m : hz ) ( is : hzgeh n m ) : hqgeh ( hztohq n ) ( hztohq m ) := hztohqandleh _ _ is .

(** *** Integral part of a rational *)

Definition intpartint0 ( xa : dirprod hz ( intdomnonzerosubmonoid hzintdom ) ) : nat := natdiv ( hzabsval (pr1 xa ) ) ( hzabsval ( pr1 ( pr2 xa ) ) )  .

Lemma iscompintpartint0 : iscomprelfun ( eqrelabmonoidfrac hzmultabmonoid ( intdomnonzerosubmonoid hzintdom ) ) intpartint0 .
Proof . Opaque hq.  unfold iscomprelfun .  intros xa1 xa2 .  set ( x1 := pr1 xa1 ) . set ( aa1 := pr2 xa1 ) . set ( a1 := pr1 aa1 ) .  set ( x2 := pr1 xa2 ) . set ( aa2 := pr2 xa2 ) . set ( a2 := pr1 aa2 ) . simpl .  apply ( @hinhuniv _ ( hProppair _ ( setproperty natset _ _ ) ) ) .  intro t2 .  assert ( e := pr2 t2 ) .

simpl in e .  assert ( e' := ( maponpaths hzabsval ( hzmultrcan _ _ _ ( pr2 ( pr1 t2 ) ) e ) ) : paths ( hzabsval ( x1 * a2 )%hz ) ( hzabsval ( x2 * a1 )%hz ) ) .  clear e . clear t2 . rewrite ( pathsinv0 ( hzabsvalandmult _ _ ) ) in e' . rewrite ( pathsinv0 ( hzabsvalandmult _ _ ) ) in e' .

unfold intpartint0 . simpl .  change ( paths ( natdiv ( hzabsval x1 ) ( hzabsval a1 ) ) ( natdiv ( hzabsval x2 ) ( hzabsval a2 ) ) ) . rewrite ( pathsinv0 ( natdivandmultr (hzabsval x1 ) (hzabsval a1 ) ( hzabsval a2 ) ( hzabsvalneq0  ( pr2 aa1 ) ) ( natneq0andmult _ _ ( hzabsvalneq0 (pr2 aa1) ) ( hzabsvalneq0  (pr2 aa2) ) ) ) ) .   rewrite ( pathsinv0 ( natdivandmultr (hzabsval x2 ) (hzabsval a2 ) ( hzabsval a1 ) ( hzabsvalneq0  ( pr2 aa2 ) ) ( natneq0andmult _ _ ( hzabsvalneq0 (pr2 aa2) ) ( hzabsvalneq0  (pr2 aa1) ) ) ) ) .  rewrite ( natmultcomm ( hzabsval a1 ) ( hzabsval a2 ) ) .  rewrite e' . apply idpath . Transparent hq .  Defined .

Opaque iscompintpartint0 .

Definition intpart0 : hq -> nat := setquotuniv ( eqrelabmonoidfrac hzmultabmonoid (intdomnonzerosubmonoid hzintdom) ) natset _
     ( iscompintpartint0 ) .

Definition intpart ( x : hq ) : hz .
Proof . intro . destruct ( hqlthorgeh x 0 ) as [ l | ge ] .  destruct ( isdeceqhq ( x + ( hztohq ( nattohz ( intpart0 x ) ) ) ) 0 ) as [ e | ne ] .

apply ( - (nattohz (intpart0 x)))%hz .

apply ( - ( 1 + (nattohz (intpart0 x)) ) )%hz .

apply (nattohz (intpart0 x)) . Defined .

(** Computation test *)

Transparent hz .

Eval lazy in ( hzabsval ( intpart ( hqdiv ( hztohq ( nattohz ( 10 ) ) )  ( - ( 1 + 1 + 1 ) ) ) ) ) .

Opaque hz .

(* End of the file hq.v *)


(** * 6.887 Formal Reasoning About Programs - Lab 3
    * Model Checking, including abstraction *)

Require Import Frap.

Set Implicit Arguments.

(* Authors: Peng Wang (wangpeng@csail.mit.edu), Adam Chlipala (adamc@csail.mit.edu) *)

(* Examples based on ideas introduced in ModelChecking.v, from the book source.
 * Key definitions about model checking are imported from the Frap library. *)

(* Use model checking to verify the following program
 * against the property that j==3 when the program finishes.

  <<
  int i = 0;
  int j = 0;

  void foo() {
    while (i <= 2){
      ++i;
      ++j;
    }
  }
  >>
*)

(* CHALLENGE #1: We've made a small mistake in formalizing this program as a
 * transition system.  Correct the mistake.  (Otherwise, the program will not,
 * in fact, satisfy the spec!) *)

Inductive pc :=
| Loop
| i_add_1
| j_add_1
| Done.

Record vars := {
  I : nat;
  J : nat
}.

Record state := {
  Pc : pc;
  Vars : vars
}.

Definition foo_init := { {| Pc := Loop; Vars := {| I := 0; J := 0 |} |} }.

Inductive step : state -> state -> Prop :=
| Step_Loop_done : forall i j,
    step {| Pc := Loop; Vars := {| I := i;
                                   J := j |} |}
         {| Pc := Done; Vars := {| I := i;
                                   J := j |} |}
| Step_Loop_enter : forall i j,
    step {| Pc := Loop; Vars := {| I := i;
                                   J := j |} |}
         {| Pc := i_add_1; Vars := {| I := i;
                                      J := j |} |}
| Step_i_add_1 : forall i j,
    step {| Pc := i_add_1; Vars := {| I := i;
                                      J := j |} |}
         {| Pc := j_add_1; Vars := {| I := 1 + i;
                                      J := j |} |}
| Step_j_add_1 : forall i j,
    step {| Pc := j_add_1; Vars := {| I := i;
                                      J := j |} |}
         {| Pc := Loop; Vars := {| I := i;
                                   J := 1 + j |} |}.

Definition foo_sys := {|
  Initial := foo_init;
  Step := step
|}.

Definition foo_correct (st : state) :=
  st.(Pc) = Done -> st.(Vars).(J) = 3.

(* A hint to help the model checker, related to when to unfold definitions *)
Arguments foo_correct / .

(* CHALLENGE #2: Prove the system correct.
 * WARNING: with the broken system above, the model checker is likely to run for
 * intractably long!  However, when you fix the system definition, this should
 * be a very easy proof, thanks to the magic of automatic state-space
 * exploration. *)
Theorem foo_ok :
  invariantFor foo_sys foo_correct.
Proof.
Admitted.

(* Next, we'll look at verifying the following two-thread producer/consumer
 * program against the property that MIN <= x <= MAX always holds.

  <<
  x = MIN;

  void producer(){
    while(true){
      lock();
      if (x < MAX) {
        ++x;
      }
      unlock();
    }
  }

  void consumer(){
    while(true){
      lock();
      if (x > MIN) {
        --x;
      }
      unlock();
    }
  }
  >>
*)

(* Here's our formal encoding of the system, which this time you can trust to be
 * correct. *)

Notation num := nat.

Section prco.
  (* We use sections and variables to introduce local, unknown parameters. *)
  Variable MIN : num.
  Variable MAX : num.

  Record shared_state val := { Locked : bool; X : val }.

  Inductive producer_pc :=
  | PrLock
  | PrTest
  | PrInc
  | PrUnlock.

  Definition producer_state := threaded_state (shared_state num) producer_pc.

  Definition producer_init := { {| Shared := {| Locked := false; X := MIN |};
                                   Private := PrLock |} }.

  Inductive producer_step : producer_state -> producer_state -> Prop :=
  | PrStep_Lock : forall x,
      producer_step {| Shared := {| Locked := false; X := x|}; Private := PrLock |}
                    {| Shared := {| Locked := true; X := x|}; Private := PrTest |}
  | PrStep_Test_true : forall l x,
      x < MAX ->
      producer_step {| Shared := {| Locked := l; X := x|}; Private := PrTest |}
                    {| Shared := {| Locked := l; X := x|}; Private := PrInc |}
  | PrStep_Test_false : forall l x,
      x >= MAX ->
      producer_step {| Shared := {| Locked := l; X := x|}; Private := PrTest |}
                    {| Shared := {| Locked := l; X := x|}; Private := PrUnlock |}
  | PrStep_Inc : forall l x,
      producer_step {| Shared := {| Locked := l; X := x|}; Private := PrInc |}
                    {| Shared := {| Locked := l; X := 1 + x|}; Private := PrUnlock |}
  | PrStep_Unlock : forall l x,
      producer_step {| Shared := {| Locked := l; X := x|}; Private := PrUnlock |}
                    {| Shared := {| Locked := false; X := x|}; Private := PrLock |}.

  Definition producer_sys := {|
    Initial := producer_init;
    Step := producer_step
  |}.

  Inductive consumer_pc :=
  | CoLock
  | CoTest
  | CoDec
  | CoUnlock.

  Definition consumer_state := threaded_state (shared_state num) consumer_pc.

  Definition consumer_init := { {| Shared := {| Locked := false; X := MIN |};
                                   Private := CoLock |} }.

  Inductive consumer_step : consumer_state -> consumer_state -> Prop :=
  | CoStep_Lock : forall x,
      consumer_step {| Shared := {| Locked := false; X := x|}; Private := CoLock |}
                    {| Shared := {| Locked := true; X := x|}; Private := CoTest |}
  | CoStep_Test_true : forall l x,
      x > MIN ->
      consumer_step {| Shared := {| Locked := l; X := x|}; Private := CoTest |}
                    {| Shared := {| Locked := l; X := x|}; Private := CoDec |}
  | CoStep_Test_false : forall l x,
      x <= MIN ->
      consumer_step {| Shared := {| Locked := l; X := x|}; Private := CoTest |}
                    {| Shared := {| Locked := l; X := x|}; Private := CoUnlock |}
  | CoStep_Dec : forall l x,
      consumer_step {| Shared := {| Locked := l; X := x|}; Private := CoDec |}
                    {| Shared := {| Locked := l; X := x - 1|}; Private := CoUnlock |}
  | CoStep_Unlock : forall l x,
      consumer_step {| Shared := {| Locked := l; X := x|}; Private := CoUnlock |}
                    {| Shared := {| Locked := false; X := x|}; Private := CoLock |}.

  Definition consumer_sys := {|
    Initial := consumer_init;
    Step := consumer_step
  |}.

  Definition prco_sys := parallel producer_sys consumer_sys.

  Definition prco_state := threaded_state (shared_state num) (producer_pc * consumer_pc).

  Definition prco_correct (s : prco_state) :=
    MIN <= s.(Shared).(X) <= MAX.

  (* Let's re-express the combined initial state as a singleton set. *)
  Theorem prco_init_is :
    parallel1 producer_init consumer_init = { {| Shared := {| Locked := false; X := MIN|};
                                                 Private := (PrLock, CoLock) |} }.
  Proof.
    simplify.
    apply sets_equal; simplify.
    propositional.
    {
      invert H; invert H2; invert H4; equality.
    }
    invert H0.
    repeat constructor.
  Qed.

End prco.

Hint Rewrite prco_init_is.
Arguments prco_correct / .

(* We can try model checking [proco_sys] with different [MIN] and [MAX]
 * values. *)
Theorem prco_ok_example :
  invariantFor (prco_sys 1 2) (prco_correct 1 2).
Proof.
  Time model_check_find_invariant.
  model_check_finish.
Qed.

(* But the time for model checking grows rapidly with larger constants.
 * We should apply abstraction. *)

(* CHALLENGE #3: Come up with a suitable abstraction of this system and use it
 * to verify the original program *for all [MIN] and [MAX] values (assuming 0 < MIN < MAX)*, by reduction
 * to a finite-state system that can be model checked. *)

Section prco_a.

  Variable MIN : num.
  Variable MAX : num.
  (* We make this assumption about MIN and MAX, which becomes a hypothesis that can be used in the following part of the section *)
  Hypothesis MIN_MAX : 0 < MIN < MAX.

  Theorem prco_ok :
    invariantFor (prco_sys MIN MAX) (prco_correct MIN MAX).
  Proof.
  Admitted.

End prco_a.


From Rela Require Import Loc.

(** A memory state (called sigma) maps locations to natural numbers **)

Definition sigma : Type := Loc.t -> nat.

(** A default memory state **)

Definition default_sigma : sigma := fun _ => 0.

(** Notation for updating  memory states **)

Definition update_sigma (x:Loc.Loc.t) (v: nat) (l:sigma) : sigma :=
fun (x': Loc.t) => if Loc.Loc.eq_dec x x' then v else l x'.

Notation "x '!->' v ';' l" := (update_sigma x v l)(at level 100, v at next level, right associativity).

Lemma get_sigma_same : forall x v l, (x !-> v ; l) x = v.
Proof.
intros.
unfold update_sigma.
destruct (Loc.eq_dec x x).
 * reflexivity.
 * contradiction n. reflexivity.
Qed.

Lemma get_lambda_diff : forall x1 x2 v l, x2 <> x1 -> (x1 !-> v ; l) x2 = l x2.
Proof.
intros.
unfold update_sigma.
destruct (Loc.eq_dec x1 x2).
+ contradiction H. rewrite e. reflexivity.
+ reflexivity.
Qed.


Require Import TestSuite.admit.
(* compile en user    3m39.915s sur cachalot *)
Require Import Nsatz.

(* Example with a generic domain *)

Section test.

Context {A:Type}`{Aid:Integral_domain A}.

Lemma example3 : forall x y z,
  x+y+z==0 ->
  x*y+x*z+y*z==0->
  x*y*z==0 -> x^3%Z==0.
Proof.
Time nsatz.
Qed.

Lemma example4 : forall x y z u,
  x+y+z+u==0 ->
  x*y+x*z+x*u+y*z+y*u+z*u==0->
  x*y*z+x*y*u+x*z*u+y*z*u==0->
  x*y*z*u==0 -> x^4%Z==0.
Proof.
Time nsatz.
Qed.

Lemma example5 : forall x y z u v,
  x+y+z+u+v==0 ->
  x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v==0->
  x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v==0->
  x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z==0 ->
  x*y*z*u*v==0 -> x^5%Z==0.
Proof.
Time nsatz.
Qed.

Goal forall x y:Z,  x = y -> (x+0)%Z = (y*1+0)%Z.
nsatz.
Qed.

Require Import Reals.

Goal forall x y:R,  x = y -> (x+0)%R = (y*1+0)%R.
nsatz.
Qed.

Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R.
nsatz.
Qed.

End test.

Section Geometry.
(* See the interactive pictures of Laurent Théry
   on http://www-sop.inria.fr/marelle/CertiGeo/
   and research paper on
   https://docs.google.com/fileview?id=0ByhB3nPmbnjTYzFiZmIyNGMtYTkwNC00NWFiLWJiNzEtODM4NmVkYTc2NTVk&hl=fr
*)

Require Import List.
Require Import Reals.

Record point:Type:={
 X:R;
 Y:R}.

Definition collinear(A B C:point):=
  (X A - X B)*(Y C - Y B)-(Y A - Y B)*(X C - X B)=0.

Definition parallel (A B C D:point):=
  ((X A)-(X B))*((Y C)-(Y D))=((Y A)-(Y B))*((X C)-(X D)).

Definition notparallel (A B C D:point)(x:R):=
  x*(((X A)-(X B))*((Y C)-(Y D))-((Y A)-(Y B))*((X C)-(X D)))=1.

Definition orthogonal (A B C D:point):=
  ((X A)-(X B))*((X C)-(X D))+((Y A)-(Y B))*((Y C)-(Y D))=0.

Definition equal2(A B:point):=
  (X A)=(X B) /\ (Y A)=(Y B).

Definition equal3(A B:point):=
  ((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0.

Definition nequal2(A B:point):=
  (X A)<>(X B) \/ (Y A)<>(Y B).

Definition nequal3(A B:point):=
  not (((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0).

Definition middle(A B I:point):=
  2%R*(X I)=(X A)+(X B) /\ 2%R*(Y I)=(Y A)+(Y B).

Definition distance2(A B:point):=
  (X B - X A)^2%Z + (Y B - Y A)^2%Z.

(* AB = CD *)
Definition samedistance2(A B C D:point):=
  (X B - X A)^2%Z + (Y B - Y A)^2%Z = (X D - X C)^2%Z + (Y D - Y C)^2%Z.
Definition determinant(A O B:point):=
  (X A - X O)*(Y B - Y O) - (Y A - Y O)*(X B - X O).
Definition scalarproduct(A O B:point):=
  (X A - X O)*(X B - X O) + (Y A - Y O)*(Y B - Y O).
Definition norm2(A O B:point):=
  ((X A - X O)^2%Z+(Y A - Y O)^2%Z)*((X B - X O)^2%Z+(Y B - Y O)^2%Z).

Definition equaldistance(A B C D:point):=
  ((X B) - (X A))^2%Z + ((Y B) - (Y A))^2%Z =
  ((X D) - (X C))^2%Z + ((Y D) - (Y C))^2%Z.

Definition equaltangente(A B C D E F:point):=
  let s1:= determinant A B C in
  let c1:= scalarproduct A B C in
  let s2:= determinant D E F in
  let c2:= scalarproduct D E F in
  s1 * c2 = s2 * c1.

Ltac cnf2 f :=
  match f with
   | ?A \/ (?B /\ ?C) =>
     let c1 := cnf2 (A\/B) in
     let c2 := cnf2 (A\/C) in constr:(c1/\c2)
   | (?B /\ ?C) \/ ?A =>
     let c1 := cnf2 (B\/A) in
     let c2 := cnf2 (C\/A) in constr:(c1/\c2)
   | (?A \/ ?B) \/ ?C =>
     let c1 := cnf2 (B\/C) in cnf2 (A \/ c1)
   | _ => f
  end
with cnf f :=
  match f with
   | ?A \/ ?B =>
     let c1 := cnf A in
       let c2 := cnf B in
         cnf2 (c1 \/ c2)
   | ?A /\ ?B =>
     let c1 := cnf A in
       let c2 := cnf B in
         constr:(c1 /\ c2)
   | _ => f
  end.

Ltac scnf :=
  match goal with
    | |- ?f => let c := cnf f in
      assert c;[repeat split| tauto]
  end.

Ltac disj_to_pol f :=
  match f with
   | ?a = ?b \/ ?g => let p := disj_to_pol g in constr:((a - b)* p)
   | ?a = ?b => constr:(a - b)
  end.

Lemma fastnsatz1:forall x y:R, x - y = 0 -> x = y.
nsatz.
Qed.

Ltac fastnsatz:=
  try trivial; try apply fastnsatz1; try trivial; nsatz.

Ltac proof_pol_disj :=
  match goal with
   | |- ?g => let p := disj_to_pol g in
     let h := fresh "hp" in
     assert (h:p = 0);
     [idtac|
      prod_disj h p]
   | _ => idtac
  end
with prod_disj h p :=
  match goal with
   | |- ?a = ?b \/ ?g =>
        match p with
          | ?q * ?p1 =>
        let h0 := fresh "hp" in
        let h1 := fresh "hp" in
        let h2 := fresh "hp" in
        assert (h0:a - b = 0 \/ p1 = 0);
        [apply Rmult_integral; exact h|
         destruct h0 as [h1|h2];
         [left; fastnsatz|
          right; prod_disj h2 p1]]
        end
   | _ => fastnsatz
  end.

(*
Goal forall a b c d e f:R, a=b \/ c=d \/ e=f \/ e=a.
intros. scnf; proof_pol_disj .
admit.*)

Ltac geo_unfold :=
  unfold collinear, parallel, notparallel, orthogonal,
    equal2, equal3, nequal2, nequal3,
    middle, samedistance2,
    determinant, scalarproduct, norm2, distance2,
      equaltangente, determinant, scalarproduct, equaldistance.

Ltac geo_rewrite_hyps:=
  repeat (match goal with
           | h:X _ = _ |- _ => rewrite h in *; clear h
           | h:Y _ = _ |- _ => rewrite h in *; clear h
          end).

Ltac geo_split_hyps:=
  repeat (match goal with
           | h:_ /\ _ |- _ => destruct h
          end).

Ltac geo_begin:=
  geo_unfold;
  intros;
  geo_rewrite_hyps;
  geo_split_hyps;
  scnf; proof_pol_disj.

(* Examples *)

Lemma medians: forall A B C A1 B1 C1 H:point,
  middle B C A1 ->
  middle A C B1 ->
  middle A B C1 ->
  collinear A A1 H -> collinear B B1 H ->
  collinear C C1 H
  \/ collinear A B C.
Proof. geo_begin.
idtac "Medians".
 Time nsatz.
(*Finished transaction in 2. secs (2.69359u,0.s)
*) Qed.

Lemma Pythagore: forall A B C:point,
  orthogonal A B A C ->
  distance2 A C + distance2 A B = distance2 B C.
Proof. geo_begin.
idtac "Pythagore".
Time nsatz.
(*Finished transaction in 0. secs (0.354946u,0.s)
*) Qed.

Lemma Thales: forall O A B C D:point,
  collinear O A C -> collinear O B D ->
  parallel A B C D ->
  (distance2 O B * distance2 O C = distance2 O D * distance2 O A
  /\ distance2 O B * distance2 C D = distance2 O D * distance2 A B)
 \/ collinear O A B.
geo_begin.
idtac "Thales".
Time nsatz. (*Finished transaction in 2. secs (1.598757u,0.s)*)
Time nsatz.
Qed.

Lemma segments_of_chords: forall A B C D M O:point,
  equaldistance O A O B ->
  equaldistance O A O C ->
  equaldistance O A O D ->
  collinear A B M ->
  collinear C D M ->
  (distance2 M A) * (distance2 M B) = (distance2 M C) * (distance2 M D)
  \/ parallel A B C D.
Proof.
geo_begin.
idtac "segments_of_chords".
Time nsatz.
(*Finished transaction in 3. secs (2.704589u,0.s)
*) Qed.

Lemma isoceles: forall A B C:point,
  equaltangente A B C B C A ->
  distance2 A B = distance2 A C
  \/ collinear A B C.
Proof. geo_begin.  Time nsatz.
(*Finished transaction in 1. secs (1.140827u,0.s)*) Qed.

Lemma minh: forall A B C D O E H I:point,
  X A = 0 -> Y A = 0 -> Y O = 0 ->
  equaldistance O A O B ->
  equaldistance O A O C ->
  equaldistance O A O D ->
  orthogonal A C B D ->
  collinear A C E ->
  collinear B D E ->
  collinear A B H ->
  orthogonal E H A B ->
  collinear C D I ->
  middle C D I ->
  collinear H E I
  \/ (X C)^2%Z * (X B)^5%Z * (X O)^2%Z
     * (X C - 2%Z * X O)^3%Z * (-2%Z * X O + X B)=0
  \/  parallel A C B D.
Proof. geo_begin.
idtac "minh".
Time nsatz with radicalmax :=1%N strategy:=1%Z
  parameters:=(X O::X B::X C::nil)
  variables:= (@nil R).
(*Finished transaction in 13. secs (10.102464u,0.s)
*)
Qed.

Lemma Pappus: forall A B C A1 B1 C1 P Q S:point,
  X A = 0 -> Y A = 0 -> Y B = 0 -> Y C = 0 ->
  collinear A1 B1 C1 ->
  collinear A B1 P -> collinear A1 B P ->
  collinear A C1 Q -> collinear A1 C Q ->
  collinear B C1 S -> collinear B1 C S ->
  collinear P Q S
  \/ (Y A1 - Y B1)^2%Z=0 \/ (X A = X B1)
  \/ (X A1 = X C) \/ (X C = X B1)
  \/ parallel A B1 A1 B \/ parallel A C1 A1 C \/ parallel B C1 B1 C.
Proof.
geo_begin.
idtac "Pappus".
Time nsatz with radicalmax :=1%N strategy:=0%Z
  parameters:=(X B::X A1::Y A1::X B1::Y B1::X C::Y C1::nil)
  variables:= (X B
 :: X A1
    :: Y A1
       :: X B1
          :: Y B1
             :: X C
                :: Y C1
                   :: X C1 :: Y P :: X P :: Y Q :: X Q :: Y S :: X S :: nil).
(*Finished transaction in 8. secs (7.795815u,0.000999999999999s)
*)
Qed.

Lemma Simson: forall A B C O D E F G:point,
  X A = 0 -> Y A = 0 ->
  equaldistance O A O B ->
  equaldistance O A O C ->
  equaldistance O A O D ->
  orthogonal  E D B C ->
  collinear B C E ->
  orthogonal F D A C ->
  collinear A C F ->
  orthogonal G D A B ->
  collinear A B G ->
  collinear E F G
  \/ (X C)^2%Z = 0 \/ (Y C)^2%Z = 0 \/ (X B)^2%Z = 0 \/ (Y B)^2%Z = 0 \/ (Y C - Y B)^2%Z = 0
  \/ equal3 B A
  \/ equal3 A C \/ (X C - X B)^2%Z = 0
  \/ equal3 B C.
Proof.
geo_begin.
idtac "Simson".
Time nsatz with radicalmax :=1%N strategy:=0%Z
  parameters:=(X B::Y B::X C::Y C::Y D::nil)
  variables:= (@nil R). (* compute -[X Y]. *)
(*Finished transaction in 8. secs (7.550852u,0.s)
*)
Qed.

Lemma threepoints: forall A B C A1 B1 A2 B2 H1 H2 H3:point,
  (* H1 intersection of bisections *)
  middle B C A1 ->  orthogonal H1 A1 B C ->
  middle A C B1 -> orthogonal H1 B1 A C ->
  (* H2 intersection of medians *)
  collinear A A1 H2 -> collinear B B1 H2 ->
  (* H3 intersection of altitudes *)
  collinear B C A2 ->  orthogonal A A2 B C ->
  collinear A C B2 -> orthogonal B B2 A C ->
  collinear A A1 H3 -> collinear B B1 H3 ->
  collinear H1 H2 H3
  \/ collinear A B C.
Proof. geo_begin.
idtac "threepoints".
Time nsatz.
(*Finished transaction in 7. secs (6.282045u,0.s)
*) Qed.

Lemma Feuerbach:  forall A B C A1 B1 C1 O A2 B2 C2 O2:point,
  forall r r2:R,
  X A = 0 -> Y A =  0 -> X B = 1 -> Y B =  0->
  middle A B C1 -> middle B C A1 -> middle C A B1 ->
  distance2 O A1 = distance2 O B1 ->
  distance2 O A1 = distance2 O C1 ->
  collinear A B C2 -> orthogonal A B O2 C2 ->
  collinear B C A2 -> orthogonal B C O2 A2 ->
  collinear A C B2 -> orthogonal A C O2 B2 ->
  distance2 O2 A2 = distance2 O2 B2 ->
  distance2 O2 A2 = distance2 O2 C2 ->
  r^2%Z = distance2 O A1 ->
  r2^2%Z = distance2 O2 A2 ->
  distance2 O O2 = (r + r2)^2%Z
  \/ distance2 O O2 = (r - r2)^2%Z
  \/ collinear A B C.
Proof. geo_begin.
idtac "Feuerbach".
Time nsatz.
(*Finished transaction in 21. secs (19.021109u,0.s)*)
Qed.

Lemma Euler_circle: forall A B C A1 B1 C1 A2 B2 C2 O:point,
  middle A B C1 -> middle B C A1 -> middle C A B1 ->
  orthogonal A B C C2 -> collinear A B C2 ->
  orthogonal B C A A2 -> collinear B C A2 ->
  orthogonal A C B B2 -> collinear A C B2 ->
  distance2 O A1 = distance2 O B1 ->
  distance2 O A1 = distance2 O C1 ->
  (distance2 O A2 = distance2 O A1
   /\distance2 O B2 = distance2 O A1
   /\distance2 O C2 = distance2 O A1)
  \/ collinear A B C.
Proof. geo_begin.
idtac "Euler_circle 3 goals".
Time nsatz.
(*Finished transaction in 13. secs (11.208296u,0.124981s)*)
Time nsatz.
(*Finished transaction in 10. secs (8.846655u,0.s)*)
Time nsatz.
(*Finished transaction in 11. secs (9.186603u,0.s)*)
Qed.

Lemma Desargues: forall A B C A1 B1 C1 P Q R S:point,
  X S = 0 -> Y S = 0 -> Y A = 0 ->
  collinear A S A1 -> collinear B S B1 -> collinear C S C1 ->
  collinear B1 C1 P -> collinear B C P ->
  collinear A1 C1 Q -> collinear A C Q ->
  collinear A1 B1 R -> collinear A B R ->
  collinear P Q R
  \/ X A = X B \/ X A = X C \/ X B = X C  \/ X A = 0 \/ Y B = 0 \/ Y C = 0
  \/ collinear S B C \/ parallel A C A1 C1 \/ parallel A B A1 B1.
Proof.
geo_begin.
idtac "Desargues".
Time
let lv := rev (X A
 :: X B
    :: Y B
       :: X C
          :: Y C
             :: Y A1 :: X A1
                :: Y B1
                   :: Y C1
                      :: X R
                         :: Y R
                            :: X Q
                               :: Y Q :: X P :: Y P :: X C1 :: X B1 :: nil) in
nsatz with radicalmax :=1%N strategy:=0%Z
  parameters:=(X A::X B::Y B::X C::Y C::X A1::Y B1::Y C1::nil)
  variables:= lv. (*Finished transaction in 8. secs (8.02578u,0.001s)*)
Qed.

Lemma chords: forall O A B C D M:point,
  equaldistance O A O B ->
  equaldistance O A O C ->
  equaldistance O A O D ->
  collinear A B M -> collinear C D M ->
  scalarproduct A M B = scalarproduct C M D
  \/ parallel A B C D.
Proof. geo_begin.
idtac "chords".
 Time nsatz.
(*Finished transaction in 4. secs (3.959398u,0.s)*)
Qed.

Lemma Ceva: forall A B C D E F M:point,
  collinear M A D -> collinear M B E -> collinear M C F ->
  collinear B C D -> collinear E A C -> collinear F A B ->
  (distance2 D B) * (distance2 E C) * (distance2 F A) =
  (distance2 D C) * (distance2 E A) * (distance2 F B)
  \/ collinear A B C.
Proof. geo_begin.
idtac "Ceva".
Time nsatz.
(*Finished transaction in 105. secs (104.121171u,0.474928s)*)
Qed.

Lemma bissectrices: forall A B C M:point,
  equaltangente C A M M A B ->
  equaltangente A B M M B C ->
  equaltangente B C M M C A
  \/ equal3 A B.
Proof. geo_begin.
idtac "bissectrices".
Time nsatz.
(*Finished transaction in 2. secs (1.937705u,0.s)*)
Qed.

Lemma bisections: forall A B C A1 B1 C1 H:point,
  middle B C A1 ->  orthogonal H A1 B C ->
  middle A C B1 -> orthogonal H B1 A C ->
  middle A B C1 ->
  orthogonal H C1 A B
  \/ collinear A B C.
Proof. geo_begin.
idtac "bisections".
Time nsatz. (*Finished transaction in 2. secs (2.024692u,0.002s)*)
Qed.

Lemma altitudes: forall A B C A1 B1 C1 H:point,
  collinear B C A1 ->  orthogonal A A1 B C ->
  collinear A C B1 -> orthogonal B B1 A C ->
  collinear A B C1 -> orthogonal C C1 A B ->
  collinear A A1 H -> collinear B B1 H ->
  collinear C C1 H
  \/ equal2 A B
  \/ collinear A B C.
Proof. geo_begin.
idtac "altitudes".
Time nsatz. (*Finished transaction in 3. secs (3.001544u,0.s)*)
Time nsatz. (*Finished transaction in 4. secs (3.113527u,0.s)*)
Qed.

Lemma hauteurs:forall A B C A1 B1 C1 H:point,
  collinear B C A1 ->  orthogonal A A1 B C ->
  collinear A C B1 -> orthogonal B B1 A C ->
  collinear A B C1 -> orthogonal C C1 A B ->
  collinear A A1 H -> collinear B B1 H ->

  collinear C C1 H
  \/ collinear A B C.

geo_begin.
idtac "hauteurs".
Time
 let lv := constr:(Y A1
 :: X A1 :: Y B1 :: X B1 :: Y A :: Y B :: X B :: X A :: X H :: Y C
 :: Y C1 :: Y H :: X C1 :: X C :: (@Datatypes.nil R)) in
nsatz with radicalmax := 2%N strategy := 1%Z parameters := (@Datatypes.nil R)
 variables := lv.
(*Finished transaction in 5. secs (4.360337u,0.008999s)*)
Qed.

End Geometry.


Require Export decidability.
Require back.

(** Duality **)

Module swap (M': ProjectivePlane') <: ProjectivePlane'.

Definition Point := M'.Line.
Definition Line := M'.Point.

Definition Incid := fun (x:Point) (y:Line) => M'.Incid y x.
Definition incid_dec : forall (A : Point) (l : Line), {Incid A l} + {~ Incid A l}.
Proof.
unfold Incid.
intros.
apply M'.incid_dec.
Qed.

Definition a1_exist := M'.a2_exist.
Definition a2_exist := M'.a1_exist.

Lemma uniqueness : forall A B :Point, forall l m : Line,
Incid A l -> Incid B l  -> Incid A m -> Incid B m -> A=B\/l=m.
intros.
unfold Point, Line, Incid in *.
assert ((l=m)\/(A=B)).
apply M'.uniqueness; assumption.
intuition.
Qed.

Export back.
Module M := back.back M'.
Module ProjectivePlaneFacts_m := decidability.decidability M.

Module uniq := uniqueness_axioms M'.

Ltac Apply_unicity := match goal with
H1: ?A <> ?B, H2: ?Incid ?A ?l, H3: ?Incid ?B ?l, H4 : ?Incid ?A ?m, H5: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: l=m); try apply (uniq.a1_unique A B l m H1 H2 H3 H4 H5);subst l
| H1: ?l <> ?m, H2: ?Incid ?A ?l, H3: ?Incid ?A ?m, H4 : ?Incid ?B ?l, H5: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: A=B); try apply (uniq.a2_unique l m A B H1 H2 H3 H4 H5);subst A
end.

Ltac Collapse := repeat (Apply_unicity; CleanDuplicatedHyps).

Ltac line_through l A B Ha Hb := elim (M'.a1_exist A B); intros l [Ha Hb].

Lemma a3_1_aux :
  forall (P: Point) (l:Line),
  ~ Incid P l -> {A:Point & {B:Point & {C:Point |
 (dist3 A B C/\Incid A l /\Incid B l /\ Incid C l)}}}.
Proof.
intro l1.
intro P.
intro Hincid.

elim (M'.a3_1 l1).
intros A HA; elim HA.
intros B HB; elim HB.
intros C (Hz1,(Hz2,(Hz3,Hz4))); clear HA HB.

line_through m1 P A Hm1A Hm1B.
line_through m2 P B Hm2A Hm2B.
line_through m3 P C Hm3A Hm3B.
exists m1.
exists m2.
exists m3.

split.
2:intuition.
unfold dist3.
split.
intros Hm1m2.
subst m1.
assert (A=B).
assert (m2<>l1).
intro Hm2l1.
subst m2.
intuition.

apply (uniq.a2_unique m2 l1 A B H) ; intuition.
subst A.
unfold dist3 in Hz1; intuition.

split.

intros Hm1m2.
subst m1.
assert (A=C).
assert (m3<>l1).
intro Hm3l1.
subst.
intuition.

apply (uniq.a2_unique m3 l1 A C H) ; intuition.
subst.
unfold dist3 in Hz1; intuition.

intros Hm1m2.
subst.
assert (B=C).
assert (m3<>l1).
intro Hm3l1.
subst.
intuition.

apply (uniq.a2_unique m3 l1 B C H) ; intuition.
subst.
unfold dist3 in Hz1; intuition.
Qed.

Definition a3_1:
 forall l:Line,{A:Point & {B:Point & {C:Point |
 (dist3 A B C/\Incid A l /\Incid B l /\ Incid C l)}}}.
(** Using a3_2, we build two lines l1 and l2.
The we perform case distinction on Incid P l1 and Indic P l2
If P does not belong to l1 or l2 we use the previous lemma.
Othewise P belongs to l1 and l2, we use the outsider lemma.
*)

(*
unfold Line, Point, Incid.
*)

elim M'.a3_2 ; intros l1 Hl1.
elim Hl1; intros l2 Hl2; clear Hl1.

intros P.
elim (M'.incid_dec P l1);intros HMl1.
elim (M'.incid_dec P l2);intros HMl2.

(** Case P is at the intersections of l1 and l2 **)

exists l1.
exists l2.

elim (ProjectivePlaneFacts_m.outsider l1 l2).

intros K (HK1, HK2).

line_through m P K Hm1 Hm2.
exists m.

unfold dist3.
unfold ProjectivePlaneFacts_m.Incid in *.
unfold M.Incid in *.
intuition;subst;intuition.

(** Case P is not on l2 *)

apply (a3_1_aux) with (P:=l2);assumption.

(** Case P is not on l1 *)
apply (a3_1_aux) with (P:=l1);assumption.
Qed.

Definition a3_2 : {l1:Line & {l2:Line | l1 <> l2}}.
generalize M'.a3_2  M'.a3_1.
intros H1 H2.
elim H1.
intro l.
intro Hl2.
elim (H2 l).
intros P H';elim H'.
intro Q.
intros.
elim p.
intros x (H1', (H2', (H3', H4'))).
exists P.
exists Q.
unfold dist3 in H1'; tauto.
Qed.

End swap.

Module example (M': ProjectivePlane').

Module Swaped := swap M'.
Export M'.

Lemma dual_example :
forall P : Point,
       {l1 : Line &
       {l2 : Line &
       {l3 : Line |
       dist3 l1 l2 l3 /\
       Incid P l1 /\ Incid P l2 /\ Incid P l3}}}.
Proof.
apply Swaped.a3_1.
Qed.

End example.


Require Import PV.Syntax.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import compcert.lib.Integers.
Require Import SetsClass.SetsClass. Import SetsNotation.
Local Open Scope string.
Local Open Scope Z.
Local Open Scope sets.

Module SmallStep.
Import Lang_SimpleWhile.

Definition state: Type := var_name -> Z.

Inductive istep (s : state) : expr_int -> expr_int -> Prop :=
| IS_Var : forall x,
    istep s (EVar x) (EConst (s x))
| IS_Add_0 : forall v1 v2,
    istep s (EAdd (EConst v1) (EConst v2)) (EConst (v1 + v2))
| IS_Add_1 : forall e1 e1' e2,
    istep s e1 e1' ->
    istep s (EAdd e1 e2) (EAdd e1' e2)
| IS_Add_2 : forall v1 e2 e2',
    istep s e2 e2' ->
    istep s (EAdd (EConst v1) e2) (EAdd (EConst v1) e2')
| IS_Sub_0 : forall v1 v2,
    istep s (ESub (EConst v1) (EConst v2)) (EConst (v1 - v2))
| IS_Sub_1 : forall e1 e1' e2,
    istep s e1 e1' ->
    istep s (ESub e1 e2) (ESub e1' e2)
| IS_Sub_2 : forall v1 e2 e2',
    istep s e2 e2' ->
    istep s (ESub (EConst v1) e2) (ESub (EConst v1) e2')
| IS_Mul_0 : forall v1 v2,
    istep s (EMul (EConst v1) (EConst v2)) (EConst (v1 * v2))
| IS_Mul_1 : forall e1 e1' e2,
    istep s e1 e1' ->
    istep s (EMul e1 e2) (EMul e1' e2)
| IS_Mul_2 : forall v1 e2 e2',
    istep s e2 e2' ->
    istep s (EMul (EConst v1) e2) (EMul (EConst v1) e2')
.

Inductive ivalue : expr_int -> Prop :=
| ivalue_const : forall n, ivalue (EConst n).

Theorem istep_progress : forall s e,
  ivalue e \/ exists e', istep s e e'.
Proof.
  intros.
  induction e; [ left | | | | ]; try right.
  - apply ivalue_const.
  - exists (EConst (s x)); apply IS_Var.
  - destruct IHe1 as [ [?] | [? ?] ].
    + destruct IHe2 as [ [?] | [? ?] ].
      * exists (EConst (n + n0)); apply IS_Add_0.
      * exists (EAdd n x); apply IS_Add_2; tauto.
    + exists (EAdd x e2); apply IS_Add_1; tauto.
  - destruct IHe1 as [ [?] | [? ?] ].
    + destruct IHe2 as [ [?] | [? ?] ].
      * exists (EConst (n - n0)); apply IS_Sub_0.
      * exists (ESub n x); apply IS_Sub_2; tauto.
    + exists (ESub x e2); apply IS_Sub_1; tauto.
  - destruct IHe1 as [ [?] | [? ?] ].
    + destruct IHe2 as [ [?] | [? ?] ].
      * exists (EConst (n * n0)); apply IS_Mul_0.
      * exists (EMul n x); apply IS_Mul_2; tauto.
    + exists (EMul x e2); apply IS_Mul_1; tauto.
Qed.

Definition lt_eval (v1 v2 : Z) :=
  if v1 <? v2 then ETrue else EFalse.

Inductive bstep (s : state) : expr_bool -> expr_bool -> Prop :=
| BS_Lt_0 : forall v1 v2,
    bstep s (ELt (EConst v1) (EConst v2)) (lt_eval v1 v2)
| BS_Lt_1 : forall e1 e1' e2,
    istep s e1 e1' ->
    bstep s (ELt e1 e2) (ELt e1' e2)
| BS_Lt_2 : forall v1 e2 e2',
    istep s e2 e2' ->
    bstep s (ELt (EConst v1) e2) (ELt (EConst v1) e2')
| BS_And_False : forall e,
    bstep s (EAnd EFalse e) EFalse
| BS_And_True_True :
    bstep s (EAnd ETrue ETrue) ETrue
| BS_And_True_False :
    bstep s (EAnd ETrue EFalse) EFalse
| BS_And_1 : forall e1 e1' e2,
    bstep s e1 e1' ->
    bstep s (EAnd e1 e2) (EAnd e1' e2)
| BS_And_2 : forall e2 e2',
    bstep s e2 e2' ->
    bstep s (EAnd ETrue e2) (EAnd ETrue e2')
| BS_Not_True :
    bstep s (ENot ETrue) EFalse
| BS_Not_False :
    bstep s (ENot EFalse) ETrue
| BS_Not_1 : forall e1 e1',
    bstep s e1 e1' ->
    bstep s (ENot e1) (ENot e1')
.

Inductive bvalue : expr_bool -> Prop :=
| bvalue_true : bvalue ETrue
| bvalue_false : bvalue EFalse
.

Theorem bstep_progress : forall s e,
  bvalue e \/ exists e', bstep s e e'.
Proof.
  intros.
  induction e; [ left | left | right | right | right ].
  - apply bvalue_true.
  - apply bvalue_false.
  - pose proof (istep_progress s e1); destruct H as [ [?] | [? ?] ].
    + pose proof (istep_progress s e2); destruct H as [ [?] | [? ?] ].
      * exists (lt_eval n n0); apply BS_Lt_0.
      * exists (ELt (EConst n) x); apply BS_Lt_2; tauto.
    + exists (ELt x e2); apply BS_Lt_1; tauto.
  - destruct IHe1 as [ [|] | [? ?] ].
    + destruct IHe2 as [ [|] | [? ?] ].
      * exists ETrue; apply BS_And_True_True.
      * exists EFalse; apply BS_And_True_False.
      * exists (EAnd ETrue x); apply BS_And_2; tauto.
    + exists EFalse; apply BS_And_False.
    + exists (EAnd x e2); apply BS_And_1; tauto.
  - destruct IHe as [ [|] | [? ?] ].
    + exists EFalse; apply BS_Not_True.
    + exists ETrue; apply BS_Not_False.
    + exists (ENot x); apply BS_Not_1; tauto.
Qed.

Definition state_update (s : state) (x : var_name) (v : Z) : state := fun y =>
  if String.eqb x y then v else s y.

Inductive cstep : (com * state) -> (com * state) -> Prop :=
| CS_AsgnStep : forall s x e e',
    istep s e e' ->
    cstep ((CAsgn x e), s) ((CAsgn x e'), s)
| CS_Asgn : forall s x v,
    cstep ((CAsgn x (EConst v)), s) (CSkip, (state_update s x v))
| CS_SeqStep : forall s s' c1 c1' c2,
    cstep (c1, s) (c1', s') ->
    cstep ((CSeq c1 c2), s) ((CSeq c1' c2), s')
| CS_SeqSkip : forall s c,
    cstep ((CSeq CSkip c), s) (c, s)
| CS_IfStep : forall s e e' c1 c2,
    bstep s e e' ->
    cstep ((CIf e c1 c2), s) ((CIf e' c1 c2), s)
| CS_IfTrue : forall s c1 c2,
    cstep ((CIf ETrue c1 c2), s) (c1, s)
| CS_IfFalse : forall s c1 c2,
    cstep ((CIf EFalse c1 c2), s) (c2, s)
| CS_While : forall s e c,
    cstep ((CWhile e c), s) ((CIf e (CSeq c (CWhile e c)) CSkip), s)
.

Inductive cvalue : com -> Prop :=
| cvalue_skip : cvalue CSkip.

Theorem cstep_progress : forall s c,
  cvalue c \/ exists c' s', cstep (c, s) (c', s').
Proof.
  intros.
  induction c; [ left | | | | ]; try right.
  - apply cvalue_skip.
  - pose proof (istep_progress s e); destruct H as [ [?] | [? ?] ].
    + exists CSkip, (state_update s x n); apply CS_Asgn.
    + exists (CAsgn x x0), s; apply CS_AsgnStep; tauto.
  - destruct IHc1 as [ [] | [? [? ?] ] ].
    + exists c2, s; apply CS_SeqSkip.
    + exists (CSeq x c2), x0; apply CS_SeqStep; tauto.
  - pose proof (bstep_progress s e); destruct H as [ [|] | [? ?] ].
    + exists c1, s; apply CS_IfTrue.
    + exists c2, s; apply CS_IfFalse.
    + exists (CIf x c1 c2), s; apply CS_IfStep; tauto.
  - exists (CIf e (CSeq c (CWhile e c)) CSkip), s; apply CS_While.
Qed.

End SmallStep.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import HoTT.
Require Import UnivalenceAxiom.

Definition UIP :=
  forall (A : Type) (x y:A) (p q : x = y),
    p = q.
Definition UIP_refl :=
  forall (A : Type) (x : A) (p : x = x),
    p = idpath.
Definition K :=
  forall A (x : A) (P : x = x -> Type),
    P (idpath x) -> forall (h : x = x), P h.

(* Groupoid model shows that K/UIP are not derivable in ITT *)

Theorem UIPisUIPrefl : UIP <-> UIP_refl.
Proof.
  split.
    intro U. unfold UIP_refl.
    unfold UIP in U.
    intros A x p.
    apply (U A x x p idpath).

    intro Ur. intros A x y p q.
    induction q. apply Ur.
Qed.

Theorem UIP2K : UIP -> K.
Proof.
  intro U.
  intros A x P H h.
  rewrite <- (U A x x idpath h). exact H.
Qed.

Theorem K2UIP : K -> UIP.
Proof.
  intro k. intros A x y p q.
  destruct p.
  (* Set Printing Implicit. <-- to see why case analysis on q does not work *)
  (* destruct q. *)
  apply (k A x (fun m => idpath = m) idpath).
Qed.

Definition coerce : forall A B, (A = B) -> A -> B :=
  fun A B p a => match p with
                   | idpath => a
                 end.

Lemma coerce_refl : forall A x, coerce A A idpath x = x.
Proof.
  intros. simpl. reflexivity.
Qed.

Lemma coerce_id : K -> forall (e : Bool = Bool), coerce Bool Bool e true = true.
Proof.
  intros K e.
  apply (K Type Bool (fun p => coerce Bool Bool p true = true) (coerce_refl Bool true) e).
Qed.