(** * Algebra I. Part D.  Integral domains and fileds. Vladimir Voevodsky. Aug. 2011 - .

*)

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

(** To upstream files *)

(** To one binary operation *)

Lemma islcancelableif { X : hSet } ( opp : binop X ) ( x : X ) ( is : forall a b : X , paths ( opp x a ) ( opp x b ) -> paths a b ) : islcancelable opp x .
Proof . intros . apply isinclbetweensets . apply ( setproperty X ) . apply ( setproperty X ) . apply is .  Defined .

Lemma isrcancelableif { X : hSet } ( opp : binop X ) ( x : X ) ( is : forall a b : X , paths ( opp a x ) ( opp b x ) -> paths a b ) : isrcancelable opp x .
Proof . intros . apply isinclbetweensets . apply ( setproperty X ) . apply ( setproperty X ) . apply is .  Defined .

Definition iscancelableif { X : hSet } ( opp : binop X ) ( x : X ) ( isl : forall a b : X , paths ( opp x a ) ( opp x b ) -> paths a b ) ( isr : forall a b : X , paths ( opp a x ) ( opp b x ) -> paths a b ) : iscancelable opp x := dirprodpair ( islcancelableif opp x isl ) ( isrcancelableif opp x isr ) .

(** To monoids *)

Open Local Scope  multmonoid_scope.

Definition linvpair ( X : monoid ) ( x : X ) := total2 ( fun x' : X => paths ( x' * x ) 1 ) .
Definition pr1linvpair ( X : monoid ) ( x : X ) : linvpair X x -> X := @pr1 _ _ .

Definition linvpairxy ( X : monoid ) ( x y : X ) ( x' : linvpair X x ) ( y' : linvpair X y ) : linvpair X ( x * y ) .
Proof . intros . split with ( ( pr1 y' ) * ( pr1 x' ) ) . rewrite ( assocax _ _ _ ( x * y ) ) .  rewrite ( pathsinv0 ( assocax _ _ x y ) ) . rewrite ( pr2 x' ) .  rewrite ( lunax _ y ) .  rewrite ( pr2 y' ) . apply idpath . Defined .

Definition lcanfromlinv ( X : monoid ) ( a b c : X ) ( c' : linvpair X c ) ( e : paths ( c * a ) ( c * b ) ) : paths a b .
Proof . intros . assert ( e' := maponpaths ( fun x : X => ( pr1 c' ) * x ) e ) .  simpl in e' . rewrite ( pathsinv0 ( assocax X _ _ _ ) ) in e' .  rewrite ( pathsinv0 ( assocax X _ _ _ ) ) in e' . rewrite ( pr2 c' ) in e' .  rewrite ( lunax X a ) in e' .  rewrite ( lunax X b ) in e'. apply e' . Defined.

Definition rinvpair ( X : monoid ) ( x : X ) := total2 ( fun x' : X => paths ( x * x' ) 1 ) .
Definition pr1rinvpair ( X : monoid ) ( x : X ) : rinvpair X x -> X := @pr1 _ _ .

Definition rinvpairxy ( X : monoid ) ( x y : X ) ( x' : rinvpair X x ) ( y' : rinvpair X y ) : rinvpair X ( x * y ) .
Proof . intros . split with ( ( pr1 y' ) * ( pr1 x' ) ) . rewrite ( assocax _ x y _ ) .  rewrite ( pathsinv0 ( assocax _ y _ _ ) ) . rewrite ( pr2 y' ) .  rewrite ( lunax _ _ ) .  rewrite ( pr2 x' ) . apply idpath . Defined .

Definition rcanfromrinv ( X : monoid ) ( a b c : X ) ( c' : rinvpair X c ) ( e : paths ( a * c  ) ( b * c ) ) : paths a b .
Proof . intros . assert ( e' := maponpaths ( fun x : X => x * ( pr1 c' ) ) e ) .  simpl in e' . rewrite ( assocax X _ _ _ )  in e' .  rewrite ( assocax X _ _ _ ) in e' . rewrite ( pr2 c' ) in e' .  rewrite ( runax X a ) in e' .  rewrite ( runax X b ) in e'. apply e' . Defined.

Lemma pathslinvtorinv ( X : monoid ) ( x : X ) ( x' : linvpair X x ) ( x'' : rinvpair X x ) : paths ( pr1 x' ) ( pr1 x'' ) .
Proof . intros .   destruct ( runax X ( pr1 x' ) ) . unfold p . destruct ( pr2 x'' ) . set ( int := x * pr1 x'' ) . change ( paths ( pr1 x' * int ) ( pr1 x'' ) ) .   destruct ( lunax X ( pr1 x'' ) ) . destruct ( pr2 x' ) .  unfold p1 . unfold int . apply ( pathsinv0 ( assocax X _ _ _ ) ) .  Defined .

Definition invpair ( X : monoid ) ( x : X ) := total2 ( fun x' : X => dirprod ( paths ( x' * x ) 1 ) ( paths ( x * x' ) 1 ) ) .
Definition pr1invpair ( X : monoid ) ( x : X ) : invpair X x -> X := @pr1 _ _ .
Definition invtolinv ( X : monoid ) ( x : X ) ( x' : invpair X x ) : linvpair X x := tpair _ ( pr1 x' ) ( pr1 ( pr2 x' ) ) .
Definition invtorinv ( X : monoid ) ( x : X ) ( x' : invpair X x ) : rinvpair X x := tpair _ ( pr1 x' ) ( pr2 ( pr2 x' ) ) .

Lemma isapropinvpair ( X : monoid ) ( x : X ) : isaprop ( invpair X x ) .
Proof . intros . apply invproofirrelevance . intros x' x'' . apply ( invmaponpathsincl _ ( isinclpr1 _ ( fun a => isapropdirprod _ _ ( setproperty X _ _ ) ( setproperty X _ _ ) ) ) ) .  apply ( pathslinvtorinv X x ( invtolinv X x x' ) ( invtorinv X x x'' ) ) . Defined.

Definition invpairxy ( X : monoid ) ( x y : X ) ( x' : invpair X x ) ( y' : invpair X y ) : invpair X ( x * y ) .
Proof . intros . split with ( ( pr1 y' ) * ( pr1 x' ) ) . split .  apply ( pr2 ( linvpairxy _ x y ( invtolinv _ x x' ) ( invtolinv _ y y' ) ) ) .  apply ( pr2 ( rinvpairxy _ x y ( invtorinv _ x x' ) ( invtorinv _ y y' ) ) ) .  Defined .

(** To groups *)

Lemma grfrompathsxy ( X : gr ) { a b : X } ( e : paths a b ) : paths ( op a ( grinv X b ) ) ( unel X ) .
Proof . intros .   assert  ( e' := maponpaths ( fun x : X => op x  ( grinv X b ) ) e ) . simpl in e' .  rewrite ( grrinvax X _ ) in e' .  apply e' . Defined .

Lemma grtopathsxy ( X : gr ) { a b : X } ( e : paths ( op a ( grinv X b ) ) ( unel X )  ) : paths a b  .
Proof . intros . assert ( e' := maponpaths ( fun x => op x b ) e ) . simpl in e' . rewrite ( assocax X ) in e' . rewrite ( grlinvax X ) in e' . rewrite ( lunax X ) in e' . rewrite ( runax X ) in e' . apply e' . Defined .

(** To rigs *)

Definition multlinvpair ( X : rig ) ( x : X ) := linvpair ( rigmultmonoid X ) x .

Definition multrinvpair ( X : rig ) ( x : X ) := rinvpair ( rigmultmonoid X ) x .

Definition multinvpair ( X : rig ) ( x : X ) := invpair ( rigmultmonoid X ) x .

Definition rigneq0andmultlinv ( X : rig ) ( n m : X ) ( isnm : neg ( paths ( n * m ) 0 )%rig ) : neg ( paths n 0 )%rig .
Proof . intros . intro e .  rewrite e in isnm .  rewrite ( rigmult0x X ) in isnm .  destruct ( isnm ( idpath _ ) ) .  Defined .

Definition rigneq0andmultrinv ( X : rig ) ( n m : X ) ( isnm : neg ( paths ( n * m ) 0 )%rig ) : neg ( paths m 0 )%rig .
Proof . intros . intro e .  rewrite e in isnm .  rewrite ( rigmultx0 _ ) in isnm .  destruct ( isnm ( idpath _ ) ) .  Defined .

(** To rings *)

Local Open Scope rng_scope.

Definition rngneq0andmultlinv ( X : rng ) ( n m : X ) ( isnm : neg ( paths ( n * m ) 0 ) ) : neg ( paths n 0 ) .
Proof . intros . intro e .  rewrite e in isnm .  rewrite ( rngmult0x X ) in isnm .  destruct ( isnm ( idpath _ ) ) .  Defined .

Definition rngneq0andmultrinv ( X : rng ) ( n m : X ) ( isnm : neg ( paths ( n * m ) 0 ) ) : neg ( paths m 0 ) .
Proof . intros . intro e .  rewrite e in isnm .  rewrite ( rngmultx0 _ ) in isnm .  destruct ( isnm ( idpath _ ) ) .  Defined .

Definition rngpossubmonoid ( X : rng ) { R : hrel X } ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) : @submonoids ( rngmultmonoid X ) .
Proof . intros . split with ( fun x => R x 0 ) . split .  intros x1 x2 . apply is1 . apply ( pr2 x1 ) .  apply ( pr2 x2 ) .  apply is2 . Defined .

Lemma isinvrngmultgtif ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( nc : neqchoice R ) ( isa : isasymm R ) : isinvrngmultgt X R .
Proof . intros . split .

intros a b rab0 ra0 . assert ( int : neg ( paths b 0 ) ) . intro e .  rewrite e in rab0 .  rewrite ( rngmultx0 X _ ) in rab0 .  apply ( isa _ _ rab0 rab0 ) . destruct ( nc _ _ int ) as [ g | l ] . apply g . set ( int' := rngmultgt0lt0 X is0 is1 ra0 l ) .  destruct ( isa _ _ rab0 int' ) .

intros a b rab0 rb0 . assert ( int : neg ( paths a 0 ) ) . intro e .  rewrite e in rab0 .  rewrite ( rngmult0x X _ ) in rab0 .  apply ( isa _ _ rab0 rab0 ) . destruct ( nc _ _ int ) as [ g | l ] . apply g . set ( int' := rngmultlt0gt0 X is0 is1 l rb0 ) .  destruct ( isa _ _ rab0 int' ) .  Defined .

(** ** Standard Algebraic Structures (cont.) Integral domains and Fileds.

Some of the notions condidered in this section were introduced in  C. Mulvey "Intuitionistic algebra and representations of rings". See also P.T. Johnstone "Rings, fields and spectra". We only consider here the strongest ("geometric") forms of the conditions of integrality and of being a field. In particular all our fileds have decidable equality and p-adic numbers or reals are not fileds in the sense of the definitions considered here.   *)

Local Open Scope rng_scope.

(** *** Integral domains *)

(** **** General definitions *)

Definition isnonzerorng ( X : rng ) := neg ( @paths X 1 0 ) .

Lemma isnonzerolinvel ( X : rng ) ( is : isnonzerorng X ) ( x : X ) ( x' : multlinvpair X x ) : neg ( paths ( pr1 x' ) 0 ) .
Proof . intros . apply ( negf ( maponpaths ( fun a : X => a * x ) ) ) .  assert ( e := pr2 x' ) . change ( paths ( pr1 x' * x ) 1 ) in e . change ( neg ( paths ( pr1 x' * x ) ( 0 * x ) ) ) .   rewrite e . rewrite ( rngmult0x X _ ) . apply is . Defined .

Lemma isnonzerorinvel ( X : rng ) ( is : isnonzerorng X ) ( x : X ) ( x' : multrinvpair X x ) : neg ( paths ( pr1 x' ) 0 ) .
Proof . intros . apply ( negf ( maponpaths ( fun a : X => x * a ) ) ) .  assert ( e := pr2 x' ) . change ( paths ( x * pr1 x' ) 1 ) in e . change ( neg ( paths ( x * pr1 x' ) ( x * 0 ) ) ) .   rewrite e . rewrite ( rngmultx0 X _ ) . apply is . Defined .

Lemma isnonzerofromlinvel ( X : rng ) ( is : isnonzerorng X ) ( x : X ) ( x' : multlinvpair X x ) : neg ( paths x 0 ) .
Proof .  intros .   apply ( negf ( maponpaths ( fun a : X => ( pr1 x' ) * a ) ) ) .  assert ( e := pr2 x' ) . change ( paths ( pr1 x' * x ) 1 ) in e . change ( neg ( paths ( pr1 x' * x ) ( ( pr1 x' ) * 0 ) ) ) .   rewrite e . rewrite ( rngmultx0 X _ ) . apply is . Defined .

Lemma isnonzerofromrinvel ( X : rng ) ( is : isnonzerorng X ) ( x : X ) ( x' : multrinvpair X x ) : neg ( paths x 0 ) .
Proof .  intros .   apply ( negf ( maponpaths ( fun a : X => a * ( pr1 x' ) ) ) ) .  assert ( e := pr2 x' ) . change ( paths ( x * pr1 x' ) 1 ) in e . change ( neg ( paths ( x * pr1 x' ) ( 0 * ( pr1 x' ) ) ) ) .   rewrite e . rewrite ( rngmult0x X _ ) . apply is . Defined .

Definition isintdom ( X : commrng ) := dirprod ( isnonzerorng X ) ( forall a1 a2 : X , paths ( a1 * a2 ) 0 -> hdisj ( eqset a1 0 ) ( eqset a2 0 ) ) .

Definition intdom := total2 ( fun X : commrng => isintdom X ) .
Definition pr1intdom : intdom -> commrng := @pr1 _ _ .
Coercion pr1intdom : intdom >-> commrng .

Definition nonzeroax ( X : intdom ) : neg ( @paths X 1 0 ) := pr1 ( pr2 X ) .
Definition intdomax ( X : intdom ) : forall a1 a2 : X , paths ( a1 * a2 ) 0 -> hdisj ( eqset a1 0 ) ( eqset a2 0 )  := pr2 ( pr2 X ) .

(** **** Computational lemmas for integral domains *)

Lemma intdomax2l ( X : intdom ) ( x y : X ) ( is : paths ( x * y ) 0 ) ( ne : neg ( paths x 0 ) ) : paths y 0 .
Proof . intros .  assert ( int := intdomax X _ _ is ) .  generalize ne .  assert ( int' : isaprop ( neg (paths x 0) -> paths y 0 ) ) . apply impred . intro . apply ( setproperty X _ _ ) .  generalize int .  simpl .  apply ( @hinhuniv _ ( hProppair _ int' ) ) .  intro ene . destruct ene as [ e'' | ne' ] .  destruct ( ne e'' ) . intro .  apply ne' .  Defined .

Lemma intdomax2r ( X : intdom ) ( x y : X ) ( is : paths ( x * y ) 0 ) ( ne : neg ( paths y 0 ) ) : paths x 0 .
Proof . intros .  assert ( int := intdomax X _ _ is ) .  generalize ne .  assert ( int' : isaprop ( neg (paths y 0) -> paths x 0 ) ) . apply impred . intro . apply ( setproperty X _ _ ) .  generalize int .  simpl .  apply ( @hinhuniv _ ( hProppair _ int' ) ) .  intro ene . destruct ene as [ e'' | ne' ] .   intro .  apply e'' . destruct ( ne ne' ) .  Defined .

Definition intdomneq0andmult ( X : intdom ) ( n m : X ) ( isn : neg ( paths n 0 ) ) ( ism : neg ( paths m 0 ) ) : neg ( paths ( n * m ) 0 ) .
Proof . intros . intro e . destruct ( ism ( intdomax2l X n m e isn  ) ) .  Defined .

Lemma intdomlcan ( X : intdom ) : forall a b c : X , neg ( paths c 0 ) -> paths ( c * a ) ( c * b ) -> paths a b .
Proof . intros X a b c ne e . apply ( @grtopathsxy ( rngaddabgr X ) a b ) . change ( paths ( a - b ) 0 ) . assert ( e' := grfrompathsxy ( rngaddabgr X ) e ) .  change ( paths ( ( c * a ) - ( c * b ) ) 0 ) in e' .  rewrite ( pathsinv0 ( rngrmultminus X _ _ ) ) in e' .  rewrite ( pathsinv0 ( rngldistr X _ _ c ) ) in e' . assert ( int := intdomax X _ _ e' ) .  generalize ne .  assert ( int' : isaprop ( neg (paths c 0) -> paths (a - b) 0 ) ) . apply impred . intro . apply ( setproperty X _ _ ) .  generalize int .  simpl .  apply ( @hinhuniv _ ( hProppair _ int' ) ) .  intro ene . destruct ene as [ e'' | ne' ] .  destruct ( ne e'' ) . intro .  apply ne' .  Defined .

Opaque intdomlcan .

Lemma intdomrcan ( X : intdom ) : forall a b c : X , neg ( paths c 0 ) -> paths ( a * c ) ( b * c ) -> paths a b .
Proof . intros X a b c ne e . apply ( @grtopathsxy ( rngaddabgr X ) a b ) . change ( paths ( a - b ) 0 ) . assert ( e' := grfrompathsxy ( rngaddabgr X ) e ) .  change ( paths ( ( a * c ) - ( b * c ) ) 0 ) in e' .  rewrite ( pathsinv0 ( rnglmultminus X _ _ ) ) in e' .  rewrite ( pathsinv0 ( rngrdistr X _ _ c ) ) in e' . assert ( int := intdomax X _ _ e' ) .  generalize ne .  assert ( int' : isaprop ( neg (paths c 0) -> paths (a - b) 0 ) ) . apply impred . intro . apply ( setproperty X _ _ ) .  generalize int .  simpl .  apply ( @hinhuniv _ ( hProppair _ int' ) ) .  intro ene . destruct ene as [ e'' | ne' ] .  intro .  apply e'' .  destruct ( ne ne' ) .  Defined .

Opaque intdomrcan .

Lemma intdomiscancelable ( X : intdom ) ( x : X ) ( is : neg ( paths x 0 ) ) : iscancelable ( @op2 X ) x .
Proof . intros . apply iscancelableif .  intros a b . apply ( intdomlcan X a b x is ) .  intros a b . apply ( intdomrcan X a b x is ) . Defined .

(** **** Multiplicative submonoid of non-zero elements *)

Definition intdomnonzerosubmonoid ( X : intdom ) : @subabmonoids ( rngmultabmonoid X ) .
Proof . intros . split with ( fun x : X => hProppair _ ( isapropneg ( paths x 0 ) ) ) . split .

intros a b . simpl in * .  intro e . set ( int := intdomax X ( pr1 a ) ( pr1 b ) e ) . clearbody int . generalize int . apply ( toneghdisj ) .  apply ( dirprodpair ( pr2 a ) ( pr2 b ) ) .

simpl .  apply ( nonzeroax X ) . Defined .

(** **** Relations similar to "greater" on integral domains *)

Definition intdomnonzerotopos ( X : intdom ) ( R : hrel X ) ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( x : intdomnonzerosubmonoid X ) : rngpossubmonoid X is1 is2 .
Proof . intros . destruct ( nc ( pr1 x ) 0 ( pr2 x ) ) as [ g | l ] . apply ( tpair _ ( pr1 x ) g ) . split with ( - ( pr1 x ) ) .  simpl . apply rngtogt0 . apply is0 .  rewrite ( rngminusminus X _ ) .  apply l . Defined .

(** *** Ring units ( i.e. multilicatively invertible elements ) *)

(** *** Fields *)

(** **** Main definitions *)

Definition isafield ( X : commrng ) := dirprod ( isnonzerorng X ) ( forall x : X , coprod ( multinvpair X x ) ( paths x 0 ) ) .

Definition fld := total2 ( fun X : commrng => isafield X ) .
Definition fldpair ( X : commrng ) ( is : isafield X ) : fld := tpair _ X is .
Definition pr1fld : fld -> commrng := @pr1 _ _ .

Definition fldtointdom ( X : fld ) : intdom .
Proof . intro . split with ( pr1 X ) .  split with ( pr1 ( pr2 X ) ) . intros a1 a2 . destruct ( pr2 ( pr2 X ) a1 ) as [ a1' | e0 ] .

intro e12 . rewrite ( pathsinv0 ( rngmultx0 ( pr1 X ) a1 ) ) in e12 . set ( e2 := lcanfromlinv _ _ _ _ ( invtolinv _ _ a1' ) e12 ) .  apply ( hinhpr _ ( ii2 e2 ) ) .

intro e12 . apply ( hinhpr _ ( ii1 e0 ) ) . Defined .

Coercion fldtointdom : fld >-> intdom .

Definition fldchoice { X : fld } ( x : X ) : coprod ( multinvpair X x ) ( paths x 0 ) := pr2 ( pr2 X ) x.

Definition fldmultinvpair ( X : fld ) ( x : X ) ( ne : neg ( paths x 0 ) ) : multinvpair X x .
Proof . intros . destruct ( fldchoice x ) as [ ne0 | e0 ] . apply ne0 . destruct ( ne e0 ) . Defined .

Definition fldmultinv { X : fld } ( x : X ) ( ne : neg ( paths x 0 ) ) : X := pr1 ( fldmultinvpair X x ne ) .

(** **** Field of fractions of an integral domain with decidable equality *)

Definition fldfracmultinvint ( X : intdom ) ( is : isdeceq X ) ( xa : dirprod X ( intdomnonzerosubmonoid X ) ) : dirprod X ( intdomnonzerosubmonoid X ) .
Proof .  intros . destruct ( is ( pr1 xa ) 0 ) as [ e0 | ne0 ] . apply ( dirprodpair 1 ( tpair ( fun x => neg ( paths x 0 ) ) 1 ( nonzeroax X ) ) ) . apply ( dirprodpair ( pr1 ( pr2 xa ) ) ( tpair ( fun x => neg ( paths x 0 ) ) ( pr1 xa ) ne0 ) ) .  Defined .

(** Note: we choose a strange from the mathematicians perspective approach to the definition of the multiplicative inverse on non-zero elements of a field due to the current, somewhat less than satisfactory, situation with computational behavior of our construction of set-quotients. The particular problem is that the weak equivalence between "quotient of subtype" and "subtype of a quotient" is not isomorphism in the syntactic category. This can be corrected by extension of the type system with tfc-terms. See discussion in hSet.v *)

Lemma fldfracmultinvintcomp  ( X : intdom ) ( is : isdeceq X ) : iscomprelrelfun ( eqrelcommrngfrac X ( intdomnonzerosubmonoid X ) ) ( eqrelcommrngfrac X ( intdomnonzerosubmonoid X ) ) ( fldfracmultinvint X is ) .
Proof . intros .  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 hinhfun . intro t2 .  unfold fldfracmultinvint .  destruct ( is (pr1 xa1) 0 ) as [ e1 | ne1 ] . destruct ( is (pr1 xa2) 0 ) as [ e2 | ne2 ] .

simpl .  split with ( tpair ( fun x => neg ( paths x 0 ) ) 1 ( nonzeroax X ) ) . apply idpath .

simpl . set ( aa0 := pr1 t2 ) . set ( a0 := pr1 aa0 ) . assert ( e := pr2 t2 ) . change ( paths ( x1 * a2 * a0 ) ( x2 * a1 * a0 ) ) in e .  change ( paths x1 0 ) in e1 . rewrite e1 in e . rewrite ( rngmult0x X _ ) in e .   rewrite ( rngmult0x X _ ) in e . assert ( e' := intdomax2r X _ _ ( pathsinv0 e ) ( pr2 aa0 ) ) .   assert ( e'' := intdomax2r X _ _ e' ( pr2 aa1 ) ) . destruct ( ne2 e'' ) .  destruct ( is (pr1 xa2) 0 ) as [ e2 | ne2 ] .

simpl . set ( aa0 := pr1 t2 ) . set ( a0 := pr1 aa0 ) . assert ( e := pr2 t2 ) . change ( paths ( x1 * a2 * a0 ) ( x2 * a1 * a0 ) ) in e .  change ( paths x2 0 ) in e2 . rewrite e2 in e . rewrite ( rngmult0x X _ ) in e .   rewrite ( rngmult0x X _ ) in e . assert ( e' := intdomax2r X _ _  e ( pr2 aa0 ) ) .   assert ( e'' := intdomax2r X _ _ e' ( pr2 aa2 ) ) . destruct ( ne1 e'' ) .

simpl .  set ( aa0 := pr1 t2 ) . set ( a0 := pr1 aa0 ) . assert ( e := pr2 t2 ) . split with aa0 . change ( paths ( a1 * x2 * a0 ) ( a2 * x1 * a0 ) ) .  change ( paths ( x1 * a2 * a0 ) ( x2 * a1 * a0 ) ) in e . rewrite ( rngcomm2 X a1 x2 ) .  rewrite ( rngcomm2 X a2 x1 ) .  apply ( pathsinv0 e ) .  Defined .

Opaque fldfracmultinvintcomp .

Definition fldfracmultinv0 ( X : intdom ) ( is : isdeceq X ) ( x : commrngfrac X ( intdomnonzerosubmonoid X ) ) : commrngfrac X ( intdomnonzerosubmonoid X ) := setquotfun _ _ _ ( fldfracmultinvintcomp X is ) x .

Lemma nonzeroincommrngfrac ( X : commrng ) ( S : @submonoids ( rngmultmonoid X ) ) ( xa : dirprod X S ) ( ne : neg ( paths ( setquotpr ( eqrelcommrngfrac X S ) xa ) ( setquotpr _ ( dirprodpair 0 ( unel S ) ) ) ) ) : neg ( paths ( pr1 xa ) 0 ) .
Proof . intros . set ( x := pr1 xa ) . set ( aa := pr2 xa ) .  assert ( e' := negf ( weqpathsinsetquot ( eqrelcommrngfrac X S ) _ _ ) ne ) . simpl in e' . generalize e' .   apply negf .  intro e .  apply hinhpr .  split with ( unel S ) .  change ( paths ( x * 1 * 1 ) ( 0 * ( pr1 aa ) * 1 ) ) . rewrite e . rewrite ( rngmult0x X _ ) .  rewrite ( rngmult0x X _ ) .   rewrite ( rngmult0x X _ ) .  rewrite ( rngmult0x X _ ) . apply idpath . Defined .

Opaque nonzeroincommrngfrac .

Lemma zeroincommrngfrac ( X : intdom ) ( S : @submonoids ( rngmultmonoid X ) ) ( is : forall s : S , neg ( paths ( pr1 s ) 0 ) ) ( x : X ) ( aa : S ) ( e : paths ( setquotpr ( eqrelcommrngfrac X S ) ( dirprodpair x aa ) ) ( setquotpr _ ( dirprodpair 0 ( unel S ) ) ) )  : paths x 0 .
Proof . intros . assert ( e' := invweq ( weqpathsinsetquot _ _ _ ) e ) .  simpl in e' .  generalize e' .  apply ( @hinhuniv _ ( hProppair _ ( setproperty X _ _ ) ) ) . intro t2 . simpl . set ( aa0 := pr1 t2 ) . set ( a0 := pr1 aa0 ) . assert ( e2 := pr2 t2 ) . set ( a := pr1 aa ) .  simpl in e2 . change ( paths ( x * 1 * a0 ) ( 0 * a * a0 ) ) in e2 . rewrite ( rngmult0x X _ ) in e2 .  rewrite ( rngmult0x X _ ) in e2 . rewrite ( rngrunax2 X _ ) in e2 . apply ( intdomax2r X x a0 e2 ( is aa0 ) ) . Defined .

Opaque zeroincommrngfrac .

Lemma isdeceqfldfrac  ( X : intdom ) ( is : isdeceq X ) : isdeceq ( commrngfrac X ( intdomnonzerosubmonoid X ) ) .
Proof . intros . apply isdeceqcommrngfrac .  intro a . apply isrcancelableif . intros b0 b1 e . apply ( intdomrcan X _ _ ( pr1 a ) ( pr2 a ) e ) .  apply is . Defined .

Lemma islinvinfldfrac ( X : intdom ) ( is : isdeceq X ) ( x : commrngfrac X ( intdomnonzerosubmonoid X ) ) ( ne : neg ( paths x 0 ) ) : paths ( ( fldfracmultinv0 X is x ) * x ) 1 .
Proof . intros X is . assert ( int : forall x0 , isaprop ( neg ( paths x0 0 ) ->  paths ( ( fldfracmultinv0 X is x0 ) * x0 ) 1 ) ) . intro x0 . apply impred. intro . apply ( setproperty (commrngfrac X (intdomnonzerosubmonoid X)) (fldfracmultinv0 X is x0 * x0) _ ) . apply ( setquotunivprop _ ( fun x0 => hProppair _ ( int x0 ) ) ) .  simpl . intros xa ne .  change ( paths ( setquotpr (eqrelcommrngfrac X (intdomnonzerosubmonoid X)) ( dirprodpair ( ( pr1 ( fldfracmultinvint X is xa ) ) * ( pr1 xa ) ) ( @op ( intdomnonzerosubmonoid X ) ( pr2 ( fldfracmultinvint X is xa ) ) ( pr2 xa ) ) ) ) ( setquotpr _ ( dirprodpair 1 ( tpair _ 1 ( nonzeroax X ) ) ) ) )  . apply ( weqpathsinsetquot ) .  unfold fldfracmultinvint . simpl . destruct ( is (pr1 xa) 0  ) as [ e0 | ne0' ] .

destruct ( nonzeroincommrngfrac X ( intdomnonzerosubmonoid X ) xa ne e0 ) .

apply hinhpr .  split with ( tpair ( fun a => neg ( paths a 0 ) ) 1 ( nonzeroax X ) ) .  set ( x := ( pr1 xa ) : X ) . set ( aa := pr2 xa ) . set ( a := ( pr1 aa ) : X ) . simpl .  change ( paths ( a * x * 1  * 1 ) ( 1 * ( x * a ) * 1 ) ) .  rewrite ( rngcomm2 X a x ) .  rewrite ( rngrunax2 X _ ) .  rewrite ( rngrunax2 X _ ) .  rewrite ( rngrunax2 X _ ) . rewrite ( rnglunax2 X _ ) .    apply idpath . Defined .

Opaque islinvinfldfrac .

Lemma isrinvinfldfrac ( X : intdom ) ( is : isdeceq X ) ( x : commrngfrac X ( intdomnonzerosubmonoid X ) ) ( ne : neg ( paths x 0 ) ) : paths ( x * ( fldfracmultinv0 X is x ) ) 1 .
Proof . intros. rewrite ( rngcomm2 _ _ _ ) . apply islinvinfldfrac . apply ne . Defined .

Definition fldfrac ( X : intdom ) ( is : isdeceq X ) : fld .
Proof . intros . split with ( commrngfrac X ( intdomnonzerosubmonoid X ) ) . split .

intro e . assert ( e' := zeroincommrngfrac X ( intdomnonzerosubmonoid X ) ( fun a : ( intdomnonzerosubmonoid X ) => pr2 a ) 1 ( unel ( intdomnonzerosubmonoid X ) ) e ) . apply ( nonzeroax X e' ) .

intro x .  destruct ( isdeceqfldfrac X is x 0 ) as [ e | ne ] .

apply ( ii2 e ) .

apply ii1 . split with ( fldfracmultinv0 X is x ) . split . apply ( islinvinfldfrac X is x ne )  .   apply ( isrinvinfldfrac X is x ne ) .  Defined .

(** **** Canonical homomorphism to the field of fractions *)

Definition tofldfrac ( X : intdom ) ( is : isdeceq X ) ( x : X ) : fldfrac X is := setquotpr _ ( dirprodpair x ( tpair ( fun x => neg ( paths x 0 ) ) 1 ( nonzeroax X ) ) ) .

Definition isbinop1funtofldfrac ( X : intdom ) ( is : isdeceq X ) : @isbinopfun ( rngaddabgr X ) ( rngaddabgr ( fldfrac X is ) ) ( tofldfrac X is ) :=  isbinop1funtocommrngfrac X _ .

Lemma isunital1funtofldfrac ( X : intdom ) ( is : isdeceq X ) : paths ( tofldfrac X is 0 ) 0 .
Proof . intros. apply idpath . Defined .

Definition isaddmonoidfuntofldfrac ( X : intdom ) ( is : isdeceq X ) : @ismonoidfun  ( rngaddabgr X ) ( rngaddabgr ( fldfrac X is ) ) ( tofldfrac X is ) := dirprodpair ( isbinop1funtofldfrac X is ) ( isunital1funtofldfrac X is ) .

Definition tofldfracandminus0 ( X : intdom ) ( is : isdeceq X ) ( x : X ) : paths ( tofldfrac X is ( - x ) ) ( - tofldfrac X is x ) := tocommrngfracandminus0 _ _ x  .

Definition tofldfracandminus ( X : intdom ) ( is : isdeceq X ) ( x y : X ) : paths ( tofldfrac X is ( x - y ) ) ( tofldfrac X is x - tofldfrac X is y ) := tocommrngfracandminus _ _ x y .

Definition isbinop2funtofldfrac  ( X : intdom ) ( is : isdeceq X ) : @isbinopfun ( rngmultmonoid X ) ( rngmultmonoid ( fldfrac X is ) ) ( tofldfrac X is ) := isbinopfuntoabmonoidfrac ( rngmultabmonoid X ) ( intdomnonzerosubmonoid X ) .

Opaque isbinop2funtofldfrac .

Lemma isunital2funtofldfrac  ( X : intdom ) ( is : isdeceq X ) : paths ( tofldfrac X is 1 ) 1 .
Proof . intros. apply idpath . Defined .

Opaque isunital2funtofldfrac .

Definition ismultmonoidfuntofldfrac  ( X : intdom ) ( is : isdeceq X ) : @ismonoidfun  ( rngmultmonoid X ) ( rngmultmonoid ( fldfrac X is ) ) ( tofldfrac X is ) := dirprodpair ( isbinop2funtofldfrac X is ) ( isunital2funtofldfrac X is ) .

Definition isrngfuntofldfrac ( X : intdom ) ( is : isdeceq X ) : @isrngfun X ( fldfrac X is ) ( tofldfrac X is ) := dirprodpair ( isaddmonoidfuntofldfrac X is ) ( ismultmonoidfuntofldfrac X is ) .

Definition isincltofldfrac ( X : intdom ) ( is : isdeceq X ) : isincl ( tofldfrac X is ) := isincltocommrngfrac X ( intdomnonzerosubmonoid X ) ( fun x : _ =>  pr2 ( intdomiscancelable X ( pr1 x ) ( pr2 x ) ) ) .

(** *** Relations similar to "greater" on fields of fractions

Our approach here is slightly different from the tranditional one used for example in Bourbaki Algebra II , Ch. VI , Section 2 where one starts with a total ordering on a ring and extends it to its field of fractions. This situation woud be exemplified by the extension of "greater or equal" from integers to rationals. We have chosen to use instead as our archetypical example the extension of "greater" from integers to rationals. There is no particular difference between the two choices for types with decidable equality but in the setting of general rings in constructive mathematics the relations such as "greater" appear to be more fundamental than relations such as "greater or equal". For example, "greater or equal" on constructive real numbers can be obtained from "greater" but not vice versa.  *)

(** **** Description of the field of fractions as the ring of fractions with respect to the submonoid of "positive" elements *)

Definition weqfldfracgtint_f ( X : intdom ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( xa : dirprod X ( intdomnonzerosubmonoid X ) ) : dirprod X ( rngpossubmonoid X is1 is2 ) .
Proof . intros . destruct ( nc ( pr1 ( pr2 xa ) ) 0 ( pr2 ( pr2 xa ) ) ) as [ g | l ] .  apply ( dirprodpair ( pr1 xa ) ( tpair _ ( pr1 ( pr2 xa ) ) g ) ) . split with ( - ( pr1 xa ) ) .  split with ( - ( pr1 ( pr2 xa ) ) ) .  simpl . apply ( rngfromlt0 X is0 l ) . Defined .

Lemma weqfldfracgtintcomp_f ( X : intdom ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) : iscomprelrelfun ( eqrelcommrngfrac X ( intdomnonzerosubmonoid X ) ) ( eqrelcommrngfrac X ( rngpossubmonoid X is1 is2 ) ) ( weqfldfracgtint_f X is0 is1 is2 nc ) .
Proof . intros . intros xa1 xa2 . simpl . set ( x1 := pr1 xa1 ) . set ( aa1 := pr2 xa1 ) . set ( a1 := pr1 aa1 ) . set ( x2 := pr1 xa2 ) . set ( aa2 := pr2 xa2 ) . set ( a2 := pr1 aa2 ) . apply hinhfun .  intro t2 . split with ( tpair ( fun x => R x 0 ) 1 is2 ) .  set ( aa0 := pr1 t2 ) . set ( a0 := pr1 aa0 ) . assert ( e := pr2 t2 ) . change ( paths ( x1 * a2 * a0 ) ( x2 * a1 * a0 ) ) in e .  unfold weqfldfracgtint_f . destruct ( nc (pr1 (pr2 xa1)) 0 (pr2 (pr2 xa1)) ) as [ g1 | l1 ] .  destruct ( nc (pr1 (pr2 xa2)) 0 (pr2 (pr2 xa2)) ) as [ g2 | l2 ] .

simpl .  rewrite ( rngrunax2 X _ ) . rewrite ( rngrunax2 X _ ) . apply ( intdomrcan X _ _ _ ( pr2 aa0 ) e ) .

simpl .   rewrite ( rngrunax2 X _ ) . rewrite ( rngrunax2 X _ ) . rewrite (rngrmultminus X _ _ ) . rewrite ( rnglmultminus X _ _ ) . apply ( maponpaths ( fun x : X => - x ) ) .  apply ( intdomrcan X _ _ _ ( pr2 aa0 ) e ) .  destruct ( nc (pr1 (pr2 xa2)) 0 (pr2 (pr2 xa2)) ) as [ g2 | l2 ] .

simpl .   rewrite ( rngrunax2 X _ ) . rewrite ( rngrunax2 X _ ) . rewrite (rngrmultminus X _ _ ) . rewrite ( rnglmultminus X _ _ ) . apply ( maponpaths ( fun x : X => - x ) ) .  apply ( intdomrcan X _ _ _ ( pr2 aa0 ) e ) .

simpl .    rewrite ( rngrunax2 X _ ) . rewrite ( rngrunax2 X _ ) . rewrite (rngrmultminus X _ _ ) . rewrite ( rnglmultminus X _ _ ) .  rewrite (rngrmultminus X _ _ ) . rewrite ( rnglmultminus X _ _ ) . apply ( maponpaths ( fun x : X => - - x ) ) .  apply ( intdomrcan X _ _ _ ( pr2 aa0 ) e ) . Defined .

Opaque weqfldfracgtintcomp_f .

Definition weqfldfracgt_f ( X : intdom ) ( is : isdeceq X ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) : fldfrac X is -> commrngfrac X ( rngpossubmonoid X is1 is2 ) := setquotfun _ _ _ ( weqfldfracgtintcomp_f X is0 is1 is2 nc ) .

Definition weqfldfracgtint_b ( X : intdom ) { R : hrel X } ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( ir : isirrefl R ) ( xa : dirprod X ( rngpossubmonoid X is1 is2 ) ) : dirprod X ( intdomnonzerosubmonoid X ) := dirprodpair ( pr1 xa ) ( tpair _ ( pr1 ( pr2 xa ) ) ( rtoneq ir ( pr2 ( pr2 xa ) ) ) ) .

Lemma weqfldfracgtintcomp_b ( X : intdom ) { R : hrel X } ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( ir : isirrefl R ) : iscomprelrelfun ( eqrelcommrngfrac X ( rngpossubmonoid X is1 is2 ) ) ( eqrelcommrngfrac X ( intdomnonzerosubmonoid X ) ) ( weqfldfracgtint_b X is1 is2 ir ) .
Proof . intros . intros xa1 xa2 . simpl .  apply hinhfun .  intro t2 . split with ( tpair _ ( pr1 ( pr1 t2 ) ) ( rtoneq ir ( pr2 ( pr1 t2 ) ) ) ) .   apply ( pr2 t2 ) .  Defined .

Definition weqfldfracgt_b ( X : intdom ) ( is : isdeceq X ) { R : hrel X } ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( ir : isirrefl R ) : commrngfrac X ( rngpossubmonoid X is1 is2 ) -> fldfrac X is := setquotfun _ _ _ ( weqfldfracgtintcomp_b X is1 is2 ir ) .

Definition weqfldfracgt ( X : intdom ) ( is : isdeceq X ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( ir : isirrefl R ) : weq ( fldfrac X is ) ( commrngfrac X ( rngpossubmonoid X is1 is2 ) ) .
Proof . intros . set ( f := weqfldfracgt_f X is is0 is1 is2 nc ) . set ( g := weqfldfracgt_b X is is1 is2 ir ) .  split with f .

assert ( egf : forall a , paths ( g ( f a ) ) a ) .  unfold fldfrac. simpl . apply ( setquotunivprop _ ( fun a => hProppair _ ( isasetsetquot _ ( g ( f a ) ) a  ) ) ) . intro xa .  simpl . change ( paths ( setquotpr (eqrelcommrngfrac X (intdomnonzerosubmonoid X)) ( weqfldfracgtint_b X is1 is2 ir ( weqfldfracgtint_f X is0 is1 is2 nc xa ) ) ) ( setquotpr (eqrelcommrngfrac X (intdomnonzerosubmonoid X)) xa ) ) . apply ( weqpathsinsetquot ) . simpl . apply hinhpr . split with ( tpair ( fun x => neg ( paths x 0 ) ) 1 ( nonzeroax X ) ) . simpl . unfold weqfldfracgtint_f .  destruct ( nc (pr1 (pr2 xa)) 0 (pr2 (pr2 xa)) ) as [ g' | l' ] .

simpl . apply idpath .

simpl .  rewrite (rngrmultminus X _ _ ) . rewrite ( rnglmultminus X _ _ ) . apply idpath .

assert ( efg : forall a , paths ( f ( g a ) ) a ) .  unfold fldfrac. simpl . apply ( setquotunivprop _ ( fun a => hProppair _ ( isasetsetquot _ ( f ( g a ) ) a  ) ) ) . intro xa .  simpl .
change ( paths ( setquotpr _ ( weqfldfracgtint_f X is0 is1 is2 nc ( weqfldfracgtint_b X is1 is2 ir xa ) ) ) ( setquotpr (eqrelcommrngfrac X (rngpossubmonoid X is1 is2)) xa ) ) . apply weqpathsinsetquot . simpl . apply hinhpr .  split with ( tpair ( fun x => R x 0 ) 1 is2 ) .  unfold weqfldfracgtint_f .   unfold weqfldfracgtint_b . simpl . set ( int := nc (pr1 (pr2 xa)) 0 (rtoneq ir (pr2 (pr2 xa)))  ). change ( nc (pr1 (pr2 xa)) 0 (rtoneq ir (pr2 (pr2 xa))) ) with int . destruct int as [ g' | l' ] .

simpl . apply idpath .

simpl .   rewrite (rngrmultminus X _ _ ) . rewrite ( rnglmultminus X _ _ ) . apply idpath .

apply ( gradth _ _ egf efg ) . Defined .

Lemma isrngfunweqfldfracgt_b ( X : intdom ) ( is : isdeceq X ) { R : hrel X } ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( ir : isirrefl R ) : isrngfun ( weqfldfracgt_b X is is1 is2 ir ) .
Proof . intros . set ( g :=  weqfldfracgt_b X is is1 is2 ir ) . set ( g0 := weqfldfracgtint_b X is1 is2 ir ) . split .

split .

unfold isbinopfun . change ( forall x x' : commrngfrac X ( rngpossubmonoid X is1 is2 )  , paths ( g ( x + x' ) ) ( ( g x ) + ( g x' ) ) ) .  apply ( setquotuniv2prop _ ( fun x x' : commrngfrac X ( rngpossubmonoid X is1 is2 ) => hProppair _ ( setproperty (fldfrac X is) ( g ( x + x' ) ) ( ( g x ) + ( g x' ) ) ) ) ) . intros xa1 xa2 .  change ( paths ( setquotpr (eqrelcommrngfrac X ( intdomnonzerosubmonoid X ) ) ( g0 ( commrngfracop1int X (rngpossubmonoid X is1 is2) xa1 xa2 ) ) ) ( setquotpr (eqrelcommrngfrac X ( intdomnonzerosubmonoid X )) ( commrngfracop1int  X ( intdomnonzerosubmonoid X ) ( g0 xa1 ) ( g0 xa2 ) ) ) )  . apply ( maponpaths ( setquotpr _ ) ) .  unfold g0 .  unfold weqfldfracgtint_b . unfold commrngfracop1int . simpl . apply ( pathsdirprod ) .  apply idpath . destruct xa1 as [ x1 aa1 ] .   destruct xa2 as [ x2 aa2 ] .  simpl . destruct aa1 as [ a1 ia1 ] . destruct aa2 as [ a2 ia2 ] . simpl .  apply ( invmaponpathsincl ( @pr1 _ _ ) ( isinclpr1 _ ( fun a => ( isapropneg ( paths a 0 ) ) ) ) ( tpair _ (a1 * a2) (rtoneq ir (is1 a1 a2 ia1 ia2)) ) (carrierpair
        (fun x : pr1 X =>
         hProppair (paths x 0 -> empty) (isapropneg (paths x 0)))
        (a1 * a2)
        (fun e : paths (a1 * a2) 0 =>
         toneghdisj (dirprodpair (rtoneq ir ia1) (rtoneq ir ia2))
           (intdomax X a1 a2 e))) ( idpath _ ) ) .

change ( paths ( setquotpr (eqrelcommrngfrac X ( intdomnonzerosubmonoid X )) ( g0 ( dirprodpair 0 ( tpair _ 1 is2 ) ) ) ) ( setquotpr _ ( dirprodpair 0 ( tpair _ 1 ( nonzeroax X ) ) ) ) ) . apply ( maponpaths ( setquotpr _ ) ) .  unfold g0 .  unfold weqfldfracgtint_b . simpl . apply pathsdirprod . apply idpath .  apply ( invmaponpathsincl ( @pr1 _ _ ) ( isinclpr1 _ ( fun a => ( isapropneg ( paths a 0 ) ) ) ) ( tpair _ 1 ( rtoneq ir is2 ) ) ( tpair _  1 ( nonzeroax X ) ) ) .  simpl . apply idpath .

split .

unfold isbinopfun . change ( forall x x' : commrngfrac X ( rngpossubmonoid X is1 is2 )  , paths ( g ( x * x' ) ) ( ( g x ) * ( g x' ) ) ) .  apply ( setquotuniv2prop _ ( fun x x' : commrngfrac X ( rngpossubmonoid X is1 is2 ) => hProppair _ ( setproperty (fldfrac X is) ( g ( x * x' ) ) ( ( g x ) * ( g x' ) ) ) ) ) . intros xa1 xa2 .  change ( paths ( setquotpr (eqrelcommrngfrac X ( intdomnonzerosubmonoid X ) ) ( g0 ( commrngfracop2int X (rngpossubmonoid X is1 is2) xa1 xa2 ) ) ) ( setquotpr (eqrelcommrngfrac X ( intdomnonzerosubmonoid X )) ( commrngfracop2int  X ( intdomnonzerosubmonoid X ) ( g0 xa1 ) ( g0 xa2 ) ) ) )  . apply ( maponpaths ( setquotpr _ ) ) .  unfold g0 .  unfold weqfldfracgtint_b . unfold commrngfracop2int . unfold abmonoidfracopint .  simpl . apply ( pathsdirprod ) .  apply idpath . destruct xa1 as [ x1 aa1 ] .   destruct xa2 as [ x2 aa2 ] .  simpl . destruct aa1 as [ a1 ia1 ] . destruct aa2 as [ a2 ia2 ] . simpl .  apply ( invmaponpathsincl ( @pr1 _ _ ) ( isinclpr1 _ ( fun a => ( isapropneg ( paths a 0 ) ) ) ) ( tpair _ ( a1 * a2 ) ( rtoneq ir (is1 a1 a2 ia1 ia2) ) ) (carrierpair
        (fun x : pr1 X =>
         hProppair (paths x 0 -> empty) (isapropneg (paths x 0)))
        (a1 * a2)
        (fun e : paths (a1 * a2) 0 =>
         toneghdisj (dirprodpair (rtoneq ir ia1) (rtoneq ir ia2))
           (intdomax X a1 a2 e))) ( idpath _ ) ) .

change ( paths ( setquotpr (eqrelcommrngfrac X ( intdomnonzerosubmonoid X )) ( g0 ( dirprodpair 1 ( tpair _ 1 is2 ) ) ) ) ( setquotpr _ ( dirprodpair 1 ( tpair _ 1 ( nonzeroax X ) ) ) ) ) . apply ( maponpaths ( setquotpr _ ) ) .  unfold g0 .  unfold weqfldfracgtint_b . simpl . apply pathsdirprod . apply idpath .  apply ( invmaponpathsincl ( @pr1 _ _ ) ( isinclpr1 _ ( fun a => ( isapropneg ( paths a 0 ) ) ) ) ( tpair _ 1 ( rtoneq ir is2 ) ) ( tpair _ 1 ( nonzeroax X ) ) ) .  simpl . apply idpath . Defined .

Opaque isrngfunweqfldfracgt_b .

Lemma isrngfunweqfldfracgt_f ( X : intdom ) ( is : isdeceq X ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( ir : isirrefl R ) : isrngfun ( weqfldfracgt_f X is is0 is1 is2 nc ) .
Proof . intros . unfold weqfldfracgt_f .  set ( int := rngisopair ( invweq ( weqfldfracgt X is is0 is1 is2 nc ir ) ) ( isrngfunweqfldfracgt_b X is is1 is2 ir ) ) . change ( @isrngfun (fldfrac X is) (commrngfrac X (rngpossubmonoid X is1 is2)) ( invmap int ) ) .  apply isrngfuninvmap . Defined .

Opaque isrngfunweqfldfracgt_f .

(** **** Definition and properties of "greater" on the field of fractions *)

Definition fldfracgt ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) : hrel ( fldfrac X is ) := fun a b => commrngfracgt X ( rngpossubmonoid X is1 is2 ) is0 is1 ( fun c r => r )  ( weqfldfracgt_f X is is0 is1 is2 nc a ) ( weqfldfracgt_f X is is0 is1 is2 nc b ) .

Lemma isrngmultfldfracgt ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( ir : isirrefl R ) : isrngmultgt ( fldfrac X is ) ( fldfracgt X is is0 is1 is2 nc ) .
Proof . intros . apply ( rngmultgtandfun ( rngfunconstr  ( isrngfunweqfldfracgt_f X is is0 is1 is2 nc ir ) ) ) .  apply isrngmultcommrngfracgt . Defined .

Opaque isrngmultfldfracgt .

Lemma isrngaddfldfracgt ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( ir : isirrefl R ) : @isbinophrel ( rngaddabgr ( fldfrac X is ) ) ( fldfracgt X is is0 is1 is2 nc ) .
Proof . intros . apply ( rngaddhrelandfun ( rngfunconstr  ( isrngfunweqfldfracgt_f X is is0 is1 is2 nc ir ) ) ) .  apply isrngaddcommrngfracgt . Defined .

Opaque isrngaddfldfracgt .

Lemma istransfldfracgt ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( isr : istrans R ) : istrans ( fldfracgt X is is0 is1 is2 nc ) .
Proof . intros . intros a b c . unfold fldfracgt .  apply istransabmonoidfracrel .  apply isr . Defined .

Opaque istransfldfracgt .

Lemma isirreflfldfracgt ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( isr : isirrefl R ) : isirrefl ( fldfracgt X is is0 is1 is2 nc ) .
Proof . intros .   intros a .  unfold fldfracgt  . apply isirreflabmonoidfracrel . apply isr .  Defined .

Opaque isirreflfldfracgt .

Lemma isasymmfldfracgt ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( isr : isasymm R ) : isasymm ( fldfracgt X is is0 is1 is2 nc ) .
Proof . intros .  intros a b .  unfold fldfracgt  . apply isasymmabmonoidfracrel . apply isr . Defined .

Opaque  isasymmfldfracgt .

Lemma iscotransfldfracgt ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( isr : iscotrans R ) : iscotrans ( fldfracgt X is is0 is1 is2 nc ) .
Proof . intros . intros a b c .  unfold fldfracgt  . apply iscotransabmonoidfracrel . apply isr . Defined .

Opaque iscotransfldfracgt .

Lemma isantisymmnegfldfracgt  ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( ir : isirrefl R ) ( isr : isantisymmneg R ) : isantisymmneg ( fldfracgt X is is0 is1 is2 nc ) .
Proof . intros .  assert ( int : isantisymmneg ( commrngfracgt X ( rngpossubmonoid X is1 is2 ) is0 is1 ( fun c r => r ) ) ) . unfold commrngfracgt . apply ( isantisymmnegabmonoidfracrel (rngmultabmonoid X) (rngpossubmonoid X is1 is2)
        (ispartbinopcommrngfracgt X (rngpossubmonoid X is1 is2) is0 is1
           (fun (c : X) (r : (rngpossubmonoid X is1 is2) c) => r))). apply isr .

intros a b n1 n2 . set ( e := int _ _ n1 n2 ) .  apply ( invmaponpathsweq ( weqfldfracgt X is is0 is1 is2 nc ir )  _ _ e ) . Defined .

Opaque isantisymmnegfldfracgt .

Definition isdecfldfracgt ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) ( nc : neqchoice R ) ( isa : isasymm R ) ( isr : isdecrel R ) : isdecrel ( fldfracgt X is is0 is1 is2 nc ) .
Proof . intros .  unfold fldfracgt . intros a b . apply isdecabmonoidfracrel .   apply ( pr1 ( isinvrngmultgtaspartinvbinophrel X R is0 ) ) .  apply isinvrngmultgtif . apply is0 . apply is1 . apply nc .  apply isa .  apply isr .  Defined .

(** **** Relations and the canonical homomorphism to the field of fractions *)

Definition iscomptofldfrac ( X : intdom ) ( is : isdeceq X ) { L : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) L ) ( is1 : isrngmultgt X L )  ( is2 : L 1 0 ) ( nc : neqchoice L ) ( isa : isasymm L ) : iscomprelrelfun L ( fldfracgt X is is0 is1 is2 nc ) ( tofldfrac X is ) .
Proof . intros . intros x1 x2 l . assert ( int := iscomptocommrngfrac X ( rngpossubmonoid X is1 is2 ) is0 is1 ( fun c r => r )  ) . simpl in int .  unfold fldfracgt . unfold iscomprelrelfun in int .  assert ( ee : forall x : X , paths (tocommrngfrac X (rngpossubmonoid X is1 is2) x) (weqfldfracgt_f X is is0 is1 is2 nc (tofldfrac X is x)) ) .  intros x .  change (tocommrngfrac X (rngpossubmonoid X is1 is2) x) with (  setquotpr (eqrelcommrngfrac X (rngpossubmonoid X is1 is2)) ( dirprodpair x ( tpair ( fun a => L a 0 ) _ is2 ) ) ) . change (weqfldfracgt_f X is is0 is1 is2 nc (tofldfrac X is x)) with (  setquotpr (eqrelcommrngfrac X (rngpossubmonoid X is1 is2)) ( weqfldfracgtint_f X is0 is1 is2 nc ( dirprodpair x ( tpair ( fun a => neg ( paths a 0 ) ) 1 ( nonzeroax X ) ) ) ) ) . apply ( maponpaths ( setquotpr (eqrelcommrngfrac X (rngpossubmonoid X is1 is2)) ) ) . unfold weqfldfracgtint_f .  simpl . destruct ( nc 1 0 (nonzeroax X)  ) as [ l' | nl ] .

apply pathsdirprod .  apply idpath .  apply ( invmaponpathsincl _ ( isinclpr1 _ ( fun a => ( pr2 ( L a 0 ) ) ) ) ) . apply idpath .

destruct ( isa _ _ is2 nl ) .

assert  ( int' := int x1 x2 ) .   rewrite ( ee x1 ) in int' .   rewrite ( ee x2 ) in int' . apply int' .  apply l . Defined .

Opaque iscomptofldfrac .

(* End of the file algebra1d.v *)


Require Import Orders OrdersEx.

Module PairUsualOrderedType (O1 O2 : UsualOrderedType) <: UsualOrderedType.
  Definition t := prod O1.t O2.t.

  (* This is weird:
    Without this line, the module complains about
    the form of the equality props when you close
    the module. The fields this thing encomapsses
    are just definitions w/in the module and
    shouldn't need to be parameterized, right?
  *)
  Include HasUsualEq <+ UsualIsEq.

  Definition lt x y :=
    O1.lt (fst x) (fst y) \/
    (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)).

  Lemma lt_strorder : StrictOrder lt.
  Proof.
    constructor.
    {
      unfold Irreflexive.
      unfold Reflexive, complement.
      intros. destruct x as (x1, x2).
      unfold lt in H.
      destruct H as [H | H].
      destruct (O1.lt_strorder) as [H0 H1].
      apply H0 in H; auto.
      destruct (O2.lt_strorder) as [H0 H1].
      destruct H as [H H2].
      apply H0 in H2; auto.
    }
    {
      unfold Transitive. intros.
      unfold lt in *.
      destruct H as [H | H]; destruct H0 as [H0 | H0].
      {
        left.
        destruct (O1.lt_strorder) as [H1 H2].
        apply H2 with (y := (fst y)); auto.
      }
      {
        left. destruct H0 as [H0 H1].
        unfold O1.eq in H0.
        rewrite H0 in H. auto.
      }
      {
        left. destruct H as [H  H1].
        unfold O1.eq in H. rewrite <- H in H0.
        auto.
      }
      {
        right.
        destruct H as [H H'].
        destruct H0 as [H0 H0'].
        split. unfold O1.eq in *.
        rewrite H; auto.
        destruct O2.lt_strorder as [H1 H1'].
        apply H1' with (y :=  snd y); auto.
      }
    }
  Qed.

  Lemma lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt.
  Proof.
    constructor; intros; subst; auto.
  Qed.

  Definition compare (x y : t) : comparison :=
    let (x1, x2) := x in
    let (y1, y2) := y in
      match O1.compare x1 y1 with
      | Lt => Lt
      | Gt => Gt
      | Eq =>
          match O2.compare x2 y2 with
          | Lt => Lt
          | Gt => Gt
          | Eq => Eq
          end
      end.

  Lemma compare_spec :
    forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y).
  Proof.
    intros.
    case_eq (compare x y); intros;
    constructor; destruct x as (x1, x2), y as (y1, y2);
    unfold compare in H;
    destruct (O1.compare_spec x1 y1);
    destruct (O2.compare_spec x2 y2);
    subst; auto; try congruence;
    unfold lt, O1.eq;
    try solve [ right; split; auto | left; auto].
  Qed.

  Lemma eq_dec : forall x y : t, {x = y} + {x <> y}.
  Proof.
    destruct x as (x1, x2), y as (y1, y2).
    destruct (O1.eq_dec x1 y1);
    destruct (O2.eq_dec x2 y2);
    [left; f_equal; auto | right | right | right];
    intros H; inversion H; congruence.
  Qed.

End PairUsualOrderedType.


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
(* Require Import Coq.Strings.String. *)
Require Import Coq.Lists.List.
Import ListNotations.
Require Export ExtLib.Structures.Monads.
Import MonadNotation.

Require Import Coq.Program.Basics.

From QuickChick Require Import QuickChick Tactics Instances.
Import QcNotation.
Import QcDefaultNotation. Open Scope qc_scope.

Require Import Equalities.

Set Bullet Behavior "Strict Subproofs".

Inductive symbol := a | b | c.
Instance symbol_dec (x y : symbol) : Dec (x = y).
Proof. dec_eq. Defined.
Derive Show for symbol.

Definition word := list symbol.
Instance word_dec (x y : word) : Dec (x = y).
Proof. dec_eq. Defined.

Definition example_dyck : word := [a;b;c;a;b;c;a;a;b;b;c;c].
Definition example_dyck2 : word := [a;a;b;c;a;b;c;a;a;b;b;c;c;b;c].

Definition count (s: symbol) (w : word) : nat :=
  count_occ (fun x y => dec_if_dec_eq x y (symbol_dec x y)) w s.

Compute (count a example_dyck).

Fixpoint proper_prefixes' (a b c : nat) (w : word) : bool :=
  if (a <? b) || (b <? c) then
    false
  else
    match w with
    | [] => true
    | s :: w' =>
        match s with
        | a => proper_prefixes' (a + 1) b c w'
        | b => proper_prefixes' a (b + 1) c w'
        | c => proper_prefixes' a b (c + 1) w'
        end
    end.

Definition proper_prefixes : word -> bool := proper_prefixes' 0 0 0.

Definition dyck (w : word) : Prop :=
  (count a w = count b w) /\
  (count b w = count c w) /\
  (proper_prefixes w = true).

Definition dyckb (w : word) : bool :=
  (count a w =? count b w) &&
  (count b w =? count c w) &&
  (eqb (proper_prefixes w) true).

Example test_isdyck :
  dyck example_dyck.
Proof. firstorder. Qed.

Example test_isdyck2 :
  dyckb example_dyck = true.
Proof. firstorder. Qed.

Derive (Show, GenSized, Shrink, Arbitrary) for symbol.

Definition insert (i : nat) (s : symbol) (w : word) : word :=
  firstn i w ++ [s] ++ skipn i w.
(* Compute (insert 1 c [a; a; a; b; c; b; c]). *)

Fixpoint genDyckSized (size : nat) : G word :=
  match size with
  (* step: non-deterministically insert abc-triplet *)
  | (S (S (S size'))) =>
    w <- genDyckSized size';;
    (* insert 'a' *)
    ai <- choose (0, length w) ;;
    wa <- ret (insert ai a w) ;;
    (* insert 'b' *)
    bi <- choose (ai + 1, length w + 1) ;;
    wab <- ret (insert bi b wa) ;;
    (* insert 'c' *)
    ci <- choose (bi + 1, length w + 2) ;;
    wabc <- ret (insert ci c wab) ;;
    ret wabc
  (* base: empty Dyck word *)
  | _ => ret [a; b; c]
  end.

Instance genDyck : Gen word :=
  { arbitrary := sized genDyckSized }.

Definition genDyckWord : G word := @arbitrary word genDyck.

Sample genDyckWord.

Definition index : Type := nat.

Definition indexed_word : Type := list (index * symbol).

Definition Match : Type := index * index * index.

Definition Policy : Type := word -> list Match.

Fixpoint cmp'
  (s_a : list index) (s_ab : list (index * index)) (w : indexed_word) : list Match :=
  match w with
  | [] => []
  | (i,x) :: rest =>
    match x with
    | a => cmp' (s_a ++ [i]) s_ab rest
    | b => let ai := last s_a 0
           in  cmp' (removelast s_a) (s_ab ++ [(ai, i)]) rest
    | c => let (ai, bi) := last s_ab (0, 0)
           in  (ai, bi, i) :: cmp' s_a (removelast s_ab) rest
    end
  end.

Fixpoint indexWord (i : nat) (w : word) : indexed_word :=
  match w with
  | []    => []
  | x::xs => (i, x) :: indexWord (S i) xs
  end.

Definition cmp : Policy := compose (cmp' [] []) (indexWord 0).
(* Compute (example_dyck, cmp example_dyck).
Compute (example_dyck2, cmp example_dyck2). *)

Definition getIndices' (m : Match) : list index :=
  match m with
  (x, y, z) => [x; y; z]
  end.

Definition getIndices (m : list Match) : list index :=
  concat (map getIndices' m).

Fixpoint splitWord' (ass bs cs : nat) (acc dw : word) : list word :=
  match dw with
  | (x::dw') =>
    match x with
    | a => splitWord' (ass + 1) bs cs (acc ++ [a]) dw'
    | b => splitWord' ass (bs + 1) cs (acc ++ [b]) dw'
    | c =>
      let cs'  := cs + 1 in
      let acc' := acc ++ [c] in
      if (ass =? bs) && (bs =? cs') then
        acc' :: splitWord' 0 0 0 [] dw'
      else
        splitWord' ass bs cs' acc' dw'
    end
  | [] => []
  end.

Definition splitWord : word -> list word := splitWord' 0 0 0 [].
(* Compute (splitWord [a;b;c;a;b;c;a;a;b;b;c;c;a;b;c]). *)

Instance shrinkDyck : Shrink word :=
  { shrink := splitWord }.

Definition spec (w w' : word) :=
  dyckb (w ++ w') && dyckb (w' ++ insert 0 c w).
(* QuickChick spec. *)

Definition should_fail (w : word) :=
  dyckb w && (59 <=? length w) ==> dyckb (w ++ [a;b] ++ w).
(* Extract Constant defNumTests => "10000".
Extract Constant defNumDiscards => "(2 * defNumTests)".
Extract Constant defNumShrinks => "1000".
Extract Constant defSize => "60".
QuickChick should_fail. *)

Definition rev_word (w : word) : word :=
  map (fun s => match s with a => c | b => b | c => a end) (rev w).
(* Compute (rev_word example_dyck). *)

Definition reverse_preserves_dyck (w : word) :=
  dyckb w ==> dyckb (rev_word w).
(* QuickChick reverse_preserves_dyck. *)

Definition cmp_preserves_indices (w : word) :=
  dyckb w ==> (length (getIndices (cmp w)) =? length w).
(* QuickChick cmp_preserves_indices. *)

Definition Range : Type := index * index.
Definition RangeMatch : Type := Range * Range * Range.

Definition singularRange (i: index) : Range := (i, i).

Definition range_lt (r1 r2 : Range) : bool :=
  match r1, r2 with
  | (x, _), (y, _) => x <? y
  end.

Definition rangem_lt (r1 r2 : RangeMatch) : bool :=
match r1, r2 with
| (x, _, _), (y, _, _) => range_lt x y
end.

Require Import List.
Require Import Arith.
Require Import Sorted.
Require Import Recdef.
Function bubble (l : list Range) {measure length} : list Range :=
  match l with
  | [] => []
  | [n] => [n]
  | n1 :: n2 :: l' =>
    if range_lt n1 n2 then
      n1 :: (bubble (n2 :: l'))
    else n2 :: (bubble (n1 :: l'))
  end.
Proof.
  auto. auto.
Defined.
Function bubble_sort (l : list Range) : list Range :=
  match l with
  | [] => []
  | n :: l' => bubble (n :: (bubble_sort l'))
  end.
(* Compute (bubble_sort [(0,0); (9,10); (7,8)]). *)

Definition getRangeMatch (rs : list Range) : option RangeMatch :=
  match rs with
  | [x; y; z] => Some (x, y, z)
  | _         => None
  end.

Function collapse' (cont : nat) (rs : list Range) {measure length rs} : list Range :=
  if cont =? 3 then
    rs
  else match rs with
  | [] => []
  | [x] => [x]
  | (x1,x2) :: (y1,y2) :: rs' =>
    if (x2 + 1) =? y1 then
      collapse' (cont + 1) ((x1, y2) :: rs')
    else
      (x1, x2) :: collapse' cont ((y1, y2) :: rs')
  end.
Proof.
all: unfold length; auto.
Defined.
(* Compute (collapse' 0 [(0,3); (4,10); (17,18)]). *)

Definition collapse (r1 r2 : RangeMatch) : option RangeMatch :=
  match r1 with | ((x, x'), (y, y'), (z, z')) =>
  match r2 with | ((k, k'), (l, l'), (m, m')) =>
    getRangeMatch
      (collapse' 0
        (bubble_sort [(x,x'); (y, y'); (z, z'); (k, k'); (l, l'); (m, m')]))
  end
  end.
(* Compute (collapse ((10,11), (15,17), (18,20)) ((12,13), (14,15), (30,40))). *)

Definition collapsible (r1 r2 : RangeMatch) : bool :=
  match collapse r1 r2 with
  | Some _ => true
  | None   => false
  end.

Definition mkRangeMatch (m : Match) : RangeMatch :=
  match m with
  | (i, j, k) => ((i, i), (j, j), (k, k))
  end.

Definition rangify : list Match -> list RangeMatch := map mkRangeMatch.

Require Import Coq.Init.Nat.
Definition test (w : word) :=
  let ranges := rangify (cmp w) in
  let rangePairs := filter (uncurry rangem_lt) (list_prod ranges ranges) in
  let existN := fun n f l => n <=? length (filter f l) in
  (dyckb w) && (30 <? length w)
    ==> existN (length w / 3) (uncurry collapsible) rangePairs.
(*     ==> existsb (uncurry collapsible) rangePairs. *)
Extract Constant defNumTests => "100000".
Extract Constant defNumDiscards => "(2 * defNumTests)".
Extract Constant defNumShrinks => "10000".
Extract Constant defSize => "50".
QuickChick test.

(*******************
** Typeclasses

(* Must be inductive *)
(* Derive ArbitrarySizedSuchThat for dyck.  *)

Definition genWordSized := @genListSized symbol GenSizedsymbol.

Definition wordGen (n : nat) : G word := @arbitrarySized word genWordSized n.
(* Sample (wordGen 10). *)

(* Definition dyckGen : G (option word) := suchThatMaybe (wordGen 261) dyckb. *)

(* Definition wordProp (g : nat -> G word) n :=
  forAll (g n) (fun t => @collect (length t) true).
QuickChick (wordProp wordGen 5). *)
*)

(*******************
** Alternative designs

0. Boolean
Definition is_dyck (w : string): bool :=
  (count "a" w =? count "b" w) &&
  (count "b" w =? count "c" w) &&
  (proper_prefixes 0 0 0 w).

Definition IsDyck (w : string) : Prop := is_dyck w = true.

Example test_isdyck :
  IsDyck "abcabcaabbcc".
Proof. reflexivity. Qed.

1. Proposition
Definition IsDyck_Prop (w : string): Prop :=
  (count "a" w = count "b" w) /\
  (count "b" w = count "c" w) /\
  (proper_prefixes 0 0 0 w).

2. Inductive Propoposition
Inductive is_Dyck : string -> Prop :=
  | Empty : is_Dyck ""
  | Insert : forall w', is_Dyck w' -> is_Dyck (String "a" w').

Example prove_dyck : is_Dyck "aaaa".
Proof. repeat constructor. Qed.

Inductive Dyck : string -> string -> string -> Prop :=
| Base : Dyck "a" "b" "c"
| Step : forall x y z l m n u v w,
            Dyck x y z
         -> Dyck l m n
         -> Interleave x y z l m n u v w (* TODO *)
         -> Dyck u v w.

Example test_Dyck :
  Dyck "aa" "bb" "cc".
Proof.
  apply (Step "a" "b" "c" "a" "b" "c"); constructor.
Qed.

Inductive Dyck : (string*string*string) -> Prop :=
| Base : Dyck ("a"%string, "b"%string, "c"%string)
| Step : forall x y z l m n, Dyck (x, y, z)
                          -> Dyck (l, m, n)
                          -> Dyck ((x ++ l)%string, (y ++ m)%string, (z ++ n)%string).

(forall w', is_true (prefix w' w)
         -> (count "a" w' >= count "b" w' >= count "c" w'))

(* Definition ValidSplit (x y z l m n k q r : word) : Prop :=
  ~ (k = []) /\ ~ (q = []) /\ ~ (r = []) /\
  True
  .

Infix "+++" := app (right associativity, at level 60) : list_scope.
*)

(* Inductive Dyck : word -> word -> word -> Prop :=
| Base : Dyck [a] [b] [c]
| Step : forall x y z l m n k q r,
           Dyck x y z
           -> Dyck l m n
           -> ValidSplit x y z l m n k q r
           -> Dyck k q r.
*)

(* Inductive Dyck : word -> word -> word -> Prop :=
| Base : Dyck [a] [b] [c]
| Step : forall x y z l m n,
           Dyck x y z
           -> Dyck l m n
           -> Dyck (x +++ l) (y +++ m) (z +++ n).

Instance Dyck_deq (x y z : word) : Dec (Dyck x y z).
Proof.
Admitted.

Conjecture dyckTest : forall x y z, dyck (x +++ y +++ z) -> dyck ((a::x) +++ (b::y) +++ (c::z)).

QuickChick dyckTest.

Theorem sound (x y z : word) : Dyck x y z -> dyck (x ++ y ++ z).
Proof.
  intro DW.
  induction DW; firstorder.
  - admit.
  - admit.
  - admit.
Admitted. *)

(*
Fixpoint insertAt {A} (i : nat) (x : A) (xs : list A) : list A :=
  match i with
  | O => x :: xs
  | S i' =>
    match xs with
    | [] => []
    | x' :: xs' => x' :: insertAt i' x xs'
    end
  end.

Fixpoint genDyckWord (sz : nat) : G word :=
  let base := [a; b; c]
  in match sz with
  | O => ret base
  | S sz' =>
    freq [ (1, ret base) ;
           (sz, xs <- genDyckWord sz';;
                ai <- choose (0, length xs);;
                bi <- choose (ai + 1, length xs + 1);;
                ci <- choose (bi + 1, length xs + 2);;
                ret (insertAt ci c (insertAt bi b (insertAt ai a xs))))  ]
  end.

Sample (genDyckWord 10).
*)

********************)


(** Gaia-compatible [H'_ alpha] fast growing functions

(imported from [hydras.Epsilon0.Hprime] )
*)

(* begin snippet Requirements:: no-out  *)
From mathcomp Require Import all_ssreflect zify.
From gaia Require Export ssete9.
From Coq Require Import Logic.Eqdep_dec.
From hydras Require Import DecPreOrder T1 E0.
From hydras Require Paths.
From hydras Require Import primRec PrimRecExamples.
From hydras Require Import  Iterates Hprime L_alpha.
From gaia_hydras Require Import T1Bridge GCanon GPaths.
(* end snippet Requirements *)

Set Implicit Arguments.
Unset Strict Implicit.

(* begin snippet HprimeDef *)
Definition H'_ alpha i := Hprime.H'_ (E0_g2h alpha) i.
(* end snippet HprimeDef *)

(** ** Equations for [H'_] *)

(* begin snippet HprimeEquations:: no-out *)
Lemma H'_eq1 (i: nat) : H'_ E0zero i = i.
Proof. by rewrite /H'_  g2h_E0zero Epsilon0.Hprime.H'_eq1.  Qed.

Lemma H'_eq2  alpha i :
  H'_ (E0succ alpha) i = H'_ alpha (S i).
Proof.
  case alpha => ? ?; by rewrite /H'_  g2h_E0succ  H'_eq2.
Qed.

Lemma H'_eq3 alpha i :
  E0limit alpha ->  H'_ alpha i =  H'_ (E0Canon alpha (S i)) i.
(* ... *)
(* end snippet HprimeEquations *)
Proof.
  rewrite /E0limit /H'_ => H; rewrite H'_eq3 => //; congr Hprime.H'_.    apply E0_eq_intro => /=;  by rewrite g2h_canon.
Qed.

(** **  Examples *)

(* begin snippet Examples:: no-out *)
Lemma H'_omega k : H'_ E0omega k = (2 * k).+1 %nat.
Proof.
  rewrite H'_eq3  ?/E0limit => //.
  (* ... *)
(* end snippet Examples *)
  replace (E0Canon E0omega k.+1) with (E0fin k.+1); last first.
  apply gE0_eq_intro => /=;  by rewrite E0fin_cnf T1succ_nat.
  rewrite /H'_ E0g2h_Fin H'_Fin; lia.
Qed.

(* begin snippet Examplesb:: no-out *)
Lemma H'_omega_double (k: nat) :
  H'_ (E0mul E0omega (E0fin 2)) k =  (4 * k + 3)%coq_nat.
Proof.
  by rewrite /H'_  -H'_omega_double E0g2h_mulE E0g2h_omegaE E0g2h_Fin.
Qed.
(* end snippet Examplesb *)

(** TODO
    import more abstract properties of H'_ *)

(* begin snippet abstract:: no-out  *)
Lemma H'_dom alpha beta :
  E0lt alpha beta -> dominates_strong (H'_ beta) (H'_ alpha).
(* end snippet abstract  *)
Proof.
  move => H; have H' : (hE0lt (E0_g2h alpha) (E0_g2h beta))
  by rewrite -gE0lt_iff.
  case (Epsilon0.Hprime.H'_dom _ _ H') => x Hx; exists x; rewrite  /H'_.
  move => p Hp; apply /ltP; apply Hx;  by apply /leP.
Qed.

(* begin snippet abstractb:: no-out  *)
Lemma H'_alpha_mono (alpha : E0) : strict_mono (H'_ alpha).
Proof.
  generalize (Hprime.H'_alpha_mono (E0_g2h alpha)) => H x y /ltP.
  move /H;  by rewrite /H'_ => /ltP.
Qed.
(* end snippet abstractb  *)

(* begin snippet abstractc:: no-out  *)
Theorem H'_alpha_gt alpha (Halpha: alpha <> E0zero) n :
  (n < H'_ alpha n)%N.
Proof.
  move: (H'_alpha_gt (E0_g2h alpha)) => H.
  rewrite /H'_ ; apply /ltP; apply H => H0; apply Halpha.
  apply gE0_eq_intro; case: alpha H H0 Halpha => // ? ? ? H0 ?.
  injection H0 => Heq; by rewrite -g2h_eqE ?Heq.
Qed.

Lemma H'_omega_cube_min :
forall k : nat,
  0 <> k -> (hyper_exp2 k.+1  <= H'_ (E0phi0 (E0fin 3)) k)%N.
Proof.
  move => k Hk; apply /leP; transitivity (Hprime.H'_ (hE0phi0 3) k).
  - by apply H'_omega_cube_min.
  - by rewrite /H'_  E0g2h_phi0 E0g2h_Fin.
Qed.
(* end snippet abstractc  *)


(**  PA : Peano Arithmetic

       Original development by Russel O'Connor
       Bullets and abbreviations by Pierre Casteran
*)

From Coq Require Import Arith Lia Ensembles Decidable.
Require Import folProp subAll folLogic3.
Require Export Languages LNT.
Require Import NewNotations.

Section PA.

Definition PA1 := (allH 0, Succ v_ 0 <> Zero)%nt.

Definition PA2 := (allH 1 0, Succ v_ 0 = Succ v_ 1 -> v_ 0 = v_ 1)%nt.

Definition PA3 := (allH 0, v_ 0 + Zero = v_ 0)%nt.

Definition PA4 := (allH 1 0, v_ 0 + Succ v_ 1 = Succ (v_ 0 + v_ 1))%nt.

Definition PA5 := (allH 0, v_ 0 * Zero = Zero)%nt.

Definition PA6 := (allH 1 0, v_ 0 * Succ v_ 1 = v_ 0 * v_ 1 + v_ 0)%nt.

Definition PA7 (f : Formula) (v : nat) : Formula :=
   let f_0 := substF LNT f v Zero%nt in
   let f_Sv := substF LNT f v (Succ v_ v)%nt in
   close _  (f_0 -> (allH v, f -> f_Sv) -> allH v, f)%nt.

Definition InductionSchema (f : Formula) : Prop :=
  exists g : Formula, (exists v : nat, f = PA7 g v).

Definition PA := SetAddn InductionSchema PA1 PA2 PA3 PA4 PA5 PA6.

Definition open :=
  Formula_rec LNT (fun _ => Formula) (fun t t0 : Term => equal t t0)
    (fun (r : Relations LNT)
         (ts : Terms (arityR LNT r)) =>  atomic r ts)
    (fun (f : Formula) _ (f0 : Formula) _ => impH f f0)
    (fun (f : Formula) _ => notH f)
    (fun (n : nat) _ (recf : Formula) => recf).

Lemma PAdec : forall x : Formula, decidable (In _ PA x).
Proof.
  intros x.
  unfold PA in |- *.
  induction (formula_dec LNT LNT_dec x PA6).
  - rewrite a; left; right; constructor.
  - induction (formula_dec LNT LNT_dec x PA5).
    + rewrite a; left; left; right; constructor.
    + induction (formula_dec LNT LNT_dec x PA4).
      * rewrite a; left; do 2 left; right; constructor.
      * induction (formula_dec LNT LNT_dec x PA3).
        -- rewrite a; left; do 3 left; right; constructor.
        -- induction (formula_dec LNT LNT_dec x PA2).
           ++ rewrite a; left; do 4 left; right; constructor.
           ++ induction (formula_dec LNT LNT_dec x PA1).
              ** rewrite a; left; do 5 left; right; constructor.
              ** cut (In Formula InductionSchema x \/
                        ~ In Formula InductionSchema x).
                 { intros  [H| H].
                   - left; do 6 left; assumption.
                   - right; intro H0.
                     repeat tauto || induction H0.
                 }
                 clear b b0 b1 b2 b3 b4.
                 assert
                   (H: forall y : Formula,
                       (decidable
                          (exists (f : Formula) (v : nat),
                              (substF LNT f v Zero ->
                               (allH v, f -> substF LNT f v (Succ v_ v)) ->
                               allH v, f)%nt
                              = y))).
                 { intros y;
                   destruct y as [t t0| r t| f f0| f| n f];
                   try (right; unfold not in |- *;
                        intros; decompose record H; discriminate ).
                   destruct f0 as [t t0| r t| f0 f1| f0| n f0];
                     try (right; unfold not in |- *; intros;
                          decompose record H; discriminate).
                   destruct f0 as [t t0| r t| f0 f2| f0| n f0];
                     try (right; unfold not in |- *; intros;
                          decompose record H; discriminate).
                   destruct f1 as [t t0| r t| f1 f2| f1| n0 f1];
                     try (right; unfold not in |- *; intros;
                          decompose record H; discriminate).
                   destruct (formula_dec LNT LNT_dec (substF LNT f1 n0 Zero) f)
                     as [a | b].
                   - rewrite <- a; clear a f.
                     destruct f0 as [t t0| r t| f f0| f| n1 f];
                       try (right; unfold not in |- *; intros;
                            decompose record H; discriminate).
                     induction (formula_dec LNT LNT_dec f1 f) as [a | b].
                     + rewrite <- a; clear a f.
                       induction
                         (formula_dec LNT LNT_dec
                            (substF LNT f1 n0 (Succ (v_ n0))%nt) f0).
                       * rewrite <- a; clear a f0.
                         induction (eq_nat_dec n n0) as [a | b].
                         -- rewrite a; left.
                            exists f1.
                            exists n0.
                            reflexivity.
                         -- right; unfold not in |- *; intros;
                              apply b; decompose record H /r.
                            intros H x0 x1 H1; inversion H1; auto.
                       *  right; unfold not in |- *; intros; apply b;
                            decompose record H /r.
                          intros H x0 x1 H1; inversion H1;
                            reflexivity.
                     + right; unfold not in |- *; intros; apply b;
                         decompose record H /r.
                       intros H x0 x1 H1; inversion H1; auto.
                   -  right; unfold not in |- *; intros; apply b;
                        decompose record H /r.
                      intros H x0 x1 H1; inversion H1; auto.
                 }
                 induction (formula_dec LNT LNT_dec x (close LNT (open x))) as [a | b].
                 --- induction (H (open x)).
                     left.
                     unfold In, InductionSchema, PA7 in |- *.
                     decompose record H0 /r.
                     intros x0 x1 H2; exists x0, x1; now rewrite H2.
                     right.
                     intros H1; apply H0.
                     unfold In, InductionSchema, PA7 in H1.
                     decompose record H1 /r.
                     intros x0 x1 H3; exists x0, x1; rewrite H3.
                     unfold close.
                 induction
                   (List.nodup eq_nat_dec
                      (freeVarFormula LNT
                        (substF LNT x0 x1 Zero ->
                          (allH x1, x0 -> substF LNT x0 x1 (Succ (v_ x1))) ->
                          allH x1, x0)%nt)).
                  simpl; reflexivity.
                 simpl; assumption.
                 --- right; intros H0; apply b.
                     unfold In, InductionSchema, PA7 in H0.
                     decompose record H0 /r.
                     intros x0 x1 H2; rewrite H2.
                     replace
                       (open
                          (close LNT
                             (substF LNT x0 x1 Zero ->
                              (allH x1, x0 ->
                                        substF LNT x0 x1 (Succ v_ x1)) ->
                              allH x1, x0)%nt))
                       with
                       (substF LNT x0 x1 Zero ->
                        (allH x1, x0 ->
                                  substF LNT x0 x1 (Succ v_ x1)) ->
                        allH x1, x0)%nt;
                       [reflexivity |].
                     unfold close in |- *.
                     induction
                       (List.nodup eq_nat_dec
                          (freeVarFormula LNT
                             (substF LNT x0 x1 Zero ->
                              (allH x1, x0 -> substF LNT x0 x1 (Succ (v_ x1))) ->
                              (allH x1, x0)))%nt).
                     simpl; reflexivity.
                     simpl; auto.
Qed.

Lemma closedPA1 : ClosedSystem LNT PA.
Proof.
  unfold ClosedSystem, PA in |- *.
  intros v f H.
  induction H as [x H| x H].
  - induction H as [x H| x H].
    + induction H as [x H| x H].
      * induction H as [x H| x H].
      -- induction H as [x H| x H].
         ++  induction H as [x H| x H].
             ** induction H as (x0, H).
                induction H as (x1, H).
                unfold PA7 in H.
                rewrite H.
                apply freeVarClosed.
             ** induction H; auto.
         ++ induction H; auto.
      -- induction H; auto.
      * induction H; auto.
    + induction H; auto.
- induction H; auto.
Qed.

Lemma closedPA : forall v : nat, ~ In_freeVarSys LNT v PA.
Proof.
 intros v H; unfold In_freeVarSys in H.
 destruct H as [x H]; elim closedPA1 with v x; tauto.
Qed.

Lemma pa1 (a : Term):  SysPrf PA (Succ a <> Zero)%nt.
Proof.
  replace (Succ a <> Zero)%nt with  (substF LNT (Succ v_ 0 <> Zero)%nt 0 a).
  - apply forallE, Axm; repeat (try right; constructor) || left.
  - reflexivity.
Qed.

Lemma pa2 (a b : Term):  SysPrf PA (Succ a = Succ b ->  a = b)%nt.
Proof.
  set (m := fun x : nat => match x with
                           | O => a
                           | S _ => b
                           end) in *.
  replace (Succ a = Succ b ->  a = b)%nt with
    (subAllFormula LNT
       (Succ v_ 0 = Succ v_ 1 ->  v_ 0 = v_ 1)%nt
       (fun x : nat =>
          match le_lt_dec 2 x with
          | left _ => var x
          | right _ => m x
          end)).
  - apply (subAllCloseFrom LNT).
    simpl; apply Axm; repeat (try right; constructor) || left.
  - simpl; induction (le_lt_dec 2 0).
    + lia.
    + destruct (le_lt_dec 2 1).
      * lia.
      * reflexivity.
Qed.

Lemma pa3 (a : Term): SysPrf PA (a + Zero = a)%nt.
Proof.
  replace (a + Zero = a)%nt with  (substF LNT (v_ 0 + Zero = v_ 0)%nt 0 a).
  - apply forallE, Axm; repeat (try right; constructor) || left.
  - reflexivity.
Qed.

Lemma pa4 ( a b : Term) :  SysPrf PA (a + Succ b = Succ (a + b))%nt.
Proof.
  set (m := fun x : nat => match x with
                           | O => a
                           | S _ => b
                           end) in *.
  replace (a + Succ b = Succ (a + b))%nt with
    (subAllFormula LNT
       (v_ 0 + Succ v_ 1 = Succ (v_ 0  + v_ 1))%nt
       (fun x : nat =>
          match le_lt_dec 2 x with
          | left _ => var x
          | right _ => m x
          end)).
  - apply (subAllCloseFrom LNT).
    simpl in |- *.
    apply Axm; repeat (try right; constructor) || left.
  - simpl in |- *.
    induction (le_lt_dec 2 0).
    + lia.
    + induction (le_lt_dec 2 1).
      * lia.
      * reflexivity.
Qed.

Lemma pa5 (a : Term): SysPrf PA (a * Zero = Zero)%nt.
Proof.
  replace (a * Zero = Zero)%nt with
    (substF LNT (v_ 0 * Zero = Zero)%nt 0 a).
  - apply forallE.
    apply Axm; repeat (try right; constructor) || left.
  - reflexivity.
Qed.

Lemma pa6 (a b : Term) :  SysPrf PA (a * Succ b = a * b + a)%nt.
Proof.
  set (m := fun x : nat => match x with
                           | O => a
                           | S _ => b
                           end) in *.
  replace (a * Succ b = a * b + a)%nt with
    (subAllFormula LNT
       (v_ 0 * Succ (v_ 1) = v_ 0 * v_ 1 + v_ 0)%nt
       (fun x : nat =>
          match le_lt_dec 2 x with
          | left _ => var x
          | right _ => m x
          end)).
  - apply (subAllCloseFrom LNT).
    simpl in |- *.
    apply Axm; repeat (try right; constructor) || left.
  - simpl in |- *.
    induction (le_lt_dec 2 0).
    + lia.
    + induction (le_lt_dec 2 1).
      * lia.
      * reflexivity.
Qed.

Lemma induct (f : Formula) (v : nat):
  let f_0 := substF LNT f v Zero
  in let f_Sv := substF LNT f v (Succ (v_ v))%nt
     in  SysPrf PA f_0 ->
         SysPrf PA (allH v, f -> f_Sv)%nt
         -> SysPrf PA (allH v, f)%nt.
Proof.
  intros ? ? H H0; eapply impE.
  - eapply impE.
    + apply (openClosed LNT).
      apply Axm; repeat left.
      unfold InductionSchema in |- *.
      unfold In in |- *.
      unfold PA7 in |- *.
      exists f, v; reflexivity.
    + apply H.
- apply H0.
Qed.

End PA.


Require Import Reals.

Open Scope R_scope.

Definition Real := R.

(* function parameter *)
Variable s : Real.

(* constant *)
Parameter H H0 Hd1 Hd2 : Real.

(* variables *)
Parameter t deltaH K : Real.

(* functions from s to real. *)
Variables Um Im Om Tm : Real -> Real.

Definition tm1 := H0 - H - /2 * Hd2 * t * t.
Definition tm2 := Hd1 - Hd2 * t.
(*
Definition tm3 := (Tm s) * (Lm *s + Rm).
Definition tm4 := (Um s) * Kt - Kt * Ke * (Om s) - (Lm * s + Rm) * (Jm * s + Bm) * (Om s).
*)
(* assumptions of this deduction. *)
Axiom e1 : tm1 = 0.
Axiom e2 : tm2 = 0.
Axiom e3 : 2 * Hd2 <> 0.
Axiom e4 : 2 <> 0.

Definition tm5 := H0 - H.

Lemma eq0_eq : forall y z, y-z = 0 -> y = z.
intros.
apply sym_eq.
apply Rminus_diag_uniq_sym.
assumption.
Qed.

(* move Ke * (Om s) in tm1 to the  right of  = *)
Lemma tm5_eq : tm5  = /2 * Hd2 * t * t.
apply eq0_eq.
apply e1.
Qed.

Definition tm7 :=  Hd2 * t * t.

Lemma tm5_puls_tm7 : tm5 = /2 * tm7.
unfold tm7.
rewrite tm5_eq.
ring.
Qed.

Definition tm6 :=  Hd1.

Lemma tm6_eq : tm6  = Hd2 * t.
apply eq0_eq.
apply e2.
Qed.

Lemma l1 : 2 * Hd2 * (/ (2 * Hd2) * (tm6 * tm6)) = (2 * Hd2) * / (2 * Hd2) * (tm6 * tm6).
apply sym_eq.
apply Rmult_assoc.
Qed.

Lemma l2 : 2 * Hd2 * / (2 * Hd2) = 1.
apply Rinv_r.
apply e3.
Qed.

Lemma l3 : 2 * Hd2 * tm5 =  2 * tm5 * Hd2.
ring.
Qed.

Lemma l3_1 : 2 * (/ 2 * tm7) = 2 * /2 * tm7.
apply sym_eq.
apply Rmult_assoc.
Qed.

Lemma l3_2 : 2 * / 2 = 1.
apply Rinv_r.
apply e4.
Qed.

Theorem final_result : (2 * Hd2) <> 0 -> tm5 =  / (2 * Hd2) * (tm6 * tm6).
apply Rmult_eq_reg_l.
rewrite l1.
rewrite l2.
rewrite l3.
rewrite tm5_puls_tm7.
rewrite l3_1.
rewrite l3_2.
unfold tm7.
rewrite tm6_eq.
ring.
Qed.


(* $Id: Partitions.v,v 1.13 2003/03/13 12:06:22 lcf Exp $ *)

Require Export Continuity.

Section Definitions.

(* Tex_Prose
\chapter{Partitions}

We now begin to lay the way for the definition of integral.  This will be done in the Riemann way, through the definition of a sequence of sums that is proved to be convergent; in order to do that, we first need to do a bit of work on partitions.

\section{Definitions}

A partition is defined as a record type.  For each compact interval $[a,b]$ and each natural number $n$, a partition of $[a,b]$ with $n+1$ points is a choice of real numbers $a=a_0\leq a_1\leq\ldots\leq a_n=b$; the following specification works as follows:
\begin{description}
\item[Pts] is the function that chooses the points;
\item[prf1] states that \verb!Pts! is a setoid function;
\item[prf2] states that the points are ordered;
\item[start] requires that $a_0=a$ and
\item[finish] requires that $a_n=b$.
\end{description}
*)

(* Begin_Tex_Verb *)
Record Partition [a,b:IR][Hab:a[<=]b][lng:nat] : Set :=
  {Pts : (i:nat)(le i lng)->IR;
   prf1 : (i,j:nat)i=j->(Hi:(le i lng))(Hj:(le j lng))(Pts i Hi)[=](Pts j Hj);
   prf2 : (i:nat)(H:(le i lng))(H':(le (S i) lng))(Pts i H)[<=](Pts (S i) H');
   start : (H:(le O lng))(Pts O H)[=]a;
   finish : (H:(le lng lng))(Pts lng H)[=]b}.
(* End_Tex_Verb *)

(* Tex_Prose
Two immediate consequences of this are that $a_i\leq a_j$ whenever $i\leq j$ and that $a_i\in[a,b]$ for all $i$.
*)

(* Begin_Tex_Verb *)
Lemma Partition_mon : (a,b,Hab,lng:?)(P:(Partition a b Hab lng))
  (i,j:nat)(Hi,Hj:?)(le i j)->
    (Pts ???? P i Hi)[<=](Pts ???? P j Hj).
(* End_Tex_Verb *)
Intros; Induction j.
Cut i=O; [Intro | Auto with arith].
Apply eq_imp_leEq; Apply prf1; Auto.
Elim (le_lt_eq_dec ?? H); Intro H1.
Cut (le j lng); [Intro | Clear Hrecj; Omega].
Apply leEq_transitive with (Pts ???? P j H0).
Apply Hrecj; Clear Hrecj; Auto with arith.
Apply prf2.
Apply eq_imp_leEq; Apply prf1; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Partition_in_compact : (a,b,Hab,lng:?)
  (P:(Partition a b Hab lng))(i:nat)(H:(le i lng))
    (compact a b Hab (Pts ???? P i H)).
(* End_Tex_Verb *)
Intros.
Split.
Apply leEq_wdl with (Pts ???? P ? (le_O_n ?)).
Apply Partition_mon; Auto with arith.
Apply start.
Apply leEq_wdr with (Pts ???? P ? (le_n ?)).
Apply Partition_mon; Auto with arith.
Apply finish.
Qed.

(* Tex_Prose
Each partition $\{a_0,\ldots,a_n\}$ implies a partition $\{a_0,\ldots,a_{n-1}\}$ of the interval $[a,a_{n-1}]$.  This partition will play an important role in much of our future work, so we take some care to define it.
*)

(* Begin_Tex_Verb *)
Lemma part_pred_lemma : (a,b,Hab,lng:?)
  (P:(Partition a b Hab lng))(i:nat)(Hi:(le i lng))
    a[<=](Pts ???? P i Hi).
(* End_Tex_Verb *)
Intros.
Apply leEq_wdl with (Pts ???? P O (le_O_n ?)).
Apply Partition_mon; Auto with arith.
Apply start.
Qed.

(* Begin_Tex_Verb *)
Definition Partition_Pred [a,b,Hab,n,P:?] :
  (Partition a ?
    (part_pred_lemma a b Hab (S n) P n (le_n_Sn n)) n).
(* End_Tex_Verb *)
Intros.
Apply Build_Partition with [i:nat][Hi:(le i n)](Pts ???? P i (le_S ?? Hi)).
Intros; Simpl; Apply prf1; Assumption.
Intros; Simpl; Apply prf2.
Intros; Simpl; Apply start.
Intros; Simpl; Apply prf1; Auto.
Defined.

(* Tex_Prose
The \emph{mesh} of a partition is the greatest distance between two consecutive points.  For convenience's sake we also define the dual concept, which is very helpful in some situations.  In order to do this, we begin by building a list with all the distances between consecutive points; next we only need to extract the maximum and the minimum of this list\footnote{Notice that this list is nonempty except in the case when $a=b$ and $n=0$; this means that the convention we took of defining the minimum and maximum of the empty list to be 0 actually helps us in this case.}.
*)

(* Begin_Tex_Verb *)
Definition Part_Mesh_List
  [n,a,b,Hab:?][P:(Partition a b Hab n)] : (list IR).
(* End_Tex_Verb *)
Intro; Induction n; Intros.
Apply nil.
Apply cons.
Apply (Pts ???? P ? (le_n (S n)))[-](Pts ???? P ? (le_S ?? (le_n n))).
Apply Hrecn with a (Pts ???? P ? (le_n_Sn n)) (part_pred_lemma ???? P n (le_n_Sn n)).
Apply Partition_Pred.
Defined.

(* Begin_Tex_Verb *)
Definition Mesh [a,b,Hab,n,P:?] :=
  (maxlist (Part_Mesh_List n a b Hab P)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition AntiMesh [a,b,Hab,n,P:?] :=
  (minlist (Part_Mesh_List n a b Hab P)).
(* End_Tex_Verb *)

(* Tex_Prose
Even partitions (partitions where all the points are evenly spaced) will also play a central role in our work; the first two lemmas are presented simply to make the definition of even partition lighter.
*)

(* Begin_Tex_Verb *)
Lemma even_part_1 : (a,b:IR)(n:nat)(Hn:~(O=n))
  a[+](nring O)[*]((b[-]a)[/]?[//](nring_ap_zero' ? n Hn))[=]a.
(* End_Tex_Verb *)
Intros; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma even_part_2 : (a,b:IR)(n:nat)(Hn:~(O=n))
  a[+](nring n)[*]((b[-]a)[/]?[//](nring_ap_zero' ? n Hn))[=]b.
(* End_Tex_Verb *)
Intros; Rational.
Qed.

(* Begin_Tex_Verb *)
Definition Even_Partition [a,b,Hab,n:?][Hn:~(O=n)] :
  (Partition a b Hab n).
(* End_Tex_Verb *)
Intros.
Apply Build_Partition with [i:nat][Hi:(le i n)]a[+](nring i)[*]((b[-]a)[/]?[//](nring_ap_zero' ? n Hn)).
Intros; Simpl.
Rewrite H; Algebra.
Intros; Simpl.
Apply plus_resp_leEq_lft.
Apply mult_resp_leEq_rht.
Apply less_leEq; Apply less_plusOne.
Apply shift_leEq_div.
Apply nring_pos; Clear H; Apply neq_O_lt; Auto.
Apply shift_leEq_minus.
Step Zero[+]a.
Step a; Assumption.
Intros; Simpl; Apply even_part_1; Auto.
Intros; Simpl; Apply even_part_2; Auto.
Defined.

(* Tex_Prose
We will also need to consider arbitrary sums of the form \[\sum_{i=0}^{n-1}f(x_i)(a_{i+1}-a_i)\] where $x_i\in[a_i,a_{i+1}]$.  For this, we again need a choice function $x$ which has to satisfy some condition.  We define the condition and the sum:
*)

(* Begin_Tex_Verb *)
Definition Points_in_Partition [a,b,Hab,n:?]
  [P:(Partition a b Hab n)][g:(i:nat)(lt i n)->IR] : CProp :=
  (i:nat)(H:(lt i n))
    (Compact (prf2 ???? P i (lt_le_weak ?? H) H) (g i H)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Pts_part_lemma : (a,b,Hab,n,P,g:?)
  (Points_in_Partition a b Hab n P g)->
    (i:nat)(H:(lt i n))(compact a b Hab (g i H)).
(* End_Tex_Verb *)
Intros.
Elim (H i H0); Intros.
Split.
EApply leEq_transitive.
2: Apply a0.
Apply leEq_wdl with (Pts ???? P O (le_O_n ?)).
Apply Partition_mon; Auto with arith.
Apply start.
EApply leEq_transitive.
Apply b0.
Apply leEq_wdr with (Pts ???? P n (le_n ?)).
Apply Partition_mon; Auto with arith.
Apply finish.
Qed.

(* Begin_Tex_Verb *)
Definition Partition_Sum [a,b,Hab,n:?][P:(Partition a b Hab n)]
  [g,F:?][H:(Points_in_Partition ???? P g)]
  [incF:(included (Compact Hab) (Pred F))] :=
  (Sumx [i:nat][Hi:(lt i n)]
    (F (g i Hi) (incF ? (Pts_part_lemma ?????? H i Hi)))[*]
      ((Pts ???? P (S i) Hi)[-]
        (Pts ???? P i (lt_le_weak ?? Hi)))).
(* End_Tex_Verb *)

(* Tex_Prose
\section{Constructions}

We now formalize some trivial and helpful constructions.

\begin{convention} We will assume a fixed compact interval $[a,b]$, denoted by \verb!I!.
\end{convention}
*)

Variables a,b:IR.
Hypothesis Hab : a[<=]b.
Local I:=(compact a b Hab).

Section Getting_Points.

(* Tex_Prose
From a partition we always have a canonical choice of points at which to evaluate a function: just take all but the last points of the partition.

\begin{convention} Let \verb!Q! be a partition of \verb!I! with \verb!m! points.
\end{convention}
*)

Variable m:nat.
Variable Q:(Partition a b Hab m).

(* Begin_Tex_Verb *)
Definition Partition_imp_points : (i:nat)(lt i m)->IR.
(* End_Tex_Verb *)
Intros.
Apply (Pts ???? Q i (lt_le_weak ?? H)).
Defined.

(* Begin_Tex_Verb *)
Lemma Partition_imp_points_1 :
  (Points_in_Partition ???? Q Partition_imp_points).
(* End_Tex_Verb *)
Red; Intros.
Unfold Partition_imp_points; Split.
Apply leEq_reflexive.
Apply prf2.
Qed.

(* Begin_Tex_Verb *)
Lemma Partition_imp_points_2 :
  (nat_less_n_fun ?? Partition_imp_points).
(* End_Tex_Verb *)
Red; Intros.
Unfold Partition_imp_points; Simpl.
Apply prf1; Auto.
Qed.

End Getting_Points.

(* Tex_Prose
As a corollary, given any continuous function $F$ and a natural number we have an immediate choice of a sum of $F$ in $[a,b]$.
*)

Variable F:PartIR.
Hypothesis contF:(Continuous_I Hab F).

(* Begin_Tex_Verb *)
Definition Even_Partition_Sum [n:nat][Hn:~(O=n)] : IR.
(* End_Tex_Verb *)
Intros.
Apply Partition_Sum with a b Hab n (Even_Partition a b Hab n Hn) (Partition_imp_points ? (Even_Partition a b Hab n Hn)) F.
Apply Partition_imp_points_1.
Apply contin_imp_inc; Assumption.
Defined.

End Definitions.

Implicits Partition [1 2].
Implicits Partition_Pred [1 2 3 4].
Implicits Mesh [1 2 3 4].
Implicits AntiMesh [1 2 3 4].
Implicits Pts [1 2 3 4].
Implicits Part_Mesh_List [1 2 3 4].
Implicits Points_in_Partition [1 2 3 4].
Implicits Partition_Sum [1 2 3 4 5 6 7].
Implicits Even_Partition [1 2].
Implicits Even_Partition_Sum [1 2].

Section Lemmas.

(* Tex_Prose
\section{Lemmas}

Finally, we include some important lemmas about partitions.

If a partition has more than one point then its mesh list is nonempty.
*)

(* Begin_Tex_Verb *)
Lemma length_Part_Mesh_List : (n:nat)(a,b:IR)(Hab:(a[<=]b))
  (P:(Partition Hab n))(lt O n)->
    (lt O (length (Part_Mesh_List P))).
(* End_Tex_Verb *)
Intro; Case n; Intros.
ElimType False; Inversion H.
Simpl; Auto with arith.
Qed.

(* Tex_Prose
Any element of the auxiliary list defined to calculate the mesh of a partition has a very specific form.
*)

(* Begin_Tex_Verb *)
Lemma Part_Mesh_List_lemma : (n:nat)(a,b:IR)(Hab:(a[<=]b))
  (P:(Partition Hab n))(x:IR)(member x (Part_Mesh_List P))->
  {i:nat & {Hi:(Cle i n) & {Hi':(Cle (S i) n) | x[=]
    (Pts P ? (Cle_to ?? Hi'))[-](Pts P ? (Cle_to ?? Hi))}}}.
(* End_Tex_Verb *)
Intro; Induction n.
Simpl; Intros.
ElimType CFalse; Assumption.
Intros.
Simpl in H; Inversion_clear H.
Elim (Hrecn ????? H0); Clear Hrecn.
Intros i H; Elim H; Clear H.
Intros Hi H; Elim H; Clear H.
Intros Hi' H.
Simpl in H.
Exists i; Exists (toCle ?? (le_S ?? (Cle_to ?? Hi))); Exists (toCle ?? (le_S ?? (Cle_to ?? Hi'))).
EApply eq_transitive_unfolded.
Apply H.
Apply cg_minus_wd; Apply prf1; Auto.
Exists n.
Exists (toCle ?? (le_S ?? (le_n n))).
Exists (toCle ?? (le_n (S n))).
EApply eq_transitive_unfolded.
Apply H0.
Apply cg_minus_wd; Apply prf1; Auto.
Qed.

(* Tex_Prose
Mesh and antimesh are always nonnegative.
*)

(* Begin_Tex_Verb *)
Lemma Mesh_nonneg : (n:nat)(a,b:IR)(Hab:(a[<=]b))
  (P:(Partition Hab n))Zero[<=](Mesh P).
(* End_Tex_Verb *)
Induction n.
Intros; Unfold Mesh; Simpl.
Apply leEq_reflexive.
Clear n; Intros.
Unfold Mesh.
Apply leEq_transitive with (Pts P ? (le_n (S n)))[-](Pts P ? (le_S ?? (le_n n))).
Apply shift_leEq_minus; Step (Pts P ? (le_S ?? (le_n n))).
Apply prf2.
Apply maxlist_greater.
Right; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma AntiMesh_nonneg : (n:nat)(a,b:IR)(Hab:(a[<=]b))
  (P:(Partition Hab n))Zero[<=](AntiMesh P).
(* End_Tex_Verb *)
Intro; Induction n.
Intros; Unfold AntiMesh; Simpl.
Apply leEq_reflexive.
Intros.
Unfold AntiMesh.
Apply leEq_minlist.
Simpl; Auto with arith.
Intros.
Simpl in H; Inversion_clear H.
Unfold AntiMesh in Hrecn.
Apply leEq_transitive with (minlist (Part_Mesh_List (Partition_Pred P))).
2: Apply minlist_smaller; Assumption.
Apply Hrecn.
EApply leEq_wdr.
2: Apply eq_symmetric_unfolded; Apply H0.
Apply shift_leEq_minus; Step (Pts P ? (le_S ?? (le_n n))).
Apply prf2.
Qed.

(* Tex_Prose
Most important, AntiMesh and Mesh provide lower and upper bounds for the distance between any two consecutive points in a partition.

\begin{convention} Let \verb!I!$=[a,b]$ and \verb!P! be a partition of \verb!I! with \verb!n! points.
\end{convention}
*)

Variables a,b:IR.
Local I:=(compact a b).
Hypothesis Hab:(a[<=]b).

Variable n:nat.
Variable P:(Partition Hab n).

(* Begin_Tex_Verb *)
Lemma Mesh_lemma : (i:nat)(H,H':?)
  (Pts P (S i) H')[-](Pts P i H)[<=](Mesh P).
(* End_Tex_Verb *)
Clear I; Generalize n a b Hab P; Clear P n Hab a b.
Induction n.
Intros; ElimType False; Inversion H'.
Clear n; Intro m; Intros.
Induction m.
Cut O=i; [Intro | Inversion H'; Auto; Inversion H2].
Generalize H0 H'; Clear H0 H'; Rewrite <- H1.
Intros.
Unfold Mesh; Simpl.
Apply eq_imp_leEq; Apply cg_minus_wd; Apply prf1; Auto.
Elim (le_lt_eq_dec ?? H'); Intro H1.
Cut (le i (S m)); [Intro | Auto with arith].
Cut (le (S i) (S m)); [Intro | Auto with arith].
LetTac P':=(Partition_Pred P).
Apply leEq_wdl with (Pts P' ? H3)[-](Pts P' ? H2).
2: Simpl; Apply cg_minus_wd; Apply prf1; Auto.
Apply leEq_transitive with (Mesh P').
Apply H.
Unfold Mesh; Simpl; Apply rht_leEq_Max.
Cut i=(S m); [Intro | Auto with arith].
Generalize H' H0; Clear H0 H'.
Rewrite H2; Intros.
Unfold Mesh; Apply maxlist_greater; Right.
Apply cg_minus_wd; Apply prf1; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma AntiMesh_lemma : (i:nat)(H,H':?)
  (AntiMesh P)[<=](Pts P (S i) H')[-](Pts P i H).
(* End_Tex_Verb *)
Clear I; Generalize n a b Hab P; Clear P n Hab a b.
Induction n.
Intros; ElimType False; Inversion H'.
Clear n; Intro m; Intros.
Induction m.
Cut O=i; [Intro | Inversion H'; Auto; Inversion H2].
Generalize H0 H'; Clear H0 H'; Rewrite <- H1.
Intros.
Unfold AntiMesh; Simpl.
Apply eq_imp_leEq; Apply cg_minus_wd; Apply prf1; Auto.
Elim (le_lt_eq_dec ?? H'); Intro H1.
Cut (le i (S m)); [Intro | Auto with arith].
Cut (le (S i) (S m)); [Intro | Auto with arith].
LetTac P':=(Partition_Pred P).
Apply leEq_wdr with (Pts P' ? H3)[-](Pts P' ? H2).
2: Simpl; Apply cg_minus_wd; Apply prf1; Auto.
Apply leEq_transitive with (AntiMesh P').
2: Apply H.
Unfold AntiMesh; Simpl.
EApply leEq_wdr.
2: Apply cg_inv_inv.
Apply inv_resp_leEq; Apply rht_leEq_Max.
Cut i=(S m); [Intro | Auto with arith].
Generalize H' H0; Clear H0 H'.
Rewrite H2; Intros.
Unfold AntiMesh; Apply minlist_smaller; Right.
Apply cg_minus_wd; Apply prf1; Auto.
Qed.

(* Tex_Prose
Finally, we define what it means for a partition $Q$ to be a refinement of $P$ and prove the two main properties of refinements.
*)

(* Begin_Tex_Verb *)
Definition Refinement [m:nat][Q:(Partition Hab m)] :=
  {f:nat->nat |
    ((f O)=O)/\((f n)=m)/\
    ((i,j:nat)(lt i j)->(lt (f i) (f j))) &
      (i:nat)(H:(le i n)){H':(Cle (f i) m) |
        (Pts P i H)[=](Pts Q (f i) (Cle_to ?? H'))}}.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Refinement_lemma : (m,Q:?)(Refinement m Q)->
  (i:nat)(Hi:(le i m))(Hi':(le (S i) m))
    {j:nat & {Hj:(Cle j n) & {Hj':(Cle (S j) n) |
      ((Pts P ? (Cle_to ?? Hj))[<=](Pts Q ? Hi)) |
      ((Pts Q ? Hi')[<=](Pts P ? (Cle_to ?? Hj')))}}}.
(* End_Tex_Verb *)
Intros.
Elim H; Clear H; Intros f Hf.
Elim Hf; Clear Hf; Intros Hf0 Hf.
Elim Hf; Clear Hf; Intros Hfn Hfmon.
Intro Hf.
Cut {j:nat | (le (f j) i) | (le (S i) (f (S j)))}.
Intro.
Elim H; Clear H; Intros j Hj Hj'.
Exists j.
Cut (lt j n).
Intro.
Cut (le j n); [Intro | Auto with arith].
Cut (Cle j n); [Intro Hj1 | Auto].
Exists Hj1.
Elim (Hf j H0); Intros H' HPts.
Cut (le (S j) n); [Intro | Apply H].
Cut (Cle (S j) n); [Intro Hj2 | Auto].
Elim (Hf (S j) H1); Intros H'' HPts'.
Exists Hj2.
EApply leEq_wdl.
2: EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply HPts.
Apply Partition_mon; Assumption.
Apply prf1; Auto.
EApply leEq_wdr.
2: EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply HPts'.
Apply Partition_mon; Assumption.
Apply prf1; Auto.
Clear Hj' Hf Hf0.
Cut (lt i (f n)).
Intro.
Cut (lt (f j) (f n)); [Intro | Apply le_lt_trans with i; Auto].
Apply not_ge.
Intro; Red in H1.
Apply (le_not_lt (f j) (f n)); Auto with arith.
Apply Hfmon.
Elim (le_lt_eq_dec ?? H1); Intro; Auto.
Rewrite b0 in H0; Elim (lt_n_n (f j)); Auto.
Rewrite <- Hfn in Hi'; Auto.
Apply mon_fun_covers; Auto.
Exists n; Clear Hf Hfmon.
Rewrite Hfn; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Mesh_leEq : (m,Q:?)(Refinement m Q)->(Mesh Q)[<=](Mesh P).
(* End_Tex_Verb *)
Intro; Case m.
Intros.
Unfold 1 Mesh; Simpl.
Apply Mesh_nonneg.
Clear m; Intro m; Intros.
Unfold 1 Mesh.
Apply maxlist_leEq.
Simpl; Auto with arith.
Intros.
Cut {i:nat & {Hi:(Cle i (S m)) & {Hi':(Cle (S i) (S m)) |  x[=](Pts Q ? (Cle_to ?? Hi'))[-](Pts Q ? (Cle_to ?? Hi))}}}.
2: Apply Part_Mesh_List_lemma; Assumption.
Clear H0; Intro.
Elim H0; Clear H0; Intros i H0.
Elim H0; Clear H0; Intros Hi H0.
Elim H0; Clear H0; Intros Hi' H0.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply H0.
Elim H; Intros f Hf.
Elim Hf; Clear Hf; Intros Hf' Hf.
Cut {j:nat & {Hj:(Cle j n) & {Hj':(Cle (S j) n) |
      ((Pts P ? (Cle_to ?? Hj))[<=](Pts Q ? (Cle_to ?? Hi))) | ((Pts Q ? (Cle_to ?? Hi'))[<=](Pts P ? (Cle_to ?? Hj')))}}}.
Intro.
Elim H1; Intros j Hj.
Elim Hj; Clear H1 Hj; Intros Hj Hjaux.
Elim Hjaux; Clear Hjaux; Intros Hj' Hjaux.
Intros HPts HPts'.
Apply leEq_transitive with (Pts P ? (Cle_to ?? Hj'))[-](Pts P ? (Cle_to ?? Hj)).
Unfold cg_minus; Apply plus_resp_leEq_both.
Assumption.
Apply inv_resp_leEq; Assumption.
Apply Mesh_lemma.
Apply Refinement_lemma; Assumption.
Qed.

End Lemmas.

Implicits Refinement [1 2 3 4 6].