./._Voevodsky-Coq000777 000765 000024 00000000256 12404034072 014502 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/000777 000765 000024 00000000000 12404034072 014177 5ustar00nicolastaff000000 000000 Voevodsky-Coq/._.gitignore000777 000765 000024 00000000256 12346040720 016414 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/.gitignore000777 000765 000024 00000000145 12346040720 016174 0ustar00nicolastaff000000 000000 coq-8.4pl3-uf .#* *.html *.css *.vo *.glob *.v.d /TAGS .#* /html .*.aux /Make.makefile.bak .DS_store Voevodsky-Coq/._Coq_patch000777 000765 000024 00000000256 12404034072 016246 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/Coq_patch/000777 000765 000024 00000000000 12404034072 016100 5ustar00nicolastaff000000 000000 Voevodsky-Coq/._Generalities000777 000765 000024 00000000256 12404034072 016760 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/Generalities/000777 000765 000024 00000000000 12404034072 016612 5ustar00nicolastaff000000 000000 Voevodsky-Coq/._hlevel1000777 000765 000024 00000000256 12404034072 015705 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel1/000777 000765 000024 00000000000 12404034072 015537 5ustar00nicolastaff000000 000000 Voevodsky-Coq/._hlevel2000777 000765 000024 00000000256 12404034072 015706 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/000777 000765 000024 00000000000 12404034072 015540 5ustar00nicolastaff000000 000000 Voevodsky-Coq/._Makefile000777 000765 000024 00000000256 12346040720 016064 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/Makefile000777 000765 000024 00000005423 12346040720 015650 0ustar00nicolastaff000000 000000 all : hlevel2/hq.vo hlevel2/finitesets.vo Proof_of_Extensionality/funextfun.vo hlevel2/hq.vo : hlevel2/hq.v hlevel2/hz.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 hq hlevel2/hz.vo : hlevel2/hz.v hlevel2/hnat.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 hz hlevel2/finitesets.vo : hlevel2/finitesets.v hlevel2/stnfsets.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 finitesets hlevel2/stnfsets.vo : hlevel2/stnfsets.v hlevel2/hnat.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 stnfsets hlevel2/hnat.vo : hlevel2/hnat.v hlevel2/algebra1d.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 hnat hlevel2/algebra1d.vo : hlevel2/algebra1d.v hlevel2/algebra1c.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 algebra1d hlevel2/algebra1c.vo : hlevel2/algebra1c.v hlevel2/algebra1b.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 algebra1c hlevel2/algebra1b.vo : hlevel2/algebra1b.v hlevel2/algebra1a.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 algebra1b hlevel2/algebra1a.vo : hlevel2/algebra1a.v hlevel2/hSet.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 algebra1a hlevel2/hSet.vo : hlevel2/hSet.v hlevel1/hProp.vo cd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 hSet hlevel1/hProp.vo : hlevel1/hProp.v Generalities/uu0.vo cd hlevel1/ && coqc -no-sharing -R . Foundations.hlevel1 hProp Proof_of_Extensionality/funextfun.vo : Proof_of_Extensionality/funextfun.v Generalities/uu0.vo cd Proof_of_Extensionality/ && coqc -no-sharing -R . Foundations.Proof_of_Extensionality funextfun Generalities/uu0.vo : Generalities/uu0.v Generalities/uuu.vo cd Generalities/ && coqc -no-sharing -R . Foundations.Generalities uu0 Generalities/uuu.vo : Generalities/uuu.v cd Generalities/ && coqc -no-sharing -R . Foundations.Generalities uuu clean : rm -f Generalities/*.vo Proof_of_Extensionality/*.vo hlevel1/*.vo hlevel2/*.vo rm -f Generalities/*.glob Proof_of_Extensionality/*.glob hlevel1/*.glob hlevel2/*.glob rm -fr html # # The following is copied from a makefile generated by coq_makefile V8.3pl5 # VFILES:=Generalities/uuu.v\ Generalities/uu0.v\ Proof_of_Extensionality/funextfun.v\ hlevel1/hProp.v\ hlevel2/hSet.v\ hlevel2/algebra1a.v\ hlevel2/algebra1b.v\ hlevel2/algebra1c.v\ hlevel2/algebra1d.v\ hlevel2/hnat.v\ hlevel2/stnfsets.v\ hlevel2/finitesets.v\ hlevel2/hz.v\ hlevel2/hq.v VOFILES:=$(VFILES:.v=.vo) COQLIB:=$(shell $(COQBIN)coqtop -where | sed -e 's/\\/\\\\/g') install : mkdir -p $(COQLIB)/user-contrib (for i in $(VOFILES); do \ install -d `dirname $(COQLIB)/user-contrib/Foundations/$$i`; \ install $$i $(COQLIB)/user-contrib/Foundations/$$i; \ done) html: mkdir -p html coqdoc --html -d html -R . Foundations $(VFILES) .PHONY: html Voevodsky-Coq/._Proof_of_Extensionality000777 000765 000024 00000000256 12404034072 021215 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/Proof_of_Extensionality/000777 000765 000024 00000000000 12404034072 021047 5ustar00nicolastaff000000 000000 Voevodsky-Coq/._README.md000777 000765 000024 00000000256 12346040720 015703 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/README.md000777 000765 000024 00000014417 12346040720 015472 0ustar00nicolastaff000000 000000 # UniMath By Vladimir Voevodsky February 2010 -- April 2014. This is the April 2014 version of the mathematical library for the proof assistant Coq based on the univalent semantics for the calculus of inductive constructions. This library is also available at https://github.com/UniMath/UniMath/tree/vv-master-for-coq8.4pl3patched ## Prerequisites To compile the library you have to first compile Coq 8.4pl3 patched with the patch file from `Coq_patch` subdirectory. See the `README.md` file in `Coq_patch` for further instructions on how to compile the patched Coq and how to set up your `PATH` to make the compiled binaries available. You will also need the `make` utility, but you need that already to compile Coq. We provide instructions on how to use the library with [Emacs](http://www.emacswiki.org/) and [ProofGeneral](http://proofgeneral.inf.ed.ac.uk/). Thus we assume basic familiarity with ProofGeneral. It may be possible to use other Coq interfaces, but we have not investigated them. ## Compilation Assuming the correct version of patched Coq 8.4pl3 is available on the `PATH` (see previous section), the easiest way to compile the library is by typing make in the main directory (where this `README.md` file is). The library takes about one coffee break to compile. ## Installation If you type make install the compiled library will be installed in the `user-contrib` directory of the version of Coq that was used for compilation. This step is not necessary, you can browse the library in-place without installation. ## How to use the library Once the library is compiled the individual files of the library can be followed line-by-line using an interface to Coq, such as [Proof General](http://proofgeneral.inf.ed.ac.uk/). We assume you already have a working Emacs with Proof General set up. The only bit of customization needed is to tell Proof General that is should use the patched Coq. There are two cases: 1. The `proof-prog-name-ask` variable is set to `t` and so Proof General always asks interactively which `coqtop` executable it should use. In this case point it to the `coqtop` executable from the patched Coq `coq-8.4pl3-uf`. You should still customize `coq-prog-args` by adding the `-no-sharing` option, so maybe the second case is better: 2. The `prof-prog-name-ask` variable is set to `nil` and Proof General uses the `coqtop` provided in the `coq-prog-name` variable. In this case you should set the variable to the `coqtop` executable from the patched Coq. You should also set `coq-prog-args` to `("-emacs-U" "-no-sharing")`. The customization of Emacs variables can be accomplished through "Customize options" in the Proof-General menu. To customize a specific variable, say `coq-prog-name`, type `M-x customize-variable coq-prog-name RET`. Once you have the Proof General running correctly. ## Generating the HTML files for browsing You may generate an HTML version of the files suitable for browsing by typing make html The files will be generated in the `html` subdirectory. The main file is called `index.html`. ## Description of files The library contains the following subdirectories: * `Generalities` * `hlevel1` * `hlevel2` * `Proof_of_Extensionality` ### Directory `Generalities` This directory contains the files `uuu.v` and `uu0.v`. * File `uuu.v` contains some new notations for the constructions defined in `Coq.Init` library as well as the definition of "dependent sum" `total2`. * File `uu0.v` contains the bulk of general results and definitions about types which are pertinent to the univalent approach. In this file we prove main results which apply to all types and which require only one universe level to be proved. Some of the results in `uu0` use the extensionality axiom for functions (introduced in the same file). No other axioms or resizing rules (see below) are used and these files should compile with the unpatched version of Coq-8.4. ### Directory `hlevel1` This directory contains one file `hProp.v` with results and constructions related to types of h-level 1 i.e. to types which correspond to "propositions" in our formalization. Some of the results here use " resizing rules " and therefore it will currently not compile without a `type_in_type` patch. Note that we continue to keep track of universe levels in these files "by hand" and use only those "universe re-assignment" or "resizing" rules which are semantically justified. Some of the results in this file also use the univalence axiom for hProp called `uahp` which is equivalent to the axiom asserting that if two propositions are logically equivalent then they are equal. ### Directory `hlevel2` This directory contains files with constructions and results related to types of hlevel 2 i.e. to types corresponding to sets in our formalization. * The first file is `hSet.v`. It contains most general definitions related to sets including the constructions related to set-quotients of types. * The next group of files in the hierarchy are `algebra1{a,b,c,d}.v` which contains many definitions and constructions of general abstract algebra culminating at the moment in the construction of the field of fractions of an integral domain with decidable equality. The files also contain definitions and results about the relations on algebraic structures. * The next file is `hnat.v` which contains many simple lemmas about arithmetic and comparisons on natural numbers. * Then the hierarchy branches: * On one branch there are files `stnfsets.v` and `finitesets.v` which introduce constructions related to standard and general finite sets respectively. * On another branch there are files `hz.v` and `hq.v` which introduce the basic cosntructions related to the integer and rational arithmetic as particular cases of the general theorems of the algebra1 group of files. At the end of files `finitesets.v`, `hz.v` and `hq.v` there are sample computations which show that despite our use of the extensionality axioms the relevant terms of types `bool` and `nat` fully normalize. The last computation example in `hq.v` which evaluates the absolute value of the integral part of `10 / -3`. ### Directory `Proof_of_Extensionality` This directory contains the formulation of general Univalence Axiom and a proof that it implies functional extensionality. Voevodsky-Coq/README.txt000777 000765 000024 00000000000 12352047726 017161 2README.mdustar00nicolastaff000000 000000 Voevodsky-Coq/Proof_of_Extensionality/._funextfun.v000777 000765 000024 00000000256 12346040720 023505 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/Proof_of_Extensionality/funextfun.v000777 000765 000024 00000016137 12346040720 023275 0ustar00nicolastaff000000 000000 (** * Univalence axiom and functional extensionality. Vladimir Voevodsky. Feb. 2010 - Sep. 2011 This file contains the formulation of the univalence axiom and the proof that it implies functional extensionality for functions - Theorem funextfun. *) (** *** Preamble. *) (** *** Imports. *) Unset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *) Add LoadPath ".." as Foundations. Require Export Foundations.Generalities.uu0. (** ** Univalence axiom. *) Definition eqweqmap { T1 T2 : UU } ( e: paths T1 T2 ) : weq T1 T2 . Proof. intros. destruct e . apply idweq. Defined. Axiom univalenceaxiom : forall T1 T2 : UU , isweq ( @eqweqmap T1 T2 ). Definition weqtopaths { T1 T2 : UU } ( w : weq T1 T2 ) : paths T1 T2 := invmap ( weqpair _ ( univalenceaxiom T1 T2 ) ) w. Definition weqpathsweq { T1 T2 : UU } ( w : weq T1 T2 ) : paths ( eqweqmap ( weqtopaths w ) ) w := homotweqinvweq ( weqpair _ ( univalenceaxiom T1 T2 ) ) w. (** We show that [ univalenceaxiom ] is equivalent to the axioms [ weqtopaths0 ] and [ weqpathsweq0 ] stated below . *) Axiom weqtopaths0 : forall ( T1 T2 : UU ) ( w : weq T1 T2 ) , paths T1 T2. Axiom weqpathsweq0 : forall ( T1 T2 : UU ) ( w : weq T1 T2 ) , paths ( eqweqmap ( weqtopaths0 _ _ w ) ) w. Theorem univfromtwoaxioms ( T1 T2 : UU ) : isweq ( @eqweqmap T1 T2 ). Proof. intros. set ( P1 := fun XY : dirprod UU UU => ( match XY with tpair X Y => paths X Y end ) ) . set ( P2 := fun XY : dirprod UU UU => match XY with tpair X Y => weq X Y end ) . set ( Z1 := total2 P1 ). set ( Z2 := total2 P2 ). set ( f := totalfun _ _ ( fun XY : dirprod UU UU => match XY with tpair X Y => @eqweqmap X Y end ) : Z1 -> Z2 ) . set ( g := totalfun _ _ ( fun XY : dirprod UU UU => match XY with tpair X Y => weqtopaths0 X Y end ) : Z2 -> Z1 ) . set ( s1 := fun X Y : UU => fun w : weq X Y => tpair P2 ( dirprodpair X Y ) w ) . set ( efg := fun a => match a as a' return ( paths ( f ( g a' ) ) a' ) with tpair ( tpair X Y ) w => ( maponpaths ( s1 X Y ) ( weqpathsweq0 X Y w ) ) end ) . set ( h := fun a1 : Z1 => pr1 ( pr1 a1 ) ) . assert ( egf0 : forall a1 : Z1 , paths ( pr1 ( g ( f a1 ) ) ) ( pr1 a1 ) ). intro. apply idpath. assert ( egf1 : forall a1 a1' : Z1 , paths ( pr1 a1' ) ( pr1 a1 ) -> paths a1' a1 ). intros. set ( X' := maponpaths ( @pr1 _ _ ) X ). assert ( is : isweq h ). apply isweqpr1pr1 . apply ( invmaponpathsweq ( weqpair h is ) _ _ X' ). set ( egf := fun a1 => ( egf1 _ _ ( egf0 a1 ) ) ). set ( is2 := gradth _ _ egf efg ). apply ( isweqtotaltofib P1 P2 ( fun XY : dirprod UU UU => match XY with tpair X Y => @eqweqmap X Y end ) is2 ( dirprodpair T1 T2 ) ). Defined. (** Conjecture : the pair [weqtopaths0] and [weatopathsweq0] is well defined up to a canonical equality. **) (** ** Transport theorem. Theorem saying that any general scheme to "transport" a structure along a weak equivalence which does not change the structure in the case of the identity equivalence is equivalent to the transport along the path which corresponds to a weak equivalence by the univalenceaxiom. As a corollary we conclude that for any such transport scheme the corresponding maps on spaes of structures are weak equivalences. *) Lemma isweqtransportf10 { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : isweq ( transportf P e ). Proof. intros. destruct e. apply idisweq. Defined. Lemma isweqtransportb10 { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : isweq ( transportb P e ). Proof. intros. apply ( isweqtransportf10 _ ( pathsinv0 e ) ). Defined. Lemma l1 { X0 X0' : UU } ( ee : paths X0 X0' ) ( P : UU -> UU ) ( pp' : P X0' ) ( R : forall X X' : UU , forall w : weq X X' , P X' -> P X ) ( r : forall X : UU , forall p : P X , paths ( R X X ( idweq X ) p ) p ) : paths ( R X0 X0' ( eqweqmap ee ) pp' ) ( transportb P ee pp' ). Proof. intro. intro. intro. intro. intro. destruct ee. simpl. intro. intro. apply r. Defined. Theorem weqtransportb ( P : UU -> UU ) ( R : forall ( X X' : UU ) ( w : weq X X' ) , P X' -> P X ) ( r : forall X : UU , forall p : P X , paths ( R X X ( idweq X ) p ) p ) : forall ( X X' : UU ) ( w : weq X X' ) ( p' : P X' ) , paths ( R X X' w p' ) ( transportb P ( weqtopaths w ) p' ). Proof. intros. set ( uv := weqtopaths w ). set ( v := eqweqmap uv ). assert ( e : paths v w ) . unfold weqtopaths in uv. apply ( homotweqinvweq ( weqpair _ ( univalenceaxiom X X' ) ) w ). assert ( ee : paths ( R X X' v p' ) ( R X X' w p' ) ) . set ( R' := fun vis : weq X X' => R X X' vis p' ). assert ( ee' : paths ( R' v ) ( R' w ) ). apply ( maponpaths R' e ). assumption. destruct ee. apply l1. assumption. Defined. Corollary isweqweqtransportb ( P : UU -> UU ) ( R : forall ( X X' : UU ) ( w : weq X X' ) , P X' -> P X ) ( r : forall X : UU , forall p : P X , paths ( R X X ( idweq X ) p ) p ) : forall ( X X' : UU ) ( w : weq X X' ) , isweq ( fun p' : P X' => R X X' w p' ). Proof. intros. assert ( e : forall p' : P X' , paths ( R X X' w p' ) ( transportb P ( weqtopaths w ) p' ) ). apply weqtransportb. assumption. assert ( ee : forall p' : P X' , paths ( transportb P ( weqtopaths w ) p' ) ( R X X' w p' ) ). intro. apply ( pathsinv0 ( e p' ) ). clear e. assert ( is1 : isweq ( transportb P ( weqtopaths w ) ) ). apply isweqtransportb10. apply ( isweqhomot ( transportb P ( weqtopaths w ) ) ( fun p' : P X' => R X X' w p' ) ee is1 ). Defined. (** Theorem saying that composition with a weak equivalence is a weak equivalence on function spaces. *) Theorem isweqcompwithweq { X X' : UU } ( w : weq X X' ) ( Y : UU ) : isweq ( fun f : X' -> Y => ( fun x : X => f ( w x ) ) ). Proof. intros. set ( P := fun X0 : UU => ( X0 -> Y ) ). set ( R := fun X0 : UU => ( fun X0' : UU => ( fun w1 : X0 -> X0' => ( fun f : P X0' => ( fun x : X0 => f ( w1 x ) ) ) ) ) ). set ( r := fun X0 : UU => ( fun f : X0 -> Y => pathsinv0 ( etacor f ) ) ). apply ( isweqweqtransportb P R r X X' w ). Defined. (** ** Proof of the functional extensionality for functions *) Lemma eqcor0 { X X' : UU } ( w : weq X X' ) ( Y : UU ) ( f1 f2 : X' -> Y ) : paths ( fun x : X => f1 ( w x ) ) ( fun x : X => f2 ( w x ) ) -> paths f1 f2. Proof. intros. apply ( invmaponpathsweq ( weqpair _ ( isweqcompwithweq w Y ) ) f1 f2 ). assumption. Defined. Lemma apathpr1topr ( T : UU ) : paths ( fun z : pathsspace T => pr1 z ) ( fun z : pathsspace T => pr1 ( pr2 z ) ). Proof. intro. apply ( eqcor0 ( weqpair _ ( isweqdeltap T ) ) _ ( fun z : pathsspace T => pr1 z ) ( fun z : pathsspace T => pr1 ( pr2 z ) ) ( idpath ( idfun T ) ) ) . Defined. Theorem funextfun { X Y : UU } ( f1 f2 : X -> Y ) ( e : forall x : X , paths ( f1 x ) ( f2 x ) ) : paths f1 f2. Proof. intros. set ( f := fun x : X => pathsspacetriple Y ( e x ) ) . set ( g1 := fun z : pathsspace Y => pr1 z ) . set ( g2 := fun z : pathsspace Y => pr1 ( pr2 z ) ). assert ( e' : paths g1 g2 ). apply ( apathpr1topr Y ). assert ( ee : paths ( fun x : X => f1 x ) ( fun x : X => f2 x ) ). change ( paths (fun x : X => g1 ( f x ) ) (fun x : X => g2 ( f x ) ) ) . destruct e' . apply idpath . apply etacoronpaths. apply ee . Defined. (* End of the file funextfun.v *) Voevodsky-Coq/hlevel2/._algebra1a.v000777 000765 000024 00000000256 12346040720 017773 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/algebra1a.v000777 000765 000024 00000213720 12346040720 017560 0ustar00nicolastaff000000 000000 (** * Algebra 1 . Part A . Generalities. 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 ".." as Foundations. Require Export Foundations.hlevel2.hSet . (** To upstream files *) (** ** Sets with one and two binary operations *) (** *** Binary operations *) (** **** General definitions *) Definition binop ( X : UU ) := X -> X -> X . Definition islcancelable { X : UU } ( opp : binop X ) ( x : X ) := isincl ( fun x0 : X => opp x x0 ) . Definition isrcancelable { X : UU } ( opp : binop X ) ( x : X ) := isincl ( fun x0 : X => opp x0 x ) . Definition iscancelable { X : UU } ( opp : binop X ) ( x : X ) := dirprod ( islcancelable opp x ) ( isrcancelable opp x ) . Definition islinvertible { X : UU } ( opp : binop X ) ( x : X ) := isweq ( fun x0 : X => opp x x0 ) . Definition isrinvertible { X : UU } ( opp : binop X ) ( x : X ) := isweq ( fun x0 : X => opp x0 x ) . Definition isinvertible { X : UU } ( opp : binop X ) ( x : X ) := dirprod ( islinvertible opp x ) ( isrinvertible opp x ) . (** **** Standard conditions on one binary operation on a set *) (** *) Definition isassoc { X : hSet} ( opp : binop X ) := forall x x' x'' , paths ( opp ( opp x x' ) x'' ) ( opp x ( opp x' x'' ) ) . Lemma isapropisassoc { X : hSet } ( opp : binop X ) : isaprop ( isassoc opp ) . Proof . intros . apply impred . intro x . apply impred . intro x' . apply impred . intro x'' . simpl . apply ( setproperty X ) . Defined . (** *) Definition islunit { X : hSet} ( opp : binop X ) ( un0 : X ) := forall x : X , paths ( opp un0 x ) x . Lemma isapropislunit { X : hSet} ( opp : binop X ) ( un0 : X ) : isaprop ( islunit opp un0 ) . Proof . intros . apply impred . intro x . simpl . apply ( setproperty X ) . Defined . Definition isrunit { X : hSet} ( opp : binop X ) ( un0 : X ) := forall x : X , paths ( opp x un0 ) x . Lemma isapropisrunit { X : hSet} ( opp : binop X ) ( un0 : X ) : isaprop ( isrunit opp un0 ) . Proof . intros . apply impred . intro x . simpl . apply ( setproperty X ) . Defined . Definition isunit { X : hSet} ( opp : binop X ) ( un0 : X ) := dirprod ( islunit opp un0 ) ( isrunit opp un0 ) . Definition isunital { X : hSet} ( opp : binop X ) := total2 ( fun un0 : X => isunit opp un0 ) . Definition isunitalpair { X : hSet } { opp : binop X } ( un0 : X ) ( is : isunit opp un0 ) : isunital opp := tpair _ un0 is . Lemma isapropisunital { X : hSet} ( opp : binop X ) : isaprop ( isunital opp ) . Proof . intros . apply ( @isapropsubtype X ( fun un0 : _ => hconj ( hProppair _ ( isapropislunit opp un0 ) ) ( hProppair _ ( isapropisrunit opp un0 ) ) ) ) . intros u1 u2 . intros ua1 ua2 . apply ( pathscomp0 ( pathsinv0 ( pr2 ua2 u1 ) ) ( pr1 ua1 u2 ) ) . Defined . (** *) Definition ismonoidop { X : hSet } ( opp : binop X ) := dirprod ( isassoc opp ) ( isunital opp ) . Definition assocax_is { X : hSet } { opp : binop X } : ismonoidop opp -> isassoc opp := @pr1 _ _ . Definition unel_is { X : hSet } { opp : binop X } ( is : ismonoidop opp ) : X := pr1 ( pr2 is ) . Definition lunax_is { X : hSet } { opp : binop X } ( is : ismonoidop opp ) := pr1 ( pr2 ( pr2 is ) ) . Definition runax_is { X : hSet } { opp : binop X } ( is : ismonoidop opp ) := pr2 ( pr2 ( pr2 is ) ) . Lemma isapropismonoidop { X : hSet } ( opp : binop X ) : isaprop ( ismonoidop opp ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply ( isapropisassoc ) . apply ( isapropisunital ) . Defined . (** *) Definition islinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) := forall x : X , paths ( opp ( inv0 x ) x ) un0 . Lemma isapropislinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) : isaprop ( islinv opp un0 inv0 ) . Proof . intros . apply impred . intro x . apply ( setproperty X (opp (inv0 x) x) un0 ) . Defined . Definition isrinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) := forall x : X , paths ( opp x ( inv0 x ) ) un0 . Lemma isapropisrinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) : isaprop ( isrinv opp un0 inv0 ) . Proof . intros . apply impred . intro x . apply ( setproperty X ) . Defined . Definition isinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) := dirprod ( islinv opp un0 inv0 ) ( isrinv opp un0 inv0 ) . Lemma isapropisinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) : isaprop ( isinv opp un0 inv0 ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropislinv . apply isapropisrinv . Defined . Definition invstruct { X : hSet } ( opp : binop X ) ( is : ismonoidop opp ) := total2 ( fun inv0 : X -> X => isinv opp ( unel_is is ) inv0 ) . Definition isgrop { X : hSet } ( opp : binop X ) := total2 ( fun is : ismonoidop opp => invstruct opp is ) . Definition isgroppair { X : hSet } { opp : binop X } ( is1 : ismonoidop opp ) ( is2 : invstruct opp is1 ) : isgrop opp := tpair ( fun is : ismonoidop opp => invstruct opp is ) is1 is2 . Definition pr1isgrop ( X : hSet ) ( opp : binop X ) : isgrop opp -> ismonoidop opp := @pr1 _ _ . Coercion pr1isgrop : isgrop >-> ismonoidop . Definition grinv_is { X : hSet } { opp : binop X } ( is : isgrop opp ) : X -> X := pr1 ( pr2 is ) . Definition grlinvax_is { X : hSet } { opp : binop X } ( is : isgrop opp ) := pr1 ( pr2 ( pr2 is ) ) . Definition grrinvax_is { X : hSet } { opp : binop X } ( is : isgrop opp ) := pr2 ( pr2 ( pr2 is ) ) . Lemma isweqrmultingr_is { X : hSet } { opp : binop X } ( is : isgrop opp ) ( x0 : X ) : isrinvertible opp x0 . Proof . intros . destruct is as [ is istr ] . set ( f := fun x : X => opp x x0 ) . set ( g := fun x : X => opp x ( ( pr1 istr ) x0 ) ) . destruct is as [ assoc isun0 ] . destruct istr as [ inv0 axs ] . destruct isun0 as [ un0 unaxs ] . simpl in * |- . assert ( egf : forall x : _ , paths ( g ( f x ) ) x ) . intro x . unfold f . unfold g . destruct ( pathsinv0 ( assoc x x0 ( inv0 x0 ) ) ) . assert ( e := pr2 axs x0 ) . simpl in e . rewrite e . apply ( pr2 unaxs x ) . assert ( efg : forall x : _ , paths ( f ( g x ) ) x ) . intro x . unfold f . unfold g . destruct ( pathsinv0 ( assoc x ( inv0 x0 ) x0 ) ) . assert ( e := pr1 axs x0 ) . simpl in e . rewrite e . apply ( pr2 unaxs x ) . apply ( gradth _ _ egf efg ) . Defined . Lemma isweqlmultingr_is { X : hSet } { opp : binop X } ( is : isgrop opp ) ( x0 : X ) : islinvertible opp x0 . Proof . intros . destruct is as [ is istr ] . set ( f := fun x : X => opp x0 x ) . set ( g := fun x : X => opp ( ( pr1 istr ) x0 ) x ) . destruct is as [ assoc isun0 ] . destruct istr as [ inv0 axs ] . destruct isun0 as [ un0 unaxs ] . simpl in * |- . assert ( egf : forall x : _ , paths ( g ( f x ) ) x ) . intro x . unfold f . unfold g . destruct ( assoc ( inv0 x0 ) x0 x ) . assert ( e := pr1 axs x0 ) . simpl in e . rewrite e . apply ( pr1 unaxs x ) . assert ( efg : forall x : _ , paths ( f ( g x ) ) x ) . intro x . unfold f . unfold g . destruct ( assoc x0 ( inv0 x0 ) x ) . assert ( e := pr2 axs x0 ) . simpl in e . rewrite e . apply ( pr1 unaxs x ) . apply ( gradth _ _ egf efg ) . Defined . Lemma isapropinvstruct { X : hSet } { opp : binop X } ( is : ismonoidop opp ) : isaprop ( invstruct opp is ) . Proof . intros . apply isofhlevelsn . intro is0 . set ( un0 := pr1 ( pr2 is ) ) . assert ( int : forall i : X -> X , isaprop ( dirprod ( forall x : X , paths ( opp ( i x ) x ) un0 ) ( forall x : X , paths ( opp x ( i x ) ) un0 ) ) ) . intro i . apply ( isofhleveldirprod 1 ) . apply impred . intro x . simpl . apply ( setproperty X ) . apply impred . intro x . simpl . apply ( setproperty X ) . apply ( isapropsubtype ( fun i : _ => hProppair _ ( int i ) ) ) . intros inv1 inv2 . simpl . intro ax1 . intro ax2 . apply funextfun . intro x0 . apply ( invmaponpathsweq ( weqpair _ ( isweqrmultingr_is ( tpair _ is is0 ) x0 ) ) ) . simpl . rewrite ( pr1 ax1 x0 ) . rewrite ( pr1 ax2 x0 ) . apply idpath . Defined . Lemma isapropisgrop { X : hSet } ( opp : binop X ) : isaprop ( isgrop opp ) . Proof . intros . apply ( isofhleveltotal2 1 ) . apply isapropismonoidop . apply isapropinvstruct . Defined . (* (** Unitary monoid where all elements are invertible is a group *) Definition allinvvertibleinv { X : hSet } { opp : binop X } ( is : ismonoidop opp ) ( allinv : forall x : X , islinvertible opp x ) : X -> X := fun x : X => invmap ( weqpair _ ( allinv x ) ) ( unel_is is ) . *) (** The following lemma is an analog of [ Bourbaki , Alg. 1 , ex. 2 , p. 132 ] *) Lemma isgropif { X : hSet } { opp : binop X } ( is0 : ismonoidop opp ) ( is : forall x : X, hexists ( fun x0 : X => eqset ( opp x x0 ) ( unel_is is0 ) ) ) : isgrop opp . Proof . intros . split with is0 . destruct is0 as [ assoc isun0 ] . destruct isun0 as [ un0 unaxs0 ] . simpl in is . simpl in unaxs0 . simpl in un0 . simpl in assoc . simpl in unaxs0 . assert ( l1 : forall x' : X , isincl ( fun x0 : X => opp x0 x' ) ) . intro x' . apply ( @hinhuniv ( total2 ( fun x0 : X => paths ( opp x' x0 ) un0 ) ) ( hProppair _ ( isapropisincl ( fun x0 : X => opp x0 x' ) ) ) ) . intro int1 . simpl . apply isinclbetweensets . apply ( pr2 X ) . apply ( pr2 X ) . intros a b . intro e . rewrite ( pathsinv0 ( pr2 unaxs0 a ) ) . rewrite ( pathsinv0 ( pr2 unaxs0 b ) ) . destruct int1 as [ invx' eq ] . rewrite ( pathsinv0 eq ) . destruct ( assoc a x' invx' ) . destruct ( assoc b x' invx' ) . rewrite e . apply idpath . apply ( is x' ) . assert ( is' : forall x : X, hexists ( fun x0 : X => eqset ( opp x0 x ) un0 ) ) . intro x . apply ( fun f : _ => hinhuniv f ( is x ) ) . intro s1 . destruct s1 as [ x' eq ] . apply hinhpr . split with x' . simpl . apply ( invmaponpathsincl _ ( l1 x' ) ) . rewrite ( assoc x' x x' ) . rewrite eq . rewrite ( pr1 unaxs0 x' ) . unfold unel_is. simpl . rewrite ( pr2 unaxs0 x' ) . apply idpath . assert ( l1' : forall x' : X , isincl ( fun x0 : X => opp x' x0 ) ) . intro x' . apply ( @hinhuniv ( total2 ( fun x0 : X => paths ( opp x0 x' ) un0 ) ) ( hProppair _ ( isapropisincl ( fun x0 : X => opp x' x0 ) ) ) ) . intro int1 . simpl . apply isinclbetweensets . apply ( pr2 X ) . apply ( pr2 X ) . intros a b . intro e . rewrite ( pathsinv0 ( pr1 unaxs0 a ) ) . rewrite ( pathsinv0 ( pr1 unaxs0 b ) ) . destruct int1 as [ invx' eq ] . rewrite ( pathsinv0 eq ) . destruct ( pathsinv0 ( assoc invx' x' a ) ) . destruct ( pathsinv0 ( assoc invx' x' b ) ) . rewrite e . apply idpath . apply ( is' x' ) . assert ( int : forall x : X , isaprop ( total2 ( fun x0 : X => eqset ( opp x0 x ) un0 ) ) ) . intro x . apply isapropsubtype . intros x1 x2 . intros eq1 eq2 . apply ( invmaponpathsincl _ ( l1 x ) ) . rewrite eq1 . rewrite eq2 . apply idpath . simpl . set ( linv0 := fun x : X => hinhunivcor1 ( hProppair _ ( int x ) ) ( is' x ) ) . simpl in linv0 . set ( inv0 := fun x : X => pr1 ( linv0 x ) ) . split with inv0 . simpl . split with ( fun x : _ => pr2 ( linv0 x ) ) . intro x . apply ( invmaponpathsincl _ ( l1 x ) ) . rewrite ( assoc x ( inv0 x ) x ) . change ( inv0 x ) with ( pr1 ( linv0 x ) ) . rewrite ( pr2 ( linv0 x ) ) . unfold unel_is . simpl . rewrite ( pr1 unaxs0 x ) . rewrite ( pr2 unaxs0 x ) . apply idpath . Defined . (** *) Definition iscomm { X : hSet} ( opp : binop X ) := forall x x' : X , paths ( opp x x' ) ( opp x' x ) . Lemma isapropiscomm { X : hSet } ( opp : binop X ) : isaprop ( iscomm opp ) . Proof . intros . apply impred . intros x . apply impred . intro x' . simpl . apply ( setproperty X ) . Defined . Definition isabmonoidop { X : hSet } ( opp : binop X ) := dirprod ( ismonoidop opp ) ( iscomm opp ) . Definition pr1isabmonoidop ( X : hSet ) ( opp : binop X ) : isabmonoidop opp -> ismonoidop opp := @pr1 _ _ . Coercion pr1isabmonoidop : isabmonoidop >-> ismonoidop . Definition commax_is { X : hSet} { opp : binop X } ( is : isabmonoidop opp ) : iscomm opp := pr2 is . Lemma isapropisabmonoidop { X : hSet } ( opp : binop X ) : isaprop ( isabmonoidop opp ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropismonoidop . apply isapropiscomm . Defined . Lemma abmonoidoprer { X : hSet } { opp : binop X } ( is : isabmonoidop opp ) ( a b c d : X ) : paths ( opp ( opp a b ) ( opp c d ) ) ( opp ( opp a c ) ( opp b d ) ) . Proof . intros . destruct is as [ is comm ] . destruct is as [ assoc unital0 ] . simpl in * . destruct ( assoc ( opp a b ) c d ) . destruct ( assoc ( opp a c ) b d ) . destruct ( pathsinv0 ( assoc a b c ) ) . destruct ( pathsinv0 ( assoc a c b ) ) . destruct ( comm b c ) . apply idpath . Defined . (** *) Lemma weqlcancelablercancelable { X : hSet } ( opp : binop X ) ( is : iscomm opp ) ( x : X ) : weq ( islcancelable opp x ) ( isrcancelable opp x ) . Proof . intros . assert ( f : ( islcancelable opp x ) -> ( isrcancelable opp x ) ) . unfold islcancelable . unfold isrcancelable . intro isl . apply ( fun h : _ => isinclhomot _ _ h isl ) . intro x0 . apply is . assert ( g : ( isrcancelable opp x ) -> ( islcancelable opp x ) ) . unfold islcancelable . unfold isrcancelable . intro isr . apply ( fun h : _ => isinclhomot _ _ h isr ) . intro x0 . apply is . split with f . apply ( isweqimplimpl f g ( isapropisincl ( fun x0 : X => opp x x0 ) ) ( isapropisincl ( fun x0 : X => opp x0 x ) ) ) . Defined . Lemma weqlinvertiblerinvertible { X : hSet } ( opp : binop X ) ( is : iscomm opp ) ( x : X ) : weq ( islinvertible opp x ) ( isrinvertible opp x ) . Proof . intros . assert ( f : ( islinvertible opp x ) -> ( isrinvertible opp x ) ) . unfold islinvertible . unfold isrinvertible . intro isl . apply ( fun h : _ => isweqhomot _ _ h isl ) . apply is . assert ( g : ( isrinvertible opp x ) -> ( islinvertible opp x ) ) . unfold islinvertible . unfold isrinvertible . intro isr . apply ( fun h : _ => isweqhomot _ _ h isr ) . intro x0 . apply is . split with f . apply ( isweqimplimpl f g ( isapropisweq ( fun x0 : X => opp x x0 ) ) ( isapropisweq ( fun x0 : X => opp x0 x ) ) ) . Defined . Lemma weqlunitrunit { X : hSet } ( opp : binop X ) ( is : iscomm opp ) ( un0 : X ) : weq ( islunit opp un0 ) ( isrunit opp un0 ) . Proof . intros . assert ( f : ( islunit opp un0 ) -> ( isrunit opp un0 ) ) . unfold islunit . unfold isrunit . intro isl . intro x . destruct ( is un0 x ) . apply ( isl x ) . assert ( g : ( isrunit opp un0 ) -> ( islunit opp un0 ) ) . unfold islunit . unfold isrunit . intro isr . intro x . destruct ( is x un0 ) . apply ( isr x ) . split with f . apply ( isweqimplimpl f g ( isapropislunit opp un0 ) ( isapropisrunit opp un0 ) ) . Defined . Lemma weqlinvrinv { X : hSet } ( opp : binop X ) ( is : iscomm opp ) ( un0 : X ) ( inv0 : X -> X ) : weq ( islinv opp un0 inv0 ) ( isrinv opp un0 inv0 ) . Proof . intros . assert ( f : ( islinv opp un0 inv0 ) -> ( isrinv opp un0 inv0 ) ) . unfold islinv . unfold isrinv . intro isl . intro x . destruct ( is ( inv0 x ) x ) . apply ( isl x ) . assert ( g : ( isrinv opp un0 inv0 ) -> ( islinv opp un0 inv0 ) ) . unfold islinv . unfold isrinv . intro isr . intro x . destruct ( is x ( inv0 x ) ) . apply ( isr x ) . split with f . apply ( isweqimplimpl f g ( isapropislinv opp un0 inv0 ) ( isapropisrinv opp un0 inv0 ) ) . Defined . Opaque abmonoidoprer . (** *) Definition isabgrop { X : hSet } ( opp : binop X ) := dirprod ( isgrop opp ) ( iscomm opp ) . Definition pr1isabgrop ( X : hSet ) ( opp : binop X ) : isabgrop opp -> isgrop opp := @pr1 _ _ . Coercion pr1isabgrop : isabgrop >-> isgrop . Definition isabgroptoisabmonoidop ( X : hSet ) ( opp : binop X ) : isabgrop opp -> isabmonoidop opp := fun is : _ => dirprodpair ( pr1 ( pr1 is ) ) ( pr2 is ) . Coercion isabgroptoisabmonoidop : isabgrop >-> isabmonoidop . Lemma isapropisabgrop { X : hSet } ( opp : binop X ) : isaprop ( isabgrop opp ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropisgrop . apply isapropiscomm . Defined . (** **** Standard conditions on a pair of binary operations on a set *) (** *) Definition isldistr { X : hSet} ( opp1 opp2 : binop X ) := forall x x' x'' : X , paths ( opp2 x'' ( opp1 x x' ) ) ( opp1 ( opp2 x'' x ) ( opp2 x'' x' ) ) . Lemma isapropisldistr { X : hSet} ( opp1 opp2 : binop X ) : isaprop ( isldistr opp1 opp2 ) . Proof . intros . apply impred . intro x . apply impred . intro x' . apply impred . intro x'' . simpl . apply ( setproperty X ) . Defined . Definition isrdistr { X : hSet} ( opp1 opp2 : binop X ) := forall x x' x'' : X , paths ( opp2 ( opp1 x x' ) x'' ) ( opp1 ( opp2 x x'' ) ( opp2 x' x'' ) ) . Lemma isapropisrdistr { X : hSet} ( opp1 opp2 : binop X ) : isaprop ( isrdistr opp1 opp2 ) . Proof . intros . apply impred . intro x . apply impred . intro x' . apply impred . intro x'' . simpl . apply ( setproperty X ) . Defined . Definition isdistr { X : hSet } ( opp1 opp2 : binop X ) := dirprod ( isldistr opp1 opp2 ) ( isrdistr opp1 opp2 ) . Lemma isapropisdistr { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( isdistr opp1 opp2 ) . Proof . intros . apply ( isofhleveldirprod 1 _ _ ( isapropisldistr _ _ ) ( isapropisrdistr _ _ ) ) . Defined . (** *) Lemma weqldistrrdistr { X : hSet} ( opp1 opp2 : binop X ) ( is : iscomm opp2 ) : weq ( isldistr opp1 opp2 ) ( isrdistr opp1 opp2 ) . Proof . intros . assert ( f : ( isldistr opp1 opp2 ) -> ( isrdistr opp1 opp2 ) ) . unfold isldistr . unfold isrdistr . intro isl . intros x x' x'' . destruct ( is x'' ( opp1 x x' ) ) . destruct ( is x'' x ) . destruct ( is x'' x' ) . apply ( isl x x' x'' ) . assert ( g : ( isrdistr opp1 opp2 ) -> ( isldistr opp1 opp2 ) ) . unfold isldistr . unfold isrdistr . intro isr . intros x x' x'' . destruct ( is ( opp1 x x' ) x'' ) . destruct ( is x x'' ) . destruct ( is x' x'' ) . apply ( isr x x' x'' ) . split with f . apply ( isweqimplimpl f g ( isapropisldistr opp1 opp2 ) ( isapropisrdistr opp1 opp2 ) ) . Defined . (** *) Definition isrigops { X : hSet } ( opp1 opp2 : binop X ) := dirprod ( total2 ( fun axs : dirprod ( isabmonoidop opp1 ) ( ismonoidop opp2 ) => ( dirprod ( forall x : X , paths ( opp2 ( unel_is ( pr1 axs ) ) x ) ( unel_is ( pr1 axs ) ) ) ) ( forall x : X , paths ( opp2 x ( unel_is ( pr1 axs ) ) ) ( unel_is ( pr1 axs ) ) ) ) ) ( isdistr opp1 opp2 ) . Definition rigop1axs_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> isabmonoidop opp1 := fun is : _ => pr1 ( pr1 ( pr1 is ) ) . Definition rigop2axs_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> ismonoidop opp2 := fun is : _ => pr2 ( pr1 ( pr1 is ) ) . Definition rigdistraxs_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> isdistr opp1 opp2 := fun is : _ => pr2 is . Definition rigldistrax_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> isldistr opp1 opp2 := fun is : _ => pr1 ( pr2 is ) . Definition rigrdistrax_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> isrdistr opp1 opp2 := fun is : _ => pr2 ( pr2 is ) . Definition rigunel1_is { X : hSet } { opp1 opp2 : binop X } ( is : isrigops opp1 opp2 ) : X := pr1 (pr2 (pr1 (rigop1axs_is is))) . Definition rigunel2_is { X : hSet } { opp1 opp2 : binop X } ( is : isrigops opp1 opp2 ) : X := (pr1 (pr2 (rigop2axs_is is))) . Definition rigmult0x_is { X : hSet } { opp1 opp2 : binop X } ( is : isrigops opp1 opp2 ) ( x : X ) : paths ( opp2 ( rigunel1_is is ) x ) ( rigunel1_is is ) := pr1 ( pr2 ( pr1 is ) ) x . Definition rigmultx0_is { X : hSet } { opp1 opp2 : binop X } ( is : isrigops opp1 opp2 ) ( x : X ) : paths ( opp2 x ( rigunel1_is is ) ) ( rigunel1_is is ) := pr2 ( pr2 ( pr1 is ) ) x . Lemma isapropisrigops { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( isrigops opp1 opp2 ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply ( isofhleveltotal2 1 ) . apply ( isofhleveldirprod 1 ) . apply isapropisabmonoidop . apply isapropismonoidop. intro x . apply ( isofhleveldirprod 1 ) . apply impred. intro x' . apply ( setproperty X ) . apply impred . intro x' . apply ( setproperty X ) . apply isapropisdistr . Defined . (** *) Definition isrngops { X : hSet } ( opp1 opp2 : binop X ) := dirprod ( dirprod ( isabgrop opp1 ) ( ismonoidop opp2 ) ) ( isdistr opp1 opp2 ) . Definition rngop1axs_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> isabgrop opp1 := fun is : _ => pr1 ( pr1 is ) . Definition rngop2axs_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> ismonoidop opp2 := fun is : _ => pr2 ( pr1 is ) . Definition rngdistraxs_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> isdistr opp1 opp2 := fun is : _ => pr2 is . Definition rngldistrax_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> isldistr opp1 opp2 := fun is : _ => pr1 ( pr2 is ) . Definition rngrdistrax_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> isrdistr opp1 opp2 := fun is : _ => pr2 ( pr2 is ) . Definition rngunel1_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) : X := unel_is ( pr1 ( pr1 is ) ) . Definition rngunel2_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) : X := unel_is ( pr2 ( pr1 is ) ) . Lemma isapropisrngops { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( isrngops opp1 opp2 ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply ( isofhleveldirprod 1 ) . apply isapropisabgrop . apply isapropismonoidop. apply isapropisdistr . Defined . Lemma multx0_is_l { X : hSet } { opp1 opp2 : binop X } ( is1 : isgrop opp1 ) ( is2 : ismonoidop opp2 ) ( is12 : isdistr opp1 opp2 ) : forall x : X , paths ( opp2 x ( unel_is ( pr1 is1 ) ) ) ( unel_is ( pr1 is1 ) ) . Proof . intros . destruct is12 as [ ldistr0 rdistr0 ] . destruct is2 as [ assoc2 [ un2 [ lun2 run2 ] ] ] . simpl in * . apply ( invmaponpathsweq ( weqpair _ ( isweqrmultingr_is is1 ( opp2 x un2 ) ) ) ) . simpl . destruct is1 as [ [ assoc1 [ un1 [ lun1 run1 ] ] ] [ inv0 [ linv0 rinv0 ] ] ] . unfold unel_is . simpl in * . rewrite ( lun1 ( opp2 x un2 ) ) . destruct ( ldistr0 un1 un2 x ) . rewrite ( run2 x ) . rewrite ( lun1 un2 ) . rewrite ( run2 x ) . apply idpath . Defined . Opaque multx0_is_l . Lemma mult0x_is_l { X : hSet } { opp1 opp2 : binop X } ( is1 : isgrop opp1 ) ( is2 : ismonoidop opp2 ) ( is12 : isdistr opp1 opp2 ) : forall x : X , paths ( opp2 ( unel_is ( pr1 is1 ) ) x ) ( unel_is ( pr1 is1 ) ) . Proof . intros . destruct is12 as [ ldistr0 rdistr0 ] . destruct is2 as [ assoc2 [ un2 [ lun2 run2 ] ] ] . simpl in * . apply ( invmaponpathsweq ( weqpair _ ( isweqrmultingr_is is1 ( opp2 un2 x ) ) ) ) . simpl . destruct is1 as [ [ assoc1 [ un1 [ lun1 run1 ] ] ] [ inv0 [ linv0 rinv0 ] ] ] . unfold unel_is . simpl in * . rewrite ( lun1 ( opp2 un2 x ) ) . destruct ( rdistr0 un1 un2 x ) . rewrite ( lun2 x ) . rewrite ( lun1 un2 ) . rewrite ( lun2 x ) . apply idpath . Defined . Opaque mult0x_is_l . Definition minus1_is_l { X : hSet } { opp1 opp2 : binop X } ( is1 : isgrop opp1 ) ( is2 : ismonoidop opp2 ) := ( grinv_is is1 ) ( unel_is is2 ) . Lemma islinvmultwithminus1_is_l { X : hSet } { opp1 opp2 : binop X } ( is1 : isgrop opp1 ) ( is2 : ismonoidop opp2 ) ( is12 : isdistr opp1 opp2 ) ( x : X ) : paths ( opp1 ( opp2 ( minus1_is_l is1 is2 ) x ) x ) ( unel_is ( pr1 is1 ) ) . Proof . intros . set ( xinv := opp2 (minus1_is_l is1 is2) x ) . rewrite ( pathsinv0 ( lunax_is is2 x ) ) . unfold xinv . rewrite ( pathsinv0 ( pr2 is12 _ _ x ) ) . unfold minus1_is_l . unfold grinv_is . rewrite ( grlinvax_is is1 _ ) . apply mult0x_is_l . apply is2 . apply is12 . Defined . Opaque islinvmultwithminus1_is_l . Lemma isrinvmultwithminus1_is_l { X : hSet } { opp1 opp2 : binop X } ( is1 : isgrop opp1 ) ( is2 : ismonoidop opp2 ) ( is12 : isdistr opp1 opp2 ) ( x : X ) : paths ( opp1 x ( opp2 ( minus1_is_l is1 is2 ) x ) ) ( unel_is ( pr1 is1 ) ) . Proof . intros . set ( xinv := opp2 (minus1_is_l is1 is2) x ) . rewrite ( pathsinv0 ( lunax_is is2 x ) ) . unfold xinv . rewrite ( pathsinv0 ( pr2 is12 _ _ x ) ) . unfold minus1_is_l . unfold grinv_is . rewrite ( grrinvax_is is1 _ ) . apply mult0x_is_l . apply is2 . apply is12 . Defined . Opaque isrinvmultwithminus1_is_l . Lemma isminusmultwithminus1_is_l { X : hSet } { opp1 opp2 : binop X } ( is1 : isgrop opp1 ) ( is2 : ismonoidop opp2 ) ( is12 : isdistr opp1 opp2 ) ( x : X ) : paths ( opp2 ( minus1_is_l is1 is2 ) x ) ( grinv_is is1 x ) . Proof . intros . apply ( invmaponpathsweq ( weqpair _ ( isweqrmultingr_is is1 x ) ) ) . simpl . rewrite ( islinvmultwithminus1_is_l is1 is2 is12 x ) . unfold grinv_is . rewrite ( grlinvax_is is1 x ) . apply idpath . Defined . Opaque isminusmultwithminus1_is_l . Lemma isrngopsif { X : hSet } { opp1 opp2 : binop X } ( is1 : isgrop opp1 ) ( is2 : ismonoidop opp2 ) ( is12 : isdistr opp1 opp2 ) : isrngops opp1 opp2 . Proof . intros . set ( assoc1 := pr1 ( pr1 is1 ) ) . split . split . split with is1 . intros x y . apply ( invmaponpathsweq ( weqpair _ ( isweqrmultingr_is is1 ( opp2 ( minus1_is_l is1 is2 ) ( opp1 x y ) ) ) ) ) . simpl . rewrite ( isrinvmultwithminus1_is_l is1 is2 is12 ( opp1 x y ) ) . rewrite ( pr1 is12 x y _ ) . destruct ( assoc1 ( opp1 y x ) (opp2 (minus1_is_l is1 is2) x) (opp2 (minus1_is_l is1 is2) y)) . rewrite ( assoc1 y x _ ) . destruct ( pathsinv0 ( isrinvmultwithminus1_is_l is1 is2 is12 x ) ) . unfold unel_is . rewrite ( runax_is ( pr1 is1 ) y ) . rewrite ( isrinvmultwithminus1_is_l is1 is2 is12 y ) . apply idpath . apply is2 . apply is12 . Defined . Definition rngmultx0_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) := multx0_is_l ( rngop1axs_is is ) ( rngop2axs_is is ) ( rngdistraxs_is is ) . Definition rngmult0x_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) := mult0x_is_l ( rngop1axs_is is ) ( rngop2axs_is is ) ( rngdistraxs_is is ) . Definition rngminus1_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) := minus1_is_l ( rngop1axs_is is ) ( rngop2axs_is is ) . Definition rngmultwithminus1_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) := isminusmultwithminus1_is_l ( rngop1axs_is is ) ( rngop2axs_is is ) ( rngdistraxs_is is ) . Definition isrngopstoisrigops ( X : hSet ) ( opp1 opp2 : binop X ) ( is : isrngops opp1 opp2 ) : isrigops opp1 opp2 . Proof. intros . split . split with ( dirprodpair ( isabgroptoisabmonoidop _ _ ( rngop1axs_is is ) ) ( rngop2axs_is is ) ) . split . simpl . apply ( rngmult0x_is ) . simpl . apply ( rngmultx0_is ) . apply ( rngdistraxs_is is ) . Defined . Coercion isrngopstoisrigops : isrngops >-> isrigops . (** *) Definition iscommrigops { X : hSet } ( opp1 opp2 : binop X ) := dirprod ( isrigops opp1 opp2 ) ( iscomm opp2 ) . Definition pr1iscommrigops ( X : hSet ) ( opp1 opp2 : binop X ) : iscommrigops opp1 opp2 -> isrigops opp1 opp2 := @pr1 _ _ . Coercion pr1iscommrigops : iscommrigops >-> isrigops . Definition rigiscommop2_is { X : hSet } { opp1 opp2 : binop X } ( is : iscommrigops opp1 opp2 ) : iscomm opp2 := pr2 is . Lemma isapropiscommrig { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( iscommrigops opp1 opp2 ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropisrigops . apply isapropiscomm . Defined . (** *) Definition iscommrngops { X : hSet } ( opp1 opp2 : binop X ) := dirprod ( isrngops opp1 opp2 ) ( iscomm opp2 ) . Definition pr1iscommrngops ( X : hSet ) ( opp1 opp2 : binop X ) : iscommrngops opp1 opp2 -> isrngops opp1 opp2 := @pr1 _ _ . Coercion pr1iscommrngops : iscommrngops >-> isrngops . Definition rngiscommop2_is { X : hSet } { opp1 opp2 : binop X } ( is : iscommrngops opp1 opp2 ) : iscomm opp2 := pr2 is . Lemma isapropiscommrng { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( iscommrngops opp1 opp2 ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropisrngops . apply isapropiscomm . Defined . Definition iscommrngopstoiscommrigops ( X : hSet ) ( opp1 opp2 : binop X ) ( is : iscommrngops opp1 opp2 ) : iscommrigops opp1 opp2 := dirprodpair ( isrngopstoisrigops _ _ _ ( pr1 is ) ) ( pr2 is ) . Coercion iscommrngopstoiscommrigops : iscommrngops >-> iscommrigops . (** *** Sets with one binary operation *) (** **** General definitions *) Definition setwithbinop := total2 ( fun X : hSet => binop X ) . Definition setwithbinoppair ( X : hSet ) ( opp : binop X ) : setwithbinop := tpair ( fun X : hSet => binop X ) X opp . Definition pr1setwithbinop : setwithbinop -> hSet := @pr1 _ ( fun X : hSet => binop X ) . Coercion pr1setwithbinop : setwithbinop >-> hSet . Definition op { X : setwithbinop } : binop X := pr2 X . Notation "x + y" := ( op x y ) : addoperation_scope . Notation "x * y" := ( op x y ) : multoperation_scope . (** **** Functions compatible with a binary operation ( homomorphisms ) and their properties *) Definition isbinopfun { X Y : setwithbinop } ( f : X -> Y ) := forall x x' : X , paths ( f ( op x x' ) ) ( op ( f x ) ( f x' ) ) . Lemma isapropisbinopfun { X Y : setwithbinop } ( f : X -> Y ) : isaprop ( isbinopfun f ) . Proof . intros . apply impred . intro x . apply impred . intro x' . apply ( setproperty Y ) . Defined . Definition binopfun ( X Y : setwithbinop ) : UU := total2 ( fun f : X -> Y => isbinopfun f ) . Definition binopfunpair { X Y : setwithbinop } ( f : X -> Y ) ( is : isbinopfun f ) : binopfun X Y := tpair _ f is . Definition pr1binopfun ( X Y : setwithbinop ) : binopfun X Y -> ( X -> Y ) := @pr1 _ _ . Coercion pr1binopfun : binopfun >-> Funclass . Lemma isasetbinopfun ( X Y : setwithbinop ) : isaset ( binopfun X Y ) . Proof . intros . apply ( isasetsubset ( pr1binopfun X Y ) ) . change ( isofhlevel 2 ( X -> Y ) ) . apply impred . intro . apply ( setproperty Y ) . apply isinclpr1 . intro . apply isapropisbinopfun . Defined . Lemma isbinopfuncomp { X Y Z : setwithbinop } ( f : binopfun X Y ) ( g : binopfun Y Z ) : isbinopfun ( funcomp ( pr1 f ) ( pr1 g ) ) . Proof . intros . set ( axf := pr2 f ) . set ( axg := pr2 g ) . intros a b . unfold funcomp . rewrite ( axf a b ) . rewrite ( axg ( pr1 f a ) ( pr1 f b ) ) . apply idpath . Defined . Opaque isbinopfuncomp . Definition binopfuncomp { X Y Z : setwithbinop } ( f : binopfun X Y ) ( g : binopfun Y Z ) : binopfun X Z := binopfunpair ( funcomp ( pr1 f ) ( pr1 g ) ) ( isbinopfuncomp f g ) . Definition binopmono ( X Y : setwithbinop ) : UU := total2 ( fun f : incl X Y => isbinopfun ( pr1 f ) ) . Definition binopmonopair { X Y : setwithbinop } ( f : incl X Y ) ( is : isbinopfun f ) : binopmono X Y := tpair _ f is . Definition pr1binopmono ( X Y : setwithbinop ) : binopmono X Y -> incl X Y := @pr1 _ _ . Coercion pr1binopmono : binopmono >-> incl . Definition binopincltobinopfun ( X Y : setwithbinop ) : binopmono X Y -> binopfun X Y := fun f => binopfunpair ( pr1 ( pr1 f ) ) ( pr2 f ) . Coercion binopincltobinopfun : binopmono >-> binopfun . Definition binopmonocomp { X Y Z : setwithbinop } ( f : binopmono X Y ) ( g : binopmono Y Z ) : binopmono X Z := binopmonopair ( inclcomp ( pr1 f ) ( pr1 g ) ) ( isbinopfuncomp f g ) . Definition binopiso ( X Y : setwithbinop ) : UU := total2 ( fun f : weq X Y => isbinopfun f ) . Definition binopisopair { X Y : setwithbinop } ( f : weq X Y ) ( is : isbinopfun f ) : binopiso X Y := tpair _ f is . Definition pr1binopiso ( X Y : setwithbinop ) : binopiso X Y -> weq X Y := @pr1 _ _ . Coercion pr1binopiso : binopiso >-> weq . Definition binopisotobinopmono ( X Y : setwithbinop ) : binopiso X Y -> binopmono X Y := fun f => binopmonopair ( pr1 f ) ( pr2 f ) . Coercion binopisotobinopmono : binopiso >-> binopmono . Definition binopisocomp { X Y Z : setwithbinop } ( f : binopiso X Y ) ( g : binopiso Y Z ) : binopiso X Z := binopisopair ( weqcomp ( pr1 f ) ( pr1 g ) ) ( isbinopfuncomp f g ) . Lemma isbinopfuninvmap { X Y : setwithbinop } ( f : binopiso X Y ) : isbinopfun ( invmap ( pr1 f ) ) . Proof . intros . set ( axf := pr2 f ) . intros a b . apply ( invmaponpathsweq ( pr1 f ) ) . rewrite ( homotweqinvweq ( pr1 f ) ( op a b ) ) . rewrite ( axf (invmap (pr1 f) a) (invmap (pr1 f) b) ) . rewrite ( homotweqinvweq ( pr1 f ) a ) . rewrite ( homotweqinvweq ( pr1 f ) b ) . apply idpath . Defined . Opaque isbinopfuninvmap . Definition invbinopiso { X Y : setwithbinop } ( f : binopiso X Y ) : binopiso Y X := binopisopair ( invweq ( pr1 f ) ) ( isbinopfuninvmap f ) . (** **** Transport of properties of a binary operation *) Lemma isincltwooutof3a { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isg : isincl g ) ( isgf : isincl ( funcomp f g ) ) : isincl f . Proof . intros . apply ( isofhlevelff 1 f g isgf ) . apply ( isofhlevelfsnincl 1 g isg ) . Defined . Lemma islcancelablemonob { X Y : setwithbinop } ( f : binopmono X Y ) ( x : X ) ( is : islcancelable ( @op Y ) ( f x ) ) : islcancelable ( @op X ) x . Proof . intros . unfold islcancelable . apply ( isincltwooutof3a (fun x0 : X => op x x0) f ( pr2 ( pr1 f ) ) ) . assert ( h : homot ( funcomp f ( fun y0 : Y => op ( f x ) y0 ) ) (funcomp (fun x0 : X => op x x0) f) ) . intro x0 . unfold funcomp . apply ( pathsinv0 ( ( pr2 f ) x x0 ) ) . apply ( isinclhomot _ _ h ) . apply ( isinclcomp f ( inclpair _ is ) ) . Defined . Lemma isrcancelablemonob { X Y : setwithbinop } ( f : binopmono X Y ) ( x : X ) ( is : isrcancelable ( @op Y ) ( f x ) ) : isrcancelable ( @op X ) x . Proof . intros . unfold islcancelable . apply ( isincltwooutof3a (fun x0 : X => op x0 x) f ( pr2 ( pr1 f ) ) ) . assert ( h : homot ( funcomp f ( fun y0 : Y => op y0 ( f x ) ) ) (funcomp (fun x0 : X => op x0 x ) f) ) . intro x0 . unfold funcomp . apply ( pathsinv0 ( ( pr2 f ) x0 x ) ) . apply ( isinclhomot _ _ h ) . apply ( isinclcomp f ( inclpair _ is ) ) . Defined . Lemma iscancelablemonob { X Y : setwithbinop } ( f : binopmono X Y ) ( x : X ) ( is : iscancelable ( @op Y ) ( f x ) ) : iscancelable ( @op X ) x . Proof . intros . apply ( dirprodpair ( islcancelablemonob f x ( pr1 is ) ) ( isrcancelablemonob f x ( pr2 is ) ) ) . Defined . Notation islcancelableisob := islcancelablemonob . Notation isrcancelableisob := isrcancelablemonob . Notation iscancelableisob := iscancelablemonob . Lemma islinvertibleisob { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : islinvertible ( @op Y ) ( f x ) ) : islinvertible ( @op X ) x . Proof . intros . unfold islinvertible . apply ( twooutof3a (fun x0 : X => op x x0) f ) . assert ( h : homot ( funcomp f ( fun y0 : Y => op ( f x ) y0 ) ) (funcomp (fun x0 : X => op x x0) f) ) . intro x0 . unfold funcomp . apply ( pathsinv0 ( ( pr2 f ) x x0 ) ) . apply ( isweqhomot _ _ h ) . apply ( pr2 ( weqcomp f ( weqpair _ is ) ) ) . apply ( pr2 ( pr1 f ) ) . Defined . Lemma isrinvertibleisob { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : isrinvertible ( @op Y ) ( f x ) ) : isrinvertible ( @op X ) x . Proof . intros . unfold islinvertible . apply ( twooutof3a (fun x0 : X => op x0 x) f ) . assert ( h : homot ( funcomp f ( fun y0 : Y => op y0 ( f x ) ) ) (funcomp (fun x0 : X => op x0 x ) f) ) . intro x0 . unfold funcomp . apply ( pathsinv0 ( ( pr2 f ) x0 x ) ) . apply ( isweqhomot _ _ h ) . apply ( pr2 ( weqcomp f ( weqpair _ is ) ) ) . apply ( pr2 ( pr1 f ) ) . Defined . Lemma isinvertiblemonob { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : isinvertible ( @op Y ) ( f x ) ) : isinvertible ( @op X ) x . Proof . intros . apply ( dirprodpair ( islinvertibleisob f x ( pr1 is ) ) ( isrinvertibleisob f x ( pr2 is ) ) ) . Defined . Definition islinvertibleisof { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : islinvertible ( @op X ) x ) : islinvertible ( @op Y ) ( f x ) . Proof . intros . unfold islinvertible . apply ( twooutof3b f ) . apply ( pr2 ( pr1 f ) ) . assert ( h : homot ( funcomp ( fun x0 : X => op x x0 ) f ) (fun x0 : X => op (f x) (f x0)) ) . intro x0 . unfold funcomp . apply ( pr2 f x x0 ) . apply ( isweqhomot _ _ h ) . apply ( pr2 ( weqcomp ( weqpair _ is ) f ) ) . Defined . Definition isrinvertibleisof { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : isrinvertible ( @op X ) x ) : isrinvertible ( @op Y ) ( f x ) . Proof . intros . unfold isrinvertible . apply ( twooutof3b f ) . apply ( pr2 ( pr1 f ) ) . assert ( h : homot ( funcomp ( fun x0 : X => op x0 x ) f ) (fun x0 : X => op (f x0) (f x) ) ) . intro x0 . unfold funcomp . apply ( pr2 f x0 x ) . apply ( isweqhomot _ _ h ) . apply ( pr2 ( weqcomp ( weqpair _ is ) f ) ) . Defined . Lemma isinvertiblemonof { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : isinvertible ( @op X ) x ) : isinvertible ( @op Y ) ( f x ) . Proof . intros . apply ( dirprodpair ( islinvertibleisof f x ( pr1 is ) ) ( isrinvertibleisof f x ( pr2 is ) ) ) . Defined . Lemma isassocmonob { X Y : setwithbinop } ( f : binopmono X Y ) ( is : isassoc ( @op Y ) ) : isassoc ( @op X ) . Proof . intros . set ( axf := pr2 f ) . simpl in axf . intros a b c . apply ( invmaponpathsincl _ ( pr2 ( pr1 f ) ) ) . rewrite ( axf ( op a b ) c ) . rewrite ( axf a b ) . rewrite ( axf a ( op b c ) ) . rewrite ( axf b c ) . apply is . Defined . Opaque isassocmonob . Lemma iscommmonob { X Y : setwithbinop } ( f : binopmono X Y ) ( is : iscomm ( @op Y ) ) : iscomm ( @op X ) . Proof . intros . set ( axf := pr2 f ) . simpl in axf . intros a b . apply ( invmaponpathsincl _ ( pr2 ( pr1 f ) ) ) . rewrite ( axf a b ) . rewrite ( axf b a ) . apply is . Defined . Opaque iscommmonob . Notation isassocisob := isassocmonob . Notation iscommisob := iscommmonob . Lemma isassocisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isassoc ( @op X ) ) : isassoc ( @op Y ) . Proof . intros . apply ( isassocmonob ( invbinopiso f ) is ) . Defined . Opaque isassocisof . Lemma iscommisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : iscomm ( @op X ) ) : iscomm ( @op Y ) . Proof . intros . apply ( iscommmonob ( invbinopiso f ) is ) . Defined . Opaque iscommisof . Lemma isunitisof { X Y : setwithbinop } ( f : binopiso X Y ) ( unx : X ) ( is : isunit ( @op X ) unx ) : isunit ( @op Y ) ( f unx ) . Proof . intros . set ( axf := pr2 f ) . split . intro a . change ( f unx ) with ( pr1 f unx ) . apply ( invmaponpathsweq ( pr1 ( invbinopiso f ) ) ) . rewrite ( pr2 ( invbinopiso f ) ( pr1 f unx ) a ) . simpl . rewrite ( homotinvweqweq ( pr1 f ) unx ) . apply ( pr1 is ) . intro a . change ( f unx ) with ( pr1 f unx ) . apply ( invmaponpathsweq ( pr1 ( invbinopiso f ) ) ) . rewrite ( pr2 ( invbinopiso f ) a ( pr1 f unx ) ) . simpl . rewrite ( homotinvweqweq ( pr1 f ) unx ) . apply ( pr2 is ) . Defined . Opaque isunitisof . Definition isunitalisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isunital ( @op X ) ) : isunital ( @op Y ) := isunitalpair ( f ( pr1 is ) ) ( isunitisof f ( pr1 is ) ( pr2 is ) ) . Lemma isunitisob { X Y : setwithbinop } ( f : binopiso X Y ) ( uny : Y ) ( is : isunit ( @op Y ) uny ) : isunit ( @op X ) ( ( invmap f ) uny ) . Proof . intros . set ( int := isunitisof ( invbinopiso f ) ) . simpl . simpl in int . apply int . apply is . Defined . Opaque isunitisob . Definition isunitalisob { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isunital ( @op Y ) ) : isunital ( @op X ) := isunitalpair ( ( invmap f ) ( pr1 is ) ) ( isunitisob f ( pr1 is ) ( pr2 is ) ) . Definition ismonoidopisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : ismonoidop ( @op X ) ) : ismonoidop ( @op Y ) := dirprodpair ( isassocisof f ( pr1 is ) ) ( isunitalisof f ( pr2 is ) ) . Definition ismonoidopisob { X Y : setwithbinop } ( f : binopiso X Y ) ( is : ismonoidop ( @op Y ) ) : ismonoidop ( @op X ) := dirprodpair ( isassocisob f ( pr1 is ) ) ( isunitalisob f ( pr2 is ) ) . Lemma isinvisof { X Y : setwithbinop } ( f : binopiso X Y ) ( unx : X ) ( invx : X -> X ) ( is : isinv ( @op X ) unx invx ) : isinv ( @op Y ) ( pr1 f unx ) ( funcomp ( invmap ( pr1 f ) ) ( funcomp invx ( pr1 f ) ) ) . Proof . intros . set ( axf := pr2 f ) . set ( axinvf := pr2 ( invbinopiso f ) ) . simpl in axf . simpl in axinvf . unfold funcomp . split . intro a . apply ( invmaponpathsweq ( pr1 ( invbinopiso f ) ) ) . simpl . rewrite ( axinvf ( ( pr1 f ) (invx (invmap ( pr1 f ) a))) a ) . rewrite ( homotinvweqweq ( pr1 f ) unx ) . rewrite ( homotinvweqweq ( pr1 f ) (invx (invmap ( pr1 f ) a)) ) . apply ( pr1 is ) . intro a . apply ( invmaponpathsweq ( pr1 ( invbinopiso f ) ) ) . simpl . rewrite ( axinvf a ( ( pr1 f ) (invx (invmap ( pr1 f ) a))) ) . rewrite ( homotinvweqweq ( pr1 f ) unx ) . rewrite ( homotinvweqweq ( pr1 f ) (invx (invmap ( pr1 f ) a)) ) . apply ( pr2 is ) . Defined . Opaque isinvisof . Definition isgropisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isgrop ( @op X ) ) : isgrop ( @op Y ) := tpair _ ( ismonoidopisof f is ) ( tpair _ ( funcomp ( invmap ( pr1 f ) ) ( funcomp ( grinv_is is ) ( pr1 f ) ) ) ( isinvisof f ( unel_is is ) ( grinv_is is ) ( pr2 ( pr2 is ) ) ) ) . Lemma isinvisob { X Y : setwithbinop } ( f : binopiso X Y ) ( uny : Y ) ( invy : Y -> Y ) ( is : isinv ( @op Y ) uny invy ) : isinv ( @op X ) ( invmap ( pr1 f ) uny ) ( funcomp ( pr1 f ) ( funcomp invy ( invmap ( pr1 f ) ) ) ) . Proof . intros . apply ( isinvisof ( invbinopiso f ) uny invy is ) . Defined . Opaque isinvisob . Definition isgropisob { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isgrop ( @op Y ) ) : isgrop ( @op X ) := tpair _ ( ismonoidopisob f is ) ( tpair _ ( funcomp ( pr1 f ) ( funcomp ( grinv_is is ) ( invmap ( pr1 f ) ) ) ) ( isinvisob f ( unel_is is ) ( grinv_is is ) ( pr2 ( pr2 is ) ) ) ) . Definition isabmonoidopisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isabmonoidop ( @op X ) ) : isabmonoidop ( @op Y ) := tpair _ ( ismonoidopisof f is ) ( iscommisof f ( commax_is is ) ) . Definition isabmonoidopisob { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isabmonoidop ( @op Y ) ) : isabmonoidop ( @op X ) := tpair _ ( ismonoidopisob f is ) ( iscommisob f ( commax_is is ) ) . Definition isabgropisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isabgrop ( @op X ) ) : isabgrop ( @op Y ) := tpair _ ( isgropisof f is ) ( iscommisof f ( commax_is is ) ) . Definition isabgropisob { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isabgrop ( @op Y ) ) : isabgrop ( @op X ) := tpair _ ( isgropisob f is ) ( iscommisob f ( commax_is is ) ) . (** **** Subobjects *) Definition issubsetwithbinop { X : hSet } ( opp : binop X ) ( A : hsubtypes X ) := forall a a' : A , A ( opp ( pr1 a ) ( pr1 a' ) ) . Lemma isapropissubsetwithbinop { X : hSet } ( opp : binop X ) ( A : hsubtypes X ) : isaprop ( issubsetwithbinop opp A ) . Proof . intros . apply impred . intro a . apply impred . intros a' . apply ( pr2 ( A ( opp (pr1 a) (pr1 a')) ) ) . Defined . Definition subsetswithbinop { X : setwithbinop } := total2 ( fun A : hsubtypes X => issubsetwithbinop ( @op X ) A ) . Definition subsetswithbinoppair { X : setwithbinop } := tpair ( fun A : hsubtypes X => issubsetwithbinop ( @op X ) A ) . Definition subsetswithbinopconstr { X : setwithbinop } := @subsetswithbinoppair X . Definition pr1subsetswithbinop ( X : setwithbinop ) : @subsetswithbinop X -> hsubtypes X := @pr1 _ ( fun A : hsubtypes X => issubsetwithbinop ( @op X ) A ) . Coercion pr1subsetswithbinop : subsetswithbinop >-> hsubtypes . Definition totalsubsetwithbinop ( X : setwithbinop ) : @subsetswithbinop X . Proof . intros . split with ( fun x : X => htrue ) . intros x x' . apply tt . Defined . Definition carrierofasubsetwithbinop { X : setwithbinop } ( A : @subsetswithbinop X ) : setwithbinop . Proof . intros . set ( aset := ( hSetpair ( carrier A ) ( isasetsubset ( pr1carrier A ) ( setproperty X ) ( isinclpr1carrier A ) ) ) : hSet ) . split with aset . set ( subopp := ( fun a a' : A => carrierpair A ( op ( pr1carrier _ a ) ( pr1carrier _ a' ) ) ( pr2 A a a' ) ) : ( A -> A -> A ) ) . simpl . unfold binop . apply subopp . Defined . Coercion carrierofasubsetwithbinop : subsetswithbinop >-> setwithbinop . (** **** Relations compatible with a binary operation and quotient objects *) Definition isbinophrel { X : setwithbinop } ( R : hrel X ) := dirprod ( forall a b c : X , R a b -> R ( op c a ) ( op c b ) ) ( forall a b c : X , R a b -> R ( op a c ) ( op b c ) ) . Definition isbinophrellogeqf { X : setwithbinop } { L R : hrel X } ( lg : hrellogeq L R ) ( isl : isbinophrel L ) : isbinophrel R . Proof . intros . split . intros a b c rab . apply ( ( pr1 ( lg _ _ ) ( ( pr1 isl ) _ _ _ ( pr2 ( lg _ _ ) rab ) ) ) ) . intros a b c rab . apply ( ( pr1 ( lg _ _ ) ( ( pr2 isl ) _ _ _ ( pr2 ( lg _ _ ) rab ) ) ) ) . Defined . Lemma isapropisbinophrel { X : setwithbinop } ( R : hrel X ) : isaprop ( isbinophrel R ) . Proof . intros . apply isapropdirprod . apply impred . intro a . apply impred . intro b . apply impred . intro c . apply impred . intro r . apply ( pr2 ( R _ _ ) ) . apply impred . intro a . apply impred . intro b . apply impred . intro c . apply impred . intro r . apply ( pr2 ( R _ _ ) ) . Defined . Lemma isbinophrelif { X : setwithbinop } ( R : hrel X ) ( is : iscomm ( @op X ) ) ( isl : forall a b c : X , R a b -> R ( op c a ) ( op c b ) ) : isbinophrel R . Proof . intros . split with isl . intros a b c rab . destruct ( is c a ) . destruct ( is c b ) . apply ( isl _ _ _ rab ) . Defined . Lemma iscompbinoptransrel { X : setwithbinop } ( R : hrel X ) ( ist : istrans R ) ( isb : isbinophrel R ) : iscomprelrelfun2 R R ( @op X ) . Proof . intros . intros a b c d . intros rab rcd . set ( racbc := pr2 isb a b c rab ) . set ( rbcbd := pr1 isb c d b rcd ) . apply ( ist _ _ _ racbc rbcbd ) . Defined . Lemma isbinopreflrel { X : setwithbinop } ( R : hrel X ) ( isr : isrefl R ) ( isb : iscomprelrelfun2 R R ( @op X ) ) : isbinophrel R . Proof . intros . split . intros a b c rab . apply ( isb c c a b ( isr c ) rab ) . intros a b c rab . apply ( isb a b c c rab ( isr c ) ) . Defined . Definition binophrel { X : setwithbinop } := total2 ( fun R : hrel X => isbinophrel R ) . Definition binophrelpair { X : setwithbinop } := tpair ( fun R : hrel X => isbinophrel R ) . Definition pr1binophrel ( X : setwithbinop ) : @binophrel X -> hrel X := @pr1 _ ( fun R : hrel X => isbinophrel R ) . Coercion pr1binophrel : binophrel >-> hrel . Definition binoppo { X : setwithbinop } := total2 ( fun R : po X => isbinophrel R ) . Definition binoppopair { X : setwithbinop } := tpair ( fun R : po X => isbinophrel R ) . Definition pr1binoppo ( X : setwithbinop ) : @binoppo X -> po X := @pr1 _ ( fun R : po X => isbinophrel R ) . Coercion pr1binoppo : binoppo >-> po . Definition binopeqrel { X : setwithbinop } := total2 ( fun R : eqrel X => isbinophrel R ) . Definition binopeqrelpair { X : setwithbinop } := tpair ( fun R : eqrel X => isbinophrel R ) . Definition pr1binopeqrel ( X : setwithbinop ) : @binopeqrel X -> eqrel X := @pr1 _ ( fun R : eqrel X => isbinophrel R ) . Coercion pr1binopeqrel : binopeqrel >-> eqrel . Definition setwithbinopquot { X : setwithbinop } ( R : @binopeqrel X ) : setwithbinop . Proof . intros . split with ( setquotinset R ) . set ( qt := setquot R ) . set ( qtset := setquotinset R ) . assert ( iscomp : iscomprelrelfun2 R R op ) . apply ( iscompbinoptransrel R ( eqreltrans R ) ( pr2 R ) ) . set ( qtmlt := setquotfun2 R R op iscomp ) . simpl . unfold binop . apply qtmlt . Defined . Definition ispartbinophrel { X : setwithbinop } ( S : hsubtypes X ) ( R : hrel X ) := dirprod ( forall a b c : X , S c -> R a b -> R ( op c a ) ( op c b ) ) ( forall a b c : X , S c -> R a b -> R ( op a c ) ( op b c ) ) . Definition isbinoptoispartbinop { X : setwithbinop } ( S : hsubtypes X ) ( L : hrel X ) ( is : isbinophrel L ) : ispartbinophrel S L . Proof . intros X S L . unfold isbinophrel . unfold ispartbinophrel . intro d2 . split . intros a b c is . apply ( pr1 d2 a b c ) . intros a b c is . apply ( pr2 d2 a b c ) . Defined . Definition ispartbinophrellogeqf { X : setwithbinop } ( S : hsubtypes X ) { L R : hrel X } ( lg : hrellogeq L R ) ( isl : ispartbinophrel S L ) : ispartbinophrel S R . Proof . intros . split . intros a b c is rab . apply ( ( pr1 ( lg _ _ ) ( ( pr1 isl ) _ _ _ is ( pr2 ( lg _ _ ) rab ) ) ) ) . intros a b c is rab . apply ( ( pr1 ( lg _ _ ) ( ( pr2 isl ) _ _ _ is ( pr2 ( lg _ _ ) rab ) ) ) ) . Defined . Lemma ispartbinophrelif { X : setwithbinop } ( S : hsubtypes X ) ( R : hrel X ) ( is : iscomm ( @op X ) ) ( isl : forall a b c : X , S c -> R a b -> R ( op c a ) ( op c b ) ) : ispartbinophrel S R . Proof . intros . split with isl . intros a b c s rab . destruct ( is c a ) . destruct ( is c b ) . apply ( isl _ _ _ s rab ) . Defined . (** **** Relations inversely compatible with a binary operation *) Definition isinvbinophrel { X : setwithbinop } ( R : hrel X ) := dirprod ( forall a b c : X , R ( op c a ) ( op c b ) -> R a b ) ( forall a b c : X , R ( op a c ) ( op b c ) -> R a b ) . Definition isinvbinophrellogeqf { X : setwithbinop } { L R : hrel X } ( lg : hrellogeq L R ) ( isl : isinvbinophrel L ) : isinvbinophrel R . Proof . intros . split . intros a b c rab . apply ( ( pr1 ( lg _ _ ) ( ( pr1 isl ) _ _ _ ( pr2 ( lg _ _ ) rab ) ) ) ) . intros a b c rab . apply ( ( pr1 ( lg _ _ ) ( ( pr2 isl ) _ _ _ ( pr2 ( lg _ _ ) rab ) ) ) ) . Defined . Lemma isapropisinvbinophrel { X : setwithbinop } ( R : hrel X ) : isaprop ( isinvbinophrel R ) . Proof . intros . apply isapropdirprod . apply impred . intro a . apply impred . intro b . apply impred . intro c . apply impred . intro r . apply ( pr2 ( R _ _ ) ) . apply impred . intro a . apply impred . intro b . apply impred . intro c . apply impred . intro r . apply ( pr2 ( R _ _ ) ) . Defined . Lemma isinvbinophrelif { X : setwithbinop } ( R : hrel X ) ( is : iscomm ( @op X ) ) ( isl : forall a b c : X , R ( op c a ) ( op c b ) -> R a b ) : isinvbinophrel R . Proof . intros . split with isl . intros a b c rab . destruct ( is c a ) . destruct ( is c b ) . apply ( isl _ _ _ rab ) . Defined . Definition ispartinvbinophrel { X : setwithbinop } ( S : hsubtypes X ) ( R : hrel X ) := dirprod ( forall a b c : X , S c -> R ( op c a ) ( op c b ) -> R a b ) ( forall a b c : X , S c -> R ( op a c ) ( op b c ) -> R a b ) . Definition isinvbinoptoispartinvbinop { X : setwithbinop } ( S : hsubtypes X ) ( L : hrel X ) ( is : isinvbinophrel L ) : ispartinvbinophrel S L . Proof . intros X S L . unfold isinvbinophrel . unfold ispartinvbinophrel . intro d2 . split . intros a b c s . apply ( pr1 d2 a b c ) . intros a b c s . apply ( pr2 d2 a b c ) . Defined . Definition ispartinvbinophrellogeqf { X : setwithbinop } ( S : hsubtypes X ) { L R : hrel X } ( lg : hrellogeq L R ) ( isl : ispartinvbinophrel S L ) : ispartinvbinophrel S R . Proof . intros . split . intros a b c s rab . apply ( ( pr1 ( lg _ _ ) ( ( pr1 isl ) _ _ _ s ( pr2 ( lg _ _ ) rab ) ) ) ) . intros a b c s rab . apply ( ( pr1 ( lg _ _ ) ( ( pr2 isl ) _ _ _ s ( pr2 ( lg _ _ ) rab ) ) ) ) . Defined . Lemma ispartinvbinophrelif { X : setwithbinop } ( S : hsubtypes X ) ( R : hrel X ) ( is : iscomm ( @op X ) ) ( isl : forall a b c : X , S c -> R ( op c a ) ( op c b ) -> R a b ) : ispartinvbinophrel S R . Proof . intros . split with isl . intros a b c s rab . destruct ( is c a ) . destruct ( is c b ) . apply ( isl _ _ _ s rab ) . Defined . (** **** Homomorphisms and relations *) Lemma binophrelandfun { X Y : setwithbinop } ( f : binopfun X Y ) ( R : hrel Y ) ( is : @isbinophrel Y R ) : @isbinophrel X ( fun x x' => R ( f x ) ( f x' ) ) . Proof . intros . set ( ish := ( pr2 f ) : forall a0 b0 , paths ( f ( op a0 b0 ) ) ( op ( f a0 ) ( f b0 ) ) ) . split . intros a b c r . rewrite ( ish _ _ ) . rewrite ( ish _ _ ) . apply ( pr1 is ) . apply r . intros a b c r . rewrite ( ish _ _ ) . rewrite ( ish _ _ ) . apply ( pr2 is ) . apply r . Defined . Lemma ispartbinophrelandfun { X Y : setwithbinop } ( f : binopfun X Y ) ( SX : hsubtypes X ) ( SY : hsubtypes Y ) ( iss : forall x : X , ( SX x ) -> ( SY ( f x ) ) ) ( R : hrel Y ) ( is : @ispartbinophrel Y SY R ) : @ispartbinophrel X SX ( fun x x' => R ( f x ) ( f x' ) ) . Proof . intros . set ( ish := ( pr2 f ) : forall a0 b0 , paths ( f ( op a0 b0 ) ) ( op ( f a0 ) ( f b0 ) ) ) . split . intros a b c s r . rewrite ( ish _ _ ) . rewrite ( ish _ _ ) . apply ( ( pr1 is ) _ _ _ ( iss _ s ) r ) . intros a b c s r . rewrite ( ish _ _ ) . rewrite ( ish _ _ ) . apply ( ( pr2 is ) _ _ _ ( iss _ s ) r ) . Defined . Lemma invbinophrelandfun { X Y : setwithbinop } ( f : binopfun X Y ) ( R : hrel Y ) ( is : @isinvbinophrel Y R ) : @isinvbinophrel X ( fun x x' => R ( f x ) ( f x' ) ) . Proof . intros . set ( ish := ( pr2 f ) : forall a0 b0 , paths ( f ( op a0 b0 ) ) ( op ( f a0 ) ( f b0 ) ) ) . split . intros a b c r . rewrite ( ish _ _ ) in r . rewrite ( ish _ _ ) in r . apply ( ( pr1 is ) _ _ _ r ) . intros a b c r . rewrite ( ish _ _ ) in r . rewrite ( ish _ _ ) in r . apply ( ( pr2 is ) _ _ _ r ) . Defined . Lemma ispartinvbinophrelandfun { X Y : setwithbinop } ( f : binopfun X Y ) ( SX : hsubtypes X ) ( SY : hsubtypes Y ) ( iss : forall x : X , ( SX x ) -> ( SY ( f x ) ) ) ( R : hrel Y ) ( is : @ispartinvbinophrel Y SY R ) : @ispartinvbinophrel X SX ( fun x x' => R ( f x ) ( f x' ) ) . Proof . intros . set ( ish := ( pr2 f ) : forall a0 b0 , paths ( f ( op a0 b0 ) ) ( op ( f a0 ) ( f b0 ) ) ) . split . intros a b c s r . rewrite ( ish _ _ ) in r . rewrite ( ish _ _ ) in r . apply ( ( pr1 is ) _ _ _ ( iss _ s ) r ) . intros a b c s r . rewrite ( ish _ _ ) in r . rewrite ( ish _ _ ) in r . apply ( ( pr2 is ) _ _ _ ( iss _ s ) r ) . Defined . (** **** Quotient relations *) Lemma isbinopquotrel { X : setwithbinop } ( R : @binopeqrel X ) { L : hrel X } ( is : iscomprelrel R L ) ( isl : isbinophrel L ) : @isbinophrel ( setwithbinopquot R ) ( quotrel is ) . Proof . intros . unfold isbinophrel . split . assert ( int : forall a b c : setwithbinopquot R , isaprop ( quotrel is a b -> quotrel is (op c a ) (op c b ) ) ) . intros a b c . apply impred . intro . apply ( pr2 ( quotrel is _ _ ) ) . apply ( setquotuniv3prop R ( fun a b c => hProppair _ ( int a b c ) ) ) . exact ( pr1 isl ) . assert ( int : forall a b c : setwithbinopquot R , isaprop ( quotrel is a b -> quotrel is (op a c ) (op b c ) ) ) . intros a b c . apply impred . intro . apply ( pr2 ( quotrel is _ _ ) ) . apply ( setquotuniv3prop R ( fun a b c => hProppair _ ( int a b c ) ) ) . exact ( pr2 isl ) . Defined . (** **** Direct products *) Definition setwithbinopdirprod ( X Y : setwithbinop ) : setwithbinop . Proof . intros . split with ( setdirprod X Y ) . unfold binop . simpl . (* ??? in 8.4-8.5-trunk the following apply generates an error message if the type of xy and xy' is left as _ despite the fact that the type of goal is dirprod X Y -> dirprod X Y -> .. *) apply ( fun xy xy' : dirprod X Y => dirprodpair ( op ( pr1 xy ) ( pr1 xy' ) ) ( op ( pr2 xy ) ( pr2 xy' ) ) ) . Defined . (** *** Sets with two binary operations *) (** **** General definitions *) Definition setwith2binop := total2 ( fun X : hSet => dirprod ( binop X ) ( binop X ) ) . Definition setwith2binoppair ( X : hSet ) ( opps : dirprod ( binop X ) ( binop X ) ) : setwith2binop := tpair ( fun X : hSet => dirprod ( binop X ) ( binop X ) ) X opps . Definition pr1setwith2binop : setwith2binop -> hSet := @pr1 _ ( fun X : hSet => dirprod ( binop X ) ( binop X ) ) . Coercion pr1setwith2binop : setwith2binop >-> hSet . Definition op1 { X : setwith2binop } : binop X := pr1 ( pr2 X ) . Definition op2 { X : setwith2binop } : binop X := pr2 ( pr2 X ) . Definition setwithbinop1 ( X : setwith2binop ) : setwithbinop := setwithbinoppair ( pr1 X ) ( @op1 X ) . Definition setwithbinop2 ( X : setwith2binop ) : setwithbinop := setwithbinoppair ( pr1 X ) ( @op2 X ) . Notation "x + y" := ( op1 x y ) : twobinops_scope . Notation "x * y" := ( op2 x y ) : twobinops_scope . (** **** Functions compatible with a pair of binary operation ( homomorphisms ) and their properties *) Definition istwobinopfun { X Y : setwith2binop } ( f : X -> Y ) := dirprod ( forall x x' : X , paths ( f ( op1 x x' ) ) ( op1 ( f x ) ( f x' ) ) ) ( forall x x' : X , paths ( f ( op2 x x' ) ) ( op2 ( f x ) ( f x' ) ) ) . Lemma isapropistwobinopfun { X Y : setwith2binop } ( f : X -> Y ) : isaprop ( istwobinopfun f ) . Proof . intros . apply isofhleveldirprod . apply impred . intro x . apply impred . intro x' . apply ( setproperty Y ) . apply impred . intro x . apply impred . intro x' . apply ( setproperty Y ) . Defined . Definition twobinopfun ( X Y : setwith2binop ) : UU := total2 ( fun f : X -> Y => istwobinopfun f ) . Definition twobinopfunpair { X Y : setwith2binop } ( f : X -> Y ) ( is : istwobinopfun f ) : twobinopfun X Y := tpair _ f is . Definition pr1twobinopfun ( X Y : setwith2binop ) : twobinopfun X Y -> ( X -> Y ) := @pr1 _ _ . Coercion pr1twobinopfun : twobinopfun >-> Funclass . Definition binop1fun { X Y : setwith2binop } ( f : twobinopfun X Y ) : binopfun ( setwithbinop1 X ) ( setwithbinop1 Y ) := @binopfunpair ( setwithbinop1 X ) ( setwithbinop1 Y ) ( pr1 f ) ( pr1 ( pr2 f ) ) . Definition binop2fun { X Y : setwith2binop } ( f : twobinopfun X Y ) : binopfun ( setwithbinop2 X ) ( setwithbinop2 Y ) := @binopfunpair ( setwithbinop2 X ) ( setwithbinop2 Y ) ( pr1 f ) ( pr2 ( pr2 f ) ) . Lemma isasettwobinopfun ( X Y : setwith2binop ) : isaset ( twobinopfun X Y ) . Proof . intros . apply ( isasetsubset ( pr1twobinopfun X Y ) ) . change ( isofhlevel 2 ( X -> Y ) ) . apply impred . intro . apply ( setproperty Y ) . apply isinclpr1 . intro . apply isapropistwobinopfun . Defined . Lemma istwobinopfuncomp { X Y Z : setwith2binop } ( f : twobinopfun X Y ) ( g : twobinopfun Y Z ) : istwobinopfun ( funcomp ( pr1 f ) ( pr1 g ) ) . Proof . intros . set ( ax1f := pr1 ( pr2 f ) ) . set ( ax2f := pr2 ( pr2 f ) ) . set ( ax1g := pr1 ( pr2 g ) ) . set ( ax2g := pr2 ( pr2 g ) ) . split. intros a b . unfold funcomp . rewrite ( ax1f a b ) . rewrite ( ax1g ( pr1 f a ) ( pr1 f b ) ) . apply idpath . intros a b . unfold funcomp . rewrite ( ax2f a b ) . rewrite ( ax2g ( pr1 f a ) ( pr1 f b ) ) . apply idpath . Defined . Opaque istwobinopfuncomp . Definition twobinopfuncomp { X Y Z : setwith2binop } ( f : twobinopfun X Y ) ( g : twobinopfun Y Z ) : twobinopfun X Z := twobinopfunpair ( funcomp ( pr1 f ) ( pr1 g ) ) ( istwobinopfuncomp f g ) . Definition twobinopmono ( X Y : setwith2binop ) : UU := total2 ( fun f : incl X Y => istwobinopfun f ) . Definition twobinopmonopair { X Y : setwith2binop } ( f : incl X Y ) ( is : istwobinopfun f ) : twobinopmono X Y := tpair _ f is . Definition pr1twobinopmono ( X Y : setwith2binop ) : twobinopmono X Y -> incl X Y := @pr1 _ _ . Coercion pr1twobinopmono : twobinopmono >-> incl . Definition twobinopincltotwobinopfun ( X Y : setwith2binop ) : twobinopmono X Y -> twobinopfun X Y := fun f => twobinopfunpair ( pr1 ( pr1 f ) ) ( pr2 f ) . Coercion twobinopincltotwobinopfun : twobinopmono >-> twobinopfun . Definition binop1mono { X Y : setwith2binop } ( f : twobinopmono X Y ) : binopmono ( setwithbinop1 X ) ( setwithbinop1 Y ) := @binopmonopair ( setwithbinop1 X ) ( setwithbinop1 Y ) ( pr1 f ) ( pr1 ( pr2 f ) ) . Definition binop2mono { X Y : setwith2binop } ( f : twobinopmono X Y ) : binopmono ( setwithbinop2 X ) ( setwithbinop2 Y ) := @binopmonopair ( setwithbinop2 X ) ( setwithbinop2 Y ) ( pr1 f ) ( pr2 ( pr2 f ) ) . Definition twobinopmonocomp { X Y Z : setwith2binop } ( f : twobinopmono X Y ) ( g : twobinopmono Y Z ) : twobinopmono X Z := twobinopmonopair ( inclcomp ( pr1 f ) ( pr1 g ) ) ( istwobinopfuncomp f g ) . Definition twobinopiso ( X Y : setwith2binop ) : UU := total2 ( fun f : weq X Y => istwobinopfun f ) . Definition twobinopisopair { X Y : setwith2binop } ( f : weq X Y ) ( is : istwobinopfun f ) : twobinopiso X Y := tpair _ f is . Definition pr1twobinopiso ( X Y : setwith2binop ) : twobinopiso X Y -> weq X Y := @pr1 _ _ . Coercion pr1twobinopiso : twobinopiso >-> weq . Definition twobinopisototwobinopmono ( X Y : setwith2binop ) : twobinopiso X Y -> twobinopmono X Y := fun f => twobinopmonopair ( pr1 f ) ( pr2 f ) . Coercion twobinopisototwobinopmono : twobinopiso >-> twobinopmono . Definition binop1iso { X Y : setwith2binop } ( f : twobinopiso X Y ) : binopiso ( setwithbinop1 X ) ( setwithbinop1 Y ) := @binopisopair ( setwithbinop1 X ) ( setwithbinop1 Y ) ( pr1 f ) ( pr1 ( pr2 f ) ) . Definition binop2iso { X Y : setwith2binop } ( f : twobinopiso X Y ) : binopiso ( setwithbinop2 X ) ( setwithbinop2 Y ) := @binopisopair ( setwithbinop2 X ) ( setwithbinop2 Y ) ( pr1 f ) ( pr2 ( pr2 f ) ) . Definition twobinopisocomp { X Y Z : setwith2binop } ( f : twobinopiso X Y ) ( g : twobinopiso Y Z ) : twobinopiso X Z := twobinopisopair ( weqcomp ( pr1 f ) ( pr1 g ) ) ( istwobinopfuncomp f g ) . Lemma istwobinopfuninvmap { X Y : setwith2binop } ( f : twobinopiso X Y ) : istwobinopfun ( invmap ( pr1 f ) ) . Proof . intros . set ( ax1f := pr1 ( pr2 f ) ) . set ( ax2f := pr2 ( pr2 f ) ) . split . intros a b . apply ( invmaponpathsweq ( pr1 f ) ) . rewrite ( homotweqinvweq ( pr1 f ) ( op1 a b ) ) . rewrite ( ax1f (invmap (pr1 f) a) (invmap (pr1 f) b) ) . rewrite ( homotweqinvweq ( pr1 f ) a ) . rewrite ( homotweqinvweq ( pr1 f ) b ) . apply idpath . intros a b . apply ( invmaponpathsweq ( pr1 f ) ) . rewrite ( homotweqinvweq ( pr1 f ) ( op2 a b ) ) . rewrite ( ax2f (invmap (pr1 f) a) (invmap (pr1 f) b) ) . rewrite ( homotweqinvweq ( pr1 f ) a ) . rewrite ( homotweqinvweq ( pr1 f ) b ) . apply idpath . Defined . Opaque istwobinopfuninvmap . Definition invtwobinopiso { X Y : setwith2binop } ( f : twobinopiso X Y ) : twobinopiso Y X := twobinopisopair ( invweq ( pr1 f ) ) ( istwobinopfuninvmap f ) . (** **** Transport of properties of a pair binary operations *) Lemma isldistrmonob { X Y : setwith2binop } ( f : twobinopmono X Y ) ( is : isldistr ( @op1 Y ) ( @op2 Y ) ) : isldistr ( @op1 X ) ( @op2 X ) . Proof . intros . set ( ax1f := pr1 ( pr2 f ) ) . set ( ax2f := pr2 ( pr2 f ) ) . intros a b c . apply ( invmaponpathsincl _ ( pr2 ( pr1 f ) ) ) . change ( paths ( (pr1 f) (op2 c (op1 a b))) ( (pr1 f) (op1 (op2 c a) (op2 c b))) ) . rewrite ( ax2f c ( op1 a b ) ) . rewrite ( ax1f a b ) . rewrite ( ax1f ( op2 c a ) ( op2 c b ) ) . rewrite ( ax2f c a ) . rewrite ( ax2f c b ) . apply is . Defined . Opaque isldistrmonob . Lemma isrdistrmonob { X Y : setwith2binop } ( f : twobinopmono X Y ) ( is : isrdistr ( @op1 Y ) ( @op2 Y ) ) : isrdistr ( @op1 X ) ( @op2 X ) . Proof . intros . set ( ax1f := pr1 ( pr2 f ) ) . set ( ax2f := pr2 ( pr2 f ) ) . intros a b c . apply ( invmaponpathsincl _ ( pr2 ( pr1 f ) ) ) . change ( paths ( (pr1 f) (op2 (op1 a b) c)) ( (pr1 f) (op1 (op2 a c) (op2 b c))) ) . rewrite ( ax2f ( op1 a b ) c ) . rewrite ( ax1f a b ) . rewrite ( ax1f ( op2 a c ) ( op2 b c ) ) . rewrite ( ax2f a c ) . rewrite ( ax2f b c ) . apply is . Defined . Opaque isrdistrmonob . Definition isdistrmonob { X Y : setwith2binop } ( f : twobinopmono X Y ) ( is : isdistr ( @op1 Y ) ( @op2 Y ) ) : isdistr ( @op1 X ) ( @op2 X ) := dirprodpair ( isldistrmonob f ( pr1 is ) ) ( isrdistrmonob f ( pr2 is ) ) . Notation isldistrisob := isldistrmonob . Notation isrdistrisob := isrdistrmonob . Notation isdistrisob := isdistrmonob . Lemma isldistrisof { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isldistr ( @op1 X ) ( @op2 X ) ) : isldistr ( @op1 Y ) ( @op2 Y ) . Proof . intros . apply ( isldistrisob ( invtwobinopiso f ) is ) . Defined . Lemma isrdistrisof { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isrdistr ( @op1 X ) ( @op2 X ) ) : isrdistr ( @op1 Y ) ( @op2 Y ) . Proof . intros . apply ( isrdistrisob ( invtwobinopiso f ) is ) . Defined . Lemma isdistrisof { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isdistr ( @op1 X ) ( @op2 X ) ) : isdistr ( @op1 Y ) ( @op2 Y ) . Proof . intros . apply ( isdistrisob ( invtwobinopiso f ) is ) . Defined . Definition isrigopsisof { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isrigops ( @op1 X ) ( @op2 X ) ) : isrigops ( @op1 Y ) ( @op2 Y ) . Proof . intros. split . split with ( dirprodpair ( isabmonoidopisof ( binop1iso f ) ( rigop1axs_is is ) ) ( ismonoidopisof ( binop2iso f ) ( rigop2axs_is is ) ) ) . simpl . change (unel_is (ismonoidopisof (binop1iso f) (rigop1axs_is is))) with ( (pr1 f ) ( rigunel1_is is ) ) . split . intro y . rewrite ( pathsinv0 ( homotweqinvweq f y ) ) . rewrite ( pathsinv0 ( ( pr2 ( pr2 f ) ) _ _ ) ) . apply ( maponpaths ( pr1 f ) ) . apply ( rigmult0x_is is ) . intro y . rewrite ( pathsinv0 ( homotweqinvweq f y ) ) . rewrite ( pathsinv0 ( ( pr2 ( pr2 f ) ) _ _ ) ) . apply ( maponpaths ( pr1 f ) ) . apply ( rigmultx0_is is ) . apply ( isdistrisof f ) . apply ( rigdistraxs_is is ) . Defined . Definition isrigopsisob { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isrigops ( @op1 Y ) ( @op2 Y ) ) : isrigops ( @op1 X ) ( @op2 X ) . Proof. intros . apply ( isrigopsisof ( invtwobinopiso f ) is ) . Defined . Definition isrngopsisof { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isrngops ( @op1 X ) ( @op2 X ) ) : isrngops ( @op1 Y ) ( @op2 Y ) := dirprodpair ( dirprodpair ( isabgropisof ( binop1iso f ) ( rngop1axs_is is ) ) ( ismonoidopisof ( binop2iso f ) ( rngop2axs_is is ) ) ) ( isdistrisof f ( pr2 is ) ) . Definition isrngopsisob { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isrngops ( @op1 Y ) ( @op2 Y ) ) : isrngops ( @op1 X ) ( @op2 X ) := dirprodpair ( dirprodpair ( isabgropisob ( binop1iso f ) ( rngop1axs_is is ) ) ( ismonoidopisob ( binop2iso f ) ( rngop2axs_is is ) ) ) ( isdistrisob f ( pr2 is ) ) . Definition iscommrngopsisof { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : iscommrngops ( @op1 X ) ( @op2 X ) ) : iscommrngops ( @op1 Y ) ( @op2 Y ) := dirprodpair ( isrngopsisof f is ) ( iscommisof ( binop2iso f ) ( pr2 is ) ) . Definition iscommrngopsisob { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : iscommrngops ( @op1 Y ) ( @op2 Y ) ) : iscommrngops ( @op1 X ) ( @op2 X ) := dirprodpair ( isrngopsisob f is ) ( iscommisob ( binop2iso f ) ( pr2 is ) ) . (** **** Subobjects *) Definition issubsetwith2binop { X : setwith2binop } ( A : hsubtypes X ) := dirprod ( forall a a' : A , A ( op1 ( pr1 a ) ( pr1 a' ) ) ) ( forall a a' : A , A ( op2 ( pr1 a ) ( pr1 a' ) ) ) . Lemma isapropissubsetwith2binop { X : setwith2binop } ( A : hsubtypes X ) : isaprop ( issubsetwith2binop A ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply impred . intro a . apply impred . intros a' . apply ( pr2 ( A ( op1 (pr1 a) (pr1 a')) ) ) . apply impred . intro a . apply impred . intros a' . apply ( pr2 ( A ( op2 (pr1 a) (pr1 a')) ) ) . Defined . Definition subsetswith2binop { X : setwith2binop } := total2 ( fun A : hsubtypes X => issubsetwith2binop A ) . Definition subsetswith2binoppair { X : setwith2binop } := tpair ( fun A : hsubtypes X => issubsetwith2binop A ) . Definition subsetswith2binopconstr { X : setwith2binop } := @subsetswith2binoppair X . Definition pr1subsetswith2binop ( X : setwith2binop ) : @subsetswith2binop X -> hsubtypes X := @pr1 _ ( fun A : hsubtypes X => issubsetwith2binop A ) . Coercion pr1subsetswith2binop : subsetswith2binop >-> hsubtypes . Definition totalsubsetwith2binop ( X : setwith2binop ) : @subsetswith2binop X . Proof . intros . split with ( fun x : X => htrue ) . split . intros x x' . apply tt . intros . apply tt . Defined . Definition carrierofsubsetwith2binop { X : setwith2binop } ( A : @subsetswith2binop X ) : setwith2binop . Proof . intros . set ( aset := ( hSetpair ( carrier A ) ( isasetsubset ( pr1carrier A ) ( setproperty X ) ( isinclpr1carrier A ) ) ) : hSet ) . split with aset . set ( subopp1 := ( fun a a' : A => carrierpair A ( op1 ( pr1carrier _ a ) ( pr1carrier _ a' ) ) ( pr1 ( pr2 A ) a a' ) ) : ( A -> A -> A ) ) . set ( subopp2 := ( fun a a' : A => carrierpair A ( op2 ( pr1carrier _ a ) ( pr1carrier _ a' ) ) ( pr2 ( pr2 A ) a a' ) ) : ( A -> A -> A ) ) . simpl . apply ( dirprodpair subopp1 subopp2 ) . Defined . Coercion carrierofsubsetwith2binop : subsetswith2binop >-> setwith2binop . (** **** Quotient objects *) Definition is2binophrel { X : setwith2binop } ( R : hrel X ) := dirprod ( @isbinophrel ( setwithbinop1 X ) R ) ( @isbinophrel ( setwithbinop2 X ) R ) . Lemma isapropis2binophrel { X : setwith2binop } ( R : hrel X ) : isaprop ( is2binophrel R ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropisbinophrel . apply isapropisbinophrel . Defined . Lemma iscomp2binoptransrel { X : setwith2binop } ( R : hrel X ) ( is : istrans R ) ( isb : is2binophrel R ) : dirprod ( iscomprelrelfun2 R R ( @op1 X ) ) ( iscomprelrelfun2 R R ( @op2 X ) ) . Proof . intros . split . apply ( @iscompbinoptransrel ( setwithbinop1 X ) R is ( pr1 isb ) ) . apply ( @iscompbinoptransrel ( setwithbinop2 X ) R is ( pr2 isb ) ) . Defined . Definition twobinophrel { X : setwith2binop } := total2 ( fun R : hrel X => is2binophrel R ) . Definition twobinophrelpair { X : setwith2binop } := tpair ( fun R : hrel X => is2binophrel R ) . Definition pr1twobinophrel ( X : setwith2binop ) : @twobinophrel X -> hrel X := @pr1 _ ( fun R : hrel X => is2binophrel R ) . Coercion pr1twobinophrel : twobinophrel >-> hrel . Definition twobinoppo { X : setwith2binop } := total2 ( fun R : po X => is2binophrel R ) . Definition twobinoppopair { X : setwith2binop } := tpair ( fun R : po X => is2binophrel R ) . Definition pr1twobinoppo ( X : setwith2binop ) : @twobinoppo X -> po X := @pr1 _ ( fun R : po X => is2binophrel R ) . Coercion pr1twobinoppo : twobinoppo >-> po . Definition twobinopeqrel { X : setwith2binop } := total2 ( fun R : eqrel X => is2binophrel R ) . Definition twobinopeqrelpair { X : setwith2binop } := tpair ( fun R : eqrel X => is2binophrel R ) . Definition pr1twobinopeqrel ( X : setwith2binop ) : @twobinopeqrel X -> eqrel X := @pr1 _ ( fun R : eqrel X => is2binophrel R ) . Coercion pr1twobinopeqrel : twobinopeqrel >-> eqrel . Definition setwith2binopquot { X : setwith2binop } ( R : @twobinopeqrel X ) : setwith2binop . Proof . intros . split with ( setquotinset R ) . set ( qt := setquot R ) . set ( qtset := setquotinset R ) . assert ( iscomp1 : iscomprelrelfun2 R R ( @op1 X ) ) . apply ( pr1 ( iscomp2binoptransrel ( pr1 R ) ( eqreltrans _ ) ( pr2 R ) ) ) . set ( qtop1 := setquotfun2 R R ( @op1 X ) iscomp1 ) . assert ( iscomp2 : iscomprelrelfun2 R R ( @op2 X ) ) . apply ( pr2 ( iscomp2binoptransrel ( pr1 R ) ( eqreltrans _ ) ( pr2 R ) ) ) . set ( qtop2 := setquotfun2 R R ( @op2 X ) iscomp2 ) . simpl . apply ( dirprodpair qtop1 qtop2 ) . Defined . (** **** Direct products *) Definition setwith2binopdirprod ( X Y : setwith2binop ) : setwith2binop . Proof . intros . split with ( setdirprod X Y ) . simpl . (* ??? same issue as with setwithbinopdirpro above *) apply ( dirprodpair ( fun xy xy' : dirprod X Y => dirprodpair ( op1 ( pr1 xy ) ( pr1 xy' ) ) ( op1 ( pr2 xy ) ( pr2 xy' ) ) ) ( fun xy xy' : dirprod X Y => dirprodpair ( op2 ( pr1 xy ) ( pr1 xy' ) ) ( op2 ( pr2 xy ) ( pr2 xy' ) ) ) ) . Defined . (* End of the file algebra1a.v *) Voevodsky-Coq/hlevel2/._algebra1b.v000777 000765 000024 00000000256 12346040720 017774 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/algebra1b.v000777 000765 000024 00000233261 12346040720 017563 0ustar00nicolastaff000000 000000 (** * Algebra I. Part B. Monoids, abelian monoids groups, abelian groups. 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 ".." as Foundations. Require Export Foundations.hlevel2.algebra1a . (** To upstream files *) (** ** Standard Algebraic Structures *) (** *** Monoids *) (** **** Basic definitions *) Definition monoid := total2 ( fun X : setwithbinop => ismonoidop ( @op X ) ) . Definition monoidpair := tpair ( fun X : setwithbinop => ismonoidop ( @op X ) ) . Definition monoidconstr := monoidpair . Definition pr1monoid : monoid -> setwithbinop := @pr1 _ _ . Coercion pr1monoid : monoid >-> setwithbinop . Definition assocax ( X : monoid ) : isassoc ( @op X ) := pr1 ( pr2 X ) . Definition unel ( X : monoid) : X := pr1 ( pr2 ( pr2 X ) ) . Definition lunax ( X : monoid ) : islunit ( @op X ) ( unel X ) := pr1 ( pr2 ( pr2 ( pr2 X ) ) ) . Definition runax ( X : monoid ) : isrunit ( @op X ) ( unel X ) := pr2 ( pr2 ( pr2 ( pr2 X ) ) ) . Notation "x + y" := ( op x y ) : addmonoid_scope . Notation "0" := ( unel _ ) : addmonoid_scope . Delimit Scope addmonoid_scope with addmonoid. Notation "x * y" := ( op x y ) : multmonoid_scope . Notation "1" := ( unel _ ) : multmonoid_scope . Delimit Scope multmonoid_scope with multmonoid. (** **** Functions betweens monoids compatible with structure ( homomorphisms ) and their properties *) Definition ismonoidfun { X Y : monoid } ( f : X -> Y ) := dirprod ( isbinopfun f ) ( paths ( f ( unel X ) ) ( unel Y ) ) . Lemma isapropismonoidfun { X Y : monoid } ( f : X -> Y ) : isaprop ( ismonoidfun f ) . Proof . intros . apply isofhleveldirprod . apply isapropisbinopfun . apply ( setproperty Y ) . Defined . Definition monoidfun ( X Y : monoid ) : UU := total2 ( fun f : X -> Y => ismonoidfun f ) . Definition monoidfunconstr { X Y : monoid } { f : X -> Y } ( is : ismonoidfun f ) : monoidfun X Y := tpair _ f is . Definition pr1monoidfun ( X Y : monoid ) : monoidfun X Y -> ( X -> Y ) := @pr1 _ _ . Definition monoidfuntobinopfun ( X Y : monoid ) : monoidfun X Y -> binopfun X Y := fun f => binopfunpair ( pr1 f ) ( pr1 ( pr2 f ) ) . Coercion monoidfuntobinopfun : monoidfun >-> binopfun . Lemma isasetmonoidfun ( X Y : monoid ) : isaset ( monoidfun X Y ) . Proof . intros . apply ( isasetsubset ( pr1monoidfun X Y ) ) . change ( isofhlevel 2 ( X -> Y ) ) . apply impred . intro . apply ( setproperty Y ) . apply isinclpr1 . intro . apply isapropismonoidfun . Defined . Lemma ismonoidfuncomp { X Y Z : monoid } ( f : monoidfun X Y ) ( g : monoidfun Y Z ) : ismonoidfun ( funcomp ( pr1 f ) ( pr1 g ) ) . Proof . intros . split with ( isbinopfuncomp f g ) . unfold funcomp . rewrite ( pr2 ( pr2 f ) ) . apply ( pr2 ( pr2 g ) ) . Defined . Opaque ismonoidfuncomp . Definition monoidfuncomp { X Y Z : monoid } ( f : monoidfun X Y ) ( g : monoidfun Y Z ) : monoidfun X Z := monoidfunconstr ( ismonoidfuncomp f g ) . Definition monoidmono ( X Y : monoid ) : UU := total2 ( fun f : incl X Y => ismonoidfun f ) . Definition monoidmonopair { X Y : monoid } ( f : incl X Y ) ( is : ismonoidfun f ) : monoidmono X Y := tpair _ f is . Definition pr1monoidmono ( X Y : monoid ) : monoidmono X Y -> incl X Y := @pr1 _ _ . Coercion pr1monoidmono : monoidmono >-> incl . Definition monoidincltomonoidfun ( X Y : monoid ) : monoidmono X Y -> monoidfun X Y := fun f => monoidfunconstr ( pr2 f ) . Coercion monoidincltomonoidfun : monoidmono >-> monoidfun . Definition monoidmonotobinopmono ( X Y : monoid ) : monoidmono X Y -> binopmono X Y := fun f => binopmonopair ( pr1 f ) ( pr1 ( pr2 f ) ) . Coercion monoidmonotobinopmono : monoidmono >-> binopmono . Definition monoidmonocomp { X Y Z : monoid } ( f : monoidmono X Y ) ( g : monoidmono Y Z ) : monoidmono X Z := monoidmonopair ( inclcomp ( pr1 f ) ( pr1 g ) ) ( ismonoidfuncomp f g ) . Definition monoidiso ( X Y : monoid ) : UU := total2 ( fun f : weq X Y => ismonoidfun f ) . Definition monoidisopair { X Y : monoid } ( f : weq X Y ) ( is : ismonoidfun f ) : monoidiso X Y := tpair _ f is . Definition pr1monoidiso ( X Y : monoid ) : monoidiso X Y -> weq X Y := @pr1 _ _ . Coercion pr1monoidiso : monoidiso >-> weq . Definition monoidisotomonoidmono ( X Y : monoid ) : monoidiso X Y -> monoidmono X Y := fun f => monoidmonopair ( pr1 f ) ( pr2 f ) . Coercion monoidisotomonoidmono : monoidiso >-> monoidmono . Definition monoidisotobinopiso ( X Y : monoid ) : monoidiso X Y -> binopiso X Y := fun f => binopisopair ( pr1 f ) ( pr1 ( pr2 f ) ) . Coercion monoidisotobinopiso : monoidiso >-> binopiso . Lemma ismonoidfuninvmap { X Y : monoid } ( f : monoidiso X Y ) : ismonoidfun ( invmap ( pr1 f ) ) . Proof . intros . split with ( isbinopfuninvmap f ) . apply ( invmaponpathsweq ( pr1 f ) ) . rewrite ( homotweqinvweq ( pr1 f ) ) . apply ( pathsinv0 ( pr2 ( pr2 f ) ) ) . Defined . Opaque ismonoidfuninvmap . Definition invmonoidiso { X Y : monoid } ( f : monoidiso X Y ) : monoidiso Y X := monoidisopair ( invweq ( pr1 f ) ) ( ismonoidfuninvmap f ) . (** **** Subobjects *) Definition issubmonoid { X : monoid } ( A : hsubtypes X ) := dirprod ( issubsetwithbinop ( @op X ) A ) ( A ( unel X ) ) . Lemma isapropissubmonoid { X : monoid } ( A : hsubtypes X ) : isaprop ( issubmonoid A ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropissubsetwithbinop . apply ( pr2 ( A ( unel X ) ) ) . Defined . Definition submonoids { X : monoid } := total2 ( fun A : hsubtypes X => issubmonoid A ) . Definition submonoidpair { X : monoid } := tpair ( fun A : hsubtypes X => issubmonoid A ) . Definition submonoidconstr { X : monoid } := @submonoidpair X . Definition pr1submonoids ( X : monoid ) : @submonoids X -> hsubtypes X := @pr1 _ _ . Definition totalsubmonoid ( X : monoid ) : @submonoids X . Proof . intro . split with ( fun x : _ => htrue ) . split . intros x x' . apply tt . apply tt . Defined . Definition submonoidstosubsetswithbinop ( X : monoid ) : @submonoids X -> @subsetswithbinop X := fun A : _ => subsetswithbinoppair ( pr1 A ) ( pr1 ( pr2 A ) ) . Coercion submonoidstosubsetswithbinop : submonoids >-> subsetswithbinop . Lemma ismonoidcarrier { X : monoid } ( A : @submonoids X ) : ismonoidop ( @op A ) . Proof . intros . split . intros a a' a'' . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply ( assocax X ) . split with ( carrierpair _ ( unel X ) ( pr2 ( pr2 A ) ) ) . split . simpl . intro a . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply ( lunax X ) . intro a . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply ( runax X ) . Defined . Definition carrierofsubmonoid { X : monoid } ( A : @submonoids X ) : monoid . Proof . intros . split with A . apply ismonoidcarrier . Defined . Coercion carrierofsubmonoid : submonoids >-> monoid . (** **** Quotient objects *) Lemma isassocquot { X : monoid } ( R : @binopeqrel X ) : isassoc ( @op ( setwithbinopquot R ) ) . Proof . intros . intros a b c . apply ( setquotuniv3prop R ( fun x x' x'' : setwithbinopquot R => hProppair _ ( setproperty ( setwithbinopquot R ) ( op ( op x x' ) x'' ) ( op x ( op x' x'' )) ) ) ) . intros x x' x'' . apply ( maponpaths ( setquotpr R ) ( assocax X x x' x'' ) ) . Defined . Opaque isassocquot . Lemma isunitquot { X : monoid } ( R : @binopeqrel X ) : isunit ( @op ( setwithbinopquot R ) ) ( setquotpr R ( pr1 ( pr2 ( pr2 X ) ) ) ) . Proof . intros . set ( qun := setquotpr R ( pr1 ( pr2 ( pr2 X ) ) ) ) . set ( qsetwithop := setwithbinopquot R ) . split . intro x . apply ( setquotunivprop R ( fun x => @eqset qsetwithop ( ( @op qsetwithop ) qun x ) x ) ) . simpl . intro x0 . apply ( maponpaths ( setquotpr R ) ( lunax X x0 ) ) . intro x . apply ( setquotunivprop R ( fun x => @eqset qsetwithop ( ( @op qsetwithop ) x qun ) x ) ) . simpl . intro x0 . apply ( maponpaths ( setquotpr R ) ( runax X x0 ) ) . Defined . Opaque isunitquot . Definition ismonoidquot { X : monoid } ( R : @binopeqrel X ) : ismonoidop ( @op ( setwithbinopquot R ) ) := tpair _ ( isassocquot R ) ( tpair _ ( setquotpr R ( pr1 ( pr2 ( pr2 X ) ) ) ) ( isunitquot R ) ) . Definition monoidquot { X : monoid } ( R : @binopeqrel X ) : monoid . Proof . intros . split with ( setwithbinopquot R ) . apply ismonoidquot . Defined . (** **** Direct products *) Lemma isassocdirprod ( X Y : monoid ) : isassoc ( @op ( setwithbinopdirprod X Y ) ) . Proof . intros . simpl . intros xy xy' xy'' . simpl . apply pathsdirprod . apply ( assocax X ) . apply ( assocax Y ) . Defined . Opaque isassocdirprod . Lemma isunitindirprod ( X Y : monoid ) : isunit ( @op ( setwithbinopdirprod X Y ) ) ( dirprodpair ( unel X ) ( unel Y ) ) . Proof . split . intro xy . destruct xy as [ x y ] . simpl . apply pathsdirprod . apply ( lunax X ) . apply ( lunax Y ) . intro xy . destruct xy as [ x y ] . simpl . apply pathsdirprod . apply ( runax X ) . apply ( runax Y ) . Defined . Opaque isunitindirprod . Definition ismonoiddirprod ( X Y : monoid ) : ismonoidop ( @op ( setwithbinopdirprod X Y ) ) := tpair _ ( isassocdirprod X Y ) ( tpair _ ( dirprodpair ( unel X ) ( unel Y ) ) ( isunitindirprod X Y ) ) . Definition monoiddirprod ( X Y : monoid ) : monoid . Proof . intros . split with ( setwithbinopdirprod X Y ) . apply ismonoiddirprod . Defined . (** *** Abelian ( commutative ) monoids *) (** **** Basic definitions *) Definition abmonoid := total2 ( fun X : setwithbinop => isabmonoidop ( @op X ) ) . Definition abmonoidpair := tpair ( fun X : setwithbinop => isabmonoidop ( @op X ) ) . Definition abmonoidconstr := abmonoidpair . Definition abmonoidtomonoid : abmonoid -> monoid := fun X : _ => monoidpair ( pr1 X ) ( pr1 ( pr2 X ) ) . Coercion abmonoidtomonoid : abmonoid >-> monoid . Definition commax ( X : abmonoid ) : iscomm ( @op X ) := pr2 ( pr2 X ) . Definition abmonoidrer ( X : abmonoid ) ( a b c d : X ) : paths ( op ( op a b ) ( op c d ) ) ( op ( op a c ) ( op b d ) ) := abmonoidoprer ( pr2 X ) a b c d . (** **** Subobjects *) Definition subabmonoids { X : abmonoid } := @submonoids X . Identity Coercion id_subabmonoids : subabmonoids >-> submonoids . Lemma iscommcarrier { X : abmonoid } ( A : @submonoids X ) : iscomm ( @op A ) . Proof . intros . intros a a' . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply ( pr2 ( pr2 X ) ) . Defined . Opaque iscommcarrier . Definition isabmonoidcarrier { X : abmonoid } ( A : @submonoids X ) : isabmonoidop ( @op A ) := dirprodpair ( ismonoidcarrier A ) ( iscommcarrier A ) . Definition carrierofsubabmonoid { X : abmonoid } ( A : @subabmonoids X ) : abmonoid . Proof . intros . unfold subabmonoids in A . split with A . apply isabmonoidcarrier . Defined . Coercion carrierofsubabmonoid : subabmonoids >-> abmonoid . (** **** Quotient objects *) Lemma iscommquot { X : abmonoid } ( R : @binopeqrel X ) : iscomm ( @op ( setwithbinopquot R ) ) . Proof . intros . set ( X0 := setwithbinopquot R ) . intros x x' . apply ( setquotuniv2prop R ( fun x x' : X0 => hProppair _ ( setproperty X0 ( op x x') ( op x' x) ) ) ) . intros x0 x0' . apply ( maponpaths ( setquotpr R ) ( ( commax X ) x0 x0' ) ) . Defined . Opaque iscommquot . Definition isabmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : isabmonoidop ( @op ( setwithbinopquot R ) ) := dirprodpair ( ismonoidquot R ) ( iscommquot R ) . Definition abmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : abmonoid . Proof . intros . split with ( setwithbinopquot R ) . apply isabmonoidquot . Defined . (** **** Direct products *) Lemma iscommdirprod ( X Y : abmonoid ) : iscomm ( @op ( setwithbinopdirprod X Y ) ) . Proof . intros . intros xy xy' . destruct xy as [ x y ] . destruct xy' as [ x' y' ] . simpl . apply pathsdirprod . apply ( commax X ) . apply ( commax Y ) . Defined . Opaque iscommdirprod . Definition isabmonoiddirprod ( X Y : abmonoid ) : isabmonoidop ( @op ( setwithbinopdirprod X Y ) ) := dirprodpair ( ismonoiddirprod X Y ) ( iscommdirprod X Y ) . Definition abmonoiddirprod ( X Y : abmonoid ) : abmonoid . Proof . intros . split with ( setwithbinopdirprod X Y ) . apply isabmonoiddirprod . Defined . (** **** Monoid of fractions of an abelian monoid Note : the following construction uses onbly associativity and commutativity of the [ abmonoid ] operations but does not use the unit element . *) Open Scope addmonoid_scope . Definition abmonoidfracopint ( X : abmonoid ) ( A : @submonoids X ) : binop ( dirprod X A ) := @op ( setwithbinopdirprod X A ) . Definition hrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : hrel ( setwithbinopdirprod X A ) := fun xa yb : dirprod X A => hexists ( fun a0 : A => paths ( ( ( pr1 xa ) + ( pr1 ( pr2 yb ) ) ) + ( pr1 a0 ) ) ( ( ( pr1 yb ) + ( pr1 ( pr2 xa ) ) + ( pr1 a0 ) ) ) ) . Lemma iseqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : iseqrel ( hrelabmonoidfrac X A ) . Proof . intros . set ( assoc := assocax X ) . set ( comm := commax X ) . set ( R := hrelabmonoidfrac X A ) . assert ( symm : issymm R ) . intros xa yb . unfold R . simpl . apply hinhfun . intro eq1 . destruct eq1 as [ x1 eq1 ] . split with x1 . destruct x1 as [ x1 isx1 ] . simpl . apply ( pathsinv0 eq1 ) . assert ( trans : istrans R ) . unfold istrans . intros ab cd ef . simpl . apply hinhfun2 . destruct ab as [ a b ] . destruct cd as [ c d ] . destruct ef as [ e f ] . destruct b as [ b isb ] . destruct d as [ d isd ] . destruct f as [ f isf ] . intros eq1 eq2 . destruct eq1 as [ x1 eq1 ] . destruct eq2 as [ x2 eq2 ] . simpl in * . split with ( @op A ( tpair _ d isd ) ( @op A x1 x2 ) ) . destruct x1 as [ x1 isx1 ] . destruct x2 as [ x2 isx2 ] . destruct A as [ A ax ] . simpl in * . rewrite ( assoc a f ( d + ( x1 + x2 ) ) ) . rewrite ( comm f ( d + ( x1 + x2 ) ) ) . destruct ( assoc a ( d + ( x1 + x2 ) ) f ) . destruct ( assoc a d ( x1 + x2 ) ) . destruct ( assoc ( a + d ) x1 x2 ) . rewrite eq1 . rewrite ( comm x1 x2 ) . rewrite ( assoc e b ( d + ( x2 + x1 ) ) ) . rewrite ( comm b ( d + ( x2 + x1 ) ) ) . destruct ( assoc e ( d + ( x2 + x1 ) ) b ) . destruct ( assoc e d ( x2 + x1 ) ) . destruct ( assoc ( e + d ) x2 x1 ) . destruct eq2 . rewrite ( assoc ( c + b ) x1 x2 ) . rewrite ( assoc ( c + f ) x2 x1 ) . rewrite ( comm x1 x2 ) . rewrite ( assoc ( c + b ) ( x2 + x1 ) f ) . rewrite ( assoc ( c + f ) ( x2 + x1 ) b ) . rewrite ( comm ( x2 + x1 ) f ) . rewrite ( comm ( x2 + x1 ) b ) . destruct ( assoc ( c + b ) f ( x2 + x1 ) ) . destruct ( assoc ( c + f ) b ( x2 + x1 ) ) . rewrite ( assoc c b f ) . rewrite ( assoc c f b ) . rewrite ( comm b f ) . apply idpath . assert ( refl : isrefl R ) . intro xa . simpl . apply hinhpr . split with ( pr2 xa ) . apply idpath . apply ( iseqrelconstr trans refl symm ) . Defined . Opaque iseqrelabmonoidfrac . Definition eqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : eqrel ( setwithbinopdirprod X A ) := eqrelpair ( hrelabmonoidfrac X A ) ( iseqrelabmonoidfrac X A ) . Lemma isbinophrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : @isbinophrel ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) . Proof . intros . apply ( isbinopreflrel ( eqrelabmonoidfrac X A ) ( eqrelrefl ( eqrelabmonoidfrac X A ) ) ) . set ( rer := abmonoidoprer ( pr2 X ) ) . intros a b c d . simpl . apply hinhfun2 . destruct a as [ a a' ] . destruct a' as [ a' isa' ] . destruct b as [ b b' ] . destruct b' as [ b' isb' ] . destruct c as [ c c' ] . destruct c' as [ c' isc' ] . destruct d as [ d d' ] . destruct d' as [ d' isd' ] . intros ax ay . destruct ax as [ a1 eq1 ] . destruct ay as [ a2 eq2 ] . split with ( @op A a1 a2 ) . destruct a1 as [ a1 aa1 ] . destruct a2 as [ a2 aa2 ] . simpl in *. rewrite ( rer a c b' d' ) . rewrite ( rer b d a' c' ) . rewrite ( rer ( a + b' ) ( c + d' ) a1 a2 ) . rewrite ( rer ( b + a' ) ( d + c' ) a1 a2 ) . destruct eq1 . destruct eq2 . apply idpath . Defined . Opaque isbinophrelabmonoidfrac . Definition abmonoidfracop ( X : abmonoid ) ( A : @submonoids X ) : binop ( setquot ( hrelabmonoidfrac X A ) ) := setquotfun2 ( hrelabmonoidfrac X A ) ( eqrelabmonoidfrac X A ) ( abmonoidfracopint X A ) ( ( iscompbinoptransrel _ ( eqreltrans _ ) ( isbinophrelabmonoidfrac X A ) ) ) . Definition binopeqrelabmonoidfrac ( X : abmonoid ) ( A : @subabmonoids X ) : @binopeqrel ( abmonoiddirprod X A ) := @binopeqrelpair ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) ( isbinophrelabmonoidfrac X A ) . Definition abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : abmonoid := abmonoidquot ( binopeqrelabmonoidfrac X A ) . Definition prabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : X -> A -> abmonoidfrac X A := fun ( x : X ) ( a : A ) => setquotpr ( eqrelabmonoidfrac X A ) ( dirprodpair x a ) . (* ??? could the use of [ issubabmonoid ] in [ binopeqrelabmonoidfrac ] and [ submonoid ] in [ abmonoidfrac ] lead to complications for the unification machinery? See also [ abmonoidfracisbinoprelint ] below . *) Lemma invertibilityinabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : forall a a' : A , isinvertible ( @op ( abmonoidfrac X A ) ) ( prabmonoidfrac X A ( pr1 a ) a' ) . Proof . intros . set ( R := eqrelabmonoidfrac X A ) . unfold isinvertible . assert ( isl : islinvertible ( @op ( abmonoidfrac X A ) ) ( prabmonoidfrac X A ( pr1 a ) a' ) ) . unfold islinvertible . set ( f := fun x0 : abmonoidfrac X A => prabmonoidfrac X A (pr1 a) a' + x0 ) . set ( g := fun x0 : abmonoidfrac X A => prabmonoidfrac X A (pr1 a' ) a + x0 ) . assert ( egf : forall x0 : _ , paths ( g ( f x0 ) ) x0 ) . apply ( setquotunivprop R ( fun x0 : abmonoidfrac X A => eqset (g (f x0)) x0 ) ) . intro xb . simpl . apply ( iscompsetquotpr R ( @dirprodpair X A ( ( pr1 a' ) + ( ( pr1 a ) + ( pr1 xb ) ) ) ( ( @op A ) a ( ( @op A ) a' ( pr2 xb ) ) ) ) ) . simpl . apply hinhpr . split with ( unel A ) . unfold pr1carrier . simpl . set ( e := assocax X ( pr1 a ) ( pr1 a' ) ( pr1 ( pr2 xb ) ) ) . simpl in e . destruct e . set ( e := assocax X ( pr1 xb ) ( pr1 a + pr1 a' ) ( pr1 ( pr2 xb ) ) ) . simpl in e . destruct e . set ( e := assocax X ( pr1 a' ) ( pr1 a ) ( pr1 xb ) ) . simpl in e . destruct e . set ( e := commax X ( pr1 a ) ( pr1 a' ) ) . simpl in e . destruct e . set ( e := commax X ( pr1 a + pr1 a' ) ( pr1 xb ) ) . simpl in e . destruct e . apply idpath . assert ( efg : forall x0 : _ , paths ( f ( g x0 ) ) x0 ) . apply ( setquotunivprop R ( fun x0 : abmonoidfrac X A => eqset (f (g x0)) x0 ) ) . intro xb . simpl . apply ( iscompsetquotpr R ( @dirprodpair X A ( ( pr1 a ) + ( ( pr1 a' ) + ( pr1 xb ) ) ) ( ( @op A ) a' ( ( @op A ) a ( pr2 xb ) ) ) ) ) . simpl . apply hinhpr . split with ( unel A ) . unfold pr1carrier . simpl . set ( e := assocax X ( pr1 a' ) ( pr1 a ) ( pr1 ( pr2 xb ) ) ) . simpl in e . destruct e . set ( e := assocax X ( pr1 xb ) ( pr1 a' + pr1 a ) ( pr1 ( pr2 xb ) ) ) . simpl in e . destruct e . set ( e := assocax X ( pr1 a ) ( pr1 a' ) ( pr1 xb ) ) . simpl in e . destruct e . set ( e := commax X ( pr1 a' ) ( pr1 a ) ) . simpl in e . destruct e . set ( e := commax X ( pr1 a' + pr1 a ) ( pr1 xb ) ) . simpl in e . destruct e . apply idpath . apply ( gradth _ _ egf efg ) . apply ( dirprodpair isl ( weqlinvertiblerinvertible ( @op ( abmonoidfrac X A ) ) ( commax ( abmonoidfrac X A ) ) ( prabmonoidfrac X A ( pr1 a ) a' ) isl ) ) . Defined . (** **** Canonical homomorphism to the monoid of fractions *) Definition toabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) ( x : X ) : abmonoidfrac X A := setquotpr _ ( dirprodpair x ( unel A ) ) . Lemma isbinopfuntoabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : isbinopfun ( toabmonoidfrac X A ) . Proof . intros . unfold isbinopfun . intros x1 x2 . change ( paths ( setquotpr _ ( dirprodpair ( x1 + x2 ) ( @unel A ) ) ) ( setquotpr ( eqrelabmonoidfrac X A ) ( dirprodpair ( x1 + x2 ) ( ( unel A ) + ( unel A ) ) ) ) ) . apply ( maponpaths ( setquotpr _ ) ) . apply ( @pathsdirprod X A ) . apply idpath . apply ( pathsinv0 ( lunax A 0 ) ) . Defined . Lemma isunitalfuntoabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : paths ( toabmonoidfrac X A ( unel X ) ) ( unel ( abmonoidfrac X A ) ) . Proof . intros . apply idpath . Defined . Definition ismonoidfuntoabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : ismonoidfun ( toabmonoidfrac X A ) := dirprodpair ( isbinopfuntoabmonoidfrac X A ) ( isunitalfuntoabmonoidfrac X A ) . (** **** Abelian monoid of fractions in the case when elements of the localziation submonoid are cancelable *) Definition hrel0abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : hrel ( dirprod X A ) := fun xa yb : setdirprod X A => eqset ( ( pr1 xa ) + ( pr1 ( pr2 yb ) ) ) ( ( pr1 yb ) + ( pr1 ( pr2 xa ) ) ) . Lemma weqhrelhrel0abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) ( iscanc : forall a : A , isrcancelable ( @op X ) ( pr1carrier _ a ) ) ( xa xa' : dirprod X A ) : weq ( eqrelabmonoidfrac X A xa xa' ) ( hrel0abmonoidfrac X A xa xa' ) . Proof . intros . unfold eqrelabmonoidfrac . unfold hrelabmonoidfrac . simpl . apply weqimplimpl . apply ( @hinhuniv _ ( eqset (pr1 xa + pr1 (pr2 xa')) (pr1 xa' + pr1 (pr2 xa)) ) ) . intro ae . destruct ae as [ a eq ] . apply ( invmaponpathsincl _ ( iscanc a ) _ _ eq ) . intro eq . apply hinhpr . split with ( unel A ) . rewrite ( runax X ) . rewrite ( runax X ) . apply eq . apply ( isapropishinh _ ) . apply ( setproperty X ) . Defined . Lemma isinclprabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) ( iscanc : forall a : A , isrcancelable ( @op X ) ( pr1carrier _ a ) ) : forall a' : A , isincl ( fun x => prabmonoidfrac X A x a' ) . Proof . intros . apply isinclbetweensets . apply ( setproperty X ) . apply ( setproperty ( abmonoidfrac X A ) ) . intros x x' . intro e . set ( e' := invweq ( weqpathsinsetquot ( eqrelabmonoidfrac X A ) ( dirprodpair x a' ) ( dirprodpair x' a' ) ) e ) . set ( e'':= weqhrelhrel0abmonoidfrac X A iscanc ( dirprodpair _ _ ) ( dirprodpair _ _ ) e' ) . simpl in e'' . apply ( invmaponpathsincl _ ( iscanc a' ) ) . apply e'' . Defined . Definition isincltoabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) ( iscanc : forall a : A , isrcancelable ( @op X ) ( pr1carrier _ a ) ) : isincl ( toabmonoidfrac X A ) := isinclprabmonoidfrac X A iscanc ( unel A ) . Lemma isdeceqabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) ( iscanc : forall a : A , isrcancelable ( @op X ) ( pr1carrier _ a ) ) ( is : isdeceq X ) : isdeceq ( abmonoidfrac X A ) . Proof . intros . apply ( isdeceqsetquot ( eqrelabmonoidfrac X A ) ) . intros xa xa' . apply ( isdecpropweqb ( weqhrelhrel0abmonoidfrac X A iscanc xa xa' ) ) . apply isdecpropif . unfold isaprop . simpl . set ( int := setproperty X (pr1 xa + pr1 (pr2 xa')) (pr1 xa' + pr1 (pr2 xa))) . simpl in int . apply int . unfold hrel0abmonoidfrac . unfold eqset . simpl . apply ( is _ _ ) . Defined . (** **** Relations on the abelian monoid of fractions *) Definition abmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) ( L : hrel X ) : hrel ( setwithbinopdirprod X A ) := fun xa yb => hexists ( fun c0 : A => L ( ( ( pr1 xa ) + ( pr1 ( pr2 yb ) ) ) + ( pr1 c0 ) ) ( ( ( pr1 yb ) + ( pr1 ( pr2 xa ) ) ) + ( pr1 c0 ) ) ) . Lemma iscomprelabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) : iscomprelrel ( eqrelabmonoidfrac X A ) ( abmonoidfracrelint X A L ) . Proof . intros . set ( assoc := ( assocax X ) : isassoc ( @op X ) ) . unfold isassoc in assoc . set ( comm := commax X ) . unfold iscomm in comm . set ( rer := abmonoidrer X ) . apply iscomprelrelif . apply ( eqrelsymm ( eqrelabmonoidfrac X A ) ) . intros xa xa' yb . unfold hrelabmonoidfrac . simpl . apply ( @hinhfun2 ) . intros t2e t2l . destruct t2e as [ c1a e ] . destruct t2l as [ c0a l ] . set ( x := pr1 xa ) . set ( a := pr1 ( pr2 xa ) ) . set ( x' := pr1 xa' ) . set ( a' := pr1 ( pr2 xa' ) ) . set ( y := pr1 yb ) . set ( b := pr1 ( pr2 yb ) ) . set ( c0 := pr1 c0a ) . set ( c1 := pr1 c1a ) . split with ( ( pr2 xa ) + c1a + c0a ) . change ( L ( ( x' + b ) + ( ( a + c1 ) + c0 ) ) ( ( y + a' ) + ( ( a + c1 ) + c0 ) ) ) . change ( paths ( x + a' + c1 ) ( x' + a + c1 ) ) in e . rewrite ( rer x' _ _ c0 ) . destruct ( assoc x' a c1 ) . destruct e . rewrite ( assoc x a' c1 ) . rewrite ( rer x _ _ c0 ) . rewrite ( assoc a c1 c0 ) . rewrite ( rer _ a' a _ ) . rewrite ( assoc a' c1 c0 ) . rewrite ( comm a' _ ) . rewrite ( comm c1 _ ) . rewrite ( assoc c0 c1 a' ) . destruct ( assoc ( x + b ) c0 ( @op X c1 a' ) ) . destruct ( assoc ( y + a ) c0 ( @op X c1 a' ) ) . apply ( ( pr2 is ) _ _ _ ( pr2 ( @op A c1a ( pr2 xa' ) ) ) l ) . intros xa yb yb' . unfold hrelabmonoidfrac . simpl . apply ( @hinhfun2 ) . intros t2e t2l . destruct t2e as [ c1a e ] . destruct t2l as [ c0a l ] . set ( x := pr1 xa ) . set ( a := pr1 ( pr2 xa ) ) . set ( y' := pr1 yb' ) . set ( b' := pr1 ( pr2 yb' ) ) . set ( y := pr1 yb ) . set ( b := pr1 ( pr2 yb ) ) . set ( c0 := pr1 c0a ) . set ( c1 := pr1 c1a ) . split with ( ( pr2 yb ) + c1a + c0a ) . change ( L ( ( x + b' ) + ( ( b + c1 ) + c0 ) ) ( ( y' + a ) + ( ( b + c1 ) + c0 ) ) ) . change ( paths ( y + b' + c1 ) ( y' + b + c1 ) ) in e . rewrite ( rer y' _ _ c0 ) . destruct ( assoc y' b c1 ) . destruct e . rewrite ( assoc y b' c1 ) . rewrite ( rer y _ _ c0 ) . rewrite ( assoc b c1 c0 ) . rewrite ( rer _ b' b _ ) . rewrite ( assoc b' c1 c0 ) . rewrite ( comm b' _ ) . rewrite ( comm c1 _ ) . rewrite ( assoc c0 c1 b' ) . destruct ( assoc ( x + b ) c0 ( @op X c1 b' ) ) . destruct ( assoc ( y + a ) c0 ( @op X c1 b' ) ) . apply ( ( pr2 is ) _ _ _ ( pr2 ( @op A c1a ( pr2 yb' ) ) ) l ) . Defined . Opaque iscomprelabmonoidfracrelint . Definition abmonoidfracrel ( X : abmonoid ) ( A : @submonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) := quotrel ( iscomprelabmonoidfracrelint X A is ) . Lemma istransabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : istrans L ) : istrans ( abmonoidfracrelint X A L ) . Proof . intros . set ( assoc := ( assocax X ) : isassoc ( @op X ) ) . unfold isassoc in assoc . set ( comm := commax X ) . unfold iscomm in comm . set ( rer := abmonoidrer X ) . intros xa1 xa2 xa3 . unfold abmonoidfracrelint . simpl . apply hinhfun2 . intros t2l1 t2l2 . set ( c1a := pr1 t2l1 ) . set ( l1 := pr2 t2l1 ) . set ( c2a := pr1 t2l2 ) . set ( l2 := pr2 t2l2 ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr1 ( pr2 xa1 ) ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr1 ( pr2 xa2 ) ) . set ( x3 := pr1 xa3 ) . set ( a3 := pr1 ( pr2 xa3 ) ) . set ( c1 := pr1 c1a ) . set ( c2 := pr1 c2a ) . split with ( ( pr2 xa2 ) + ( @op A c1a c2a ) ) . change ( L ( ( x1 + a3 ) + ( a2 + ( c1 + c2 ) ) ) ( ( x3 + a1 ) + ( a2 + ( c1 + c2 ) ) ) ) . assert ( ll1 : L ( ( x1 + a3 ) + ( a2 + ( @op X c1 c2 ) ) ) ( ( ( x2 + a1 ) + c1 ) + ( c2 + a3 ) ) ) . rewrite ( rer _ a3 a2 _ ) . rewrite ( comm a3 ( @op X c1 c2 ) ) . rewrite ( assoc c1 c2 a3 ) . destruct ( assoc ( x1 + a2 ) c1 ( @op X c2 a3 ) ) . apply ( ( pr2 is ) _ _ _ ( pr2 ( @op A c2a ( pr2 xa3 ) ) ) l1 ) . assert ( ll2 : L ( ( ( x2 + a3 ) + c2 ) + ( @op X a1 c1 ) ) ( ( x3 + a1 ) + ( a2 + ( @op X c1 c2 ) ) ) ) . rewrite ( rer _ a1 a2 _ ) . destruct ( assoc a1 c1 c2 ) . rewrite ( comm ( a1 + c1 ) c2 ) . destruct ( assoc ( x3 + a2 ) c2 ( @op X a1 c1 )) . apply ( ( pr2 is ) _ _ _ ( pr2 ( @op A ( pr2 xa1 ) c1a ) ) l2 ) . assert ( e : paths (x2 + a1 + c1 + (c2 + a3)) (x2 + a3 + c2 + (a1 + c1)) ) . rewrite ( assoc ( x2 + a1 ) c1 _ ) . rewrite ( assoc ( x2 + a3 ) c2 _ ) . rewrite ( assoc x2 a1 _ ) . rewrite ( assoc x2 a3 _ ) . destruct ( assoc a1 c1 ( c2 + a3 ) ) . destruct ( assoc a3 c2 ( a1 + c1 ) ) . destruct ( comm ( c2 + a3 ) ( a1 + c1 ) ) . rewrite ( comm a3 c2 ) . apply idpath . destruct e . apply ( isl _ _ _ ll1 ll2 ) . Defined . Opaque istransabmonoidfracrelint . Lemma istransabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : istrans L ) : istrans ( abmonoidfracrel X A is ) . Proof . intros . apply istransquotrel . apply istransabmonoidfracrelint . apply is . apply isl . Defined . Lemma issymmabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : issymm L ) : issymm ( abmonoidfracrelint X A L ) . Proof . intros . intros xa1 xa2 . unfold abmonoidfracrelint . simpl . apply hinhfun . intros t2l1 . set ( c1a := pr1 t2l1 ) . set ( l1 := pr2 t2l1 ) . split with ( c1a ) . apply ( isl _ _ l1 ) . Defined . Opaque issymmabmonoidfracrelint . Lemma issymmabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : issymm L ) : issymm ( abmonoidfracrel X A is ) . Proof . intros . apply issymmquotrel . apply issymmabmonoidfracrelint . apply is . apply isl . Defined . Lemma isreflabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isrefl L ) : isrefl ( abmonoidfracrelint X A L ) . Proof . intros . intro xa . unfold abmonoidfracrelint . simpl . apply hinhpr . split with ( unel A ) . apply ( isl _ ) . Defined . Lemma isreflabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isrefl L ) : isrefl ( abmonoidfracrel X A is ) . Proof . intros . apply isreflquotrel . apply isreflabmonoidfracrelint . apply is . apply isl . Defined . Lemma ispoabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : ispo L ) : ispo ( abmonoidfracrelint X A L ) . Proof . intros . split with ( istransabmonoidfracrelint X A is ( pr1 isl ) ) . apply ( isreflabmonoidfracrelint X A is ( pr2 isl ) ) . Defined . Lemma ispoabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : ispo L ) : ispo ( abmonoidfracrel X A is ) . Proof . intros . apply ispoquotrel . apply ispoabmonoidfracrelint . apply is . apply isl . Defined . Lemma iseqrelabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iseqrel L ) : iseqrel ( abmonoidfracrelint X A L ) . Proof . intros . split with ( ispoabmonoidfracrelint X A is ( pr1 isl ) ) . apply ( issymmabmonoidfracrelint X A is ( pr2 isl ) ) . Defined . Lemma iseqrelabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iseqrel L ) : iseqrel ( abmonoidfracrel X A is ) . Proof . intros . apply iseqrelquotrel . apply iseqrelabmonoidfracrelint . apply is . apply isl . Defined . Lemma isirreflabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isirrefl L ) : isirrefl ( abmonoidfracrelint X A L ) . Proof . intros . unfold isirrefl. intro xa . unfold abmonoidfracrelint . simpl . unfold neg . apply ( @hinhuniv _ ( hProppair _ isapropempty ) ) . intro t2 . apply ( isl _ ( pr2 t2 ) ) . Defined . Lemma isirreflabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isirrefl L ) : isirrefl ( abmonoidfracrel X A is ) . Proof . intros . apply isirreflquotrel . apply isirreflabmonoidfracrelint . apply is . apply isl . Defined . Lemma isasymmabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isasymm L ) : isasymm ( abmonoidfracrelint X A L ) . Proof . intros . set ( assoc := ( assocax X ) : isassoc ( @op X ) ) . unfold isassoc in assoc . set ( comm := commax X ) . unfold iscomm in comm . unfold isasymm. intros xa1 xa2 . unfold abmonoidfracrelint . simpl . apply ( @hinhuniv2 _ _ ( hProppair _ isapropempty ) ) . intros t2l1 t2l2 . set ( c1a := pr1 t2l1 ) . set ( l1 := pr2 t2l1 ) . set ( c2a := pr1 t2l2 ) . set ( l2 := pr2 t2l2 ) . set ( c1 := pr1 c1a ) . set ( c2 := pr1 c2a ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr1 ( pr2 xa1 ) ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr1 ( pr2 xa2 ) ) . assert ( ll1 : L ( ( x1 + a2 ) + ( @op X c1 c2 ) ) ( ( x2 + a1 ) + ( @op X c1 c2 ) ) ) . destruct ( assoc ( x1 + a2 ) c1 c2 ) . destruct ( assoc ( x2 + a1 ) c1 c2 ) . apply ( ( pr2 is ) _ _ _ ( pr2 c2a ) ) . apply l1 . assert ( ll2 : L ( ( x2 + a1 ) + ( @op X c1 c2 ) ) ( ( x1 + a2 ) + ( @op X c1 c2 ) ) ) . destruct ( comm c2 c1 ) . destruct ( assoc ( x1 + a2 ) c2 c1 ) . destruct ( assoc ( x2 + a1 ) c2 c1 ) . apply ( ( pr2 is ) _ _ _ ( pr2 c1a ) ) . apply l2 . apply ( isl _ _ ll1 ll2 ) . Defined . Opaque isasymmabmonoidfracrelint . Lemma isasymmabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isasymm L ) : isasymm ( abmonoidfracrel X A is ) . Proof . intros . apply isasymmquotrel . apply isasymmabmonoidfracrelint . apply is . apply isl . Defined . Lemma iscoasymmabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iscoasymm L ) : iscoasymm ( abmonoidfracrelint X A L ) . Proof . intros . set ( assoc := ( assocax X ) : isassoc ( @op X ) ) . unfold isassoc in assoc . set ( comm := commax X ) . unfold iscomm in comm . unfold iscoasymm. intros xa1 xa2 . intro nl0 . set ( nl := neghexisttoforallneg _ nl0 ( unel A ) ) . simpl in nl . set ( l := isl _ _ nl ) . apply hinhpr . split with ( unel A ) . apply l . Defined . Opaque isasymmabmonoidfracrelint . Lemma iscoasymmabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iscoasymm L ) : iscoasymm ( abmonoidfracrel X A is ) . Proof . intros . apply iscoasymmquotrel . apply iscoasymmabmonoidfracrelint . apply is . apply isl . Defined . Lemma istotalabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : istotal L ) : istotal ( abmonoidfracrelint X A L ) . Proof . intros . unfold istotal . intros x1 x2 . unfold abmonoidfracrelint . set ( int := isl ( pr1 x1 + pr1 (pr2 x2) ) (pr1 x2 + pr1 (pr2 x1) ) ) . generalize int . clear int . simpl . apply hinhfun . apply coprodf . intro l . apply hinhpr . split with ( unel A ) . rewrite ( runax X _ ) . rewrite ( runax X _ ) . apply l . intro l . apply hinhpr . split with ( unel A ) . rewrite ( runax X _ ) . rewrite ( runax X _ ) . apply l . Defined . Lemma istotalabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : istotal L ) : istotal ( abmonoidfracrel X A is ) . Proof . intros . apply istotalquotrel . apply istotalabmonoidfracrelint . apply is . apply isl . Defined . Lemma iscotransabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iscotrans L ) : iscotrans ( abmonoidfracrelint X A L ) . Proof . intros . set ( assoc := ( assocax X ) : isassoc ( @op X ) ) . unfold isassoc in assoc . set ( comm := ( commax X ) : iscomm ( @op X ) ) . unfold iscomm in comm . set ( rer := abmonoidrer X ) . unfold iscotrans . intros xa1 xa2 xa3 . unfold abmonoidfracrelint . simpl . apply ( @hinhuniv _ ( ishinh _ ) ) . intro t2 . set ( c0a := pr1 t2 ) . set ( l0 := pr2 t2 ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr1 ( pr2 xa1 ) ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr1 ( pr2 xa2 ) ) . set ( x3 := pr1 xa3 ) . set ( a3 := pr1 ( pr2 xa3 ) ) . set ( c0 := pr1 c0a ) . set ( z1 := ( x1 + a3 + ( a2 + c0 ) ) ) . set ( z2 := x2 + a1 + ( a3 + c0 ) ) . set ( z3 := x3 + a1 + ( a2 + c0 ) ) . assert ( int : L z1 z3 ) . unfold z1 . unfold z3 . rewrite ( comm a2 c0 ) . rewrite ( pathsinv0 ( assoc _ _ a2 ) ) . rewrite ( pathsinv0 ( assoc _ _ a2 ) ) . apply ( ( pr2 is ) _ _ _ ( pr2 ( pr2 xa2 ) ) l0 ) . set ( int' := isl z1 z2 z3 int ) . generalize int' . clear int' . simpl . apply hinhfun . intro cc . destruct cc as [ l12 | l23 ] . apply ii1 . apply hinhpr . split with ( ( pr2 xa3 ) + c0a ) . change ( L ( x1 + a2 + ( a3 + c0 ) ) ( x2 + a1 + ( a3 + c0 ) ) ) . rewrite ( rer _ a2 a3 _ ) . apply l12 . apply ii2 . apply hinhpr . split with ( ( pr2 xa1 ) + c0a ) . change ( L ( x2 + a3 + ( a1 + c0 ) ) ( x3 + a2 + ( a1 + c0 ) ) ) . rewrite ( rer _ a3 a1 _ ) . rewrite ( rer _ a2 a1 _ ) . apply l23 . Defined . Opaque iscotransabmonoidfracrelint . Lemma iscotransabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iscotrans L ) : iscotrans ( abmonoidfracrel X A is ) . Proof . intros . apply iscotransquotrel . apply iscotransabmonoidfracrelint . apply is . apply isl . Defined . Lemma isantisymmnegabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isantisymmneg L ) : isantisymmneg ( abmonoidfracrel X A is ) . Proof . intros . assert ( int : forall x1 x2 , isaprop ( neg ( abmonoidfracrel X A is x1 x2 )-> neg ( abmonoidfracrel X A is x2 x1 ) -> paths x1 x2 ) ) . intros x1 x2 . apply impred . intro . apply impred . intro . apply ( isasetsetquot _ x1 x2 ) . unfold isantisymmneg . apply ( setquotuniv2prop _ ( fun x1 x2 => hProppair _ ( int x1 x2 ) ) ) . intros xa1 xa2 . intros r r' . apply ( weqpathsinsetquot _ ) . generalize r r' . clear r r' . change ( neg ( abmonoidfracrelint X A L xa1 xa2 ) -> neg ( abmonoidfracrelint X A L xa2 xa1 ) -> ( eqrelabmonoidfrac X A xa1 xa2 ) ) . intros nr12 nr21 . set ( nr12' := neghexisttoforallneg _ nr12 ( unel A ) ) . set ( nr21' := neghexisttoforallneg _ nr21 ( unel A ) ) . set ( int' := isl _ _ nr12' nr21' ) . simpl . apply hinhpr . split with ( unel A ) . apply int' . Defined . Opaque isantisymmnegabmonoidfracrel . Lemma isantisymmabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isantisymm L ) : isantisymm ( abmonoidfracrel X A is ) . Proof . intros . set ( assoc := ( assocax X ) : isassoc ( @op X ) ) . unfold isassoc in assoc . set ( comm := commax X ) . unfold iscomm in comm . unfold isantisymm. assert ( int : forall x1 x2 , isaprop ( ( abmonoidfracrel X A is x1 x2 )-> ( abmonoidfracrel X A is x2 x1 )-> paths x1 x2 ) ) . intros x1 x2 . apply impred . intro . apply impred . intro . apply ( isasetsetquot _ x1 x2 ) . apply ( setquotuniv2prop _ ( fun x1 x2 => hProppair _ ( int x1 x2 ) ) ) . intros xa1 xa2 . intros r r' . apply ( weqpathsinsetquot _ ) . generalize r r' . clear r r' . change ( ( abmonoidfracrelint X A L xa1 xa2 ) -> ( abmonoidfracrelint X A L xa2 xa1 ) -> ( eqrelabmonoidfrac X A xa1 xa2 ) ) . unfold abmonoidfracrelint . unfold eqrelabmonoidfrac . simpl . apply hinhfun2 . intros t2l1 t2l2 . set ( c1a := pr1 t2l1 ) . set ( l1 := pr2 t2l1 ) . set ( c2a := pr1 t2l2 ) . set ( l2 := pr2 t2l2 ) . set ( c1 := pr1 c1a ) . set ( c2 := pr1 c2a ) . split with ( @op A c1a c2a ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr1 ( pr2 xa1 ) ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr1 ( pr2 xa2 ) ) . change ( paths ( x1 + a2 + ( @op X c1 c2 ) ) ( x2 + a1 + ( @op X c1 c2 ) ) ) . assert ( ll1 : L ( ( x1 + a2 ) + ( @op X c1 c2 ) ) ( ( x2 + a1 ) + ( @op X c1 c2 ) ) ) . destruct ( assoc ( x1 + a2 ) c1 c2 ) . destruct ( assoc ( x2 + a1 ) c1 c2 ) . apply ( ( pr2 is ) _ _ _ ( pr2 c2a ) ) . apply l1 . assert ( ll2 : L ( ( x2 + a1 ) + ( @op X c1 c2 ) ) ( ( x1 + a2 ) + ( @op X c1 c2 ) ) ) . destruct ( comm c2 c1 ) . destruct ( assoc ( x1 + a2 ) c2 c1 ) . destruct ( assoc ( x2 + a1 ) c2 c1 ) . apply ( ( pr2 is ) _ _ _ ( pr2 c1a ) ) . apply l2 . apply ( isl _ _ ll1 ll2 ) . Defined . Opaque isantisymmabmonoidfracrel . Lemma ispartbinopabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) : @ispartbinophrel ( setwithbinopdirprod X A ) ( fun xa => A ( pr1 xa ) ) ( abmonoidfracrelint X A L ) . Proof . intros . set ( assoc := ( assocax X ) : isassoc ( @op X ) ) . unfold isassoc in assoc . set ( comm := commax X ) . unfold iscomm in comm . set ( rer := abmonoidrer X ) . apply ispartbinophrelif . apply ( commax ( abmonoiddirprod X A ) ) . intros xa yb zc s . unfold abmonoidfracrelint . simpl . apply ( @hinhfun ) . intro t2l . destruct t2l as [ c0a l ] . set ( x := pr1 xa ) . set ( a := pr1 ( pr2 xa ) ) . set ( y := pr1 yb ) . set ( b := pr1 ( pr2 yb ) ) . set ( z := pr1 zc ) . set ( c := pr1 ( pr2 zc ) ) . set ( c0 := pr1 c0a ) . split with c0a . change ( L ( ( ( z + x ) + ( c + b ) ) + c0 ) ( ( ( z + y ) + ( c + a ) ) + c0 ) ) . change ( pr1 ( L ( ( x + b ) + c0 ) ( ( y + a ) + c0 ) ) ) in l . rewrite ( rer z _ _ b ) . rewrite ( assoc ( z + c ) _ _ ) . rewrite ( rer z _ _ a ) . rewrite ( assoc ( z + c ) _ _ ) . apply ( ( pr1 is ) _ _ _ ( pr2 ( @op A ( carrierpair A z s ) ( pr2 zc ) ) ) ) . apply l . Defined . Opaque ispartbinopabmonoidfracrelint . (* ??? Coq 8.4-8.5 trunk hangs here on the following line: Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( aa aa' : A ) ( z z' : abmonoidfrac X A ) ( l : abmonoidfracrel X A is z z' ) , abmonoidfracrel X A is ( ( prabmonoidfrac X A ( pr1 aa ) aa' ) + z ) ( ( prabmonoidfrac X A ( pr1 aa ) aa' ) + z' ) . *) Lemma ispartlbinopabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( aa aa' : A ) ( z z' : abmonoidfrac X A ) ( l : abmonoidfracrel X A is z z' ) : abmonoidfracrel X A is ( ( prabmonoidfrac X A ( pr1 aa ) aa' ) + z ) ( ( prabmonoidfrac X A ( pr1 aa ) aa' ) + z' ) . Proof . intros X A L is aa aa' . set ( assoc := ( assocax X ) : isassoc ( @op X ) ) . unfold isassoc in assoc . set ( comm := commax X ) . unfold iscomm in comm . set ( rer := abmonoidrer X ) . assert ( int : forall z z' , isaprop ( abmonoidfracrel X A is z z' -> abmonoidfracrel X A is (prabmonoidfrac X A (pr1 aa) aa' + z) (prabmonoidfrac X A (pr1 aa) aa' + z') ) ) . intros z z' . apply impred . intro . apply ( pr2 ( abmonoidfracrel _ _ _ _ _ ) ) . apply ( setquotuniv2prop _ ( fun z z' => hProppair _ ( int z z' ) ) ) . intros xa1 xa2 . change ( abmonoidfracrelint X A L xa1 xa2 -> abmonoidfracrelint X A L ( @op ( abmonoiddirprod X A ) ( dirprodpair ( pr1 aa ) aa' ) xa1 ) ( @op ( abmonoiddirprod X A ) ( dirprodpair ( pr1 aa ) aa' ) xa2 ) ) . unfold abmonoidfracrelint . simpl . apply hinhfun . intro t2l . set ( a := pr1 aa ) . set ( a' := pr1 aa' ) . set ( c0a := pr1 t2l ) . set ( l := pr2 t2l ) . set ( c0 := pr1 c0a ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr1 ( pr2 xa1 ) ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr1 ( pr2 xa2 ) ) . split with c0a . change ( L ( a + x1 + ( a' + a2 ) + c0 ) ( a + x2 + ( a' + a1 ) + c0 ) ) . rewrite ( rer _ x1 a' _ ) . rewrite ( rer _ x2 a' _ ) . rewrite ( assoc _ ( x1 + a2 ) c0 ) . rewrite ( assoc _ ( x2 + a1 ) c0 ) . apply ( ( pr1 is ) _ _ _ ( pr2 ( @op A aa aa' ) ) ) . apply l . Defined . Opaque ispartlbinopabmonoidfracrel . Lemma ispartrbinopabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( aa aa' : A ) ( z z' : abmonoidfrac X A ) ( l : abmonoidfracrel X A is z z' ) : abmonoidfracrel X A is ( z + ( prabmonoidfrac X A ( pr1 aa ) aa' ) ) ( z' + ( prabmonoidfrac X A ( pr1 aa ) aa' ) ) . Proof . intros X A L is aa aa' . set ( assoc := ( assocax X ) : isassoc ( @op X ) ) . unfold isassoc in assoc . set ( comm := commax X ) . unfold iscomm in comm . set ( rer := abmonoidrer X ) . assert ( int : forall z z' : abmonoidfrac X A , isaprop ( abmonoidfracrel X A is z z' -> abmonoidfracrel X A is ( z + ( prabmonoidfrac X A (pr1 aa) aa') ) ( z' + prabmonoidfrac X A (pr1 aa) aa' ) ) ) . intros z z' . apply impred . intro . apply ( pr2 ( abmonoidfracrel _ _ _ _ _ ) ) . apply ( setquotuniv2prop _ ( fun z z' => hProppair _ ( int z z' ) ) ) . intros xa1 xa2 . change ( abmonoidfracrelint X A L xa1 xa2 -> abmonoidfracrelint X A L ( @op ( abmonoiddirprod X A ) xa1 ( dirprodpair ( pr1 aa ) aa' ) ) ( @op ( abmonoiddirprod X A ) xa2 ( dirprodpair ( pr1 aa ) aa' ) ) ) . unfold abmonoidfracrelint . simpl . apply hinhfun . intro t2l . set ( a := pr1 aa ) . set ( a' := pr1 aa' ) . set ( c0a := pr1 t2l ) . set ( l := pr2 t2l ) . set ( c0 := pr1 c0a ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr1 ( pr2 xa1 ) ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr1 ( pr2 xa2 ) ) . split with c0a . change ( L ( x1 + a + ( a2 + a' ) + c0 ) ( x2 + a + ( a1 + a' ) + c0 ) ) . rewrite ( rer _ a a2 _ ) . rewrite ( rer _ a a1 _ ) . rewrite ( assoc ( x1 + a2 ) _ c0 ) . rewrite ( assoc ( x2 + a1 ) _ c0 ) . rewrite ( comm _ c0 ) . destruct ( assoc ( x1 + a2 ) c0 ( a + a' ) ) . destruct ( assoc ( x2 + a1 ) c0 ( a + a' ) ) . apply ( ( pr2 is ) _ _ _ ( pr2 ( @op A aa aa' ) ) ) . apply l . Defined . Opaque ispartrbinopabmonoidfracrel . Lemma abmonoidfracrelimpl ( X : abmonoid ) ( A : @subabmonoids X ) { L L' : hrel X } ( is : ispartbinophrel A L ) ( is' : ispartbinophrel A L' ) ( impl : forall x x' , L x x' -> L' x x' ) ( x x' : abmonoidfrac X A ) ( ql : abmonoidfracrel X A is x x' ) : abmonoidfracrel X A is' x x' . Proof . intros . generalize ql . apply quotrelimpl . intros x0 x0' . unfold abmonoidfracrelint . simpl . apply hinhfun . intro t2 . split with ( pr1 t2 ) . apply ( impl _ _ ( pr2 t2 ) ) . Defined . Opaque abmonoidfracrelimpl . Lemma abmonoidfracrellogeq ( X : abmonoid ) ( A : @subabmonoids X ) { L L' : hrel X } ( is : ispartbinophrel A L ) ( is' : ispartbinophrel A L' ) ( lg : forall x x' , L x x' <-> L' x x' ) ( x x' : abmonoidfrac X A ) : ( abmonoidfracrel X A is x x' ) <-> ( abmonoidfracrel X A is' x x' ) . Proof . intros . apply quotrellogeq . intros x0 x0' . split . unfold abmonoidfracrelint . simpl . apply hinhfun . intro t2 . split with ( pr1 t2 ) . apply ( pr1 ( lg _ _ ) ( pr2 t2 ) ) . unfold abmonoidfracrelint . simpl . apply hinhfun . intro t2 . split with ( pr1 t2 ) . apply ( pr2 ( lg _ _ ) ( pr2 t2 ) ) . Defined . Opaque abmonoidfracrellogeq . Definition isdecabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartinvbinophrel A L ) ( isl : isdecrel L ) : isdecrel ( abmonoidfracrelint X A L ) . Proof . intros . intros xa1 xa2 . set ( x1 := pr1 xa1 ) . set ( a1 := pr1 ( pr2 xa1 ) ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr1 ( pr2 xa2 ) ) . assert ( int : coprod ( L ( x1 + a2 ) ( x2 + a1 ) ) ( neg ( L ( x1 + a2 ) ( x2 + a1 ) ) ) ) . apply ( isl _ _ ) . destruct int as [ l | nl ] . apply ii1 . unfold abmonoidfracrelint . apply hinhpr . split with ( unel A ) . rewrite ( runax X _ ) . rewrite ( runax X _ ) . apply l . apply ii2 . generalize nl . clear nl . apply negf . unfold abmonoidfracrelint . simpl . apply ( @hinhuniv _ ( hProppair _ ( pr2 ( L _ _ ) ) ) ) . intro t2l . destruct t2l as [ c0a l ] . simpl . apply ( ( pr2 is ) _ _ _ ( pr2 c0a ) l ) . Defined . Definition isdecabmonoidfracrel ( X : abmonoid ) ( A : @submonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isi : ispartinvbinophrel A L ) ( isl : isdecrel L ) : isdecrel ( abmonoidfracrel X A is ) . Proof . intros . apply isdecquotrel . apply isdecabmonoidfracrelint . apply isi . apply isl . Defined . (** **** Relations and the canonical homomorphism to [ abmonoidfrac ] *) Lemma iscomptoabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) : iscomprelrelfun L ( abmonoidfracrel X A is ) ( toabmonoidfrac X A ) . Proof . intros . unfold iscomprelrelfun . intros x x' l . change ( abmonoidfracrelint X A L ( dirprodpair x ( unel A ) ) ( dirprodpair x' ( unel A ) ) ) . simpl . apply ( hinhpr ) . split with ( unel A ) . apply ( ( pr2 is ) _ _ 0 ) . apply ( pr2 ( unel A ) ) . apply ( ( pr2 is ) _ _ 0 ) . apply ( pr2 ( unel A ) ) . apply l . Defined . Opaque iscomptoabmonoidfrac . Close Scope addmonoid_scope . (** *** Groups *) (** **** Basic definitions *) Definition gr := total2 ( fun X : setwithbinop => isgrop ( @op X ) ) . Definition grpair := tpair ( fun X : setwithbinop => isgrop ( @op X ) ) . Definition grconstr := grpair . Definition grtomonoid : gr -> monoid := fun X : _ => monoidpair ( pr1 X ) ( pr1 ( pr2 X ) ) . Coercion grtomonoid : gr >-> monoid . Definition grinv ( X : gr ) : X -> X := pr1 ( pr2 ( pr2 X ) ) . Definition grlinvax ( X : gr ) : islinv ( @op X ) ( unel X ) ( grinv X ) := pr1 ( pr2 ( pr2 ( pr2 X ) ) ) . Definition grrinvax ( X : gr ) : isrinv ( @op X ) ( unel X ) ( grinv X ) := pr2 ( pr2 ( pr2 ( pr2 X ) ) ) . Lemma monoidfuninvtoinv { X Y : gr } ( f : monoidfun X Y ) ( x : X ) : paths ( f ( grinv X x ) ) ( grinv Y ( f x ) ) . Proof . intros . apply ( invmaponpathsweq ( weqpair _ ( isweqrmultingr_is ( pr2 Y ) ( f x ) ) ) ) . simpl . change ( paths (op (pr1 f (grinv X x)) (pr1 f x)) (op (grinv Y (pr1 f x)) (pr1 f x)) ) . rewrite ( grlinvax Y ( pr1 f x) ) . destruct ( pr1 ( pr2 f ) (grinv X x) x ) . rewrite ( grlinvax X x ) . apply ( pr2 ( pr2 f ) ) . Defined . (** **** Computation lemmas for groups *) Definition weqlmultingr ( X : gr ) ( x0 : X ) := weqpair _ ( isweqlmultingr_is ( pr2 X ) x0 ) . Definition weqrmultingr ( X : gr ) ( x0 : X ) := weqpair _ ( isweqrmultingr_is ( pr2 X ) x0 ) . Lemma grlcan ( X : gr ) { a b : X } ( c : X ) ( e : paths ( op c a ) ( op c b ) ) : paths a b . Proof . intros . apply ( invmaponpathsweq ( weqlmultingr X c ) _ _ e ) . Defined . Lemma grrcan ( X : gr ) { a b : X } ( c : X ) ( e : paths ( op a c ) ( op b c ) ) : paths a b . Proof . intros . apply ( invmaponpathsweq ( weqrmultingr X c ) _ _ e ) . Defined . Lemma grinvunel ( X : gr ) : paths ( grinv X ( unel X ) ) ( unel X ) . Proof . intro . apply ( grrcan X ( unel X ) ) . rewrite ( grlinvax X ) . rewrite ( runax X ) . apply idpath . Defined . Lemma grinvinv ( X : gr ) ( a : X ) : paths ( grinv X ( grinv X a ) ) a . Proof . intros . apply ( grlcan X ( grinv X a ) ) . rewrite ( grlinvax X a ) . rewrite ( grrinvax X _ ) . apply idpath . Defined . Lemma grinvmaponpathsinv ( X : gr ) { a b : X } ( e : paths ( grinv X a ) ( grinv X b ) ) : paths a b . Proof . intros . assert ( e' := maponpaths ( fun x => grinv X x ) e ) . simpl in e' . rewrite ( grinvinv X _ ) in e' . rewrite ( grinvinv X _ ) in e' . apply e'. Defined . Lemma grinvandmonoidfun ( X Y : gr ) { f : X -> Y } ( is : ismonoidfun f ) ( x : X ) : paths ( f ( grinv X x ) ) ( grinv Y ( f x ) ) . Proof . intros . apply ( grrcan Y ( f x ) ) . rewrite ( pathsinv0 ( pr1 is _ _ ) ) . rewrite ( grlinvax X ) . rewrite ( grlinvax Y ) . apply ( pr2 is ) . Defined . (** **** Relations on groups *) Lemma isinvbinophrelgr ( X : gr ) { R : hrel X } ( is : isbinophrel R ) : isinvbinophrel R . Proof . intros . set ( is1 := pr1 is ) . set ( is2 := pr2 is ) . split . intros a b c r . set ( r' := is1 _ _ ( grinv X c ) r ) . clearbody r' . rewrite ( pathsinv0 ( assocax X _ _ a ) ) in r' . rewrite ( pathsinv0 ( assocax X _ _ b ) ) in r' . rewrite ( grlinvax X c ) in r' . rewrite ( lunax X a ) in r' . rewrite ( lunax X b ) in r' . apply r' . intros a b c r . set ( r' := is2 _ _ ( grinv X c ) r ) . clearbody r' . rewrite ( ( assocax X a _ _ ) ) in r' . rewrite ( ( assocax X b _ _ ) ) in r' . rewrite ( grrinvax X c ) in r' . rewrite ( runax X a ) in r' . rewrite ( runax X b ) in r' . apply r' . Defined . Opaque isinvbinophrelgr . Lemma isbinophrelgr ( X : gr ) { R : hrel X } ( is : isinvbinophrel R ) : isbinophrel R . Proof . intros . set ( is1 := pr1 is ) . set ( is2 := pr2 is ) . split . intros a b c r . rewrite ( pathsinv0 ( lunax X a ) ) in r . rewrite ( pathsinv0 ( lunax X b ) ) in r . rewrite ( pathsinv0 ( grlinvax X c ) ) in r . rewrite ( assocax X _ _ a ) in r . rewrite ( assocax X _ _ b ) in r . apply ( is1 _ _ ( grinv X c ) r ) . intros a b c r . rewrite ( pathsinv0 ( runax X a ) ) in r . rewrite ( pathsinv0 ( runax X b ) ) in r . rewrite ( pathsinv0 ( grrinvax X c ) ) in r . rewrite ( pathsinv0 ( assocax X a _ _ ) ) in r . rewrite ( pathsinv0 ( assocax X b _ _ ) ) in r . apply ( is2 _ _ ( grinv X c ) r ) . Defined . Opaque isbinophrelgr . Lemma grfromgtunel ( X : gr ) { R : hrel X } ( is : isbinophrel R ) { x : X } ( isg : R x ( unel X ) ) : R ( unel X ) ( grinv X x ) . Proof . intros . assert ( r := ( pr2 is ) _ _ ( grinv X x ) isg ) . rewrite ( grrinvax X x ) in r . rewrite ( lunax X _ ) in r . apply r . Defined . Lemma grtogtunel ( X : gr ) { R : hrel X } ( is : isbinophrel R ) { x : X } ( isg : R ( unel X ) ( grinv X x ) ) : R x ( unel X ) . Proof . intros . assert ( r := ( pr2 is ) _ _ x isg ) . rewrite ( grlinvax X x ) in r . rewrite ( lunax X _ ) in r . apply r . Defined . Lemma grfromltunel ( X : gr ) { R : hrel X } ( is : isbinophrel R ) { x : X } ( isg : R ( unel X ) x ) : R ( grinv X x ) ( unel X ) . Proof . intros . assert ( r := ( pr1 is ) _ _ ( grinv X x ) isg ) . rewrite ( grlinvax X x ) in r . rewrite ( runax X _ ) in r . apply r . Defined . Lemma grtoltunel ( X : gr ) { R : hrel X } ( is : isbinophrel R ) { x : X } ( isg : R ( grinv X x ) ( unel X ) ) : R ( unel X ) x . Proof . intros . assert ( r := ( pr1 is ) _ _ x isg ) . rewrite ( grrinvax X x ) in r . rewrite ( runax X _ ) in r . apply r . Defined . (** **** Subobjects *) Definition issubgr { X : gr } ( A : hsubtypes X ) := dirprod ( issubmonoid A ) ( forall x : X , A x -> A ( grinv X x ) ) . Lemma isapropissubgr { X : gr } ( A : hsubtypes X ) : isaprop ( issubgr A ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropissubmonoid . apply impred . intro x . apply impred . intro a . apply ( pr2 (A ( grinv X x)) ) . Defined . Definition subgrs { X : gr } := total2 ( fun A : hsubtypes X => issubgr A ) . Definition subgrpair { X : gr } := tpair ( fun A : hsubtypes X => issubgr A ) . Definition subgrconstr { X : gr } := @subgrpair X . Definition subgrstosubmonoids ( X : gr ) : @subgrs X -> @submonoids X := fun A : _ => submonoidpair ( pr1 A ) ( pr1 ( pr2 A ) ) . Coercion subgrstosubmonoids : subgrs >-> submonoids . Lemma isinvoncarrier { X : gr } ( A : @subgrs X ) : isinv ( @op A ) ( unel A ) ( fun a : A => carrierpair _ ( grinv X ( pr1 a ) ) ( pr2 ( pr2 A ) ( pr1 a ) ( pr2 a ) ) ) . Proof . intros . split . intro a . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply ( grlinvax X ( pr1 a ) ) . intro a . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply ( grrinvax X ( pr1 a ) ) . Defined . Definition isgrcarrier { X : gr } ( A : @subgrs X ) : isgrop ( @op A ) := tpair _ ( ismonoidcarrier A ) ( tpair _ ( fun a : A => carrierpair _ ( grinv X ( pr1 a ) ) ( pr2 ( pr2 A ) ( pr1 a ) ( pr2 a ) ) ) ( isinvoncarrier A ) ) . Definition carrierofasubgr { X : gr } ( A : @subgrs X ) : gr . Proof . intros . split with A . apply ( isgrcarrier A ) . Defined . Coercion carrierofasubgr : subgrs >-> gr . (** **** Quotient objects *) Lemma grquotinvcomp { X : gr } ( R : @binopeqrel X ) : iscomprelrelfun R R (grinv X) . Proof . intros . destruct R as [ R isb ] . set ( isc := iscompbinoptransrel _ ( eqreltrans _ ) isb ) . unfold iscomprelrelfun . intros x x' r . destruct R as [ R iseq ] . destruct iseq as [ ispo0 symm0 ] . destruct ispo0 as [ trans0 refl0 ] . unfold isbinophrel in isb . set ( r0 := isc _ _ _ _ ( isc _ _ _ _ ( refl0 ( grinv X x' ) ) r ) ( refl0 ( grinv X x ) ) ) . rewrite ( grlinvax X x' ) in r0 . rewrite ( assocax X ( grinv X x' ) x ( grinv X x ) ) in r0 . rewrite ( grrinvax X x ) in r0 . rewrite ( lunax X _ ) in r0 . rewrite ( runax X _ ) in r0 . apply ( symm0 _ _ r0 ) . Defined . Opaque grquotinvcomp . Definition invongrquot { X : gr } ( R : @binopeqrel X ) : setquot R -> setquot R := setquotfun R R ( grinv X ) ( grquotinvcomp R ) . Lemma isinvongrquot { X : gr } ( R : @binopeqrel X ) : isinv ( @op ( setwithbinopquot R ) ) ( setquotpr R ( unel X ) ) ( invongrquot R ) . Proof . intros . split . unfold islinv . apply ( setquotunivprop R ( fun x : setwithbinopquot R => eqset (@op ( setwithbinopquot R ) (invongrquot R x) x) (setquotpr R (unel X)) ) ) . intro x . apply ( @maponpaths _ _ ( setquotpr R ) ( @op X ( grinv X x ) x ) ( unel X ) ) . apply ( grlinvax X ) . unfold isrinv . apply ( setquotunivprop R ( fun x : setwithbinopquot R => eqset (@op ( setwithbinopquot R ) x (invongrquot R x) ) (setquotpr R (unel X)) ) ) . intro x . apply ( @maponpaths _ _ ( setquotpr R ) ( @op X x ( grinv X x ) ) ( unel X ) ) . apply ( grrinvax X ) . Defined . Opaque isinvongrquot . Definition isgrquot { X : gr } ( R : @binopeqrel X ) : isgrop ( @op ( setwithbinopquot R ) ) := tpair _ ( ismonoidquot R ) ( tpair _ ( invongrquot R ) ( isinvongrquot R ) ) . Definition grquot { X : gr } ( R : @binopeqrel X ) : gr . Proof . intros . split with ( setwithbinopquot R ) . apply isgrquot . Defined . (** **** Direct products *) Lemma isgrdirprod ( X Y : gr ) : isgrop ( @op ( setwithbinopdirprod X Y ) ) . Proof . intros . split with ( ismonoiddirprod X Y ) . split with ( fun xy : _ => dirprodpair ( grinv X ( pr1 xy ) ) ( grinv Y ( pr2 xy ) ) ) . split . intro xy . destruct xy as [ x y ] . unfold unel_is . simpl . apply pathsdirprod . apply ( grlinvax X x ) . apply ( grlinvax Y y ) . intro xy . destruct xy as [ x y ] . unfold unel_is . simpl . apply pathsdirprod . apply ( grrinvax X x ) . apply ( grrinvax Y y ) . Defined . Definition grdirprod ( X Y : gr ) : gr . Proof . intros . split with ( setwithbinopdirprod X Y ) . apply isgrdirprod . Defined . (** *** Abelian groups *) (** **** Basic definitions *) Definition abgr := total2 ( fun X : setwithbinop => isabgrop ( @op X ) ) . Definition abgrpair ( X : setwithbinop ) ( is : isabgrop ( @op X ) ) : abgr := tpair ( fun X : setwithbinop => isabgrop ( @op X ) ) X is . Definition abgrconstr ( X : abmonoid ) ( inv0 : X -> X ) ( is : isinv ( @op X ) ( unel X ) inv0 ) : abgr := abgrpair X ( dirprodpair ( isgroppair ( pr2 X ) ( tpair _ inv0 is ) ) ( commax X ) ) . Definition abgrtogr : abgr -> gr := fun X : _ => grpair ( pr1 X ) ( pr1 ( pr2 X ) ) . Coercion abgrtogr : abgr >-> gr . Definition abgrtoabmonoid : abgr -> abmonoid := fun X : _ => abmonoidpair ( pr1 X ) ( dirprodpair ( pr1 ( pr1 ( pr2 X ) ) ) ( pr2 ( pr2 X ) ) ) . Coercion abgrtoabmonoid : abgr >-> abmonoid . (** **** Subobjects *) Definition subabgrs { X : abgr } := @subgrs X . Identity Coercion id_subabgrs : subabgrs >-> subgrs . Lemma isabgrcarrier { X : abgr } ( A : @subgrs X ) : isabgrop ( @op A ) . Proof . intros . split with ( isgrcarrier A ) . apply ( pr2 ( @isabmonoidcarrier X A ) ) . Defined . Definition carrierofasubabgr { X : abgr } ( A : @subabgrs X ) : abgr . Proof . intros . split with A . apply isabgrcarrier . Defined . Coercion carrierofasubabgr : subabgrs >-> abgr . (** **** Quotient objects *) Lemma isabgrquot { X : abgr } ( R : @binopeqrel X ) : isabgrop ( @op ( setwithbinopquot R ) ) . Proof . intros . split with ( isgrquot R ) . apply ( pr2 ( @isabmonoidquot X R ) ) . Defined . Definition abgrquot { X : abgr } ( R : @binopeqrel X ) : abgr . Proof . intros . split with ( setwithbinopquot R ) . apply isabgrquot . Defined . (** **** Direct products *) Lemma isabgrdirprod ( X Y : abgr ) : isabgrop ( @op ( setwithbinopdirprod X Y ) ) . Proof . intros . split with ( isgrdirprod X Y ) . apply ( pr2 ( isabmonoiddirprod X Y ) ) . Defined . Definition abgrdirprod ( X Y : abgr ) : abgr . Proof . intros . split with ( setwithbinopdirprod X Y ) . apply isabgrdirprod . Defined . (** **** Abelian group of fractions of an abelian unitary monoid *) Open Scope addmonoid_scope . Definition hrelabgrfrac ( X : abmonoid ) : hrel ( dirprod X X ) := fun xa1 xa2 => hexists ( fun x0 : X => paths ( ( ( pr1 xa1 ) + ( pr2 xa2 ) ) + x0 ) ( ( ( pr1 xa2 ) + ( pr2 xa1 ) ) + x0 ) ) . Definition abgrfracphi ( X : abmonoid ) ( xa : dirprod X X ) : dirprod X ( totalsubtype X ) := dirprodpair ( pr1 xa ) ( carrierpair ( fun x : X => htrue ) ( pr2 xa ) tt ) . Definition hrelabgrfrac' ( X : abmonoid ) : hrel ( dirprod X X ) := fun xa1 xa2 => eqrelabmonoidfrac X ( totalsubmonoid X ) ( abgrfracphi X xa1 ) ( abgrfracphi X xa2 ) . Lemma logeqhrelsabgrfrac ( X : abmonoid ) : hrellogeq ( hrelabgrfrac' X ) ( hrelabgrfrac X ) . Proof . intros . split . simpl . apply hinhfun . intro t2 . set ( a0 := pr1 ( pr1 t2 ) ) . split with a0 . apply ( pr2 t2 ) . simpl . apply hinhfun . intro t2 . set ( x0 := pr1 t2 ) . split with ( tpair _ x0 tt ) . apply ( pr2 t2 ) . Defined . Lemma iseqrelabgrfrac ( X : abmonoid ) : iseqrel ( hrelabgrfrac X ) . Proof . intro . apply ( iseqrellogeqf ( logeqhrelsabgrfrac X ) ) . apply ( iseqrelconstr ) . intros xx' xx'' xx''' . intros r1 r2 . apply ( eqreltrans ( eqrelabmonoidfrac X ( totalsubmonoid X ) ) _ _ _ r1 r2 ) . intro xx. apply ( eqrelrefl ( eqrelabmonoidfrac X ( totalsubmonoid X ) ) _ ) . intros xx xx' . intro r . apply ( eqrelsymm ( eqrelabmonoidfrac X ( totalsubmonoid X ) ) _ _ r ) . Defined . Opaque iseqrelabgrfrac . Definition eqrelabgrfrac ( X : abmonoid ) : @eqrel ( abmonoiddirprod X X ) := eqrelpair _ ( iseqrelabgrfrac X ) . Lemma isbinophrelabgrfrac ( X : abmonoid ) : @isbinophrel ( abmonoiddirprod X X ) ( hrelabgrfrac X ) . Proof . intro . apply ( @isbinophrellogeqf ( abmonoiddirprod X X ) _ _ ( logeqhrelsabgrfrac X ) ) . split . intros a b c r . apply ( pr1 ( isbinophrelabmonoidfrac X ( totalsubmonoid X ) ) _ _ ( dirprodpair ( pr1 c ) ( carrierpair ( fun x : X => htrue ) ( pr2 c ) tt ) ) r ) . intros a b c r . apply ( pr2 ( isbinophrelabmonoidfrac X ( totalsubmonoid X ) ) _ _ ( dirprodpair ( pr1 c ) ( carrierpair ( fun x : X => htrue ) ( pr2 c ) tt ) ) r ) . Defined . Opaque isbinophrelabgrfrac . Definition binopeqrelabgrfrac ( X : abmonoid ) : @binopeqrel ( abmonoiddirprod X X ) := binopeqrelpair ( eqrelabgrfrac X ) ( isbinophrelabgrfrac X ) . Definition abgrfraccarrier ( X : abmonoid ) : abmonoid := @abmonoidquot ( abmonoiddirprod X X ) ( binopeqrelabgrfrac X ) . Definition abgrfracinvint ( X : abmonoid ) : dirprod X X -> dirprod X X := fun xs : _ => dirprodpair ( pr2 xs ) ( pr1 xs ) . Lemma abgrfracinvcomp ( X : abmonoid ) : iscomprelrelfun ( hrelabgrfrac X ) ( eqrelabgrfrac X ) ( abgrfracinvint X ) . Proof . intros . unfold iscomprelrelfun . unfold eqrelabgrfrac . unfold hrelabgrfrac . unfold eqrelabmonoidfrac . unfold hrelabmonoidfrac . simpl . intros xs xs' . apply ( hinhfun ) . intro tt0 . set ( x := pr1 xs ) . set ( s := pr2 xs ) . set ( x' := pr1 xs' ) . set ( s' := pr2 xs' ) . split with ( pr1 tt0 ) . destruct tt0 as [ a eq ] . change ( paths ( s + x' + a ) ( s' + x + a ) ) . apply pathsinv0 . simpl . set ( e := commax X s' x ) . simpl in e . rewrite e . clear e . set ( e := commax X s x' ) . simpl in e . rewrite e . clear e. apply eq . Defined . Opaque abgrfracinvcomp . Definition abgrfracinv ( X : abmonoid ) : abgrfraccarrier X -> abgrfraccarrier X := setquotfun ( hrelabgrfrac X ) ( eqrelabgrfrac X ) ( abgrfracinvint X ) ( abgrfracinvcomp X ) . Lemma abgrfracisinv ( X : abmonoid ) : isinv ( @op ( abgrfraccarrier X ) ) ( unel ( abgrfraccarrier X ) ) ( abgrfracinv X ) . Proof . intros . set ( R := eqrelabgrfrac X ) . assert ( isl : islinv ( @op ( abgrfraccarrier X ) ) ( unel ( abgrfraccarrier X ) ) ( abgrfracinv X ) ) . unfold islinv . apply ( setquotunivprop R ( fun x : abgrfraccarrier X => eqset (abgrfracinv X x + x) (unel (abgrfraccarrier X)) ) ) . intro xs . set ( x := pr1 xs ) . set ( s := pr2 xs ) . apply ( iscompsetquotpr R ( @op ( abmonoiddirprod X X ) ( abgrfracinvint X xs ) xs ) ( unel _ ) ) . simpl . apply hinhpr . split with ( unel X ) . change ( paths ( s + x + ( unel X ) + ( unel X ) ) ( ( unel X ) + ( x + s ) + ( unel X ) ) ) . destruct ( commax X x s ) . destruct ( commax X ( unel X ) ( x + s ) ) . apply idpath . apply ( dirprodpair isl ( weqlinvrinv ( @op ( abgrfraccarrier X ) ) ( commax ( abgrfraccarrier X ) ) ( unel ( abgrfraccarrier X ) ) ( abgrfracinv X ) isl ) ) . Defined . Opaque abgrfracisinv . Definition abgrfrac ( X : abmonoid ) : abgr := abgrconstr ( abgrfraccarrier X ) ( abgrfracinv X ) ( abgrfracisinv X ) . Definition prabgrfrac ( X : abmonoid ) : X -> X -> abgrfrac X := fun x x' : X => setquotpr ( eqrelabgrfrac X ) ( dirprodpair x x' ) . (** **** Abelian group of fractions and abelian monoid of fractions *) Definition weqabgrfracint ( X : abmonoid ) : weq ( dirprod X X ) ( dirprod X ( totalsubtype X ) ) := weqdirprodf ( idweq X ) ( invweq ( weqtotalsubtype X ) ) . Definition weqabgrfrac ( X : abmonoid ) : weq ( abgrfrac X ) ( abmonoidfrac X ( totalsubmonoid X ) ) . Proof . intros . apply ( weqsetquotweq ( eqrelabgrfrac X ) ( eqrelabmonoidfrac X ( totalsubmonoid X ) ) ( weqabgrfracint X ) ) . simpl . intros x x' . destruct x as [ x1 x2 ] . destruct x' as [ x1' x2' ] . simpl in * . apply hinhfun . intro tt0 . destruct tt0 as [ xx0 is0 ] . split with ( carrierpair ( fun x : X => htrue ) xx0 tt ) . apply is0 . simpl . intros x x' . destruct x as [ x1 x2 ] . destruct x' as [ x1' x2' ] . simpl in * . apply hinhfun . intro tt0 . destruct tt0 as [ xx0 is0 ] . split with ( pr1 xx0 ) . apply is0 . Defined . (** **** Canonical homomorphism to the abelian group of fractions *) Definition toabgrfrac ( X : abmonoid ) ( x : X ) : abgrfrac X := setquotpr _ ( dirprodpair x ( unel X ) ) . Lemma isbinopfuntoabgrfrac ( X : abmonoid ) : isbinopfun ( toabgrfrac X ) . Proof . intros . unfold isbinopfun . intros x1 x2 . change ( paths ( setquotpr _ ( dirprodpair ( x1 + x2 ) ( unel X ) ) ) ( setquotpr ( eqrelabgrfrac X ) ( dirprodpair ( x1 + x2 ) ( ( unel X ) + ( unel X ) ) ) ) ) . apply ( maponpaths ( setquotpr _ ) ) . apply ( @pathsdirprod X X ) . apply idpath . apply ( pathsinv0 ( lunax X 0 ) ) . Defined . Lemma isunitalfuntoabgrfrac ( X : abmonoid ) : paths ( toabgrfrac X ( unel X ) ) ( unel ( abgrfrac X ) ) . Proof . intros . apply idpath . Defined . Definition ismonoidfuntoabgrfrac ( X : abmonoid ) : ismonoidfun ( toabgrfrac X ) := dirprodpair ( isbinopfuntoabgrfrac X ) ( isunitalfuntoabgrfrac X ) . (** **** Abelian group of fractions in the case when all elements are cancelable *) Lemma isinclprabgrfrac ( X : abmonoid ) ( iscanc : forall x : X , isrcancelable ( @op X ) x ) : forall x' : X , isincl ( fun x => prabgrfrac X x x' ) . Proof . intros . set ( int := isinclprabmonoidfrac X ( totalsubmonoid X ) ( fun a : totalsubmonoid X => iscanc ( pr1 a ) ) ( carrierpair ( fun x : X => htrue ) x' tt ) ) . set ( int1 := isinclcomp ( inclpair _ int ) ( invweq ( weqabgrfrac X ) ) ) . apply int1 . Defined . Definition isincltoabgrfrac ( X : abmonoid ) ( iscanc : forall x : X , isrcancelable ( @op X ) x ) : isincl ( toabgrfrac X ) := isinclprabgrfrac X iscanc ( unel X ) . Lemma isdeceqabgrfrac ( X : abmonoid ) ( iscanc : forall x : X , isrcancelable ( @op X ) x ) ( is : isdeceq X ) : isdeceq ( abgrfrac X ) . Proof . intros . apply ( isdeceqweqf ( invweq ( weqabgrfrac X ) ) ) . apply ( isdeceqabmonoidfrac X ( totalsubmonoid X ) ( fun a : totalsubmonoid X => iscanc ( pr1 a ) ) is ) . Defined . (** **** Relations on the abelian group of fractions *) Definition abgrfracrelint ( X : abmonoid ) ( L : hrel X ) : hrel ( setwithbinopdirprod X X ) := fun xa yb => hexists ( fun c0 : X => L ( ( ( pr1 xa ) + ( pr2 yb ) ) + c0 ) ( ( ( pr1 yb ) + ( pr2 xa ) ) + c0 ) ) . Definition abgrfracrelint' ( X : abmonoid ) ( L : hrel X ) : hrel ( setwithbinopdirprod X X ) := fun xa1 xa2 => abmonoidfracrelint _ ( totalsubmonoid X ) L ( abgrfracphi X xa1 ) ( abgrfracphi X xa2 ) . Lemma logeqabgrfracrelints ( X : abmonoid ) ( L : hrel X ) : hrellogeq ( abgrfracrelint' X L ) ( abgrfracrelint X L ) . Proof . intros . split . unfold abgrfracrelint . unfold abgrfracrelint' . simpl . apply hinhfun . intro t2 . set ( a0 := pr1 ( pr1 t2 ) ) . split with a0 . apply ( pr2 t2 ) . simpl . apply hinhfun . intro t2 . set ( x0 := pr1 t2 ) . split with ( tpair _ x0 tt ) . apply ( pr2 t2 ) . Defined . Lemma iscomprelabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : iscomprelrel ( eqrelabgrfrac X ) ( abgrfracrelint X L ) . Proof . intros . apply ( iscomprelrellogeqf1 _ ( logeqhrelsabgrfrac X ) ) . apply ( iscomprelrellogeqf2 _ ( logeqabgrfracrelints X L ) ) . intros x x' x0 x0' r r0 . apply ( iscomprelabmonoidfracrelint _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) _ _ _ _ r r0 ) . Defined . Opaque iscomprelabgrfracrelint . Definition abgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) := quotrel ( iscomprelabgrfracrelint X is ) . Definition abgrfracrel' ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : hrel ( abgrfrac X ) := fun x x' => abmonoidfracrel X ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) ( weqabgrfrac X x ) ( weqabgrfrac X x' ) . Definition logeqabgrfracrels ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : hrellogeq ( abgrfracrel' X is ) ( abgrfracrel X is ) . Proof . intros X L is x1 x2 . split . assert ( int : forall x x' , isaprop ( abgrfracrel' X is x x' -> abgrfracrel X is x x' ) ) . intros x x' . apply impred . intro . apply ( pr2 _ ) . generalize x1 x2 . clear x1 x2 . apply ( setquotuniv2prop _ ( fun x x' => hProppair _ ( int x x' ) ) ) . intros x x' . change ( ( abgrfracrelint' X L x x' ) -> ( abgrfracrelint _ L x x' ) ) . apply ( pr1 ( logeqabgrfracrelints X L x x' ) ) . assert ( int : forall x x' , isaprop ( abgrfracrel X is x x' -> abgrfracrel' X is x x' ) ) . intros x x' . apply impred . intro . apply ( pr2 _ ) . generalize x1 x2 . clear x1 x2 . apply ( setquotuniv2prop _ ( fun x x' => hProppair _ ( int x x' ) ) ) . intros x x' . change ( ( abgrfracrelint X L x x' ) -> ( abgrfracrelint' _ L x x' ) ) . apply ( pr2 ( logeqabgrfracrelints X L x x' ) ) . Defined . Lemma istransabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : istrans L ) : istrans ( abgrfracrelint X L ) . Proof . intros . apply ( istranslogeqf ( logeqabgrfracrelints X L ) ) . intros a b c rab rbc . apply ( istransabmonoidfracrelint _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl _ _ _ rab rbc ) . Defined . Opaque istransabgrfracrelint . Lemma istransabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : istrans L ) : istrans ( abgrfracrel X is ) . Proof . intros . apply istransquotrel . apply istransabgrfracrelint . apply is . apply isl . Defined . Lemma issymmabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : issymm L ) : issymm ( abgrfracrelint X L ) . Proof . intros . apply ( issymmlogeqf ( logeqabgrfracrelints X L ) ) . intros a b rab . apply ( issymmabmonoidfracrelint _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl _ _ rab ) . Defined . Opaque issymmabgrfracrelint . Lemma issymmabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : issymm L ) : issymm ( abgrfracrel X is ) . Proof . intros . apply issymmquotrel . apply issymmabgrfracrelint . apply is . apply isl . Defined . Lemma isreflabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isrefl L ) : isrefl ( abgrfracrelint X L ) . Proof . intros . intro xa . unfold abgrfracrelint . simpl . apply hinhpr . split with ( unel X ) . apply ( isl _ ) . Defined . Lemma isreflabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isrefl L ) : isrefl ( abgrfracrel X is ) . Proof . intros . apply isreflquotrel . apply isreflabgrfracrelint . apply is . apply isl . Defined . Lemma ispoabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : ispo L ) : ispo ( abgrfracrelint X L ) . Proof . intros . split with ( istransabgrfracrelint X is ( pr1 isl ) ) . apply ( isreflabgrfracrelint X is ( pr2 isl ) ) . Defined . Lemma ispoabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : ispo L ) : ispo ( abgrfracrel X is ) . Proof . intros . apply ispoquotrel . apply ispoabgrfracrelint . apply is . apply isl . Defined . Lemma iseqrelabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : iseqrel L ) : iseqrel ( abgrfracrelint X L ) . Proof . intros . split with ( ispoabgrfracrelint X is ( pr1 isl ) ) . apply ( issymmabgrfracrelint X is ( pr2 isl ) ) . Defined . Lemma iseqrelabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : iseqrel L ) : iseqrel ( abgrfracrel X is ) . Proof . intros . apply iseqrelquotrel . apply iseqrelabgrfracrelint . apply is . apply isl . Defined . Lemma isantisymmnegabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isantisymmneg L ) : isantisymmneg ( abgrfracrel X is ) . Proof . intros . apply ( isantisymmneglogeqf ( logeqabgrfracrels X is ) ) . intros a b rab rba . set ( int := isantisymmnegabmonoidfracrel _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl ( weqabgrfrac X a ) ( weqabgrfrac X b ) rab rba ) . apply ( invmaponpathsweq _ _ _ int ) . Defined . Lemma isantisymmabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isantisymm L ) : isantisymm ( abgrfracrel X is ) . Proof . intros . apply ( isantisymmlogeqf ( logeqabgrfracrels X is ) ) . intros a b rab rba . set ( int := isantisymmabmonoidfracrel _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl ( weqabgrfrac X a ) ( weqabgrfrac X b ) rab rba ) . apply ( invmaponpathsweq _ _ _ int ) . Defined . Opaque isantisymmabgrfracrel . Lemma isirreflabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isirrefl L ) : isirrefl ( abgrfracrel X is ) . Proof . intros . apply ( isirrefllogeqf ( logeqabgrfracrels X is ) ) . intros a raa . apply ( isirreflabmonoidfracrel _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl ( weqabgrfrac X a ) raa ) . Defined . Opaque isirreflabgrfracrel . Lemma isasymmabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isasymm L ) : isasymm ( abgrfracrel X is ) . Proof . intros . apply ( isasymmlogeqf ( logeqabgrfracrels X is ) ) . intros a b rab rba . apply ( isasymmabmonoidfracrel _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl ( weqabgrfrac X a ) ( weqabgrfrac X b ) rab rba ) . Defined . Opaque isasymmabgrfracrel . Lemma iscoasymmabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : iscoasymm L ) : iscoasymm ( abgrfracrel X is ) . Proof . intros . apply ( iscoasymmlogeqf ( logeqabgrfracrels X is ) ) . intros a b rab . apply ( iscoasymmabmonoidfracrel _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl ( weqabgrfrac X a ) ( weqabgrfrac X b ) rab ) . Defined . Opaque iscoasymmabgrfracrel . Lemma istotalabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : istotal L ) : istotal ( abgrfracrel X is ) . Proof . intros . apply ( istotallogeqf ( logeqabgrfracrels X is ) ) . intros a b . apply ( istotalabmonoidfracrel _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl ( weqabgrfrac X a ) ( weqabgrfrac X b ) ) . Defined . Opaque istotalabgrfracrel . Lemma iscotransabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : iscotrans L ) : iscotrans ( abgrfracrel X is ) . Proof . intros . apply ( iscotranslogeqf ( logeqabgrfracrels X is ) ) . intros a b c . apply ( iscotransabmonoidfracrel _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl ( weqabgrfrac X a ) ( weqabgrfrac X b ) ( weqabgrfrac X c ) ) . Defined . Opaque iscotransabgrfracrel . Lemma abgrfracrelimpl ( X : abmonoid ) { L L' : hrel X } ( is : isbinophrel L ) ( is' : isbinophrel L' ) ( impl : forall x x' , L x x' -> L' x x' ) ( x x' : abgrfrac X ) ( ql : abgrfracrel X is x x' ) : abgrfracrel X is' x x' . Proof . intros . generalize ql . apply quotrelimpl . intros x0 x0' . simpl . apply hinhfun . intro t2 . split with ( pr1 t2 ) . apply ( impl _ _ ( pr2 t2 ) ) . Defined . Opaque abgrfracrelimpl . Lemma abgrfracrellogeq ( X : abmonoid ) { L L' : hrel X } ( is : isbinophrel L ) ( is' : isbinophrel L' ) ( lg : forall x x' , L x x' <-> L' x x' ) ( x x' : abgrfrac X ) : ( abgrfracrel X is x x' ) <-> ( abgrfracrel X is' x x' ) . Proof . intros . apply quotrellogeq . intros x0 x0' . split . simpl . apply hinhfun . intro t2 . split with ( pr1 t2 ) . apply ( pr1 ( lg _ _ ) ( pr2 t2 ) ) . simpl . apply hinhfun . intro t2 . split with ( pr1 t2 ) . apply ( pr2 ( lg _ _ ) ( pr2 t2 ) ) . Defined . Opaque abgrfracrellogeq . Lemma isbinopabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : @isbinophrel ( setwithbinopdirprod X X ) ( abgrfracrelint X L ) . Proof . intros . apply ( isbinophrellogeqf ( logeqabgrfracrelints X L ) ) . split . intros a b c lab . apply ( pr1 ( ispartbinopabmonoidfracrelint _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) ) ( abgrfracphi X a ) ( abgrfracphi X b ) ( abgrfracphi X c ) tt lab ) . intros a b c lab . apply ( pr2 ( ispartbinopabmonoidfracrelint _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) ) ( abgrfracphi X a ) ( abgrfracphi X b ) ( abgrfracphi X c ) tt lab ) . Defined . Opaque isbinopabgrfracrelint . Lemma isbinopabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : @isbinophrel ( abgrfrac X ) ( abgrfracrel X is ) . Proof . intros . apply ( isbinopquotrel ( binopeqrelabgrfrac X ) ( iscomprelabgrfracrelint X is ) ) . apply ( isbinopabgrfracrelint X is ) . Defined . Definition isdecabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isinvbinophrel L ) ( isl : isdecrel L ) : isdecrel ( abgrfracrelint X L ) . Proof . intros . intros xa1 xa2 . set ( x1 := pr1 xa1 ) . set ( a1 := pr2 xa1 ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr2 xa2 ) . assert ( int : coprod ( L ( x1 + a2 ) ( x2 + a1 ) ) ( neg ( L ( x1 + a2 ) ( x2 + a1 ) ) ) ) . apply ( isl _ _ ) . destruct int as [ l | nl ] . apply ii1 . unfold abgrfracrelint . apply hinhpr . split with ( unel X ) . rewrite ( runax X _ ) . rewrite ( runax X _ ) . apply l . apply ii2 . generalize nl . clear nl . apply negf . unfold abgrfracrelint . simpl . apply ( @hinhuniv _ ( hProppair _ ( pr2 ( L _ _ ) ) ) ) . intro t2l . destruct t2l as [ c0a l ] . simpl . apply ( ( pr2 is ) _ _ c0a l ) . Defined . Definition isdecabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isi : isinvbinophrel L ) ( isl : isdecrel L ) : isdecrel ( abgrfracrel X is ) . Proof . intros . apply isdecquotrel . apply isdecabgrfracrelint . apply isi . apply isl . Defined . (** **** Relations and the canonical homomorphism to [ abgrfrac ] *) Lemma iscomptoabgrfrac ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : iscomprelrelfun L ( abgrfracrel X is ) ( toabgrfrac X ) . Proof . intros . unfold iscomprelrelfun . intros x x' l . change ( abgrfracrelint X L ( dirprodpair x ( unel X ) ) ( dirprodpair x' ( unel X ) ) ) . simpl . apply ( hinhpr ) . split with ( unel X ) . apply ( ( pr2 is ) _ _ 0 ) . apply ( ( pr2 is ) _ _ 0 ) . apply l . Defined . Opaque iscomptoabgrfrac . Close Scope addmonoid_scope . (* End of the file algebra1b.v *) Voevodsky-Coq/hlevel2/._algebra1c.v000777 000765 000024 00000000256 12346040720 017775 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/algebra1c.v000777 000765 000024 00000266776 12346040720 017605 0ustar00nicolastaff000000 000000 (** * Algebra I. Part C. Rigs and rings. 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 ".." as Foundations. Require Export Foundations.hlevel2.algebra1b . (** To upstream files *) (** ** Standard Algebraic Structures (cont.) *) (** *** Rigs - semirings with 1 , 0 and x*0 = 0*x=0 *) (** **** General definitions *) Definition rig := total2 ( fun X : setwith2binop => isrigops ( @op1 X ) ( @op2 X ) ) . Definition rigpair { X : setwith2binop } ( is : isrigops ( @op1 X ) ( @op2 X ) ) : rig := tpair ( fun X : setwith2binop => isrigops ( @op1 X ) ( @op2 X ) ) X is . Definition pr1rig : rig -> setwith2binop := @pr1 _ ( fun X : setwith2binop => isrigops ( @op1 X ) ( @op2 X ) ) . Coercion pr1rig : rig >-> setwith2binop . Definition rigaxs ( X : rig ) : isrigops ( @op1 X ) ( @op2 X ) := pr2 X . Definition rigop1axs ( X : rig ) : isabmonoidop ( @op1 X ) := rigop1axs_is ( pr2 X ) . Definition rigassoc1 ( X : rig ) : isassoc ( @op1 X ) := assocax_is ( rigop1axs X ) . Definition rigunel1 { X : rig } : X := unel_is ( rigop1axs X ) . Definition riglunax1 ( X : rig ) : islunit op1 ( @rigunel1 X ) := lunax_is ( rigop1axs X ) . Definition rigrunax1 ( X : rig ) : isrunit op1 ( @rigunel1 X ) := runax_is ( rigop1axs X ) . Definition rigmult0x ( X : rig ) : forall x : X , paths ( op2 ( @rigunel1 X ) x ) ( @rigunel1 X ) := rigmult0x_is ( pr2 X ) . Definition rigmultx0 ( X : rig ) : forall x : X , paths ( op2 x ( @rigunel1 X ) ) ( @rigunel1 X ) := rigmultx0_is ( pr2 X ) . Definition rigcomm1 ( X : rig ) : iscomm ( @op1 X ) := commax_is ( rigop1axs X ) . Definition rigop2axs ( X : rig ) : ismonoidop ( @op2 X ) := rigop2axs_is ( pr2 X ) . Definition rigassoc2 ( X : rig ) : isassoc ( @op2 X ) := assocax_is ( rigop2axs X ) . Definition rigunel2 { X : rig } : X := unel_is ( rigop2axs X ) . Definition riglunax2 ( X : rig ) : islunit op2 ( @rigunel2 X ) := lunax_is ( rigop2axs X ) . Definition rigrunax2 ( X : rig ) : isrunit op2 ( @rigunel2 X ) := runax_is ( rigop2axs X ) . Definition rigdistraxs ( X : rig ) : isdistr ( @op1 X ) ( @op2 X ) := pr2 ( pr2 X ) . Definition rigldistr ( X : rig ) : isldistr ( @op1 X ) ( @op2 X ) := pr1 ( pr2 ( pr2 X ) ) . Definition rigrdistr ( X : rig ) : isrdistr ( @op1 X ) ( @op2 X ) := pr2 ( pr2 ( pr2 X ) ) . Definition rigconstr { X : hSet } ( opp1 opp2 : binop X ) ( ax11 : ismonoidop opp1 ) ( ax12 : iscomm opp1 ) ( ax2 : ismonoidop opp2 ) ( m0x : forall x : X , paths ( opp2 ( unel_is ax11 ) x ) ( unel_is ax11 ) ) ( mx0 : forall x : X , paths ( opp2 x ( unel_is ax11 ) ) ( unel_is ax11 ) ) ( dax : isdistr opp1 opp2 ) : rig . Proof. intros. split with ( setwith2binoppair X ( dirprodpair opp1 opp2 ) ) . split . split with ( dirprodpair ( dirprodpair ax11 ax12 ) ax2 ) . apply ( dirprodpair m0x mx0 ) . apply dax . Defined . Definition rigaddabmonoid ( X : rig ) : abmonoid := abmonoidpair ( setwithbinoppair X op1 ) ( rigop1axs X ) . Definition rigmultmonoid ( X : rig ) : monoid := monoidpair ( setwithbinoppair X op2 ) ( rigop2axs X ) . Notation "x + y" := ( op1 x y ) : rig_scope . Notation "x * y" := ( op2 x y ) : rig_scope . Notation "0" := ( rigunel1 ) : rig_scope . Notation "1" := ( rigunel2 ) : rig_scope . Delimit Scope rig_scope with rig . (** **** Homomorphisms of rigs (rig functions) *) Definition isrigfun { X Y : rig } ( f : X -> Y ) := dirprod ( @ismonoidfun ( rigaddabmonoid X ) ( rigaddabmonoid Y ) f ) ( @ismonoidfun ( rigmultmonoid X ) ( rigmultmonoid Y ) f ) . Definition rigfun ( X Y : rig ) := total2 ( fun f : X -> Y => isrigfun f ) . Definition rigfunconstr { X Y : rig } { f : X -> Y } ( is : isrigfun f ) : rigfun X Y := tpair _ f is . Definition pr1rigfun ( X Y : rig ) : rigfun X Y -> ( X -> Y ) := @pr1 _ _ . Coercion pr1rigfun : rigfun >-> Funclass. Definition rigaddfun { X Y : rig } ( f : rigfun X Y ) : monoidfun ( rigaddabmonoid X ) ( rigaddabmonoid Y ) := monoidfunconstr ( pr1 ( pr2 f ) ) . Definition rigmultfun { X Y : rig } ( f : rigfun X Y ) : monoidfun ( rigmultmonoid X ) ( rigmultmonoid Y ) := monoidfunconstr ( pr2 ( pr2 f ) ) . Definition rigiso ( X Y : rig ) := total2 ( fun f : weq X Y => isrigfun f ) . Definition rigisopair { X Y : rig } ( f : weq X Y ) ( is : isrigfun f ) : rigiso X Y := tpair _ f is . Definition pr1rigiso ( X Y : rig ) : rigiso X Y -> weq X Y := @pr1 _ _ . Coercion pr1rigiso : rigiso >-> weq . Definition rigaddiso { X Y : rig } ( f : rigiso X Y ) : monoidiso ( rigaddabmonoid X ) ( rigaddabmonoid Y ) := @monoidisopair ( rigaddabmonoid X ) ( rigaddabmonoid Y ) ( pr1 f ) ( pr1 ( pr2 f ) ) . Definition rigmultiso { X Y : rig } ( f : rigiso X Y ) : monoidiso ( rigmultmonoid X ) ( rigmultmonoid Y ) := @monoidisopair ( rigmultmonoid X ) ( rigmultmonoid Y ) ( pr1 f ) ( pr2 ( pr2 f ) ) . Lemma isrigfuninvmap { X Y : rig } ( f : rigiso X Y ) : isrigfun ( invmap f ) . Proof . intros . split . apply ( ismonoidfuninvmap ( rigaddiso f ) ) . apply ( ismonoidfuninvmap ( rigmultiso f ) ) . Defined . (** **** Relations similar to "greater" or "greater or equal" on rigs *) Definition isrigmultgt ( X : rig ) ( R : hrel X ) := forall a b c d : X , R a b -> R c d -> R ( op1 ( op2 a c ) ( op2 b d ) ) ( op1 ( op2 a d ) ( op2 b c ) ) . Definition isinvrigmultgt ( X : rig ) ( R : hrel X ) := dirprod ( forall a b c d : X , R ( op1 ( op2 a c ) ( op2 b d ) ) ( op1 ( op2 a d ) ( op2 b c ) ) -> R a b -> R c d ) ( forall a b c d : X , R ( op1 ( op2 a c ) ( op2 b d ) ) ( op1 ( op2 a d ) ( op2 b c ) ) -> R c d -> R a b ) . (** **** Subobjects *) Definition issubrig { X : rig } ( A : hsubtypes X ) := dirprod ( @issubmonoid ( rigaddabmonoid X ) A ) ( @issubmonoid ( rigmultmonoid X ) A ) . Lemma isapropissubrig { X : rig } ( A : hsubtypes X ) : isaprop ( issubrig A ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropissubmonoid . apply isapropissubmonoid . Defined . Definition subrigs ( X : rig ) := total2 ( fun A : hsubtypes X => issubrig A ) . Definition subrigpair { X : rig } := tpair ( fun A : hsubtypes X => issubrig A ) . Definition pr1subrig ( X : rig ) : @subrigs X -> hsubtypes X := @pr1 _ (fun A : hsubtypes X => issubrig A ) . Definition subrigtosubsetswith2binop ( X : rig ) : subrigs X -> @subsetswith2binop X := fun A : _ => subsetswith2binoppair ( pr1 A ) ( dirprodpair ( pr1 ( pr1 ( pr2 A ) ) ) ( pr1 ( pr2 ( pr2 A ) ) ) ) . Coercion subrigtosubsetswith2binop : subrigs >-> subsetswith2binop . Definition rigaddsubmonoid { X : rig } : subrigs X -> @subabmonoids ( rigaddabmonoid X ) := fun A : _ => @submonoidpair ( rigaddabmonoid X ) ( pr1 A ) ( pr1 ( pr2 A ) ) . Definition rigmultsubmonoid { X : rig } : subrigs X -> @submonoids ( rigmultmonoid X ) := fun A : _ => @submonoidpair ( rigmultmonoid X ) ( pr1 A ) ( pr2 ( pr2 A ) ) . Lemma isrigcarrier { X : rig } ( A : subrigs X ) : isrigops ( @op1 A ) ( @op2 A ) . Proof . intros . split . split with ( dirprodpair ( isabmonoidcarrier ( rigaddsubmonoid A ) ) ( ismonoidcarrier ( rigmultsubmonoid A ) ) ) . split . intro a . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply rigmult0x . intro a . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply rigmultx0 . split . intros a b c . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply rigldistr . intros a b c . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply rigrdistr . Defined . Definition carrierofasubrig ( X : rig ) ( A : subrigs X ) : rig . Proof . intros . split with A . apply isrigcarrier . Defined . Coercion carrierofasubrig : subrigs >-> rig . (** **** Quotient objects *) Definition rigeqrel { X : rig } := @twobinopeqrel X . Identity Coercion id_rigeqrel : rigeqrel >-> twobinopeqrel . Definition addabmonoideqrel { X : rig } ( R : @rigeqrel X ) : @binopeqrel ( rigaddabmonoid X ) := @binopeqrelpair ( rigaddabmonoid X ) ( pr1 R ) ( pr1 ( pr2 R ) ) . Definition multmonoideqrel { X : rig } ( R : @rigeqrel X ) : @binopeqrel ( rigmultmonoid X ) := @binopeqrelpair ( rigmultmonoid X ) ( pr1 R ) ( pr2 ( pr2 R ) ) . Lemma isrigquot { X : rig } ( R : @rigeqrel X ) : isrigops ( @op1 ( setwith2binopquot R ) ) ( @op2 ( setwith2binopquot R ) ) . Proof . intros . split . split with ( dirprodpair ( isabmonoidquot ( addabmonoideqrel R ) ) ( ismonoidquot ( multmonoideqrel R ) ) ) . set ( opp1 := @op1 ( setwith2binopquot R ) ) . set ( opp2 := @op2 ( setwith2binopquot R ) ) . set ( zr := setquotpr R ( @rigunel1 X ) ) . split . apply ( setquotunivprop R ( fun x => hProppair _ ( setproperty ( setwith2binopquot R ) ( opp2 zr x ) zr ) ) ) . intro x . apply ( maponpaths ( setquotpr R ) ( rigmult0x X x ) ) . apply ( setquotunivprop R ( fun x => hProppair _ ( setproperty ( setwith2binopquot R ) ( opp2 x zr ) zr ) ) ) . intro x . apply ( maponpaths ( setquotpr R ) ( rigmultx0 X x ) ) . set ( opp1 := @op1 ( setwith2binopquot R ) ) . set ( opp2 := @op2 ( setwith2binopquot R ) ) . split . unfold isldistr . apply ( setquotuniv3prop R ( fun x x' x'' => hProppair _ ( setproperty ( setwith2binopquot R ) ( opp2 x'' ( opp1 x x' ) ) ( opp1 ( opp2 x'' x ) ( opp2 x'' x' ) ) ) ) ) . intros x x' x'' . apply ( maponpaths ( setquotpr R ) ( rigldistr X x x' x'' ) ) . unfold isrdistr . apply ( setquotuniv3prop R ( fun x x' x'' => hProppair _ ( setproperty ( setwith2binopquot R ) ( opp2 ( opp1 x x' ) x'' ) ( opp1 ( opp2 x x'' ) ( opp2 x' x'' ) ) ) ) ) . intros x x' x'' . apply ( maponpaths ( setquotpr R ) ( rigrdistr X x x' x'' ) ) . Defined . Definition rigquot { X : rig } ( R : @rigeqrel X ) : rig := @rigpair ( setwith2binopquot R ) ( isrigquot R ) . (** **** Direct products *) Lemma isrigdirprod ( X Y : rig ) : isrigops ( @op1 ( setwith2binopdirprod X Y ) ) ( @op2 ( setwith2binopdirprod X Y ) ) . Proof . intros . split . split with ( dirprodpair ( isabmonoiddirprod ( rigaddabmonoid X ) ( rigaddabmonoid Y ) ) ( ismonoiddirprod ( rigmultmonoid X ) ( rigmultmonoid Y ) ) ) . simpl . split . intro xy . unfold setwith2binopdirprod . unfold op1 . unfold op2 . unfold ismonoiddirprod . unfold unel_is . simpl . apply pathsdirprod . apply ( rigmult0x X ) . apply ( rigmult0x Y ) . intro xy . unfold setwith2binopdirprod . unfold op1 . unfold op2 . unfold ismonoiddirprod . unfold unel_is . simpl . apply pathsdirprod . apply ( rigmultx0 X ) . apply ( rigmultx0 Y ) . split . intros xy xy' xy'' . unfold setwith2binopdirprod . unfold op1 . unfold op2 . simpl . apply pathsdirprod . apply ( rigldistr X ) . apply ( rigldistr Y ) . intros xy xy' xy'' . unfold setwith2binopdirprod . unfold op1 . unfold op2 . simpl . apply pathsdirprod . apply ( rigrdistr X ) . apply ( rigrdistr Y ) . Defined . Definition rigdirprod ( X Y : rig ) := @rigpair ( setwith2binopdirprod X Y ) ( isrigdirprod X Y ) . (** *** Commutative rigs *) (** **** General definitions *) Definition commrig := total2 ( fun X : setwith2binop => iscommrigops ( @op1 X ) ( @op2 X ) ) . Definition commrigpair ( X : setwith2binop ) ( is : iscommrigops ( @op1 X ) ( @op2 X ) ) : commrig := tpair ( fun X : setwith2binop => iscommrigops ( @op1 X ) ( @op2 X ) ) X is . Definition commrigconstr { X : hSet } ( opp1 opp2 : binop X ) ( ax11 : ismonoidop opp1 ) ( ax12 : iscomm opp1 ) ( ax2 : ismonoidop opp2 ) ( ax22 : iscomm opp2 ) ( m0x : forall x : X , paths ( opp2 ( unel_is ax11 ) x ) ( unel_is ax11 ) ) ( mx0 : forall x : X , paths ( opp2 x ( unel_is ax11 ) ) ( unel_is ax11 ) ) ( dax : isdistr opp1 opp2 ) : commrig . Proof. intros. split with ( setwith2binoppair X ( dirprodpair opp1 opp2 ) ) . split . split . split with ( dirprodpair ( dirprodpair ax11 ax12 ) ax2 ) . apply ( dirprodpair m0x mx0 ) . apply dax . apply ax22 . Defined . Definition commrigtorig : commrig -> rig := fun X : _ => @rigpair ( pr1 X ) ( pr1 ( pr2 X ) ) . Coercion commrigtorig : commrig >-> rig . Definition rigcomm2 ( X : commrig ) : iscomm ( @op2 X ) := pr2 ( pr2 X ) . Definition commrigop2axs ( X : commrig ) : isabmonoidop ( @op2 X ) := tpair _ ( rigop2axs X ) ( rigcomm2 X ) . Definition commrigmultabmonoid ( X : commrig ) : abmonoid := abmonoidpair ( setwithbinoppair X op2 ) ( dirprodpair ( rigop2axs X ) ( rigcomm2 X ) ) . (** **** Relations similar to "greater" on commutative rigs *) Lemma isinvrigmultgtif ( X : commrig ) ( R : hrel X ) ( is2 : forall a b c d , R ( op1 ( op2 a c ) ( op2 b d ) ) ( op1 ( op2 a d ) ( op2 b c ) ) -> R a b -> R c d ) : isinvrigmultgt X R . Proof . intros . split . apply is2 . intros a b c d r rcd . rewrite ( rigcomm1 X ( op2 a d ) _ ) in r . rewrite ( rigcomm2 X a c ) in r . rewrite ( rigcomm2 X b d ) in r . rewrite ( rigcomm2 X b c ) in r . rewrite ( rigcomm2 X a d ) in r . apply ( is2 _ _ _ _ r rcd ) . Defined . (** **** Subobjects *) Lemma iscommrigcarrier { X : commrig } ( A : @subrigs X ) : iscommrigops ( @op1 A ) ( @op2 A ) . Proof . intros . split with ( isrigcarrier A ) . apply ( pr2 ( @isabmonoidcarrier ( commrigmultabmonoid X ) ( rigmultsubmonoid A ) ) ) . Defined . (* ??? slows down at the last [ apply ] and at [ Defined ] ( oct.16.2011 - does not slow down anymore with two Dan's patches ) *) Definition carrierofasubcommrig { X : commrig } ( A : @subrigs X ) : commrig := commrigpair A ( iscommrigcarrier A ) . (** **** Quotient objects *) Lemma iscommrigquot { X : commrig } ( R : @rigeqrel X ) : iscommrigops ( @op1 ( setwith2binopquot R ) ) ( @op2 ( setwith2binopquot R ) ) . Proof . intros . split with ( isrigquot R ) . apply ( pr2 ( @isabmonoidquot ( commrigmultabmonoid X ) ( multmonoideqrel R ) ) ) . Defined . Definition commrigquot { X : commrig } ( R : @rigeqrel X ) := commrigpair ( setwith2binopquot R ) ( iscommrigquot R ) . (** **** Direct products *) Lemma iscommrigdirprod ( X Y : commrig ) : iscommrigops ( @op1 ( setwith2binopdirprod X Y ) ) ( @op2 ( setwith2binopdirprod X Y ) ) . Proof . intros . split with ( isrigdirprod X Y ) . apply ( pr2 ( isabmonoiddirprod ( commrigmultabmonoid X ) ( commrigmultabmonoid Y ) ) ) . Defined . Definition commrigdirprod ( X Y : commrig ) := commrigpair ( setwith2binopdirprod X Y ) ( iscommrigdirprod X Y ) . (** *** Rings *) (** **** General definitions *) Definition rng := total2 ( fun X : setwith2binop => isrngops ( @op1 X ) ( @op2 X ) ) . Definition rngpair { X : setwith2binop } ( is : isrngops ( @op1 X ) ( @op2 X ) ) : rng := tpair ( fun X : setwith2binop => isrngops ( @op1 X ) ( @op2 X ) ) X is . Definition pr1rng : rng -> setwith2binop := @pr1 _ ( fun X : setwith2binop => isrngops ( @op1 X ) ( @op2 X ) ) . Coercion pr1rng : rng >-> setwith2binop . Definition rngaxs ( X : rng ) : isrngops ( @op1 X ) ( @op2 X ) := pr2 X . Definition rngop1axs ( X : rng ) : isabgrop ( @op1 X ) := pr1 ( pr1 ( pr2 X ) ) . Definition rngassoc1 ( X : rng ) : isassoc ( @op1 X ) := assocax_is ( rngop1axs X ) . Definition rngunel1 { X : rng } : X := unel_is ( rngop1axs X ) . Definition rnglunax1 ( X : rng ) : islunit op1 ( @rngunel1 X ) := lunax_is ( rngop1axs X ) . Definition rngrunax1 ( X : rng ) : isrunit op1 ( @rngunel1 X ) := runax_is ( rngop1axs X ) . Definition rnginv1 { X : rng } : X -> X := grinv_is ( rngop1axs X ) . Definition rnglinvax1 ( X : rng ) : forall x : X , paths ( op1 ( rnginv1 x ) x ) rngunel1 := grlinvax_is ( rngop1axs X ) . Definition rngrinvax1 ( X : rng ) : forall x : X , paths ( op1 x ( rnginv1 x ) ) rngunel1 := grrinvax_is ( rngop1axs X ) . Definition rngcomm1 ( X : rng ) : iscomm ( @op1 X ) := commax_is ( rngop1axs X ) . Definition rngop2axs ( X : rng ) : ismonoidop ( @op2 X ) := pr2 ( pr1 ( pr2 X ) ) . Definition rngassoc2 ( X : rng ) : isassoc ( @op2 X ) := assocax_is ( rngop2axs X ) . Definition rngunel2 { X : rng } : X := unel_is ( rngop2axs X ) . Definition rnglunax2 ( X : rng ) : islunit op2 ( @rngunel2 X ) := lunax_is ( rngop2axs X ) . Definition rngrunax2 ( X : rng ) : isrunit op2 ( @rngunel2 X ) := runax_is ( rngop2axs X ) . Definition rngdistraxs ( X : rng ) : isdistr ( @op1 X ) ( @op2 X ) := pr2 ( pr2 X ) . Definition rngldistr ( X : rng ) : isldistr ( @op1 X ) ( @op2 X ) := pr1 ( pr2 ( pr2 X ) ) . Definition rngrdistr ( X : rng ) : isrdistr ( @op1 X ) ( @op2 X ) := pr2 ( pr2 ( pr2 X ) ) . Definition rngconstr { X : hSet } ( opp1 opp2 : binop X ) ( ax11 : isgrop opp1 ) ( ax12 : iscomm opp1 ) ( ax2 : ismonoidop opp2 ) ( dax : isdistr opp1 opp2 ) : rng := @rngpair ( setwith2binoppair X ( dirprodpair opp1 opp2 ) ) ( dirprodpair ( dirprodpair ( dirprodpair ax11 ax12 ) ax2 ) dax ) . Definition rngmultx0 ( X : rng ) : forall x : X , paths ( op2 x rngunel1 ) rngunel1 := rngmultx0_is ( rngaxs X ) . Definition rngmult0x ( X : rng ) : forall x : X , paths ( op2 rngunel1 x ) rngunel1 := rngmult0x_is ( rngaxs X ) . Definition rngminus1 { X : rng } : X := rngminus1_is ( rngaxs X ) . Definition rngmultwithminus1 ( X : rng ) : forall x : X , paths ( op2 rngminus1 x ) ( rnginv1 x ) := rngmultwithminus1_is ( rngaxs X ) . Definition rngaddabgr ( X : rng ) : abgr := abgrpair ( setwithbinoppair X op1 ) ( rngop1axs X ) . Definition rngmultmonoid ( X : rng ) : monoid := monoidpair ( setwithbinoppair X op2 ) ( rngop2axs X ) . Notation "x + y" := ( op1 x y ) : rng_scope . Notation "x - y" := ( op1 x ( rnginv1 y ) ) . Notation "x * y" := ( op2 x y ) : rng_scope . Notation "0" := ( rngunel1 ) : rng_scope . Notation "1" := ( rngunel2 ) : rng_scope . Notation "-1" := ( rngminus1 ) ( at level 0 ) : rng_scope . Notation " - x " := ( rnginv1 x ) : rng_scope . Delimit Scope rng_scope with rng . Definition rngtorig ( X : rng ) : rig := @rigpair _ ( pr2 X ) . Coercion rngtorig : rng >-> rig . (** **** Homomorphisms of rings *) Definition isrngfun { X Y : rng } ( f : X -> Y ) := @isrigfun X Y f . Definition rngfun ( X Y : rng ) := rigfun X Y . Definition rngfunconstr { X Y : rng } { f : X -> Y } ( is : isrngfun f ) : rngfun X Y := rigfunconstr is . Identity Coercion id_rngfun : rngfun >-> rigfun. Definition rngaddfun { X Y : rng } ( f : rngfun X Y ) : monoidfun ( rngaddabgr X ) ( rngaddabgr Y ) := monoidfunconstr ( pr1 ( pr2 f ) ) . Definition rngmultfun { X Y : rng } ( f : rngfun X Y ) : monoidfun ( rngmultmonoid X ) ( rngmultmonoid Y ) := monoidfunconstr ( pr2 ( pr2 f ) ) . Definition rngiso ( X Y : rng ) := rigiso X Y . Definition rngisopair { X Y : rng } ( f : weq X Y ) ( is : isrngfun f ) : rngiso X Y := tpair _ f is . Identity Coercion id_rngiso : rngiso >-> rigiso . Definition isrngfuninvmap { X Y : rng } ( f : rngiso X Y ) : isrngfun ( invmap f ) := isrigfuninvmap f . (** **** Computation lemmas for rings *) Open Scope rng_scope . Definition rnginvunel1 ( X : rng ) : paths ( - 0 ) 0 := grinvunel ( rngaddabgr X ) . Lemma rngismultlcancelableif ( X : rng ) ( x : X ) ( isl: forall y , paths ( x * y ) 0 -> paths y 0 ) : islcancelable op2 x . Proof . intros . apply ( @isinclbetweensets X X ) . apply setproperty . apply setproperty . intros x1 x2 e . assert ( e' := maponpaths ( fun a => a + ( x * ( -x2 ) ) ) e ) . simpl in e' . rewrite ( pathsinv0 ( rngldistr X _ _ x ) ) in e' . rewrite ( pathsinv0 ( rngldistr X _ _ x ) ) in e' . rewrite ( rngrinvax1 X x2 ) in e' . rewrite ( rngmultx0 X _ ) in e' . assert ( e'' := isl ( x1 - x2 ) e' ) . assert ( e''' := maponpaths ( fun a => a + x2 ) e'' ) . simpl in e''' . rewrite ( rngassoc1 X _ _ x2 ) in e''' . rewrite ( rnglinvax1 X x2 ) in e''' . rewrite ( rnglunax1 X _ ) in e''' . rewrite ( rngrunax1 X _ ) in e''' . apply e''' . Defined . Opaque rngismultlcancelableif . Lemma rngismultrcancelableif ( X : rng ) ( x : X ) ( isr: forall y , paths ( y * x ) 0 -> paths y 0 ) : isrcancelable op2 x . Proof . intros . apply ( @isinclbetweensets X X ) . apply setproperty . apply setproperty . intros x1 x2 e . assert ( e' := maponpaths ( fun a => a + ( ( -x2 ) * x ) ) e ) . simpl in e' . rewrite ( pathsinv0 ( rngrdistr X _ _ x ) ) in e' . rewrite ( pathsinv0 ( rngrdistr X _ _ x ) ) in e' . rewrite ( rngrinvax1 X x2 ) in e' . rewrite ( rngmult0x X _ ) in e' . assert ( e'' := isr ( x1 - x2 ) e' ) . assert ( e''' := maponpaths ( fun a => a + x2 ) e'' ) . simpl in e''' . rewrite ( rngassoc1 X _ _ x2 ) in e''' . rewrite ( rnglinvax1 X x2 ) in e''' . rewrite ( rnglunax1 X _ ) in e''' . rewrite ( rngrunax1 X _ ) in e''' . apply e''' . Defined . Opaque rngismultrcancelableif . Lemma rngismultcancelableif ( X : rng ) ( x : X ) ( isl: forall y , paths ( x * y ) 0 -> paths y 0 ) ( isr: forall y , paths ( y * x ) 0 -> paths y 0 ) : iscancelable op2 x . Proof . intros . apply ( dirprodpair ( rngismultlcancelableif X x isl ) ( rngismultrcancelableif X x isr ) ) . Defined . Lemma rnglmultminus ( X : rng ) ( a b : X ) : paths ( ( - a ) * b ) ( - ( a * b ) ) . Proof . intros . apply ( @grrcan ( rngaddabgr X ) _ _ ( a * b ) ) . change ( paths ( -a * b + a * b ) ( - ( a * b ) + a * b ) ) . rewrite ( rnglinvax1 X _ ) . rewrite ( pathsinv0 ( rngrdistr X _ _ _ ) ) . rewrite ( rnglinvax1 X _ ) . rewrite ( rngmult0x X _ ) . apply idpath . Defined . Opaque rnglmultminus . Lemma rngrmultminus ( X : rng ) ( a b : X ) : paths ( a * ( - b ) ) ( - ( a * b ) ) . Proof . intros . apply ( @grrcan ( rngaddabgr X ) _ _ ( a * b ) ) . change ( paths ( a * ( - b ) + a * b ) ( - ( a * b ) + a * b ) ) . rewrite ( rnglinvax1 X _ ) . rewrite ( pathsinv0 ( rngldistr X _ _ _ ) ) . rewrite ( rnglinvax1 X _ ) . rewrite ( rngmultx0 X _ ) . apply idpath . Defined . Opaque rngrmultminus . Lemma rngmultminusminus ( X : rng ) ( a b : X ) : paths ( -a * - b ) ( a * b ) . Proof . intros . apply ( @grrcan ( rngaddabgr X ) _ _ ( - a * b ) ) . simpl . rewrite ( pathsinv0 ( rngldistr X _ _ ( - a ) ) ) . rewrite ( pathsinv0 ( rngrdistr X _ _ b ) ) . rewrite ( rnglinvax1 X b ) . rewrite ( rngrinvax1 X a ) . rewrite ( rngmult0x X _ ) . rewrite ( rngmultx0 X _ ) . apply idpath . Defined . Opaque rngmultminusminus . Lemma rngminusminus ( X : rng ) ( a : X ) : paths ( - - a ) a . Proof . intros . apply ( grinvinv ( rngaddabgr X ) a ) . Defined . Definition rnginvmaponpathsminus ( X : rng ) { a b : X } ( e : paths ( - a ) ( - b ) ) : paths a b := grinvmaponpathsinv ( rngaddabgr X ) e . (** **** Relations compatible with the additive structure on rings *) Definition rngfromgt0 ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) { x : X } ( is : R x 0 ) : R 0 ( - x ) := grfromgtunel ( rngaddabgr X ) is0 is . Definition rngtogt0 ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) { x : X } ( is : R 0 ( - x ) ) : R x 0 := grtogtunel ( rngaddabgr X ) is0 is . Definition rngfromlt0 ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) { x : X } ( is : R 0 x ) : R ( - x ) 0 := grfromltunel ( rngaddabgr X ) is0 is . Definition rngtolt0 ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) { x : X } ( is : R ( - x ) 0 ) : R 0 x := grtoltunel ( rngaddabgr X ) is0 is . (** **** Relations compatible with the multiplicative structure on rings *) Definition isrngmultgt ( X : rng ) ( R : hrel X ) := forall a b , R a 0 -> R b 0 -> R ( a * b ) 0 . Lemma rngmultgt0lt0 ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isrngmultgt X R ) { x y : X } ( isx : R x 0 ) ( isy : R 0 y ) : R 0 ( x * y ) . Proof . intros . assert ( isy' := grfromltunel ( rngaddabgr X ) is0 isy ) . assert ( r := is _ _ isx isy' ) . change ( pr1 ( R ( x * ( - y ) ) 0 ) ) in r . rewrite ( rngrmultminus X _ _ ) in r . assert ( r' := grfromgtunel ( rngaddabgr X ) is0 r ) . change ( pr1 ( R 0 ( - - ( x * y ) ) ) ) in r' . rewrite ( rngminusminus X ( x * y ) ) in r' . apply r' . Defined . Opaque rngmultgt0lt0 . Lemma rngmultlt0gt0 ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isrngmultgt X R ) { x y : X } ( isx : R 0 x ) ( isy : R y 0 ) : R 0 ( x * y ) . Proof . intros . assert ( isx' := grfromltunel ( rngaddabgr X ) is0 isx ) . assert ( r := is _ _ isx' isy ) . change ( pr1 ( R ( ( - x ) * y ) 0 ) ) in r . rewrite ( rnglmultminus X _ _ ) in r . assert ( r' := grfromgtunel ( rngaddabgr X ) is0 r ) . change ( pr1 ( R 0 ( - - ( x * y ) ) ) ) in r' . rewrite ( rngminusminus X ( x * y ) ) in r' . apply r' . Defined . Opaque rngmultlt0gt0 . Lemma rngmultlt0lt0 ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isrngmultgt X R ) { x y : X } ( isx : R 0 x ) ( isy : R 0 y ) : R ( x * y ) 0 . Proof . intros . assert ( rx := rngfromlt0 _ is0 isx ) . assert ( ry := rngfromlt0 _ is0 isy ) . assert ( int := is _ _ rx ry ) . rewrite ( rngmultminusminus X _ _ ) in int . apply int . Defined . Opaque rngmultlt0lt0 . Lemma isrngmultgttoislrngmultgt ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isrngmultgt X R ) : forall a b c : X , R c 0 -> R a b -> R ( c * a ) ( c * b ) . Proof . intros X R is0 is a b c rc0 rab . set ( rab':= ( pr2 is0 ) _ _ ( - b ) rab ) . clearbody rab' . change ( pr1 ( R ( a - b ) ( b - b ) ) ) in rab' . rewrite ( rngrinvax1 X b ) in rab' . set ( r' := is _ _ rc0 rab' ) . clearbody r' . set ( r'' := ( pr2 is0 ) _ _ ( c * b ) r' ) . clearbody r'' . change ( pr1 ( R ( c * ( a - b ) + c * b ) ( 0 + c * b ) ) ) in r'' . rewrite ( rnglunax1 X _ ) in r'' . rewrite ( pathsinv0 ( rngldistr X _ _ c ) ) in r'' . rewrite ( rngassoc1 X a _ _ ) in r'' . rewrite ( rnglinvax1 X b ) in r'' . rewrite ( rngrunax1 X _ ) in r'' . apply r'' . Defined . Opaque isrngmultgttoislrngmultgt . Lemma islrngmultgttoisrngmultgt ( X : rng ) { R : hrel X } ( is : forall a b c : X , R c 0 -> R a b -> R ( c * a ) ( c * b ) ) : isrngmultgt X R . Proof . intros . intros a b ra rb . set ( int := is b 0 a ra rb ) . clearbody int . rewrite ( rngmultx0 X _ ) in int . apply int . Defined . Opaque islrngmultgttoisrngmultgt . Lemma isrngmultgttoisrrngmultgt ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isrngmultgt X R ) : forall a b c : X , R c 0 -> R a b -> R ( a * c ) ( b * c ) . Proof . intros X R is0 is a b c rc0 rab . set ( rab':= ( pr2 is0 ) _ _ ( - b ) rab ) . clearbody rab' . change ( pr1 ( R ( a - b ) ( b - b ) ) ) in rab' . rewrite ( rngrinvax1 X b ) in rab' . set ( r' := is _ _ rab' rc0 ) . clearbody r' . set ( r'' := ( pr2 is0 ) _ _ ( b * c ) r' ) . clearbody r'' . change ( pr1 ( R ( ( a - b ) * c + b * c ) ( 0 + b * c ) ) ) in r'' . rewrite ( rnglunax1 X _ ) in r'' . rewrite ( pathsinv0 ( rngrdistr X _ _ c ) ) in r'' . rewrite ( rngassoc1 X a _ _ ) in r'' . rewrite ( rnglinvax1 X b ) in r'' . rewrite ( rngrunax1 X _ ) in r'' . apply r'' . Defined . Opaque isrngmultgttoisrrngmultgt . Lemma isrrngmultgttoisrngmultgt ( X : rng ) { R : hrel X } ( is1 : forall a b c : X , R c 0 -> R a b -> R ( a * c ) ( b * c ) ) : isrngmultgt X R . Proof . intros . intros a b ra rb . set ( int := is1 _ _ _ rb ra ) . clearbody int . rewrite ( rngmult0x X _ ) in int . apply int . Defined . Opaque isrrngmultgttoisrngmultgt . Lemma isrngmultgtaspartbinophrel ( X : rng ) ( R : hrel X ) ( is0 : @isbinophrel ( rngaddabgr X ) R ) : ( isrngmultgt X R ) <-> ( @ispartbinophrel ( rngmultmonoid X ) ( fun a => R a 0 ) R ) . Proof . intros . split . intro ism . split . apply ( isrngmultgttoislrngmultgt X is0 ism ) . apply ( isrngmultgttoisrrngmultgt X is0 ism ) . intro isp . apply ( islrngmultgttoisrngmultgt X ( pr1 isp ) ) . Defined . Lemma isrngmultgttoisrigmultgt ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isrngmultgt X R ) : isrigmultgt X R . Proof . intros . set ( rer := abmonoidrer ( rngaddabgr X ) ) . simpl in rer . intros a b c d rab rcd . assert ( intab : R ( a - b ) 0 ) . destruct ( rngrinvax1 X b ) . apply ( ( pr2 is0 ) _ _ ( - b ) ) . apply rab . assert ( intcd : R ( c - d ) 0 ) . destruct ( rngrinvax1 X d ) . apply ( ( pr2 is0 ) _ _ ( - d ) ) . apply rcd . set ( int := is _ _ intab intcd ) . rewrite ( rngrdistr X _ _ _ ) in int . rewrite ( rngldistr X _ _ _ ) in int . rewrite ( rngldistr X _ _ _ ) in int . set ( int' := ( pr2 is0 ) _ _ ( a * d + b * c ) int ) . clearbody int' . simpl in int' . rewrite ( rnglunax1 _ ) in int' . rewrite ( rngcomm1 X ( - b * c ) _ ) in int' . rewrite ( rer _ ( a * - d ) _ _ ) in int' . rewrite ( rngassoc1 X _ (a * - d + - b * c) _ ) in int' . rewrite ( rer _ _ ( a * d ) _ ) in int' . rewrite ( pathsinv0 ( rngldistr X _ _ a ) ) in int'. rewrite ( rnglinvax1 X d ) in int' . rewrite ( rngmultx0 X _ ) in int' . rewrite ( pathsinv0 ( rngrdistr X _ _ c ) ) in int' . rewrite ( rnglinvax1 X b ) in int' . rewrite ( rngmult0x X _ ) in int' . rewrite ( rngrunax1 X _ ) in int' . rewrite ( rngrunax1 X _ ) in int' . rewrite ( rngmultminusminus X b d ) in int' . apply int' . Defined . Opaque isrngmultgttoisrigmultgt . Lemma isrigmultgttoisrngmultgt ( X : rng ) { R : hrel X } ( is : isrigmultgt X R ) : isrngmultgt X R . Proof . intros . intros a b ra0 rb0 . set ( is' := is _ _ _ _ ra0 rb0 ) . simpl in is' . fold ( pr1rng ) in is' . rewrite ( rngmult0x X b ) in is' . rewrite ( rngmultx0 X a ) in is' . rewrite ( rngmult0x X 0 ) in is' . rewrite ( rngrunax1 X _ ) in is' . rewrite ( rngrunax1 X _ ) in is' . apply is' . Defined . Opaque isrigmultgttoisrngmultgt . (** **** Relations "inversely compatible" with the multiplicative structure on rings *) Definition isinvrngmultgt ( X : rng ) ( R : hrel X ) := dirprod ( forall a b , R ( a * b ) 0 -> R a 0 -> R b 0 ) ( forall a b , R ( a * b ) 0 -> R b 0 -> R a 0 ) . Lemma isinvrngmultgttoislinvrngmultgt ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isinvrngmultgt X R ) : forall a b c : X , R c 0 -> R ( c * a ) ( c * b ) -> R a b . Proof . intros X R is0 is a b c rc0 r . set ( rab':= ( pr2 is0 ) _ _ ( c * - b ) r ) . clearbody rab' . change ( pr1 ( R ( c * a + c * - b ) ( c * b + c * - b ) ) ) in rab' . rewrite ( pathsinv0 ( rngldistr X _ _ c ) ) in rab' . rewrite ( pathsinv0 ( rngldistr X _ _ c ) ) in rab' . rewrite ( rngrinvax1 X b ) in rab' . rewrite ( rngmultx0 X _ ) in rab' . set ( r' := ( pr1 is ) _ _ rab' rc0 ) . clearbody r' . set ( r'' := ( pr2 is0 ) _ _ b r' ) . clearbody r'' . change ( pr1 ( R ( a - b + b ) ( 0 + b ) ) ) in r'' . rewrite ( rnglunax1 X _ ) in r'' . rewrite ( rngassoc1 X a _ _ ) in r'' . rewrite ( rnglinvax1 X b ) in r'' . rewrite ( rngrunax1 X _ ) in r'' . apply r'' . Defined . Opaque isinvrngmultgttoislinvrngmultgt . Lemma isinvrngmultgttoisrinvrngmultgt ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isinvrngmultgt X R ) : forall a b c : X , R c 0 -> R ( a * c ) ( b * c ) -> R a b . Proof . intros X R is0 is a b c rc0 r . set ( rab':= ( pr2 is0 ) _ _ ( - b * c ) r ) . clearbody rab' . change ( pr1 ( R ( a * c + - b * c ) ( b * c + - b * c ) ) ) in rab' . rewrite ( pathsinv0 ( rngrdistr X _ _ c ) ) in rab' . rewrite ( pathsinv0 ( rngrdistr X _ _ c ) ) in rab' . rewrite ( rngrinvax1 X b ) in rab' . rewrite ( rngmult0x X _ ) in rab' . set ( r' := ( pr2 is ) _ _ rab' rc0 ) . clearbody r' . set ( r'' := ( pr2 is0 ) _ _ b r' ) . clearbody r'' . change ( pr1 ( R ( a - b + b ) ( 0 + b ) ) ) in r'' . rewrite ( rnglunax1 X _ ) in r'' . rewrite ( rngassoc1 X a _ _ ) in r'' . rewrite ( rnglinvax1 X b ) in r'' . rewrite ( rngrunax1 X _ ) in r'' . apply r'' . Defined . Opaque isinvrngmultgttoisrinvrngmultgt . Lemma islrinvrngmultgttoisinvrngmultgt ( X : rng ) { R : hrel X } ( isl : forall a b c : X , R c 0 -> R ( c * a ) ( c * b ) -> R a b ) ( isr : forall a b c : X , R c 0 -> R ( a * c ) ( b * c ) -> R a b ) : isinvrngmultgt X R . Proof . intros . split . intros a b rab ra . rewrite ( pathsinv0 ( rngmultx0 X a ) ) in rab . apply ( isl _ _ _ ra rab ) . intros a b rab rb . rewrite ( pathsinv0 ( rngmult0x X b ) ) in rab . apply ( isr _ _ _ rb rab ) . Defined . Opaque islrinvrngmultgttoisinvrngmultgt . Lemma isinvrngmultgtaspartinvbinophrel ( X : rng ) ( R : hrel X ) ( is0 : @isbinophrel ( rngaddabgr X ) R ) : ( isinvrngmultgt X R ) <-> ( @ispartinvbinophrel ( rngmultmonoid X ) ( fun a => R a 0 ) R ) . Proof . intros . split . intro ism . split . apply ( isinvrngmultgttoislinvrngmultgt X is0 ism ) . apply ( isinvrngmultgttoisrinvrngmultgt X is0 ism ) . intro isp . apply ( islrinvrngmultgttoisinvrngmultgt X ( pr1 isp ) ( pr2 isp ) ) . Defined . Lemma isinvrngmultgttoisinvrigmultgt ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isinvrngmultgt X R ) : isinvrigmultgt X R . Proof . intros . set ( rer := abmonoidrer ( rngaddabgr X ) ) . simpl in rer . split . intros a b c d r rab . set ( r' := ( pr2 is0 ) _ _ (a * - d + - b * c) r ) . clearbody r' . simpl in r' . rewrite ( rer _ ( b * c ) _ _ ) in r' . rewrite ( pathsinv0 ( rngldistr X _ _ a ) ) in r' . rewrite ( pathsinv0 ( rngrdistr X _ _ c ) ) in r' . rewrite ( rngrinvax1 X d ) in r' . rewrite ( rngrinvax1 X b ) in r' . rewrite ( rngmult0x X _ ) in r' . rewrite ( rngmultx0 X _ ) in r' . rewrite ( rnglunax1 X ) in r' . rewrite ( rer _ ( b * d ) _ _ ) in r' . rewrite ( pathsinv0 ( rngldistr X _ _ a ) ) in r' . simpl in r' . fold pr1rng in r' . rewrite ( pathsinv0 ( rngmultminusminus X b d ) ) in r' . rewrite ( pathsinv0 ( rngldistr X _ _ ( - b ) ) ) in r' . rewrite ( rngcomm1 X _ c ) in r' . rewrite ( pathsinv0 ( rngrdistr X _ _ _ ) ) in r'. set ( rab' := ( pr2 is0 ) _ _ ( - b ) rab ) . clearbody rab'. simpl in rab' . rewrite ( rngrinvax1 X b ) in rab' . set ( rcd' := ( pr1 is ) _ _ r' rab' ) . set ( rcd'' := ( pr2 is0 ) _ _ d rcd' ) . simpl in rcd'' . rewrite ( rngassoc1 _ _ _ ) in rcd''. rewrite ( rnglinvax1 X _ ) in rcd'' . rewrite ( rnglunax1 X _ ) in rcd''. rewrite ( rngrunax1 X _ ) in rcd'' . apply rcd''. intros a b c d r rcd . set ( r' := ( pr2 is0 ) _ _ (a * - d + - b * c) r ) . clearbody r' . simpl in r' . rewrite ( rer _ ( b * c ) _ _ ) in r' . rewrite ( pathsinv0 ( rngldistr X _ _ a ) ) in r' . rewrite ( pathsinv0 ( rngrdistr X _ _ c ) ) in r' . rewrite ( rngrinvax1 X d ) in r' . rewrite ( rngrinvax1 X b ) in r' . rewrite ( rngmult0x X _ ) in r' . rewrite ( rngmultx0 X _ ) in r' . rewrite ( rnglunax1 X ) in r' . rewrite ( rer _ ( b * d ) _ _ ) in r' . rewrite ( pathsinv0 ( rngldistr X _ _ a ) ) in r' . simpl in r' . fold pr1rng in r' . rewrite ( pathsinv0 ( rngmultminusminus X b d ) ) in r' . rewrite ( pathsinv0 ( rngldistr X _ _ ( - b ) ) ) in r' . rewrite ( rngcomm1 X _ c ) in r' . rewrite ( pathsinv0 ( rngrdistr X _ _ _ ) ) in r'. set ( rcd' := ( pr2 is0 ) _ _ ( - d ) rcd ) . clearbody rcd'. simpl in rcd' . rewrite ( rngrinvax1 X d ) in rcd' . set ( rab' := ( pr2 is ) _ _ r' rcd' ) . set ( rab'' := ( pr2 is0 ) _ _ b rab' ) . simpl in rab'' . rewrite ( rngassoc1 _ _ _ ) in rab''. rewrite ( rnglinvax1 X _ ) in rab'' . rewrite ( rnglunax1 X _ ) in rab''. rewrite ( rngrunax1 X _ ) in rab'' . apply rab''. Defined . Opaque isinvrngmultgttoisinvrigmultgt . (** **** Relations on rings and ring homomorphisms *) Lemma rngaddhrelandfun { X Y : rng } ( f : rngfun X Y ) ( R : hrel Y ) ( isr : @isbinophrel ( rngaddabgr Y ) R ) : @isbinophrel ( rngaddabgr X ) ( fun x x' => R ( f x ) ( f x' ) ) . Proof . intros . apply ( binophrelandfun ( rngaddfun f ) R isr ) . Defined . Lemma rngmultgtandfun { X Y : rng } ( f : rngfun X Y ) ( R : hrel Y ) ( isr : isrngmultgt Y R ) : isrngmultgt X ( fun x x' => R ( f x ) ( f x' ) ) . Proof . intros . intros a b ra rb . assert ( ax0 := ( pr2 ( pr1 ( pr2 f ) ) ) : paths ( f 0 ) 0 ) . assert ( ax1 := ( pr1 ( pr2 ( pr2 f ) ) ) : forall a b , paths ( f ( a * b ) ) ( ( f a ) * ( f b ) ) ) . rewrite ax0 in ra . rewrite ax0 in rb . rewrite ax0 . rewrite ( ax1 _ _ ) . apply ( isr _ _ ra rb ) . Defined . Lemma rnginvmultgtandfun { X Y : rng } ( f : rngfun X Y ) ( R : hrel Y ) ( isr : isinvrngmultgt Y R ) : isinvrngmultgt X ( fun x x' => R ( f x ) ( f x' ) ) . Proof . intros . assert ( ax0 := ( pr2 ( pr1 ( pr2 f ) ) ) : paths ( f 0 ) 0 ) . assert ( ax1 := ( pr1 ( pr2 ( pr2 f ) ) ) : forall a b , paths ( f ( a * b ) ) ( ( f a ) * ( f b ) ) ) . split . intros a b rab ra . rewrite ax0 in ra . rewrite ax0 in rab . rewrite ax0 . rewrite ( ax1 _ _ ) in rab . apply ( ( pr1 isr ) _ _ rab ra ) . intros a b rab rb . rewrite ax0 in rb . rewrite ax0 in rab . rewrite ax0 . rewrite ( ax1 _ _ ) in rab . apply ( ( pr2 isr ) _ _ rab rb ) . Defined . Close Scope rng_scope . (** **** Subobjects *) Definition issubrng { X : rng } ( A : hsubtypes X ) := dirprod ( @issubgr ( rngaddabgr X ) A ) ( @issubmonoid ( rngmultmonoid X ) A ) . Lemma isapropissubrng { X : rng } ( A : hsubtypes X ) : isaprop ( issubrng A ) . Proof . intros . apply ( isofhleveldirprod 1 ) . apply isapropissubgr . apply isapropissubmonoid . Defined . Definition subrngs ( X : rng ) := total2 ( fun A : hsubtypes X => issubrng A ) . Definition subrngpair { X : rng } := tpair ( fun A : hsubtypes X => issubrng A ) . Definition pr1subrng ( X : rng ) : @subrngs X -> hsubtypes X := @pr1 _ (fun A : hsubtypes X => issubrng A ) . Definition subrngtosubsetswith2binop ( X : rng ) : subrngs X -> @subsetswith2binop X := fun A : _ => subsetswith2binoppair ( pr1 A ) ( dirprodpair ( pr1 ( pr1 ( pr1 ( pr2 A ) ) ) ) ( pr1 ( pr2 ( pr2 A ) ) ) ) . Coercion subrngtosubsetswith2binop : subrngs >-> subsetswith2binop . Definition addsubgr { X : rng } : subrngs X -> @subgrs ( rngaddabgr X ) := fun A : _ => @subgrpair ( rngaddabgr X ) ( pr1 A ) ( pr1 ( pr2 A ) ) . Definition multsubmonoid { X : rng } : subrngs X -> @submonoids ( rngmultmonoid X ) := fun A : _ => @submonoidpair ( rngmultmonoid X ) ( pr1 A ) ( pr2 ( pr2 A ) ) . Lemma isrngcarrier { X : rng } ( A : subrngs X ) : isrngops ( @op1 A ) ( @op2 A ) . Proof . intros . split with ( dirprodpair ( isabgrcarrier ( addsubgr A ) ) ( ismonoidcarrier ( multsubmonoid A ) ) ) . split . intros a b c . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply rngldistr . intros a b c . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply rngrdistr . Defined . Definition carrierofasubrng ( X : rng ) ( A : subrngs X ) : rng . Proof . intros . split with A . apply isrngcarrier . Defined . Coercion carrierofasubrng : subrngs >-> rng . (** **** Quotient objects *) Definition rngeqrel { X : rng } := @twobinopeqrel X . Identity Coercion id_rngeqrel : rngeqrel >-> twobinopeqrel . Definition rngaddabgreqrel { X : rng } ( R : @rngeqrel X ) : @binopeqrel ( rngaddabgr X ) := @binopeqrelpair ( rngaddabgr X ) ( pr1 R ) ( pr1 ( pr2 R ) ) . Definition rngmultmonoideqrel { X : rng } ( R : @rngeqrel X ) : @binopeqrel ( rngmultmonoid X ) := @binopeqrelpair ( rngmultmonoid X ) ( pr1 R ) ( pr2 ( pr2 R ) ) . Lemma isrngquot { X : rng } ( R : @rngeqrel X ) : isrngops ( @op1 ( setwith2binopquot R ) ) ( @op2 ( setwith2binopquot R ) ) . Proof . intros . split with ( dirprodpair ( isabgrquot ( rngaddabgreqrel R ) ) ( ismonoidquot ( rngmultmonoideqrel R ) ) ) . simpl . set ( opp1 := @op1 ( setwith2binopquot R ) ) . set ( opp2 := @op2 ( setwith2binopquot R ) ) . split . unfold isldistr . apply ( setquotuniv3prop R ( fun x x' x'' => hProppair _ ( setproperty ( setwith2binopquot R ) ( opp2 x'' ( opp1 x x' ) ) ( opp1 ( opp2 x'' x ) ( opp2 x'' x' ) ) ) ) ) . intros x x' x'' . apply ( maponpaths ( setquotpr R ) ( rngldistr X x x' x'' ) ) . unfold isrdistr . apply ( setquotuniv3prop R ( fun x x' x'' => hProppair _ ( setproperty ( setwith2binopquot R ) ( opp2 ( opp1 x x' ) x'' ) ( opp1 ( opp2 x x'' ) ( opp2 x' x'' ) ) ) ) ) . intros x x' x'' . apply ( maponpaths ( setquotpr R ) ( rngrdistr X x x' x'' ) ) . Defined . Definition rngquot { X : rng } ( R : @rngeqrel X ) : rng := @rngpair ( setwith2binopquot R ) ( isrngquot R ) . (** **** Direct products *) Lemma isrngdirprod ( X Y : rng ) : isrngops ( @op1 ( setwith2binopdirprod X Y ) ) ( @op2 ( setwith2binopdirprod X Y ) ) . Proof . intros . split with ( dirprodpair ( isabgrdirprod ( rngaddabgr X ) ( rngaddabgr Y ) ) ( ismonoiddirprod ( rngmultmonoid X ) ( rngmultmonoid Y ) ) ) . simpl . split . intros xy xy' xy'' . unfold setwith2binopdirprod . unfold op1 . unfold op2 . simpl . apply pathsdirprod . apply ( rngldistr X ) . apply ( rngldistr Y ) . intros xy xy' xy'' . unfold setwith2binopdirprod . unfold op1 . unfold op2 . simpl . apply pathsdirprod . apply ( rngrdistr X ) . apply ( rngrdistr Y ) . Defined . Definition rngdirprod ( X Y : rng ) := @rngpair ( setwith2binopdirprod X Y ) ( isrngdirprod X Y ) . (** **** Ring of differences associated with a rig *) Open Scope rig_scope . Definition rigtorngaddabgr ( X : rig ) : abgr := abgrfrac ( rigaddabmonoid X ) . Definition rigtorngcarrier ( X : rig ) : hSet := pr1 ( pr1 ( rigtorngaddabgr X ) ) . Definition rigtorngop1int ( X : rig ) : binop ( dirprod X X ) := fun x x' => dirprodpair ( ( pr1 x ) + ( pr1 x' ) ) ( ( pr2 x ) + ( pr2 x' ) ) . Definition rigtorngop1 ( X : rig ) : binop ( rigtorngcarrier X ) := @op ( rigtorngaddabgr X ) . Definition rigtorngop1axs ( X : rig ) : isabgrop ( rigtorngop1 X ) := pr2 ( rigtorngaddabgr X ) . Definition rigtorngunel1 ( X : rig ) : rigtorngcarrier X := unel ( rigtorngaddabgr X ) . Definition eqrelrigtorng ( X : rig ) : eqrel ( dirprod X X ) := eqrelabgrfrac ( rigaddabmonoid X ) . Definition rigtorngop2int ( X : rig ) : binop ( dirprod X X ) := fun xx xx' : dirprod X X => dirprodpair ( pr1 xx * pr1 xx' + pr2 xx * pr2 xx' ) ( pr1 xx * pr2 xx' + pr2 xx * pr1 xx' ) . Definition rigtorngunel2int ( X : rig ) : dirprod X X := dirprodpair 1 0 . Lemma rigtorngop2comp ( X : rig ) : iscomprelrelfun2 ( eqrelrigtorng X ) ( eqrelrigtorng X ) ( rigtorngop2int X ) . Proof . intros . apply iscomprelrelfun2if . intros xx xx' aa . simpl . apply @hinhfun . intro tt1 . destruct tt1 as [ x0 e ] . split with ( x0 * pr2 aa + x0 * pr1 aa ) . set ( rd := rigrdistr X ) . set ( cm1 := rigcomm1 X ) . set ( as1 := rigassoc1 X ) . set ( rr := abmonoidoprer ( rigop1axs X ) ) . rewrite ( cm1 ( pr1 xx * pr1 aa ) ( pr2 xx * pr2 aa ) ) . rewrite ( rr _ ( pr1 xx * pr1 aa ) (pr1 xx' * pr2 aa) _ ) . rewrite ( cm1 (pr2 xx * pr2 aa ) ( pr1 xx' * pr2 aa ) ) . destruct ( rd ( pr1 xx ) ( pr2 xx' ) (pr1 aa ) ) . destruct ( rd ( pr1 xx' ) ( pr2 xx ) ( pr2 aa ) ) . rewrite ( rr ( (pr1 xx' + pr2 xx) * pr2 aa ) ( (pr1 xx + pr2 xx') * pr1 aa ) ( x0 * pr2 aa ) ( x0 * pr1 aa ) ) . destruct ( rd (pr1 xx' + pr2 xx) x0 ( pr2 aa ) ) . destruct ( rd (pr1 xx + pr2 xx') x0 ( pr1 aa ) ) . rewrite ( cm1 ( pr1 xx' * pr1 aa ) ( pr2 xx' * pr2 aa ) ) . rewrite ( rr _ ( pr1 xx' * pr1 aa ) (pr1 xx * pr2 aa) _ ) . rewrite ( cm1 (pr2 xx' * pr2 aa ) ( pr1 xx * pr2 aa ) ) . destruct ( rd ( pr1 xx' ) ( pr2 xx ) (pr1 aa ) ) . destruct ( rd ( pr1 xx ) ( pr2 xx' ) ( pr2 aa ) ) . rewrite ( rr ( (pr1 xx + pr2 xx') * pr2 aa ) ( (pr1 xx' + pr2 xx) * pr1 aa ) ( x0 * pr2 aa ) ( x0 * pr1 aa ) ) . destruct ( rd (pr1 xx + pr2 xx' ) x0 ( pr2 aa ) ) . destruct ( rd (pr1 xx' + pr2 xx) x0 ( pr1 aa ) ) . destruct e . apply idpath . intros aa xx xx' . simpl . apply @hinhfun . intro tt1 . destruct tt1 as [ x0 e ] . split with ( pr1 aa * x0 + pr2 aa * x0 ) . set ( ld := rigldistr X ) . set ( cm1 := rigcomm1 X ) . set ( as1 := rigassoc1 X ) . set ( rr := abmonoidoprer ( rigop1axs X ) ) . rewrite ( rr _ ( pr2 aa * pr2 xx ) (pr1 aa * pr2 xx' ) _ ) . destruct ( ld ( pr1 xx ) ( pr2 xx' ) ( pr1 aa ) ) . destruct ( ld ( pr2 xx ) ( pr1 xx' ) ( pr2 aa ) ) . rewrite ( rr _ ( pr2 aa * (pr2 xx + pr1 xx') ) ( pr1 aa * x0 ) _ ) . destruct ( ld (pr1 xx + pr2 xx') x0 ( pr1 aa ) ) . destruct ( ld (pr2 xx + pr1 xx') x0 ( pr2 aa ) ) . rewrite ( rr _ ( pr2 aa * pr2 xx' ) (pr1 aa * pr2 xx ) _ ) . destruct ( ld ( pr1 xx' ) ( pr2 xx ) ( pr1 aa ) ) . destruct ( ld ( pr2 xx' ) ( pr1 xx ) ( pr2 aa ) ) . rewrite ( rr _ ( pr2 aa * (pr2 xx' + pr1 xx) ) ( pr1 aa * x0 ) _ ) . destruct ( ld (pr1 xx' + pr2 xx) x0 ( pr1 aa ) ) . destruct ( ld (pr2 xx' + pr1 xx) x0 ( pr2 aa ) ) . rewrite ( cm1 ( pr2 xx ) ( pr1 xx' ) ) . rewrite ( cm1 ( pr2 xx' ) ( pr1 xx ) ) . destruct e . apply idpath . Defined . Opaque rigtorngop2comp . Definition rigtorngop2 ( X : rig ) : binop ( rigtorngcarrier X ) := setquotfun2 ( eqrelrigtorng X ) ( eqrelrigtorng X ) ( rigtorngop2int X ) ( rigtorngop2comp X ) . Lemma rigtorngassoc2 ( X : rig ) : isassoc ( rigtorngop2 X ) . Proof . intro . unfold isassoc . apply ( setquotuniv3prop ( eqrelrigtorng X ) ( fun x x' x'' : rigtorngcarrier X => eqset (rigtorngop2 X (rigtorngop2 X x x') x'') (rigtorngop2 X x (rigtorngop2 X x' x'')) ) ) . intros x x' x'' . change ( paths ( setquotpr (eqrelrigtorng X) ( rigtorngop2int X ( rigtorngop2int X x x' ) x'' ) ) ( setquotpr (eqrelrigtorng X) ( rigtorngop2int X x ( rigtorngop2int X x' x'' ) ) ) ) . apply ( maponpaths ( setquotpr ( eqrelrigtorng X ) ) ) . unfold rigtorngop2int . simpl . set ( rd := rigrdistr X ) . set ( ld := rigldistr X ) . set ( cm1 := rigcomm1 X ) . set ( as1 := rigassoc1 X ) . set ( as2 := rigassoc2 X ) . set ( rr := abmonoidoprer ( rigop1axs X ) ) . apply pathsdirprod . rewrite ( rd _ _ ( pr1 x'' ) ) . rewrite ( rd _ _ ( pr2 x'' ) ) . rewrite ( ld _ _ ( pr1 x ) ) . rewrite ( ld _ _ ( pr2 x ) ) . destruct ( as2 ( pr1 x ) ( pr1 x' ) ( pr1 x'' ) ) . destruct ( as2 ( pr1 x ) ( pr2 x' ) ( pr2 x'' ) ) . destruct ( as2 ( pr2 x ) ( pr1 x' ) ( pr2 x'' ) ) . destruct ( as2 ( pr2 x ) ( pr2 x' ) ( pr1 x'' ) ) . destruct ( cm1 ( pr2 x * pr2 x' * pr1 x'' ) ( pr2 x * pr1 x' * pr2 x'' ) ) . rewrite ( rr _ ( pr2 x * pr2 x' * pr1 x'' ) (pr1 x * pr2 x' * pr2 x'' ) _ ) . apply idpath . rewrite ( rd _ _ ( pr1 x'' ) ) . rewrite ( rd _ _ ( pr2 x'' ) ) . rewrite ( ld _ _ ( pr1 x ) ) . rewrite ( ld _ _ ( pr2 x ) ) . destruct ( as2 ( pr1 x ) ( pr1 x' ) ( pr2 x'' ) ) . destruct ( as2 ( pr1 x ) ( pr2 x' ) ( pr1 x'' ) ) . destruct ( as2 ( pr2 x ) ( pr1 x' ) ( pr1 x'' ) ) . destruct ( as2 ( pr2 x ) ( pr2 x' ) ( pr2 x'' ) ) . destruct ( cm1 ( pr2 x * pr2 x' * pr2 x'' ) ( pr2 x * pr1 x' * pr1 x'' ) ) . rewrite ( rr _ ( pr1 x * pr2 x' * pr1 x'' ) (pr2 x * pr2 x' * pr2 x'' ) _ ) . apply idpath . Defined . Opaque rigtorngassoc2 . Definition rigtorngunel2 ( X : rig ) : rigtorngcarrier X := setquotpr ( eqrelrigtorng X ) ( rigtorngunel2int X ) . Lemma rigtornglunit2 ( X : rig ) : islunit ( rigtorngop2 X ) ( rigtorngunel2 X ) . Proof . intro . unfold islunit . apply ( setquotunivprop ( eqrelrigtorng X ) ( fun x : rigtorngcarrier X => eqset (rigtorngop2 X (rigtorngunel2 X) x) x ) ) . intro x . change ( paths ( setquotpr (eqrelrigtorng X ) ( rigtorngop2int X ( rigtorngunel2int X ) x ) ) ( setquotpr (eqrelrigtorng X) x ) ) . apply ( maponpaths ( setquotpr ( eqrelrigtorng X ) ) ) . unfold rigtorngop2int . simpl . destruct x as [ x1 x2 ] . simpl . set ( lu2 := riglunax2 X ) . set ( ru1 := rigrunax1 X ) . set ( m0x := rigmult0x X ) . apply pathsdirprod . rewrite ( lu2 x1 ) . rewrite ( m0x x2 ) . apply ( ru1 x1 ) . rewrite ( lu2 x2 ) . rewrite ( m0x x1 ) . apply ( ru1 x2 ) . Defined . Opaque rigtornglunit2 . Lemma rigtorngrunit2 ( X : rig ) : isrunit ( rigtorngop2 X ) ( rigtorngunel2 X ) . Proof . intro . unfold isrunit . apply ( setquotunivprop ( eqrelrigtorng X ) ( fun x : rigtorngcarrier X => eqset (rigtorngop2 X x (rigtorngunel2 X)) x ) ) . intro x . change ( paths ( setquotpr (eqrelrigtorng X ) ( rigtorngop2int X x ( rigtorngunel2int X ) ) ) ( setquotpr (eqrelrigtorng X) x ) ) . apply ( maponpaths ( setquotpr ( eqrelrigtorng X ) ) ) . unfold rigtorngop2int . simpl . destruct x as [ x1 x2 ] . simpl . set ( ru2 := rigrunax2 X ) . set ( ru1 := rigrunax1 X ) . set ( lu1 := riglunax1 X ) . set ( mx0 := rigmultx0 X ) . apply pathsdirprod . rewrite ( ru2 x1 ) . rewrite ( mx0 x2 ) . apply ( ru1 x1 ) . rewrite ( ru2 x2 ) . rewrite ( mx0 x1 ) . apply ( lu1 x2 ) . Defined . Opaque rigtorngrunit2 . Definition rigtorngisunit ( X : rig ) : isunit ( rigtorngop2 X ) ( rigtorngunel2 X ) := dirprodpair ( rigtornglunit2 X ) ( rigtorngrunit2 X ) . Definition rigtorngisunital ( X : rig ) : isunital ( rigtorngop2 X ) := tpair _ ( rigtorngunel2 X ) ( rigtorngisunit X ) . Definition rigtorngismonoidop2 ( X : rig ) : ismonoidop ( rigtorngop2 X ) := dirprodpair ( rigtorngassoc2 X ) ( rigtorngisunital X ) . Lemma rigtorngldistr ( X : rig ) : isldistr ( rigtorngop1 X ) ( rigtorngop2 X ) . Proof . intro . unfold isldistr . apply ( setquotuniv3prop ( eqrelrigtorng X ) ( fun x x' x'' : rigtorngcarrier X => eqset (rigtorngop2 X x'' (rigtorngop1 X x x')) (rigtorngop1 X (rigtorngop2 X x'' x) (rigtorngop2 X x'' x')) ) ) . intros x x' x'' . change ( paths ( setquotpr (eqrelrigtorng X ) ( rigtorngop2int X x'' ( rigtorngop1int X x x' ) ) ) ( setquotpr (eqrelrigtorng X ) ( rigtorngop1int X ( rigtorngop2int X x'' x ) ( rigtorngop2int X x'' x' ) ) ) ) . apply ( maponpaths ( setquotpr ( eqrelrigtorng X ) ) ) . unfold rigtorngop1int . unfold rigtorngop2int . simpl . set ( ld := rigldistr X ) . set ( cm1 := rigcomm1 X ) . set ( rr := abmonoidoprer ( rigop1axs X ) ) . apply pathsdirprod . rewrite ( ld _ _ ( pr1 x'' ) ) . rewrite ( ld _ _ ( pr2 x'' ) ) . apply ( rr _ ( pr1 x'' * pr1 x' ) (pr2 x'' * pr2 x ) _ ) . rewrite ( ld _ _ ( pr1 x'' ) ) . rewrite ( ld _ _ ( pr2 x'' ) ) . apply ( rr _ (pr1 x'' * pr2 x' ) ( pr2 x'' * pr1 x ) _ ) . Defined . Opaque rigtorngldistr . Lemma rigtorngrdistr ( X : rig ) : isrdistr ( rigtorngop1 X ) ( rigtorngop2 X ) . Proof . intro . unfold isrdistr . apply ( setquotuniv3prop ( eqrelrigtorng X ) ( fun x x' x'' : rigtorngcarrier X => eqset (rigtorngop2 X (rigtorngop1 X x x') x'' ) (rigtorngop1 X (rigtorngop2 X x x'' ) (rigtorngop2 X x' x'' )) ) ) . intros x x' x'' . change ( paths ( setquotpr (eqrelrigtorng X ) ( rigtorngop2int X ( rigtorngop1int X x x' ) x'' ) ) ( setquotpr (eqrelrigtorng X ) ( rigtorngop1int X ( rigtorngop2int X x x'' ) ( rigtorngop2int X x' x'' ) ) ) ) . apply ( maponpaths ( setquotpr ( eqrelrigtorng X ) ) ) . unfold rigtorngop1int . unfold rigtorngop2int . simpl . set ( rd := rigrdistr X ) . set ( cm1 := rigcomm1 X ) . set ( rr := abmonoidoprer ( rigop1axs X ) ) . apply pathsdirprod . rewrite ( rd _ _ ( pr1 x'' ) ) . rewrite ( rd _ _ ( pr2 x'' ) ) . apply ( rr _ ( pr1 x' * pr1 x'' ) (pr2 x * pr2 x'' ) _ ) . rewrite ( rd _ _ ( pr1 x'' ) ) . rewrite ( rd _ _ ( pr2 x'' ) ) . apply ( rr _ (pr1 x' * pr2 x'' ) ( pr2 x * pr1 x'' ) _ ) . Defined . Opaque rigtorngrdistr . Definition rigtorngdistr ( X : rig ) : isdistr ( rigtorngop1 X ) ( rigtorngop2 X ) := dirprodpair ( rigtorngldistr X ) ( rigtorngrdistr X ) . Definition rigtorng ( X : rig ) : rng . Proof . intro . split with ( @setwith2binoppair ( rigtorngcarrier X ) ( dirprodpair ( rigtorngop1 X ) ( rigtorngop2 X ) ) ) . split . apply ( dirprodpair ( rigtorngop1axs X ) ( rigtorngismonoidop2 X ) ) . apply ( rigtorngdistr X ) . Defined . (** **** Canonical homomorphism to the ring associated with a rig (ring of differences) *) Definition torngdiff ( X : rig ) ( x : X ) : rigtorng X := setquotpr _ ( dirprodpair x 0 ) . Lemma isbinop1funtorngdiff ( X : rig ) : @isbinopfun ( rigaddabmonoid X ) ( rngaddabgr ( rigtorng X ) ) ( torngdiff X ) . Proof . intros . unfold isbinopfun . intros x x' . apply ( isbinopfuntoabgrfrac ( rigaddabmonoid X ) x x' ) . Defined . Opaque isbinop1funtorngdiff . Lemma isunital1funtorngdiff ( X : rig ) : paths ( torngdiff X 0 ) 0%rng . Proof . intro. apply idpath . Defined . Opaque isunital1funtorngdiff . Definition isaddmonoidfuntorngdiff ( X : rig ) : @ismonoidfun ( rigaddabmonoid X ) ( rngaddabgr ( rigtorng X ) ) ( torngdiff X ) := dirprodpair ( isbinop1funtorngdiff X ) ( isunital1funtorngdiff X ) . Lemma isbinop2funtorngdiff ( X : rig ) : @isbinopfun ( rigmultmonoid X ) ( rngmultmonoid ( rigtorng X ) ) ( torngdiff X ) . Proof . intros . unfold isbinopfun . intros x x' . change ( paths ( setquotpr _ ( dirprodpair ( x * x' ) 0 ) ) ( setquotpr (eqrelrigtorng X ) ( rigtorngop2int X ( dirprodpair x 0 ) ( dirprodpair x' 0 ) ) ) ) . apply ( maponpaths ( setquotpr _ ) ) . unfold rigtorngop2int . simpl . apply pathsdirprod . rewrite ( rigmultx0 X _ ) . rewrite ( rigrunax1 X _ ) . apply idpath . rewrite ( rigmult0x X _ ) . rewrite ( rigmultx0 X _ ) . rewrite ( rigrunax1 X _ ) . apply idpath . Defined . Lemma isunital2funtorngdiff ( X : rig ) : paths ( torngdiff X 1 ) 1%rng . Proof . intro. apply idpath . Defined . Opaque isunital2funtorngdiff . Definition ismultmonoidfuntorngdiff ( X : rig ) : @ismonoidfun ( rigmultmonoid X ) ( rngmultmonoid ( rigtorng X ) ) ( torngdiff X ) := dirprodpair ( isbinop2funtorngdiff X ) ( isunital2funtorngdiff X ) . Definition isrigfuntorngdiff ( X : rig ) : @isrigfun X ( rigtorng X ) ( torngdiff X ) := dirprodpair ( isaddmonoidfuntorngdiff X ) ( ismultmonoidfuntorngdiff X ) . Definition isincltorngdiff ( X : rig ) ( iscanc : forall x : X , @isrcancelable X ( @op1 X ) x ) : isincl ( torngdiff X ) := isincltoabgrfrac ( rigaddabmonoid X ) iscanc . (** **** Relations similar to "greater" or "greater or equal" on the ring associated with a rig *) Definition rigtorngrel ( X : rig ) { R : hrel X } ( is : @isbinophrel ( rigaddabmonoid X ) R ) : hrel ( rigtorng X ) := abgrfracrel ( rigaddabmonoid X ) is . Lemma isrngrigtorngmultgt ( X : rig ) { R : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) R ) ( is : isrigmultgt X R ) : isrngmultgt ( rigtorng X ) ( rigtorngrel X is0 ) . Proof . intros . set ( assoc := rigassoc1 X ) . set ( comm := rigcomm1 X ) . set ( rer := ( abmonoidrer ( rigaddabmonoid X ) ) : forall a b c d : X , paths ( ( a + b ) + ( c + d ) ) ( ( a + c ) + ( b + d ) ) ) . set ( ld := rigldistr X ) . set ( rd := rigrdistr X ) . assert ( int : forall a b , isaprop ( rigtorngrel X is0 a rngunel1 -> rigtorngrel X is0 b rngunel1 -> rigtorngrel X is0 (a * b) rngunel1 ) ) . intros a b . apply impred . intro . apply impred . intro . apply ( pr2 _ ) . unfold isrngmultgt . apply ( setquotuniv2prop _ ( fun a b => hProppair _ ( int a b ) ) ) . intros xa1 xa2 . change ( ( abgrfracrelint ( rigaddabmonoid X ) R ) xa1 ( dirprodpair ( @rigunel1 X ) ( @rigunel1 X ) ) -> ( abgrfracrelint ( rigaddabmonoid X ) R ) xa2 ( dirprodpair ( @rigunel1 X ) ( @rigunel1 X ) ) -> ( abgrfracrelint ( rigaddabmonoid X ) R ( @rigtorngop2int X xa1 xa2 ) ( dirprodpair ( @rigunel1 X ) ( @rigunel1 X ) ) ) ) . unfold abgrfracrelint . simpl . apply hinhfun2 . intros t22 t21 . set ( c2 := pr1 t21 ) . set ( c1 := pr1 t22 ) . set ( r1 := pr2 t21 ) . set ( r2 := pr2 t22 ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr2 xa1 ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr2 xa2 ) . split with ( ( x1 * c2 + a1 * c2 ) + ( ( c1 * x2 + c1 * c2 ) + ( c1 * a2 + c1 * c2 ) ) ) . change ( pr1 ( R ( x1 * x2 + a1 * a2 + 0 + ( ( x1 * c2 + a1 * c2 ) + ( ( c1 * x2 + c1 * c2 ) + ( c1 * a2 + c1 * c2 ) ) ) ) ( 0 + ( x1 * a2 + a1 * x2 ) + ( x1 * c2 + a1 * c2 + ( ( c1 * x2 + c1 * c2 ) + ( c1 * a2 + c1 * c2 ) ) ) ) ) ) . rewrite ( riglunax1 X _ ) . rewrite ( rigrunax1 X _ ) . rewrite ( assoc ( x1 * c2 ) _ _ ) . rewrite ( rer _ ( a1 * a2 ) _ _ ) . rewrite ( rer _ ( a1 * x2 ) _ _ ) . rewrite ( pathsinv0 ( assoc ( a1 * a2 ) _ _ ) ) . rewrite ( pathsinv0 ( assoc ( a1 * x2 ) _ _ ) ) . rewrite ( pathsinv0 ( assoc ( x1 * x2 + _ ) _ _ ) ) . rewrite ( pathsinv0 ( assoc ( x1 * a2 + _ ) _ _ ) ) . rewrite ( rer _ ( a1 * a2 + _ ) _ _ ) . rewrite ( rer _ ( a1 * x2 + _ ) _ _ ) . rewrite ( pathsinv0 ( ld _ _ x1 ) ) . rewrite ( pathsinv0 ( ld _ _ x1 ) ) . rewrite ( pathsinv0 ( ld _ _ c1 ) ) . rewrite ( pathsinv0 ( ld _ _ c1 ) ) . rewrite ( pathsinv0 ( ld _ _ a1 ) ) . rewrite ( pathsinv0 ( ld _ _ a1 ) ) . rewrite ( pathsinv0 ( rd _ _ ( x2 + c2 ) ) ) . rewrite ( pathsinv0 ( rd _ _ ( a2 + c2 ) ) ) . rewrite ( comm ( a1 * _ ) _ ) . rewrite ( rer _ ( c1 * _ ) _ _ ) . rewrite ( pathsinv0 ( rd _ _ ( x2 + c2 ) ) ) . rewrite ( pathsinv0 ( rd _ _ ( a2 + c2 ) ) ) . clearbody r1 . clearbody r2 . change ( pr1 ( R ( x2 + 0 + c2 ) ( 0 + a2 + c2 ) ) ) in r1 . change ( pr1 ( R ( x1 + 0 + c1 ) ( 0 + a1 + c1 ) ) ) in r2 . rewrite ( rigrunax1 X _ ) in r1 . rewrite ( riglunax1 X _ ) in r1 . rewrite ( rigrunax1 X _ ) in r2 . rewrite ( riglunax1 X _ ) in r2 . rewrite ( comm c1 a1 ) . apply ( is _ _ _ _ r2 r1 ) . Defined . Opaque isrngrigtorngmultgt . Definition isdecrigtorngrel ( X : rig ) { R : hrel X } ( is : @isbinophrel ( rigaddabmonoid X ) R ) ( is' : @isinvbinophrel ( rigaddabmonoid X ) R ) ( isd : isdecrel R ) : isdecrel ( rigtorngrel X is ) . Proof . intros . apply ( isdecabgrfracrel ( rigaddabmonoid X ) is is' isd ) . Defined . Lemma isinvrngrigtorngmultgt ( X : rig ) { R : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) R ) ( is1 : @isinvbinophrel ( rigaddabmonoid X ) R ) ( is : isinvrigmultgt X R ) : isinvrngmultgt ( rigtorng X ) ( rigtorngrel X is0 ) . Proof . intros . split . assert ( int : forall a b , isaprop ( rigtorngrel X is0 (a * b) rngunel1 -> rigtorngrel X is0 a rngunel1 -> rigtorngrel X is0 b rngunel1 ) ) . intros . apply impred . intro . apply impred . intro . apply ( pr2 _ ) . apply ( setquotuniv2prop _ ( fun a b => hProppair _ ( int a b ) ) ) . intros xa1 xa2 . change ( ( abgrfracrelint ( rigaddabmonoid X ) R ( @rigtorngop2int X xa1 xa2 ) ( dirprodpair ( @rigunel1 X ) ( @rigunel1 X ) ) ) -> ( abgrfracrelint ( rigaddabmonoid X ) R ) xa1 ( dirprodpair ( @rigunel1 X ) ( @rigunel1 X ) ) -> ( abgrfracrelint ( rigaddabmonoid X ) R ) xa2 ( dirprodpair ( @rigunel1 X ) ( @rigunel1 X ) ) ) . unfold abgrfracrelint . simpl . apply hinhfun2 . intros t22 t21 . set ( c2 := pr1 t22 ) . set ( c1 := pr1 t21 ) . set ( r1 := pr2 t21 ) . set ( r2 := pr2 t22 ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr2 xa1 ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr2 xa2 ) . simpl in r2 . clearbody r2 . change ( pr1 ( R ( x1 * x2 + a1 * a2 + 0 + c2 ) ( 0 + ( x1 * a2 + a1 * x2 ) + c2 ) ) ) in r2 . rewrite ( riglunax1 X _ ) in r2 . rewrite ( rigrunax1 X _ ) in r2 . rewrite ( rigrunax1 X _ ) . rewrite ( riglunax1 X _ ) . set ( r2' := ( pr2 is1 ) _ _ c2 r2 ) . clearbody r1 . change ( pr1 ( R ( x1 + 0 + c1 ) ( 0 + a1 + c1 ) ) ) in r1 . rewrite ( riglunax1 X _ ) in r1 . rewrite ( rigrunax1 X _ ) in r1 . set ( r1' := ( pr2 is1 ) _ _ c1 r1 ) . split with 0 . rewrite ( rigrunax1 X _ ) . rewrite ( rigrunax1 X _ ) . apply ( ( pr1 is ) _ _ _ _ r2' r1' ) . assert ( int : forall a b , isaprop ( rigtorngrel X is0 (a * b) rngunel1 -> rigtorngrel X is0 b rngunel1 -> rigtorngrel X is0 a rngunel1 ) ) . intros . apply impred . intro . apply impred . intro . apply ( pr2 _ ) . apply ( setquotuniv2prop _ ( fun a b => hProppair _ ( int a b ) ) ) . intros xa1 xa2 . change ( ( abgrfracrelint ( rigaddabmonoid X ) R ( @rigtorngop2int X xa1 xa2 ) ( dirprodpair ( @rigunel1 X ) ( @rigunel1 X ) ) ) -> ( abgrfracrelint ( rigaddabmonoid X ) R ) xa2 ( dirprodpair ( @rigunel1 X ) ( @rigunel1 X ) ) -> ( abgrfracrelint ( rigaddabmonoid X ) R ) xa1 ( dirprodpair ( @rigunel1 X ) ( @rigunel1 X ) ) ) . unfold abgrfracrelint . simpl . apply hinhfun2 . intros t22 t21 . set ( c2 := pr1 t22 ) . set ( c1 := pr1 t21 ) . set ( r1 := pr2 t21 ) . set ( r2 := pr2 t22 ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr2 xa1 ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr2 xa2 ) . simpl in r2 . clearbody r2 . change ( pr1 ( R ( x1 * x2 + a1 * a2 + 0 + c2 ) ( 0 + ( x1 * a2 + a1 * x2 ) + c2 ) ) ) in r2 . rewrite ( riglunax1 X _ ) in r2 . rewrite ( rigrunax1 X _ ) in r2 . rewrite ( rigrunax1 X _ ) . rewrite ( riglunax1 X _ ) . set ( r2' := ( pr2 is1 ) _ _ c2 r2 ) . clearbody r1 . change ( pr1 ( R ( x2 + 0 + c1 ) ( 0 + a2 + c1 ) ) ) in r1 . rewrite ( riglunax1 X _ ) in r1 . rewrite ( rigrunax1 X _ ) in r1 . set ( r1' := ( pr2 is1 ) _ _ c1 r1 ) . split with 0 . rewrite ( rigrunax1 X _ ) . rewrite ( rigrunax1 X _ ) . apply ( ( pr2 is ) _ _ _ _ r2' r1' ) . Defined . Opaque isinvrngrigtorngmultgt . (** **** Realations and the canonical homomorphism to the ring associated with a rig (ring of differences) *) Definition iscomptorngdiff ( X : rig ) { L : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) L ) : iscomprelrelfun L ( rigtorngrel X is0 ) ( torngdiff X ) := iscomptoabgrfrac ( rigaddabmonoid X ) is0 . Opaque iscomptorngdiff . Close Scope rig_scope . (** *** Commutative rings *) (** **** General definitions *) Definition iscommrng ( X : setwith2binop ) := iscommrngops ( @op1 X ) ( @op2 X ) . Definition commrng := total2 ( fun X : setwith2binop => iscommrngops ( @op1 X ) ( @op2 X ) ) . Definition commrngpair ( X : setwith2binop ) ( is : iscommrngops ( @op1 X ) ( @op2 X ) ) := tpair ( fun X : setwith2binop => iscommrngops ( @op1 X ) ( @op2 X ) ) X is . Definition commrngconstr { X : hSet } ( opp1 opp2 : binop X ) ( ax11 : isgrop opp1 ) ( ax12 : iscomm opp1 ) ( ax21 : ismonoidop opp2 ) ( ax22 : iscomm opp2 ) ( dax : isdistr opp1 opp2 ) : commrng := @commrngpair ( setwith2binoppair X ( dirprodpair opp1 opp2 ) ) ( dirprodpair ( dirprodpair ( dirprodpair ( dirprodpair ax11 ax12 ) ax21 ) dax ) ax22 ) . Definition commrngtorng : commrng -> rng := fun X : _ => @rngpair ( pr1 X ) ( pr1 ( pr2 X ) ) . Coercion commrngtorng : commrng >-> rng . Definition rngcomm2 ( X : commrng ) : iscomm ( @op2 X ) := pr2 ( pr2 X ) . Definition commrngop2axs ( X : commrng ) : isabmonoidop ( @op2 X ) := tpair _ ( rngop2axs X ) ( rngcomm2 X ) . Definition rngmultabmonoid ( X : commrng ) : abmonoid := abmonoidpair ( setwithbinoppair X op2 ) ( dirprodpair ( rngop2axs X ) ( rngcomm2 X ) ) . Definition commrngtocommrig ( X : commrng ) : commrig := commrigpair _ ( pr2 X ) . Coercion commrngtocommrig : commrng >-> commrig . (** **** Computational lemmas for commutative rings *) Open Scope rng_scope. Lemma commrngismultcancelableif ( X : commrng ) ( x : X ) ( isl : forall y , paths ( x * y ) 0 -> paths y 0 ) : iscancelable op2 x . Proof . intros . split . apply ( rngismultlcancelableif X x isl ) . assert ( isr : forall y , paths ( y * x ) 0 -> paths y 0 ) . intros y e . rewrite ( rngcomm2 X _ _ ) in e . apply ( isl y e ) . apply ( rngismultrcancelableif X x isr ) . Defined . Opaque commrngismultcancelableif . Close Scope rng_scope. (** **** Subobjects *) Lemma iscommrngcarrier { X : commrng } ( A : @subrngs X ) : iscommrngops ( @op1 A ) ( @op2 A ) . Proof . intros . split with ( isrngcarrier A ) . apply ( pr2 ( @isabmonoidcarrier ( rngmultabmonoid X ) ( multsubmonoid A ) ) ) . Defined . Definition carrierofasubcommrng { X : commrng } ( A : @subrngs X ) : commrng := commrngpair A ( iscommrngcarrier A ) . (** **** Quotient objects *) Lemma iscommrngquot { X : commrng } ( R : @rngeqrel X ) : iscommrngops ( @op1 ( setwith2binopquot R ) ) ( @op2 ( setwith2binopquot R ) ) . Proof . intros . split with ( isrngquot R ) . apply ( pr2 ( @isabmonoidquot ( rngmultabmonoid X ) ( rngmultmonoideqrel R ) ) ) . Defined . Definition commrngquot { X : commrng } ( R : @rngeqrel X ) : commrng := commrngpair ( setwith2binopquot R ) ( iscommrngquot R ) . (** **** Direct products *) Lemma iscommrngdirprod ( X Y : commrng ) : iscommrngops ( @op1 ( setwith2binopdirprod X Y ) ) ( @op2 ( setwith2binopdirprod X Y ) ) . Proof . intros . split with ( isrngdirprod X Y ) . apply ( pr2 ( isabmonoiddirprod ( rngmultabmonoid X ) ( rngmultabmonoid Y ) ) ) . Defined . Definition commrngdirprod ( X Y : commrng ) := commrngpair ( setwith2binopdirprod X Y ) ( iscommrngdirprod X Y ) . (** **** Commutative rigs to commuttaive rings *) Open Scope rig_scope . Lemma commrigtocommrngcomm2 ( X : commrig ) : iscomm ( rigtorngop2 X ) . Proof . intro . unfold iscomm . apply ( setquotuniv2prop ( eqrelrigtorng X ) ( fun x x' : rigtorngcarrier X => eqset (rigtorngop2 X x x' ) (rigtorngop2 X x' x ) ) ) . intros x x' . change ( paths ( setquotpr (eqrelrigtorng X) ( rigtorngop2int X x x' ) ) ( setquotpr (eqrelrigtorng X) ( rigtorngop2int X x' x ) ) ) . apply ( maponpaths ( setquotpr ( eqrelrigtorng X ) ) ) . unfold rigtorngop2int . set ( cm1 := rigcomm1 X ) . set ( cm2 := rigcomm2 X ) . apply pathsdirprod . rewrite ( cm2 ( pr1 x ) ( pr1 x' ) ) . rewrite ( cm2 ( pr2 x ) ( pr2 x' ) ) . apply idpath . rewrite ( cm2 ( pr1 x ) ( pr2 x' ) ) . rewrite ( cm2 ( pr2 x ) ( pr1 x' ) ) . apply cm1 . Defined . Opaque commrigtocommrngcomm2 . Definition commrigtocommrng ( X : commrig ) : commrng . Proof . intro . split with ( rigtorng X ) . split . apply ( pr2 ( rigtorng X ) ) . apply ( commrigtocommrngcomm2 X ) . Defined . Close Scope rig_scope . (** **** Rings of fractions *) Open Scope rng_scope . Definition commrngfracop1int ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : binop ( dirprod X S ) := fun x1s1 x2s2 : dirprod X S => @dirprodpair X S ( ( ( pr1 ( pr2 x2s2 ) ) * ( pr1 x1s1 ) ) + ( ( pr1 ( pr2 x1s1 ) ) * ( pr1 x2s2 ) ) ) ( @op S ( pr2 x1s1 ) ( pr2 x2s2 ) ) . Definition commrngfracop2int ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : binop ( dirprod X S ) := abmonoidfracopint ( rngmultabmonoid X ) S . Definition commrngfracunel1int ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : dirprod X S := dirprodpair 0 ( unel S ) . Definition commrngfracunel2int ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : dirprod X S := dirprodpair 1 ( unel S ) . Definition commrngfracinv1int ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : dirprod X S -> dirprod X S := fun xs : _ => dirprodpair ( ( -1 ) * ( pr1 xs ) ) ( pr2 xs ) . Definition eqrelcommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : eqrel ( dirprod X S ) := eqrelabmonoidfrac ( rngmultabmonoid X ) S . Lemma commrngfracl1 ( X : commrng ) ( x1 x2 x3 x4 a1 a2 s1 s2 s3 s4 : X ) ( eq1 : paths ( ( x1 * s2 ) * a1 ) ( ( x2 * s1 ) * a1 ) ) ( eq2 : paths ( ( x3 * s4 ) * a2 ) ( ( x4 * s3 ) * a2 ) ) : paths ( ( ( ( s3 * x1 ) + ( s1 * x3 ) ) * ( s2 * s4 ) ) * ( a1 * a2 ) ) ( ( ( ( s4 * x2 ) + ( s2 * x4 ) ) * ( s1 * s3 ) ) * ( a1 * a2 ) ) . Proof . intros . set ( rdistr := rngrdistr X ) . set ( assoc2 := rngassoc2 X ) . set ( op2axs := commrngop2axs X ) . set ( comm2 := rngcomm2 X ) . set ( rer := abmonoidoprer op2axs ) . rewrite ( rdistr ( s3 * x1 ) ( s1 * x3 ) ( s2 * s4 ) ) . rewrite ( rdistr ( s4 * x2 ) ( s2 * x4 ) ( s1 * s3 ) ) . rewrite ( rdistr ( ( s3 * x1 ) * ( s2 * s4 ) ) ( ( s1 * x3 ) * ( s2 * s4 ) ) ( a1 * a2 ) ) . rewrite ( rdistr ( ( s4 * x2 ) * ( s1 * s3 ) ) ( ( s2 * x4 ) * ( s1 * s3 ) ) ( a1 * a2 ) ) . clear rdistr . assert ( e1 : paths ( ( ( s3 * x1 ) * ( s2 * s4 ) ) * ( a1 * a2 ) ) ( ( ( s4 * x2 ) * ( s1 * s3 ) ) * ( a1 * a2 ) ) ) . destruct ( assoc2 ( s3 * x1 ) s2 s4 ) . rewrite ( assoc2 s3 x1 s2 ) . rewrite ( rer ( s3 * ( x1 * s2 ) ) s4 a1 a2 ) . rewrite ( assoc2 s3 ( x1 * s2 ) a1 ) . destruct ( assoc2 ( s4 * x2 ) s1 s3 ) . rewrite ( assoc2 s4 x2 s1 ) . rewrite ( rer ( s4 * ( x2 * s1 ) ) s3 a1 a2 ) . rewrite ( assoc2 s4 ( x2 * s1 ) a1 ) . destruct eq1 . rewrite ( comm2 s3 ( ( x1 * s2 ) * a1 ) ) . rewrite ( comm2 s4 ( ( x1 * s2 ) * a1 ) ) . rewrite ( rer ( ( x1 * s2 ) * a1 ) s3 s4 a2 ) . apply idpath . assert ( e2 : paths ( ( ( s1 * x3 ) * ( s2 * s4 ) ) * ( a1 * a2 ) ) ( ( ( s2 * x4 ) * ( s1 * s3 ) ) * ( a1 * a2 ) ) ) . destruct ( comm2 s4 s2 ) . destruct ( comm2 s3 s1 ) . destruct ( comm2 a2 a1 ) . destruct ( assoc2 ( s1 * x3 ) s4 s2 ) . destruct ( assoc2 ( s2 * x4 ) s3 s1 ) . rewrite ( assoc2 s1 x3 s4 ) . rewrite ( assoc2 s2 x4 s3 ) . rewrite ( rer ( s1 * ( x3 * s4 ) ) s2 a2 a1 ) . rewrite ( rer ( s2 * ( x4 * s3 ) ) s1 a2 a1 ) . rewrite ( assoc2 s1 ( x3 * s4 ) a2 ) . rewrite ( assoc2 s2 ( x4 * s3 ) a2 ) . destruct eq2 . destruct ( comm2 ( ( x3 * s4 ) * a2 ) s1 ) . destruct ( comm2 ( ( x3 *s4 ) * a2 ) s2 ) . rewrite ( rer ( ( x3 * s4 ) * a2 ) s1 s2 a1 ) . apply idpath . destruct e1 . destruct e2 . apply idpath . Defined . Opaque commrngfracl1 . Lemma commrngfracop1comp ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : iscomprelrelfun2 ( eqrelcommrngfrac X S ) ( eqrelcommrngfrac X S ) ( commrngfracop1int X S ) . Proof . intros . intros xs1 xs2 xs3 xs4 . simpl . set ( ff := @hinhfun2 ) . simpl in ff . apply ff . clear ff . intros tt1 tt2 . split with ( @op S ( pr1 tt1 ) ( pr1 tt2 ) ) . assert ( eq1 := pr2 tt1 ) . simpl in eq1 . assert ( eq2 := pr2 tt2 ) . simpl in eq2 . unfold pr1carrier . apply ( commrngfracl1 X ( pr1 xs1 ) ( pr1 xs2 ) ( pr1 xs3 ) ( pr1 xs4 ) ( pr1 ( pr1 tt1 ) ) ( pr1 ( pr1 tt2 ) ) ( pr1 ( pr2 xs1 ) ) ( pr1 ( pr2 xs2 ) ) ( pr1 ( pr2 xs3 ) ) ( pr1 ( pr2 xs4 ) ) eq1 eq2 ) . Defined . Opaque commrngfracop1comp . Definition commrngfracop1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : binop ( setquotinset ( eqrelcommrngfrac X S ) ) := setquotfun2 ( eqrelcommrngfrac X S ) ( eqrelcommrngfrac X S ) ( commrngfracop1int X S ) ( commrngfracop1comp X S ) . Lemma commrngfracl2 ( X : commrng ) ( x x' x'' s s' s'' : X ) : paths ( ( s'' * ( ( s' * x ) + ( s * x' ) ) ) + ( ( s * s' ) * x'' ) ) ( ( ( s' * s'' ) * x ) + ( s * ( ( s'' * x' ) + ( s' * x'' ) ) ) ) . Proof. intros . set ( ldistr := rngldistr X ) . set ( comm2 := rngcomm2 X ) . set ( assoc2 := rngassoc2 X ) . set ( assoc1 := rngassoc1 X ) . rewrite ( ldistr ( s' * x ) ( s * x' ) s'' ) . rewrite ( ldistr ( s'' * x' ) ( s' * x'' ) s ) . destruct ( comm2 s'' s' ) . destruct ( assoc2 s'' s' x ) . destruct ( assoc2 s'' s x' ) . destruct ( assoc2 s s'' x' ) . destruct ( comm2 s s'' ) . destruct ( assoc2 s s' x'' ) . apply ( assoc1 ( ( s'' * s' ) * x ) ( ( s * s'' ) * x' ) ( ( s * s' ) * x'' ) ) . Defined . Opaque commrngfracl2 . Lemma commrngfracassoc1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isassoc ( commrngfracop1 X S ) . Proof . intros . set ( R := eqrelcommrngfrac X S ) . set ( add1int := commrngfracop1int X S ) . set ( add1 := commrngfracop1 X S ) . unfold isassoc . assert ( int : forall xs xs' xs'' : dirprod X S , paths ( setquotpr R ( add1int ( add1int xs xs' ) xs'' ) ) ( setquotpr R ( add1int xs ( add1int xs' xs'' ) ) ) ) . unfold add1int . unfold commrngfracop1int . intros xs xs' xs'' . apply ( @maponpaths _ _ ( setquotpr R ) ) . simpl . apply pathsdirprod . unfold pr1carrier . apply ( commrngfracl2 X ( pr1 xs ) ( pr1 xs' ) ( pr1 xs'' ) ( pr1 ( pr2 xs ) ) ( pr1 ( pr2 xs' ) ) ( pr1 ( pr2 xs'' ) ) ) . apply ( invmaponpathsincl _ ( isinclpr1carrier ( pr1 S ) ) ) . unfold pr1carrier . simpl . set ( assoc2 := rngassoc2 X ) . apply ( assoc2 (pr1 (pr2 xs)) (pr1 (pr2 xs')) (pr1 (pr2 xs'')) ) . apply ( setquotuniv3prop R ( fun x x' x'' : setquotinset R => @eqset ( setquotinset R ) ( add1 ( add1 x x' ) x'') ( add1 x ( add1 x' x'') ) ) int ) . Defined . Opaque commrngfracassoc1 . Lemma commrngfraccomm1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : iscomm ( commrngfracop1 X S ) . Proof . intros . set ( R := eqrelcommrngfrac X S ) . set ( add1int := commrngfracop1int X S ) . set ( add1 := commrngfracop1 X S ) . unfold iscomm . apply ( setquotuniv2prop R ( fun x x' : setquotinset R => @eqset ( setquotinset R ) ( add1 x x') ( add1 x' x ) ) ) . intros xs xs' . apply ( @maponpaths _ _ ( setquotpr R ) ( add1int xs xs' ) ( add1int xs' xs ) ) . unfold add1int . unfold commrngfracop1int . destruct xs as [ x s ] . destruct s as [ s iss ] . destruct xs' as [ x' s' ] . destruct s' as [ s' iss' ] . simpl . apply pathsdirprod . change ( paths ( ( s' * x) + ( s * x' ) ) ( ( s * x' ) + ( s' * x ) ) ) . destruct ( rngcomm1 X ( s' * x ) ( s * x' ) ) . apply idpath . apply ( invmaponpathsincl _ ( isinclpr1carrier ( pr1 S ) ) ) . simpl . change ( paths ( s * s' ) ( s' * s ) ) . apply ( rngcomm2 X ) . Defined . Opaque commrngfraccomm1 . Definition commrngfracunel1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) := setquotpr ( eqrelcommrngfrac X S ) ( commrngfracunel1int X S ) . Definition commrngfracunel2 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) := setquotpr ( eqrelcommrngfrac X S ) ( commrngfracunel2int X S ) . Lemma commrngfracinv1comp ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : iscomprelrelfun ( eqrelcommrngfrac X S ) ( eqrelcommrngfrac X S ) ( commrngfracinv1int X S ) . Proof . intros . set ( assoc2 := rngassoc2 X ) . intros xs xs' . simpl . set ( ff := @hinhfun ) . simpl in ff . apply ff . clear ff . intro tt0 . split with ( pr1 tt0 ) . set ( x := pr1 xs ) . set ( s := pr1 ( pr2 xs ) ) . set ( x' := pr1 xs' ) . set ( s' := pr1 ( pr2 xs' ) ) . set ( a0 := pr1 ( pr1 tt0 ) ) . change ( paths ( -1 * x * s' * a0 ) ( -1 * x' * s * a0 ) ) . rewrite ( assoc2 -1 x s' ) . rewrite ( assoc2 -1 x' s ) . rewrite ( assoc2 -1 ( x * s' ) a0 ) . rewrite ( assoc2 -1 ( x' * s ) a0 ) . apply ( maponpaths ( fun x0 : X => -1 * x0 ) ( pr2 tt0 ) ) . Defined . Definition commrngfracinv1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) := setquotfun ( eqrelcommrngfrac X S ) ( eqrelcommrngfrac X S ) ( commrngfracinv1int X S ) ( commrngfracinv1comp X S ) . Lemma commrngfracisinv1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isinv ( commrngfracop1 X S ) ( commrngfracunel1 X S ) ( commrngfracinv1 X S ) . Proof . intros . assert ( isl : islinv ( commrngfracop1 X S ) ( commrngfracunel1 X S ) ( commrngfracinv1 X S ) ) . set ( R := eqrelcommrngfrac X S ) . set ( add1int := commrngfracop1int X S ) . set ( add1 := commrngfracop1 X S ) . set ( inv1 := commrngfracinv1 X S ) . set ( inv1int := commrngfracinv1int X S ) . set ( qunel1int := commrngfracunel1int X S ) . set ( qunel1 := commrngfracunel1 X S) . set ( assoc2 := rngassoc2 X ) . unfold islinv . apply ( setquotunivprop R ( fun x : setquotinset R => @eqset ( setquotinset R ) ( add1 ( inv1 x ) x ) qunel1 ) ) . intro xs . apply ( iscompsetquotpr R ( add1int ( inv1int xs ) xs ) qunel1int ) . simpl . apply hinhpr . split with ( unel S ) . set ( x := pr1 xs ) . set ( s := pr1 ( pr2 xs ) ) . change ( paths ( ( s * ( -1 * x ) + s * x ) * 1 * 1 ) ( 0 * ( s * s ) * 1 ) ) . destruct ( rngldistr X ( -1 * x ) x s ) . rewrite ( rngmultwithminus1 X x ) . rewrite ( rnglinvax1 X x ) . rewrite ( rngmultx0 X s ) . rewrite ( rngmult0x X 1 ) . rewrite ( rngmult0x X 1 ) . rewrite ( rngmult0x X ( s * s ) ) . apply ( pathsinv0 ( rngmult0x X 1 ) ) . apply ( dirprodpair isl ( weqlinvrinv ( commrngfracop1 X S ) ( commrngfraccomm1 X S ) ( commrngfracunel1 X S ) ( commrngfracinv1 X S ) isl ) ) . Defined . Opaque commrngfracisinv1 . Lemma commrngfraclunit1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : islunit ( commrngfracop1 X S ) ( commrngfracunel1 X S ) . Proof . intros . set ( R := eqrelcommrngfrac X S ) . set ( add1int := commrngfracop1int X S ) . set ( add1 := commrngfracop1 X S ) . set ( un1 := commrngfracunel1 X S ). unfold islunit . apply ( setquotunivprop R ( fun x : _ => @eqset ( setquotinset R ) (add1 un1 x) x ) ) . intro xs . assert ( e0 : paths ( add1int ( commrngfracunel1int X S ) xs ) xs ) . unfold add1int . unfold commrngfracop1int . destruct xs as [ x s ] . destruct s as [ s iss ] . apply pathsdirprod . simpl . change ( paths ( ( s * 0 ) + ( 1 * x ) ) x ) . rewrite ( @rngmultx0 X s ) . rewrite ( rnglunax2 X x ) . rewrite ( rnglunax1 X x ) . apply idpath . apply ( invmaponpathsincl _ ( isinclpr1carrier ( pr1 S ) ) ) . change ( paths ( 1 * s ) s ) . apply ( rnglunax2 X s ) . apply ( maponpaths ( setquotpr R ) e0 ) . Defined . Opaque commrngfraclunit1 . Lemma commrngfracrunit1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isrunit ( commrngfracop1 X S ) ( commrngfracunel1 X S ) . Proof . intros . apply ( weqlunitrunit (commrngfracop1 X S) ( commrngfraccomm1 X S ) (commrngfracunel1 X S) ( commrngfraclunit1 X S ) ) . Defined . Opaque commrngfracrunit1 . Definition commrngfracunit1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : ismonoidop ( commrngfracop1 X S ) := tpair _ ( commrngfracassoc1 X S ) ( tpair _ ( commrngfracunel1 X S ) ( dirprodpair ( commrngfraclunit1 X S ) ( commrngfracrunit1 X S ) ) ) . Definition commrngfracop2 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : binop ( setquotinset ( eqrelcommrngfrac X S ) ) := abmonoidfracop ( rngmultabmonoid X ) S . Lemma commrngfraccomm2 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : iscomm ( commrngfracop2 X S ) . Proof . intros . apply ( commax ( abmonoidfrac ( rngmultabmonoid X ) S ) ) . Defined . Opaque commrngfraccomm2 . Lemma commrngfracldistr ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isldistr ( commrngfracop1 X S ) ( commrngfracop2 X S ) . Proof . intros . set ( R := eqrelcommrngfrac X S ) . set ( mult1int := commrngfracop2int X S ) . set ( mult1 := commrngfracop2 X S ) . set ( add1int := commrngfracop1int X S ) . set ( add1 := commrngfracop1 X S ) . unfold isldistr . apply ( setquotuniv3prop R ( fun x x' x'' : setquotinset R => @eqset ( setquotinset R ) ( mult1 x'' ( add1 x x')) ( add1 ( mult1 x'' x) ( mult1 x'' x')) ) ) . intros xs xs' xs'' . apply ( iscompsetquotpr R ( mult1int xs'' ( add1int xs xs' ) ) ( add1int ( mult1int xs'' xs ) ( mult1int xs'' xs' ) ) ) . destruct xs as [ x s ] . destruct xs' as [ x' s' ] . destruct xs'' as [ x'' s'' ] . destruct s'' as [ s'' iss'' ] . simpl . apply hinhpr . split with ( unel S ) . destruct s as [ s iss ] . destruct s' as [ s' iss' ] . simpl . change ( paths ( ( ( x'' * ( ( s' * x ) + ( s * x' ) ) ) * ( ( s'' * s ) * ( s'' * s' ) ) ) * 1 ) ( ( ( ( ( s'' * s') * ( x'' * x ) ) + ( ( s'' * s ) * ( x'' * x' ) ) ) * ( s'' * ( s * s' ) ) ) * 1 ) ) . rewrite ( rngldistr X ( s' * x ) ( s * x' ) x'' ) . rewrite ( rngrdistr X _ _ ( ( s'' * s) * ( s'' * s') ) ) . rewrite ( rngrdistr X _ _ ( s'' * ( s * s') ) ) . set ( assoc := rngassoc2 X ) . set ( comm := rngcomm2 X ) . set ( rer := @abmonoidoprer X ( @op2 X ) ( commrngop2axs X ) ) . assert ( e1 : paths ( ( x'' * ( s' * x ) ) * ( ( s'' * s ) * ( s'' * s' ) ) ) ( ( ( s'' * s') * ( x'' * x ) ) * ( s'' * ( s * s' ) ) ) ) . destruct ( assoc x'' s' x ) . destruct ( comm s' x'' ) . rewrite ( assoc s' x'' x ) . destruct ( comm ( x'' * x ) s' ) . destruct ( comm ( x'' * x ) ( s'' * s' ) ) . destruct ( assoc s'' s s' ) . destruct ( comm ( s'' * s' ) ( s'' * s ) ) . destruct ( comm s' ( s'' * s ) ) . destruct ( rer ( x'' * x ) s' ( s'' * s' ) ( s'' * s ) ) . apply idpath . assert ( e2 : paths ( ( x'' * ( s * x' ) ) * ( ( s'' * s ) * ( s'' * s' ) ) ) ( ( ( s'' * s ) * ( x'' * x' ) ) * ( s'' * ( s * s' ) ) ) ) . destruct ( assoc x'' s x' ) . destruct ( comm s x'' ) . rewrite ( assoc s x'' x' ) . destruct ( comm ( x'' * x' ) s ) . destruct ( comm ( x'' * x' ) ( s'' * s ) ) . destruct ( rer ( x'' * x' ) ( s'' * s ) s ( s'' * s' ) ) . destruct ( assoc s s'' s' ) . destruct ( assoc s'' s s' ) . destruct ( comm s s'' ) . apply idpath . rewrite e1 . rewrite e2 . apply idpath . Defined . Opaque commrngfracldistr . Lemma commrngfracrdistr ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isrdistr ( commrngfracop1 X S ) ( commrngfracop2 X S ) . Proof . intros . apply ( weqldistrrdistr (commrngfracop1 X S) ( commrngfracop2 X S ) ( commrngfraccomm2 X S ) ( commrngfracldistr X S ) ) . Defined . (** Notes : 1. Construction of the addition on the multiplicative monoid of fractions requires only commutativity and associativity of multiplication and ( right ) distributivity . No properties of the addition are used . 2. The proof of associtivity for the addition on the multiplicative monoid of fractions requires in the associativity of the original addition but no other properties . *) Definition commrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : commrng . Proof . intros . set ( R := eqrelcommrngfrac X S ) . set ( mult1 := commrngfracop2 X S ) . set ( add1 := commrngfracop1 X S ) . set ( uset := setquotinset R ) . apply ( commrngconstr add1 mult1 ) . split with ( commrngfracunit1 X S ) . split with ( commrngfracinv1 X S ) . apply ( commrngfracisinv1 X S ) . apply ( commrngfraccomm1 X S ) . apply ( pr2 ( abmonoidfrac ( rngmultabmonoid X ) S ) ) . apply ( commrngfraccomm2 X S ) . apply ( dirprodpair ( commrngfracldistr X S ) ( commrngfracrdistr X S ) ) . Defined . Definition prcommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : X -> S -> commrngfrac X S := fun x s => setquotpr _ ( dirprodpair x s ) . Lemma invertibilityincommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : forall a a' : S , isinvertible ( @op2 ( commrngfrac X S ) ) ( prcommrngfrac X S ( pr1 a ) a' ) . Proof . intros . apply ( invertibilityinabmonoidfrac ( rngmultabmonoid X ) S ) . Defined . (** **** Canonical homomorphism to the ring of fractions *) Definition tocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) ( x : X ) : commrngfrac X S := setquotpr _ ( dirprodpair x ( unel S ) ) . Lemma isbinop1funtocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @isbinopfun ( rngaddabgr X ) ( rngaddabgr ( commrngfrac X S ) ) ( tocommrngfrac X S ) . Proof . intros . unfold isbinopfun . intros x x' . change ( paths ( setquotpr _ ( dirprodpair ( x + x' ) ( unel S ) ) ) ( setquotpr ( eqrelcommrngfrac X S ) ( commrngfracop1int X S ( dirprodpair x ( unel S ) ) ( dirprodpair x' ( unel S ) ) ) ) ) . apply ( maponpaths ( setquotpr _ ) ) . unfold commrngfracop1int . simpl . apply pathsdirprod . rewrite ( rnglunax2 X _ ) . rewrite ( rnglunax2 X _ ) . apply idpath . change ( paths ( unel S ) ( op ( unel S ) ( unel S ) ) ) . apply ( pathsinv0 ( runax S _ ) ) . Defined . Opaque isbinop1funtocommrngfrac . Lemma isunital1funtocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : paths ( tocommrngfrac X S 0 ) 0 . Proof . intros. apply idpath . Defined . Opaque isunital1funtocommrngfrac . Definition isaddmonoidfuntocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @ismonoidfun ( rngaddabgr X ) ( rngaddabgr ( commrngfrac X S ) ) ( tocommrngfrac X S ) := dirprodpair ( isbinop1funtocommrngfrac X S ) ( isunital1funtocommrngfrac X S ) . Definition tocommrngfracandminus0 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) ( x : X ) : paths ( tocommrngfrac X S ( - x ) ) ( - tocommrngfrac X S x ) := grinvandmonoidfun _ _ ( isaddmonoidfuntocommrngfrac X S ) x . Definition tocommrngfracandminus ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) ( x y : X ) : paths ( tocommrngfrac X S ( x - y ) ) ( tocommrngfrac X S x - tocommrngfrac X S y ) . Proof . intros . rewrite ( ( isbinop1funtocommrngfrac X S x ( - y ) ) : paths (tocommrngfrac X S (x - y)) ( (tocommrngfrac X S x + tocommrngfrac X S ( - y ) ) ) ) . rewrite ( tocommrngfracandminus0 X S y ) . apply idpath . Defined . Opaque tocommrngfracandminus . Definition isbinop2funtocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @isbinopfun ( rngmultmonoid X ) ( rngmultmonoid ( commrngfrac X S ) ) ( tocommrngfrac X S ) := isbinopfuntoabmonoidfrac ( rngmultabmonoid X ) S . Opaque isbinop2funtocommrngfrac . Lemma isunital2funtocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : paths ( tocommrngfrac X S 1 ) 1 . Proof . intros. apply idpath . Defined . Opaque isunital2funtocommrngfrac . Definition ismultmonoidfuntocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @ismonoidfun ( rngmultmonoid X ) ( rngmultmonoid ( commrngfrac X S ) ) ( tocommrngfrac X S ) := dirprodpair ( isbinop2funtocommrngfrac X S ) ( isunital2funtocommrngfrac X S ) . Definition isrngfuntocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @isrngfun X ( commrngfrac X S ) ( tocommrngfrac X S ) := dirprodpair ( isaddmonoidfuntocommrngfrac X S ) ( ismultmonoidfuntocommrngfrac X S ) . (** **** Ring of fractions in the case when all elements which are being inverted are cancelable *) Definition hrelcommrngfrac0 ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) : hrel ( dirprod X S ) := fun xa yb : setdirprod X S => eqset ( ( pr1 xa ) * ( pr1 ( pr2 yb ) ) ) ( ( pr1 yb ) * ( pr1 ( pr2 xa ) ) ) . Lemma weqhrelhrel0commrngfrac ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) ( iscanc : forall a : S , isrcancelable ( @op2 X ) ( pr1carrier _ a ) ) ( xa xa' : dirprod X S ) : weq ( eqrelcommrngfrac X S xa xa' ) ( hrelcommrngfrac0 X S xa xa' ) . Proof . intros . unfold eqrelabmonoidfrac . unfold hrelabmonoidfrac . simpl . apply weqimplimpl . apply ( @hinhuniv _ ( eqset (pr1 xa * pr1 (pr2 xa')) (pr1 xa' * pr1 (pr2 xa)) ) ) . intro ae . destruct ae as [ a eq ] . apply ( invmaponpathsincl _ ( iscanc a ) _ _ eq ) . intro eq . apply hinhpr . split with ( unel S ) . rewrite ( rngrunax2 X ) . rewrite ( rngrunax2 X ) . apply eq . apply ( isapropishinh _ ) . apply ( setproperty X ) . Defined . Opaque weqhrelhrel0abmonoidfrac . Lemma isinclprcommrngfrac ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) ( iscanc : forall a : S , isrcancelable ( @op2 X ) ( pr1carrier _ a ) ) : forall a' : S , isincl ( fun x => prcommrngfrac X S x a' ) . Proof . intros . apply isinclbetweensets . apply ( setproperty X ) . apply ( setproperty ( commrngfrac X S ) ) . intros x x' . intro e . set ( e' := invweq ( weqpathsinsetquot ( eqrelcommrngfrac X S ) ( dirprodpair x a' ) ( dirprodpair x' a' ) ) e ) . set ( e'' := weqhrelhrel0commrngfrac X S iscanc ( dirprodpair _ _ ) ( dirprodpair _ _ ) e' ) . simpl in e'' . apply ( invmaponpathsincl _ ( iscanc a' ) ) . apply e'' . Defined . Definition isincltocommrngfrac ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) ( iscanc : forall a : S , isrcancelable ( @op2 X ) ( pr1carrier _ a ) ) : isincl ( tocommrngfrac X S ) := isinclprcommrngfrac X S iscanc ( unel S ) . Lemma isdeceqcommrngfrac ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) ( iscanc : forall a : S , isrcancelable ( @op2 X ) ( pr1carrier _ a ) ) ( is : isdeceq X ) : isdeceq ( commrngfrac X S ) . Proof . intros . apply ( isdeceqsetquot ( eqrelcommrngfrac X S ) ) . intros xa xa' . apply ( isdecpropweqb ( weqhrelhrel0commrngfrac X S iscanc xa xa' ) ) . apply isdecpropif . unfold isaprop . simpl . set ( int := setproperty X (pr1 xa * pr1 (pr2 xa')) (pr1 xa' * pr1 (pr2 xa))) . simpl in int . apply int . unfold hrelcommrngfrac0 . unfold eqset . simpl . apply ( is _ _ ) . Defined . (** **** Relations similar to "greater" or "greater or equal" on the rings of fractions *) Lemma ispartbinopcommrngfracgt ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) { R : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) R ) ( is1 : isrngmultgt X R ) ( is2 : forall c : X , S c -> R c 0 ) : @ispartbinophrel ( rngmultabmonoid X ) S R . Proof . intros . split . intros a b c s rab . apply ( isrngmultgttoislrngmultgt X is0 is1 _ _ _ ( is2 c s ) rab ) . intros a b c s rab . apply ( isrngmultgttoisrrngmultgt X is0 is1 _ _ _ ( is2 c s ) rab ) . Defined . Definition commrngfracgt ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) { R : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) R ) ( is1 : isrngmultgt X R ) ( is2 : forall c : X , S c -> R c 0 ) : hrel ( commrngfrac X S ) := abmonoidfracrel ( rngmultabmonoid X ) S ( ispartbinopcommrngfracgt X S is0 is1 is2 ) . Lemma isrngmultcommrngfracgt ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) { R : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) R ) ( is1 : isrngmultgt X R ) ( is2 : forall c : X , S c -> R c 0 ) : isrngmultgt ( commrngfrac X S ) ( commrngfracgt X S is0 is1 is2 ) . Proof . intros . set ( rer2 := ( abmonoidrer ( rngmultabmonoid X )) : forall a b c d : X , paths ( ( a * b ) * ( c * d ) ) ( ( a * c ) * ( b * d ) ) ) . apply islrngmultgttoisrngmultgt . assert ( int : forall a b c : (commrngfrac X S) , isaprop ( commrngfracgt X S is0 is1 is2 c 0 -> commrngfracgt X S is0 is1 is2 a b -> commrngfracgt X S is0 is1 is2 (c * a) (c * b) ) ) . intros a b c . apply impred . intro . apply impred . intro . apply ( pr2 _ ) . apply ( setquotuniv3prop _ ( fun a b c => hProppair _ ( int a b c ) ) ) . intros xa1 xa2 xa3 . change ( abmonoidfracrelint ( rngmultabmonoid X ) S R xa3 ( dirprodpair 0 ( unel S ) ) -> abmonoidfracrelint ( rngmultabmonoid X ) S R xa1 xa2 -> abmonoidfracrelint ( rngmultabmonoid X ) S R ( commrngfracop2int X S xa3 xa1 ) ( commrngfracop2int X S xa3 xa2 ) ) . simpl . apply hinhfun2 . intros t21 t22 . set ( c1s := pr1 t21 ) . set ( c1 := pr1 c1s ) . set ( r1 := pr2 t21 ) . set ( c2s := pr1 t22 ) . set ( c2 := pr1 c2s ) . set ( r2 := pr2 t22 ) . set ( x1 := pr1 xa1 ) . set ( a1 := pr1 ( pr2 xa1 ) ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr1 ( pr2 xa2 ) ) . set ( x3 := pr1 xa3 ) . set ( a3 := pr1 ( pr2 xa3 ) ) . split with ( @op S c1s c2s ) . change ( pr1 ( R ( x3 * x1 * ( a3 * a2 ) * ( c1 * c2 ) ) ( x3 * x2 * ( a3 * a1 ) * ( c1 * c2 ) ) ) ) . rewrite ( rngcomm2 X a3 a2 ) . rewrite ( rngcomm2 X a3 a1 ) . rewrite ( rngassoc2 X _ _ ( c1 * c2 ) ) . rewrite ( rngassoc2 X ( x3 * x2 ) _ ( c1 * c2 ) ) . rewrite ( rer2 _ a3 c1 _ ) . rewrite ( rer2 _ a3 c1 _ ) . rewrite ( rngcomm2 X a2 c1 ) . rewrite ( rngcomm2 X a1 c1 ) . rewrite ( pathsinv0 ( rngassoc2 X ( x3 * x1 ) _ _ ) ) . rewrite ( pathsinv0 ( rngassoc2 X ( x3 * x2 ) _ _ ) ) . rewrite ( rer2 _ x1 c1 _ ) . rewrite ( rer2 _ x2 c1 _ ) . rewrite ( rngcomm2 X a3 c2 ) . rewrite ( pathsinv0 ( rngassoc2 X _ c2 a3 ) ) . rewrite ( pathsinv0 ( rngassoc2 X _ c2 _ ) ) . apply ( ( isrngmultgttoisrrngmultgt X is0 is1 ) _ _ _ ( is2 _ ( pr2 ( pr2 xa3 ) ) ) ) . rewrite ( rngassoc2 X _ _ c2 ) . rewrite ( rngassoc2 X _ ( x2 * a1 ) c2 ) . simpl in r1 . clearbody r1 . simpl in r2 . clearbody r2 . change ( pr1 ( R ( x3 * 1 * c1 ) ( 0 * a3 * c1 ) ) ) in r1 . rewrite ( rngrunax2 _ _ ) in r1 . rewrite ( rngmult0x X _ ) in r1 . rewrite ( rngmult0x X _ ) in r1 . apply ( ( isrngmultgttoislrngmultgt X is0 is1 ) _ _ _ r1 r2 ) . Defined . Opaque isrngmultcommrngfracgt . Lemma isrngaddcommrngfracgt ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) { R : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) R ) ( is1 : isrngmultgt X R ) ( is2 : forall c : X , S c -> R c 0 ) : @isbinophrel ( rngaddabgr ( commrngfrac X S ) ) ( commrngfracgt X S is0 is1 is2 ) . Proof . intros . set ( rer2 := ( abmonoidrer ( rngmultabmonoid X )) : forall a b c d : X , paths ( ( a * b ) * ( c * d ) ) ( ( a * c ) * ( b * d ) ) ) . apply isbinophrelif . intros a b . apply ( rngcomm1 ( commrngfrac X S ) a b ) . assert ( int : forall a b c : rngaddabgr (commrngfrac X S) , isaprop ( commrngfracgt X S is0 is1 is2 a b -> commrngfracgt X S is0 is1 is2 (op c a) (op c b) ) ) . intros a b c . apply impred . intro . apply ( pr2 _ ) . apply ( setquotuniv3prop _ ( fun a b c => hProppair _ ( int a b c ) ) ) . intros xa1 xa2 xa3 . change ( abmonoidfracrelint ( rngmultabmonoid X ) S R xa1 xa2 -> abmonoidfracrelint ( rngmultabmonoid X ) S R ( commrngfracop1int X S xa3 xa1 ) ( commrngfracop1int X S xa3 xa2 ) ) . simpl . apply hinhfun . intro t2 . set ( c0s := pr1 t2 ) . set ( c0 := pr1 c0s ) . set ( r := pr2 t2 ) . split with c0s . set ( x1 := pr1 xa1 ) . set ( a1 := pr1 ( pr2 xa1 ) ) . set ( x2 := pr1 xa2 ) . set ( a2 := pr1 ( pr2 xa2 ) ) . set ( x3 := pr1 xa3 ) . set ( a3 := pr1 ( pr2 xa3 ) ) . change ( pr1 ( R ( ( a1 * x3 + a3 * x1 ) * ( a3 * a2 ) * c0 ) ( ( a2 * x3 + a3 * x2 ) * ( a3 * a1 ) * c0 ) ) ) . rewrite ( rngassoc2 X _ _ c0 ) . rewrite ( rngassoc2 X _ ( a3 * _ ) c0 ) . rewrite ( rngrdistr X _ _ _ ) . rewrite ( rngrdistr X _ _ _ ) . rewrite ( rer2 _ x3 _ _ ) . rewrite ( rer2 _ x3 _ _ ) . rewrite ( rngcomm2 X a3 a2 ) . rewrite ( rngcomm2 X a3 a1 ) . rewrite ( pathsinv0 ( rngassoc2 X a1 a2 a3 ) ) . rewrite ( pathsinv0 ( rngassoc2 X a2 a1 a3 ) ) . rewrite ( rngcomm2 X a1 a2 ) . apply ( ( pr1 is0 ) _ _ _ ) . rewrite ( rngcomm2 X a2 a3 ) . rewrite ( rngcomm2 X a1 a3 ) . rewrite ( rngassoc2 X a3 a2 c0 ) . rewrite ( rngassoc2 X a3 a1 c0 ) . rewrite ( rer2 _ x1 a3 _ ) . rewrite ( rer2 _ x2 a3 _ ) . rewrite ( pathsinv0 ( rngassoc2 X x1 _ _ ) ) . rewrite ( pathsinv0 ( rngassoc2 X x2 _ _ ) ) . apply ( ( isrngmultgttoislrngmultgt X is0 is1 ) _ _ _ ( is2 _ ( pr2 ( @op S ( pr2 xa3 ) ( pr2 xa3 ) ) ) ) r ) . Defined . Opaque isrngaddcommrngfracgt . Definition isdeccommrngfracgt ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) { R : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) R ) ( is1 : isrngmultgt X R ) ( is2 : forall c : X , S c -> R c 0 ) ( is' : @ispartinvbinophrel ( rngmultabmonoid X ) S R ) ( isd : isdecrel R ) : isdecrel ( commrngfracgt X S is0 is1 is2 ) . Proof . intros . apply ( isdecabmonoidfracrel ( rngmultabmonoid X ) S ( ispartbinopcommrngfracgt X S is0 is1 is2 ) is' isd ) . Defined . (** **** Realations and the canonical homomorphism to the ring of fractions *) Definition iscomptocommrngfrac ( X : commrng ) ( S : @submonoids ( rngmultabmonoid X ) ) { L : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) L ) ( is1 : isrngmultgt X L ) ( is2 : forall c : X , S c -> L c 0 ) : iscomprelrelfun L ( commrngfracgt X S is0 is1 is2 ) ( tocommrngfrac X S ) := iscomptoabmonoidfrac ( rngmultabmonoid X ) S ( ispartbinopcommrngfracgt X S is0 is1 is2 ) . Opaque iscomptocommrngfrac . Close Scope rng_scope . (* End of the file algebra1c.v *) Voevodsky-Coq/hlevel2/._algebra1d.v000777 000765 000024 00000000256 12346040720 017776 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/algebra1d.v000777 000765 000024 00000123705 12346040720 017566 0ustar00nicolastaff000000 000000 (** * 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 ".." as Foundations. Require Export Foundations.hlevel2.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 *) Voevodsky-Coq/hlevel2/._finitesets.v000777 000765 000024 00000000256 12346040720 020331 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/finitesets.v000777 000765 000024 00000037266 12346040720 020127 0ustar00nicolastaff000000 000000 (** * Finite sets. Vladimir Voevodsky . Apr. - Sep. 2011. This file contains the definition and main properties of finite sets. At the end of the file there are several elementary examples which are used as test cases to check that our constructions do not prevent Coq from normalizing terms of type nat to numerals. *) (** ** Preambule *) (** Settings *) Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *) (** Imports. *) Add LoadPath ".." as Foundations. Require Export Foundations.hlevel2.stnfsets . (** ** Sets with a given number of elements. *) (** *** Structure of a set with [ n ] elements on [ X ] defined as a term in [ weq ( stn n ) X ] *) Definition nelstruct ( n : nat ) ( X : UU ) := weq ( stn n ) X . Definition nelstructonstn ( n : nat ) : nelstruct n ( stn n ) := idweq _ . Definition nelstructweqf { X Y : UU } { n : nat } ( w : weq X Y ) ( sx : nelstruct n X ) : nelstruct n Y := weqcomp sx w . Definition nelstructweqb { X Y : UU } { n : nat } ( w : weq X Y ) ( sy : nelstruct n Y ) : nelstruct n X := weqcomp sy ( invweq w ) . Definition nelstructonempty : nelstruct 0 empty := weqstn0toempty . Definition nelstructonempty2 { X : UU } ( is : neg X ) : nelstruct 0 X := weqcomp weqstn0toempty ( invweq ( weqtoempty is ) ) . Definition nelstructonunit : nelstruct 1 unit := weqstn1tounit . Definition nelstructoncontr { X : UU } ( is : iscontr X ) : nelstruct 1 X := weqcomp weqstn1tounit ( invweq ( weqcontrtounit is ) ) . Definition nelstructonbool : nelstruct 2 bool := weqstn2tobool . Definition nelstructoncoprodwithunit { X : UU } { n : nat } ( sx : nelstruct n X ) : nelstruct ( S n ) ( coprod X unit ) := weqcomp ( invweq ( weqdnicoprod n ( lastelement n ) ) ) ( weqcoprodf sx ( idweq unit ) ) . Definition nelstructoncompl { X : UU } { n : nat } ( x : X ) ( sx : nelstruct ( S n ) X ) : nelstruct n ( compl X x ) := weqcomp ( weqdnicompl n ( invweq sx x ) ) ( invweq ( weqoncompl ( invweq sx ) x ) ) . Definition nelstructoncoprod { X Y : UU } { n m : nat } ( sx : nelstruct n X ) ( sy : nelstruct m Y ) : nelstruct ( n + m ) ( coprod X Y ) := weqcomp ( invweq ( weqfromcoprodofstn n m ) ) ( weqcoprodf sx sy ) . Definition nelstructontotal2 { X : UU } ( P : X -> UU ) ( f : X -> nat ) { n : nat } ( sx : nelstruct n X ) ( fs : forall x : X , nelstruct ( f x ) ( P x ) ) : nelstruct ( stnsum ( funcomp ( pr1 sx ) f ) ) ( total2 P ) := weqcomp ( invweq ( weqstnsum ( funcomp ( pr1 sx ) P ) ( funcomp ( pr1 sx ) f ) ( fun i : stn n => fs ( ( pr1 sx ) i ) ) ) ) ( weqfp sx P ) . Definition nelstructondirprod { X Y : UU } { n m : nat } ( sx : nelstruct n X ) ( sy : nelstruct m Y ) : nelstruct ( n * m ) ( dirprod X Y ) := weqcomp ( invweq ( weqfromprodofstn n m ) ) ( weqdirprodf sx sy ) . (** For a generalization of [ weqfromdecsubsetofstn ] see below *) Definition nelstructonfun { X Y : UU } { n m : nat } ( sx : nelstruct n X ) ( sy : nelstruct m Y ) : nelstruct ( natpower m n ) ( X -> Y ) := weqcomp ( invweq ( weqfromfunstntostn n m ) ) ( weqcomp ( weqbfun _ ( invweq sx ) ) ( weqffun _ sy ) ) . Definition nelstructonforall { X : UU } ( P : X -> UU ) ( f : X -> nat ) { n : nat } ( sx : nelstruct n X ) ( fs : forall x : X , nelstruct ( f x ) ( P x ) ) : nelstruct ( stnprod ( funcomp ( pr1 sx ) f ) ) ( forall x : X , P x ) := invweq ( weqcomp ( weqonsecbase P sx ) ( weqstnprod ( funcomp ( pr1 sx ) P ) ( funcomp ( pr1 sx ) f ) ( fun i : stn n => fs ( ( pr1 sx ) i ) ) ) ) . Definition nelstructonweq { X : UU } { n : nat } ( sx : nelstruct n X ) : nelstruct ( factorial n ) ( weq X X ) := weqcomp ( invweq ( weqfromweqstntostn n ) ) ( weqcomp ( weqbweq _ ( invweq sx ) ) ( weqfweq _ sx ) ) . (** *** The property of [ X ] to have [ n ] elements *) Definition isofnel ( n : nat ) ( X : UU ) : hProp := ishinh ( weq ( stn n ) X ) . Lemma isofneluniv { n : nat} { X : UU } ( P : hProp ) : ( ( nelstruct n X ) -> P ) -> ( isofnel n X -> P ) . Proof. intros. apply @hinhuniv with ( weq ( stn n ) X ) . assumption. assumption. Defined. Definition isofnelstn ( n : nat ) : isofnel n ( stn n ) := hinhpr _ ( nelstructonstn n ) . Definition isofnelweqf { X Y : UU } { n : nat } ( w : weq X Y ) ( sx : isofnel n X ) : isofnel n Y := hinhfun ( fun sx0 : _ => nelstructweqf w sx0 ) sx . Definition isofnelweqb { X Y : UU } { n : nat } ( w : weq X Y ) ( sy : isofnel n Y ) : isofnel n X := hinhfun ( fun sy0 : _ => nelstructweqb w sy0 ) sy . Definition isofnelempty : isofnel 0 empty := hinhpr _ nelstructonempty . Definition isofnelempty2 { X : UU } ( is : neg X ) : isofnel 0 X := hinhpr _ ( nelstructonempty2 is ) . Definition isofnelunit : isofnel 1 unit := hinhpr _ nelstructonunit . Definition isofnelcontr { X : UU } ( is : iscontr X ) : isofnel 1 X := hinhpr _ ( nelstructoncontr is ) . Definition isofnelbool : isofnel 2 bool := hinhpr _ nelstructonbool . Definition isofnelcoprodwithunit { X : UU } { n : nat } ( sx : isofnel n X ) : isofnel ( S n ) ( coprod X unit ) := hinhfun ( fun sx0 : _ => nelstructoncoprodwithunit sx0 ) sx . Definition isofnelcompl { X : UU } { n : nat } ( x : X ) ( sx : isofnel ( S n ) X ) : isofnel n ( compl X x ) := hinhfun ( fun sx0 : _ => nelstructoncompl x sx0 ) sx . Definition isofnelcoprod { X Y : UU } { n m : nat } ( sx : isofnel n X ) ( sy : isofnel m Y ) : isofnel ( n + m ) ( coprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => nelstructoncoprod sx0 sy0 ) sx sy . (** For a result corresponding to [ nelstructontotal2 ] see below . *) Definition isofnelondirprod { X Y : UU } { n m : nat } ( sx : isofnel n X ) ( sy : isofnel m Y ) : isofnel ( n * m ) ( dirprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => nelstructondirprod sx0 sy0 ) sx sy . Definition isofnelonfun { X Y : UU } { n m : nat } ( sx : isofnel n X ) ( sy : isofnel m Y ) : isofnel ( natpower m n ) ( X -> Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => nelstructonfun sx0 sy0 ) sx sy . (** For a result corresponding to [ nelstructonforall ] see below . *) Definition isofnelonweq { X : UU } { n : nat } ( sx : isofnel n X ) : isofnel ( factorial n ) ( weq X X ) := hinhfun ( fun sx0 : _ => nelstructonweq sx0 ) sx . (** ** General finite sets. *) (** *** Finite structure on a type [ X ] defined as a pair [ ( n , w ) ] where [ n : nat ] and [ w : weq ( stn n ) X ] *) Definition finstruct ( X : UU ) := total2 ( fun n : nat => nelstruct n X ) . Definition fintructpair ( X : UU ) := tpair ( fun n : nat => nelstruct n X ) . Definition finstructonstn ( n : nat ) : finstruct ( stn n ) := tpair _ n ( nelstructonstn n ) . Definition finstructweqf { X Y : UU } ( w : weq X Y ) ( sx : finstruct X ) : finstruct Y := tpair _ ( pr1 sx ) ( nelstructweqf w ( pr2 sx ) ) . Definition finstructweqb { X Y : UU } ( w : weq X Y ) ( sy : finstruct Y ) : finstruct X := tpair _ ( pr1 sy ) ( nelstructweqb w ( pr2 sy ) ) . Definition finstructonempty : finstruct empty := tpair _ 0 nelstructonempty . Definition finstructonempty2 { X : UU } ( is : neg X ) : finstruct X := tpair _ 0 ( nelstructonempty2 is ) . Definition finstructonunit : finstruct unit := tpair _ 1 nelstructonunit . Definition finstructoncontr { X : UU } ( is : iscontr X ) : finstruct X := tpair _ 1 ( nelstructoncontr is ) . (** It is not difficult to show that a direct summand of a finite set is a finite set . As a corrolary it follows that a proposition ( a type of h-level 1 ) is a finite set if and only if it is decidable . *) Definition finstructonbool : finstruct bool := tpair _ 2 nelstructonbool . Definition finstructoncoprodwithunit { X : UU } ( sx : finstruct X ) : finstruct ( coprod X unit ) := tpair _ ( S ( pr1 sx ) ) ( nelstructoncoprodwithunit ( pr2 sx ) ) . Definition finstructoncompl { X : UU } ( x : X ) ( sx : finstruct X ) : finstruct ( compl X x ) . Proof . intros . unfold finstruct . unfold finstruct in sx . destruct sx as [ n w ] . destruct n as [ | n ] . destruct ( negstn0 ( invweq w x ) ) . split with n . apply ( nelstructoncompl x w ) . Defined . Definition finstructoncoprod { X Y : UU } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( coprod X Y ) := tpair _ ( ( pr1 sx ) + ( pr1 sy ) ) ( nelstructoncoprod ( pr2 sx ) ( pr2 sy ) ) . Definition finstructontotal2 { X : UU } ( P : X -> UU ) ( sx : finstruct X ) ( fs : forall x : X , finstruct ( P x ) ) : finstruct ( total2 P ) := tpair _ ( stnsum ( funcomp ( pr1 ( pr2 sx ) ) ( fun x : X => pr1 ( fs x ) ) ) ) ( nelstructontotal2 P ( fun x : X => pr1 ( fs x ) ) ( pr2 sx ) ( fun x : X => pr2 ( fs x ) ) ) . Definition finstructondirprod { X Y : UU } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( dirprod X Y ) := tpair _ ( ( pr1 sx ) * ( pr1 sy ) ) ( nelstructondirprod ( pr2 sx ) ( pr2 sy ) ) . Definition finstructondecsubset { X : UU } ( f : X -> bool ) ( sx : finstruct X ) : finstruct ( hfiber f true ) := tpair _ ( pr1 ( weqfromdecsubsetofstn ( funcomp ( pr1 ( pr2 sx ) ) f ) ) ) ( weqcomp ( invweq ( pr2 ( weqfromdecsubsetofstn ( funcomp ( pr1 ( pr2 sx ) ) f ) ) ) ) ( weqhfibersgwtog ( pr2 sx ) f true ) ) . Definition finstructonfun { X Y : UU } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( X -> Y ) := tpair _ ( natpower ( pr1 sy ) ( pr1 sx ) ) ( nelstructonfun ( pr2 sx ) ( pr2 sy ) ) . Definition finstructonforall { X : UU } ( P : X -> UU ) ( sx : finstruct X ) ( fs : forall x : X , finstruct ( P x ) ) : finstruct ( forall x : X , P x ) := tpair _ ( stnprod ( funcomp ( pr1 ( pr2 sx ) ) ( fun x : X => pr1 ( fs x ) ) ) ) ( nelstructonforall P ( fun x : X => pr1 ( fs x ) ) ( pr2 sx ) ( fun x : X => pr2 ( fs x ) ) ) . Definition finstructonweq { X : UU } ( sx : finstruct X ) : finstruct ( weq X X ) := tpair _ ( factorial ( pr1 sx ) ) ( nelstructonweq ( pr2 sx ) ) . (** *** The property of being finite *) Definition isfinite ( X : UU ) := ishinh ( finstruct X ) . Definition fincard { X : UU } ( is : isfinite X ) : nat . Proof . intros . set ( int := carrier ( fun n : nat => isofnel n X ) ) . set ( f1 := ( fun nw : finstruct X => tpair ( fun n : nat => isofnel n X ) ( pr1 nw ) ( hinhpr _ ( pr2 nw ) ) ) : finstruct X -> int ) . assert ( isp : isaprop int ) . apply isapropsubtype . intros x1 x2 is1 is2 . apply ( @hinhuniv2 ( nelstruct x1 X ) ( nelstruct x2 X ) ( hProppair _ ( isasetnat x1 x2 ) ) ) . intros sx1 sx2 . apply ( weqtoeqstn x1 x2 ( weqcomp sx1 ( invweq sx2 ) ) ) . apply is1 . apply is2 . apply ( @hinhuniv _ ( hProppair _ isp ) f1 ) . apply is . Defined . Theorem ischoicebasefiniteset { X : UU } ( is : isfinite X ) : ischoicebase X . Proof . intros . apply ( @hinhuniv ( finstruct X ) ( ischoicebase X ) ) . intro nw . destruct nw as [ n w ] . apply ( ischoicebaseweqf w ( ischoicebasestn n ) ) . apply is . Defined . Definition isfinitestn ( n : nat ) : isfinite ( stn n ) := hinhpr _ ( finstructonstn n ) . Definition isfiniteweqf { X Y : UU } ( w : weq X Y ) ( sx : isfinite X ) : isfinite Y := hinhfun ( fun sx0 : _ => finstructweqf w sx0 ) sx . Definition isfiniteweqb { X Y : UU } ( w : weq X Y ) ( sy : isfinite Y ) : isfinite X := hinhfun ( fun sy0 : _ => finstructweqb w sy0 ) sy . Definition isfiniteempty : isfinite empty := hinhpr _ finstructonempty . Definition isfiniteempty2 { X : UU } ( is : neg X ) : isfinite X := hinhpr _ ( finstructonempty2 is ) . Definition isfiniteunit : isfinite unit := hinhpr _ finstructonunit . Definition isfinitecontr { X : UU } ( is : iscontr X ) : isfinite X := hinhpr _ ( finstructoncontr is ) . Definition isfinitebool : isfinite bool := hinhpr _ finstructonbool . Definition isfinitecoprodwithunit { X : UU } ( sx : isfinite X ) : isfinite ( coprod X unit ) := hinhfun ( fun sx0 : _ => finstructoncoprodwithunit sx0 ) sx . Definition isfinitecompl { X : UU } ( x : X ) ( sx : isfinite X ) : isfinite ( compl X x ) := hinhfun ( fun sx0 : _ => finstructoncompl x sx0 ) sx . Definition isfinitecoprod { X Y : UU } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( coprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructoncoprod sx0 sy0 ) sx sy . Definition isfinitetotal2 { X : UU } ( P : X -> UU ) ( sx : isfinite X ) ( fs : forall x : X , isfinite ( P x ) ) : isfinite ( total2 P ) . Proof . intros . set ( fs' := ischoicebasefiniteset sx _ fs ) . apply ( hinhfun2 ( fun fx0 : forall x : X , finstruct ( P x ) => fun sx0 : _ => finstructontotal2 P sx0 fx0 ) fs' sx ) . Defined . Definition isfinitedirprod { X Y : UU } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( dirprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructondirprod sx0 sy0 ) sx sy . Definition isfinitedecsubset { X : UU } ( f : X -> bool ) ( sx : isfinite X ) : isfinite ( hfiber f true ) := hinhfun ( fun sx0 : _ => finstructondecsubset f sx0 ) sx . Definition isfinitefun { X Y : UU } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( X -> Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructonfun sx0 sy0 ) sx sy . Definition isfiniteforall { X : UU } ( P : X -> UU ) ( sx : isfinite X ) ( fs : forall x : X , isfinite ( P x ) ) : isfinite ( forall x : X , P x ) . Proof . intros . set ( fs' := ischoicebasefiniteset sx _ fs ) . apply ( hinhfun2 ( fun fx0 : forall x : X , finstruct ( P x ) => fun sx0 : _ => finstructonforall P sx0 fx0 ) fs' sx ) . Defined . Definition isfiniteweq { X : UU } ( sx : isfinite X ) : isfinite ( weq X X ) := hinhfun ( fun sx0 : _ => finstructonweq sx0 ) sx . (* (* The cardinality of finite sets using double negation and decidability of equality in nat. *) Definition carddneg ( X : UU ) (is: isfinite X): nat:= pr1 (isfiniteimplisfinite0 X is). Definition preweq ( X : UU ) (is: isfinite X): isofnel (carddneg X is) X. Proof. intros X is X0. set (c:= carddneg X is). set (dnw:= pr2 (isfiniteimplisfinite0 X is)). simpl in dnw. change (pr1 nat (fun n : nat => isofnel0 n X) (isfiniteimplisfinite0 X is)) with c in dnw. assert (f: dirprod (finitestruct X) (dneg (weq (stn c) X)) -> weq (stn c) X). intro H. destruct H as [ t x ]. destruct t as [ t x0 ]. assert (dw: dneg (weq (stn t) (stn c))). set (ff:= fun ab:dirprod (weq (stn t) X)(weq (stn c) X) => weqcomp _ _ _ (pr1 ab) (invweq (pr2 ab))). apply (dnegf _ _ ff (inhdnegand _ _ (todneg _ x0) x)). assert (e:paths t c). apply (stnsdnegweqtoeq _ _ dw). clear dnw. destruct e. assumption. unfold isofnel. apply (hinhfun _ _ f (hinhand (finitestruct X) _ is (hinhpr _ dnw))). Defined. *) (* to be completed Theorem carddnegweqf (X Y:UU)(f: X -> Y)(isw:isweq f)(isx: isfinite X): paths (carddneg _ isx) (carddneg _ (isfiniteweqf _ _ _ isw isx)). Proof. intros. *) (* The cardinality of finite sets defined using the "impredicative" ishinh *) (** ** Test computations. *) (*Eval compute in carddneg _ (isfinitedirprod _ _ (isfinitestn (S (S (S (S O))))) (isfinitestn (S (S (S O))))).*) Eval compute in fincard (isfiniteempty). Eval compute in fincard (isfiniteunit). Eval compute in fincard (isfinitebool). (*Eval lazy in (pr1 (finitestructcomplement _ (dirprodpair _ _ tt tt) (finitestructdirprod _ _ (finitestructunit) (finitestructunit)))).*) Eval compute in fincard (isfinitecompl true isfinitebool). Eval compute in fincard (isfinitedirprod isfinitebool isfinitebool). Eval compute in fincard (isfinitedirprod isfinitebool (isfinitedirprod isfinitebool isfinitebool)). Eval lazy in fincard (isfinitecompl (ii1 tt) (isfinitecoprod (isfiniteunit) (isfinitebool))). Eval lazy in fincard (isfinitecompl (ii1 tt) (isfinitecoprod (isfiniteunit) (isfinitebool))). Eval lazy in fincard (isfinitecompl (dirprodpair tt tt) (isfinitedirprod isfiniteunit isfiniteunit)). Eval lazy in fincard (isfinitecompl (dirprodpair true (dirprodpair true false)) (isfinitedirprod (isfinitebool) (isfinitedirprod (isfinitebool) (isfinitebool)))). Eval lazy in fincard ( isfiniteweq ( isfinitedirprod ( isfinitedirprod isfinitebool isfinitebool ) isfinitebool ) ) . (* End of the file finitesets.v *) Voevodsky-Coq/hlevel2/._hnat.v000777 000765 000024 00000000256 12346040720 017106 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/hnat.v000777 000765 000024 00000203611 12346040720 016671 0ustar00nicolastaff000000 000000 (** * Natural numbers and their properties. Vladimir Voevodsky . Apr. - Sep. 2011 This file contains the formulations and proofs of general properties of natural numbers from the univalent perspecive. *) (** ** Preambule *) (** Settings *) Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *) (** Imports. *) Add LoadPath ".." as Foundations . Require Export Foundations.hlevel2.algebra1d . (** To up-stream files *) (** ** Equality on [ nat ] *) (** *** Basic properties of [ paths ] on [ nat ] and the proofs of [ isdeceq ] and [ isaset ] for [ nat ] . *) Lemma negpaths0sx ( x : nat ) : neg ( paths O (S x) ) . Proof. intro. set (f:= fun n : nat => match n with O => true | S m => false end ) . apply ( negf ( @maponpaths _ _ f 0 ( S x ) ) nopathstruetofalse ) . Defined. Lemma negpathssx0 ( x : nat ) : neg ( paths (S x) O ) . Proof. intros x X. apply (negpaths0sx x (pathsinv0 X)). Defined. Lemma invmaponpathsS ( n m : nat ) : paths ( S n ) ( S m ) -> paths n m . Proof. intros n m e . set ( f := fun n : nat => match n with O => O | S m => m end ) . apply ( @maponpaths _ _ f ( S n ) ( S m ) e ) . Defined. Lemma noeqinjS ( x x' : nat ) : neg ( paths x x' ) -> neg ( paths (S x) (S x') ) . Proof. intros x x'. apply ( negf ( invmaponpathsS x x' ) ) . Defined. Definition isdeceqnat: isdeceq nat. Proof. unfold isdeceq. intro x . induction x as [ | x IHx ] . intro x' . destruct x'. apply ( ii1 ( idpath O ) ) . apply ( ii2 ( negpaths0sx x' ) ) . intro x' . destruct x'. apply ( ii2 (negpathssx0 x ) ) . destruct ( IHx x' ) as [ p | e ]. apply ( ii1 ( maponpaths S p ) ) . apply ( ii2 ( noeqinjS _ _ e ) ) . Defined . Definition isisolatedn ( n : nat ) : isisolated _ n . Proof. intro. unfold isisolated . intro x' . apply isdeceqnat . Defined. Theorem isasetnat: isaset nat. Proof. apply (isasetifdeceq _ isdeceqnat). Defined. Definition natset : hSet := hSetpair _ isasetnat . (* Canonical Structure natset . *) Definition nateq ( x y : nat ) : hProp := hProppair ( paths x y ) ( isasetnat _ _ ) . Definition isdecrelnateq : isdecrel nateq := fun a b => isdeceqnat a b . Definition natdeceq : decrel nat := decrelpair isdecrelnateq . (* Canonical Structure natdeceq. *) Definition natbooleq := decreltobrel natdeceq . Definition natneq ( x y : nat ) : hProp := hProppair ( neg ( paths x y ) ) ( isapropneg _ ) . Definition isdecrelnatneq : isdecrel natneq := isdecnegrel _ isdecrelnateq . Definition natdecneq : decrel nat := decrelpair isdecrelnatneq . (* Canonical Structure natdecneq. *) Definition natboolneq := decreltobrel natdecneq . (** *** [ S : nat -> nat ] is a decidable inclusion . *) Theorem isinclS : isincl S . Proof. apply ( isinclbetweensets S isasetnat isasetnat invmaponpathsS ) . Defined . Theorem isdecinclS : isdecincl S . Proof. intro n . apply isdecpropif . apply ( isinclS n ) . destruct n as [ | n ] . assert ( nh : neg ( hfiber S 0 ) ) . intro hf . destruct hf as [ m e ] . apply ( negpathssx0 _ e ) . apply ( ii2 nh ) . apply ( ii1 ( hfiberpair _ n ( idpath _ ) ) ) . Defined . (** ** Inequalities on [ nat ] . *) (** *** Boolean "less or equal" and "greater or equal" on [ nat ] . *) Fixpoint natgtb (n m : nat) : bool := match n , m with | S n , S m => natgtb n m | O, _ => false | _, _ => true end. (** *** Semi-boolean "greater" on [ nat ] or [ natgth ] 1. Note that due to its definition [ natgth ] automatically has the property that [ natgth n m <-> natgth ( S n ) ( S m ) ] and the same applies to all other inequalities defined in this section. 2. We choose "greater" as the root relation from which we define all other relations on [ nat ] because it is more natural to extend "greater" to integers and then to rationals than it is to extend "less". *) Definition natgth ( n m : nat ) := hProppair ( paths ( natgtb n m ) true ) ( isasetbool _ _ ) . Lemma negnatgth0n ( n : nat ) : neg ( natgth 0 n ) . Proof. intro n . simpl . intro np . apply ( nopathsfalsetotrue np ) . Defined . Lemma natgthsnn ( n : nat ) : natgth ( S n ) n . Proof . intro . induction n as [ | n IHn ] . simpl . apply idpath . apply IHn . Defined . Lemma natgthsn0 ( n : nat ) : natgth ( S n ) 0 . Proof . intro . simpl . apply idpath . Defined . Lemma negnatgth0tois0 ( n : nat ) ( ng : neg ( natgth n 0 ) ) : paths n 0 . Proof . intro. destruct n as [ | n ] . intro. apply idpath. intro ng . destruct ( ng ( natgthsn0 _ ) ) . Defined . Lemma natneq0togth0 ( n : nat ) ( ne : neg ( paths n 0 ) ) : natgth n 0 . Proof . intros . destruct n as [ | n ] . destruct ( ne ( idpath _ ) ) . apply natgthsn0 . Defined . Lemma nat1gthtois0 ( n : nat ) ( g : natgth 1 n ) : paths n 0 . Proof . intro . destruct n as [ | n ] . intro . apply idpath . intro x . destruct ( negnatgth0n n x ) . Defined . Lemma istransnatgth ( n m k : nat ) : natgth n m -> natgth m k -> natgth n k . Proof. intro. induction n as [ | n IHn ] . intros m k g . destruct ( negnatgth0n _ g ) . intro m . destruct m as [ | m ] . intros k g g' . destruct ( negnatgth0n _ g' ) . intro k . destruct k as [ | k ] . intros . apply natgthsn0 . apply ( IHn m k ) . Defined. Lemma isirreflnatgth ( n : nat ) : neg ( natgth n n ) . Proof. intro . induction n as [ | n IHn ] . apply ( negnatgth0n 0 ) . apply IHn . Defined . Notation negnatlthnn := isirreflnatgth . Lemma natgthtoneq ( n m : nat ) ( g : natgth n m ) : neg ( paths n m ) . Proof . intros . intro e . rewrite e in g . apply ( isirreflnatgth _ g ) . Defined . Lemma isasymmnatgth ( n m : nat ) : natgth n m -> natgth m n -> empty . Proof. intros n m is is' . apply ( isirreflnatgth n ( istransnatgth _ _ _ is is' ) ) . Defined . Lemma isantisymmnegnatgth ( n m : nat ) : neg ( natgth n m ) -> neg ( natgth m n ) -> paths n m . Proof . intro n . induction n as [ | n IHn ] . intros m ng0m ngm0 . apply ( pathsinv0 ( negnatgth0tois0 _ ngm0 ) ) . intro m . destruct m as [ | m ] . intros ngsn0 ng0sn . destruct ( ngsn0 ( natgthsn0 _ ) ) . intros ng1 ng2 . apply ( maponpaths S ( IHn m ng1 ng2 ) ) . Defined . Lemma isdecrelnatgth : isdecrel natgth . Proof. intros n m . apply ( isdeceqbool ( natgtb n m ) true ) . Defined . Definition natgthdec := decrelpair isdecrelnatgth . (* Canonical Structure natgthdec . *) Lemma isnegrelnatgth : isnegrel natgth . Proof . apply isdecreltoisnegrel . apply isdecrelnatgth . Defined . Lemma iscoantisymmnatgth ( n m : nat ) : neg ( natgth n m ) -> coprod ( natgth m n ) ( paths n m ) . Proof . apply isantisymmnegtoiscoantisymm . apply isdecrelnatgth . intros n m . apply isantisymmnegnatgth . Defined . Lemma iscotransnatgth ( n m k : nat ) : natgth n k -> hdisj ( natgth n m ) ( natgth m k ) . Proof . intros x y z gxz . destruct ( isdecrelnatgth x y ) as [ gxy | ngxy ] . apply ( hinhpr _ ( ii1 gxy ) ) . apply hinhpr . apply ii2 . destruct ( isdecrelnatgth y x ) as [ gyx | ngyx ] . apply ( istransnatgth _ _ _ gyx gxz ) . set ( e := isantisymmnegnatgth _ _ ngxy ngyx ) . rewrite e in gxz . apply gxz . Defined . (** *** Semi-boolean "less" on [ nat ] or [ natlth ] *) Definition natlth ( n m : nat ) := natgth m n . Definition negnatlthn0 ( n : nat ) : neg ( natlth n 0 ) := negnatgth0n n . Definition natlthnsn ( n : nat ) : natlth n ( S n ) := natgthsnn n . Definition negnat0lthtois0 ( n : nat ) ( nl : neg ( natlth 0 n ) ) : paths n 0 := negnatgth0tois0 n nl . Definition natneq0to0lth ( n : nat ) ( ne : neg ( paths n 0 ) ) : natlth 0 n := natneq0togth0 n ne . Definition natlth1tois0 ( n : nat ) ( l : natlth n 1 ) : paths n 0 := nat1gthtois0 _ l . Definition istransnatlth ( n m k : nat ) : natlth n m -> natlth m k -> natlth n k := fun lnm lmk => istransnatgth _ _ _ lmk lnm . Definition isirreflnatlth ( n : nat ) : neg ( natlth n n ) := isirreflnatgth n . Notation negnatgthnn := isirreflnatlth . Lemma natlthtoneq ( n m : nat ) ( g : natlth n m ) : neg ( paths n m ) . Proof . intros . intro e . rewrite e in g . apply ( isirreflnatlth _ g ) . Defined . Definition isasymmnatlth ( n m : nat ) : natlth n m -> natlth m n -> empty := fun lnm lmn => isasymmnatgth _ _ lmn lnm . Definition isantisymmnegnattth ( n m : nat ) : neg ( natlth n m ) -> neg ( natlth m n ) -> paths n m := fun nlnm nlmn => isantisymmnegnatgth _ _ nlmn nlnm . Definition isdecrelnatlth : isdecrel natlth := fun n m => isdecrelnatgth m n . Definition natlthdec := decrelpair isdecrelnatlth . (* Canonical Structure natlthdec . *) Definition isnegrelnatlth : isnegrel natlth := fun n m => isnegrelnatgth m n . Definition iscoantisymmnatlth ( n m : nat ) : neg ( natlth n m ) -> coprod ( natlth m n ) ( paths n m ) . Proof . intros n m nlnm . destruct ( iscoantisymmnatgth m n nlnm ) as [ l | e ] . apply ( ii1 l ) . apply ( ii2 ( pathsinv0 e ) ) . Defined . Definition iscotransnatlth ( n m k : nat ) : natlth n k -> hdisj ( natlth n m ) ( natlth m k ) . Proof . intros n m k lnk . apply ( ( pr1 islogeqcommhdisj ) ( iscotransnatgth _ _ _ lnk ) ) . Defined . (** *** Semi-boolean "less or equal " on [ nat ] or [ natleh ] *) Definition natleh ( n m : nat ) := hProppair ( neg ( natgth n m ) ) ( isapropneg _ ) . Definition natleh0tois0 ( n : nat ) ( l : natleh n 0 ) : paths n 0 := negnatgth0tois0 _ l . Definition natleh0n ( n : nat ) : natleh 0 n := negnatgth0n _ . Definition negnatlehsn0 ( n : nat ) : neg ( natleh ( S n ) 0 ) := todneg _ ( natgthsn0 n ) . Definition negnatlehsnn ( n : nat ) : neg ( natleh ( S n ) n ) := todneg _ ( natgthsnn _ ) . Definition istransnatleh ( n m k : nat ) : natleh n m -> natleh m k -> natleh n k . Proof. apply istransnegrel . unfold iscotrans. apply iscotransnatgth . Defined. Definition isreflnatleh ( n : nat ) : natleh n n := isirreflnatgth n . Definition isantisymmnatleh ( n m : nat ) : natleh n m -> natleh m n -> paths n m := isantisymmnegnatgth n m . Definition isdecrelnatleh : isdecrel natleh := isdecnegrel _ isdecrelnatgth . Definition natlehdec := decrelpair isdecrelnatleh . (* Canonical Structure natlehdec . *) Definition isnegrelnatleh : isnegrel natleh . Proof . apply isdecreltoisnegrel . apply isdecrelnatleh . Defined . Definition iscoasymmnatleh ( n m : nat ) ( nl : neg ( natleh n m ) ) : natleh m n := negf ( isasymmnatgth _ _ ) nl . Definition istotalnatleh : istotal natleh . Proof . intros x y . destruct ( isdecrelnatleh x y ) as [ lxy | lyx ] . apply ( hinhpr _ ( ii1 lxy ) ) . apply hinhpr . apply ii2 . apply ( iscoasymmnatleh _ _ lyx ) . Defined . (** *** Semi-boolean "greater or equal" on [ nat ] or [ natgeh ] . *) Definition natgeh ( n m : nat ) : hProp := hProppair ( neg ( natgth m n ) ) ( isapropneg _ ) . Definition nat0gehtois0 ( n : nat ) ( g : natgeh 0 n ) : paths n 0 := natleh0tois0 _ g . Definition natgehn0 ( n : nat ) : natgeh n 0 := natleh0n n . Definition negnatgeh0sn ( n : nat ) : neg ( natgeh 0 ( S n ) ) := negnatlehsn0 n . Definition negnatgehnsn ( n : nat ) : neg ( natgeh n ( S n ) ) := negnatlehsnn n . Definition istransnatgeh ( n m k : nat ) : natgeh n m -> natgeh m k -> natgeh n k := fun gnm gmk => istransnatleh _ _ _ gmk gnm . Definition isreflnatgeh ( n : nat ) : natgeh n n := isreflnatleh _ . Definition isantisymmnatgeh ( n m : nat ) : natgeh n m -> natgeh m n -> paths n m := fun gnm gmn => isantisymmnatleh _ _ gmn gnm . Definition isdecrelnatgeh : isdecrel natgeh := fun n m => isdecrelnatleh m n . Definition natgehdec := decrelpair isdecrelnatgeh . (* Canonical Structure natgehdec . *) Definition isnegrelnatgeh : isnegrel natgeh := fun n m => isnegrelnatleh m n . Definition iscoasymmnatgeh ( n m : nat ) ( nl : neg ( natgeh n m ) ) : natgeh m n := iscoasymmnatleh _ _ nl . Definition istotalnatgeh : istotal natgeh := fun n m => istotalnatleh m n . (** *** Simple implications between comparisons *) Definition natgthtogeh ( n m : nat ) : natgth n m -> natgeh n m . Proof. intros n m g . apply iscoasymmnatgeh . apply ( todneg _ g ) . Defined . Definition natlthtoleh ( n m : nat ) : natlth n m -> natleh n m := natgthtogeh _ _ . Definition natlehtonegnatgth ( n m : nat ) : natleh n m -> neg ( natgth n m ) . Proof. intros n m is is' . apply ( is is' ) . Defined . Definition natgthtonegnatleh ( n m : nat ) : natgth n m -> neg ( natleh n m ) := fun g l => natlehtonegnatgth _ _ l g . Definition natgehtonegnatlth ( n m : nat ) : natgeh n m -> neg ( natlth n m ) := fun gnm lnm => natlehtonegnatgth _ _ gnm lnm . Definition natlthtonegnatgeh ( n m : nat ) : natlth n m -> neg ( natgeh n m ) := fun gnm lnm => natlehtonegnatgth _ _ lnm gnm . Definition negnatlehtogth ( n m : nat ) : neg ( natleh n m ) -> natgth n m := isnegrelnatgth n m . Definition negnatgehtolth ( n m : nat ) : neg ( natgeh n m ) -> natlth n m := isnegrelnatlth n m . Definition negnatgthtoleh ( n m : nat ) : neg ( natgth n m ) -> natleh n m . Proof . intros n m ng . destruct ( isdecrelnatleh n m ) as [ l | nl ] . apply l . destruct ( nl ng ) . Defined . Definition negnatlthtogeh ( n m : nat ) : neg ( natlth n m ) -> natgeh n m := fun nl => negnatgthtoleh _ _ nl . (* *** Simple corollaries of implications *** *) Definition natlehnsn ( n : nat ) : natleh n ( S n ) := natlthtoleh _ _ ( natgthsnn n ) . Definition natgehsnn ( n : nat ) : natgeh ( S n ) n := natlehnsn n . (** *** Comparison alternatives *) Definition natgthorleh ( n m : nat ) : coprod ( natgth n m ) ( natleh n m ) . Proof . intros . apply ( isdecrelnatgth n m ) . Defined . Definition natlthorgeh ( n m : nat ) : coprod ( natlth n m ) ( natgeh n m ) := natgthorleh _ _ . Definition natneqchoice ( n m : nat ) ( ne : neg ( paths n m ) ) : coprod ( natgth n m ) ( natlth n m ) . Proof . intros . destruct ( natgthorleh n m ) as [ l | g ] . apply ( ii1 l ) . destruct ( natlthorgeh n m ) as [ l' | g' ] . apply ( ii2 l' ) . destruct ( ne ( isantisymmnatleh _ _ g g' ) ) . Defined . Definition natlehchoice ( n m : nat ) ( l : natleh n m ) : coprod ( natlth n m ) ( paths n m ) . Proof . intros . destruct ( natlthorgeh n m ) as [ l' | g ] . apply ( ii1 l' ) . apply ( ii2 ( isantisymmnatleh _ _ l g ) ) . Defined . Definition natgehchoice ( n m : nat ) ( g : natgeh n m ) : coprod ( natgth n m ) ( paths n m ) . Proof . intros . destruct ( natgthorleh n m ) as [ g' | l ] . apply ( ii1 g' ) . apply ( ii2 ( isantisymmnatleh _ _ l g ) ) . Defined . (** *** Mixed transitivities *) Lemma natgthgehtrans ( n m k : nat ) : natgth n m -> natgeh m k -> natgth n k . Proof. intros n m k gnm gmk . destruct ( natgehchoice m k gmk ) as [ g' | e ] . apply ( istransnatgth _ _ _ gnm g' ) . rewrite e in gnm . apply gnm . Defined. Lemma natgehgthtrans ( n m k : nat ) : natgeh n m -> natgth m k -> natgth n k . Proof. intros n m k gnm gmk . destruct ( natgehchoice n m gnm ) as [ g' | e ] . apply ( istransnatgth _ _ _ g' gmk ) . rewrite e . apply gmk . Defined. Lemma natlthlehtrans ( n m k : nat ) : natlth n m -> natleh m k -> natlth n k . Proof . intros n m k l1 l2 . apply ( natgehgthtrans k m n l2 l1 ) . Defined . Lemma natlehlthtrans ( n m k : nat ) : natleh n m -> natlth m k -> natlth n k . Proof . intros n m k l1 l2 . apply ( natgthgehtrans k m n l2 l1 ) . Defined . (** *** Two comparisons and [ S ] *) Lemma natgthtogehsn ( n m : nat ) : natgth n m -> natgeh n ( S m ) . Proof. intro n . induction n as [ | n IHn ] . intros m X . destruct ( negnatgth0n _ X ) . intros m X . destruct m as [ | m ] . apply ( natgehn0 n ) . apply ( IHn m X ) . Defined . Lemma natgthsntogeh ( n m : nat ) : natgth ( S n ) m -> natgeh n m . Proof. intros n m a . apply ( natgthtogehsn ( S n ) m a ) . Defined. (* PeWa *) Lemma natgehtogthsn ( n m : nat ) : natgeh n m -> natgth ( S n ) m . Proof . intros n m X . apply ( natgthgehtrans _ n _ ) . apply natgthsnn . apply X . Defined. (* New *) Lemma natgehsntogth ( n m : nat ) : natgeh n ( S m ) -> natgth n m . Proof. intros n m X . apply ( natgehgthtrans _ ( S m ) _ X ) . apply natgthsnn . Defined . (* New *) Lemma natlthtolehsn ( n m : nat ) : natlth n m -> natleh ( S n ) m . Proof. intros n m X . apply ( natgthtogehsn m n X ) . Defined . Lemma natlehsntolth ( n m : nat ) : natleh ( S n ) m -> natlth n m . Proof. intros n m X . apply ( natgehsntogth m n X ) . Defined . Lemma natlehtolthsn ( n m : nat ) : natleh n m -> natlth n ( S m ) . Proof. intros n m X . apply ( natgehtogthsn m n X ) . Defined. Lemma natlthsntoleh ( n m : nat ) : natlth n ( S m ) -> natleh n m . Proof. intros n m a . apply ( natlthtolehsn n ( S m ) a ) . Defined. (* PeWa *) (** *** Comparsion alternatives and [ S ] *) Lemma natlehchoice2 ( n m : nat ) : natleh n m -> coprod ( natleh ( S n ) m ) ( paths n m ) . Proof . intros n m l . destruct ( natlehchoice n m l ) as [ l' | e ] . apply ( ii1 ( natlthtolehsn _ _ l' ) ) . apply ( ii2 e ) . Defined . Lemma natgehchoice2 ( n m : nat ) : natgeh n m -> coprod ( natgeh n ( S m ) ) ( paths n m ) . Proof . intros n m g . destruct ( natgehchoice n m g ) as [ g' | e ] . apply ( ii1 ( natgthtogehsn _ _ g' ) ) . apply ( ii2 e ) . Defined . Lemma natgthchoice2 ( n m : nat ) : natgth n m -> coprod ( natgth n ( S m ) ) ( paths n ( S m ) ) . Proof. intros n m g . destruct ( natgehchoice _ _ ( natgthtogehsn _ _ g ) ) as [ g' | e ] . apply ( ii1 g' ) . apply ( ii2 e ) . Defined . Lemma natlthchoice2 ( n m : nat ) : natlth n m -> coprod ( natlth ( S n ) m ) ( paths ( S n ) m ) . Proof. intros n m l . destruct ( natlehchoice _ _ ( natlthtolehsn _ _ l ) ) as [ l' | e ] . apply ( ii1 l' ) . apply ( ii2 e ) . Defined . (** ** Some properties of [ plus ] on [ nat ] *) (* Addition is defined in Init/Peano.v by the following code Fixpoint plus (n m:nat) : nat := match n with | O => m | S p => S (p + m) end where "n + m" := (plus n m) : nat_scope. *) (** *** The structure of the additive ablelian monoid on [ nat ] *) Lemma natplusl0 ( n : nat ) : paths ( 0 + n ) n . Proof . intros . apply idpath . Defined . Lemma natplusr0 ( n : nat ) : paths ( n + 0 ) n . Proof . intro . induction n as [ | n IH n ] . apply idpath . simpl . apply ( maponpaths S IH ) . Defined . Hint Resolve natplusr0: natarith . Lemma natplusnsm ( n m : nat ) : paths ( n + S m ) ( S n + m ) . Proof. intro . simpl . induction n as [ | n IHn ] . auto with natarith . simpl . intro . apply ( maponpaths S ( IHn m ) ) . Defined . Hint Resolve natplusnsm : natarith . Lemma natpluscomm ( n m : nat ) : paths ( n + m ) ( m + n ) . Proof. intro. induction n as [ | n IHn ] . intro . auto with natarith . intro . set ( int := IHn ( S m ) ) . set ( int2 := pathsinv0 ( natplusnsm n m ) ) . set ( int3 := pathsinv0 ( natplusnsm m n ) ) . set ( int4 := pathscomp0 int2 int ) . apply ( pathscomp0 int4 int3 ) . Defined . Hint Resolve natpluscomm : natarith . Lemma natplusassoc ( n m k : nat ) : paths ( ( n + m ) + k ) ( n + ( m + k ) ) . Proof . intro . induction n as [ | n IHn ] . auto with natarith . intros . simpl . apply ( maponpaths S ( IHn m k ) ) . Defined. Hint Resolve natplusassoc : natarith . Definition nataddabmonoid : abmonoid := abmonoidpair ( setwithbinoppair natset ( fun n m : nat => n + m ) ) ( dirprodpair ( dirprodpair natplusassoc ( @isunitalpair natset _ 0 ( dirprodpair natplusl0 natplusr0 ) ) ) natpluscomm ) . (** *** Addition and comparisons *) (** [ natgth ] *) Definition natgthtogths ( n m : nat ) : natgth n m -> natgth ( S n ) m . Proof. intros n m is . apply ( istransnatgth _ _ _ ( natgthsnn n ) is ) . Defined . Definition negnatgthmplusnm ( n m : nat ) : neg ( natgth m ( n + m ) ) . Proof. intros . induction n as [ | n IHn ] . apply isirreflnatgth . apply ( istransnatleh _ _ _ IHn ( ( natlthtoleh _ _ ( natlthnsn _ ) ) ) ) . Defined . Definition negnatgthnplusnm ( n m : nat ) : neg ( natgth n ( n + m ) ) . Proof. intros . rewrite ( natpluscomm n m ) . apply ( negnatgthmplusnm m n ) . Defined . Definition natgthandplusl ( n m k : nat ) : natgth n m -> natgth ( k + n ) ( k + m ) . Proof. intros n m k l . induction k as [ | k IHk ] . assumption . assumption . Defined . Definition natgthandplusr ( n m k : nat ) : natgth n m -> natgth ( n + k ) ( m + k ) . Proof. intros . rewrite ( natpluscomm n k ) . rewrite ( natpluscomm m k ) . apply natgthandplusl . assumption . Defined . Definition natgthandpluslinv ( n m k : nat ) : natgth ( k + n ) ( k + m ) -> natgth n m . Proof. intros n m k l . induction k as [ | k IHk ] . assumption . apply ( IHk l ) . Defined . Definition natgthandplusrinv ( n m k : nat ) : natgth ( n + k ) ( m + k ) -> natgth n m . Proof. intros n m k l . rewrite ( natpluscomm n k ) in l . rewrite ( natpluscomm m k ) in l . apply ( natgthandpluslinv _ _ _ l ) . Defined . (** [ natlth ] *) Definition natlthtolths ( n m : nat ) : natlth n m -> natlth n ( S m ) := natgthtogths _ _ . Definition negnatlthplusnmm ( n m : nat ) : neg ( natlth ( n + m ) m ) := negnatgthmplusnm _ _ . Definition negnatlthplusnmn ( n m : nat ) : neg ( natlth ( n + m ) n ) := negnatgthnplusnm _ _ . Definition natlthandplusl ( n m k : nat ) : natlth n m -> natlth ( k + n ) ( k + m ) := natgthandplusl _ _ _ . Definition natlthandplusr ( n m k : nat ) : natlth n m -> natlth ( n + k ) ( m + k ) := natgthandplusr _ _ _ . Definition natlthandpluslinv ( n m k : nat ) : natlth ( k + n ) ( k + m ) -> natlth n m := natgthandpluslinv _ _ _ . Definition natlthandplusrinv ( n m k : nat ) : natlth ( n + k ) ( m + k ) -> natlth n m := natgthandplusrinv _ _ _ . (** [ natleh ] *) Definition natlehtolehs ( n m : nat ) : natleh n m -> natleh n ( S m ) . Proof . intros n m is . apply ( istransnatleh _ _ _ is ( natlthtoleh _ _ ( natlthnsn _ ) ) ) . Defined . Definition natlehmplusnm ( n m : nat ) : natleh m ( n + m ) := negnatlthplusnmm _ _ . Definition natlehnplusnm ( n m : nat ) : natleh n ( n + m ) := negnatlthplusnmn _ _ . Definition natlehandplusl ( n m k : nat ) : natleh n m -> natleh ( k + n ) ( k + m ) := negf ( natgthandpluslinv n m k ) . Definition natlehandplusr ( n m k : nat ) : natleh n m -> natleh ( n + k ) ( m + k ) := negf ( natgthandplusrinv n m k ) . Definition natlehandpluslinv ( n m k : nat ) : natleh ( k + n ) ( k + m ) -> natleh n m := negf ( natgthandplusl n m k ) . Definition natlehandplusrinv ( n m k : nat ) : natleh ( n + k ) ( m + k ) -> natleh n m := negf ( natgthandplusr n m k ) . (** [ natgeh ] *) Definition natgehtogehs ( n m : nat ) : natgeh n m -> natgeh ( S n ) m := natlehtolehs _ _ . Definition natgehplusnmm ( n m : nat ) : natgeh ( n + m ) m := negnatgthmplusnm _ _ . Definition natgehplusnmn ( n m : nat ) : natgeh ( n + m ) n := negnatgthnplusnm _ _ . Definition natgehandplusl ( n m k : nat ) : natgeh n m -> natgeh ( k + n ) ( k + m ) := negf ( natgthandpluslinv m n k ) . Definition natgehandplusr ( n m k : nat ) : natgeh n m -> natgeh ( n + k ) ( m + k ) := negf ( natgthandplusrinv m n k ) . Definition natgehandpluslinv ( n m k : nat ) : natgeh ( k + n ) ( k + m ) -> natgeh n m := negf ( natgthandplusl m n k ) . Definition natgehandplusrinv ( n m k : nat ) : natgeh ( n + k ) ( m + k ) -> natgeh n m := negf ( natgthandplusr m n k ) . (* The following are included mainly for direct compatibility with the library hz.v *) (** *** Comparisons and [ n -> n + 1 ] *) Definition natgthtogthp1 ( n m : nat ) : natgth n m -> natgth ( n + 1 ) m . Proof. intros n m is . destruct (natpluscomm 1 n) . apply (natgthtogths n m is). Defined. Definition natlthtolthp1 ( n m : nat ) : natlth n m -> natlth n ( m + 1 ) := natgthtogthp1 _ _ . Definition natlehtolehp1 ( n m : nat ) : natleh n m -> natleh n ( m + 1 ) . Proof . intros n m is . destruct (natpluscomm 1 m) . apply (natlehtolehs n m is). Defined. Definition natgehtogehp1 ( n m : nat ) : natgeh n m -> natgeh ( n + 1 ) m := natlehtolehp1 _ _ . (** *** Two comparisons and [ n -> n + 1 ] *) Lemma natgthtogehp1 ( n m : nat ) : natgth n m -> natgeh n ( m + 1 ) . Proof. intros n m is . destruct (natpluscomm 1 m) . apply (natgthtogehsn n m is). Defined . Lemma natgthp1togeh ( n m : nat ) : natgth ( n + 1 ) m -> natgeh n m . Proof. intros n m is . destruct (natpluscomm 1 n) . apply ( natgthsntogeh n m is). Defined. (* PeWa *) Lemma natlehp1tolth ( n m : nat ) : natleh ( n + 1 ) m -> natlth n m . Proof. intros n m is . destruct (natpluscomm 1 n) . apply (natlehsntolth n m is). Defined . Lemma natlthtolehp1 ( n m : nat ) : natlth n m -> natleh ( n + 1 ) m . Proof. intros n m is . destruct (natpluscomm 1 n) . apply (natlthtolehsn n m is). Defined . Lemma natlthp1toleh ( n m : nat ) : natlth n ( m + 1 ) -> natleh n m . Proof. intros n m is . destruct (natpluscomm 1 m) . apply (natlthsntoleh n m is). Defined. (* PeWa *) Lemma natgehp1togth ( n m : nat ) : natgeh n ( m + 1 ) -> natgth n m . Proof. intros n m is . destruct (natpluscomm 1 m) . apply (natgehsntogth n m is). Defined . (** *** Comparsion alternatives and [ n -> n + 1 ] *) Lemma natlehchoice3 ( n m : nat ) : natleh n m -> coprod ( natleh ( n + 1 ) m ) ( paths n m ) . Proof . intros n m l . destruct ( natlehchoice n m l ) as [ l' | e ] . apply ( ii1 ( natlthtolehp1 _ _ l' ) ) . apply ( ii2 e ) . Defined . Lemma natgehchoice3 ( n m : nat ) : natgeh n m -> coprod ( natgeh n ( m + 1 ) ) ( paths n m ) . Proof . intros n m g . destruct ( natgehchoice n m g ) as [ g' | e ] . apply ( ii1 ( natgthtogehp1 _ _ g' ) ) . apply ( ii2 e ) . Defined . Lemma natgthchoice3 ( n m : nat ) : natgth n m -> coprod ( natgth n ( m + 1 ) ) ( paths n ( m + 1 ) ) . Proof. intros n m g . destruct ( natgehchoice _ _ ( natgthtogehp1 _ _ g ) ) as [ g' | e ] . apply ( ii1 g' ) . apply ( ii2 e ) . Defined . Lemma natlthchoice3 ( n m : nat ) : natlth n m -> coprod ( natlth ( n + 1 ) m ) ( paths ( n + 1 ) m ) . Proof. intros n m l . destruct ( natlehchoice _ _ ( natlthtolehp1 _ _ l ) ) as [ l' | e ] . apply ( ii1 l' ) . apply ( ii2 e ) . Defined . (** *** Cancellation properties of [ plus ] on [ nat ] *) Lemma pathsitertoplus ( n m : nat ) : paths ( iteration S n m ) ( n + m ) . Proof. intros . induction n as [ | n IHn ] . apply idpath . simpl . apply ( maponpaths S IHn ) . Defined . Lemma isinclnatplusr ( n : nat ) : isincl ( fun m : nat => m + n ) . Proof. intro . induction n as [ | n IHn ] . apply ( isofhlevelfhomot 1 _ _ ( fun m : nat => pathsinv0 ( natplusr0 m ) ) ) . apply ( isofhlevelfweq 1 ( idweq nat ) ) . apply ( isofhlevelfhomot 1 _ _ ( fun m : nat => pathsinv0 ( natplusnsm m n ) ) ) . simpl . apply ( isofhlevelfgf 1 _ _ isinclS IHn ) . Defined. Lemma isinclnatplusl ( n : nat ) : isincl ( fun m : nat => n + m ) . Proof. intro . apply ( isofhlevelfhomot 1 _ _ ( fun m : nat => natpluscomm m n ) ( isinclnatplusr n ) ) . Defined . Lemma natplusrcan ( a b c : nat ) ( is : paths ( a + c ) ( b + c ) ) : paths a b . Proof . intros . apply ( invmaponpathsincl _ ( isinclnatplusr c ) a b ) . apply is . Defined . Lemma natpluslcan ( a b c : nat ) ( is : paths ( c + a ) ( c + b ) ) : paths a b . Proof . intros . rewrite ( natpluscomm _ _ ) in is . rewrite ( natpluscomm c b ) in is . apply ( natplusrcan a b c is ) . Defined . Lemma iscontrhfibernatplusr ( n m : nat ) ( is : natgeh m n ) : iscontr ( hfiber ( fun i : nat => i + n ) m ) . Proof. intros . apply iscontraprop1 . apply isinclnatplusr . induction m as [ | m IHm ] . set ( e := natleh0tois0 _ is ) . split with 0 . apply e . destruct ( natlehchoice2 _ _ is ) as [ l | e ] . set ( j := IHm l ) . destruct j as [ j e' ] . split with ( S j ) . simpl . apply ( maponpaths S e' ) . split with 0 . simpl . assumption . Defined . Lemma neghfibernatplusr ( n m : nat ) ( is : natlth m n ) : neg ( hfiber ( fun i : nat => i + n ) m ) . Proof. intros. intro h . destruct h as [ i e ] . rewrite ( pathsinv0 e ) in is . destruct ( natlehtonegnatgth _ _ ( natlehmplusnm i n ) is ) . Defined . Lemma isdecinclnatplusr ( n : nat ) : isdecincl ( fun i : nat => i + n ) . Proof. intros . intro m . apply isdecpropif . apply ( isinclnatplusr _ m ) . destruct ( natlthorgeh m n ) as [ ni | i ] . apply ( ii2 ( neghfibernatplusr n m ni ) ) . apply ( ii1 ( pr1 ( iscontrhfibernatplusr n m i ) ) ) . Defined . (** *** Some properties of [ minus ] on [ nat ] Note : minus is defined in Init/Peano.v by the following code: Fixpoint minus (n m:nat) : nat := match n, m with | O, _ => n | S k, O => n | S k, S l => k - l end where "n - m" := (minus n m) : nat_scope. *) Definition minuseq0 ( n m : nat ) ( is : natleh n m ) : paths ( n - m )%nat 0 . Proof. intros n m . generalize n . clear n . induction m . intros n is . rewrite ( natleh0tois0 n is ) . simpl . apply idpath. intro n . destruct n . intro . apply idpath . apply (IHm n ) . Defined. Definition minusgeh0 ( n m : nat ) ( is : natgeh n m ) : natgeh ( n - m ) 0%nat. Proof. intro . induction n as [ | n IHn ] . intros. apply isreflnatgeh. intros . apply natgehn0 . Defined. Definition minusgth0 ( n m : nat ) ( is : natgth n m ) : natgth ( n - m ) 0%nat . Proof . intro n . induction n as [ | n IHn ] . intros . destruct (negnatgth0n _ is ) . intro m . destruct m as [ | m ] . intro . apply natgthsn0 . intro is . apply ( IHn m is ) . Defined. Definition minusgth0inv ( n m : nat ) ( is : natgth ( n - m ) 0%nat ) : natgth n m . Proof . intro . induction n as [ | n IHn ] . intros . destruct ( negnatgth0n _ is ) . intro . destruct m as [ | m ]. intros . apply natgthsn0. intro . apply ( IHn m is ) . Defined. Definition natminuseqn ( n : nat ) : paths ( n - 0 )%nat n . Proof . intro. destruct n . apply idpath . apply idpath. Defined. Definition natminuslehn ( n m : nat ) : natleh ( n - m ) n . Proof . intro n. induction n as [ | n IHn ] . intro. apply isreflnatleh . intro . destruct m as [ | m ]. apply isreflnatleh . simpl . apply ( istransnatleh _ _ _ (IHn m) ( natlehnsn n ) ) . Defined. Definition natminuslthn ( n m : nat ) ( is : natgth n 0 ) ( is' : natgth m 0 ) : natlth ( n - m ) n . Proof . intro . induction n as [ | n IHn ] . intros . destruct ( negnatgth0n _ is ) . intro m . induction m . intros . destruct ( negnatgth0n _ is' ) . intros . apply ( natlehlthtrans _ n _ ) . apply ( natminuslehn n m ) . apply natlthnsn . Defined. Definition natminuslthninv (n m : nat ) ( is : natlth ( n - m ) n ) : natgth m 0 . Proof. intro . induction n as [ | n IHn ] . intros . destruct ( negnatlthn0 _ is ) . intro m . destruct m as [ | m ] . intro . destruct ( negnatlthnn _ is ) . intro . apply ( natgthsn0 m ) . Defined. Definition minusplusnmm ( n m : nat ) ( is : natgeh n m ) : paths ( ( n - m ) + m ) n . Proof . intro n . induction n as [ | n IHn] . intro m . intro is . simpl . apply ( natleh0tois0 _ is ) . intro m . destruct m as [ | m ] . intro . simpl . rewrite ( natplusr0 n ) . apply idpath . simpl . intro is . rewrite ( natplusnsm ( n - m ) m ) . apply ( maponpaths S ( IHn m is ) ) . Defined . Definition minusplusnmmineq ( n m : nat ) : natgeh ( ( n - m ) + m ) n . Proof. intros. destruct ( natlthorgeh n m ) as [ lt | ge ] . rewrite ( minuseq0 _ _ ( natlthtoleh _ _ lt ) ). apply ( natgthtogeh _ _ lt ) . rewrite ( minusplusnmm _ _ ge ) . apply isreflnatgeh . Defined. Definition plusminusnmm ( n m : nat ) : paths ( ( n + m ) - m )%nat n . Proof. intros . set ( int1 := natgehplusnmm n m ) . apply ( natplusrcan _ _ m ) . rewrite ( minusplusnmm _ _ int1 ) . apply idpath. Defined. (* *** Two-sided minus and comparisons *) Definition natgehandminusr ( n m k : nat ) ( is : natgeh n m ) : natgeh ( n - k ) ( m - k ) . Proof. intro n. induction n as [ | n IHn ] . intros . rewrite ( nat0gehtois0 _ is ) . apply isreflnatleh . intro m . induction m . intros . destruct k . apply natgehn0. apply natgehn0 . intro k . induction k . intro is . apply is . intro is . apply ( IHn m k is ) . Defined. Definition natgehandminusl ( n m k : nat ) ( is : natgeh n m ) : natgeh ( n - k ) ( m - k ) . Proof . intro n. induction n as [ | n IHn ] . intros . rewrite ( nat0gehtois0 _ is ) . apply isreflnatleh . intro m . induction m . intros . destruct k . apply natgehn0 . apply natgehn0 . intro k . induction k . intro is . apply is . intro is . apply ( IHn m k is ) . Defined. Definition natgehandminusrinv ( n m k : nat ) ( is' : natgeh n k ) ( is : natgeh ( n - k ) ( m - k ) ) : natgeh n m . Proof. intro n. induction n as [ | n IHn ] . intros . rewrite ( nat0gehtois0 _ is' ) in is . rewrite ( natminuseqn m ) in is . rewrite ( nat0gehtois0 _ is ) . apply isreflnatleh . intro m . induction m . intros . apply natgehn0 . intros . destruct k . rewrite natminuseqn in is . rewrite natminuseqn in is . apply is . apply ( IHn m k is' is ) . Defined. (* Definition natgehandminuslinv ( n m k : nat ) ( is' : natgeh k n ) ( is : natleh ( k - n ) ( k - m ) ) : natgeh n m . Proof. intros. set ( int := natgehgthtrans _ ( k - n ) _ is ( minusgeh0 _ _ is' ) ) . set ( int' := minusgeh0inv _ _ int ) . set ( int'' := natlehandplusr _ _ n is ) . rewrite ( minusplusnmm _ _ ( natgthtogeh _ _ is' ) ) in int''. set ( int''' := natlehandplusr _ _ m int'' ) . rewrite ( natplusassoc _ n _ ) in int'''. rewrite ( natpluscomm n m ) in int''' . destruct ( natplusassoc ( k - m ) m n ) in int'''. rewrite ( minusplusnmm _ _ ( natgthtogeh _ _ int' ) ) in int'''. apply ( natgehandpluslinv _ _ k ) . apply int'''. Defined. induction n as [ | n IHn ] . intros . rewrite ( nat0gehtois0 _ is' ) in is . rewrite ( natminuseqn m ) in is . rewrite ( nat0gehtois0 _ is ) . apply isreflnatleh . intro m . induction m . intros . apply natgehn0 . intros . destruct k . rewrite natminuseqn in is . rewrite natminuseqn in is . apply is . apply ( IHn m k is is' ) . Defined. Definition natgthandminusinvr ( n m k : nat ) ( is : natgth n m ) ( is' : natgth n k ) : natgth ( n - k ) ( m - k ) . Proof . intro n. induction n as [ | n IHn ] . intros . destruct ( negnatgth0n _ is ) . intro m . induction m . intros . destruct k . apply natgthsn0. apply ( IHapply natgehn0 . intro k . induction k . intro is . apply is . intro is . apply ( IHn m k is ) . Defined. Definition natlehandminusl ( n m k : nat ) ( is : natgeh n m ) : natleh ( k - n ) ( k - m ) . Proof. intro n. induction n as [ | n IHn ] . intros . rewrite ( nat0gehtois0 _ is ) . apply isreflnatleh . intro m . induction m . intros . destruct k . apply natminuslehn . apply natminuslehn . intro k . induction k . intro is . apply isreflnatleh . intro is . apply ( IHn m k ) . apply is . Defined. Definition natlehandminusr Definition natlthandminusl ( n m k : nat ) ( is : natgth n m ) ( is' : natgeh k n ) : natlth ( k - n ) ( k - m ) . Proof. intro n. induction n as [ | n IHn ] . intros . destruct ( negnatgth0n _ is ) . intro m . induction m . intros . destruct k . destruct ( negnatgeh0sn _ is' ) . apply ( natlehlthtrans _ k _ ) . apply ( natminuslehn k n ) . apply natlthnsn . intro k . induction k . intros is is'. destruct ( negnatgeh0sn _ is' ) . intros is is' . apply ( IHn m k is is' ) . Defined. Definition natlehandminusl ( n m k : nat ) ( is : natgeh n m ) : natleh ( k - n ) ( k - m ) . Proof. intro n. induction n as [ | n IHn ] . intros . rewrite ( nat0gehtois0 _ is ) . apply isreflnatleh . intro m . induction m . intros . destruct k . apply natminuslehn . apply natminuslehn . intro k . induction k . intro is . apply isreflnatleh . intro is . apply ( IHn m k ) . apply is . Defined. Definition natlehandminusl ( n m k : nat ) : ( natleh n m ) -> natgeh ( k - n ) ( k - m ) := natlehandminusl m n k . Definition natlehandminusr ( n m k : nat ) : ( natleh n m ) -> natleh ( n - k ) ( m - k ) := natgehandminusr m n k . (* *** One sided minus and comparisons *) (* *** Greater or equal and minus *) Definition natgehrightminus ( n m k : nat ) ( is : natgeh ( n + m ) k ) : natgeh n ( k - m ) . Proof. intros . Definition natgehrightplus ( n m k : nat ) ( is : natgeh ( n - m ) k ) : natgeh n ( k + m ) . Definition natgehleftminus ( n m k : nat ) ( is : natgeh n ( m + k ) ) : natgeh ( n - k ) m . Definition natgehleftplus ( n m k : nat ) ( is : natgeh n ( m - k ) ) : natgeh ( n + k ) m . (* **** Greater and minus *) Definition natgthrightminus ( n m k : nat ) ( is : natgth ( n + m ) k ) : natgth n ( k - m ) . Proof . intros. Definition natgthrightplus ( n m k : nat ) ( is : natgth ( n - m ) k ) : natgth n ( k + m ) . Definition natgthleftminus ( n m k : nat ) ( is : natgth n ( m + k ) ) : natgth ( n - k ) m . Definition natgthleftplus ( n m k : nat ) ( is : natgth n ( m - k ) ) : natgth ( n + k ) m .\ (* **** Less and minus *) Definition natlthrightminus ( n m k : nat ) ( is : natlth ( n + m ) k ) : natlth n ( k - m ) . Definition natlthrightplus ( n m k : nat ) ( is : natlth ( n - m ) k ) : natlth n ( k + m ) . Definition natlthleftminus ( n m k : nat ) ( is : natlth n ( m + k ) ) : natlth ( n - k ) m . Definition natlthleftplus ( n m k : nat ) ( is : natlth n ( m - k ) ) : natlth ( n + k ) m . (* **** Less or equal and minus *) Definition natlehrightminus ( n m k : nat ) ( is : natleh ( n + m ) k ) : natleh n ( k - m ) . Definition natlehrightplus ( n m k : nat ) ( is : natleh ( n - m ) k ) : natleh n ( k + m ) . Definition natlehleftminus ( n m k : nat ) ( is : natleh n ( m + k ) ) : natleh ( n - k ) m . Definition natlehleftplus ( n m k : nat ) ( is : natleh n ( m - k ) ) : natleh ( n + k ) m . (* *** Mixed plus/minus associativities. There are four possible plus/minus associativities which are labelled by pp, pm, mp and mm depending on where in the side with the left parenthesis one has minuses and where one has pluses. Two of those - pp and mm, are unconditional. Two others require a condition to hold as equality and also provide an unconditional inequality. Alltogether we have six statements including a repeat of the usual pp associativity which we give here another name in accrdance with the general naming scheme for these statements. *) Notation natassocppeq := natplusassoc . Definition natassocpmeq ( n m k : nat ) ( is : natgeh m k ) : paths (( n + m ) - k )%nat (n + ( m - k )). Proof. intros. apply ( natplusrcan _ _ k ) . rewrite ( natplusassoc n _ k ) . rewrite ( minusplusnmm _ k is ) . set ( is' := istransnatgeh _ _ _ ( natgehplusnmm n m ) is ) . rewrite ( minusplusnmm _ k is' ) . apply idpath. Defined. Definition natassocpmineq ( n m k : nat ) : natleh (( n + m ) - k ) ( n + ( m - k )) . Proof. intros n m k . destruct (natgthorleh k m) as [g | le]. set ( e := minuseq0 m k ( natgthtogeh _ _ g ) ) . rewrite e . rewrite (natplusr0 n ). destruct (boolchoice ( natgtb k (n+m) ) ) as [ g' | le']. set ( e' := minuseq0 (n+m) k ( natgthtogeh _ _ g' ) ) . rewrite e' . apply natleh0n . apply ( natlehandplusrinv _ _ k ) . rewrite ( minusplusnmm _ k ) . apply natlehandplusl . apply ( natlthtoleh _ _ g ) . set ( int := falsetonegtrue _ le' ) . assumption . rewrite ( natassocpmeq _ _ _ le ) . apply isreflnatleh . Defined. Definition natassocmpeq ( n m k : nat ) ( isnm : natgeh n m ) ( ismk : natgeh m k ) : paths (( n - m ) + k )%nat (n - ( m - k ))%nat. Proof. intros. apply ( natplusrcan _ _ ( m - k ) ) . assert ( is' : natleh ( m - k ) n ) . apply ( istransnatleh _ _ _ (natminuslehn _ _ ) isnm ) . rewrite ( minusplusnmm _ _ is' ) . rewrite (natplusassoc _ k _ ) . rewrite ( natpluscomm k _ ) . rewrite ( minusplusnmm _ _ ismk ) . rewrite ( minusplusnmm _ _ isnm ) . apply idpath. Defined. Definition natassocmpineq ( n m k : nat ) : natgeh (( n - m ) + k ) ( n - ( m - k )) . Proof. intros n m k . destruct (natgthorleh k m) as [g | le]. set ( e := minuseq0 m k ( natgthtogeh _ _ g ) ) . rewrite e . rewrite ( natminuseqn n ) . apply ( natgehandplusrinv _ _ m ) . rewrite ( natplusassoc _ _ m ) . rewrite ( natpluscomm _ m ) . destruct ( natplusassoc ( n - m ) m k ) . assert ( int1 : natgeh (n - m + m + k ) ( n + k ) ) . apply ( natgehandplusr _ _ k ) . apply minusplusnmmineq . assert ( int2 : natgeh (n + k ) (n + m ) ) . apply ( natgehandplusl _ _ n ) . apply ( natgthtogeh _ _ g ) . apply ( istransnatgeh _ _ _ int1 int2 ) . destruct ( natgthorleh m n ) as [g' | le']. rewrite ( minuseq0 _ _ ( natgthtogeh _ _ g' ) ) . change ( 0 + k ) with k . apply ( natgehandplusrinv _ _ (m - k ) ) . rewrite ( natpluscomm k _ ) . rewrite ( minusplusnmm _ _ le ) . destruct ( natgthorleh ( m - k ) n ) as [ g'' | le'' ] . rewrite ( minuseq0 n ( m - k ) ( natgthtogeh _ _ g'' ) ) . apply ( natminuslehn m k ) . rewrite ( minusplusnmm _ _ le'' ) . apply ( natgthtogeh _ _ g' ) . rewrite ( natassocmpeq _ _ _ le' le ) . apply isreflnatgeh . Defined. Definition natassocmmeq ( n m k : nat ) : paths (( n - m ) - k )%nat (n - ( m + k ))%nat. Proof. intros. destruct ( natgthorleh ( m + k ) n ) as [ g | le ] . rewrite ( minuseq0 _ _ ( natgthtogeh _ _ g ) ) . assert ( int1 : natleh ( n - m ) k ) . rewrite natpluscomm in g . set ( int2 := natgehandminusr _ _ m ( natgthtogeh _ _ g ) ) . rewrite plusminusnmm in int2 . apply int2 . apply ( minuseq0 _ _ int1 ) . apply ( natplusrcan _ _ ( m + k ) ) . rewrite ( minusplusnmm _ ( m + k )%nat ) . rewrite ( natpluscomm m k ) . destruct ( natplusassoc ( n - m - k ) k m ) . rewrite apply ( natplusrcan _ _ k ) . rewrite ( natplusassoc n _ k ) . rewrite ( minusplusnmm _ k is ) . set ( is' := istransnatgeh _ _ _ ( natgehplusnmm n m ) is ) . rewrite ( minusplusnmm _ k is' ) .apply idpath. Defined. Definition natassocpmineq ( n m k : nat ) : natleh (( n + m ) - k ) ( n + ( m - k )) . Proof. intros n m k . destruct (natgthorleh k m) as [g | le]. set ( e := minuseq0 m k ( natgthtogeh _ _ g ) ) . rewrite e . rewrite (natplusr0 n ). destruct (boolchoice ( natgtb k (n+m) ) ) as [ g' | le']. set ( e' := minuseq0 (n+m) k ( natgthtogeh _ _ g' ) ) . rewrite e' . apply natleh0n . apply ( natlehandplusrinv _ _ k ) . rewrite ( minusplusnmm _ k ) . apply natlehandplusl . apply ( natlthtoleh _ _ g ) . set ( int := falsetonegtrue _ le' ) . assumption . rewrite ( natassocpmeq _ _ _ le ) . apply isreflnatleh . Defined. *) (** ** Some properties of [ mult ] on [ nat ] Note : multiplication is defined in Init/Peano.v by the following code: Fixpoint mult (n m:nat) : nat := match n with | O => 0 | S p => m + p * m end where "n * m" := (mult n m) : nat_scope. *) (** *** Basic algebraic properties of [ mult ] on [ nat ] *) Lemma natmult0n ( n : nat ) : paths ( 0 * n ) 0 . Proof. intro n . apply idpath . Defined . Hint Resolve natmult0n : natarith . Lemma natmultn0 ( n : nat ) : paths ( n * 0 ) 0 . Proof. intro n . induction n as [ | n IHn ] . apply idpath . simpl . assumption . Defined . Hint Resolve natmultn0 : natarith . Lemma multsnm ( n m : nat ) : paths ( ( S n ) * m ) ( m + n * m ) . Proof. intros . apply idpath . Defined . Hint Resolve multsnm : natarith . Lemma multnsm ( n m : nat ) : paths ( n * ( S m ) ) ( n + n * m ) . Proof. intro n . induction n as [ | n IHn ] . intro . simpl . apply idpath . intro m . simpl . apply ( maponpaths S ) . rewrite ( pathsinv0 ( natplusassoc n m ( n * m ) ) ) . rewrite ( natpluscomm n m ) . rewrite ( natplusassoc m n ( n * m ) ) . apply ( maponpaths ( fun x : nat => m + x ) ( IHn m ) ) . Defined . Hint Resolve multnsm : natarith . Lemma natmultcomm ( n m : nat ) : paths ( n * m ) ( m * n ) . Proof. intro . induction n as [ | n IHn ] . intro . auto with natarith . intro m . rewrite ( multsnm n m ) . rewrite ( multnsm m n ) . apply ( maponpaths ( fun x : _ => m + x ) ( IHn m ) ) . Defined . Lemma natrdistr ( n m k : nat ) : paths ( ( n + m ) * k ) ( n * k + m * k ) . Proof . intros . induction n as [ | n IHn ] . auto with natarith . simpl . rewrite ( natplusassoc k ( n * k ) ( m * k ) ) . apply ( maponpaths ( fun x : _ => k + x ) ( IHn ) ) . Defined . Lemma natldistr ( m k n : nat ) : paths ( n * ( m + k ) ) ( n * m + n * k ) . Proof . intros m k n . induction m as [ | m IHm ] . simpl . rewrite ( natmultn0 n ) . auto with natarith . simpl . rewrite ( multnsm n ( m + k ) ) . rewrite ( multnsm n m ) . rewrite ( natplusassoc _ _ _ ) . apply ( maponpaths ( fun x : _ => n + x ) ( IHm ) ) . Defined . Lemma natmultassoc ( n m k : nat ) : paths ( ( n * m ) * k ) ( n * ( m * k ) ) . Proof. intro . induction n as [ | n IHn ] . auto with natarith . intros . simpl . rewrite ( natrdistr m ( n * m ) k ) . apply ( maponpaths ( fun x : _ => m * k + x ) ( IHn m k ) ) . Defined . Lemma natmultl1 ( n : nat ) : paths ( 1 * n ) n . Proof. simpl . auto with natarith . Defined . Hint Resolve natmultl1 : natarith . Lemma natmultr1 ( n : nat ) : paths ( n * 1 ) n . Proof. intro n . rewrite ( natmultcomm n 1 ) . auto with natarith . Defined . Hint Resolve natmultr1 : natarith . Definition natmultabmonoid : abmonoid := abmonoidpair ( setwithbinoppair natset ( fun n m : nat => n * m ) ) ( dirprodpair ( dirprodpair natmultassoc ( @isunitalpair natset _ 1 ( dirprodpair natmultl1 natmultr1 ) ) ) natmultcomm ) . (** *** [ nat ] as a commutative rig *) Definition natcommrig : commrig . Proof . split with ( setwith2binoppair natset ( dirprodpair ( fun n m : nat => n + m ) ( fun n m : nat => n * m ) ) ) . split . split . split with ( dirprodpair ( dirprodpair ( dirprodpair natplusassoc ( @isunitalpair natset _ 0 ( dirprodpair natplusl0 natplusr0 ) ) ) natpluscomm ) ( dirprodpair natmultassoc ( @isunitalpair natset _ 1 ( dirprodpair natmultl1 natmultr1 ) ) ) ) . apply ( dirprodpair natmult0n natmultn0 ) . apply ( dirprodpair natldistr natrdistr ) . unfold iscomm . apply natmultcomm . Defined . (** *** Cancellation properties of [ mult ] on [ nat ] *) Definition natneq0andmult ( n m : nat ) ( isn : natneq n 0 ) ( ism : natneq m 0 ) : natneq ( n * m ) 0 . Proof . intros . destruct n as [ | n ] . destruct ( isn ( idpath _ ) ) . destruct m as [ | m ] . destruct ( ism ( idpath _ ) ) . simpl . apply ( negpathssx0 ) . Defined . Definition natneq0andmultlinv ( n m : nat ) ( isnm : natneq ( n * m ) 0 ) : natneq n 0 := rigneq0andmultlinv natcommrig n m isnm . Definition natneq0andmultrinv ( n m : nat ) ( isnm : natneq ( n * m ) 0 ) : natneq m 0 := rigneq0andmultrinv natcommrig n m isnm . (** *** Multiplication and comparisons *) (** [ natgth ] *) Definition natgthandmultl ( n m k : nat ) ( is : natneq k 0 ) : natgth n m -> natgth ( k * n ) ( k * m ) . Proof. intro n . induction n as [ | n IHn ] . intros m k g g' . destruct ( negnatgth0n _ g' ) . intro m . destruct m as [ | m ] . intros k g g' . rewrite ( natmultn0 k ) . rewrite ( multnsm k n ) . apply ( natgehgthtrans _ _ _ ( natgehplusnmn k ( k* n ) ) ( natneq0togth0 _ g ) ) . intros k g g' . rewrite ( multnsm k n ) . rewrite ( multnsm k m ) . apply ( natgthandplusl _ _ _ ) . apply ( IHn m k g g' ) . Defined . Definition natgthandmultr ( n m k : nat ) ( is : natneq k 0 ) : natgth n m -> natgth ( n * k ) ( m * k ) . Proof . intros n m k l . rewrite ( natmultcomm n k ) . rewrite ( natmultcomm m k ) . apply ( natgthandmultl n m k l ) . Defined . Definition natgthandmultlinv ( n m k : nat ) : natgth ( k * n ) ( k * m ) -> natgth n m . Proof . intro n . induction n as [ | n IHn ] . intros m k g . rewrite ( natmultn0 k ) in g . destruct ( negnatgth0n _ g ) . intro m . destruct m as [ | m ] . intros . apply ( natgthsn0 _ ) . intros k g . rewrite ( multnsm k n ) in g . rewrite ( multnsm k m ) in g . apply ( IHn m k ( natgthandpluslinv _ _ k g ) ) . Defined . Definition natgthandmultrinv ( n m k : nat ) : natgth ( n * k ) ( m * k ) -> natgth n m . Proof. intros n m k g . rewrite ( natmultcomm n k ) in g . rewrite ( natmultcomm m k ) in g . apply ( natgthandmultlinv n m k g ) . Defined . (** [ natlth ] *) Definition natlthandmultl ( n m k : nat ) ( is : natneq k 0 ) : natlth n m -> natlth ( k * n ) ( k * m ) := natgthandmultl _ _ _ is . Definition natlthandmultr ( n m k : nat ) ( is : natneq k 0 ) : natlth n m -> natlth ( n * k ) ( m * k ) := natgthandmultr _ _ _ is . Definition natlthandmultlinv ( n m k : nat ) : natlth ( k * n ) ( k * m ) -> natlth n m := natgthandmultlinv _ _ _ . Definition natlthandmultrinv ( n m k : nat ) : natlth ( n * k ) ( m * k ) -> natlth n m := natgthandmultrinv _ _ _ . (** [ natleh ] *) Definition natlehandmultl ( n m k : nat ) : natleh n m -> natleh ( k * n ) ( k * m ) := negf ( natgthandmultlinv _ _ _ ) . Definition natlehandmultr ( n m k : nat ) : natleh n m -> natleh ( n * k ) ( m * k ) := negf ( natgthandmultrinv _ _ _ ) . Definition natlehandmultlinv ( n m k : nat ) ( is : natneq k 0 ) : natleh ( k * n ) ( k * m ) -> natleh n m := negf ( natgthandmultl _ _ _ is ) . Definition natlehandmultrinv ( n m k : nat ) ( is : natneq k 0 ) : natleh ( n * k ) ( m * k ) -> natleh n m := negf ( natgthandmultr _ _ _ is ) . (** [ natgeh ] *) Definition natgehandmultl ( n m k : nat ) : natgeh n m -> natgeh ( k * n ) ( k * m ) := negf ( natgthandmultlinv _ _ _ ) . Definition natgehandmultr ( n m k : nat ) : natgeh n m -> natgeh ( n * k ) ( m * k ) := negf ( natgthandmultrinv _ _ _ ) . Definition natgehandmultlinv ( n m k : nat ) ( is : natneq k 0 ) : natgeh ( k * n ) ( k * m ) -> natgeh n m := negf ( natgthandmultl _ _ _ is ) . Definition natgehandmultrinv ( n m k : nat ) ( is : natneq k 0 ) : natgeh ( n * k ) ( m * k ) -> natgeh n m := negf ( natgthandmultr _ _ _ is ) . (** *** Properties of comparisons in the terminology of algebra1.v *) Open Scope rig_scope. (** [ natgth ] *) Lemma isplushrelnatgth : @isbinophrel nataddabmonoid natgth . Proof . split . apply natgthandplusl . apply natgthandplusr . Defined . Lemma isinvplushrelnatgth : @isinvbinophrel nataddabmonoid natgth . Proof . split . apply natgthandpluslinv . apply natgthandplusrinv . Defined . Lemma isinvmulthrelnatgth : @isinvbinophrel natmultabmonoid natgth . Proof . split . intros a b c r . apply ( natlthandmultlinv _ _ _ r ) . intros a b c r . apply ( natlthandmultrinv _ _ _ r ) . Defined . Lemma isrigmultgtnatgth : isrigmultgt natcommrig natgth . Proof . change ( forall a b c d : nat , natgth a b -> natgth c d -> natgth ( a * c + b * d ) ( a * d + b * c ) ) . intro a . induction a as [ | a IHa ] . intros b c d rab rcd . destruct ( negnatgth0n _ rab ) . intro b . induction b as [ | b IHb ] . intros c d rab rcd . rewrite ( natmult0n d ) . rewrite ( natplusr0 _ ) . rewrite ( natmult0n _ ) . rewrite ( natplusr0 _ ) . apply ( natlthandmultl _ _ _ ( natgthtoneq _ _ rab ) rcd ) . intros c d rab rcd . simpl . set ( rer := ( abmonoidrer nataddabmonoid ) ) . simpl in rer . rewrite ( rer _ _ d _ ) . rewrite ( rer _ _ c _ ) . rewrite ( natpluscomm c d ) . apply ( natlthandplusl (a * d + b * c) (a * c + b * d) ( d + c ) ) . apply ( IHa _ _ _ rab rcd ) . Defined . Lemma isinvrigmultgtnatgth : isinvrigmultgt natcommrig natgth . Proof . set ( rer := abmonoidrer nataddabmonoid ) . simpl in rer . apply isinvrigmultgtif . intros a b c d . generalize a b c . clear a b c . induction d as [ | d IHd ] . intros a b c g gab . change ( pr1 ( natgth ( a * c + b * 0 ) ( a * 0 + b * c ) ) ) in g . destruct c as [ | c ] . rewrite ( natmultn0 _ ) in g . destruct ( isirreflnatgth _ g ) . apply natgthsn0 . intros a b c g gab . destruct c as [ | c ] . change ( pr1 ( natgth ( a * 0 + b * S d ) ( a * S d + b * 0 ) ) ) in g . rewrite ( natmultn0 _ ) in g . rewrite ( natmultn0 _ ) in g . rewrite ( natplusl0 _ ) in g . rewrite ( natplusr0 _ ) in g . set ( g' := natgthandmultrinv _ _ _ g ) . destruct ( isasymmnatgth _ _ gab g' ) . change ( pr1 ( natgth ( a * S c + b * S d ) ( a * S d + b * S c ) ) ) in g . rewrite ( multnsm _ _ ) in g . rewrite ( multnsm _ _ ) in g . rewrite ( multnsm _ _ ) in g . rewrite ( multnsm _ _ ) in g . rewrite ( rer _ ( a * c ) _ _ ) in g . rewrite ( rer _ ( a * d ) _ _ ) in g . set ( g' := natgthandpluslinv _ _ ( a + b ) g ) . apply ( IHd a b c g' gab ) . Defined . (** [ natlth ] *) Lemma isplushrelnatlth : @isbinophrel nataddabmonoid natlth . Proof . split . intros a b c . apply ( natgthandplusl b a c ) . intros a b c . apply ( natgthandplusr b a c ) . Defined . Lemma isinvplushrelnatlth : @isinvbinophrel nataddabmonoid natlth . Proof . split . intros a b c . apply ( natgthandpluslinv b a c ) . intros a b c . apply ( natgthandplusrinv b a c ) . Defined . Lemma isinvmulthrelnatlth : @isinvbinophrel natmultabmonoid natlth . Proof . split . intros a b c r . apply ( natlthandmultlinv _ _ _ r ) . intros a b c r . apply ( natlthandmultrinv _ _ _ r ) . Defined . (** [ natleh ] *) Lemma isplushrelnatleh : @isbinophrel nataddabmonoid natleh . Proof . split . apply natlehandplusl . apply natlehandplusr . Defined . Lemma isinvplushrelnatleh : @isinvbinophrel nataddabmonoid natleh . Proof . split . apply natlehandpluslinv . apply natlehandplusrinv . Defined . Lemma ispartinvmulthrelnatleh : @ispartinvbinophrel natmultabmonoid ( fun x => natneq x 0 ) natleh . Proof . split . intros a b c s r . apply ( natlehandmultlinv _ _ _ s r ) . intros a b c s r . apply ( natlehandmultrinv _ _ _ s r ) . Defined . (** [ natgeh ] *) Lemma isplushrelnatgeh : @isbinophrel nataddabmonoid natgeh . Proof . split . intros a b c . apply ( natlehandplusl b a c ) . intros a b c . apply ( natlehandplusr b a c ) . Defined . Lemma isinvplushrelnatgeh : @isinvbinophrel nataddabmonoid natgeh . Proof . split . intros a b c . apply ( natlehandpluslinv b a c ) . intros a b c . apply ( natlehandplusrinv b a c ) . Defined . Lemma ispartinvmulthrelnatgeh : @ispartinvbinophrel natmultabmonoid ( fun x => natneq x 0 ) natgeh . Proof . split . intros a b c s r . apply ( natlehandmultlinv _ _ _ s r ) . intros a b c s r . apply ( natlehandmultrinv _ _ _ s r ) . Defined . Close Scope rig_scope . (** *** Submonoid of non-zero elements in [ nat ] *) Definition natnonzero : @subabmonoids natmultabmonoid . Proof . split with ( fun a => natneq a 0 ) . unfold issubmonoid . split . unfold issubsetwithbinop . intros a a' . apply ( natneq0andmult _ _ ( pr2 a ) ( pr2 a' ) ) . apply ( ct ( natneq , isdecrelnatneq, 1 , 0 ) ) . Defined . Lemma natnonzerocomm ( a b : natnonzero ) : paths ( @op natnonzero a b ) ( @op natnonzero b a ) . Proof . intros . apply ( invmaponpathsincl _ ( isinclpr1carrier _ ) ( @op natnonzero a b ) ( @op natnonzero b a ) ) . simpl . apply natmultcomm . Defined . (** *** Division with a remainder on [ nat ] For technical reasons it is more convenient to introduce divison with remainder for all pairs (n,m) including pairs of the form (n,0). *) Definition natdivrem ( n m : nat ) : dirprod nat nat . Proof. intros . induction n as [ | n IHn ] . intros . apply ( dirprodpair 0 0 ) . destruct ( natlthorgeh ( S ( pr2 IHn ) ) m ) . apply ( dirprodpair ( pr1 IHn ) ( S ( pr2 IHn ) ) ) . apply ( dirprodpair ( S ( pr1 IHn ) ) 0 ) . Defined . Definition natdiv ( n m : nat ) := pr1 ( natdivrem n m ) . Definition natrem ( n m : nat ) := pr2 ( natdivrem n m ) . Lemma lthnatrem ( n m : nat ) ( is : natneq m 0 ) : natlth ( natrem n m ) m . Proof. intro . destruct n as [ | n ] . unfold natrem . simpl . intros. apply ( natneq0togth0 _ is ) . unfold natrem . intros m is . simpl . destruct ( natlthorgeh (S (pr2 (natdivrem n m))) m ) as [ nt | t ] . simpl . apply nt . simpl . apply ( natneq0togth0 _ is ) . Defined . Theorem natdivremrule ( n m : nat ) ( is : natneq m 0 ) : paths n ( ( natrem n m ) + ( natdiv n m ) * m ) . Proof. intro . induction n as [ | n IHn ] . simpl . intros . apply idpath . intros m is . unfold natrem . unfold natdiv . simpl . destruct ( natlthorgeh ( S ( pr2 ( natdivrem n m ) ) ) m ) as [ nt | t ] . simpl . apply ( maponpaths S ( IHn m is ) ) . simpl . set ( is' := lthnatrem n m is ) . destruct ( natgthchoice2 _ _ is' ) as [ h | e ] . destruct ( natlehtonegnatgth _ _ t h ) . fold ( natdiv n m ) . set ( e'' := maponpaths S ( IHn m is ) ) . change (S (natrem n m + natdiv n m * m) ) with ( S ( natrem n m ) + natdiv n m * m ) in e'' . rewrite ( pathsinv0 e ) in e'' . apply e'' . Defined . Opaque natdivremrule . Lemma natlehmultnatdiv ( n m : nat ) ( is : natneq m 0 ) : natleh ( mult ( natdiv n m ) m ) n . Proof . intros . set ( e := natdivremrule n m ) . set ( int := ( natdiv n m ) * m ) . rewrite e . unfold int . apply ( natlehmplusnm _ _ ) . apply is . Defined . Theorem natdivremunique ( m i j i' j' : nat ) ( lj : natlth j m ) ( lj' : natlth j' m ) ( e : paths ( j + i * m ) ( j' + i' * m ) ) : dirprod ( paths i i' ) ( paths j j' ) . Proof. intros m i . induction i as [ | i IHi ] . intros j i' j' lj lj' . intro e . simpl in e . rewrite ( natplusr0 j ) in e . rewrite e in lj . destruct i' . simpl in e . rewrite ( natplusr0 j' ) in e . apply ( dirprodpair ( idpath _ ) e ) . simpl in lj . rewrite ( natpluscomm m ( i' * m ) ) in lj . rewrite ( pathsinv0 ( natplusassoc _ _ _ ) ) in lj . destruct ( negnatgthmplusnm _ _ lj ) . intros j i' j' lj lj' e . destruct i' as [ | i' ] . simpl in e . rewrite ( natplusr0 j' ) in e . rewrite ( pathsinv0 e ) in lj' . rewrite ( natpluscomm m ( i * m ) ) in lj' . rewrite ( pathsinv0 ( natplusassoc _ _ _ ) ) in lj' . destruct ( negnatgthmplusnm _ _ lj' ) . simpl in e . rewrite ( natpluscomm m ( i * m ) ) in e . rewrite ( natpluscomm m ( i' * m ) ) in e . rewrite ( pathsinv0 ( natplusassoc j _ _ ) ) in e . rewrite ( pathsinv0 ( natplusassoc j' _ _ ) ) in e . set ( e' := invmaponpathsincl _ ( isinclnatplusr m ) _ _ e ) . set ( ee := IHi j i' j' lj lj' e' ) . apply ( dirprodpair ( maponpaths S ( pr1 ee ) ) ( pr2 ee ) ) . Defined . Opaque natdivremunique . Lemma natdivremandmultl ( n m k : nat ) ( ism : natneq m 0 ) ( iskm : natneq ( k * m ) 0 ) : dirprod ( paths ( natdiv ( k * n ) ( k * m ) ) ( natdiv n m ) ) ( paths ( natrem ( k * n ) ( k * m ) ) ( k * ( natrem n m ) ) ) . Proof . intros . set ( ak := natdiv ( k * n ) ( k * m ) ) . set ( bk := natrem ( k * n ) ( k * m ) ) . set ( a := natdiv n m ) . set ( b := natrem n m ) . assert ( e1 : paths ( bk + ak * ( k * m ) ) ( ( b * k ) + a * ( k * m ) ) ) . unfold ak. unfold bk . rewrite ( pathsinv0 ( natdivremrule ( k * n ) ( k * m ) iskm ) ) . rewrite ( natmultcomm k m ) . rewrite ( pathsinv0 ( natmultassoc _ _ _ ) ) . rewrite ( pathsinv0 ( natrdistr _ _ _ ) ) . unfold a . unfold b . rewrite ( pathsinv0 ( natdivremrule n m ism ) ) . apply ( natmultcomm k n ) . assert ( l1 := lthnatrem n m ism ) . assert ( l1' := ( natlthandmultr _ _ _ ( natneq0andmultlinv _ _ iskm ) l1 ) ) . rewrite ( natmultcomm m k ) in l1' . set ( int := natdivremunique _ _ _ _ _ ( lthnatrem ( k * n ) ( k * m ) iskm ) l1' e1 ) . split with ( pr1 int ) . rewrite ( natmultcomm k b ) . apply ( pr2 int ) . Defined . Opaque natdivremandmultl . Definition natdivandmultl ( n m k : nat ) ( ism : natneq m 0 ) ( iskm : natneq ( k * m ) 0 ) : paths ( natdiv ( k * n ) ( k * m ) ) ( natdiv n m ) := pr1 ( natdivremandmultl _ _ _ ism iskm ) . Definition natremandmultl ( n m k : nat ) ( ism : natneq m 0 ) ( iskm : natneq ( k * m ) 0 ) : paths ( natrem ( k * n ) ( k * m ) ) ( k * ( natrem n m ) ) := pr2 ( natdivremandmultl _ _ _ ism iskm ) . Lemma natdivremandmultr ( n m k : nat ) ( ism : natneq m 0 ) ( ismk : natneq ( m * k ) 0 ) : dirprod ( paths ( natdiv ( n * k ) ( m * k ) ) ( natdiv n m ) ) ( paths ( natrem ( n * k ) ( m * k) ) ( ( natrem n m ) * k ) ) . Proof . intros . rewrite ( natmultcomm m k ) . rewrite ( natmultcomm m k ) in ismk . rewrite ( natmultcomm n k ) . rewrite ( natmultcomm ( natrem _ _ ) k ) . apply ( natdivremandmultl _ _ _ ism ismk ) . Defined . Opaque natdivremandmultr . Definition natdivandmultr ( n m k : nat ) ( ism : natneq m 0 ) ( ismk : natneq ( m * k ) 0 ) : paths ( natdiv ( n * k ) ( m * k ) ) ( natdiv n m ) := pr1 ( natdivremandmultr _ _ _ ism ismk ) . Definition natremandmultr ( n m k : nat ) ( ism : natneq m 0 ) ( ismk : natneq ( m * k ) 0 ) : paths ( natrem ( n * k ) ( m * k ) ) ( ( natrem n m ) * k ) := pr2 ( natdivremandmultr _ _ _ ism ismk ) . (** *** Exponentiation [ natpower n m ] ( " n to the power m " ) on [ nat ] *) Fixpoint natpower ( n m : nat ) := match m with O => 1 | S m' => n * ( natpower n m' ) end . (** *** Factorial on [ nat ] *) Fixpoint factorial ( n : nat ) := match n with 0 => 1 | S n' => ( S n' ) * ( factorial n' ) end . (** ** The order-preserving functions [ di i : nat -> nat ] whose image is the complement to one element [ i ] . *) Definition di ( i : nat ) ( x : nat ) : nat := match natlthorgeh x i with ii1 _ => x | ii2 _ => S x end . Lemma natlehdinsn ( i n : nat ) : natleh ( di i n ) ( S n ) . Proof . intros . unfold di . destruct ( natlthorgeh n i ) . apply natlthtoleh . apply natlthnsn . apply isreflnatleh . Defined . Lemma natgehdinn ( i n : nat ) : natgeh ( di i n ) n . Proof. intros . unfold di . destruct ( natlthorgeh n i ) . apply isreflnatleh . apply natlthtoleh . apply natlthnsn . Defined . Lemma isincldi ( i : nat ) : isincl ( di i ) . Proof. intro . apply ( isinclbetweensets ( di i ) isasetnat isasetnat ) . intros x x' . unfold di . intro e. destruct ( natlthorgeh x i ) as [ l | nel ] . destruct ( natlthorgeh x' i ) as [ l' | nel' ] . apply e . rewrite e in l . set ( e' := natgthtogths _ _ l ) . destruct ( nel' e' ) . destruct ( natlthorgeh x' i ) as [ l' | nel' ] . destruct e. set ( e' := natgthtogths _ _ l' ) . destruct ( nel e' ) . apply ( invmaponpathsS _ _ e ) . Defined . Lemma neghfiberdi ( i : nat ) : neg ( hfiber ( di i ) i ) . Proof. intros i hf . unfold di in hf . destruct hf as [ j e ] . destruct ( natlthorgeh j i ) as [ l | g ] . destruct e . apply ( isirreflnatlth _ l) . destruct e in g . apply ( negnatgehnsn _ g ) . Defined. Lemma iscontrhfiberdi ( i j : nat ) ( ne : neg ( paths i j ) ) : iscontr ( hfiber ( di i ) j ) . Proof. intros . apply iscontraprop1 . apply ( isincldi i j ) . destruct ( natlthorgeh j i ) as [ l | nel ] . split with j . unfold di . destruct ( natlthorgeh j i ) as [ l' | nel' ] . apply idpath . destruct ( nel' l ) . destruct ( natgehchoice2 _ _ nel ) as [ g | e ] . destruct j as [ | j ] . destruct ( negnatgeh0sn _ g ) . split with j . unfold di . destruct ( natlthorgeh j i ) as [ l' | g' ] . destruct ( g l' ) . apply idpath . destruct ( ne ( pathsinv0 e ) ) . Defined . Lemma isdecincldi ( i : nat ) : isdecincl ( di i ) . Proof. intro i . intro j . apply isdecpropif . apply ( isincldi i j ) . destruct ( isdeceqnat i j ) as [ eq | neq ] . destruct eq . apply ( ii2 ( neghfiberdi i ) ) . apply ( ii1 ( pr1 ( iscontrhfiberdi i j neq ) ) ) . Defined . (** ** Inductive types [ le ] with values in [ Type ] . This part is included for illustration purposes only . In practice it is easier to work with [ natleh ] than with [ le ] . *) (** *** A generalization of [ le ] and its properties . *) Inductive leF { T : Type } ( F : T -> T ) ( t : T ) : T -> Type := leF_O : leF F t t | leF_S : forall t' : T , leF F t t' -> leF F t ( F t' ) . Lemma leFiter { T : UU } ( F : T -> T ) ( t : T ) ( n : nat ) : leF F t ( iteration F n t ) . Proof. intros . induction n as [ | n IHn ] . apply leF_O . simpl . unfold funcomp . apply leF_S . assumption . Defined . Lemma leFtototal2withnat { T : UU } ( F : T -> T ) ( t t' : T ) ( a : leF F t t' ) : total2 ( fun n : nat => paths ( iteration F n t ) t' ) . Proof. intros. induction a as [ | b H0 IH0 ] . split with O . apply idpath . split with ( S ( pr1 IH0 ) ) . simpl . apply ( @maponpaths _ _ F ( iteration F ( pr1 IH0 ) t ) b ) . apply ( pr2 IH0 ) . Defined. Lemma total2withnattoleF { T : UU } ( F : T -> T ) ( t t' : T ) ( a : total2 ( fun n : nat => paths ( iteration F n t ) t' ) ) : leF F t t' . Proof. intros . destruct a as [ n e ] . destruct e . apply leFiter. Defined . Lemma leFtototal2withnat_l0 { T : UU } ( F : T -> T ) ( t : T ) ( n : nat ) : paths ( leFtototal2withnat F t _ (leFiter F t n)) ( tpair _ n ( idpath (iteration F n t) ) ) . Proof . intros . induction n as [ | n IHn ] . apply idpath . simpl . set ( h := fun ne : total2 ( fun n0 : nat => paths ( iteration F n0 t ) ( iteration F n t ) ) => tpair ( fun n0 : nat => paths ( iteration F n0 t ) ( iteration F ( S n ) t ) ) ( S ( pr1 ne ) ) ( maponpaths F ( pr2 ne ) ) ) . apply ( @maponpaths _ _ h _ _ IHn ) . Defined. Lemma isweqleFtototal2withnat { T : UU } ( F : T -> T ) ( t t' : T ) : isweq ( leFtototal2withnat F t t' ) . Proof . intros . set ( f := leFtototal2withnat F t t' ) . set ( g := total2withnattoleF F t t' ) . assert ( egf : forall x : _ , paths ( g ( f x ) ) x ) . intro x . induction x as [ | y H0 IHH0 ] . apply idpath . simpl . simpl in IHH0 . destruct (leFtototal2withnat F t y H0 ) as [ m e ] . destruct e . simpl . simpl in IHH0. apply ( @maponpaths _ _ ( leF_S F t (iteration F m t) ) _ _ IHH0 ) . assert ( efg : forall x : _ , paths ( f ( g x ) ) x ) . intro x . destruct x as [ n e ] . destruct e . simpl . apply leFtototal2withnat_l0 . apply ( gradth _ _ egf efg ) . Defined. Definition weqleFtototalwithnat { T : UU } ( F : T -> T ) ( t t' : T ) : weq ( leF F t t' ) ( total2 ( fun n : nat => paths ( iteration F n t ) t' ) ) := weqpair _ ( isweqleFtototal2withnat F t t' ) . (** *** Inductive types [ le ] with values in [ Type ] are in [ hProp ] *) Definition le ( n : nat ) : nat -> Type := leF S n . Definition le_n := leF_O S . Definition le_S := leF_S S . Theorem isaprople ( n m : nat ) : isaprop ( le n m ) . Proof. intros . apply ( isofhlevelweqb 1 ( weqleFtototalwithnat S n m ) ) . apply invproofirrelevance . intros x x' . set ( i := @pr1 _ (fun n0 : nat => paths (iteration S n0 n) m) ) . assert ( is : isincl i ) . apply ( isinclpr1 _ ( fun n0 : nat => isasetnat (iteration S n0 n) m ) ) . apply ( invmaponpathsincl _ is ) . destruct x as [ n1 e1 ] . destruct x' as [ n2 e2 ] . simpl . set ( int1 := pathsinv0 ( pathsitertoplus n1 n ) ) . set ( int2 := pathsinv0 (pathsitertoplus n2 n ) ) . set ( ee1 := pathscomp0 int1 e1 ) . set ( ee2 := pathscomp0 int2 e2 ) . set ( e := pathscomp0 ee1 ( pathsinv0 ee2 ) ) . apply ( invmaponpathsincl _ ( isinclnatplusr n ) n1 n2 e ) . Defined . (** *** Comparison between [ le ] with values in [ Type ] and [ natleh ] . *) Lemma letoleh ( n m : nat ) : le n m -> natleh n m . Proof . intros n m H . induction H as [ | m H0 IHH0 ] . apply isreflnatleh . apply natlehtolehs . assumption . Defined . Lemma natlehtole ( n m : nat ) : natleh n m -> le n m . Proof. intros n m H . induction m . assert ( int := natleh0tois0 n H ) . clear H . destruct int . apply le_n . set ( int2 := natlehchoice2 n ( S m ) H ) . destruct int2 as [ isnatleh | iseq ] . apply ( le_S n m ( IHm isnatleh ) ) . destruct iseq . apply le_n . Defined . Lemma isweqletoleh ( n m : nat ) : isweq ( letoleh n m ) . Proof. intros . set ( is1 := isaprople n m ) . set ( is2 := pr2 ( natleh n m ) ) . apply ( isweqimplimpl ( letoleh n m ) ( natlehtole n m ) is1 is2 ) . Defined . Definition weqletoleh ( n m : nat ) := weqpair _ ( isweqletoleh n m ) . (* End of the file hnat.v *) Voevodsky-Coq/hlevel2/._hq.v000777 000765 000024 00000000256 12346040720 016564 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/hq.v000777 000765 000024 00000074016 12346040720 016354 0ustar00nicolastaff000000 000000 (** * 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 ".." as Foundations. 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 *) Voevodsky-Coq/hlevel2/._hSet.v000777 000765 000024 00000000256 12346040720 017057 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/hSet.v000777 000765 000024 00000251573 12346040720 016654 0ustar00nicolastaff000000 000000 (** * Generalities on [ hSet ] . Vladimir Voevodsky. Feb. - Sep. 2011 In this file we introduce the type [ hSet ] of h-sets i.e. of types of h-level 2 as well as a number of constructions such as type of (monic) subtypes, images, surjectivity etc. which, while they formally apply to functions between arbitrary types actually only depend on the behavior of the function on the sets of connected componenets of these types. While it is possible to write a part of this file in a form which does not require RR1 it seems like a waste of effort since it would require to repeat a lot of things twice. Accordingly we assume RR1 from the start in dealing with sets. The drawback is that all the subsequent files will not compile at the moment without the Type in Type patch. *) (** ** Preambule *) (** Settings *) Unset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *) (** Imports *) Add LoadPath ".." as Foundations. Require Export Foundations.hlevel1.hProp . (** ** The type of sets i.e. of types of h-level 2 in [ UU ] *) Definition hSet:= total2 (fun X : UU => isaset X) . Definition hSetpair := tpair (fun X : UU => isaset X). Definition pr1hSet:= @pr1 UU (fun X : UU => isaset X) : hSet -> Type. Coercion pr1hSet: hSet >-> Sortclass. Definition eqset { X : hSet } ( x x' : X ) : hProp := hProppair _ ( pr2 X x x' ) . Definition setproperty ( X : hSet ) := pr2 X . Definition setdirprod ( X Y : hSet ) : hSet . Proof . intros . split with ( dirprod X Y ) . apply ( isofhleveldirprod 2 ) . apply ( pr2 X ) . apply ( pr2 Y ) . Defined . (** [ hProp ] as a set *) Definition hPropset : hSet := tpair _ hProp isasethProp . (* Canonical Structure hPropset. *) (** Booleans as a set *) Definition boolset : hSet := hSetpair bool isasetbool . (* Canonical Structure boolset . *) (** ** Types [ X ] which satisfy " weak " axiom of choice for all families [ P : X -> UU ] Weak axiom of choice for [ X ] is the condition that for any family [ P : X -> UU ] over [ X ] such that all members of the family are inhabited the space of sections of the family is inhabited . Equivalently one can formulate it as an assertion that for any surjection ( see below ) [ p : Y -> X ] the space of sections of this surjection i.e. functions [ s : X -> Y ] together with a homotopy from [ funcomp s p ] to [ idfun X ] is inhabited . It does not provide a choice of a section for such a family or a surjection . In topos-theoretic semantics this condition corresponds to " local projectivity " of [ X ] . It automatically holds for the point [ unit ] but need not hold for sub-objects of [ unit ] i.e. for types of h-level 1 ( propositions ) . In particular it does not have to hold for general types with decidable equality . Intuition based on standard univalent models suggests that any type satisfying weak axiom of choice is a set . Indeed it seems to be possible to show that if both a type and the set of connected components of this type ( see below ) satisfy weak axiom of choice then the type is a set . In particular , if one imposes weak axiom of choice for sets as an axiom then it would follow that every type satisfying weak axiom of choice is a set . I do not know however if there are models which would validate a possibility of types other than sets to satisfy weak axiom of choice . *) Definition ischoicebase_uu1 ( X : UU ) := forall P : X -> UU , ( forall x : X , ishinh ( P x ) ) -> ishinh ( forall x : X , P x ) . Lemma isapropischoicebase ( X : UU ) : isaprop ( ischoicebase_uu1 X ) . (** Uses RR1 *) Proof . intro . apply impred . intro P . apply impred . intro fs . apply ( pr2 ( ishinh _ ) ) . Defined . Definition ischoicebase ( X : UU ) : hProp := hProppair _ ( isapropischoicebase X ) . Lemma ischoicebaseweqf { X Y : UU } ( w : weq X Y ) ( is : ischoicebase X ) : ischoicebase Y . Proof . intros . unfold ischoicebase . intros Q fs . apply ( hinhfun ( invweq ( weqonsecbase Q w ) ) ) . apply ( is ( funcomp w Q ) ( fun x : X => fs ( w x ) ) ) . Defined . Lemma ischoicebaseweqb { X Y : UU } ( w : weq X Y ) ( is : ischoicebase Y ) : ischoicebase X . Proof . intros . apply ( ischoicebaseweqf ( invweq w ) is ) . Defined . Lemma ischoicebaseunit : ischoicebase unit . Proof . unfold ischoicebase . intros P fs . apply ( hinhfun ( tosecoverunit P ) ) . apply ( fs tt ) . Defined . Lemma ischoicebasecontr { X : UU } ( is : iscontr X ) : ischoicebase X . Proof . intros . apply ( ischoicebaseweqb ( weqcontrtounit is ) ischoicebaseunit ) . Defined . Lemma ischoicebaseempty : ischoicebase empty . Proof . unfold ischoicebase . intros P fs . apply ( hinhpr _ ( fun x : empty => fromempty x ) ) . Defined . Lemma ischoicebaseempty2 { X : UU } ( is : neg X ) : ischoicebase X . Proof . intros . apply ( ischoicebaseweqb ( weqtoempty is ) ischoicebaseempty ) . Defined . Lemma ischoicebasecoprod { X Y : UU } ( isx : ischoicebase X ) ( isy : ischoicebase Y ) : ischoicebase ( coprod X Y ) . Proof . intros . unfold ischoicebase . intros P fs . apply ( hinhfun ( invweq ( weqsecovercoprodtoprod P ) ) ) . apply hinhand . apply ( isx _ ( fun x : X => fs ( ii1 x ) ) ) . apply ( isy _ ( fun y : Y => fs ( ii2 y ) ) ) . Defined . (** ** The type of monic subtypes of a type (subsets of the set of connected components) *) (** *** Genneral definitions *) Definition hsubtypes ( X : UU ) := X -> hProp . Identity Coercion id_hsubtypes : hsubtypes >-> Funclass . Definition carrier { X : UU } ( A : hsubtypes X ) := total2 A. Coercion carrier : hsubtypes >-> Sortclass. Definition carrierpair { X : UU } ( A : hsubtypes X ) := tpair A. Definition pr1carrier { X:UU } ( A : hsubtypes X ) := @pr1 _ _ : carrier A -> X . Lemma isinclpr1carrier { X : UU } ( A : hsubtypes X ) : isincl ( @pr1carrier X A ) . Proof . intros . apply ( isinclpr1 A ( fun x : _ => pr2 ( A x ) ) ) . Defined . Lemma isasethsubtypes (X:UU): isaset (hsubtypes X). Proof. intro . change ( isofhlevel 2 ( hsubtypes X ) ) . apply impred . intro. apply isasethProp. Defined. Definition totalsubtype ( X : UU ) : hsubtypes X := fun x => htrue . Definition weqtotalsubtype ( X : UU ) : weq ( totalsubtype X ) X . Proof . intro . apply weqpr1 . intro . apply iscontrunit . Defined . (** *** Direct product of two subtypes *) Definition subtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : hsubtypes ( dirprod X Y ) := fun xy : _ => hconj ( A ( pr1 xy ) ) ( B ( pr2 xy ) ) . Definition fromdsubtypesdirprodcarrier { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( xyis : subtypesdirprod A B ) : dirprod A B . Proof . intros . set ( xy := pr1 xyis ) . set ( is := pr2 xyis ) . set ( x := pr1 xy ) . set ( y := pr2 xy ) . simpl in is . simpl in y . apply ( dirprodpair ( tpair A x ( pr1 is ) ) ( tpair B y ( pr2 is ) ) ) . Defined . Definition tosubtypesdirprodcarrier { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( xisyis : dirprod A B ) : subtypesdirprod A B . Proof . intros . set ( xis := pr1 xisyis ) . set ( yis := pr2 xisyis ) . set ( x := pr1 xis ) . set ( isx := pr2 xis ) . set ( y := pr1 yis ) . set ( isy := pr2 yis ) . simpl in isx . simpl in isy . apply ( tpair ( subtypesdirprod A B ) ( dirprodpair x y ) ( dirprodpair isx isy ) ) . Defined . Lemma weqsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : weq ( subtypesdirprod A B ) ( dirprod A B ) . Proof . intros . set ( f := fromdsubtypesdirprodcarrier A B ) . set ( g := tosubtypesdirprodcarrier A B ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . destruct a as [ xy is ] . destruct xy as [ x y ] . destruct is as [ isx isy ] . apply idpath . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . destruct a as [ xis yis ] . destruct xis as [ x isx ] . destruct yis as [ y isy ] . apply idpath . apply ( gradth _ _ egf efg ) . Defined . Lemma ishinhsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( isa : ishinh A ) ( isb : ishinh B ) : ishinh ( subtypesdirprod A B ) . Proof . intros . apply ( hinhfun ( invweq ( weqsubtypesdirprod A B ) ) ) . apply hinhand . apply isa . apply isb . Defined . (** *** A a subtype of with a paths between any every two elements is an h-prop. *) Lemma isapropsubtype { X : UU } ( A : hsubtypes X ) ( is : forall ( x1 x2 : X ) , A x1 -> A x2 -> paths x1 x2 ) : isaprop ( carrier A ) . Proof. intros. apply invproofirrelevance. intros x x' . assert ( isincl ( @pr1 _ A )). apply isinclpr1. intro x0. apply ( pr2 ( A x0 )). apply ( invmaponpathsincl ( @pr1 _ A ) X0 ). destruct x as [ x0 is0 ]. destruct x' as [ x0' is0' ] . simpl. apply is. assumption. assumption. Defined. (* End of " the type of monic subtypes of a type " . *) (** ** Relations on types ( or equivalently relations on the sets of connected components) *) (** *** Relations and boolean relations *) Definition hrel ( X : UU ) := X -> X -> hProp. Identity Coercion idhrel : hrel >-> Funclass . Definition brel ( X : UU ) := X -> X -> bool . Identity Coercion idbrel : brel >-> Funclass . (** *** Standard properties of relations *) Definition istrans { X : UU } ( R : hrel X ) := forall ( x1 x2 x3 : X ) ( r12 : R x1 x2 ) ( r23 : R x2 x3 ) , R x1 x3. Definition isrefl { X : UU } ( R : hrel X ) := forall x : X , R x x. Definition issymm { X : UU } ( R : hrel X ) := forall ( x1 x2 : X ) ( r12 : R x1 x2 ) , R x2 x1 . Definition ispo { X : UU } ( R : hrel X ) := dirprod ( istrans R ) ( isrefl R ) . Definition iseqrel { X : UU } ( R : hrel X ) := dirprod ( ispo R ) ( issymm R ) . Definition iseqrelconstr { X : UU } { R : hrel X } ( trans0 : istrans R ) ( refl0 : isrefl R ) ( symm0 : issymm R ) : iseqrel R := dirprodpair ( dirprodpair trans0 refl0 ) symm0 . Definition isirrefl { X : UU } ( R : hrel X ) := forall x : X , neg ( R x x ) . Definition isasymm { X : UU } ( R : hrel X ) := forall ( x1 x2 : X ) ( r12 : R x1 x2 ) ( r21 : R x2 x1 ) , empty . Definition iscoasymm { X : UU } ( R : hrel X ) := forall x1 x2 , neg ( R x1 x2 ) -> R x2 x1 . Definition istotal { X : UU } ( R : hrel X ) := forall x1 x2 , hdisj ( R x1 x2 ) ( R x2 x1 ) . Definition iscotrans { X : UU } ( R : hrel X ) := forall x1 x2 x3 , R x1 x3 -> hdisj ( R x1 x2 ) ( R x2 x3 ) . Definition isdecrel { X : UU } ( R : hrel X ) := forall x1 x2 , coprod ( R x1 x2 ) ( neg ( R x1 x2 ) ) . Definition isnegrel { X : UU } ( R : hrel X ) := forall x1 x2 , neg ( neg ( R x1 x2 ) ) -> R x1 x2 . (** Note that the property of being (co-)antisymmetric is different from other properties of relations which we consider due to the presence of [ paths ] in its formulation . As a consequence it behaves differently relative to the quotients of types - the quotient relation can be (co-)antisymmetric while the original relation was not . *) Definition isantisymm { X : UU } ( R : hrel X ) := forall ( x1 x2 : X ) ( r12 : R x1 x2 ) ( r21 : R x2 x1 ) , paths x1 x2 . Definition isantisymmneg { X : UU } ( R : hrel X ) := forall ( x1 x2 : X ) ( nr12 : neg ( R x1 x2 ) ) ( nr21 : neg ( R x2 x1 ) ) , paths x1 x2 . Definition iscoantisymm { X : UU } ( R : hrel X ) := forall x1 x2 , neg ( R x1 x2 ) -> coprod ( R x2 x1 ) ( paths x1 x2 ) . (** Note that the following condition on a relation is different from all the other which we have considered since it is not a property but a structure, i.e. it is in general unclear whether [ isaprop ( neqchoice R ) ] is provable. *) Definition neqchoice { X : UU } ( R : hrel X ) := forall x1 x2 , neg ( paths x1 x2 ) -> coprod ( R x1 x2 ) ( R x2 x1 ) . (** *** Elementary implications between properties of relations *) Lemma istransandirrefltoasymm { X : UU } { R : hrel X } ( is1 : istrans R ) ( is2 : isirrefl R ) : isasymm R . Proof . intros . intros a b rab rba . apply ( is2 _ ( is1 _ _ _ rab rba ) ) . Defined . Lemma istotaltoiscoasymm { X : UU } { R : hrel X } ( is : istotal R ) : iscoasymm R . Proof . intros . intros x1 x2 . apply ( hdisjtoimpl ( is _ _ ) ) . Defined . Lemma isdecreltoisnegrel { X : UU } { R : hrel X } ( is : isdecrel R ) : isnegrel R . Proof . intros . intros x1 x2 . destruct ( is x1 x2 ) as [ r | nr ] . intro . apply r . intro nnr . destruct ( nnr nr ) . Defined . Lemma isantisymmnegtoiscoantisymm { X : UU } { R : hrel X } ( isdr : isdecrel R ) ( isr : isantisymmneg R ) : iscoantisymm R . Proof . intros . intros x1 x2 nrx12 . destruct ( isdr x2 x1 ) as [ r | nr ] . apply ( ii1 r ) . apply ii2 . apply ( isr _ _ nrx12 nr ) . Defined . Lemma rtoneq { X : UU } { R : hrel X } ( is : isirrefl R ) { a b : X } ( r : R a b ) : neg ( paths a b ) . Proof . intros . intro e . rewrite e in r . apply ( is b r ) . Defined . (** *** Standard properties of relations and logical equivalences *) Definition hrellogeq { X : UU } ( L R : hrel X ) := forall x1 x2 , ( L x1 x2 <-> R x1 x2 ) . Definition istranslogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : istrans L ) : istrans R . Proof . intros . intros x1 x2 x3 r12 r23 . apply ( ( pr1 ( lg _ _ ) ) ( isl _ _ _ ( ( pr2 ( lg _ _ ) ) r12 ) ( ( pr2 ( lg _ _ ) ) r23 ) ) ) . Defined . Definition isrefllogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isrefl L ) : isrefl R . Proof . intros . intro x . apply ( pr1 ( lg _ _ ) ( isl x ) ) . Defined . Definition issymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : issymm L ) : issymm R . Proof . intros . intros x1 x2 r12 . apply ( pr1 ( lg _ _ ) ( isl _ _ ( pr2 ( lg _ _ ) r12 ) ) ) . Defined . Definition ispologeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : ispo L ) : ispo R . Proof . intros . apply ( dirprodpair ( istranslogeqf lg ( pr1 isl ) ) ( isrefllogeqf lg ( pr2 isl ) ) ) . Defined . Definition iseqrellogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : iseqrel L ) : iseqrel R . Proof . intros . apply ( dirprodpair ( ispologeqf lg ( pr1 isl ) ) ( issymmlogeqf lg ( pr2 isl ) ) ) . Defined . Definition isirrefllogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isirrefl L ) : isirrefl R . Proof . intros . intros x r . apply ( isl _ ( pr2 ( lg x x ) r ) ) . Defined . Definition isasymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isasymm L ) : isasymm R . Proof . intros . intros x1 x2 r12 r21 . apply ( isl _ _ ( pr2 ( lg _ _ ) r12 ) ( pr2 ( lg _ _ ) r21 ) ) . Defined . Definition iscoasymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : iscoasymm L ) : iscoasymm R . Proof . intros . intros x1 x2 r12 . apply ( ( pr1 ( lg _ _ ) ) ( isl _ _ ( negf ( pr1 ( lg _ _ ) ) r12 ) ) ) . Defined . Definition istotallogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : istotal L ) : istotal R . Proof . intros . intros x1 x2 . set ( int := isl x1 x2 ) . generalize int . clear int . simpl . apply hinhfun . apply ( coprodf ( pr1 ( lg x1 x2 ) ) ( pr1 ( lg x2 x1 ) ) ) . Defined . Definition iscotranslogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : iscotrans L ) : iscotrans R . Proof . intros . intros x1 x2 x3 r13 . set ( int := isl x1 x2 x3 ( pr2 ( lg _ _ ) r13 ) ) . generalize int . clear int . simpl . apply hinhfun . apply ( coprodf ( pr1 ( lg x1 x2 ) ) ( pr1 ( lg x2 x3 ) ) ) . Defined . Definition isdecrellogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isdecrel L ) : isdecrel R . Proof . intros . intros x1 x2 . destruct ( isl x1 x2 ) as [ l | nl ] . apply ( ii1 ( pr1 ( lg _ _ ) l ) ) . apply ( ii2 ( negf ( pr2 ( lg _ _ ) ) nl ) ) . Defined . Definition isnegrellogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isnegrel L ) : isnegrel R . Proof . intros . intros x1 x2 nnr . apply ( ( pr1 ( lg _ _ ) ) ( isl _ _ ( negf ( negf ( pr2 ( lg _ _ ) ) ) nnr ) ) ) . Defined . Definition isantisymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isantisymm L ) : isantisymm R . Proof . intros . intros x1 x2 r12 r21 . apply ( isl _ _ ( pr2 ( lg _ _ ) r12 ) ( pr2 ( lg _ _ ) r21 ) ) . Defined . Definition isantisymmneglogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isantisymmneg L ) : isantisymmneg R . Proof . intros . intros x1 x2 nr12 nr21 . apply ( isl _ _ ( negf ( pr1 ( lg _ _ ) ) nr12 ) ( negf ( pr1 ( lg _ _ ) ) nr21 ) ) . Defined . Definition iscoantisymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : iscoantisymm L ) : iscoantisymm R . Proof . intros . intros x1 x2 r12 . set ( int := isl _ _ ( negf ( pr1 ( lg _ _ ) ) r12 ) ) . generalize int . clear int . simpl . apply ( coprodf ( pr1 ( lg _ _ ) ) ( idfun _ ) ) . Defined . Definition neqchoicelogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : neqchoice L ) : neqchoice R . Proof . intros . intros x1 x2 ne . apply ( coprodf ( pr1 ( lg x1 x2 ) ) ( pr1 ( lg x2 x1 ) ) ( isl _ _ ne ) ) . Defined . (** *** Preorderings and associated types . *) Definition po ( X : UU ) := total2 ( fun R : hrel X => ispo R ) . Definition popair { X : UU } ( R : hrel X ) ( is : ispo R ) : po X := tpair ( fun R : hrel X => ispo R ) R is . Definition carrierofpo ( X : UU ) : po X -> ( X -> X -> hProp ) := @pr1 _ ( fun R : hrel X => ispo R ) . Coercion carrierofpo : po >-> Funclass . Definition Poset := total2 ( fun X : hSet => po X ) . Definition Posetpair ( X : hSet ) ( R : po X ) : Poset := tpair ( fun X : hSet => po X ) X R . Definition carrierofposet : Poset -> hSet := @pr1 _ _ . Coercion carrierofposet : Poset >-> hSet . Definition isaposetmorphism { X Y : Poset } ( f : X -> Y ) := forall x x' : X , ( pr1 ( pr2 X ) x x' ) -> ( pr1 ( pr2 Y ) ( f x ) ( f x' ) ) . Definition posetmorphism ( X Y : Poset ) := total2 ( fun f : X -> Y => isaposetmorphism f ) . Definition posetmorphismpair ( X Y : Poset ) := tpair ( fun f : X -> Y => isaposetmorphism f ) . Definition carrierofposetmorphism ( X Y : Poset ) : posetmorphism X Y -> ( X -> Y ) := @pr1 _ _ . Coercion carrierofposetmorphism : posetmorphism >-> Funclass . (** *** Eqivalence relations and associated types . *) Definition eqrel ( X : UU ) := total2 ( fun R : hrel X => iseqrel R ) . Definition eqrelpair { X : UU } ( R : hrel X ) ( is : iseqrel R ) : eqrel X := tpair ( fun R : hrel X => iseqrel R ) R is . Definition eqrelconstr { X : UU } ( R : hrel X ) ( is1 : istrans R ) ( is2 : isrefl R ) ( is3 : issymm R ) : eqrel X := eqrelpair R ( dirprodpair ( dirprodpair is1 is2 ) is3 ) . Definition pr1eqrel ( X : UU ) : eqrel X -> ( X -> ( X -> hProp ) ) := @pr1 _ _ . Coercion pr1eqrel : eqrel >-> Funclass . Definition eqreltrans { X : UU } ( R : eqrel X ) : istrans R := pr1 ( pr1 ( pr2 R ) ) . Definition eqrelrefl { X : UU } ( R : eqrel X ) : isrefl R := pr2 ( pr1 ( pr2 R ) ) . Definition eqrelsymm { X : UU } ( R : eqrel X ) : issymm R := pr2 ( pr2 R ) . (** *** Direct product of two relations *) Definition hreldirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) : hrel ( dirprod X Y ) := fun xy xy' : dirprod X Y => hconj ( RX ( pr1 xy ) ( pr1 xy' ) ) ( RY ( pr2 xy ) ( pr2 xy' ) ) . Definition istransdirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) ( isx : istrans RX ) ( isy : istrans RY ) : istrans ( hreldirprod RX RY ) := fun xy1 xy2 xy3 : _ => fun is12 : _ => fun is23 : _ => dirprodpair ( isx _ _ _ ( pr1 is12 ) ( pr1 is23 ) ) ( isy _ _ _ ( pr2 is12 ) ( pr2 is23 ) ) . Definition isrefldirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) ( isx : isrefl RX ) ( isy : isrefl RY ) : isrefl ( hreldirprod RX RY ) := fun xy : _ => dirprodpair ( isx _ ) ( isy _ ) . Definition issymmdirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) ( isx : issymm RX ) ( isy : issymm RY ) : issymm ( hreldirprod RX RY ) := fun xy1 xy2 : _ => fun is12 : _ => dirprodpair ( isx _ _ ( pr1 is12 ) ) ( isy _ _ ( pr2 is12 ) ) . Definition eqreldirprod { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) : eqrel ( dirprod X Y ) := eqrelconstr ( hreldirprod RX RY ) ( istransdirprod _ _ ( eqreltrans RX ) ( eqreltrans RY ) ) ( isrefldirprod _ _ ( eqrelrefl RX ) ( eqrelrefl RY ) ) ( issymmdirprod _ _ ( eqrelsymm RX ) ( eqrelsymm RY ) ) . (** *** Negation of a relation and its properties *) Definition negrel { X : UU } ( R : hrel X ) : hrel X := fun x x' => hProppair _ ( isapropneg ( R x x' ) ) . Lemma istransnegrel { X : UU } ( R : hrel X ) ( isr : iscotrans R ) : istrans ( negrel R ) . Proof . intros . intros x1 x2 x3 r12 r23 . apply ( negf ( isr x1 x2 x3 ) ) . apply ( toneghdisj ( dirprodpair r12 r23 ) ) . Defined . Lemma isasymmnegrel { X : UU } ( R : hrel X ) ( isr : iscoasymm R ) : isasymm ( negrel R ) . Proof . intros . intros x1 x2 r12 r21 . apply ( r21 ( isr _ _ r12 ) ) . Defined . Lemma iscoasymmgenrel { X : UU } ( R : hrel X ) ( isr : isasymm R ) : iscoasymm ( negrel R ) . Proof . intros . intros x1 x2 nr12 . apply ( negf ( isr _ _ ) nr12 ) . Defined . Lemma isdecnegrel { X : UU } ( R : hrel X ) ( isr : isdecrel R ) : isdecrel ( negrel R ) . Proof . intros . intros x1 x2 . destruct ( isr x1 x2 ) as [ r | nr ] . apply ii2 . apply ( todneg _ r ) . apply ( ii1 nr ) . Defined . Lemma isnegnegrel { X : UU } ( R : hrel X ) : isnegrel ( negrel R ) . Proof . intros . intros x1 x2 . apply ( negf ( todneg ( R x1 x2 ) ) ) . Defined . Lemma isantisymmnegrel { X : UU } ( R : hrel X ) ( isr : isantisymmneg R ) : isantisymm ( negrel R ) . Proof . intros . apply isr . Defined . (** *** Boolean representation of decidable equality *) Definition eqh { X : UU } ( is : isdeceq X ) : hrel X := fun x x' => hProppair ( paths ( booleq is x x' ) true ) ( isasetbool ( booleq is x x' ) true ) . Definition neqh { X : UU } ( is : isdeceq X ) : hrel X := fun x x' => hProppair ( paths ( booleq is x x' ) false ) ( isasetbool ( booleq is x x' ) false ) . Lemma isrefleqh { X : UU } ( is : isdeceq X ) : isrefl ( eqh is ) . Proof . intros . unfold eqh . unfold booleq . intro x . destruct ( is x x ) as [ e | ne ] . simpl . apply idpath . destruct ( ne ( idpath x ) ) . Defined . Definition weqeqh { X : UU } ( is : isdeceq X ) ( x x' : X ) : weq ( paths x x' ) ( eqh is x x' ) . Proof . intros . apply weqimplimpl . intro e . destruct e . apply isrefleqh . intro e . unfold eqh in e . unfold booleq in e . destruct ( is x x' ) as [ e' | ne' ] . apply e' . destruct ( nopathsfalsetotrue e ) . unfold isaprop. unfold isofhlevel. apply ( isasetifdeceq X is x x' ) . unfold eqh . simpl . unfold isaprop. unfold isofhlevel. apply ( isasetbool _ true ) . Defined . Definition weqneqh { X : UU } ( is : isdeceq X ) ( x x' : X ) : weq ( neg ( paths x x' ) ) ( neqh is x x' ) . Proof . intros . unfold neqh . unfold booleq . apply weqimplimpl . destruct ( is x x' ) as [ e | ne ] . intro ne . destruct ( ne e ) . intro ne' . simpl . apply idpath . destruct ( is x x' ) as [ e | ne ] . intro tf . destruct ( nopathstruetofalse tf ) . intro . exact ne . apply ( isapropneg ) . simpl . unfold isaprop. unfold isofhlevel. apply ( isasetbool _ false ) . Defined . (** *** Boolean representation of decidable relations *) Definition decrel ( X : UU ) := total2 ( fun R : hrel X => isdecrel R ) . Definition pr1decrel ( X : UU ) : decrel X -> hrel X := @pr1 _ _ . Definition decrelpair { X : UU } { R : hrel X } ( is : isdecrel R ) : decrel X := tpair _ R is . Coercion pr1decrel : decrel >-> hrel . Definition decreltobrel { X : UU } ( R : decrel X ) : brel X . Proof . intros . intros x x' . destruct ( ( pr2 R ) x x' ) . apply true . apply false . Defined . Definition breltodecrel { X : UU } ( B : brel X ) : decrel X := @decrelpair _ ( fun x x' => hProppair ( paths ( B x x' ) true ) ( isasetbool _ _ ) ) ( fun x x' => ( isdeceqbool _ _ ) ) . Definition pathstor { X : UU } ( R : decrel X ) ( x x' : X ) ( e : paths ( decreltobrel R x x' ) true ) : R x x' . Proof . unfold decreltobrel . intros . destruct ( pr2 R x x' ) as [ e' | ne ] . apply e' . destruct ( nopathsfalsetotrue e ) . Defined . Definition rtopaths { X : UU } ( R : decrel X ) ( x x' : X ) ( r : R x x' ) : paths ( decreltobrel R x x' ) true . Proof . unfold decreltobrel . intros . destruct ( ( pr2 R ) x x' ) as [ r' | nr ] . apply idpath . destruct ( nr r ) . Defined . Definition pathstonegr { X : UU } ( R : decrel X ) ( x x' : X ) ( e : paths ( decreltobrel R x x' ) false ) : neg ( R x x' ) . Proof . unfold decreltobrel . intros . destruct ( pr2 R x x' ) as [ e' | ne ] . destruct ( nopathstruetofalse e ) . apply ne . Defined . Definition negrtopaths { X : UU } ( R : decrel X ) ( x x' : X ) ( nr : neg ( R x x' ) ) : paths ( decreltobrel R x x' ) false . Proof . unfold decreltobrel . intros . destruct ( pr2 R x x' ) as [ r | nr' ] . destruct ( nr r ) . apply idpath. Defined . (** The following construction of "ct" ( "canonical term" ) is inspired by the ideas of George Gonthier. The expression [ ct ( R , x , y ) ] where [ R ] is in [ hrel X ] for some [ X ] and has a canonical structure of a decidable relation and [ x, y ] are closed terms of type [ X ] such that [ R x y ] is inhabited is the term of type [ R x y ] which relizes the canonical term in [ isdecrel R x y ] . Definition pathstor_comp { X : UU } ( R : decrel X ) ( x x' : X ) ( e : paths ( decreltobrel R x x' ) true ) : R x x' . Proof . unfold decreltobrel . intros . destruct ( pr2 R x x' ) as [ e' | ne ] . apply e' . destruct ( nopathsfalsetotrue e ) . Defined . Notation " 'ct' ( R , x , y ) " := ( ( pathstor_comp _ x y ( idpath true ) ) : R x y ) (at level 70 ) . *) Definition ctlong { X : UU } ( R : hrel X ) ( is : isdecrel R ) ( x x' : X ) ( e : paths ( decreltobrel (decrelpair is ) x x' ) true ) : R x x' . Proof . unfold decreltobrel . intros . simpl in e . destruct ( is x x' ) as [ e' | ne ] . apply e' . destruct ( nopathsfalsetotrue e ) . Defined . Notation " 'ct' ( R , is , x , y ) " := ( ctlong R is x y ( idpath true ) ) ( at level 70 ) . (** **** Restriction of a relation to a subtype *) Definition resrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) : hrel P := fun p1 p2 => L ( pr1 p1 ) ( pr1 p2 ) . Definition istransresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : istrans L ) : istrans ( resrel L P ) . Proof . intros . intros x1 x2 x3 r12 r23 . apply ( isl _ ( pr1 x2 ) _ r12 r23 ) . Defined . Definition isreflresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isrefl L ) : isrefl ( resrel L P ) . Proof . intros . intro x . apply isl . Defined . Definition issymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : issymm L ) : issymm ( resrel L P ) . Proof . intros . intros x1 x2 r12 . apply isl . apply r12 . Defined . Definition isporesrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : ispo L ) : ispo ( resrel L P ) . Proof . intros . apply ( dirprodpair ( istransresrel L P ( pr1 isl ) ) ( isreflresrel L P ( pr2 isl ) ) ) . Defined . Definition iseqrelresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : iseqrel L ) : iseqrel ( resrel L P ) . Proof . intros . apply ( dirprodpair ( isporesrel L P ( pr1 isl ) ) ( issymmresrel L P ( pr2 isl ) ) ) . Defined . Definition isirreflresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isirrefl L ) : isirrefl ( resrel L P ) . Proof . intros . intros x r . apply ( isl _ r ) . Defined . Definition isasymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isasymm L ) : isasymm ( resrel L P ) . Proof . intros . intros x1 x2 r12 r21 . apply ( isl _ _ r12 r21 ) . Defined . Definition iscoasymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : iscoasymm L ) : iscoasymm ( resrel L P ) . Proof . intros . intros x1 x2 r12 . apply ( isl _ _ r12 ) . Defined . Definition istotalresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : istotal L ) : istotal ( resrel L P ) . Proof . intros . intros x1 x2 . apply isl . Defined . Definition iscotransresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : iscotrans L ) : iscotrans ( resrel L P ) . Proof . intros . intros x1 x2 x3 r13 . apply ( isl _ _ _ r13 ) . Defined . Definition isdecrelresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isdecrel L ) : isdecrel ( resrel L P ) . Proof . intros . intros x1 x2 . apply isl . Defined . Definition isnegrelresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isnegrel L ) : isnegrel ( resrel L P ) . Proof . intros . intros x1 x2 nnr . apply ( isl _ _ nnr ) . Defined . Definition isantisymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isantisymm L ) : isantisymm ( resrel L P ) . Proof . intros . intros x1 x2 r12 r21 . apply ( invmaponpathsincl _ ( isinclpr1carrier _ ) _ _ ( isl _ _ r12 r21 ) ) . Defined . Definition isantisymmnegresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isantisymmneg L ) : isantisymmneg ( resrel L P ) . Proof . intros . intros x1 x2 nr12 nr21 . apply ( invmaponpathsincl _ ( isinclpr1carrier _ ) _ _ ( isl _ _ nr12 nr21 ) ) . Defined . Definition iscoantisymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : iscoantisymm L ) : iscoantisymm ( resrel L P ) . Proof . intros . intros x1 x2 r12 . destruct ( isl _ _ r12 ) as [ l | e ] . apply ( ii1 l ) . apply ii2 . apply ( invmaponpathsincl _ ( isinclpr1carrier _ ) _ _ e ) . Defined . Definition neqchoiceresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : neqchoice L ) : neqchoice ( resrel L P ) . Proof . intros . intros x1 x2 ne . set ( int := negf ( invmaponpathsincl _ ( isinclpr1carrier P ) _ _ ) ne ) . apply ( isl _ _ int ) . Defined . (** *** Equivalence classes with respect to a given relation *) Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) := dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) ). Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A := dirprodpair ax0 ( dirprodpair ax1 ax2 ) . Definition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> ishinh ( carrier A ) := fun is : iseqclass R A => pr1 is . Definition eqax1 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> forall x1 x2 : X, R x1 x2 -> A x1 -> A x2 := fun is: iseqclass R A => pr1 ( pr2 is) . Definition eqax2 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 := fun is: iseqclass R A => pr2 ( pr2 is) . Lemma isapropiseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : isaprop ( iseqclass R A ) . Proof. intros. unfold iseqclass. apply isofhleveldirprod. apply (isapropishinh (carrier A)). apply isofhleveldirprod. apply impredtwice. intros t t' . apply impred. intro. apply impred. intro. apply (pr2 (A t')). apply impredtwice. intros. apply impred. intro. apply impred. intro. apply (pr2 (R t t')). Defined. (** *** Direct product of equivalence classes *) Lemma iseqclassdirprod { X Y : UU } { R : hrel X } { Q : hrel Y } { A : hsubtypes X } { B : hsubtypes Y } ( isa : iseqclass R A ) ( isb : iseqclass Q B ) : iseqclass ( hreldirprod R Q ) ( subtypesdirprod A B ) . Proof . intros . set ( XY := dirprod X Y ) . set ( AB := subtypesdirprod A B ) . set ( RQ := hreldirprod R Q ) . set ( ax0 := ishinhsubtypesdirprod A B ( eqax0 isa ) ( eqax0 isb ) ) . assert ( ax1 : forall xy1 xy2 : XY , RQ xy1 xy2 -> AB xy1 -> AB xy2 ) . intros xy1 xy2 rq ab1 . apply ( dirprodpair ( eqax1 isa _ _ ( pr1 rq ) ( pr1 ab1 ) ) ( eqax1 isb _ _ ( pr2 rq ) ( pr2 ab1 ) ) ) . assert ( ax2 : forall xy1 xy2 : XY , AB xy1 -> AB xy2 -> RQ xy1 xy2 ) . intros xy1 xy2 ab1 ab2 . apply ( dirprodpair ( eqax2 isa _ _ ( pr1 ab1 ) ( pr1 ab2 ) ) ( eqax2 isb _ _ ( pr2 ab1 ) ( pr2 ab2 ) ) ) . apply ( iseqclassconstr _ ax0 ax1 ax2 ) . Defined . (** ** Images and surjectivity for functions between types (both depend only on the behavior of the corresponding function between the sets of connected components) **) Definition image { X Y : UU } ( f : X -> Y ) := total2 ( fun y : Y => ishinh ( hfiber f y ) ) . Definition imagepair { X Y : UU } (f: X -> Y) := tpair ( fun y : Y => ishinh ( hfiber f y ) ) . Definition pr1image { X Y : UU } ( f : X -> Y ) := @pr1 _ ( fun y : Y => ishinh ( hfiber f y ) ) . Definition prtoimage { X Y : UU } (f : X -> Y) : X -> image f. Proof. intros X Y f X0. apply (imagepair _ (f X0) (hinhpr _ (hfiberpair f X0 (idpath _ )))). Defined. Definition issurjective { X Y : UU } (f : X -> Y ) := forall y:Y, ishinh (hfiber f y). Lemma isapropissurjective { X Y : UU } ( f : X -> Y) : isaprop (issurjective f). Proof. intros. apply impred. intro t. apply (pr2 (ishinh (hfiber f t))). Defined. Lemma isinclpr1image { X Y : UU } (f:X -> Y): isincl (pr1image f). Proof. intros. apply isofhlevelfpr1. intro. apply ( pr2 ( ishinh ( hfiber f x ) ) ) . Defined. Lemma issurjprtoimage { X Y : UU } ( f : X -> Y) : issurjective (prtoimage f ). Proof. intros. intro z. set (f' := prtoimage f ). set (g:= pr1image f ). set (gf':= fun x:_ => g ( f' x )). assert (e: paths f gf'). apply etacorrection . assert (ff: hfiber gf' (pr1 z) -> hfiber f' z). apply ( invweq ( samehfibers _ _ ( isinclpr1image f ) z ) ) . assert (is2: ishinh (hfiber gf' (pr1 z))). destruct e. apply (pr2 z). apply (hinhfun ff is2). Defined. (** *** Surjections to sets are epimorphisms *) Theorem surjectionisepitosets { X Y Z : UU } ( f : X -> Y ) ( g1 g2 : Y -> Z ) ( is1 : issurjective f ) ( is2 : isaset Z ) ( isf : forall x : X , paths ( g1 ( f x ) ) ( g2 ( f x ) ) ) : forall y : Y , paths ( g1 y ) ( g2 y ) . Proof. intros . set (P1:= hProppair (paths (g1 y) (g2 y)) (is2 (g1 y) (g2 y))). unfold issurjective in is1. assert (s1: (hfiber f y)-> paths (g1 y) (g2 y)). intro X1. destruct X1 as [t x ]. induction x. apply (isf t). assert (s2: ishinh (paths (g1 y) (g2 y))). apply (hinhfun s1 (is1 y)). set (is3:= is2 (g1 y) (g2 y)). simpl in is3. apply (@hinhuniv (paths (g1 y) (g2 y)) (hProppair _ is3)). intro X1. assumption. assumption. Defined. (** *** The two-out-of-three properties of surjections *) Lemma issurjcomp { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isf : issurjective f ) ( isg : issurjective g ) : issurjective ( funcomp f g ) . Proof . intros . unfold issurjective . intro z . apply ( fun ff => hinhuniv ff ( isg z ) ) . intro ye . apply ( hinhfun ( hfibersftogf f g z ye ) ) . apply ( isf ) . Defined . Notation issurjtwooutof3c := issurjcomp . Lemma issurjtwooutof3b { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isgf : issurjective ( funcomp f g ) ) : issurjective g . Proof . intros . unfold issurjective . intro z . apply ( hinhfun ( hfibersgftog f g z ) ( isgf z ) ) . Defined . (** *** A function between hsets which is an inclusion and a surjection is a weak equivalence *) Lemma isweqinclandsurj { X Y : hSet } ( f : X -> Y ) ( is1 : isincl f ) ( is1 : issurjective f ) : isweq f . Proof . intros . unfold isweq . intro y . assert ( isp : isaprop ( hfiber f y ) ) . apply ( is1 y ) . apply iscontraprop1 . apply isp . apply ( @hinhuniv _ ( hProppair _ isp ) ( idfun _ ) ( is0 y ) ) . Defined . (** ** Set quotients of types. In this file we study the set quotients of types by equivalence relations. While the general notion of a quotient of a type by a relation is complicated due to the existence of different kinds of quotients (e.g. homotopy quotients or categorical quotients in the homotopy category which are usually different from each other) there is one particular class of quotients which is both very important for applications and semantically straightforward. These quotients are the universal functions from a type to an hset which respect a given relation. Some of the proofs in this section depend on the proerties of the hinhabited construction and some also depend on the univalence axiom for [ hProp ] which allows us to prove that the type of monic subtypes of a type is a set. Our main construction is analogous to the usual construction of quotient as a set of equivalence classes. Wev also consider another construction of [ setquot ] which is analogous ( on the next h-level ) to our construction of [ ishinh ] . Both have generalizations to the "higher" quotients (i.e. groupoid quotients etc.) which will be considered separately. In particular, the quotients the next h-level appear to be closely related to the localizations of categories and will be considered in the section about types of h-level 3. *) (** ** Setquotient defined in terms of equivalence classes *) Definition setquot { X : UU } ( R : hrel X ) := total2 ( fun A : _ => iseqclass R A ) . Definition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) := tpair _ A is . Definition pr1setquot { X : UU } ( R : hrel X ) : setquot R -> ( hsubtypes X ) := @pr1 _ ( fun A : _ => iseqclass R A ) . Coercion pr1setquot : setquot >-> hsubtypes . Lemma isinclpr1setquot { X : UU } ( R : hrel X ) : isincl ( pr1setquot R ) . Proof . intros . apply isinclpr1. intro x0. apply isapropiseqclass. Defined . Definition setquottouu0 { X : UU } ( R : hrel X ) ( a : setquot R ) := carrier ( pr1 a ). Coercion setquottouu0 : setquot >-> Sortclass. Theorem isasetsetquot { X : UU } ( R : hrel X ) : isaset ( setquot R ) . Proof. intros. apply ( isasetsubset ( @pr1 _ _ ) ( isasethsubtypes X ) ) . apply isinclpr1. intro. apply isapropiseqclass. Defined. Definition setquotinset { X : UU } ( R : hrel X ) : hSet := hSetpair _ ( isasetsetquot R ) . Theorem setquotpr { X : UU } ( R : eqrel X ) : X -> setquot R. Proof. intros X R X0. set ( rax:= eqrelrefl R ). set ( sax := eqrelsymm R ) . set (tax:= eqreltrans R ). split with (fun x:X => R X0 x). split with (hinhpr _ (tpair _ X0 (rax X0))). assert (a1: (forall x1 x2 : X, R x1 x2 -> R X0 x1 -> R X0 x2)). intros x1 x2 X1 X2. apply (tax X0 x1 x2 X2 X1). split with a1. assert (a2: (forall x1 x2 : X, R X0 x1 -> R X0 x2 -> R x1 x2)). intros x1 x2 X1 X2. apply (tax x1 X0 x2 (sax X0 x1 X1) X2). assumption. Defined. Lemma setquotl0 { X : UU } ( R : eqrel X ) ( c : setquot R ) ( x : c ) : paths ( setquotpr R ( pr1 x ) ) c . Proof . intros . apply ( invmaponpathsincl _ ( isinclpr1setquot R ) ) . simpl . apply funextsec . intro x0 . destruct c as [ A iseq ] . destruct x as [ x is ] . simpl in is . simpl . apply uahp . intro r . apply ( eqax1 iseq _ _ r is ) . intro a . apply ( eqax2 iseq _ _ is a ) . Defined . Theorem issurjsetquotpr { X : UU } ( R : eqrel X) : issurjective (setquotpr R ). Proof. intros. unfold issurjective. intro c. apply ( @hinhuniv ( carrier ( pr1 c ) ) ) . intro x . apply hinhpr . split with ( pr1 x ) . apply setquotl0 . apply ( eqax0 ( pr2 c ) ) . Defined . Lemma iscompsetquotpr { X : UU } ( R : eqrel X ) ( x x' : X ) ( a : R x x' ) : paths ( setquotpr R x ) ( setquotpr R x' ) . Proof. intros. apply ( invmaponpathsincl _ ( isinclpr1setquot R ) ) . simpl . apply funextsec . intro x0 . apply uahp . intro r0 . apply ( eqreltrans R _ _ _ ( eqrelsymm R _ _ a ) r0 ) . intro x0' . apply ( eqreltrans R _ _ _ a x0' ) . Defined . (** *** Universal property of [ seqtquot R ] for functions to sets satisfying compatibility condition [ iscomprelfun ] *) Definition iscomprelfun { X Y : UU } ( R : hrel X ) ( f : X -> Y ) := forall x x' : X , R x x' -> paths ( f x ) ( f x' ) . Lemma iscomprelfunlogeqf { X Y : UU } { R L : hrel X } ( lg : hrellogeq L R ) ( f : X -> Y ) ( is : iscomprelfun L f ) : iscomprelfun R f . Proof . intros . intros x x' r . apply ( is _ _ ( pr2 ( lg _ _ ) r ) ) . Defined . Lemma isapropimeqclass { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( is : iscomprelfun R f ) ( c : setquot R ) : isaprop ( image ( fun x : c => f ( pr1 x ) ) ) . Proof. intros. apply isapropsubtype . intros y1 y2 . simpl . apply ( @hinhuniv2 _ _ ( hProppair ( paths y1 y2 ) ( pr2 Y y1 y2 ) ) ) . intros x1 x2 . simpl . destruct c as [ A iseq ] . destruct x1 as [ x1 is1 ] . destruct x2 as [ x2 is2 ] . destruct x1 as [ x1 is1' ] . destruct x2 as [ x2 is2' ] . simpl in is1 . simpl in is2 . simpl in is1' . simpl in is2' . assert ( r : R x1 x2 ) . apply ( eqax2 iseq _ _ is1' is2' ) . apply ( pathscomp0 ( pathsinv0 is1 ) ( pathscomp0 ( is _ _ r ) is2 ) ) . Defined . Theorem setquotuniv { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( is : iscomprelfun R f ) ( c : setquot R ) : Y . Proof. intros. apply ( pr1image ( fun x : c => f ( pr1 x ) ) ) . apply ( @hinhuniv ( pr1 c ) ( hProppair _ ( isapropimeqclass R Y f is c ) ) ( prtoimage ( fun x : c => f ( pr1 x ) ) ) ) . apply ( eqax0 ( pr2 c ) ) . Defined . (** Note: the axioms rax, sax and trans are not used in the proof of setquotuniv. If we consider a relation which is not an equivalence relation then setquot will still be the set of subsets which are equivalence classes. Now however such subsets need not to cover all of the type. In fact their set can be empty. Nevertheless setquotuniv will apply. *) Theorem setquotunivcomm { X : UU } ( R : eqrel X ) ( Y : hSet ) ( f : X -> Y ) ( is : iscomprelfun R f ) : forall x : X , paths ( setquotuniv R Y f is ( setquotpr R x ) ) ( f x ) . Proof. intros. unfold setquotuniv . unfold setquotpr . simpl . apply idpath . Defined. Theorem weqpathsinsetquot { X : UU } ( R : eqrel X ) ( x x' : X ) : weq ( R x x' ) ( paths ( setquotpr R x ) ( setquotpr R x' ) ) . Proof . intros . split with ( iscompsetquotpr R x x' ) . apply isweqimplimpl . intro e . set ( e' := maponpaths ( pr1setquot R ) e ) . unfold pr1setquot in e' . unfold setquotpr in e' . simpl in e' . assert ( e'' := maponpaths ( fun f : _ => f x' ) e' ) . simpl in e'' . apply ( eqweqmaphProp ( pathsinv0 e'' ) ( eqrelrefl R x' ) ) . apply ( pr2 ( R x x' ) ) . set ( int := isasetsetquot R (setquotpr R x) (setquotpr R x') ) . assumption . Defined . (** *** Functoriality of [ setquot ] for functions mapping one relation to another *) Definition iscomprelrelfun { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) ( f : X -> Y ) := forall x x' : X , RX x x' -> RY ( f x ) ( f x' ) . Lemma iscomprelfunlogeqf1 { X Y : UU } { LX RX : hrel X } ( RY : hrel Y ) ( lg : hrellogeq LX RX ) ( f : X -> Y ) ( is : iscomprelrelfun LX RY f ) : iscomprelrelfun RX RY f . Proof . intros . intros x x' r . apply ( is _ _ ( pr2 ( lg _ _ ) r ) ) . Defined . Lemma iscomprelfunlogeqf2 { X Y : UU } ( RX : hrel X ) { LY RY : hrel Y } ( lg : hrellogeq LY RY ) ( f : X -> Y ) ( is : iscomprelrelfun RX LY f ) : iscomprelrelfun RX RY f . Proof . intros . intros x x' r . apply ( ( pr1 ( lg _ _ ) ) ( is _ _ r ) ) . Defined . Definition setquotfun { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> Y ) ( is : iscomprelrelfun RX RY f ) ( cx : setquot RX ) : setquot RY . Proof . intros . set ( ff := funcomp f ( setquotpr RY ) ) . assert ( isff : iscomprelfun RX ff ) . intros x x' . intro r . apply ( weqpathsinsetquot RY ( f x ) ( f x' ) ) . apply is . apply r . apply ( setquotuniv RX ( setquotinset RY ) ff isff cx) . Defined . Definition setquotfuncomm { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) ( f : X -> Y ) ( is : iscomprelrelfun RX RY f ) : forall x : X , paths ( setquotfun RX RY f is ( setquotpr RX x ) ) ( setquotpr RY ( f x ) ) . Proof . intros . simpl . apply idpath . Defined . (** *** Universal property of [ setquot ] for predicates of one and several variables *) Theorem setquotunivprop { X : UU } ( R : eqrel X ) ( P : setquot R -> hProp ) ( is : forall x : X , P ( setquotpr R x ) ) : forall c : setquot R , P c . Proof . intros . apply ( @hinhuniv ( carrier ( pr1 c ) ) ( P c ) ) . intro x . set ( e := setquotl0 R c x ) . apply ( eqweqmaphProp ( maponpaths P e ) ) . apply ( is ( pr1 x ) ) . apply ( eqax0 ( pr2 c ) ) . Defined . Theorem setquotuniv2prop { X : UU } ( R : eqrel X ) ( P : setquot R -> setquot R -> hProp ) ( is : forall x x' : X , P ( setquotpr R x ) ( setquotpr R x' ) ) : forall c c' : setquot R , P c c' . Proof . intros . assert ( int1 : forall c0' : _ , P c c0' ) . apply ( setquotunivprop R ( fun c0' => P c c0' ) ) . intro x . apply ( setquotunivprop R ( fun c0 : _ => P c0 ( setquotpr R x ) ) ) . intro x0 . apply ( is x0 x ) . apply ( int1 c' ) . Defined . Theorem setquotuniv3prop { X : UU } ( R : eqrel X ) ( P : setquot R -> setquot R -> setquot R -> hProp ) ( is : forall x x' x'' : X , P ( setquotpr R x ) ( setquotpr R x' ) ( setquotpr R x'' ) ) : forall c c' c'' : setquot R , P c c' c'' . Proof . intros . assert ( int1 : forall c0' c0'' : _ , P c c0' c0'' ) . apply ( setquotuniv2prop R ( fun c0' c0'' => P c c0' c0'' ) ) . intros x x' . apply ( setquotunivprop R ( fun c0 : _ => P c0 ( setquotpr R x ) ( setquotpr R x' ) ) ) . intro x0 . apply ( is x0 x x' ) . apply ( int1 c' c'' ) . Defined . Theorem setquotuniv4prop { X : UU } ( R : eqrel X ) ( P : setquot R -> setquot R -> setquot R -> setquot R -> hProp ) ( is : forall x x' x'' x''' : X , P ( setquotpr R x ) ( setquotpr R x' ) ( setquotpr R x'' ) ( setquotpr R x''' ) ) : forall c c' c'' c''' : setquot R , P c c' c'' c''' . Proof . intros . assert ( int1 : forall c0 c0' c0'' : _ , P c c0 c0' c0'' ) . apply ( setquotuniv3prop R ( fun c0 c0' c0'' => P c c0 c0' c0'' ) ) . intros x x' x'' . apply ( setquotunivprop R ( fun c0 : _ => P c0 ( setquotpr R x ) ( setquotpr R x' ) ( setquotpr R x'' ) ) ) . intro x0 . apply ( is x0 x x' x'' ) . apply ( int1 c' c'' c''' ) . Defined . (** Important note : theorems proved above can not be used ( al least at the moment ) to construct terms whose complete normalization ( evaluation ) is important . For example they should not be used * directly * to construct [ isdeceq ] property of [ setquot ] since [ isdeceq ] is in turn used to construct boolean equality [ booleq ] and evaluation of [ booleq x y ] is important for computational purposes . Terms produced using these universality theorems will not fully normalize even in simple cases due to the following steps in the proof of [ setquotunivprop ] . As a part of the proof term of this theorem there appears the composition of an application of [ uahp ] , transfer of the resulting term of the identity type by [ maponpaths ] along [ P ] followed by the reconstruction of a equivalence ( two directional implication ) between the corresponding propositions through [ eqweqmaphProp ] . The resulting implications are " opaque " and the proofs of disjunctions [ P \/ Q ] produced with the use of such implications can not be evaluated to one of the summands of the disjunction . An example is given by the following theorem [ isdeceqsetquot_non_constr ] which , as simple experiments show, can not be used to compute the value of [ isdeceqsetquot ] . Below we give another proof of [ isdeceq ( setquot R ) ] using the same assumptions which is " constructive " i.e. usable for the evaluation purposes . *) (** *** The case when the function between quotients defined by [ setquotfun ] is a surjection , inclusion or a weak equivalence *) Lemma issurjsetquotfun { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) ( f : X -> Y ) ( is : issurjective f ) ( is1 : iscomprelrelfun RX RY f ) : issurjective ( setquotfun RX RY f is1 ) . Proof . intros . apply ( issurjtwooutof3b ( setquotpr RX ) ) . apply ( issurjcomp f ( setquotpr RY ) is ( issurjsetquotpr RY ) ) . Defined . Lemma isinclsetquotfun { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) ( f : X -> Y ) ( is1 : iscomprelrelfun RX RY f ) ( is2 : forall x x' : X , RY ( f x ) ( f x' ) -> RX x x' ) : isincl ( setquotfun RX RY f is1 ) . Proof . intros . apply isinclbetweensets . apply isasetsetquot . apply isasetsetquot . assert ( is : forall x x' : setquot RX , isaprop ( paths (setquotfun RX RY f is1 x) (setquotfun RX RY f is1 x') -> paths x x' ) ) . intros . apply impred . intro . apply isasetsetquot . apply ( setquotuniv2prop RX ( fun x x' => hProppair _ ( is x x' ) ) ) . simpl . intros x x' . intro e . set ( e' := invweq ( weqpathsinsetquot RY ( f x ) ( f x' ) ) e ) . apply ( weqpathsinsetquot RX _ _ ( is2 x x' e' ) ) . Defined . Definition setquotincl { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) ( f : X -> Y ) ( is1 : iscomprelrelfun RX RY f ) ( is2 : forall x x' : X , RY ( f x ) ( f x' ) -> RX x x' ) := inclpair ( setquotfun RX RY f is1 ) ( isinclsetquotfun RX RY f is1 is2 ) . Definition weqsetquotweq { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) ( f : weq X Y ) ( is1 : iscomprelrelfun RX RY f ) ( is2 : forall x x' : X , RY ( f x ) ( f x' ) -> RX x x' ) : weq ( setquot RX ) ( setquot RY ) . Proof . intros . set ( ff := setquotfun RX RY f is1 ) . split with ff . assert ( is2' : forall y y' : Y , RY y y' -> RX ( invmap f y ) ( invmap f y' ) ) . intros y y' . rewrite ( pathsinv0 ( homotweqinvweq f y ) ) . rewrite ( pathsinv0 ( homotweqinvweq f y' ) ) . rewrite ( homotinvweqweq f ( invmap f y ) ) . rewrite ( homotinvweqweq f ( invmap f y' ) ) . apply ( is2 _ _ ) . set ( gg := setquotfun RY RX ( invmap f ) is2' ) . assert ( egf : forall a , paths ( gg ( ff a ) ) a ) . apply ( setquotunivprop RX ( fun a0 => hProppair _ ( isasetsetquot RX ( gg ( ff a0 ) ) a0 ) ) ) . simpl . intro x . unfold ff . unfold gg . apply ( maponpaths ( setquotpr RX ) ( homotinvweqweq f x ) ) . assert ( efg : forall a , paths ( ff ( gg a ) ) a ) . apply ( setquotunivprop RY ( fun a0 => hProppair _ ( isasetsetquot RY ( ff ( gg a0 ) ) a0 ) ) ) . simpl . intro x . unfold ff . unfold gg . apply ( maponpaths ( setquotpr RY ) ( homotweqinvweq f x ) ) . apply ( gradth _ _ egf efg ) . Defined . Definition weqsetquotsurj { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) ( f : X -> Y ) ( is : issurjective f ) ( is1 : iscomprelrelfun RX RY f ) ( is2 : forall x x' : X , RY ( f x ) ( f x' ) -> RX x x' ) : weq ( setquot RX ) ( setquot RY ) . Proof . intros . set ( ff := setquotfun RX RY f is1 ) . split with ff . apply ( @isweqinclandsurj ( setquotinset RX ) ( setquotinset RY ) ff ) . apply ( isinclsetquotfun RX RY f is1 is2 ) . apply ( issurjsetquotfun RX RY f is is1 ) . Defined . (** *** [ setquot ] with respect to the product of two relations *) Definition setquottodirprod { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) ( cc : setquot ( eqreldirprod RX RY ) ) : dirprod ( setquot RX ) ( setquot RY ) . Proof . intros . set ( RXY := eqreldirprod RX RY ) . apply ( dirprodpair ( setquotuniv RXY ( setquotinset RX ) ( funcomp ( @pr1 _ ( fun x : _ => Y ) ) ( setquotpr RX ) ) ( fun xy xy' : dirprod X Y => fun rr : RXY xy xy' => iscompsetquotpr RX _ _ ( pr1 rr ) ) cc ) ( setquotuniv RXY ( setquotinset RY ) ( funcomp ( @pr2 _ ( fun x : _ => Y ) ) ( setquotpr RY ) ) ( fun xy xy' : dirprod X Y => fun rr : RXY xy xy' => iscompsetquotpr RY _ _ ( pr2 rr ) ) cc ) ) . Defined . Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ) := setquotpair _ _ ( iseqclassdirprod ( pr2 ( pr1 cd ) ) ( pr2 ( pr2 cd ) ) ) . Theorem weqsetquottodirprod { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) : weq ( setquot ( eqreldirprod RX RY ) ) ( dirprod ( setquot RX ) ( setquot RY ) ) . Proof . intros . set ( f := setquottodirprod RX RY ) . set ( g := dirprodtosetquot RX RY ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . apply ( setquotunivprop _ ( fun a : _ => ( hProppair _ ( isasetsetquot _ ( g ( f a ) ) a ) ) ) ) . intro xy . destruct xy as [ x y ] . simpl . apply ( invmaponpathsincl _ ( isinclpr1setquot _ ) ) . simpl . apply funextsec . intro xy' . destruct xy' as [ x' y' ] . apply idpath . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . destruct a as [ ax ay ] . apply pathsdirprod . generalize ax . clear ax . apply ( setquotunivprop RX ( fun ax : _ => ( hProppair _ ( isasetsetquot _ _ _ ) ) ) ) . intro x . simpl . generalize ay . clear ay . apply ( setquotunivprop RY ( fun ay : _ => ( hProppair _ ( isasetsetquot _ _ _ ) ) ) ) . intro y . simpl . apply ( invmaponpathsincl _ ( isinclpr1setquot _ ) ) . apply funextsec . intro x0 . simpl . apply idpath . generalize ax . clear ax . apply ( setquotunivprop RX ( fun ax : _ => ( hProppair _ ( isasetsetquot _ _ _ ) ) ) ) . intro x . simpl . generalize ay . clear ay . apply ( setquotunivprop RY ( fun ay : _ => ( hProppair _ ( isasetsetquot _ _ _ ) ) ) ) . intro y . simpl . apply ( invmaponpathsincl _ ( isinclpr1setquot _ ) ) . apply funextsec . intro x0 . simpl . apply idpath . apply ( gradth _ _ egf efg ) . Defined . (** *** Universal property of [ setquot ] for functions of two variables *) Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) := forall x x' x0 x0' : X , R x x' -> R x0 x0' -> paths ( f x x0 ) ( f x' x0' ) . Lemma iscomprelfun2if { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) ( is1 : forall x x' x0 : X , R x x' -> paths ( f x x0 ) ( f x' x0 ) ) ( is2 : forall x x0 x0' : X , R x0 x0' -> paths ( f x x0 ) ( f x x0' ) ) : iscomprelfun2 R f . Proof . intros . intros x x' x0 x0' . intros r r' . set ( e := is1 x x' x0 r ) . set ( e' := is2 x' x0 x0' r' ) . apply ( pathscomp0 e e' ) . Defined . Lemma iscomprelfun2logeqf { X Y : UU } { L R : hrel X } ( lg : hrellogeq L R ) ( f : X -> X -> Y ) ( is : iscomprelfun2 L f ) : iscomprelfun2 R f . Proof . intros . intros x x' x0 x0' r r0 . apply ( is _ _ _ _ ( ( pr2 ( lg _ _ ) ) r ) ( ( pr2 ( lg _ _ ) ) r0 ) ) . Defined . Definition setquotuniv2 { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) : Y . Proof. intros . set ( ff := fun xy : dirprod X X => f ( pr1 xy ) ( pr2 xy ) ) . set ( RR := hreldirprod R R ) . assert ( isff : iscomprelfun RR ff ) . intros xy x'y' . simpl . intro dp . destruct dp as [ r r'] . apply ( is _ _ _ _ r r' ) . apply ( setquotuniv RR Y ff isff ( dirprodtosetquot R R ( dirprodpair c c0 ) ) ) . Defined . Theorem setquotuniv2comm { X : UU } ( R : eqrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) : forall x x' : X , paths ( setquotuniv2 R Y f is ( setquotpr R x ) ( setquotpr R x' ) ) ( f x x' ) . Proof. intros. apply idpath . Defined. (** *** Functoriality of [ setquot ] for functions of two variables mapping one relation to another *) Definition iscomprelrelfun2 { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) ( f : X -> X -> Y ) := forall x x' x0 x0' : X , RX x x' -> RX x0 x0' -> RY ( f x x0 ) ( f x' x0' ) . Lemma iscomprelrelfun2if { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> X -> Y ) ( is1 : forall x x' x0 : X , RX x x' -> RY ( f x x0 ) ( f x' x0 ) ) ( is2 : forall x x0 x0' : X , RX x0 x0' -> RY ( f x x0 ) ( f x x0' ) ) : iscomprelrelfun2 RX RY f . Proof . intros . intros x x' x0 x0' . intros r r' . set ( e := is1 x x' x0 r ) . set ( e' := is2 x' x0 x0' r' ) . apply ( eqreltrans RY _ _ _ e e' ) . Defined . Lemma iscomprelrelfun2logeqf1 { X Y : UU } { LX RX : hrel X } ( RY : hrel Y ) ( lg : hrellogeq LX RX ) ( f : X -> X -> Y ) ( is : iscomprelrelfun2 LX RY f ) : iscomprelrelfun2 RX RY f . Proof . intros . intros x x' x0 x0' r r0 . apply ( is _ _ _ _ ( ( pr2 ( lg _ _ ) ) r ) ( ( pr2 ( lg _ _ ) ) r0 ) ) . Defined . Lemma iscomprelrelfun2logeqf2 { X Y : UU } ( RX : hrel X ) { LY RY : hrel Y } ( lg : hrellogeq LY RY ) ( f : X -> X -> Y ) ( is : iscomprelrelfun2 RX LY f ) : iscomprelrelfun2 RX RY f . Proof . intros . intros x x' x0 x0' r r0 . apply ( ( pr1 ( lg _ _ ) ) ( is _ _ _ _ r r0 ) ) . Defined . Definition setquotfun2 { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> X -> Y ) ( is : iscomprelrelfun2 RX RY f ) ( cx cx0 : setquot RX ) : setquot RY . Proof . intros . set ( ff := fun x x0 : X => setquotpr RY ( f x x0 ) ) . assert ( isff : iscomprelfun2 RX ff ) . intros x x' x0 x0' . intros r r0 . apply ( weqpathsinsetquot RY ( f x x0 ) ( f x' x0' ) ) . apply is . apply r . apply r0 . apply ( setquotuniv2 RX ( setquotinset RY ) ff isff cx cx0 ) . Defined . Theorem setquotfun2comm { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) ( f : X -> X -> Y ) ( is : iscomprelrelfun2 RX RY f ) : forall x x' : X , paths ( setquotfun2 RX RY f is ( setquotpr RX x ) ( setquotpr RX x' ) ) ( setquotpr RY ( f x x' ) ) . Proof. intros. apply idpath . Defined. (** *** Set quotients with respect to decidable equivalence relations have decidable equality *) Theorem isdeceqsetquot_non_constr { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) : isdeceq ( setquot R ) . Proof . intros . apply isdeceqif . intros x x' . apply ( setquotuniv2prop R ( fun x0 x0' => hProppair _ ( isapropisdecprop ( paths x0 x0' ) ) ) ) . intros x0 x0' . simpl . apply ( isdecpropweqf ( weqpathsinsetquot R x0 x0' ) ( is x0 x0' ) ) . Defined . Definition setquotbooleqint { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) ( x x' : X ) : bool . Proof . intros . destruct ( pr1 ( is x x' ) ) . apply true . apply false . Defined . Lemma setquotbooleqintcomp { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) : iscomprelfun2 R ( setquotbooleqint R is ) . Proof . intros . unfold iscomprelfun2 . intros x x' x0 x0' r r0 . unfold setquotbooleqint . destruct ( pr1 ( is x x0 ) ) as [ r1 | nr1 ] . destruct ( pr1 ( is x' x0' ) ) as [ r1' | nr1' ] . apply idpath . destruct ( nr1' ( eqreltrans R _ _ _ ( eqreltrans R _ _ _ ( eqrelsymm R _ _ r ) r1 ) r0 ) ) . destruct ( pr1 ( is x' x0' ) ) as [ r1' | nr1' ] . destruct ( nr1 ( eqreltrans R _ _ _ r ( eqreltrans R _ _ _ r1' ( eqrelsymm R _ _ r0 ) ) ) ) . apply idpath . Defined . Definition setquotbooleq { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) : setquot R -> setquot R -> bool := setquotuniv2 R ( hSetpair _ ( isasetbool ) ) ( setquotbooleqint R is ) ( setquotbooleqintcomp R is ) . Lemma setquotbooleqtopaths { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) ( x x' : setquot R ) : paths ( setquotbooleq R is x x' ) true -> paths x x' . Proof . intros X R is . assert ( isp : forall x x' : setquot R , isaprop ( paths ( setquotbooleq R is x x' ) true -> paths x x' ) ) . intros x x' . apply impred . intro . apply ( isasetsetquot R x x' ) . apply ( setquotuniv2prop R ( fun x x' => hProppair _ ( isp x x' ) ) ) . simpl . intros x x' . change ( paths (setquotbooleqint R is x x' ) true -> paths (setquotpr R x) (setquotpr R x') ) . unfold setquotbooleqint . destruct ( pr1 ( is x x' ) ) as [ i1 | i2 ] . intro . apply ( weqpathsinsetquot R _ _ i1 ) . intro H . destruct ( nopathsfalsetotrue H ) . Defined . Lemma setquotpathstobooleq { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) ( x x' : setquot R ) : paths x x' -> paths ( setquotbooleq R is x x' ) true . Proof . intros X R is x x' e . destruct e . generalize x . apply ( setquotunivprop R ( fun x => hProppair _ ( isasetbool (setquotbooleq R is x x) true ) ) ) . simpl . intro x0 . change ( paths ( setquotbooleqint R is x0 x0 ) true ) . unfold setquotbooleqint . destruct ( pr1 ( is x0 x0 ) ) as [ i1 | i2 ] . apply idpath . destruct ( i2 ( eqrelrefl R x0 ) ) . Defined . Definition isdeceqsetquot { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) : isdeceq ( setquot R ) . Proof . intros . intros x x' . destruct ( boolchoice ( setquotbooleq R is x x' ) ) as [ i | ni ] . apply ( ii1 ( setquotbooleqtopaths R is x x' i ) ) . apply ii2 . intro e . destruct ( falsetonegtrue _ ni ( setquotpathstobooleq R is x x' e ) ) . Defined . (** *** Relations on quotient sets Note that all the properties of the quotient relations which we consider other than [ isantisymm ] are also inherited in the opposite direction - if the quotent relation satisfies the property then the original relation does . *) Definition iscomprelrel { X : UU } ( R : hrel X ) ( L : hrel X ) := iscomprelfun2 R L . Lemma iscomprelrelif { X : UU } { R : hrel X } ( L : hrel X ) ( isr : issymm R ) ( i1 : forall x x' y , R x x' -> L x y -> L x' y ) ( i2 : forall x y y' , R y y' -> L x y -> L x y' ) : iscomprelrel R L . Proof . intros . intros x x' y y' rx ry . set ( rx' := isr _ _ rx ) . set ( ry' := isr _ _ ry ) . apply uahp . intro lxy . set ( int1 := i1 _ _ _ rx lxy ) . apply ( i2 _ _ _ ry int1 ) . intro lxy' . set ( int1 := i1 _ _ _ rx' lxy' ) . apply ( i2 _ _ _ ry' int1 ) . Defined . Lemma iscomprelrellogeqf1 { X : UU } { R R' : hrel X } ( L : hrel X ) ( lg : hrellogeq R R' ) ( is : iscomprelrel R L ) : iscomprelrel R' L . Proof . intros . apply ( iscomprelfun2logeqf lg L is ) . Defined . Lemma iscomprelrellogeqf2 { X : UU } ( R : hrel X ) { L L' : hrel X } ( lg : hrellogeq L L' ) ( is : iscomprelrel R L ) : iscomprelrel R L' . Proof . intros . intros x x' x0 x0' r r0 . assert ( e : paths ( L x x0 ) ( L' x x0 ) ) . apply uahp . apply ( pr1 ( lg _ _ ) ) . apply ( pr2 ( lg _ _ ) ) . assert ( e' : paths ( L x' x0' ) ( L' x' x0' ) ) . apply uahp . apply ( pr1 ( lg _ _ ) ) . apply ( pr2 ( lg _ _ ) ) . destruct e . destruct e' . apply ( is _ _ _ _ r r0 ) . Defined . Definition quotrel { X : UU } { R L : hrel X } ( is : iscomprelrel R L ) : hrel ( setquot R ) := setquotuniv2 R hPropset L is . Lemma istransquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : istrans L ) : istrans ( quotrel is ) . Proof . intros . unfold istrans. assert ( int : forall x1 x2 x3 : setquot R , isaprop ( quotrel is x1 x2 -> quotrel is x2 x3 -> quotrel is x1 x3 ) ) . intros x1 x2 x3 . apply impred . intro . apply impred . intro . apply ( pr2 ( quotrel is x1 x3 ) ) . apply ( setquotuniv3prop R ( fun x1 x2 x3 => hProppair _ ( int x1 x2 x3 ) ) ) . intros x x' x'' . intros r r' . apply ( isl x x' x'' r r' ) . Defined . Lemma issymmquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : issymm L ) : issymm ( quotrel is ) . Proof . intros . unfold issymm. assert ( int : forall x1 x2 : setquot R , isaprop ( quotrel is x1 x2 -> quotrel is x2 x1 ) ) . intros x1 x2 . apply impred . intro . apply ( pr2 ( quotrel is x2 x1 ) ) . apply ( setquotuniv2prop R ( fun x1 x2 => hProppair _ ( int x1 x2 ) ) ) . intros x x' . intros r . apply ( isl x x' r ) . Defined . Lemma isreflquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isrefl L ) : isrefl ( quotrel is ) . Proof . intros . unfold isrefl . apply ( setquotunivprop R ) . intro x . apply ( isl x ) . Defined . Lemma ispoquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : ispo L ) : ispo ( quotrel is ) . Proof . intros . split with ( istransquotrel is ( pr1 isl ) ) . apply ( isreflquotrel is ( pr2 isl ) ) . Defined . Lemma iseqrelquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : iseqrel L ) : iseqrel ( quotrel is ) . Proof . intros . split with ( ispoquotrel is ( pr1 isl ) ) . apply ( issymmquotrel is ( pr2 isl ) ) . Defined . Lemma isirreflquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isirrefl L ) : isirrefl ( quotrel is ) . Proof . intros . unfold isirrefl . apply ( setquotunivprop R ( fun x => hProppair _ ( isapropneg (quotrel is x x) ) ) ) . intro x . apply ( isl x ) . Defined . Lemma isasymmquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isasymm L ) : isasymm ( quotrel is ) . Proof . intros . unfold isasymm. assert ( int : forall x1 x2 : setquot R , isaprop ( quotrel is x1 x2 -> quotrel is x2 x1 -> empty ) ) . intros x1 x2 . apply impred . intro . apply impred . intro . apply isapropempty . apply ( setquotuniv2prop R ( fun x1 x2 => hProppair _ ( int x1 x2 ) ) ) . intros x x' . intros r r' . apply ( isl x x' r r' ) . Defined . Lemma iscoasymmquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : iscoasymm L ) : iscoasymm ( quotrel is ) . Proof . intros . unfold iscoasymm. assert ( int : forall x1 x2 : setquot R , isaprop ( neg ( quotrel is x1 x2 ) -> quotrel is x2 x1 ) ) . intros x1 x2 . apply impred . intro . apply ( pr2 _ ) . apply ( setquotuniv2prop R ( fun x1 x2 => hProppair _ ( int x1 x2 ) ) ) . intros x x' . intros r . apply ( isl x x' r ) . Defined . Lemma istotalquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : istotal L ) : istotal ( quotrel is ) . Proof . intros . unfold istotal . apply ( setquotuniv2prop R ( fun x1 x2 => hdisj _ _ ) ) . intros x x' . intros r r' . apply ( isl x x' r r' ) . Defined . Lemma iscotransquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : iscotrans L ) : iscotrans ( quotrel is ) . Proof . intros . unfold iscotrans . assert ( int : forall x1 x2 x3 : setquot R , isaprop ( quotrel is x1 x3 -> hdisj (quotrel is x1 x2) (quotrel is x2 x3) ) ) . intros . apply impred . intro . apply ( pr2 _ ) . apply ( setquotuniv3prop R ( fun x1 x2 x3 => hProppair _ ( int x1 x2 x3 ) ) ) . intros x x' x'' . intros r . apply ( isl x x' x'' r ) . Defined . Lemma isantisymmquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isantisymm L ) : isantisymm ( quotrel is ) . Proof . intros . unfold isantisymm. assert ( int : forall x1 x2 : setquot R , isaprop ( quotrel is x1 x2 -> quotrel is x2 x1 -> paths x1 x2 ) ) . intros x1 x2 . apply impred . intro . apply impred . intro . apply ( isasetsetquot R x1 x2 ) . apply ( setquotuniv2prop R ( fun x1 x2 => hProppair _ ( int x1 x2 ) ) ) . intros x x' . intros r r' . apply ( maponpaths ( setquotpr R ) ( isl x x' r r' ) ) . Defined . Lemma isantisymmnegquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isantisymmneg L ) : isantisymmneg ( quotrel is ) . Proof . intros . unfold isantisymmneg. assert ( int : forall x1 x2 : setquot R , isaprop ( neg ( quotrel is x1 x2 ) -> neg ( quotrel is x2 x1 ) -> paths x1 x2 ) ) . intros x1 x2 . apply impred . intro . apply impred . intro . apply ( isasetsetquot R x1 x2 ) . apply ( setquotuniv2prop R ( fun x1 x2 => hProppair _ ( int x1 x2 ) ) ) . intros x x' . intros r r' . apply ( maponpaths ( setquotpr R ) ( isl x x' r r' ) ) . Defined . (** We do not have a lemma for [ neqchoicequotrel ] since [ neqchoice ] is not a property and since even when it is a property such as under the additional condition [ isasymm ] on the relation it still carrier computational content (similarly to [ isdec ]) which would be lost under our current approach of taking quotients. How to best define [neqchoicequotrel] remains at the moment an open question.*) Lemma quotrelimpl { X : UU } { R : eqrel X } { L L' : hrel X } ( is : iscomprelrel R L ) ( is' : iscomprelrel R L' ) ( impl : forall x x' , L x x' -> L' x x' ) ( x x' : setquot R ) ( ql : quotrel is x x' ) : quotrel is' x x' . Proof . intros . generalize x x' ql . assert ( int : forall x0 x0' , isaprop ( quotrel is x0 x0' -> quotrel is' x0 x0' ) ) . intros x0 x0' . apply impred . intro . apply ( pr2 _ ) . apply ( setquotuniv2prop _ ( fun x0 x0' => hProppair _ ( int x0 x0' ) ) ) . intros x0 x0' . change ( L x0 x0' -> L' x0 x0' ) . apply ( impl x0 x0' ) . Defined . Lemma quotrellogeq { X : UU } { R : eqrel X } { L L' : hrel X } ( is : iscomprelrel R L ) ( is' : iscomprelrel R L' ) ( lg : forall x x' , L x x' <-> L' x x' ) ( x x' : setquot R ) : ( quotrel is x x' ) <-> ( quotrel is' x x' ) . Proof . intros . split . apply ( quotrelimpl is is' ( fun x0 x0' => pr1 ( lg x0 x0' ) ) x x' ) . apply ( quotrelimpl is' is ( fun x0 x0' => pr2 ( lg x0 x0' ) ) x x' ) . Defined . (** Constructive proof of decidability of the quotient relation *) Definition quotdecrelint { X : UU } { R : hrel X } ( L : decrel X ) ( is : iscomprelrel R ( pr1 L ) ) : brel ( setquot R ) . Proof . intros . set ( f := decreltobrel L ) . unfold brel . apply ( setquotuniv2 R boolset f ) . intros x x' x0 x0' r r0. unfold f . unfold decreltobrel in * . destruct ( pr2 L x x0' ) as [ l | nl ] . destruct ( pr2 L x' x0' ) as [ l' | nl' ] . destruct ( pr2 L x x0 ) as [ l'' | nl'' ] . apply idpath . set ( e := is x x' x0 x0' r r0 ) . destruct e . destruct ( nl'' l' ) . destruct ( pr2 L x x0 ) as [ l'' | nl'' ] . set ( e := is x x' x0 x0' r r0 ) . destruct e . destruct ( nl' l'' ) . apply idpath . destruct ( pr2 L x x0 ) as [ l' | nl' ] . destruct ( pr2 L x' x0' ) as [ l'' | nl'' ] . apply idpath . set ( e := is x x' x0 x0' r r0 ) . destruct e . destruct ( nl'' l' ) . destruct ( pr2 L x' x0' ) as [ l'' | nl'' ] . set ( e := is x x' x0 x0' r r0 ) . destruct e . destruct ( nl' l'' ) . apply idpath . Defined . Definition quotdecrelintlogeq { X : UU } { R : eqrel X } ( L : decrel X ) ( is : iscomprelrel R ( pr1 L ) ) ( x x' : setquot R ) : breltodecrel ( quotdecrelint L is ) x x' <-> quotrel is x x' . Proof . intros X R L is . assert ( int : forall x x' , isaprop ( paths ( quotdecrelint L is x x' ) true <-> ( quotrel is x x' ) ) ) . intros x x' . apply isapropdirprod . apply impred . intro . apply ( pr2 ( quotrel _ _ _ ) ) . apply impred . intro . apply isasetbool . apply ( setquotuniv2prop R ( fun x x' => hProppair _ ( int x x' ) ) ) . intros x x' . simpl . split . apply ( pathstor L x x' ) . apply ( rtopaths L x x' ) . Defined . Lemma isdecquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isdecrel L ) : isdecrel ( quotrel is ) . Proof . intros . apply ( isdecrellogeqf ( quotdecrelintlogeq ( decrelpair isl ) is ) ( pr2 ( breltodecrel ( quotdecrelint ( decrelpair isl ) is ) ) ) ) . Defined . Definition decquotrel { X : UU } { R : eqrel X } ( L : decrel X ) ( is : iscomprelrel R L ) : decrel ( setquot R ) := decrelpair ( isdecquotrel is ( pr2 L ) ) . (** *** Subtypes of quotients and quotients of subtypes *) Definition reseqrel { X : UU } ( R : eqrel X ) ( P : hsubtypes X ) : eqrel P := eqrelpair _ ( iseqrelresrel R P ( pr2 R ) ) . Lemma iseqclassresrel { X : UU } ( R : hrel X ) ( P Q : hsubtypes X ) ( is : iseqclass R Q ) ( is' : forall x , Q x -> P x ) : iseqclass ( resrel R P ) ( fun x : P => Q ( pr1 x ) ) . Proof . intros . split . set ( l1 := pr1 is ) . generalize l1 . clear l1 . simpl . apply hinhfun . intro q . split with ( carrierpair P ( pr1 q ) ( is' ( pr1 q ) ( pr2 q ) ) ) . apply ( pr2 q ) . split . intros p1 p2 r12 q1 . apply ( ( pr1 ( pr2 is ) ) _ _ r12 q1 ) . intros p1 p2 q1 q2 . apply ( ( pr2 ( pr2 is ) ) _ _ q1 q2 ) . Defined . Definition fromsubquot { X : UU } ( R : eqrel X ) ( P : hsubtypes ( setquot R ) ) ( p : P ) : setquot ( resrel R ( funcomp ( setquotpr R ) P ) ) . Proof . intros . split with ( fun rp : carrier (funcomp (setquotpr R) P) => ( pr1 p ) ( pr1 rp ) ) . apply ( iseqclassresrel R ( funcomp ( setquotpr R ) P ) _ ( pr2 ( pr1 p ) ) ) . intros x px . set ( e := setquotl0 R _ ( carrierpair _ x px ) ) . (* *) simpl in e . unfold funcomp . rewrite e . apply ( pr2 p ) . Defined . Definition tosubquot { X : UU } ( R : eqrel X ) ( P : hsubtypes ( setquot R ) ) : setquot ( resrel R ( funcomp ( setquotpr R ) P ) ) -> P . Proof . intros X R P . assert ( int : isaset P ) . apply ( isasetsubset ( @pr1 _ P ) ) . apply ( setproperty ( setquotinset R ) ) . apply isinclpr1carrier . apply ( setquotuniv _ ( hSetpair _ int ) ( fun xp => carrierpair P ( setquotpr R ( pr1 xp ) ) ( pr2 xp ) ) ) . intros xp1 xp2 rp12 . apply ( invmaponpathsincl _ ( isinclpr1carrier P ) _ _ ) . simpl . apply ( iscompsetquotpr ) . apply rp12 . Defined . Definition weqsubquot { X : UU } ( R : eqrel X ) ( P : hsubtypes ( setquot R ) ) : weq P ( setquot ( resrel R ( funcomp ( setquotpr R ) P ) ) ) . Proof . intros . set ( f := fromsubquot R P ) . set ( g := tosubquot R P ) . split with f . assert ( int0 : isaset P ) . apply ( isasetsubset ( @pr1 _ P ) ) . apply ( setproperty ( setquotinset R ) ) . apply isinclpr1carrier . assert ( egf : forall a , paths ( g ( f a ) ) a ) . intros a . destruct a as [ p isp ] . generalize isp . generalize p . clear isp . clear p . assert ( int : forall p , isaprop ( forall isp : P p , paths (g (f ( tpair _ p isp ))) ( tpair _ p isp ) ) ) . intro p . apply impred . intro . apply ( int0 _ _ ) . apply ( setquotunivprop _ ( fun a => hProppair _ ( int a ) ) ) . simpl . intros x isp . apply ( invmaponpathsincl _ ( isinclpr1carrier P ) _ _ ) . apply idpath . assert ( efg : forall a , paths ( f ( g a ) ) a ) . assert ( int : forall a , isaprop ( paths ( f ( g a ) ) a ) ) . intro a . apply ( setproperty ( setquotinset (resrel R (funcomp (setquotpr R) P)) ) ) . set ( Q := reseqrel R (funcomp (setquotpr R) P) ) . apply ( setquotunivprop Q ( fun a : setquot (resrel R (funcomp (setquotpr R) P)) => hProppair _ ( int a ) ) ) . intro a . simpl . unfold f . unfold g . unfold fromsubquot . unfold tosubquot . (* Compilations hangs here if the next command is "simpl." in 8.4-8.5-trunk *) apply ( invmaponpathsincl _ ( isinclpr1 _ ( fun a => isapropiseqclass _ a ) ) ) . apply idpath . apply ( gradth _ _ egf efg ) . Defined . (** Comment: unfortunetely [ weqsubquot ] is not as useful as it should be at moment due to the failure of the following code to work: [ Lemma test ( X : UU ) ( R : eqrel X ) ( P : hsubtypes ( setquot R ) ) ( x : X ) ( is : P ( setquotpr R x ) ) : paths ( setquotpr ( reseqrel R (funcomp (setquotpr R) P) ) ( tpair _ x is ) ) ( fromsubquot R P ( tpair _ ( setquotpr R x ) is ) ) . Proof . intros . apply idpath . Defined . ] As one of the consequences we are forced to use a "hack" in the definition of multiplicative inverses for rationals in [ hqmultinv ] . The issue which arises here is the same one which arises in several other places in the work with quotients. It can be traced back first to the failure of [ invmaponpathsincl ] to map [ idpath ] to [ idpath ] and then to the fact that for [ ( X : UU ) ( is : isaprop X ) ] the term [ t := proofirrelevance is : forall x1 x2 : X , paths x1 x2 ] does not satisfy (definitionally) the condition [ t x x == idpath x ]. It can and probably should be fixed by the addition of a new componenet to CIC in the form of a term constructor: tfc ( X : Type ) ( E : X -> Type ) ( is : forall x , iscontr ( E x ) ) ( x0 : X ) ( e0 : E x0 ) : forall x : X , E x . and a computation rule tfc_comp ( tfc X E is x0 e0 x0 ) == e0 (with both tfc and tfc_comp definable in an arbitrary context) Such an extension will be compatible with the univalent models and should not, as far as I can see, provide any problems for normalization or for the decidability of typing. Using tfc one can give a construction of [ proofirrelevance ] as follows ( recall that [ isaprop := forall x1 x2 , iscontr ( paths x1 x2 ) ] ) : Lemma proofirrelevance { X : UU } ( is : isaprop X ) : forall x1 x2 , paths x1 x2 . Proof . intros X is x1 . apply ( tfc X ( fun x2 => paths x1 x2 ) is x1 ( idpath x1 ) ) . Defined . Defined in this way [ proofirrelevance ] will have the required property and will enable to define [ invmaponpathsincl ] in such a way that the existing proofs of [ setquotl0 ] and [ fromsubquot ] and [ weqsubquot ] will provide the desired behavior of [ fromsubquot ] on terms of the form [ ( tpair _ ( setquotpr R x ) is ) ]. *) (** *** The set of connected components of type. *) Definition pathshrel ( X : UU ) := fun x x' : X => ishinh ( paths x x' ) . Definition istranspathshrel ( X : UU ) : istrans ( pathshrel X ) := fun x x' x'' : _ => fun a : _ => fun b : _ => hinhfun2 (fun e1 : paths x x' => fun e2 : paths x' x'' => pathscomp0 e1 e2 ) a b . Definition isreflpathshrel ( X : UU ) : isrefl ( pathshrel X ) := fun x : _ => hinhpr _ ( idpath x ) . Definition issymmpathshrel ( X : UU ) : issymm ( pathshrel X ) := fun x x': _ => fun a : _ => hinhfun ( fun e : paths x x' => pathsinv0 e ) a . Definition pathseqrel ( X : UU ) := eqrelconstr ( pathshrel X ) ( istranspathshrel X ) ( isreflpathshrel X ) ( issymmpathshrel X ) . Definition pi0 ( X : UU ) := setquot ( pathshrel X ) . Definition pi0pr ( X : UU ) := setquotpr ( pathseqrel X ) . (** ** Set quotients. Construction 2. ****************** THIS SECTION IS UNFINISHED ****************** Another construction of the set quotient is based on the following idea. Let X be a set. Then we have the obvious "double evaluation map" from X to the product over all sets Y of the sets ((X -> Y) -> Y). This is always an inclusion and in particular X is isomorphic to the image of this map. Suppore now we have a relation (which need not be an equivalence relation) R on X. Then we know that (X/R -> Y) is a subset of (X -> Y) which consists of functions compatible with the relation even if we do not know what X/R is. Thus we may consider the image of X in the product over all Y of ((X/R -> Y) ->Y) and it must be isomorphic to X/R. This ideas are realized in the definitions given below. There are two advantages to this approach. One is that the relation need not be an equivalence relation. Another one is that it can be more easily generalized to the higher quotients of type. We also show that two constructions of set-quotients of types - the one given in set_quotients and the one given here agree up to an isomorphism (weak equivalence). *) (** *** Functions compatible with a relation *) Definition compfun { X : UU } ( R : hrel X ) ( S : UU ) : UU := total2 (fun F: X -> S => iscomprelfun R F ) . Definition compfunpair { X : UU } ( R : hrel X ) { S : UU } ( f : X -> S ) ( is : iscomprelfun R f ) : compfun R S := tpair _ f is . Definition pr1compfun ( X : UU ) ( R : hrel X ) ( S : UU ) : @compfun X R S -> ( X -> S ) := @pr1 _ _ . Coercion pr1compfun : compfun >-> Funclass . Definition compevmapset { X : UU } ( R : hrel X ) : X -> forall S : hSet, ( compfun R S ) -> S := fun x : X => fun S : _ => fun f : compfun R S => pr1 f x. Definition compfuncomp { X : UU } ( R : hrel X ) { S S' : UU } ( f : compfun R S ) ( g : S -> S' ) : compfun R S' . Proof . intros . split with ( funcomp f g ) . intros x x' r . apply ( maponpaths g ( pr2 f x x' r ) ) . Defined . (** Tests Definition F ( X Y : UU ) ( R : hrel X ) := ( compfun R Y ) -> Y . Definition Fi ( X Y : UU ) ( R : hrel X ) : X -> F X Y R := fun x => fun f => f x . Lemma iscompFi { X Y : UU } ( R : hrel X ) : iscomprelfun R ( Fi X Y R ) . Proof . intros . intros x x' r . unfold Fi . apply funextfun . intro f . apply ( pr2 f x x' r ) . Defined . Definition Fv { X Y : UU } ( R : hrel X ) ( f : compfun R Y ) ( phi : F X Y R ) : Y := phi f . Definition qeq { X Y : UU } ( R : hrel X ) := total2 ( fun phi : F X Y R => forall psi : F X Y R -> Y , paths ( psi phi ) ( Fv R ( compfuncomp R ( compfunpair R _ ( iscompFi R ) ) psi ) phi ) ) . Lemma isinclpr1qeq { X : UU } ( R : hrel X ) ( Y : hSet ) : isincl ( @pr1 _ ( fun phi : F X Y R => forall psi : F X Y R -> Y , paths ( psi phi ) ( Fv R ( compfuncomp R ( compfunpair R _ ( iscompFi R ) ) psi ) phi ) ) ) . Proof . intros . apply isinclpr1 . intro phi . apply impred . intro psi . apply ( pr2 Y ) . Defined. Definition toqeq { X Y : UU } ( R : hrel X ) ( x : X ) : @qeq X Y R . Proof . intros . split with ( Fi X Y R x ) . intro psi. apply idpath . Defined . Lemma iscomptoqeq { X : UU } ( Y : hSet ) ( R : hrel X ) : iscomprelfun R ( @toqeq X Y R ) . Proof . intros . intros x x' r . unfold toqeq . apply ( invmaponpathsincl _ ( isinclpr1qeq R Y ) ) . apply ( @iscompFi X Y R x x' r ) . Defined . Definition qequniv { X : UU } ( Y : hSet ) ( R : hrel X ) ( f : compfun R Y ) ( phi : @qeq X Y R ) : Y . Proof . intros . apply ( Fv R f ( pr1 phi ) ) . Defined. Lemma qequnivandpr { X : UU } ( Y : hSet ) ( R : hrel X ) ( f : compfun R Y ) ( x : X ) : paths ( qequniv Y R f ( toqeq R x ) ) ( f x ) . Proof . intros . apply idpath . Defined . Lemma etaqeq { X : UU } ( Y : hSet ) ( R : hrel X ) ( psi : qeq R -> Y ) ( phi : qeq R ) : paths ( psi phi ) ( qequniv Y R ( compfuncomp R ( compfunpair R _ ( iscomptoqeq Y R ) ) psi ) phi ) . Proof . intros . apply ( pr2 phi psi ) . Definition Fd1 { X Y : UU } : F X Y R -> ( F ( F X Y ) Y ) := Fi ( F X Y ) Y . Definition Fd2 { X Y : UU } ( R : hrel X ) ( phi : F X Y R ) ( psi : F X Y R -> Y ) : Y := ( Fv R ( funcomp ( Fi X Y R ) psi ) phi ) . Definition Ffunct { X1 X2 : UU } ( f : X1 -> X2 ) ( Y : UU ) : F X1 Y -> F X2 Y := fun phi => fun g => phi ( funcomp f g ) . Lemma testd1 { X Y : UU } ( psi : F X Y -> Y ) ( phi : F X Y ) : paths ( psi phi ) ( Fd1 phi psi ) . Proof . intros . apply idpath . Defined . Lemma testd2 { X Y : UU } ( psi : F X Y -> Y ) ( phi : F X Y ) : paths ( Fv ( funcomp ( Fi X Y ) psi ) phi ) ( Fd2 phi psi ) . Proof . intros . apply idpath . Defined . Definition F ( X Y : UU ) := ( X -> Y ) -> Y . Definition Ffunct { X1 X2 : UU } ( f : X1 -> X2 ) ( Y : UU ) : F X1 Y -> F X2 Y := fun phi => fun g => phi ( funcomp f g ) . Definition Fi ( X Y : UU ) : X -> F X Y := fun x => fun f => f x . Definition Fd1 { X Y : UU } : F X Y -> ( F ( F X Y ) Y ) := Fi ( F X Y ) Y . Definition Fd2 { X Y : UU } : F X Y -> ( F ( F X Y ) Y ) := Ffunct ( Fi X Y ) Y . Definition Fv { X Y : UU } ( f : X -> Y ) ( phi : F X Y ) : Y := phi f . Lemma testd1 { X Y : UU } ( psi : F X Y -> Y ) ( phi : F X Y ) : paths ( psi phi ) ( Fd1 phi psi ) . Proof . intros . apply idpath . Defined . Lemma testd2 { X Y : UU } ( psi : F X Y -> Y ) ( phi : F X Y ) : paths ( Fv ( funcomp ( Fi X Y ) psi ) phi ) ( Fd2 phi psi ) . Proof . intros . apply idpath . Defined . Lemma Xineq ( X Y : UU ) ( x : X ) : paths ( Fd1 ( Fi X Y x ) ) ( Fd2 ( Fi X Y x ) ) . Proof . intros . apply idpath . Defined . Lemma test ( X Y : UU ) ( phi : F X Y ) ( f : X -> Y ) : paths ( Fd1 phi ( Fi ( X -> Y ) Y f ) ) ( Fd2 phi ( Fi ( X -> Y ) Y f ) ) . Proof . intros . unfold Fd1 . unfold Fd2. unfold Fi . unfold Ffunct . unfold funcomp . simpl . apply ( maponpaths phi ) . apply etacorrection . Defined . Inductive try0 ( T : Type ) ( t : T ) : forall ( t1 t2 : T ) ( e1 : paths t t1 ) ( e2 : paths t t2 ) , Type := idconstr : forall ( t' : T ) ( e' : paths t t' ) , try0 T t t' t' e' e' . Definition try0map1 ( T : Type ) ( t : T ) ( t1 t2 : T ) ( e1 : paths t t1 ) ( e2 : paths t t2 ) ( X : try0 T t t1 t2 e1 e2 ) : paths t1 t2 . Proof . intros . destruct X . apply idpath . Defined . Definition try0map2 ( T : Type ) ( t : T ) ( t1 t2 : T ) ( e1 : paths t t1 ) ( e2 : paths t t2 ) : try0 T t t1 t2 e1 e2 . Proof . Lemma test ( X : UU ) ( t : X ) : paths ( pr2 ( iscontrcoconustot X t ) ( pr1 ( iscontrcoconustot X t ) ) ) ( idpath _ ) . Proof . intros . apply idpath . Lemma test { X : UU } ( is : iscontr X ) : paths ( pr2 ( iscontrcor is ) ( pr1 ( iscontrcor is ) ) ) ( idpath _ ) . Proof . intros . apply idpath . Lemma test { X : UU } ( R : eqrel X ) ( Y : hSet ) ( f : setquot R -> Y ) : paths f ( setquotuniv R Y ( funcomp ( setquotpr R ) f ) ( fun x x' : X => fun r : R x x' => maponpaths f ( iscompsetquotpr R x x' r ) ) ) . Proof . intros . apply funextfun . intro c . simpl . destruct c as [ A iseq ] . simpl . *) (** *** The quotient set of a type by a relation. *) Definition setquot2 { X : UU } ( R : hrel X ) : UU := image ( compevmapset R ) . Theorem isasetsetquot2 { X : UU } ( R : hrel X ) : isaset ( setquot2 R ) . Proof. intros. assert (is1: isofhlevel 2 ( forall S: hSet, (compfun R S) -> S )). apply impred. intro. apply impred. intro X0. apply (pr2 t). apply (isasetsubset _ is1 (isinclpr1image _ )). Defined. Definition setquot2inset { X : UU } ( R : hrel X ) : hSet := hSetpair _ ( isasetsetquot2 R ) . (** We will be asuming below that setquot2 is in UU. In the future it should be proved using [ issurjsetquot2pr ] below and a resizing axiom. The appropriate resizing axiom for this should say that if X -> Y is a surjection, Y is an hset and X : UU then Y : UU . *) Definition setquot2pr { X : UU } ( R : hrel X ) : X -> setquot2 R := fun x : X => imagepair ( compevmapset R ) _ ( hinhpr _ ( hfiberpair ( compevmapset R ) x ( idpath _ ) ) ) . Lemma issurjsetquot2pr { X : UU } ( R : hrel X ) : issurjective ( setquot2pr R ) . Proof. intros. apply issurjprtoimage. Defined. Lemma iscompsetquot2pr { X : UU } ( R : hrel X ) : iscomprelfun R ( setquot2pr R ) . Proof. intros. intros x x' r . assert (e1: paths ( compevmapset R x ) ( compevmapset R x' ) ) . apply funextsec. intro S. apply funextsec. intro f. unfold compfun in f. apply ( pr2 f x x' r ) . apply ( invmaponpathsincl _ ( isinclpr1image ( compevmapset R ) ) ( setquot2pr R x ) ( setquot2pr R x' ) e1 ) . Defined . (** *** Universal property of [ seqtquot2 R ] for functions to sets satisfying compatibility condition [ iscomprelfun ] *) Definition setquot2univ { X : UU } ( R : hrel X ) ( Y : hSet ) ( F : X -> Y ) (is : iscomprelfun R F ) ( c: setquot2 R ) : Y := pr1 c Y ( compfunpair _ F is ) . Theorem setquot2univcomm { X : UU } ( R : hrel X ) ( Y : hSet ) ( F : X -> Y ) (iscomp : iscomprelfun R F ) ( x : X) : paths (setquot2univ _ _ F iscomp ( setquot2pr R x )) (F x) . Proof. intros. apply idpath. Defined. (** *** Weak equivalence from [ R x x' ] to [ paths ( setquot2pr R x ) ( setquot2pr R x' ) ] *) Lemma weqpathssetquot2l1 { X : UU } ( R : eqrel X ) ( x : X ) : iscomprelfun R ( fun x' => R x x' ) . Proof . intros . intros x' x'' . intro r . apply uahp . intro r' . apply ( eqreltrans R _ _ _ r' r ) . intro r'' . apply ( eqreltrans R _ _ _ r'' ( eqrelsymm R _ _ r ) ) . Defined . Theorem weqpathsinsetquot2 { X : UU } ( R : eqrel X ) ( x x' : X ) : weq ( R x x' ) ( paths ( setquot2pr R x ) ( setquot2pr R x' ) ) . Proof . intros . apply weqimplimpl . apply iscompsetquot2pr . set ( int := setquot2univ R hPropset ( fun x'' => R x x'' ) ( weqpathssetquot2l1 R x ) ) . intro e . change ( pr1 ( int ( setquot2pr R x' ) ) ) . destruct e . change ( R x x ) . apply ( eqrelrefl R ) . apply ( pr2 ( R x x' ) ) . apply ( isasetsetquot2 ) . Defined . (* *** Comparison of setquot2 and setquot. *) Definition setquottosetquot2 (X: UU) (R: hrel X) (is: iseqrel R) : setquot R -> setquot2 R. Proof. intros X R is X0. apply (setquotuniv R (hSetpair _ (isasetsetquot2 R)) (setquot2pr R) (iscompsetquot2pr R) X0). Defined. (* End of the file hSet.v *) Voevodsky-Coq/hlevel2/._hz.v000777 000765 000024 00000000256 12346040720 016575 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/hz.v000777 000765 000024 00000121124 12346040720 016356 0ustar00nicolastaff000000 000000 (** * Generalities on the type of integers and integer arithmetic. Vladimir Voevodsky . Aug. - Sep. 2011. In this file we introduce the type [ hz ] of integers defined as the quotient set of [ dirprod nat nat ] by the standard equivalence relation and develop the main notions of the integer arithmetic using this definition . *) (** ** Preambule *) (** Settings *) Unset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *) (** Imports *) Add LoadPath ".." as Foundations. Require Export Foundations.hlevel2.hnat . (** Upstream *) (** ** The commutative ring [ hz ] of integres *) (** *** General definitions *) Definition hz : commrng := commrigtocommrng natcommrig . Definition hzaddabgr : abgr := rngaddabgr hz . Definition hzmultabmonoid : abmonoid := rngmultabmonoid hz . Definition natnattohz : nat -> nat -> hz := fun n m => setquotpr _ ( dirprodpair n m ) . Definition hzplus : hz -> hz -> hz := @op1 hz. Definition hzsign : hz -> hz := grinv hzaddabgr . Definition hzminus : hz -> hz -> hz := fun x y => hzplus x ( hzsign y ) . Definition hzzero : hz := unel hzaddabgr . Definition hzmult : hz -> hz -> hz := @op2 hz . Definition hzone : hz := unel hzmultabmonoid . Bind Scope hz_scope with hz . Notation " x + y " := ( hzplus x y ) : hz_scope . Notation " 0 " := hzzero : hz_scope . Notation " 1 " := hzone : hz_scope . Notation " - x " := ( hzsign x ) : hz_scope . Notation " x - y " := ( hzminus x y ) : hz_scope . Notation " x * y " := ( hzmult x y ) : hz_scope . Delimit Scope hz_scope with hz . (** *** Properties of equlaity on [ hz ] *) Theorem isdeceqhz : isdeceq hz . Proof . change ( isdeceq ( abgrfrac ( rigaddabmonoid natcommrig ) ) ) . apply isdeceqabgrfrac . apply isinclnatplusr . apply isdeceqnat . Defined . Lemma isasethz : isaset hz . Proof . apply ( setproperty hzaddabgr ) . Defined . Definition hzeq ( x y : hz ) : hProp := hProppair ( paths x y ) ( isasethz _ _ ) . Definition isdecrelhzeq : isdecrel hzeq := fun a b => isdeceqhz a b . Definition hzdeceq : decrel hz := decrelpair isdecrelhzeq . (* Canonical Structure hzdeceq. *) Definition hzbooleq := decreltobrel hzdeceq . Definition hzneq ( x y : hz ) : hProp := hProppair ( neg ( paths x y ) ) ( isapropneg _ ) . Definition isdecrelhzneq : isdecrel hzneq := isdecnegrel _ isdecrelhzeq . Definition hzdecneq : decrel hz := decrelpair isdecrelhzneq . (* Canonical Structure hzdecneq. *) Definition hzboolneq := decreltobrel hzdecneq . Open Local Scope hz_scope . (** *** [ hz ] is a non-zero ring *) Lemma isnonzerornghz : isnonzerorng hz . Proof . apply ( ct ( hzneq , isdecrelhzneq, 1 , 0 ) ) . Defined . (** *** Properties of addition and subtraction on [ hz ] *) Definition hzminuszero : paths ( - 0 ) 0 := rnginvunel1 hz . Lemma hzplusr0 ( x : hz ) : paths ( x + 0 ) x . Proof . intro . apply ( rngrunax1 _ x ) . Defined . Lemma hzplusl0 ( x : hz ) : paths ( 0 + x ) x . Proof . intro . apply ( rnglunax1 _ x ) . Defined . Lemma hzplusassoc ( x y z : hz ) : paths ( ( x + y ) + z ) ( x + ( y + z ) ) . Proof . intros . apply ( rngassoc1 hz x y z ) . Defined . Lemma hzpluscomm ( x y : hz ) : paths ( x + y ) ( y + x ) . Proof . intros . apply ( rngcomm1 hz x y ) . Defined . Lemma hzlminus ( x : hz ) : paths ( -x + x ) 0 . Proof . intro. apply ( rnglinvax1 hz x ) . Defined . Lemma hzrminus ( x : hz ) : paths ( x - x ) 0 . Proof . intro. apply ( rngrinvax1 hz x ) . Defined . Lemma isinclhzplusr ( n : hz ) : isincl ( fun m : hz => m + n ) . Proof. intro . apply ( pr2 ( weqtoincl _ _ ( weqrmultingr hzaddabgr n ) ) ) . Defined. Lemma isinclhzplusl ( n : hz ) : isincl ( fun m : hz => n + m ) . Proof. intro. apply ( pr2 ( weqtoincl _ _ ( weqlmultingr hzaddabgr n ) ) ) . Defined . Lemma hzpluslcan ( a b c : hz ) ( is : paths ( c + a ) ( c + b ) ) : paths a b . Proof . intros . apply ( @grlcan hzaddabgr a b c is ) . Defined . Lemma hzplusrcan ( a b c : hz ) ( is : paths ( a + c ) ( b + c ) ) : paths a b . Proof . intros . apply ( @grrcan hzaddabgr a b c is ) . Defined . Definition hzinvmaponpathsminus { a b : hz } ( e : paths ( - a ) ( - b ) ) : paths a b := grinvmaponpathsinv hzaddabgr e . (** *** Properties of multiplication on [ hz ] *) Lemma hzmultr1 ( x : hz ) : paths ( x * 1 ) x . Proof . intro . apply ( rngrunax2 _ x ) . Defined . Lemma hzmultl1 ( x : hz ) : paths ( 1 * x ) x . Proof . intro . apply ( rnglunax2 _ x ) . Defined . Lemma hzmult0x ( x : hz ) : paths ( 0 * x ) 0 . Proof . intro . apply ( rngmult0x _ x ) . Defined . Lemma hzmultx0 ( x : hz ) : paths ( x * 0 ) 0 . Proof . intro . apply ( rngmultx0 _ x ) . Defined . Lemma hzmultassoc ( x y z : hz ) : paths ( ( x * y ) * z ) ( x * ( y * z ) ) . Proof . intros . apply ( rngassoc2 hz x y z ) . Defined . Lemma hzmultcomm ( x y : hz ) : paths ( x * y ) ( y * x ) . Proof . intros . apply ( rngcomm2 hz x y ) . Defined . Definition hzneq0andmultlinv ( n m : hz ) ( isnm : hzneq ( n * m ) 0 ) : hzneq n 0 := rngneq0andmultlinv hz n m isnm . Definition hzneq0andmultrinv ( n m : hz ) ( isnm : hzneq ( n * m ) 0 ) : hzneq m 0 := rngneq0andmultrinv hz n m isnm . (** ** Definition and properties of "greater", "less", "greater or equal" and "less or equal" on [ hz ] . *) (** *** Definitions and notations *) Definition hzgth : hrel hz := rigtorngrel natcommrig isplushrelnatgth . Definition hzlth : hrel hz := fun a b => hzgth b a . Definition hzleh : hrel hz := fun a b => hProppair ( neg ( hzgth a b ) ) ( isapropneg _ ) . Definition hzgeh : hrel hz := fun a b => hProppair ( neg ( hzgth b a ) ) ( isapropneg _ ) . (** *** Decidability *) Lemma isdecrelhzgth : isdecrel hzgth . Proof . apply ( isdecrigtorngrel natcommrig isplushrelnatgth ) . apply isinvplushrelnatgth . apply isdecrelnatgth . Defined . Definition hzgthdec := decrelpair isdecrelhzgth . (* Canonical Structure hzgthdec . *) Definition isdecrelhzlth : isdecrel hzlth := fun x x' => isdecrelhzgth x' x . Definition hzlthdec := decrelpair isdecrelhzlth . (* Canonical Structure hzlthdec . *) Definition isdecrelhzleh : isdecrel hzleh := isdecnegrel _ isdecrelhzgth . Definition hzlehdec := decrelpair isdecrelhzleh . (* Canonical Structure hzlehdec . *) Definition isdecrelhzgeh : isdecrel hzgeh := fun x x' => isdecrelhzleh x' x . Definition hzgehdec := decrelpair isdecrelhzgeh . (* Canonical Structure hzgehdec . *) (** *** Properties of individual relations *) (** [ hzgth ] *) Lemma istranshzgth ( n m k : hz ) : hzgth n m -> hzgth m k -> hzgth n k . Proof. apply ( istransabgrfracrel nataddabmonoid isplushrelnatgth ) . unfold istrans . apply istransnatgth . Defined. Lemma isirreflhzgth ( n : hz ) : neg ( hzgth n n ) . Proof. apply ( isirreflabgrfracrel nataddabmonoid isplushrelnatgth ) . unfold isirrefl . apply isirreflnatgth . Defined . Lemma hzgthtoneq ( n m : hz ) ( g : hzgth n m ) : neg ( paths n m ) . Proof . intros . intro e . rewrite e in g . apply ( isirreflhzgth _ g ) . Defined . Lemma isasymmhzgth ( n m : hz ) : hzgth n m -> hzgth m n -> empty . Proof. apply ( isasymmabgrfracrel nataddabmonoid isplushrelnatgth ) . unfold isasymm . apply isasymmnatgth . Defined . Lemma isantisymmneghzgth ( n m : hz ) : neg ( hzgth n m ) -> neg ( hzgth m n ) -> paths n m . Proof . apply ( isantisymmnegabgrfracrel nataddabmonoid isplushrelnatgth ) . unfold isantisymmneg . apply isantisymmnegnatgth . Defined . Lemma isnegrelhzgth : isnegrel hzgth . Proof . apply isdecreltoisnegrel . apply isdecrelhzgth . Defined . Lemma iscoantisymmhzgth ( n m : hz ) : neg ( hzgth n m ) -> coprod ( hzgth m n ) ( paths n m ) . Proof . apply isantisymmnegtoiscoantisymm . apply isdecrelhzgth . intros n m . apply isantisymmneghzgth . Defined . Lemma iscotranshzgth ( n m k : hz ) : hzgth n k -> hdisj ( hzgth n m ) ( hzgth m k ) . Proof . intros x y z gxz . destruct ( isdecrelhzgth x y ) as [ gxy | ngxy ] . apply ( hinhpr _ ( ii1 gxy ) ) . apply hinhpr . apply ii2 . destruct ( isdecrelhzgth y x ) as [ gyx | ngyx ] . apply ( istranshzgth _ _ _ gyx gxz ) . set ( e := isantisymmneghzgth _ _ ngxy ngyx ) . rewrite e in gxz . apply gxz . Defined . (** [ hzlth ] *) Definition istranshzlth ( n m k : hz ) : hzlth n m -> hzlth m k -> hzlth n k := fun lnm lmk => istranshzgth _ _ _ lmk lnm . Definition isirreflhzlth ( n : hz ) : neg ( hzlth n n ) := isirreflhzgth n . Lemma hzlthtoneq ( n m : hz ) ( g : hzlth n m ) : neg ( paths n m ) . Proof . intros . intro e . rewrite e in g . apply ( isirreflhzlth _ g ) . Defined . Definition isasymmhzlth ( n m : hz ) : hzlth n m -> hzlth m n -> empty := fun lnm lmn => isasymmhzgth _ _ lmn lnm . Definition isantisymmneghztth ( n m : hz ) : neg ( hzlth n m ) -> neg ( hzlth m n ) -> paths n m := fun nlnm nlmn => isantisymmneghzgth _ _ nlmn nlnm . Definition isnegrelhzlth : isnegrel hzlth := fun n m => isnegrelhzgth m n . Definition iscoantisymmhzlth ( n m : hz ) : neg ( hzlth n m ) -> coprod ( hzlth m n ) ( paths n m ) . Proof . intros n m nlnm . destruct ( iscoantisymmhzgth m n nlnm ) as [ l | e ] . apply ( ii1 l ) . apply ( ii2 ( pathsinv0 e ) ) . Defined . Definition iscotranshzlth ( n m k : hz ) : hzlth n k -> hdisj ( hzlth n m ) ( hzlth m k ) . Proof . intros n m k lnk . apply ( ( pr1 islogeqcommhdisj ) ( iscotranshzgth _ _ _ lnk ) ) . Defined . (** [ hzleh ] *) Definition istranshzleh ( n m k : hz ) : hzleh n m -> hzleh m k -> hzleh n k . Proof. apply istransnegrel . unfold iscotrans. apply iscotranshzgth . Defined. Definition isreflhzleh ( n : hz ) : hzleh n n := isirreflhzgth n . Definition isantisymmhzleh ( n m : hz ) : hzleh n m -> hzleh m n -> paths n m := isantisymmneghzgth n m . Definition isnegrelhzleh : isnegrel hzleh . Proof . apply isdecreltoisnegrel . apply isdecrelhzleh . Defined . Definition iscoasymmhzleh ( n m : hz ) ( nl : neg ( hzleh n m ) ) : hzleh m n := negf ( isasymmhzgth _ _ ) nl . Definition istotalhzleh : istotal hzleh . Proof . intros x y . destruct ( isdecrelhzleh x y ) as [ lxy | lyx ] . apply ( hinhpr _ ( ii1 lxy ) ) . apply hinhpr . apply ii2 . apply ( iscoasymmhzleh _ _ lyx ) . Defined . (** [ hzgeh ] . *) Definition istranshzgeh ( n m k : hz ) : hzgeh n m -> hzgeh m k -> hzgeh n k := fun gnm gmk => istranshzleh _ _ _ gmk gnm . Definition isreflhzgeh ( n : hz ) : hzgeh n n := isreflhzleh _ . Definition isantisymmhzgeh ( n m : hz ) : hzgeh n m -> hzgeh m n -> paths n m := fun gnm gmn => isantisymmhzleh _ _ gmn gnm . Definition isnegrelhzgeh : isnegrel hzgeh := fun n m => isnegrelhzleh m n . Definition iscoasymmhzgeh ( n m : hz ) ( nl : neg ( hzgeh n m ) ) : hzgeh m n := iscoasymmhzleh _ _ nl . Definition istotalhzgeh : istotal hzgeh := fun n m => istotalhzleh m n . (** *** Simple implications between comparisons *) Definition hzgthtogeh ( n m : hz ) : hzgth n m -> hzgeh n m . Proof. intros n m g . apply iscoasymmhzgeh . apply ( todneg _ g ) . Defined . Definition hzlthtoleh ( n m : hz ) : hzlth n m -> hzleh n m := hzgthtogeh _ _ . Definition hzlehtoneghzgth ( n m : hz ) : hzleh n m -> neg ( hzgth n m ) . Proof. intros n m is is' . apply ( is is' ) . Defined . Definition hzgthtoneghzleh ( n m : hz ) : hzgth n m -> neg ( hzleh n m ) := fun g l => hzlehtoneghzgth _ _ l g . Definition hzgehtoneghzlth ( n m : hz ) : hzgeh n m -> neg ( hzlth n m ) := fun gnm lnm => hzlehtoneghzgth _ _ gnm lnm . Definition hzlthtoneghzgeh ( n m : hz ) : hzlth n m -> neg ( hzgeh n m ) := fun gnm lnm => hzlehtoneghzgth _ _ lnm gnm . Definition neghzlehtogth ( n m : hz ) : neg ( hzleh n m ) -> hzgth n m := isnegrelhzgth n m . Definition neghzgehtolth ( n m : hz ) : neg ( hzgeh n m ) -> hzlth n m := isnegrelhzlth n m . Definition neghzgthtoleh ( n m : hz ) : neg ( hzgth n m ) -> hzleh n m . Proof . intros n m ng . destruct ( isdecrelhzleh n m ) as [ l | nl ] . apply l . destruct ( nl ng ) . Defined . Definition neghzlthtogeh ( n m : hz ) : neg ( hzlth n m ) -> hzgeh n m := fun nl => neghzgthtoleh _ _ nl . (** *** Comparison alternatives *) Definition hzgthorleh ( n m : hz ) : coprod ( hzgth n m ) ( hzleh n m ) . Proof . intros . apply ( isdecrelhzgth n m ) . Defined . Definition hzlthorgeh ( n m : hz ) : coprod ( hzlth n m ) ( hzgeh n m ) := hzgthorleh _ _ . Definition hzneqchoice ( n m : hz ) ( ne : neg ( paths n m ) ) : coprod ( hzgth n m ) ( hzlth n m ) . Proof . intros . destruct ( hzgthorleh n m ) as [ g | l ] . destruct ( hzlthorgeh n m ) as [ g' | l' ] . destruct ( isasymmhzgth _ _ g g' ) . apply ( ii1 g ) . destruct ( hzlthorgeh n m ) as [ l' | g' ] . apply ( ii2 l' ) . destruct ( ne ( isantisymmhzleh _ _ l g' ) ) . Defined . Definition hzlehchoice ( n m : hz ) ( l : hzleh n m ) : coprod ( hzlth n m ) ( paths n m ) . Proof . intros . destruct ( hzlthorgeh n m ) as [ l' | g ] . apply ( ii1 l' ) . apply ( ii2 ( isantisymmhzleh _ _ l g ) ) . Defined . Definition hzgehchoice ( n m : hz ) ( g : hzgeh n m ) : coprod ( hzgth n m ) ( paths n m ) . Proof . intros . destruct ( hzgthorleh n m ) as [ g' | l ] . apply ( ii1 g' ) . apply ( ii2 ( isantisymmhzleh _ _ l g ) ) . Defined . (** *** Mixed transitivities *) Lemma hzgthgehtrans ( n m k : hz ) : hzgth n m -> hzgeh m k -> hzgth n k . Proof. intros n m k gnm gmk . destruct ( hzgehchoice m k gmk ) as [ g' | e ] . apply ( istranshzgth _ _ _ gnm g' ) . rewrite e in gnm . apply gnm . Defined. Lemma hzgehgthtrans ( n m k : hz ) : hzgeh n m -> hzgth m k -> hzgth n k . Proof. intros n m k gnm gmk . destruct ( hzgehchoice n m gnm ) as [ g' | e ] . apply ( istranshzgth _ _ _ g' gmk ) . rewrite e . apply gmk . Defined. Lemma hzlthlehtrans ( n m k : hz ) : hzlth n m -> hzleh m k -> hzlth n k . Proof . intros n m k l1 l2 . apply ( hzgehgthtrans k m n l2 l1 ) . Defined . Lemma hzlehlthtrans ( n m k : hz ) : hzleh n m -> hzlth m k -> hzlth n k . Proof . intros n m k l1 l2 . apply ( hzgthgehtrans k m n l2 l1 ) . Defined . (** *** Addition and comparisons *) (** [ hzgth ] *) Definition hzgthandplusl ( n m k : hz ) : hzgth n m -> hzgth ( k + n ) ( k + m ) . Proof. apply ( pr1 ( isbinopabgrfracrel nataddabmonoid isplushrelnatgth ) ) . Defined . Definition hzgthandplusr ( n m k : hz ) : hzgth n m -> hzgth ( n + k ) ( m + k ) . Proof. apply ( pr2 ( isbinopabgrfracrel nataddabmonoid isplushrelnatgth ) ) . Defined . Definition hzgthandpluslinv ( n m k : hz ) : hzgth ( k + n ) ( k + m ) -> hzgth n m . Proof. intros n m k g . set ( g' := hzgthandplusl _ _ ( - k ) g ) . clearbody g' . rewrite ( pathsinv0 ( hzplusassoc _ _ n ) ) in g' . rewrite ( pathsinv0 ( hzplusassoc _ _ m ) ) in g' . rewrite ( hzlminus k ) in g' . rewrite ( hzplusl0 _ ) in g' . rewrite ( hzplusl0 _ ) in g' . apply g' . Defined . Definition hzgthandplusrinv ( n m k : hz ) : hzgth ( n + k ) ( m + k ) -> hzgth n m . Proof. intros n m k l . rewrite ( hzpluscomm n k ) in l . rewrite ( hzpluscomm m k ) in l . apply ( hzgthandpluslinv _ _ _ l ) . Defined . Lemma hzgthsnn ( n : hz ) : hzgth ( n + 1 ) n . Proof . intro . set ( int := hzgthandplusl _ _ n ( ct ( hzgth , isdecrelhzgth, 1 , 0 ) ) ) . clearbody int . rewrite ( hzplusr0 _ ) in int . apply int . Defined . (** [ hzlth ] *) Definition hzlthandplusl ( n m k : hz ) : hzlth n m -> hzlth ( k + n ) ( k + m ) := hzgthandplusl _ _ _ . Definition hzlthandplusr ( n m k : hz ) : hzlth n m -> hzlth ( n + k ) ( m + k ) := hzgthandplusr _ _ _ . Definition hzlthandpluslinv ( n m k : hz ) : hzlth ( k + n ) ( k + m ) -> hzlth n m := hzgthandpluslinv _ _ _ . Definition hzlthandplusrinv ( n m k : hz ) : hzlth ( n + k ) ( m + k ) -> hzlth n m := hzgthandplusrinv _ _ _ . Definition hzlthnsn ( n : hz ) : hzlth n ( n + 1 ) := hzgthsnn n . (** [ hzleh ] *) Definition hzlehandplusl ( n m k : hz ) : hzleh n m -> hzleh ( k + n ) ( k + m ) := negf ( hzgthandpluslinv n m k ) . Definition hzlehandplusr ( n m k : hz ) : hzleh n m -> hzleh ( n + k ) ( m + k ) := negf ( hzgthandplusrinv n m k ) . Definition hzlehandpluslinv ( n m k : hz ) : hzleh ( k + n ) ( k + m ) -> hzleh n m := negf ( hzgthandplusl n m k ) . Definition hzlehandplusrinv ( n m k : hz ) : hzleh ( n + k ) ( m + k ) -> hzleh n m := negf ( hzgthandplusr n m k ) . (** [ hzgeh ] *) Definition hzgehandplusl ( n m k : hz ) : hzgeh n m -> hzgeh ( k + n ) ( k + m ) := negf ( hzgthandpluslinv m n k ) . Definition hzgehandplusr ( n m k : hz ) : hzgeh n m -> hzgeh ( n + k ) ( m + k ) := negf ( hzgthandplusrinv m n k ) . Definition hzgehandpluslinv ( n m k : hz ) : hzgeh ( k + n ) ( k + m ) -> hzgeh n m := negf ( hzgthandplusl m n k ) . Definition hzgehandplusrinv ( n m k : hz ) : hzgeh ( n + k ) ( m + k ) -> hzgeh n m := negf ( hzgthandplusr m n k ) . (** *** Properties of [ hzgth ] in the terminology of algebra1.v (continued below) Note: at the moment we do not need properties of [ hzlth ] , [ hzleh ] and [ hzgeh ] in terminology of algebra1 since the corresponding relations on [ hq ] are bulid from [ hqgth ] . *) Lemma isplushrelhzgth : @isbinophrel hzaddabgr hzgth . Proof . split . apply hzgthandplusl . apply hzgthandplusr . Defined . Lemma isinvplushrelhzgth : @isinvbinophrel hzaddabgr hzgth . Proof . split . apply hzgthandpluslinv . apply hzgthandplusrinv . Defined . Lemma isrngmulthzgth : isrngmultgt _ hzgth . Proof . apply ( isrngrigtorngmultgt natcommrig isplushrelnatgth isrigmultgtnatgth ) . Defined . Lemma isinvrngmulthzgth : isinvrngmultgt _ hzgth . Proof . apply ( isinvrngrigtorngmultgt natcommrig isplushrelnatgth isinvplushrelnatgth isinvrigmultgtnatgth ) . Defined . (** *** Negation and comparisons *) (** [ hzgth ] *) Lemma hzgth0andminus { n : hz } ( is : hzgth n 0 ) : hzlth ( - n ) 0 . Proof . intros . apply ( rngfromgt0 hz isplushrelhzgth ) . apply is . Defined . Lemma hzminusandgth0 { n : hz } ( is : hzgth ( - n ) 0 ) : hzlth n 0 . Proof . intros . apply ( rngtolt0 hz isplushrelhzgth ) . apply is . Defined . (** [ hzlth ] *) Lemma hzlth0andminus { n : hz } ( is : hzlth n 0 ) : hzgth ( - n ) 0 . Proof . intros . apply ( rngfromlt0 hz isplushrelhzgth ) . apply is . Defined . Lemma hzminusandlth0 { n : hz } ( is : hzlth ( - n ) 0 ) : hzgth n 0 . Proof . intros . apply ( rngtogt0 hz isplushrelhzgth ) . apply is . Defined . (* ??? Coq slows down on the proofs of these two lemmas for no good reason. *) (** [ hzleh ] *) Lemma hzleh0andminus { n : hz } ( is : hzleh n 0 ) : hzgeh ( - n ) 0 . Proof . intro n . apply ( negf ( @hzminusandlth0 n ) ) . Defined . Lemma hzminusandleh0 { n : hz } ( is : hzleh ( - n ) 0 ) : hzgeh n 0 . Proof . intro n . apply ( negf ( @hzlth0andminus n ) ) . Defined . (** [ hzgeh ] *) Lemma hzgeh0andminus { n : hz } ( is : hzgeh n 0 ) : hzleh ( - n ) 0 . Proof . intro n . apply ( negf ( @hzminusandgth0 n ) ) . Defined . Lemma hzminusandgeh0 { n : hz } ( is : hzgeh ( - n ) 0 ) : hzleh n 0 . Proof . intro n . apply ( negf ( @hzgth0andminus n ) ) . Defined . (** *** Multiplication and comparisons *) (** [ hzgth ] *) Definition hzgthandmultl ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth n m -> hzgth ( k * n ) ( k * m ) . Proof. apply ( isrngmultgttoislrngmultgt _ isplushrelhzgth isrngmulthzgth ) . Defined . Definition hzgthandmultr ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth n m -> hzgth ( n * k ) ( m * k ) . Proof . apply ( isrngmultgttoisrrngmultgt _ isplushrelhzgth isrngmulthzgth ) . Defined . Definition hzgthandmultlinv ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth ( k * n ) ( k * m ) -> hzgth n m . Proof . intros n m k is is' . apply ( isinvrngmultgttoislinvrngmultgt hz isplushrelhzgth isinvrngmulthzgth n m k is is' ) . Defined . Definition hzgthandmultrinv ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth ( n * k ) ( m * k ) -> hzgth n m . Proof. intros n m k is is' . apply ( isinvrngmultgttoisrinvrngmultgt hz isplushrelhzgth isinvrngmulthzgth n m k is is' ) . Defined . (** [ hzlth ] *) Definition hzlthandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzlth n m -> hzlth ( k * n ) ( k * m ) := hzgthandmultl _ _ _ is . Definition hzlthandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzlth n m -> hzlth ( n * k ) ( m * k ) := hzgthandmultr _ _ _ is . Definition hzlthandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzlth ( k * n ) ( k * m ) -> hzlth n m := hzgthandmultlinv _ _ _ is . Definition hzlthandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzlth ( n * k ) ( m * k ) -> hzlth n m := hzgthandmultrinv _ _ _ is . (** [ hzleh ] *) Definition hzlehandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzleh n m -> hzleh ( k * n ) ( k * m ) := negf ( hzgthandmultlinv _ _ _ is ) . Definition hzlehandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzleh n m -> hzleh ( n * k ) ( m * k ) := negf ( hzgthandmultrinv _ _ _ is ) . Definition hzlehandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzleh ( k * n ) ( k * m ) -> hzleh n m := negf ( hzgthandmultl _ _ _ is ) . Definition hzlehandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzleh ( n * k ) ( m * k ) -> hzleh n m := negf ( hzgthandmultr _ _ _ is ) . (** [ hzgeh ] *) Definition hzgehandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh n m -> hzgeh ( k * n ) ( k * m ) := negf ( hzgthandmultlinv _ _ _ is ) . Definition hzgehandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh n m -> hzgeh ( n * k ) ( m * k ) := negf ( hzgthandmultrinv _ _ _ is ) . Definition hzgehandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh ( k * n ) ( k * m ) -> hzgeh n m := negf ( hzgthandmultl _ _ _ is ) . Definition hzgehandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh ( n * k ) ( m * k ) -> hzgeh n m := negf ( hzgthandmultr _ _ _ is ) . (** Multiplication of positive with positive, positive with negative, negative with positive, two negatives etc. *) Lemma hzmultgth0gth0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzgth n 0 ) : hzgth ( m * n ) 0 . Proof . intros . apply isrngmulthzgth . apply ism . apply isn . Defined . Lemma hzmultgth0geh0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzgeh n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzgehchoice _ _ isn ) as [ gn | en ] . apply ( hzgthtogeh _ _ ( hzmultgth0gth0 ism gn ) ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined . Lemma hzmultgeh0gth0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzgth n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzgehchoice _ _ ism ) as [ gm | em ] . apply ( hzgthtogeh _ _ ( hzmultgth0gth0 gm isn ) ) . rewrite em . rewrite ( hzmult0x _ ) . apply isreflhzgeh . Defined . Lemma hzmultgeh0geh0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzgeh n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzgehchoice _ _ isn ) as [ gn | en ] . apply ( hzmultgeh0gth0 ism gn ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined . Lemma hzmultgth0lth0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzlth n 0 ) : hzlth ( m * n ) 0 . Proof . intros . apply ( rngmultgt0lt0 hz isplushrelhzgth isrngmulthzgth ) . apply ism . apply isn . Defined . Lemma hzmultgth0leh0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzleh n 0 ) : hzleh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . apply ( hzlthtoleh _ _ ( hzmultgth0lth0 ism ln ) ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzleh . Defined . Lemma hzmultgeh0lth0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzlth n 0 ) : hzleh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ ism ) as [ lm | em ] . apply ( hzlthtoleh _ _ ( hzmultgth0lth0 lm isn ) ) . destruct em . rewrite ( hzmult0x _ ) . apply isreflhzleh . Defined . Lemma hzmultgeh0leh0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzleh n 0 ) : hzleh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . apply ( hzmultgeh0lth0 ism ln ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzleh . Defined . Lemma hzmultlth0gth0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzgth n 0 ) : hzlth ( m * n ) 0 . Proof . intros . rewrite ( hzmultcomm ) . apply hzmultgth0lth0 . apply isn . apply ism . Defined . Lemma hzmultlth0geh0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzgeh n 0 ) : hzleh ( m * n ) 0 . Proof . intros . rewrite ( hzmultcomm ) . apply hzmultgeh0lth0 . apply isn . apply ism . Defined . Lemma hzmultleh0gth0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzgth n 0 ) : hzleh ( m * n ) 0 . Proof . intros . rewrite ( hzmultcomm ) . apply hzmultgth0leh0 . apply isn . apply ism . Defined . Lemma hzmultleh0geh0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzgeh n 0 ) : hzleh ( m * n ) 0 . Proof . intros . rewrite ( hzmultcomm ) . apply hzmultgeh0leh0 . apply isn . apply ism . Defined . Lemma hzmultlth0lth0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzlth n 0 ) : hzgth ( m * n ) 0 . Proof . intros . assert ( ism' := hzlth0andminus ism ) . assert ( isn' := hzlth0andminus isn ) . assert ( int := isrngmulthzgth _ _ ism' isn' ) . rewrite ( rngmultminusminus hz ) in int . apply int . Defined . Lemma hzmultlth0leh0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzleh n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . intros . destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . apply ( hzgthtogeh _ _ ( hzmultlth0lth0 ism ln ) ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined . Lemma hzmultleh0lth0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzlth n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ ism ) as [ lm | em ] . apply ( hzgthtogeh _ _ ( hzmultlth0lth0 lm isn ) ) . rewrite em . rewrite ( hzmult0x _ ) . apply isreflhzgeh . Defined . Lemma hzmultleh0leh0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzleh n 0 ) : hzgeh ( m * n ) 0 . Proof . intros . destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . apply ( hzmultleh0lth0 ism ln ) . rewrite en . rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined . (** *** [ hz ] as an integral domain *) Lemma isintdomhz : isintdom hz . Proof . split with isnonzerornghz . intros a b e0 . destruct ( isdeceqhz a 0 ) as [ ea | nea ] . apply ( hinhpr _ ( ii1 ea ) ) . destruct ( isdeceqhz b 0 ) as [ eb | neb ] . apply ( hinhpr _ ( ii2 eb ) ) . destruct ( hzneqchoice _ _ nea ) as [ ga | la ] . destruct ( hzneqchoice _ _ neb ) as [ gb | lb ] . destruct ( hzgthtoneq _ _ ( hzmultgth0gth0 ga gb ) e0 ) . destruct ( hzlthtoneq _ _ ( hzmultgth0lth0 ga lb ) e0 ) . destruct ( hzneqchoice _ _ neb ) as [ gb | lb ] . destruct ( hzlthtoneq _ _ ( hzmultlth0gth0 la gb ) e0 ) . destruct ( hzgthtoneq _ _ ( hzmultlth0lth0 la lb ) e0 ) . Defined . Definition hzintdom : intdom := tpair _ _ isintdomhz . Definition hzneq0andmult ( n m : hz ) ( isn : hzneq n 0 ) ( ism : hzneq m 0 ) : hzneq ( n * m ) 0 := intdomneq0andmult hzintdom n m isn ism . Lemma hzmultlcan ( a b c : hz ) ( ne : neg ( paths c 0 ) ) ( e : paths ( c * a ) ( c * b ) ) : paths a b . Proof . intros . apply ( intdomlcan hzintdom _ _ _ ne e ) . Defined . Lemma hzmultrcan ( a b c : hz ) ( ne : neg ( paths c 0 ) ) ( e : paths ( a * c ) ( b * c ) ) : paths a b . Proof . intros . apply ( intdomrcan hzintdom _ _ _ ne e ) . Defined . Lemma isinclhzmultl ( n : hz )( ne : neg ( paths n 0 ) ) : isincl ( fun m : hz => n * m ) . Proof. intros . apply ( pr1 ( intdomiscancelable hzintdom n ne ) ) . Defined . Lemma isinclhzmultr ( n : hz )( ne : neg ( paths n 0 ) ) : isincl ( fun m : hz => m * n ) . Proof. intros . apply ( pr2 ( intdomiscancelable hzintdom n ne ) ) . Defined. (** *** Comparisons and [ n -> n + 1 ] *) Definition hzgthtogths ( n m : hz ) : hzgth n m -> hzgth ( n + 1 ) m . Proof. intros n m is . apply ( istranshzgth _ _ _ ( hzgthsnn n ) is ) . Defined . Definition hzlthtolths ( n m : hz ) : hzlth n m -> hzlth n ( m + 1 ) := hzgthtogths _ _ . Definition hzlehtolehs ( n m : hz ) : hzleh n m -> hzleh n ( m + 1 ) . Proof . intros n m is . apply ( istranshzleh _ _ _ is ( hzlthtoleh _ _ ( hzlthnsn _ ) ) ) . Defined . Definition hzgehtogehs ( n m : hz ) : hzgeh n m -> hzgeh ( n + 1 ) m := hzlehtolehs _ _ . (** *** Two comparisons and [ n -> n + 1 ] *) Lemma hzgthtogehsn ( n m : hz ) : hzgth n m -> hzgeh n ( m + 1 ) . Proof. assert ( int : forall n m , isaprop ( hzgth n m -> hzgeh n ( m + 1 ) ) ) . intros . apply impred . intro . apply ( pr2 _ ) . unfold hzgth in * . apply ( setquotuniv2prop _ ( fun n m => hProppair _ ( int n m ) ) ) . set ( R := abgrfracrelint nataddabmonoid natgth ) . intros x x' . change ( R x x' -> ( neg ( R ( @op ( abmonoiddirprod (rigaddabmonoid natcommrig) (rigaddabmonoid natcommrig) ) x' ( dirprodpair 1%nat 0%nat ) ) x ) ) ) . unfold R . unfold abgrfracrelint . simpl . apply ( @hinhuniv _ (hProppair ( neg ( ishinh_UU _ ) ) ( isapropneg _ ) ) ) . intro t2 . simpl . unfold neg . apply ( @hinhuniv _ ( hProppair _ isapropempty ) ) . intro t2' . set ( x1 := pr1 x ) . set ( a1 := pr2 x ) . set ( x2 := pr1 x' ) . set ( a2 := pr2 x' ) . set ( c1 := pr1 t2 ) . set ( r1 := pr2 t2 ) . clearbody r1 . change ( pr1 ( natgth ( x1 + a2 + c1 ) ( x2 + a1 + c1 ) ) ) in r1 . set ( c2 := pr1 t2' ) . set ( r2 := pr2 t2' ) . clearbody r2 . change ( pr1 ( natgth ( ( x2 + 1 ) + a1 + c2 ) ( x1 + ( a2 + 0 ) + c2 ) ) ) in r2 . set ( r1' := natgthandplusrinv _ _ c1 r1 ) . set ( r2' := natgthandplusrinv _ _ c2 r2 ) . rewrite ( natplusr0 _ ) in r2' . rewrite ( natpluscomm _ 1 ) in r2' . rewrite ( natplusassoc _ _ _ ) in r2' . apply ( natgthtogehsn _ _ r1' r2' ) . Defined . Lemma hzgthsntogeh ( n m : hz ) : hzgth ( n + 1 ) m -> hzgeh n m . Proof. intros n m a . apply (hzgehandplusrinv n m 1) . apply ( hzgthtogehsn ( n + 1 ) m a ) . Defined. (* PeWa *) Lemma hzlehsntolth ( n m : hz ) : hzleh ( n + 1 ) m -> hzlth n m . Proof. intros n m X . apply ( hzlthlehtrans _ _ _ ( hzlthnsn n ) X ) . Defined . Lemma hzlthtolehsn ( n m : hz ) : hzlth n m -> hzleh ( n + 1 ) m . Proof. intros n m X . apply ( hzgthtogehsn m n X ) . Defined . Lemma hzlthsntoleh ( n m : hz ) : hzlth n ( m + 1 ) -> hzleh n m . Proof. intros n m a . apply (hzlehandplusrinv n m 1) . apply ( hzlthtolehsn n ( m + 1 ) a ) . Defined. (* PeWa *) Lemma hzgehsntogth ( n m : hz ) : hzgeh n ( m + 1 ) -> hzgth n m . Proof. intros n m X . apply ( hzlehsntolth m n X ) . Defined . (** *** Comparsion alternatives and [ n -> n + 1 ] *) Lemma hzlehchoice2 ( n m : hz ) : hzleh n m -> coprod ( hzleh ( n + 1 ) m ) ( paths n m ) . Proof . intros n m l . destruct ( hzlehchoice n m l ) as [ l' | e ] . apply ( ii1 ( hzlthtolehsn _ _ l' ) ) . apply ( ii2 e ) . Defined . Lemma hzgehchoice2 ( n m : hz ) : hzgeh n m -> coprod ( hzgeh n ( m + 1 ) ) ( paths n m ) . Proof . intros n m g . destruct ( hzgehchoice n m g ) as [ g' | e ] . apply ( ii1 ( hzgthtogehsn _ _ g' ) ) . apply ( ii2 e ) . Defined . Lemma hzgthchoice2 ( n m : hz ) : hzgth n m -> coprod ( hzgth n ( m + 1 ) ) ( paths n ( m + 1 ) ) . Proof. intros n m g . destruct ( hzgehchoice _ _ ( hzgthtogehsn _ _ g ) ) as [ g' | e ] . apply ( ii1 g' ) . apply ( ii2 e ) . Defined . Lemma hzlthchoice2 ( n m : hz ) : hzlth n m -> coprod ( hzlth ( n + 1 ) m ) ( paths ( n + 1 ) m ) . Proof. intros n m l . destruct ( hzlehchoice _ _ ( hzlthtolehsn _ _ l ) ) as [ l' | e ] . apply ( ii1 l' ) . apply ( ii2 e ) . Defined . (** *** Operations and comparisons on [ hz ] and [ natnattohz ] *) Lemma natnattohzandgth ( xa1 xa2 : dirprod nat nat ) ( is : hzgth ( setquotpr _ xa1 ) ( setquotpr _ xa2 ) ) : natgth ( ( pr1 xa1 ) + ( pr2 xa2 ) ) ( ( pr1 xa2 ) + ( pr2 xa1 ) ) . Proof . intros . change ( ishinh_UU ( total2 ( fun a0 => natgth (pr1 xa1 + pr2 xa2 + a0) (pr1 xa2 + pr2 xa1 + a0) ) ) ) in is . generalize is . apply @hinhuniv . intro t2 . set ( a0 := pr1 t2 ) . assert ( g := pr2 t2 ) . change ( pr1 ( natgth (pr1 xa1 + pr2 xa2 + a0) (pr1 xa2 + pr2 xa1 + a0) ) ) in g . apply ( natgthandplusrinv _ _ a0 g ) . Defined . Lemma natnattohzandlth ( xa1 xa2 : dirprod nat nat ) ( is : hzlth ( setquotpr _ xa1 ) ( setquotpr _ xa2 ) ) : natlth ( ( pr1 xa1 ) + ( pr2 xa2 ) ) ( ( pr1 xa2 ) + ( pr2 xa1 ) ) . Proof . intros . apply ( natnattohzandgth xa2 xa1 is ) . Defined . (** *** Canonical rig homomorphism from [ nat ] to [ hz ] *) Definition nattohz : nat -> hz := fun n => setquotpr _ ( dirprodpair n 0%nat ) . Definition isinclnattohz : isincl nattohz := isincltorngdiff natcommrig ( fun n => isinclnatplusr n ) . Definition nattohzandneq ( n m : nat ) ( is : natneq n m ) : hzneq ( nattohz n ) ( nattohz m ) := negf ( invmaponpathsincl _ isinclnattohz n m ) is . Definition nattohzand0 : paths ( nattohz 0%nat ) 0 := idpath _ . Definition nattohzandS ( n : nat ) : paths ( nattohz ( S n ) ) ( 1 + nattohz n ) := isbinop1funtorngdiff natcommrig 1%nat n . Definition nattohzand1 : paths ( nattohz 1%nat ) 1 := idpath _ . Definition nattohzandplus ( n m : nat ) : paths ( nattohz ( n + m )%nat ) ( nattohz n + nattohz m ) := isbinop1funtorngdiff natcommrig n m . Definition nattohzandminus ( n m : nat ) ( is : natgeh n m ) : paths ( nattohz ( n - m )%nat ) ( nattohz n - nattohz m ) . Proof . intros . apply ( hzplusrcan _ _ ( nattohz m ) ) . unfold hzminus . rewrite ( hzplusassoc ( nattohz n ) ( - nattohz m ) ( nattohz m ) ) . rewrite ( hzlminus _ ) . rewrite hzplusr0 . rewrite ( pathsinv0 ( nattohzandplus _ _ ) ) . rewrite ( minusplusnmm _ _ is ) . apply idpath . Defined . Opaque nattohzandminus . Definition nattohzandmult ( n m : nat ) : paths ( nattohz ( n * m )%nat ) ( nattohz n * nattohz m ) . Proof . intros . simpl . change nattohz with ( torngdiff natcommrig ) . apply ( isbinop2funtorngdiff natcommrig n m ) . Defined . Definition nattohzandgth ( n m : nat ) ( is : natgth n m ) : hzgth ( nattohz n ) ( nattohz m ) := iscomptorngdiff natcommrig isplushrelnatgth n m is . Definition nattohzandlth ( n m : nat ) ( is : natlth n m ) : hzlth ( nattohz n ) ( nattohz m ) := nattohzandgth m n is . Definition nattohzandleh ( n m : nat ) ( is : natleh n m ) : hzleh ( nattohz n ) ( nattohz m ) . Proof . intros . destruct ( natlehchoice _ _ is ) as [ l | e ] . apply ( hzlthtoleh _ _ ( nattohzandlth _ _ l ) ) . rewrite e . apply ( isreflhzleh ) . Defined . Definition nattohzandgeh ( n m : nat ) ( is : natgeh n m ) : hzgeh ( nattohz n ) ( nattohz m ) := nattohzandleh _ _ is . (** *** Addition and subtraction on [ nat ] and [ hz ] *) (** *** Absolute value on [ hz ] *) Definition hzabsvalint : ( dirprod nat nat ) -> nat . Proof . intro nm . destruct ( natgthorleh ( pr1 nm ) ( pr2 nm ) ) . apply ( minus ( pr1 nm ) ( pr2 nm ) ) . apply ( minus ( pr2 nm ) ( pr1 nm ) ) . Defined . Lemma hzabsvalintcomp : @iscomprelfun ( dirprod nat nat ) nat ( hrelabgrfrac nataddabmonoid ) hzabsvalint . Proof . unfold iscomprelfun . intros x x' . unfold hrelabgrfrac . simpl . apply ( @hinhuniv _ ( hProppair _ ( isasetnat (hzabsvalint x) (hzabsvalint x') ) ) ) . unfold hzabsvalint . set ( n := ( pr1 x ) : nat ) . set ( m := ( pr2 x ) : nat ) . set ( n' := ( pr1 x' ) : nat ) . set ( m' := ( pr2 x' ) : nat ) . set ( int := natgthorleh n m ) . set ( int' := natgthorleh n' m' ) . intro tt0 . simpl . destruct tt0 as [ x0 eq ] . simpl in eq . assert ( e' := invmaponpathsincl _ ( isinclnatplusr x0 ) _ _ eq ) . destruct int as [isgt | isle ] . destruct int' as [ isgt' | isle' ] . apply ( invmaponpathsincl _ ( isinclnatplusr ( m + m' ) ) ) . rewrite ( pathsinv0 ( natplusassoc ( n - m ) m m' ) ) . rewrite ( natpluscomm m m' ) . rewrite ( pathsinv0 ( natplusassoc ( n' - m' ) m' m ) ) . rewrite ( minusplusnmm n m ( natgthtogeh _ _ isgt ) ) . rewrite ( minusplusnmm n' m' ( natgthtogeh _ _ isgt' ) ) . apply e' . assert ( e'' := natlehandplusl n' m' n isle' ) . assert ( e''' := natgthandplusr n m n' isgt ) . assert ( e'''' := natlthlehtrans _ _ _ e''' e'' ) . rewrite e' in e'''' . rewrite ( natpluscomm m n' ) in e'''' . destruct ( isirreflnatgth _ e'''' ) . destruct int' as [ isgt' | isle' ] . destruct ( natpluscomm m n') . set ( e'' := natlehandplusr n m m' isle ) . set ( e''' := natgthandplusl n' m' m isgt' ) . set ( e'''' := natlehlthtrans _ _ _ e'' e''' ) . rewrite e' in e'''' . destruct ( isirreflnatgth _ e'''' ) . apply ( invmaponpathsincl _ ( isinclnatplusr ( n + n') ) ) . rewrite ( pathsinv0 ( natplusassoc ( m - n ) n n' ) ) . rewrite ( natpluscomm n n' ) . rewrite ( pathsinv0 ( natplusassoc ( m' - n') n' n ) ) . rewrite ( minusplusnmm m n isle ) . rewrite ( minusplusnmm m' n' isle' ) . rewrite ( natpluscomm m' n ) . rewrite ( natpluscomm m n' ) . apply ( pathsinv0 e' ) . Defined . Definition hzabsval : hz -> nat := setquotuniv _ natset hzabsvalint hzabsvalintcomp . Lemma hzabsval0 : paths ( hzabsval 0 ) 0%nat . Proof . apply idpath . Defined . Lemma hzabsvalgth0 { x : hz } ( is : hzgth x 0 ) : paths ( nattohz ( hzabsval x ) ) x . Proof . assert ( int : forall x : hz , isaprop ( hzgth x 0 -> paths ( nattohz ( hzabsval x ) ) x ) ) . intro . apply impred . intro . apply ( setproperty hz ) . apply ( setquotunivprop _ ( fun x => hProppair _ ( int x ) ) ) . intros xa g . simpl in xa . assert ( g' := natnattohzandgth _ _ g ) . simpl in g' . simpl . change ( paths ( setquotpr (eqrelabgrfrac (rigaddabmonoid natcommrig)) ( dirprodpair ( hzabsvalint xa ) 0%nat ) ) ( setquotpr (eqrelabgrfrac (rigaddabmonoid natcommrig)) xa ) ) . apply weqpathsinsetquot . simpl . apply hinhpr . split with 0%nat . change ( pr1 ( natgth ( pr1 xa + 0%nat ) ( pr2 xa ) ) ) in g' . rewrite ( natplusr0 _ ) in g' . change ( paths (hzabsvalint xa + pr2 xa + 0)%nat (pr1 xa + 0 + 0)%nat ) . rewrite ( natplusr0 _ ) . rewrite ( natplusr0 _ ) . rewrite ( natplusr0 _ ) . unfold hzabsvalint . destruct ( natgthorleh (pr1 xa) (pr2 xa) ) as [ g'' | l ] . rewrite ( minusplusnmm _ _ ( natlthtoleh _ _ g'' ) ) . apply idpath . destruct ( l g' ) . Defined . Opaque hzabsvalgth0 . Lemma hzabsvalgeh0 { x : hz } ( is : hzgeh x 0 ) : paths ( nattohz ( hzabsval x ) ) x . Proof . intros . destruct ( hzgehchoice _ _ is ) as [ g | e ] . apply ( hzabsvalgth0 g ) . rewrite e . apply idpath . Defined . Lemma hzabsvallth0 { x : hz } ( is : hzlth x 0 ) : paths ( nattohz ( hzabsval x ) ) ( - x ) . Proof . assert ( int : forall x : hz , isaprop ( hzlth x 0 -> paths ( nattohz ( hzabsval x ) ) ( - x ) ) ) . intro . apply impred . intro . apply ( setproperty hz ) . apply ( setquotunivprop _ ( fun x => hProppair _ ( int x ) ) ) . intros xa l . simpl in xa . assert ( l' := natnattohzandlth _ _ l ) . simpl in l' . simpl . change ( paths ( setquotpr (eqrelabgrfrac (rigaddabmonoid natcommrig)) ( dirprodpair ( hzabsvalint xa ) 0%nat ) ) ( setquotpr (eqrelabgrfrac (rigaddabmonoid natcommrig)) ( dirprodpair ( pr2 xa ) ( pr1 xa ) ) ) ) . apply weqpathsinsetquot . simpl . apply hinhpr . split with 0%nat . change ( pr1 ( natlth ( pr1 xa + 0%nat ) ( pr2 xa ) ) ) in l' . rewrite ( natplusr0 _ ) in l' . change ( paths (hzabsvalint xa + pr1 xa + 0)%nat (pr2 xa + 0 + 0)%nat ) . rewrite ( natplusr0 _ ) . rewrite ( natplusr0 _ ) . rewrite ( natplusr0 _ ) . unfold hzabsvalint . destruct ( natgthorleh (pr1 xa) (pr2 xa) ) as [ g | l'' ] . destruct ( isasymmnatgth _ _ g l' ) . rewrite ( minusplusnmm _ _ l'' ) . apply idpath . Defined . Opaque hzabsvallth0 . Lemma hzabsvalleh0 { x : hz } ( is : hzleh x 0 ) : paths ( nattohz ( hzabsval x ) ) ( - x ) . Proof . intros . destruct ( hzlehchoice _ _ is ) as [ l | e ] . apply ( hzabsvallth0 l ) . rewrite e . apply idpath . Defined . Lemma hzabsvaleq0 { x : hz } ( e : paths ( hzabsval x ) 0%nat ) : paths x 0 . Proof . intros . destruct ( isdeceqhz x 0 ) as [ e0 | ne0 ] . apply e0 . destruct ( hzneqchoice _ _ ne0 ) as [ g | l ] . assert ( e' := hzabsvalgth0 g ) . rewrite e in e' . change ( paths 0 x ) in e' . apply ( pathsinv0 e' ) . assert ( e' := hzabsvallth0 l ) . rewrite e in e' . change ( paths 0 ( - x ) ) in e' . assert ( g := hzlth0andminus l ) . rewrite e' in g . destruct ( isirreflhzgth _ g ) . Defined . Definition hzabsvalneq0 { x : hz } := negf ( @hzabsvaleq0 x ) . Lemma hzabsvalandmult ( a b : hz ) : paths ( ( hzabsval a ) * ( hzabsval b ) )%nat ( hzabsval ( a * b ) ) . Proof . intros . apply ( invmaponpathsincl _ isinclnattohz ) . rewrite ( nattohzandmult _ _ ) . destruct ( hzgthorleh a 0 ) as [ ga | lea ] . destruct ( hzgthorleh b 0 ) as [ gb | leb ] . rewrite ( hzabsvalgth0 ga ) . rewrite ( hzabsvalgth0 gb ) . rewrite ( hzabsvalgth0 ( hzmultgth0gth0 ga gb ) ) . apply idpath . rewrite ( hzabsvalgth0 ga ) . rewrite ( hzabsvalleh0 leb ) . rewrite ( hzabsvalleh0 ( hzmultgth0leh0 ga leb ) ) . apply ( rngrmultminus hz ) . destruct ( hzgthorleh b 0 ) as [ gb | leb ] . rewrite ( hzabsvalgth0 gb ) . rewrite ( hzabsvalleh0 lea ) . rewrite ( hzabsvalleh0 ( hzmultleh0gth0 lea gb ) ) . apply ( rnglmultminus hz ) . rewrite ( hzabsvalleh0 lea ) . rewrite ( hzabsvalleh0 leb ) . rewrite ( hzabsvalgeh0 ( hzmultleh0leh0 lea leb ) ) . apply (rngmultminusminus hz ) . Defined . Eval lazy in ( hzbooleq ( natnattohz 3 4 ) ( natnattohz 17 18 ) ) . Eval lazy in ( hzbooleq ( natnattohz 3 4 ) ( natnattohz 17 19 ) ) . Eval lazy in ( hzabsval ( natnattohz 58 332 ) ) . Eval lazy in ( hzabsval ( hzplus ( natnattohz 2 3 ) ( natnattohz 3 2 ) ) ) . Eval lazy in ( hzabsval ( hzminus ( natnattohz 2 3 ) ( natnattohz 3 2 ) ) ) . Eval lazy in ( hzabsval ( hzmult ( natnattohz 20 50 ) ( natnattohz 30 20 ) ) ) . (* End of the file hz.v *) Voevodsky-Coq/hlevel2/._stnfsets.v000777 000765 000024 00000000256 12346040720 020025 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel2/stnfsets.v000777 000765 000024 00000075644 12346040720 017625 0ustar00nicolastaff000000 000000 (** * Standard finite sets . Vladimir Voevodsky . Apr. - Sep. 2011 . This file contains main constructions related to the standard finite sets defined as the initial intervals of [ nat ] and their properties . *) (** ** Preambule *) (** Settings *) Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *) (** Imports. *) Add LoadPath ".." as Foundations. Require Export Foundations.hlevel2.hnat . (* To up-stream files *) (** ** Standard finite sets [ stn ] . *) Definition stn ( n : nat ) := total2 ( fun m : nat => natlth m n ) . Definition stnpair ( n : nat ) := tpair ( fun m : nat => natlth m n ) . Definition stntonat ( n : nat ) : stn n -> nat := @pr1 _ _ . Coercion stntonat : stn >-> nat . Notation " 'stnel' ( i , j ) " := ( stnpair _ _ ( ctlong natlth isdecrelnatlth j i ( idpath true ) ) ) ( at level 70 ) . Lemma isinclstntonat ( n : nat ) : isincl ( stntonat n ) . Proof. intro . apply isinclpr1 . intro x . apply ( pr2 ( natlth x n ) ) . Defined. Lemma isdecinclstntonat ( n : nat ) : isdecincl ( stntonat n ) . Proof. intro . apply isdecinclpr1 . intro x . apply isdecpropif . apply ( pr2 _ ) . apply isdecrelnatgth . Defined . Lemma neghfiberstntonat ( n m : nat ) ( is : natgeh m n ) : neg ( hfiber ( stntonat n ) m ) . Proof. intros . intro h . destruct h as [ j e ] . destruct j as [ j is' ] . simpl in e . rewrite e in is' . apply ( natgehtonegnatlth _ _ is is' ) . Defined . Lemma iscontrhfiberstntonat ( n m : nat ) ( is : natlth m n ) : iscontr ( hfiber ( stntonat n ) m ) . Proof. intros . apply ( iscontrhfiberofincl ( stntonat n ) ( isinclstntonat n ) ( stnpair n m is ) ) . Defined . Lemma isisolatedinstn { n : nat } ( x : stn n ) : isisolated _ x. Proof. intros . apply ( isisolatedinclb ( stntonat n ) ( isinclstntonat n ) x ( isisolatedn x ) ) . Defined. Corollary isdeceqstn ( n : nat ) : isdeceq (stn n). Proof. intro. unfold isdeceq. intros x x' . apply (isisolatedinstn x x' ). Defined. Definition weqisolatedstntostn ( n : nat ) : weq ( isolated ( stn n ) ) ( stn n ) . Proof . intro . apply weqpr1 . intro x . apply iscontraprop1 . apply ( isapropisisolated ) . set ( int := isdeceqstn n x ) . assumption . Defined . Corollary isasetstn ( n : nat ) : isaset ( stn n ) . Proof. intro . apply ( isasetifdeceq _ ( isdeceqstn n ) ) . Defined . Definition stnposet ( i : nat ) : Poset . Proof. intro. unfold Poset . split with ( hSetpair ( stn i ) ( isasetstn i ) ) . unfold po. split with ( fun j1 j2 : stn i => natleh j1 j2 ) . split with ( fun j1 j2 j3 : stn i => istransnatleh j1 j2 j3 ) . exact ( fun j : stn i => isreflnatleh j ) . Defined. Definition lastelement ( n : nat ) : stn ( S n ) . Proof. intro . split with n . apply ( natgthsnn ( S n ) ) . Defined . Definition stnmtostnn ( m n : nat ) (isnatleh: natleh m n ) : stn m -> stn n := fun x : stn m => match x with tpair i is => stnpair _ i ( natlthlehtrans i m n is isnatleh ) end . (** ** "Boundary" maps [ dni : stn n -> stn ( S n ) ] and their properties . *) Definition dni ( n : nat ) ( i : stn ( S n ) ) : stn n -> stn ( S n ) . Proof. intros n i x . destruct ( natlthorgeh x i ) . apply ( stnpair ( S n ) x ( natgthtogths _ _ ( pr2 x ) ) ) . apply ( stnpair ( S n ) ( S x ) ( pr2 x ) ) . Defined. Lemma dnicommsq ( n : nat ) ( i : stn ( S n ) ) : commsqstr ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni n i ) . Proof. intros . intro x . unfold dni . unfold di . destruct ( natlthorgeh x i ) . simpl . apply idpath . simpl . apply idpath . Defined . Theorem dnihfsq ( n : nat ) ( i : stn ( S n ) ) : hfsqstr ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni n i ) . Proof. intros . apply ( ishfsqweqhfibersgtof' ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni n i ) ( dnicommsq _ _ ) ) . intro x . destruct ( natlthorgeh x n ) as [ g | l ] . assert ( is1 : iscontr ( hfiber ( stntonat n ) x ) ) . apply iscontrhfiberstntonat . assumption . assert ( is2 : iscontr ( hfiber ( stntonat ( S n ) ) ( di i x ) ) ) . apply iscontrhfiberstntonat . apply ( natlehlthtrans _ ( S x ) ( S n ) ( natlehdinsn i x ) g ) . apply isweqcontrcontr . assumption . assumption . assert ( is1 : neg ( hfiber ( stntonat ( S n ) ) ( di i x ) ) ) . apply neghfiberstntonat . unfold di . destruct ( natlthorgeh x i ) as [ l'' | g' ] . destruct ( natgehchoice2 _ _ l ) as [ g' | e ] . apply g' . rewrite e in l'' . set ( int := natlthtolehsn _ _ l'' ) . destruct ( int ( pr2 i ) ) . apply l . apply ( isweqtoempty2 _ is1 ) . Defined . Lemma weqhfiberdnihfiberdi ( n : nat ) ( i j : stn ( S n ) ) : weq ( hfiber ( dni n i ) j ) ( hfiber ( di i ) j ) . Proof. intros . apply ( weqhfibersg'tof _ _ _ _ ( dnihfsq n i ) j ) . Defined . Lemma neghfiberdni ( n : nat ) ( i : stn ( S n ) ) : neg ( hfiber ( dni n i ) i ) . Proof. intros . apply ( negf ( weqhfiberdnihfiberdi n i i ) ( neghfiberdi i ) ) . Defined . Lemma iscontrhfiberdni ( n : nat ) ( i j : stn ( S n ) ) ( ne : neg ( paths i j ) ) : iscontr ( hfiber ( dni n i ) j ) . Proof . intros . set ( ne' := negf ( invmaponpathsincl _ ( isinclstntonat ( S n ) ) _ _ ) ne ) . apply ( iscontrweqb ( weqhfiberdnihfiberdi n i j ) ( iscontrhfiberdi i j ne' ) ) . Defined . Lemma isdecincldni ( n : nat ) ( i : stn ( S n ) ) : isdecincl ( dni n i ) . Proof. intros . intro j . destruct ( isdeceqstn _ i j ) . rewrite i0 . apply ( isdecpropfromneg ( neghfiberdni n j ) ) . apply ( isdecpropfromiscontr ( iscontrhfiberdni _ _ _ e ) ) . Defined . Lemma isincldni ( n : nat ) ( i : stn ( S n ) ) : isincl ( dni n i ) . Proof. intros . apply ( isdecincltoisincl _ ( isdecincldni n i ) ) . Defined . (** ** Weak equivalences between standard finite sets and constructions on these sets *) (** *** The weak equivalence from [ stn n ] to the compl of a point [ j ] in [ stn ( S n ) ] defined by [ dni n j ] *) Definition dnitocompl ( n : nat ) ( i : stn ( S n ) ) ( j : stn n ) : compl ( stn ( S n ) ) i . Proof. intros . split with ( dni n i j ) . intro e . apply ( neghfiberdni n i ( hfiberpair _ j ( pathsinv0 e ) ) ) . Defined . Lemma isweqdnitocompl ( n : nat ) ( i : stn ( S n ) ) : isweq ( dnitocompl n i ) . Proof. intros . intro jni . destruct jni as [ j ni ] . set ( jni := complpair _ i j ni ) . destruct ( isdeceqnat i j ) . destruct ( ni ( invmaponpathsincl _ ( isinclstntonat _ ) _ _ i0 ) ) . set ( w := samehfibers ( dnitocompl n i ) _ ( isinclpr1compl _ i ) jni ) . simpl in w . assert ( is : iscontr (hfiber (fun x : stn n => dni n i x) j) ) . apply iscontrhfiberdni . assumption . apply ( iscontrweqb w is ) . Defined . Definition weqdnicompl ( n : nat ) ( i : stn ( S n ) ) := weqpair _ ( isweqdnitocompl n i ) . (** *** Weak equivalence from [ coprod ( stn n ) unit ] to [ stn ( S n ) ] defined by [ dni n i ] *) Definition weqdnicoprod ( n : nat ) ( j : stn ( S n ) ) : weq ( coprod ( stn n ) unit ) ( stn ( S n ) ) . Proof . intros . apply ( weqcomp ( weqcoprodf ( weqdnicompl n j ) ( idweq unit ) ) ( weqrecompl ( stn ( S n ) ) j ( isdeceqstn ( S n ) j ) ) ) . Defined . (** *** Weak equivalences from [ stn n ] for [ n = 0 , 1 , 2 ] to [ empty ] , [ unit ] and [ bool ] ( see also the section on [ nelstruct ] in finitesets.v ) . *) Definition negstn0 : neg ( stn 0 ) . Proof . intro x . destruct x as [ a b ] . apply ( negnatlthn0 _ b ) . Defined . Definition weqstn0toempty : weq ( stn 0 ) empty . Proof . apply weqtoempty . apply negstn0 . Defined . Definition weqstn1tounit : weq ( stn 1 ) unit . Proof. set ( f := fun x : stn 1 => tt ) . apply weqcontrcontr . split with ( lastelement 0 ) . intro t . destruct t as [ t l ] . set ( e := natlth1tois0 _ l ) . apply ( invmaponpathsincl _ ( isinclstntonat 1 ) ( stnpair _ t l ) ( lastelement 0 ) e ) . apply iscontrunit . Defined . Corollary iscontrstn1 : iscontr ( stn 1 ) . Proof. apply iscontrifweqtounit . apply weqstn1tounit . Defined . Lemma isinclfromstn1 { X : UU } ( f : stn 1 -> X ) ( is : isaset X ) : isincl f . Proof. intros . apply ( isinclbetweensets f ( isasetstn 1 ) is ) . intros x x' e . apply ( invmaponpathsweq weqstn1tounit x x' ( idpath tt ) ) . Defined . Definition weqstn2tobool : weq ( stn 2 ) bool . Proof. set ( f := fun j : stn 2 => match ( isdeceqnat j 0 ) with ii1 _ => false | ii2 _ => true end ) . set ( g := fun b : bool => match b with false => stnpair 2 0 ( idpath true ) | true => stnpair 2 1 ( idpath true ) end ) . split with f . assert ( egf : forall j : _ , paths ( g ( f j ) ) j ) . intro j . unfold f . destruct ( isdeceqnat j 0 ) as [ e | ne ] . apply ( invmaponpathsincl _ ( isinclstntonat 2 ) ) . rewrite e . apply idpath . apply ( invmaponpathsincl _ ( isinclstntonat 2 ) ) . destruct j as [ j l ] . simpl . set ( l' := natlthtolehsn _ _ l ) . destruct ( natlehchoice _ _ l' ) as [ l'' | e ] . simpl in ne . destruct ( ne ( natlth1tois0 _ l'' ) ) . apply ( pathsinv0 ( invmaponpathsS _ _ e ) ) . assert ( efg : forall b : _ , paths ( f ( g b ) ) b ) . intro b . unfold g . destruct b . apply idpath . apply idpath. apply ( gradth _ _ egf efg ) . Defined . (** *** Weak equivalence between the coproduct of [ stn n ] and [ stn m ] and [ stn ( n + m ) ] *) Theorem weqfromcoprodofstn ( n m : nat ) : weq ( coprod ( stn n ) ( stn m ) ) ( stn ( n + m ) ) . Proof. intros . assert ( i1 : forall i : nat , natlth i n -> natlth i ( n + m ) ) . intros i1 l . apply ( natlthlehtrans _ _ _ l ( natlehnplusnm n m ) ) . assert ( i2 : forall i : nat , natlth i m -> natlth ( i + n ) ( n + m ) ) . intros i2 l . rewrite ( natpluscomm i2 n ) . apply natgthandplusl . assumption . set ( f := fun ab : coprod ( stn n ) ( stn m ) => match ab with ii1 a => stnpair ( n + m ) a ( i1 a ( pr2 a ) ) | ii2 b => stnpair ( n + m ) ( b + n ) ( i2 b ( pr2 b ) ) end ) . split with f . assert ( is : isincl f ) . apply isinclbetweensets . apply ( isofhlevelssncoprod 0 _ _ ( isasetstn n ) ( isasetstn m ) ) . apply ( isasetstn ( n + m ) ) . intros x x' . intro e . destruct x as [ xn | xm ] . destruct x' as [ xn' | xm' ] . apply ( maponpaths (@ii1 _ _ ) ) . apply ( invmaponpathsincl _ ( isinclstntonat n ) _ _ ) . destruct xn as [ x ex ] . destruct xn' as [ x' ex' ] . simpl in e . simpl . apply ( maponpaths ( stntonat ( n + m ) ) e ) . destruct xn as [ x ex ] . destruct xm' as [ x' ex' ] . simpl in e . assert ( l : natleh n x ) . set ( e' := maponpaths ( stntonat _ ) e ) . simpl in e' . rewrite e' . apply ( natlehmplusnm x' n ) . destruct ( natlehtonegnatgth _ _ l ex ) . destruct x' as [ xn' | xm' ] . destruct xm as [ x ex ] . destruct xn' as [ x' ex' ] . simpl in e . assert ( e' := maponpaths ( stntonat _ ) e ) . simpl in e' . assert ( a : empty ) . clear e . rewrite ( pathsinv0 e' ) in ex' . apply ( negnatgthmplusnm _ _ ex' ) . destruct a . destruct xm as [ x ex ] . destruct xm' as [ x' ex' ] . simpl in e . apply ( maponpaths ( @ii2 _ _ ) ) . simpl . apply ( invmaponpathsincl _ ( isinclstntonat m ) _ _ ) . simpl . apply ( invmaponpathsincl _ ( isinclnatplusr n ) _ _ ( maponpaths ( stntonat _ ) e ) ) . intro jl . apply iscontraprop1 . apply ( is jl ) . destruct jl as [ j l ] . destruct ( natgthorleh n j ) as [ i | ni ] . split with ( ii1 ( stnpair _ j i ) ) . simpl . apply ( invmaponpathsincl _ ( isinclstntonat ( n + m ) ) (stnpair (n + m) j (i1 j i)) ( stnpair _ j l ) ( idpath j ) ) . set ( jmn := pr1 ( iscontrhfibernatplusr n j ni ) ) . destruct jmn as [ k e ] . assert ( is'' : natlth k m ) . rewrite ( pathsinv0 e ) in l . rewrite ( natpluscomm k n ) in l . apply ( natgthandpluslinv _ _ _ l ) . split with ( ii2 ( stnpair _ k is'' ) ) . simpl . apply ( invmaponpathsincl _ ( isinclstntonat _ ) (stnpair _ (k + n) (i2 k is'')) ( stnpair _ j l ) e ) . Defined . (** *** Weak equivalence from the total space of a family [ stn ( f x ) ] over [ stn n ] to [ stn ( stnsum n f ) ] *) Definition stnsum { n : nat } ( f : stn n -> nat ) : nat . Proof. intro n . induction n as [ | n IHn ] . intro. apply 0 . intro f . apply ( ( IHn ( fun i : stn n => f ( dni n ( lastelement n ) i ) ) ) + f ( lastelement n ) ) . Defined . Theorem weqstnsum { n : nat } ( P : stn n -> UU ) ( f : stn n -> nat ) ( ww : forall i : stn n , weq ( stn ( f i ) ) ( P i ) ) : weq ( total2 P ) ( stn ( stnsum f ) ) . Proof . intro n . induction n as [ | n IHn ] . intros . simpl . apply weqtoempty2 . apply ( @pr1 _ _ ) . apply negstn0 . intros . simpl . set ( a := stnsum (fun i : stn n => f (dni n (lastelement n) i)) ) . set ( b := f (lastelement n) ) . set ( w1 := invweq ( weqfp ( weqdnicoprod n ( lastelement n ) ) P ) ) . set ( w2 := weqcomp w1 ( weqtotal2overcoprod (fun x : coprod (stn n) unit => P ( weqdnicoprod n ( lastelement n ) x)) ) ) . simpl in w2 . assert ( w3 : weq (total2 (fun x : stn n => P (dni n (lastelement n) x))) ( stn a ) ) . assert ( int : forall x : stn n , weq ( stn ( f ( dni n (lastelement n) x) ) ) ( P (dni n (lastelement n) x) ) ) . intro x . apply ( ww ( dni n (lastelement n) x) ) . apply ( IHn ( fun x : stn n => P (dni n (lastelement n) x)) ( fun x : stn n => f ( dni n (lastelement n) x ) ) int ) . assert ( w4 : weq (total2 (fun _ : unit => P (lastelement n))) ( stn b) ) . apply ( weqcomp ( weqtotal2overunit (fun _ : unit => P (lastelement n)) ) ( invweq ( ww ( lastelement n ) ) ) ) . apply ( weqcomp w2 ( weqcomp ( weqcoprodf w3 w4 ) ( weqfromcoprodofstn a b ) ) ) . Defined . Corollary weqstnsum2 { X : UU } ( n : nat ) ( f : stn n -> nat ) ( g : X -> stn n ) ( ww : forall i : stn n , weq ( stn ( f i ) ) ( hfiber g i ) ) : weq X ( stn ( stnsum f ) ) . Proof. intros . assert ( w : weq X ( total2 ( fun i : stn n => hfiber g i ) ) ) . apply weqtococonusf . apply ( weqcomp w ( weqstnsum ( fun i : stn n => hfiber g i ) f ww ) ) . Defined . (** *** Weak equivalence between the direct product of [ stn n ] and [ stn m ] and [ stn n * m ] *) Theorem weqfromprodofstn ( n m : nat ) : weq ( dirprod ( stn n ) ( stn m ) ) ( stn ( n * m ) ) . Proof . intros . destruct ( natgthorleh m 0 ) as [ is | i ] . assert ( i1 : forall i j : nat , natlth i n -> natlth j m -> natlth ( j + i * m ) ( n * m ) ). intros i j li lj . apply ( natlthlehtrans ( j + i * m ) ( ( S i ) * m ) ( n * m ) ( natgthandplusr m j ( i * m ) lj ) ( natlehandmultr ( S i ) n m ( natgthtogehsn _ _ li ) ) ) . set ( f := fun ij : dirprod ( stn n ) ( stn m ) => match ij with tpair i j => stnpair ( n * m ) ( j + i * m ) ( i1 i j ( pr2 i ) ( pr2 j ) ) end ) . split with f . assert ( isinf : isincl f ) . apply isinclbetweensets . apply ( isofhleveldirprod 2 _ _ ( isasetstn n ) ( isasetstn m ) ) . apply ( isasetstn ( n * m ) ) . intros ij ij' e . destruct ij as [ i j ] . destruct ij' as [ i' j' ] . destruct i as [ i li ] . destruct i' as [ i' li' ] . destruct j as [ j lj ] . destruct j' as [ j' lj' ] . simpl in e . assert ( e' := maponpaths ( stntonat ( n * m ) ) e ) . simpl in e' . assert ( eei : paths i i' ) . apply ( pr1 ( natdivremunique m i j i' j' lj lj' ( maponpaths ( stntonat _ ) e ) ) ) . set ( eeis := invmaponpathsincl _ ( isinclstntonat _ ) ( stnpair _ i li ) ( stnpair _ i' li' ) eei ) . assert ( eej : paths j j' ) . apply ( pr2 ( natdivremunique m i j i' j' lj lj' ( maponpaths ( stntonat _ ) e ) ) ) . set ( eejs := invmaponpathsincl _ ( isinclstntonat _ ) ( stnpair _ j lj ) ( stnpair _ j' lj' ) eej ) . apply ( pathsdirprod eeis eejs ) . intro xnm . apply iscontraprop1 . apply ( isinf xnm ) . set ( e := pathsinv0 ( natdivremrule xnm m ( natgthtoneq _ _ is ) ) ) . set ( i := natdiv xnm m ) . set ( j := natrem xnm m ) . destruct xnm as [ xnm lxnm ] . set ( li := natlthandmultrinv _ _ _ ( natlehlthtrans _ _ _ ( natlehmultnatdiv xnm m ( natgthtoneq _ _ is ) ) lxnm ) ) . set ( lj := lthnatrem xnm m ( natgthtoneq _ _ is ) ) . split with ( dirprodpair ( stnpair n i li ) ( stnpair m j lj ) ) . simpl . apply ( invmaponpathsincl _ ( isinclstntonat _ ) _ _ ) . simpl . apply e . set ( e := natleh0tois0 _ i ) . rewrite e . rewrite ( natmultn0 n ) . split with ( @pr2 _ _ ) . apply ( isweqtoempty2 _ ( weqstn0toempty ) ) . Defined . (** *** Weak equivalences between decidable subsets of [ stn n ] and [ stn x ] *) Theorem weqfromdecsubsetofstn { n : nat } ( f : stn n -> bool ) : total2 ( fun x : nat => weq ( hfiber f true ) ( stn x ) ) . Proof . intro . induction n as [ | n IHn ] . intros . split with 0 . assert ( g : ( hfiber f true ) -> ( stn 0 ) ) . intro hf . destruct hf as [ i e ] . destruct ( weqstn0toempty i ) . apply ( weqtoempty2 g weqstn0toempty ) . intro . set ( g := weqfromcoprodofstn 1 n ) . change ( 1 + n ) with ( S n ) in g . set ( fl := fun i : stn 1 => f ( g ( ii1 i ) ) ) . set ( fh := fun i : stn n => f ( g ( ii2 i ) ) ) . assert ( w : weq ( hfiber f true ) ( hfiber ( sumofmaps fl fh ) true ) ) . set ( int := invweq ( weqhfibersgwtog g f true ) ) . assert ( h : forall x : _ , paths ( f ( g x ) ) ( sumofmaps fl fh x ) ) . intro . destruct x as [ x1 | xn ] . apply idpath . apply idpath . apply ( weqcomp int ( weqhfibershomot _ _ h true ) ) . set ( w' := weqcomp w ( invweq ( weqhfibersofsumofmaps fl fh true ) ) ) . set ( x0 := pr1 ( IHn fh ) ) . set ( w0 := pr2 ( IHn fh ) ) . simpl in w0 . destruct ( boolchoice ( fl ( lastelement 0 ) ) ) as [ i | ni ] . split with ( S x0 ) . assert ( wi : weq ( hfiber fl true ) ( stn 1 ) ) . assert ( is : iscontr ( hfiber fl true ) ) . apply iscontraprop1 . apply ( isinclfromstn1 fl isasetbool true ) . apply ( hfiberpair _ ( lastelement 0 ) i ) . apply ( weqcontrcontr is iscontrstn1 ) . apply ( weqcomp ( weqcomp w' ( weqcoprodf wi w0 ) ) ( weqfromcoprodofstn 1 _ ) ) . split with x0 . assert ( g' : neg ( hfiber fl true ) ) . intro hf . destruct hf as [ j e ] . assert ( ee : paths j ( lastelement 0 ) ) . apply ( proofirrelevance _ ( isapropifcontr iscontrstn1 ) _ _ ) . destruct ( nopathstruetofalse ( pathscomp0 ( pathscomp0 ( pathsinv0 e ) ( maponpaths fl ee ) ) ni ) ) . apply ( weqcomp w' ( weqcomp ( invweq ( weqii2withneg _ g' ) ) w0 ) ) . Defined . (** *** Weak equivalences between hfibers of functions from [ stn n ] over isolated points and [ stn x ] *) Theorem weqfromhfiberfromstn { n : nat } { X : UU } ( x : X ) ( is : isisolated X x ) ( f : stn n -> X ) : total2 ( fun x0 : nat => weq ( hfiber f x ) ( stn x0 ) ) . Proof . intros . set ( t := weqfromdecsubsetofstn ( fun i : _ => eqbx X x is ( f i ) ) ) . split with ( pr1 t ) . apply ( weqcomp ( weqhfibertobhfiber f x is ) ( pr2 t ) ) . Defined . (** *** Weak equivalence between [ stn n -> stn m ] and [ stn ( natpower m n ) ] ( uses functional extensionality ) *) Theorem weqfromfunstntostn ( n m : nat ) : weq ( stn n -> stn m ) ( stn ( natpower m n ) ) . Proof. intro n . induction n as [ | n IHn ] . intro m . apply weqcontrcontr . apply ( iscontrfunfromempty2 _ weqstn0toempty ) . apply iscontrstn1 . intro m . set ( w1 := weqfromcoprodofstn 1 n ) . assert ( w2 : weq ( stn ( S n ) -> stn m ) ( (coprod (stn 1) (stn n)) -> stn m ) ) . apply ( weqbfun _ w1 ) . set ( w3 := weqcomp w2 ( weqfunfromcoprodtoprod ( stn 1 ) ( stn n ) ( stn m ) ) ) . set ( w4 := weqcomp w3 ( weqdirprodf ( weqfunfromcontr ( stn m ) iscontrstn1 ) ( IHn m ) ) ) . apply ( weqcomp w4 ( weqfromprodofstn m ( natpower m n ) ) ) . Defined . (** *** Weak equivalence from the space of functions of a family [ stn ( f x ) ] over [ stn n ] to [ stn ( stnprod n f ) ] ( uses functional extensionality ) *) Definition stnprod { n : nat } ( f : stn n -> nat ) : nat . Proof. intro n . induction n as [ | n IHn ] . intro. apply 1 . intro f . apply ( ( IHn ( fun i : stn n => f ( dni n ( lastelement n ) i ) ) ) * f ( lastelement n ) ) . Defined . Theorem weqstnprod { n : nat } ( P : stn n -> UU ) ( f : stn n -> nat ) ( ww : forall i : stn n , weq ( stn ( f i ) ) ( P i ) ) : weq ( forall x : stn n , P x ) ( stn ( stnprod f ) ) . Proof . intro n . induction n as [ | n IHn ] . intros . simpl . apply ( weqcontrcontr ) . apply ( iscontrsecoverempty2 _ ( negstn0 ) ) . apply iscontrstn1 . intros . set ( w1 := weqdnicoprod n ( lastelement n ) ) . set ( w2 := weqonsecbase P w1 ) . set ( w3 := weqsecovercoprodtoprod ( fun x : _ => P ( w1 x ) ) ) . set ( w4 := weqcomp w2 w3 ) . set ( w5 := IHn ( fun x : stn n => P ( w1 ( ii1 x ) ) ) ( fun x : stn n => f ( w1 ( ii1 x ) ) ) ( fun i : stn n => ww ( w1 ( ii1 i ) ) ) ) . set ( w6 := weqcomp w4 ( weqdirprodf w5 ( weqsecoverunit _ ) ) ) . simpl in w6 . set ( w7 := weqcomp w6 ( weqdirprodf ( idweq _ ) ( invweq ( ww ( lastelement n ) ) ) ) ) . apply ( weqcomp w7 ( weqfromprodofstn _ _ ) ) . Defined . (** *** Weak equivalence between [ weq ( stn n ) ( stn n ) ] and [ stn ( factorial n ) ] ( uses functional extensionality ) *) Theorem weqweqstnsn ( n : nat ) : weq ( weq ( stn ( S n ) ) ( stn ( S n ) ) ) ( dirprod ( stn ( S n ) ) ( weq ( stn n ) ( stn n ) ) ) . Proof . intro . set ( nn := lastelement n ) . set ( is := isdeceqstn _ nn ) . set ( w1 := weqcutonweq ( stn ( S n ) ) nn is ) . set ( w2 := weqisolatedstntostn ( S n ) ) . set ( w3 := invweq ( weqdnicompl n nn ) ) . apply ( weqcomp w1 ( weqdirprodf w2 ( weqcomp ( weqbweq _ ( invweq w3 )) ( weqfweq _ w3 ) ) ) ) . Defined . Theorem weqfromweqstntostn ( n : nat ) : weq ( weq ( stn n ) ( stn n ) ) ( stn ( factorial n ) ) . Proof . intro . induction n as [ | n IHn ] . simpl . apply ( weqcontrcontr ) . apply ( iscontraprop1 ) . apply ( isapropweqtoempty2 _ ( negstn0 ) ) . apply idweq . apply iscontrstn1 . change ( factorial ( S n ) ) with ( ( S n ) * ( factorial n ) ) . set ( w1 := weqweqstnsn n ) . apply ( weqcomp w1 ( weqcomp ( weqdirprodf ( idweq _ ) IHn ) ( weqfromprodofstn _ _ ) ) ) . Defined . (* End of " weak equivalences between standard finite sets and constructions on these sets " . *) (** ** Standard finite sets satisfy weak axiom of choice *) Theorem ischoicebasestn ( n : nat ) : ischoicebase ( stn n ) . Proof . intro . induction n as [ | n IHn ] . apply ( ischoicebaseempty2 negstn0 ) . apply ( ischoicebaseweqf ( weqdnicoprod n ( lastelement n ) ) ( ischoicebasecoprod IHn ischoicebaseunit ) ) . Defined . (** ** Weak equivalence class of [ stn n ] determines [ n ] . *) Lemma negweqstnsn0 (n:nat): neg (weq (stn (S n)) (stn O)). Proof. unfold neg. intro. assert (lp: stn (S n)). apply lastelement. intro X. apply weqstn0toempty . apply (pr1 X lp). Defined. Lemma negweqstn0sn (n:nat): neg (weq (stn O) (stn (S n))). Proof. unfold neg. intro. assert (lp: stn (S n)). apply lastelement. intro X. apply weqstn0toempty . apply (pr1 ( invweq X ) lp). Defined. Lemma weqcutforstn ( n n' : nat ) ( w : weq (stn (S n)) (stn (S n')) ) : weq (stn n) (stn n'). Proof. intros. set ( nn := lastelement n ) . set ( w1 := weqoncompl w nn ) . set ( w2 := weqdnicompl n nn ) . set ( w3 := weqdnicompl n' ( w nn ) ) . apply ( weqcomp w2 ( weqcomp w1 ( invweq w3 ) ) ) . Defined . Theorem weqtoeqstn ( n n' : nat ) ( w : weq (stn n) (stn n') ) : paths n n'. Proof. intro. induction n as [ | n IHn ] . intro. destruct n' as [ | n' ] . intros. apply idpath. intro X. apply (fromempty (negweqstn0sn n' X)). intro n'. destruct n' as [ | n' ] . intro X. set (int:= isdeceqnat (S n) 0 ). destruct int as [ i | e ] . assumption. apply (fromempty ( negweqstnsn0 n X)). intro X. set (e:= IHn n' ( weqcutforstn _ _ X)). apply (maponpaths S e). Defined. Corollary stnsdnegweqtoeq ( n n' : nat ) ( dw : dneg (weq (stn n) (stn n')) ) : paths n n'. Proof. intros n n' X. apply (eqfromdnegeq nat isdeceqnat _ _ (dnegf (@weqtoeqstn n n') X)). Defined. (** ** Some results on bounded quantification *) Lemma weqforallnatlehn0 ( F : nat -> hProp ) : weq ( forall n : nat , natleh n 0 -> F n ) ( F 0 ) . Proof . intros . assert ( lg : ( forall n : nat , natleh n 0 -> F n ) <-> ( F 0 ) ) . split . intro f . apply ( f 0 ( isreflnatleh 0 ) ) . intros f0 n l . set ( e := natleh0tois0 _ l ) . rewrite e . apply f0 . assert ( is1 : isaprop ( forall n : nat , natleh n 0 -> F n ) ) . apply impred . intro n . apply impred . intro l . apply ( pr2 ( F n ) ) . apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) is1 ( pr2 ( F 0 ) ) ) . Defined . Lemma weqforallnatlehnsn' ( n' : nat ) ( F : nat -> hProp ) : weq ( forall n : nat , natleh n ( S n' ) -> F n ) ( dirprod ( forall n : nat , natleh n n' -> F n ) ( F ( S n' ) ) ) . Proof . intros . assert ( lg : ( forall n : nat , natleh n ( S n' ) -> F n ) <-> dirprod ( forall n : nat , natleh n n' -> F n ) ( F ( S n' ) ) ) . split . intro f. apply ( dirprodpair ( fun n => fun l => ( f n ( natlehtolehs _ _ l ) ) ) ( f ( S n' ) ( isreflnatleh _ ) ) ) . intro d2 . intro n . intro l . destruct ( natlehchoice2 _ _ l ) as [ h | e ] . simpl in h . apply ( pr1 d2 n h ) . destruct d2 as [ f2 d2 ] . rewrite e . apply d2 . assert ( is1 : isaprop ( forall n : nat , natleh n ( S n' ) -> F n ) ) . apply impred . intro n . apply impred . intro l . apply ( pr2 ( F n ) ) . assert ( is2 : isaprop ( dirprod ( forall n : nat , natleh n n' -> F n ) ( F ( S n' ) ) ) ) . apply isapropdirprod . apply impred . intro n . apply impred . intro l . apply ( pr2 ( F n ) ) . apply ( pr2 ( F ( S n' ) ) ) . apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) is1 is2 ) . Defined . Lemma weqexistsnatlehn0 ( P : nat -> hProp ) : weq ( hexists ( fun n : nat => dirprod ( natleh n 0 ) ( P n ) ) ) ( P 0 ) . Proof . intro . assert ( lg : hexists ( fun n : nat => dirprod ( natleh n 0 ) ( P n ) ) <-> P 0 ) . split . simpl . apply ( @hinhuniv _ ( P 0 ) ) . intro t2 . destruct t2 as [ n d2 ] . destruct d2 as [ l p ] . set ( e := natleh0tois0 _ l ) . clearbody e . destruct e . apply p . intro p . apply hinhpr . split with 0 . split with ( isreflnatleh 0 ) . apply p . apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( pr2 _ ) ( pr2 _ ) ) . Defined . Lemma weqexistsnatlehnsn' ( n' : nat ) ( P : nat -> hProp ) : weq ( hexists ( fun n : nat => dirprod ( natleh n ( S n' ) ) ( P n ) ) ) ( hdisj ( hexists ( fun n : nat => dirprod ( natleh n n' ) ( P n ) ) ) ( P ( S n' ) ) ) . Proof . intros . assert ( lg : hexists ( fun n : nat => dirprod ( natleh n ( S n' ) ) ( P n ) ) <-> hdisj ( hexists ( fun n : nat => dirprod ( natleh n n' ) ( P n ) ) ) ( P ( S n' ) ) ) . split . simpl . apply hinhfun . intro t2 . destruct t2 as [ n d2 ] . destruct d2 as [ l p ] . destruct ( natlehchoice2 _ _ l ) as [ h | nh ] . simpl in h . apply ii1 . apply hinhpr . split with n . apply ( dirprodpair h p ) . destruct nh . apply ( ii2 p ) . simpl . apply ( @hinhuniv _ ( ishinh _ ) ) . intro c . destruct c as [ t | p ] . generalize t . simpl . apply hinhfun . clear t . intro t . destruct t as [ n d2 ] . destruct d2 as [ l p ] . split with n . split with ( natlehtolehs _ _ l ) . apply p . apply hinhpr . split with ( S n' ) . split with ( isreflnatleh _ ) . apply p . apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( pr2 _ ) ( pr2 _ ) ) . Defined . Lemma isdecbexists ( n : nat ) ( P : nat -> UU ) ( is : forall n' , isdecprop ( P n' ) ) : isdecprop ( hexists ( fun n' => dirprod ( natleh n' n ) ( P n' ) ) ) . Proof . intros . set ( P' := fun n' : nat => hProppair _ ( is n' ) ) . induction n as [ | n IHn ] . apply ( isdecpropweqb ( weqexistsnatlehn0 P' ) ) . apply ( is 0 ) . apply ( isdecpropweqb ( weqexistsnatlehnsn' _ P' ) ) . apply isdecprophdisj . apply IHn . apply ( is ( S n ) ) . Defined . Lemma isdecbforall ( n : nat ) ( P : nat -> UU ) ( is : forall n' , isdecprop ( P n' ) ) : isdecprop ( forall n' , natleh n' n -> P n' ) . Proof . intros . set ( P' := fun n' : nat => hProppair _ ( is n' ) ) . induction n as [ | n IHn ] . apply ( isdecpropweqb ( weqforallnatlehn0 P' ) ) . apply ( is 0 ) . apply ( isdecpropweqb ( weqforallnatlehnsn' _ P' ) ) . apply isdecpropdirprod . apply IHn . apply ( is ( S n ) ) . Defined . (** The following lemma finds the largest [ n' ] such that [ neg ( P n' ) ] . It is a stronger form of ( neg forall ) -> ( exists neg ) in the case of bounded quantification of decidable propositions. *) Lemma negbforalldectototal2neg ( n : nat ) ( P : nat -> UU ) ( is : forall n' : nat , isdecprop ( P n' ) ) : neg ( forall n' : nat , natleh n' n -> P n' ) -> total2 ( fun n' => dirprod ( natleh n' n ) ( neg ( P n' ) ) ) . Proof . intros n P is . set ( P' := fun n' : nat => hProppair _ ( is n' ) ) . induction n as [ | n IHn ] . intro nf . set ( nf0 := negf ( invweq ( weqforallnatlehn0 P' ) ) nf ) . split with 0 . apply ( dirprodpair ( isreflnatleh 0 ) nf0 ) . intro nf . set ( nf2 := negf ( invweq ( weqforallnatlehnsn' n P' ) ) nf ) . set ( nf3 := fromneganddecy ( is ( S n ) ) nf2 ) . destruct nf3 as [ f1 | f2 ] . set ( int := IHn f1 ) . destruct int as [ n' d2 ] . destruct d2 as [ l np ] . split with n' . split with ( natlehtolehs _ _ l ) . apply np . split with ( S n ) . split with ( isreflnatleh _ ) . apply f2 . Defined . (** ** Accesibility - the least element of an inhabited decidable subset of [nat] *) Definition natdecleast ( F : nat -> UU ) ( is : forall n , isdecprop ( F n ) ) := total2 ( fun n : nat => dirprod ( F n ) ( forall n' : nat , F n' -> natleh n n' ) ) . Lemma isapropnatdecleast ( F : nat -> UU ) ( is : forall n , isdecprop ( F n ) ) : isaprop ( natdecleast F is ) . Proof . intros . set ( P := fun n' : nat => hProppair _ ( is n' ) ) . assert ( int1 : forall n : nat, isaprop ( dirprod ( F n ) ( forall n' : nat , F n' -> natleh n n' ) ) ) . intro n . apply isapropdirprod . apply ( pr2 ( P n ) ) . apply impred . intro t . apply impred . intro . apply ( pr2 ( natleh n t ) ) . set ( int2 := ( fun n : nat => hProppair _ ( int1 n ) ) : nat -> hProp ) . change ( isaprop ( total2 int2 ) ) . apply isapropsubtype . intros x1 x2 . intros c1 c2 . simpl in * . destruct c1 as [ e1 c1 ] . destruct c2 as [ e2 c2 ] . set ( l1 := c1 x2 e2 ) . set ( l2 := c2 x1 e1 ) . apply ( isantisymmnatleh _ _ l1 l2 ) . Defined . Theorem accth ( F : nat -> UU ) ( is : forall n , isdecprop ( F n ) ) ( is' : hexists F ) : natdecleast F is . Proof . intros F is . simpl . apply (@hinhuniv _ ( hProppair _ ( isapropnatdecleast F is ) ) ) . intro t2. destruct t2 as [ n l ] . simpl . set ( F' := fun n' : nat => hexists ( fun n'' => dirprod ( natleh n'' n' ) ( F n'' ) ) ) . assert ( X : forall n' , F' n' -> natdecleast F is ) . intro n' . simpl . induction n' as [ | n' IHn' ] . apply ( @hinhuniv _ ( hProppair _ ( isapropnatdecleast F is ) ) ) . simpl . intro t2 . destruct t2 as [ n'' is'' ] . destruct is'' as [ l'' d'' ] . split with 0 . split . set ( e := natleh0tois0 _ l'' ) . clearbody e . destruct e . apply d'' . apply ( fun n' => fun f : _ => natleh0n n' ) . apply ( @hinhuniv _ ( hProppair _ ( isapropnatdecleast F is ) ) ) . intro t2 . destruct t2 as [ n'' is'' ] . set ( j := natlehchoice2 _ _ ( pr1 is'' ) ) . destruct j as [ jl | je ] . simpl . apply ( IHn' ( hinhpr _ ( tpair _ n'' ( dirprodpair jl ( pr2 is'' ) ) ) ) ) . simpl . rewrite je in is'' . destruct is'' as [ nn is'' ] . clear nn. clear je . clear n'' . assert ( is' : isdecprop ( F' n' ) ) . apply ( isdecbexists n' F is ) . destruct ( pr1 is' ) as [ f | nf ] . apply ( IHn' f ) . split with ( S n' ) . split with is'' . intros n0 fn0 . destruct ( natlthorgeh n0 ( S n' ) ) as [ l' | g' ] . set ( i' := natlthtolehsn _ _ l' ) . destruct ( nf ( hinhpr _ ( tpair _ n0 ( dirprodpair i' fn0 ) ) ) ) . apply g' . apply ( X n ( hinhpr _ ( tpair _ n ( dirprodpair ( isreflnatleh n ) l ) ) ) ) . Defined . (* End of the file stnfsets.v *) Voevodsky-Coq/hlevel1/._hProp.v000777 000765 000024 00000000256 12346040720 017243 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/hlevel1/hProp.v000777 000765 000024 00000041173 12346040720 017031 0ustar00nicolastaff000000 000000 (** * Generalities on hProp. Vladimir Voevodsky . May - Sep. 2011 . In this file we introduce the hProp - an analog of Prop defined based on the univalent semantics. We further introduce the hProp version of the "inhabited" construction - i.e. for any [ T ] in [ UU0 ] we construct an object [ ishinh T ] and a function [ hinhpr : T -> ishinh T ] which plays the role of [ inhabits ] from the Coq standard library. The semantic meaning of [ hinhpr ] is that it is universal among functions from [ T ] to objects of hProp. Proving that [ ishinh T ] is in [ hProp ] requires a resizing rule which can be written in the putative notation for such rules as follows : Resizing Rule RR1 ( U1 U2 : Univ ) ( X : U1 ) ( is : isaprop X ) |- X : U2 . Further in the file we introduce the univalence axiom for hProp and a proof of the fact that it is equivalent to a simplier and better known axiom [ uahp ]. We prove that this axiom implies that [ hProp ] satisfies [ isaset ] i.e. it is a type of h-level 2 . This requires another resizing rule : Resizing Rule RR2 ( U1 U2 : Univ ) |- @hProp U1 : U2 . Since resizing rules are not currently implemented in Coq the file does not compile without a patch provided by Hugo Herbelin which turns off the universe consistency verification. We do however keep track of universes in our development "by hand" to ensure that when the resizing rules will become available the current proofs will verify correctly. To point out which results require resizing rules in a substantial way we mark the first few of such reults by (** RR1 *) or (** RR2 *) comment . One can achieve similar results with a combination of usual axioms which imitate the resizing rules. However unlike the usual axioms the resizing rules do not affect the computation/normalization abilities of Coq which makes them the prefrred choice in this situation. *) (** ** Preambule *) (** Settings *) Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *) (** Imports *) Add LoadPath ".." as Foundations. Require Export Foundations.Generalities.uu0. (** Universe structure *) (* Definition UU0 := UU . *) (* end of " Preambule " . *) (** ** To upstream files *) (** ** The type [ hProp ] of types of h-level 1 *) Definition hProp := total2 ( fun X : UU => isaprop X ) . Definition hProppair ( X : UU ) ( is : isaprop X ) : hProp := tpair (fun X : UU => isaprop X ) X is . Definition hProptoType := @pr1 _ _ : hProp -> Type . Coercion hProptoType: hProp >-> Sortclass. (** ** The type [ tildehProp ] of pairs ( P , p : P ) where [ P : hProp ] *) Definition tildehProp := total2 ( fun P : hProp => P ) . Definition tildehProppair { P : hProp } ( p : P ) : tildehProp := tpair _ P p . (** The following re-definitions should make proofs easier in the future when the unification algorithms in Coq are improved . At the moment they create more complications than they eliminate ( e.g. try to prove [ isapropishinh ] with [ isaprop ] in [ hProp ] ) so for the time being they are commented out . (** *** Re-definitions of some of the standard constructions of uu0.v which lift these contructions from UU to hProp . *) Definition iscontr ( X : UU ) : hProp := hProppair _ ( isapropiscontr X ) . Definition isweq { X Y : UU } ( f : X -> Y ) : hProp := hProppair _ ( isapropisweq f ) . Definition isofhlevel ( n : nat ) ( X : UU ) : hProp := hProppair _ ( isapropisofhlevel n X ) . Definition isaprop ( X : UU ) : hProp := hProppair ( isaprop X ) ( isapropisaprop X ) . Definition isaset ( X : UU ) : hProp := hProppair _ ( isapropisaset X ) . Definition isisolated ( X : UU ) ( x : X ) : hProp := hProppair _ ( isapropisisolated X x ) . Definition isdecEq ( X : UU ) : hProp := hProppair _ ( isapropisdeceq X ) . *) (** ** Intuitionistic logic on [ hProp ] *) (** *** The [ hProp ] version of the "inhabited" construction. *) Definition ishinh_UU ( X : UU ) := forall P: hProp, ( ( X -> P ) -> P ). Lemma isapropishinh ( X : UU ) : isaprop ( ishinh_UU X ). Proof. intro. apply impred . intro P . apply impred. intro. apply ( pr2 P ) . Defined . Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) ( isapropishinh X ) . (* Canonical Structure ishinh . (** RR1 *) *) Definition hinhpr ( X : UU ) : X -> ishinh X := fun x : X => fun P : hProp => fun f : X -> P => f x . Definition hinhfun { X Y : UU } ( f : X -> Y ) : ishinh_UU X -> ishinh_UU Y := fun isx : ishinh X => fun P : _ => fun yp : Y -> P => isx P ( fun x : X => yp ( f x ) ) . (** Note that the previous definitions do not require RR1 in an essential way ( except for the placing of [ ishinh ] in [ hProp UU ] - without RR1 it would be placed in [ hProp UU1 ] ) . The first place where RR1 is essentially required is in application of [ hinhuniv ] to a function [ X -> ishinh Y ] *) Definition hinhuniv { X : UU } { P : hProp } ( f : X -> P ) ( wit : ishinh_UU X ) : P := wit P f . Definition hinhand { X Y : UU } ( inx1 : ishinh_UU X ) ( iny1 : ishinh_UU Y) : ishinh ( dirprod X Y ) := fun P:_ => ddualand (inx1 P) (iny1 P). Definition hinhuniv2 { X Y : UU } { P : hProp } ( f : X -> Y -> P ) ( isx : ishinh_UU X ) ( isy : ishinh_UU Y ) : P := hinhuniv ( fun xy : dirprod X Y => f ( pr1 xy ) ( pr2 xy ) ) ( hinhand isx isy ) . Definition hinhfun2 { X Y Z : UU } ( f : X -> Y -> Z ) ( isx : ishinh_UU X ) ( isy : ishinh_UU Y ) : ishinh Z := hinhfun ( fun xy: dirprod X Y => f ( pr1 xy ) ( pr2 xy ) ) ( hinhand isx isy ) . Definition hinhunivcor1 ( P : hProp ) : ishinh_UU P -> P := hinhuniv ( idfun P ). Notation hinhprinv := hinhunivcor1 . (** *** [ ishinh ] and negation [ neg ] *) Lemma weqishinhnegtoneg ( X : UU ) : weq ( ishinh ( neg X ) ) ( neg X ) . Proof . intro . assert ( lg : logeq ( ishinh ( neg X ) ) ( neg X ) ) . split . simpl . apply ( @hinhuniv _ ( hProppair _ ( isapropneg X ) ) ) . simpl . intro nx . apply nx . apply hinhpr . apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( pr2 ( ishinh _ ) ) ( isapropneg X ) ) . Defined . Lemma weqnegtonegishinh ( X : UU ) : weq ( neg X ) ( neg ( ishinh X ) ) . Proof . intro . assert ( lg : logeq ( neg ( ishinh X ) ) ( neg X ) ) . split . apply ( negf ( hinhpr X ) ) . intro nx . unfold neg . simpl . apply ( @hinhuniv _ ( hProppair _ isapropempty ) ) . apply nx . apply ( weqimplimpl ( pr2 lg ) ( pr1 lg ) ( isapropneg _ ) ( isapropneg _ ) ) . Defined . (** *** [ ishinh ] and [ coprod ] *) Lemma hinhcoprod ( X Y : UU ) ( is : ishinh ( coprod ( ishinh X ) ( ishinh Y ) ) ) : ishinh ( coprod X Y ) . Proof. intros . unfold ishinh. intro P . intro CP. set (CPX := fun x : X => CP ( ii1 x ) ) . set (CPY := fun y : Y => CP (ii2 y) ). set (is1P := is P). assert ( f : coprod ( ishinh X ) ( ishinh Y ) -> P ) . apply ( sumofmaps ( hinhuniv CPX ) ( hinhuniv CPY ) ). apply (is1P f ) . Defined. (** *** Intuitionistic logic on [ hProp ]. *) Definition htrue : hProp := hProppair unit isapropunit. Definition hfalse : hProp := hProppair empty isapropempty. Definition hconj ( P Q : hProp ) : hProp := hProppair ( dirprod P Q ) ( isapropdirprod _ _ ( pr2 P ) ( pr2 Q ) ). Definition hdisj ( P Q : UU ) : hProp := ishinh ( coprod P Q ) . Definition hneg ( P : UU ) : hProp := hProppair ( neg P ) ( isapropneg P ) . Definition himpl ( P : UU ) ( Q : hProp ) : hProp. Proof. intros. split with ( P -> Q ) . apply impred. intro. apply (pr2 Q). Defined. Definition hexists { X : UU } ( P : X -> UU ) := ishinh ( total2 P ) . Definition wittohexists { X : UU } ( P : X -> UU ) ( x : X ) ( is : P x ) : hexists P := hinhpr ( total2 P ) (tpair _ x is ) . Definition total2tohexists { X : UU } ( P : X -> UU ) : total2 P -> hexists P := hinhpr _ . Definition weqneghexistsnegtotal2 { X : UU } ( P : X -> UU ) : weq ( neg ( hexists P ) ) ( neg ( total2 P ) ) . Proof . intros . assert ( lg : ( neg ( hexists P ) ) <-> ( neg ( total2 P ) ) ) . split . apply ( negf ( total2tohexists P ) ) . intro nt2 . unfold neg . change ( ishinh_UU ( total2 P ) -> hfalse ) . apply ( hinhuniv ) . apply nt2 . apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( isapropneg _ ) ( isapropneg _ ) ) . Defined . (** *** Associativity and commutativity of [ hdisj ] and [ hconj ] up to logical equivalence *) Lemma islogeqcommhdisj { P Q : hProp } : hdisj P Q <-> hdisj Q P . Proof . intros . split . simpl . apply hinhfun . apply coprodcomm . simpl . apply hinhfun . apply coprodcomm . Defined . (** *** Proof of the only non-trivial axiom of intuitionistic logic for our constructions. For the full list of axioms see e.g. http://plato.stanford.edu/entries/logic-intuitionistic/ *) Lemma hconjtohdisj ( P Q : UU ) ( R : hProp ) : hconj ( himpl P R ) ( himpl Q R ) -> himpl ( hdisj P Q ) R . Proof. intros P Q R X0. assert (s1: hdisj P Q -> R) . intro X1. assert (s2: coprod P Q -> R ) . intro X2. destruct X2 as [ XP | XQ ]. apply X0. apply XP . apply ( pr2 X0 ). apply XQ . apply ( hinhuniv s2 ). apply X1 . unfold himpl. simpl . apply s1 . Defined. (** *** Negation and quantification. There are four standard implications in classical logic which can be summarized as ( neg ( forall P ) ) <-> ( exists ( neg P ) ) and ( neg ( exists P ) ) <-> ( forall ( neg P ) ) . Of these four implications three are provable in the intuitionistic logic. The remaining implication ( neg ( forall P ) ) -> ( exists ( neg P ) ) is not provable in general . For a proof in the case of bounded quantification of decidable predicates on natural numbers see hnat.v . For some other cases when these implications hold see ??? . *) Lemma hexistsnegtonegforall { X : UU } ( F : X -> UU ) : hexists ( fun x : X => neg ( F x ) ) -> neg ( forall x : X , F x ) . Proof . intros X F . simpl . apply ( @hinhuniv _ ( hProppair _ ( isapropneg (forall x : X , F x ) ) ) ) . simpl . intros t2 f2 . destruct t2 as [ x d2 ] . apply ( d2 ( f2 x ) ) . Defined . Lemma forallnegtoneghexists { X : UU } ( F : X -> UU ) : ( forall x : X , neg ( F x ) ) -> neg ( hexists F ) . Proof. intros X F nf . change ( ( ishinh_UU ( total2 F ) ) -> hfalse ) . apply hinhuniv . intro t2 . destruct t2 as [ x f ] . apply ( nf x f ) . Defined . Lemma neghexisttoforallneg { X : UU } ( F : X -> UU ) : neg ( hexists F ) -> forall x : X , neg ( F x ) . Proof . intros X F nhe x . intro fx . apply ( nhe ( hinhpr _ ( tpair F x fx ) ) ) . Defined . Definition weqforallnegtonegexists { X : UU } ( F : X -> UU ) : weq ( forall x : X , neg ( F x ) ) ( neg ( hexists F ) ) . Proof . intros . apply ( weqimplimpl ( forallnegtoneghexists F ) ( neghexisttoforallneg F ) ) . apply impred . intro x . apply isapropneg . apply isapropneg . Defined . (** *** Negation and conjunction ( "and" ) and disjunction ( "or" ) . There are four implications in classical logic ( ( neg X ) and ( neg Y ) ) <-> ( neg ( X or Y ) ) and ( ( neg X ) or ( neg Y ) ) <-> ( neg ( X and Y ) ) . Of these four, three are provable unconditionally in the intuitionistic logic and the remaining one ( neg ( X and Y ) ) -> ( ( neg X ) or ( neg Y ) ) is provable only if one of the propositions is deidable. These two cases are proved in uu0.v under the names [ fromneganddecx ] and [ fromneganddecy ] . *) Lemma tonegdirprod { X Y : UU } ( is : hdisj ( neg X ) ( neg Y ) ) : neg ( dirprod X Y ) . Proof. intros X Y . simpl . apply ( @hinhuniv _ ( hProppair _ ( isapropneg ( dirprod X Y ) ) ) ) . intro c . destruct c as [ nx | ny ] . simpl . intro xy . apply ( nx ( pr1 xy ) ) . simpl . intro xy . apply ( ny ( pr2 xy ) ) . Defined . Lemma tonegcoprod { X Y : UU } ( is : dirprod ( neg X ) ( neg Y ) ) : neg ( coprod X Y ) . Proof . intros. intro c . destruct c as [ x | y ] . apply ( pr1 is x ) . apply ( pr2 is y ) . Defined . Lemma toneghdisj { X Y : UU } ( is : dirprod ( neg X ) ( neg Y ) ) : neg ( hdisj X Y ) . Proof . intros . unfold hdisj. apply ( weqnegtonegishinh ) . apply tonegcoprod . apply is . Defined . Lemma fromnegcoprod { X Y : UU } ( is : neg ( coprod X Y ) ) : dirprod ( neg X ) ( neg Y ) . Proof . intros . split . exact ( fun x => is ( ii1 x ) ) . exact ( fun y => is ( ii2 y ) ) . Defined . Lemma hdisjtoimpl { P : UU } { Q : hProp } : hdisj P Q -> ( neg P -> Q ) . Proof . intros P Q . assert ( int : isaprop ( neg P -> Q ) ) . apply impred . intro . apply ( pr2 Q ) . simpl . apply ( @hinhuniv _ ( hProppair _ int ) ) . simpl . intro pq . destruct pq as [ p | q ] . intro np . destruct ( np p ) . intro np . apply q . Defined . (** *** Property of being decidable and [ hdisj ] ( "or" ) . For being deidable [ hconj ] see [ isdecpropdirprod ] in uu0.v *) Lemma isdecprophdisj { X Y : UU } ( isx : isdecprop X ) ( isy : isdecprop Y ) : isdecprop ( hdisj X Y ) . Proof . intros . apply isdecpropif . apply ( pr2 ( hdisj X Y ) ) . destruct ( pr1 isx ) as [ x | nx ] . apply ( ii1 ( hinhpr _ ( ii1 x ) ) ) . destruct ( pr1 isy ) as [ y | ny ] . apply ( ii1 ( hinhpr _ ( ii2 y ) ) ) . apply ( ii2 ( toneghdisj ( dirprodpair nx ny ) ) ) . Defined . (** *** The double negation version of [ hinhabited ] ( does not require RR1 ) . *) Definition isinhdneg ( X : UU ) : hProp := hProppair ( dneg X ) ( isapropdneg X ) . Definition inhdnegpr (X:UU): X -> isinhdneg X := todneg X. Definition inhdnegfun { X Y : UU } (f:X -> Y): isinhdneg X -> isinhdneg Y := dnegf f. Definition inhdneguniv (X: UU)(P:UU)(is:isweq (todneg P)): (X -> P) -> ((isinhdneg X) -> P) := fun xp:_ => fun inx0:_ => (invmap ( weqpair _ is ) (dnegf xp inx0)). Definition inhdnegand (X Y:UU)(inx0: isinhdneg X)(iny0: isinhdneg Y) : isinhdneg (dirprod X Y) := dneganddnegimpldneg inx0 iny0. Definition hinhimplinhdneg (X:UU)(inx1: ishinh X): isinhdneg X := inx1 hfalse. (** ** Univalence axiom for hProp We introduce here the weakest form of the univalence axiom - the univalence axiom for hProp which is equivalent to the second part of the extensionality axiom in Church simple type theory. This axiom is easily shown to be equivalent to its version with [paths P P'] as a target and to [ weqtopathshProp ] (see below) as well as to the version of [ weqtopathshProp ] with [ paths P P'] as a target. The proof of theorem [ univfromtwoaxiomshProp ] is modeled on the proof of [ univfromtwoaxioms ] from univ01.v *) Axiom uahp : forall P P':hProp, (P -> P') -> (P' -> P) -> @paths hProp P P'. Definition eqweqmaphProp { P P': hProp } ( e: @paths hProp P P' ) : weq P P'. Proof. intros . destruct e . apply idweq. Defined. Definition weqtopathshProp { P P' : hProp } (w: weq P P' ): @paths hProp P P' := uahp P P' w ( invweq w ) . Definition weqpathsweqhProp { P P' : hProp } (w : weq P P'): paths (eqweqmaphProp (weqtopathshProp w)) w. Proof. intros. apply proofirrelevance . apply (isapropweqtoprop P P' (pr2 P')). Defined. Theorem univfromtwoaxiomshProp (P P':hProp): isweq (@eqweqmaphProp P P'). Proof. intros. set (P1:= fun XY: dirprod hProp hProp => (match XY with tpair X Y => paths X Y end)). set (P2:= fun XY: dirprod hProp hProp => match XY with tpair X Y => weq X Y end). set (Z1:= total2 P1). set (Z2:= total2 P2). set (f:= ( totalfun _ _ (fun XY: dirprod hProp hProp => (match XY with tpair X Y => @eqweqmaphProp X Y end))): Z1 -> Z2). set (g:= ( totalfun _ _ (fun XY: dirprod hProp hProp => (match XY with tpair X Y => @weqtopathshProp X Y end))): Z2 -> Z1). set (s1:= (fun X Y :hProp => fun w: weq X Y => tpair P2 ( dirprodpair X Y) w)). set (efg:= (fun a:_ => match a as a' return (paths (f (g a')) a') with tpair (tpair X Y) w => ( maponpaths (s1 X Y) (@weqpathsweqhProp X Y w)) end)). set (h:= fun a1:Z1 => (pr1 ( pr1 a1))). assert (egf0: forall a1:Z1, paths ( pr1 (g (f a1))) ( pr1 a1)). intro. apply idpath. assert (egf1: forall a1 a1':Z1, paths ( pr1 a1') ( pr1 a1) -> paths a1' a1). intros ? ? X . set (X':= maponpaths ( @pr1 _ _ ) X). assert (is: isweq h). apply ( isweqpr1pr1 hProp ). apply ( invmaponpathsweq ( weqpair h is ) _ _ X'). set (egf:= fun a1:_ => (egf1 _ _ (egf0 a1))). set (is2:= gradth _ _ egf efg). apply ( isweqtotaltofib P1 P2 (fun XY: dirprod hProp hProp => (match XY with tpair X Y => @eqweqmaphProp X Y end)) is2 ( dirprodpair P P')). Defined. Definition weqeqweqhProp ( P P' : hProp ) := weqpair _ ( univfromtwoaxiomshProp P P' ) . Corollary isasethProp : isaset hProp. Proof. unfold isaset. simpl. intros x x'. apply (isofhlevelweqb (S O) ( weqeqweqhProp x x' ) (isapropweqtoprop x x' (pr2 x'))). Defined. Lemma iscontrtildehProp : iscontr tildehProp . Proof . split with ( tpair _ htrue tt ) . intro tP . destruct tP as [ P p ] . apply ( invmaponpathsincl _ ( isinclpr1 ( fun P : hProp => P ) ( fun P => pr2 P ) ) ) . simpl . apply uahp . apply ( fun x => tt ) . intro t. apply p . Defined . Lemma isaproptildehProp : isaprop tildehProp . Proof . apply ( isapropifcontr iscontrtildehProp ) . Defined . Lemma isasettildehProp : isaset tildehProp . Proof . apply ( isasetifcontr iscontrtildehProp ) . Defined . (* End of the file hProp.v *) Voevodsky-Coq/Generalities/._uu0.v000777 000765 000024 00000000256 12346040720 017737 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/Generalities/uu0.v000777 000765 000024 00000650046 12346040720 017532 0ustar00nicolastaff000000 000000 (** * Univalent Basics. Vladimir Voevodsky. Feb. 2010 - Sep. 2011. Port to coq trunk (8.4-8.5) in March 2014. This file contains results which form a basis of the univalent approach and which do not require the use of universes as types. Fixpoints with values in a universe are used only once in the definition [ isofhlevel ]. Many results in this file do not require any axioms. The first axiom we use is [ funextempty ] which is the functional extensionality axiom for functions with values in the empty type. Closer to the end of the file we use general functional extensionality [ funextfunax ] asserting that two homotopic functions are equal. Since [ funextfunax ] itself is not an "axiom" in our sense i.e. its type is not of h-level 1 we show that it is logically equivalent to a real axiom [ funcontr ] which asserts that the space of sections of a family with contractible fibers is contractible. *) (** ** Preambule *) (** Settings *) Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *) (** Imports *) Add LoadPath ".." as Foundations . Require Export Foundations.Generalities.uuu. (** Universe structure *) Definition UU := Type . (* end of "Preambule". *) (** ** Some standard constructions not using identity types (paths) *) (** *** Canonical functions from [ empty ] and to [ unit ] *) Definition fromempty { X : UU } : empty -> X. Proof. intros X H. destruct H. Defined. Definition tounit { X : UU } : X -> unit := fun x : X => tt . (** *** Functions from [ unit ] corresponding to terms *) Definition termfun { X : UU } ( x : X ) : unit -> X := fun t : unit => x . (** *** Identity functions and function composition *) Definition idfun ( T : UU ) := fun t : T => t . Definition funcomp { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) := fun x : X => g ( f x ) . (** *** Iteration of an endomorphism *) Fixpoint iteration { T : UU } ( f : T -> T ) ( n : nat ) : T -> T := match n with O => idfun T | S m => funcomp ( iteration f m ) f end . (** *** Basic constructions related to the adjoint evaluation function [ X -> ( ( X -> Y ) -> Y ) ] *) Definition adjev { X Y : UU } ( x : X ) ( f : X -> Y ) : Y := f x. Definition adjev2 { X Y : UU } ( phi : ( ( X -> Y ) -> Y ) -> Y ) : X -> Y := (fun x : X => phi ( fun f : X -> Y => f x ) ) . (** *** Pairwise direct products *) Definition dirprod ( X Y : UU ) := total2 ( fun x : X => Y ) . Definition dirprodpair { X Y : UU } := tpair ( fun x : X => Y ) . Definition dirprodadj { X Y Z : UU } ( f : dirprod X Y -> Z ) : X -> Y -> Z := fun x : X => fun y : Y => f ( dirprodpair x y ) . Definition dirprodf { X Y X' Y' : UU } ( f : X -> Y ) ( f' : X' -> Y' ) ( xx' : dirprod X X' ) : dirprod Y Y' := dirprodpair ( f ( pr1 xx') ) ( f' ( pr2 xx' ) ) . Definition ddualand { X Y P : UU } (xp : ( X -> P ) -> P ) ( yp : ( Y -> P ) -> P ) : ( dirprod X Y -> P ) -> P. Proof. intros X Y P xp yp X0 . set ( int1 := fun ypp : ( ( Y -> P ) -> P ) => fun x : X => yp ( fun y : Y => X0 ( dirprodpair x y) ) ) . apply ( xp ( int1 yp ) ) . Defined . (** *** Negation and double negation *) Definition neg ( X : UU ) : UU := X -> empty. Definition negf { X Y : UU } ( f : X -> Y ) : neg Y -> neg X := fun phi : Y -> empty => fun x : X => phi ( f x ) . Definition dneg ( X : UU ) : UU := ( X -> empty ) -> empty . Definition dnegf { X Y : UU } ( f : X -> Y ) : dneg X -> dneg Y := negf ( negf f ) . Definition todneg ( X : UU ) : X -> dneg X := adjev . Definition dnegnegtoneg { X : UU } : dneg ( neg X ) -> neg X := adjev2 . Lemma dneganddnegl1 { X Y : UU } ( dnx : dneg X ) ( dny : dneg Y ) : neg ( X -> neg Y ) . Proof. intros. intro X2. assert ( X3 : dneg X -> neg Y ) . apply ( fun xx : dneg X => dnegnegtoneg ( dnegf X2 xx ) ) . apply ( dny ( X3 dnx ) ) . Defined. Definition dneganddnegimpldneg { X Y : UU } ( dnx : dneg X ) ( dny : dneg Y ) : dneg ( dirprod X Y ) := ddualand dnx dny. (** *** Logical equivalence *) Definition logeq ( X Y : UU ) := dirprod ( X -> Y ) ( Y -> X ) . Notation " X <-> Y " := ( logeq X Y ) : type_scope . Definition logeqnegs { X Y : UU } ( l : X <-> Y ) : ( neg X ) <-> ( neg Y ) := dirprodpair ( negf ( pr2 l ) ) ( negf ( pr1 l ) ) . (* end of "Some standard constructions not using idenity types (paths)". *) (** ** Operations on [ paths ] *) (** *** Composition of paths and inverse paths *) Definition pathscomp0 { X : UU } { a b c : X } ( e1 : paths a b ) ( e2 : paths b c ) : paths a c . Proof. intros. destruct e1. apply e2 . Defined. Hint Resolve @pathscomp0 : pathshints . Definition pathscomp0rid { X : UU } { a b : X } ( e1 : paths a b ) : paths ( pathscomp0 e1 ( idpath b ) ) e1 . Proof. intros. destruct e1. simpl. apply idpath. Defined. (** Note that we do no need [ pathscomp0lid ] since the corresponding two terms are convertible to each other due to our definition of [ pathscomp0 ] . If we defined it by destructing [ e2 ] and applying [ e1 ] then [ pathsinv0rid ] would be trivial but [ pathsinv0lid ] would require a proof. Similarly we do not need a lemma to connect [ pathsinv0 ( idpath _ ) ] to [ idpath ] *) Definition pathsinv0 { X : UU } { a b : X } ( e : paths a b ) : paths b a . Proof. intros. destruct e. apply idpath. Defined. Hint Resolve @pathsinv0 : pathshints . Definition pathsinv0l { X : UU } { a b : X } ( e : paths a b ) : paths ( pathscomp0 ( pathsinv0 e ) e ) ( idpath _ ) . Proof. intros. destruct e. apply idpath. Defined. Definition pathsinv0r { X : UU } { a b : X } ( e : paths a b ) : paths ( pathscomp0 e ( pathsinv0 e ) ) ( idpath _ ) . Proof. intros. destruct e. apply idpath. Defined. Definition pathsinv0inv0 { X : UU } { x x' : X } ( e : paths x x' ) : paths ( pathsinv0 ( pathsinv0 e ) ) e . Proof. intros. destruct e. apply idpath. Defined. (** *** Direct product of paths *) Definition pathsdirprod { X Y : UU } { x1 x2 : X } { y1 y2 : Y } ( ex : paths x1 x2 ) ( ey : paths y1 y2 ) : paths ( dirprodpair x1 y1 ) ( dirprodpair x2 y2 ) . Proof . intros . destruct ex . destruct ey . apply idpath . Defined . (** *** The function [ maponpaths ] between paths types defined by a function between abmbient types and its behavior relative to [ pathscomp0 ] and [ pathsinv0 ] *) Definition maponpaths { T1 T2 : UU } ( f : T1 -> T2 ) { t1 t2 : T1 } ( e: paths t1 t2 ) : paths ( f t1 ) ( f t2 ) . Proof. intros . destruct e . apply idpath. Defined. Definition maponpathscomp0 { X Y : UU } { x1 x2 x3 : X } ( f : X -> Y ) ( e1 : paths x1 x2 ) ( e2 : paths x2 x3 ) : paths ( maponpaths f ( pathscomp0 e1 e2 ) ) ( pathscomp0 ( maponpaths f e1 ) ( maponpaths f e2 ) ) . Proof. intros. destruct e1. destruct e2. simpl. apply idpath. Defined. Definition maponpathsinv0 { X Y : UU } ( f : X -> Y ) { x1 x2 : X } ( e : paths x1 x2 ) : paths ( maponpaths f ( pathsinv0 e ) ) ( pathsinv0 ( maponpaths f e ) ) . Proof. intros . destruct e . apply idpath . Defined . (** *** [ maponpaths ] for the identity functions and compositions of functions *) Lemma maponpathsidfun { X : UU } { x x' : X } ( e : paths x x' ) : paths ( maponpaths ( idfun X ) e ) e . Proof. intros. destruct e. apply idpath . Defined. Lemma maponpathscomp { X Y Z : UU } { x x' : X } ( f : X -> Y ) ( g : Y -> Z ) ( e : paths x x' ) : paths ( maponpaths g ( maponpaths f e ) ) ( maponpaths ( funcomp f g ) e) . Proof. intros. destruct e. apply idpath. Defined. (** The following four statements show that [ maponpaths ] defined by a function f which is homotopic to the identity is "surjective". It is later used to show that the maponpaths defined by a function which is a weak equivalence is itself a weak equivalence. *) Definition maponpathshomidinv { X : UU } (f:X -> X) ( h: forall x:X, paths (f x) x) ( x x' : X ) : paths (f x) (f x') -> paths x x' := (fun e: paths (f x) (f x') => pathscomp0 (pathsinv0 (h x)) (pathscomp0 e (h x'))). Lemma maponpathshomid1 { X : UU } (f:X -> X) (h: forall x:X, paths (f x) x) { x x' : X } (e:paths x x'): paths (maponpaths f e) (pathscomp0 (h x) (pathscomp0 e (pathsinv0 (h x')))). Proof. intros. destruct e. change (pathscomp0 (idpath x) (pathsinv0 (h x))) with (pathsinv0 (h x)). assert (ee: paths (maponpaths f (idpath x)) (idpath (f x))). apply idpath . assert (eee: paths (idpath (f x)) (pathscomp0 (h x) (pathsinv0 (h x)))). apply (pathsinv0 (pathsinv0r (h x))). apply (pathscomp0 ee eee). Defined. Lemma maponpathshomid12 { X : UU } { x x' fx fx' : X } (e:paths fx fx') (hx:paths fx x) (hx':paths fx' x') : paths (pathscomp0 hx (pathscomp0 (pathscomp0 (pathsinv0 hx) (pathscomp0 e hx')) (pathsinv0 hx'))) e. Proof. intros. destruct hx. destruct hx'. destruct e. simpl. apply idpath. Defined. Lemma maponpathshomid2 { X : UU } (f:X->X) (h: forall x:X, paths (f x) x) ( x x' : X ) (e:paths (f x) (f x')) : paths (maponpaths f (maponpathshomidinv f h _ _ e)) e. Proof. intros. assert (ee: paths (pathscomp0 (h x) (pathscomp0 (pathscomp0 (pathsinv0 (h x)) (pathscomp0 e (h x'))) (pathsinv0 (h x')))) e). apply (maponpathshomid12 e (h x) (h x')). assert (eee: paths (maponpaths f (pathscomp0 (pathsinv0 (h x)) (pathscomp0 e (h x')))) (pathscomp0 (h x) (pathscomp0 (pathscomp0 (pathsinv0 (h x)) (pathscomp0 e (h x'))) (pathsinv0 (h x'))))). apply maponpathshomid1. apply (pathscomp0 eee ee). Defined. (** Here we consider the behavior of maponpaths in the case of a projection [ p ] with a section [ s ]. *) Definition pathssec1 { X Y : UU } ( s : X -> Y ) ( p : Y -> X ) ( eps : forall x:X , paths ( p ( s x ) ) x ) ( x : X ) ( y : Y ) ( e : paths (s x) y ) : paths x (p y) := pathscomp0 ( pathsinv0 ( eps x ) ) ( maponpaths p e ) . Definition pathssec2 { X Y : UU } ( s : X -> Y ) ( p : Y -> X ) ( eps : forall x : X , paths ( p ( s x ) ) x ) ( x x' : X ) ( e : paths ( s x ) ( s x' ) ) : paths x x'. Proof. intros . set ( e' := pathssec1 s p eps _ _ e ) . apply ( pathscomp0 e' ( eps x' ) ) . Defined . Definition pathssec2id { X Y : UU } ( s : X -> Y ) ( p : Y -> X ) ( eps : forall x : X , paths ( p ( s x ) ) x ) ( x : X ) : paths ( pathssec2 s p eps _ _ ( idpath ( s x ) ) ) ( idpath x ) . Proof. intros. unfold pathssec2. unfold pathssec1. simpl. assert (e: paths (pathscomp0 (pathsinv0 (eps x)) (idpath (p (s x)))) (pathsinv0 (eps x))). apply pathscomp0rid. assert (ee: paths (pathscomp0 (pathscomp0 (pathsinv0 (eps x)) (idpath (p (s x)))) (eps x)) (pathscomp0 (pathsinv0 (eps x)) (eps x))). apply (maponpaths (fun e0: _ => pathscomp0 e0 (eps x)) e). assert (eee: paths (pathscomp0 (pathsinv0 (eps x)) (eps x)) (idpath x)). apply (pathsinv0l (eps x)). apply (pathscomp0 ee eee). Defined. Definition pathssec3 { X Y : UU } (s:X-> Y) (p:Y->X) (eps: forall x:X, paths (p (s x)) x) { x x' : X } ( e : paths x x' ) : paths (pathssec2 s p eps _ _ (maponpaths s e)) e. Proof. intros. destruct e. simpl. unfold pathssec2. unfold pathssec1. simpl. apply pathssec2id. Defined. (* end of "Operations on [ paths ]". *) (** ** Fibrations and paths *) Definition tppr { T : UU } { P : T -> UU } ( x : total2 P ) : paths x ( tpair _ (pr1 x) (pr2 x) ) . Proof. intros. destruct x. apply idpath. Defined. Definition constr1 { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : total2 (fun f: P x -> P x' => ( total2 ( fun ee : forall p : P x, paths (tpair _ x p) (tpair _ x' ( f p ) ) => forall pp : P x, paths (maponpaths ( @pr1 _ _ ) ( ee pp ) ) e ) ) ) . Proof. intros. destruct e. split with ( idfun ( P x ) ). simpl. split with (fun p : P x => idpath _ ) . unfold maponpaths. simpl. apply (fun pp : P x => idpath _ ) . Defined. Definition transportf { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : P x -> P x' := pr1 ( constr1 P e ) . Definition transportb { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : P x' -> P x := transportf P ( pathsinv0 e ) . Lemma functtransportf { X Y : UU } ( f : X -> Y ) ( P : Y -> UU ) { x x' : X } ( e : paths x x' ) ( p : P ( f x ) ) : paths ( transportf ( fun x => P ( f x ) ) e p ) ( transportf P ( maponpaths f e ) p ) . Proof. intros. destruct e. apply idpath. Defined. (** ** First homotopy notions *) (** *** Homotopy between functions *) Definition homot { X Y : UU } ( f g : X -> Y ) := forall x : X , paths ( f x ) ( g x ) . (** *** Contractibility, homotopy fibers etc. *) (** Contractible types. *) Definition iscontr (T:UU) : UU := total2 (fun cntr:T => forall t:T, paths t cntr). Definition iscontrpair { T : UU } := tpair (fun cntr:T => forall t:T, paths t cntr). Definition iscontrpr1 { T : UU } := @pr1 T ( fun cntr:T => forall t:T, paths t cntr ) . Lemma iscontrretract { X Y : UU } ( p : X -> Y ) ( s : Y -> X ) ( eps : forall y : Y, paths ( p ( s y ) ) y ) ( is : iscontr X ) : iscontr Y. Proof . intros . destruct is as [ x fe ] . set ( y := p x ) . split with y . intro y' . apply ( pathscomp0 ( pathsinv0 ( eps y' ) ) ( maponpaths p ( fe ( s y' ) ) ) ) . Defined . Lemma proofirrelevancecontr { X : UU }(is: iscontr X) ( x x' : X ): paths x x'. Proof. intros. unfold iscontr in is. destruct is as [ t x0 ]. set (e:= x0 x). set (e':= pathsinv0 (x0 x')). apply (pathscomp0 e e'). Defined. (** Coconuses - spaces of paths which begin or end at a given point. *) Definition coconustot ( T : UU ) ( t : T ) := total2 (fun t':T => paths t' t). Definition coconustotpair ( T : UU ) { t t' : T } (e: paths t' t) : coconustot T t := tpair (fun t':T => paths t' t) t' e. Definition coconustotpr1 ( T : UU ) ( t : T ) := @pr1 _ (fun t':T => paths t' t) . Lemma connectedcoconustot { T : UU } { t : T } ( c1 c2 : coconustot T t ) : paths c1 c2. Proof. intros. destruct c1 as [ x0 x ]. destruct x. destruct c2 as [ x1 x ]. destruct x. apply idpath. Defined. Lemma iscontrcoconustot ( T : UU ) (t:T) : iscontr (coconustot T t). Proof. intros. unfold iscontr. set (t0:= tpair (fun t':T => paths t' t) t (idpath t)). split with t0. intros. apply connectedcoconustot. Defined. Definition coconusfromt ( T : UU ) (t:T) := total2 (fun t':T => paths t t'). Definition coconusfromtpair ( T : UU ) { t t' : T } (e: paths t t') : coconusfromt T t := tpair (fun t':T => paths t t') t' e. Definition coconusfromtpr1 ( T : UU ) ( t : T ) := @pr1 _ (fun t':T => paths t t') . Lemma connectedcoconusfromt { T : UU } { t : T } ( e1 e2 : coconusfromt T t ) : paths e1 e2. Proof. intros. destruct e1 as [x0 x]. destruct x. destruct e2 as [ x1 x ]. destruct x. apply idpath. Defined. Lemma iscontrcoconusfromt ( T : UU ) (t:T) : iscontr (coconusfromt T t). Proof. intros. unfold iscontr. set (t0:= tpair (fun t':T => paths t t') t (idpath t)). split with t0. intros. apply connectedcoconusfromt. Defined. (** Pathsspace of a type. *) Definition pathsspace (T:UU) := total2 (fun t:T => coconusfromt T t). Definition pathsspacetriple ( T : UU ) { t1 t2 : T } (e: paths t1 t2): pathsspace T := tpair _ t1 (coconusfromtpair T e). Definition deltap ( T : UU ) : T -> pathsspace T := (fun t:T => pathsspacetriple T (idpath t)). Definition pathsspace' ( T : UU ) := total2 (fun xy : dirprod T T => (match xy with tpair x y => paths x y end)). (** Homotopy fibers. *) Definition hfiber { X Y : UU } (f:X -> Y) (y:Y) : UU := total2 (fun pointover:X => paths (f pointover) y). Definition hfiberpair { X Y : UU } (f:X -> Y) { y : Y } ( x : X ) ( e : paths ( f x ) y ) := tpair (fun pointover:X => paths (f pointover) y) x e . Definition hfiberpr1 { X Y : UU } ( f : X -> Y ) ( y : Y ) := @pr1 _ (fun pointover:X => paths (f pointover) y) . (** Paths in homotopy fibers. *) Lemma hfibertriangle1 { X Y : UU } (f:X -> Y) { y : Y } { xe1 xe2: hfiber f y } (e: paths xe1 xe2): paths (pr2 xe1) (pathscomp0 (maponpaths f (maponpaths ( @pr1 _ _ ) e)) (pr2 xe2)). Proof. intros. destruct e. simpl. apply idpath. Defined. Lemma hfibertriangle1inv0 { X Y : UU } (f:X -> Y) { y : Y } { xe1 xe2: hfiber f y } (e: paths xe1 xe2) : paths ( pathscomp0 ( maponpaths f ( pathsinv0 ( maponpaths ( @pr1 _ _ ) e ) ) ) ( pr2 xe1 ) ) ( pr2 xe2 ) . Proof . intros . destruct e . apply idpath . Defined . Lemma hfibertriangle2 { X Y : UU } (f:X -> Y) { y : Y } (xe1 xe2: hfiber f y) (ee: paths (pr1 xe1) (pr1 xe2))(eee: paths (pr2 xe1) (pathscomp0 (maponpaths f ee) (pr2 xe2))): paths xe1 xe2. Proof. intros. destruct xe1 as [ t e1 ]. destruct xe2. simpl in eee. simpl in ee. destruct ee. simpl in eee. apply (maponpaths (fun e: paths (f t) y => hfiberpair f t e) eee). Defined. (** Coconus of a function - the total space of the family of h-fibers. *) Definition coconusf { X Y : UU } (f: X -> Y):= total2 (fun y:_ => hfiber f y). Definition fromcoconusf { X Y : UU } (f: X -> Y) : coconusf f -> X := fun yxe:_ => pr1 (pr2 yxe). Definition tococonusf { X Y:UU } (f: X -> Y) : X -> coconusf f := fun x:_ => tpair _ (f x) (hfiberpair f x (idpath _ ) ). (** Total spaces of families and homotopies *) Definition famhomotfun { X : UU } { P Q : X -> UU } ( h : homot P Q ) ( xp : total2 P ) : total2 Q . Proof . intros. destruct xp as [ x p ] . split with x . destruct ( h x ) . apply p . Defined. Definition famhomothomothomot { X : UU } { P Q : X -> UU } ( h1 h2 : homot P Q ) ( H : forall x : X , paths ( h1 x ) ( h2 x ) ) : homot ( famhomotfun h1 ) ( famhomotfun h2 ) . Proof . intros . intro xp . destruct xp as [x p] . simpl . apply ( maponpaths ( fun q => tpair Q x q ) ) . destruct ( H x ) . apply idpath . Defined. (** ** Weak equivalences *) (** *** Basics *) Definition isweq { X Y : UU } ( f : X -> Y) : UU := forall y:Y, iscontr (hfiber f y) . Lemma idisweq (T:UU) : isweq (fun t:T => t). Proof. intros. unfold isweq. intro y . assert (y0: hfiber (fun t : T => t) y). apply (tpair (fun pointover:T => paths ((fun t:T => t) pointover) y) y (idpath y)). split with y0. intro t. destruct y0 as [x0 e0]. destruct t as [x1 e1]. destruct e0. destruct e1. apply idpath. Defined. Definition weq ( X Y : UU ) : UU := total2 (fun f:X->Y => isweq f) . Definition pr1weq ( X Y : UU):= @pr1 _ _ : weq X Y -> (X -> Y). Coercion pr1weq : weq >-> Funclass. Definition weqpair { X Y : UU } (f:X-> Y) (is: isweq f) : weq X Y := tpair (fun f:X->Y => isweq f) f is. Definition idweq (X:UU) : weq X X := tpair (fun f:X->X => isweq f) (fun x:X => x) ( idisweq X ) . Definition isweqtoempty { X : UU } (f : X -> empty ) : isweq f. Proof. intros. intro y. apply (fromempty y). Defined. Definition weqtoempty { X : UU } ( f : X -> empty ) := weqpair _ ( isweqtoempty f ) . Lemma isweqtoempty2 { X Y : UU } ( f : X -> Y ) ( is : neg Y ) : isweq f . Proof. intros . intro y . destruct ( is y ) . Defined . Definition weqtoempty2 { X Y : UU } ( f : X -> Y ) ( is : neg Y ) := weqpair _ ( isweqtoempty2 f is ) . Definition invmap { X Y : UU } ( w : weq X Y ) : Y -> X . Proof. intros X Y w y . apply (pr1 (pr1 ( pr2 w y ))). Defined. (** We now define different homotopies and maps between the paths spaces corresponding to a weak equivalence. What may look like unnecessary complexity in the definition of [ weqgf ] is due to the fact that the "naive" definition, that of [ weqgf00 ], needs to be corrected in order for lemma [ weqfgf ] to hold. *) Definition homotweqinvweq { T1 T2 : UU } ( w : weq T1 T2 ) : forall t2:T2, paths ( w ( invmap w t2 ) ) t2. Proof. intros. unfold invmap. simpl. apply (pr2 (pr1 ( pr2 w t2 ) ) ) . Defined. Definition homotinvweqweq0 { X Y : UU } ( w : weq X Y ) ( x : X ) : paths x ( invmap w ( w x ) ) . Proof. intros. set (isfx:= ( pr2 w ( w x ) ) ). set (pr1fx:= @pr1 X (fun x':X => paths ( w x' ) ( w x ))). set (xe1:= (hfiberpair w x (idpath ( w x)))). apply (maponpaths pr1fx (pr2 isfx xe1)). Defined. Definition homotinvweqweq { X Y : UU } ( w : weq X Y ) ( x : X ) : paths (invmap w ( w x ) ) x := pathsinv0 (homotinvweqweq0 w x). Lemma diaglemma2 { X Y : UU } (f:X -> Y) { x x':X } (e1: paths x x')(e2: paths (f x') (f x)) (ee: paths (idpath (f x)) (pathscomp0 (maponpaths f e1) e2)): paths (maponpaths f (pathsinv0 e1)) e2. Proof. intros. destruct e1. simpl. simpl in ee. assumption. Defined. Definition homotweqinvweqweq { X Y : UU } ( w : weq X Y ) ( x : X ) : paths (maponpaths w (homotinvweqweq w x)) (homotweqinvweq w ( w x)). Proof. intros. set (xe1:= hfiberpair w x (idpath (w x))). set (isfx:= ( pr2 w ) (w x)). set (xe2:= pr1 isfx). set (e:= pr2 isfx xe1). set (ee:=hfibertriangle1 w e). simpl in ee. apply (diaglemma2 w (homotinvweqweq0 w x) ( homotweqinvweq w ( w x ) ) ee ). Defined. Definition invmaponpathsweq { X Y : UU } ( w : weq X Y ) ( x x' : X ) : paths (w x) (w x') -> paths x x':= pathssec2 w (invmap w ) (homotinvweqweq w ) _ _ . Definition invmaponpathsweqid { X Y : UU } ( w : weq X Y ) ( x : X ) : paths (invmaponpathsweq w _ _ (idpath (w x))) (idpath x):= pathssec2id w (invmap w ) (homotinvweqweq w ) x. Definition pathsweq1 { X Y : UU } ( w : weq X Y ) ( x : X ) ( y : Y ) : paths (w x) y -> paths x (invmap w y) := pathssec1 w (invmap w ) (homotinvweqweq w ) _ _ . Definition pathsweq1' { X Y : UU } ( w : weq X Y ) ( x : X ) ( y : Y ) : paths x (invmap w y) -> paths ( w x ) y := fun e:_ => pathscomp0 (maponpaths w e) (homotweqinvweq w y). Definition pathsweq3 { X Y : UU } ( w : weq X Y ) { x x' : X } ( e : paths x x' ) : paths (invmaponpathsweq w x x' (maponpaths w e)) e:= pathssec3 w (invmap w ) (homotinvweqweq w ) _ . Definition pathsweq4 { X Y : UU } ( w : weq X Y ) ( x x' : X ) ( e : paths ( w x ) ( w x' )) : paths (maponpaths w (invmaponpathsweq w x x' e)) e. Proof. intros. destruct w as [ f is1 ] . set ( w := weqpair f is1 ) . set (g:=invmap w ). set (gf:= fun x:X => (g (f x))). set (ee:= maponpaths g e). set (eee:= maponpathshomidinv gf (homotinvweqweq w ) x x' ee ). assert (e1: paths (maponpaths f eee) e). assert (e2: paths (maponpaths g (maponpaths f eee)) (maponpaths g e)). assert (e3: paths (maponpaths g (maponpaths f eee)) (maponpaths gf eee)). apply maponpathscomp. assert (e4: paths (maponpaths gf eee) ee). apply maponpathshomid2. apply (pathscomp0 e3 e4). set (s:= @maponpaths _ _ g (f x) (f x')). set (p:= @pathssec2 _ _ g f (homotweqinvweq w ) (f x) (f x')). set (eps:= @pathssec3 _ _ g f (homotweqinvweq w ) (f x) (f x')). apply (pathssec2 s p eps _ _ e2 ). assert (e5: paths (maponpaths f (invmaponpathsweq w x x' e)) (maponpaths f (invmaponpathsweq w x x' (maponpaths f eee)))). apply (pathsinv0 (maponpaths (fun e0: paths (f x) (f x') => (maponpaths f (invmaponpathsweq w x x' e0))) e1)). assert (X0: paths (invmaponpathsweq w x x' (maponpaths f eee)) eee). apply (pathsweq3 w ). assert (e6: paths (maponpaths f (invmaponpathsweq w x x' (maponpaths f eee))) (maponpaths f eee)). apply (maponpaths (fun eee0: paths x x' => maponpaths f eee0) X0). set (e7:= pathscomp0 e5 e6). set (pathscomp0 e7 e1). assumption. Defined. (** *** Weak equivalences between contractible types (other implications are proved below) *) Lemma iscontrweqb { X Y : UU } ( w : weq X Y ) ( is : iscontr Y ) : iscontr X. Proof. intros . apply ( iscontrretract (invmap w ) w (homotinvweqweq w ) is ). Defined. (** *** Functions between fibers defined by a path on the base are weak equivalences *) Lemma isweqtransportf { X : UU } (P:X -> UU) { x x' : X } (e:paths x x'): isweq (transportf P e). Proof. intros. destruct e. apply idisweq. Defined. Lemma isweqtransportb { X : UU } (P:X -> UU) { x x' : X } (e:paths x x'): isweq (transportb P e). Proof. intros. apply (isweqtransportf _ (pathsinv0 e)). Defined. (** *** [ unit ] and contractibility *) (** [ unit ] is contractible (recall that [ tt ] is the name of the canonical term of the type [ unit ]). *) Lemma unitl0: paths tt tt -> coconustot _ tt. Proof. intros X. apply (coconustotpair _ X). Defined. Lemma unitl1: coconustot _ tt -> paths tt tt. Proof. intro X. destruct X as [ x t ]. destruct x. assumption. Defined. Lemma unitl2: forall e: paths tt tt, paths (unitl1 (unitl0 e)) e. Proof. intros. unfold unitl0. simpl. apply idpath. Defined. Lemma unitl3: forall e:paths tt tt, paths e (idpath tt). Proof. intros. assert (e0: paths (unitl0 (idpath tt)) (unitl0 e)). eapply connectedcoconustot. assert (e1:paths (unitl1 (unitl0 (idpath tt))) (unitl1 (unitl0 e))). apply (maponpaths unitl1 e0). assert (e2: paths (unitl1 (unitl0 e)) e). eapply unitl2. assert (e3: paths (unitl1 (unitl0 (idpath tt))) (idpath tt)). eapply unitl2. destruct e1. clear e0. destruct e2. assumption. Defined. Theorem iscontrunit: iscontr (unit). Proof. assert (pp:forall x:unit, paths x tt). intros. destruct x. apply (idpath _). apply (tpair (fun cntr:unit => forall t:unit, paths t cntr) tt pp). Defined. (** [ paths ] in [ unit ] are contractible. *) Theorem iscontrpathsinunit ( x x' : unit ) : iscontr ( paths x x' ) . Proof. intros . assert (c:paths x x'). destruct x. destruct x'. apply idpath. assert (X: forall g:paths x x', paths g c). intro. assert (e:paths c c). apply idpath. destruct c. destruct x. apply unitl3. apply (iscontrpair c X). Defined. (** A type [ T : UU ] is contractible if and only if [ T -> unit ] is a weak equivalence. *) Lemma ifcontrthenunitl0 ( e1 e2 : paths tt tt ) : paths e1 e2. Proof. intros. assert (e3: paths e1 (idpath tt) ). apply unitl3. assert (e4: paths e2 (idpath tt)). apply unitl3. destruct e3. destruct e4. apply idpath. Defined. Lemma isweqcontrtounit { T : UU } (is : iscontr T) : (isweq (fun t:T => tt)). Proof. intros T X. unfold isweq. intro y. destruct y. assert (c: hfiber (fun x:T => tt) tt). destruct X as [ t x0 ]. eapply (hfiberpair _ t (idpath tt)). assert (e: forall d: (hfiber (fun x:T => tt) tt), paths d c). intros. destruct c as [ t x] . destruct d as [ t0 x0 ]. assert (e': paths x x0). apply ifcontrthenunitl0 . assert (e'': paths t t0). destruct X as [t1 x1 ]. assert (e''': paths t t1). apply x1. assert (e'''': paths t0 t1). apply x1. destruct e''''. assumption. destruct e''. destruct e'. apply idpath. apply (iscontrpair c e). Defined. Definition weqcontrtounit { T : UU } ( is : iscontr T ) := weqpair _ ( isweqcontrtounit is ) . Theorem iscontrifweqtounit { X : UU } ( w : weq X unit ) : iscontr X. Proof. intros X X0. apply (iscontrweqb X0 ). apply iscontrunit. Defined. (** *** A homotopy equivalence is a weak equivalence *) Definition hfibersgftog { X Y Z : UU } (f:X -> Y) (g: Y -> Z) (z:Z) ( xe : hfiber (fun x:X => g(f x)) z ) : hfiber g z := hfiberpair g ( f ( pr1 xe ) ) ( pr2 xe ) . Lemma constr2 { X Y : UU } (f:X -> Y)(g: Y-> X) (efg: forall y:Y, paths (f(g y)) y) ( x0 : X) ( z0 : hfiber g x0 ) : total2 (fun z': hfiber (fun x:X => g (f x)) x0 => paths z0 (hfibersgftog f g x0 z')). Proof. intros. destruct z0 as [ y e ]. assert (eint: paths y (f x0 )). assert (e0: paths (f(g y)) y). apply efg. assert (e1: paths (f(g y)) (f x0 )). apply (maponpaths f e). destruct e1. apply pathsinv0. assumption. set (int1:=constr1 (fun y:Y => paths (g y) x0 ) eint). destruct int1 as [ t x ]. set (int2:=hfiberpair (fun x0 : X => g (f x0)) x0 (t e)). split with int2. apply x. Defined. Lemma iscontrhfiberl1 { X Y : UU } (f:X -> Y) (g: Y-> X) (efg: forall y:Y, paths (f(g y)) y) (x0 : X): iscontr (hfiber (fun x:X => g (f x)) x0 ) ->iscontr (hfiber g x0). Proof. intros X Y f g efg x0 X0. set (X1:= hfiber (fun x:X => g(f x)) x0 ). set (Y1:= hfiber g x0 ). set (f1:= hfibersgftog f g x0 ). set (g1:= fun z0:_ => pr1 (constr2 f g efg x0 z0)). set (efg1:= (fun y1:Y1 => pathsinv0 ( pr2 (constr2 f g efg x0 y1 ) ) ) ) . simpl in efg1. apply ( iscontrretract f1 g1 efg1). assumption. Defined. Lemma iscontrhfiberl2 { X Y : UU } ( f1 f2 : X-> Y) (h: forall x:X, paths (f2 x) (f1 x)) (y:Y): iscontr (hfiber f2 y) -> iscontr (hfiber f1 y). Proof. intros X Y f1 f2 h y X0. set (f:= (fun z:(hfiber f1 y) => match z with (tpair x e) => hfiberpair f2 x (pathscomp0 (h x) e) end)). set (g:= (fun z:(hfiber f2 y) => match z with (tpair x e) => hfiberpair f1 x (pathscomp0 (pathsinv0 (h x)) e) end)). assert (egf: forall z:(hfiber f1 y), paths (g (f z)) z). intros. destruct z as [ x e ]. simpl . apply ( hfibertriangle2 _ (hfiberpair f1 x (pathscomp0 (pathsinv0 (h x)) (pathscomp0 (h x) e))) ( hfiberpair f1 x e ) ( idpath x ) ) . simpl . destruct e . destruct ( h x ) . apply idpath . apply ( iscontrretract g f egf X0). Defined. Corollary isweqhomot { X Y : UU } ( f1 f2 : X-> Y ) (h: forall x:X, paths (f1 x) (f2 x)): isweq f1 -> isweq f2. Proof. intros X Y f1 f2 h X0. unfold isweq. intro y. set (Y0:= X0 y). apply (iscontrhfiberl2 f2 f1 h). assumption. Defined. Theorem gradth { X Y : UU } (f:X->Y) (g:Y->X) (egf: forall x:X, paths (g (f x)) x) (efg: forall y:Y, paths (f (g y)) y ): isweq f. Proof. intros. unfold isweq. intro z. assert (iscontr (hfiber (fun y:Y => (f (g y))) z)). assert (efg': forall y:Y, paths y (f (g y))). intros. set (e1:= efg y). apply pathsinv0. assumption. apply (iscontrhfiberl2 (fun y:Y => (f (g y))) (fun y:Y => y) efg' z (idisweq Y z)). apply (iscontrhfiberl1 g f egf z). assumption. Defined. Definition weqgradth { X Y : UU } (f:X->Y) (g:Y->X) (egf: forall x:X, paths (g (f x)) x) (efg: forall y:Y, paths (f (g y)) y ) : weq X Y := weqpair _ ( gradth _ _ egf efg ) . (** *** Some basic weak equivalences *) Corollary isweqinvmap { X Y : UU } ( w : weq X Y ) : isweq (invmap w ). Proof. intros. set (invf:= invmap w ). assert (efinvf: forall y:Y, paths ( w (invf y)) y). apply homotweqinvweq. assert (einvff: forall x:X, paths (invf ( w x)) x). apply homotinvweqweq. apply ( gradth _ _ efinvf einvff ) . Defined. Definition invweq { X Y : UU } ( w : weq X Y ) : weq Y X := weqpair (invmap w ) (isweqinvmap w ). Corollary invinv { X Y :UU } ( w : weq X Y ) ( x : X ) : paths ( invweq ( invweq w ) x) (w x). Proof. intros. unfold invweq . unfold invmap . simpl . apply idpath . Defined . Corollary iscontrweqf { X Y : UU } ( w : weq X Y ) : iscontr X -> iscontr Y. Proof. intros X Y w X0 . apply (iscontrweqb ( invweq w ) ). assumption. Defined. (** The standard weak equivalence from [ unit ] to a contractible type *) Definition wequnittocontr { X : UU } ( is : iscontr X ) : weq unit X . Proof . intros . set ( f := fun t : unit => pr1 is ) . set ( g := fun x : X => tt ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a )) a ) . intro . destruct a . apply idpath . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro . simpl . apply ( pathsinv0 ( pr2 is a ) ) . apply ( gradth _ _ egf efg ) . Defined . (** A weak equivalence bwteen types defines weak equivalences on the corresponding [ paths ] types. *) Corollary isweqmaponpaths { X Y : UU } ( w : weq X Y ) ( x x' : X ) : isweq (@maponpaths _ _ w x x'). Proof. intros. apply (gradth (@maponpaths _ _ w x x') (@invmaponpathsweq _ _ w x x') (@pathsweq3 _ _ w x x') (@pathsweq4 _ _ w x x')). Defined. Definition weqonpaths { X Y : UU } ( w : weq X Y ) ( x x' : X ) := weqpair _ ( isweqmaponpaths w x x' ) . Corollary isweqpathsinv0 { X : UU } (x x':X): isweq (@pathsinv0 _ x x'). Proof. intros. apply (gradth (@pathsinv0 _ x x') (@pathsinv0 _ x' x) (@pathsinv0inv0 _ _ _ ) (@pathsinv0inv0 _ _ _ )). Defined. Definition weqpathsinv0 { X : UU } ( x x' : X ) := weqpair _ ( isweqpathsinv0 x x' ) . Corollary isweqpathscomp0r { X : UU } (x : X ) { x' x'' : X } (e': paths x' x''): isweq (fun e:paths x x' => pathscomp0 e e'). Proof. intros. set (f:= fun e:paths x x' => pathscomp0 e e'). set (g:= fun e'': paths x x'' => pathscomp0 e'' (pathsinv0 e')). assert (egf: forall e:_ , paths (g (f e)) e). intro. destruct e. simpl. destruct e'. simpl. apply idpath. assert (efg: forall e'':_, paths (f (g e'')) e''). intro. destruct e''. simpl. destruct e'. simpl. apply idpath. apply (gradth f g egf efg). Defined. Corollary isweqtococonusf { X Y : UU } (f:X-> Y): isweq ( tococonusf f) . Proof . intros. set (ff:= fromcoconusf f). set (gg:= tococonusf f). assert (egf: forall yxe:_, paths (gg (ff yxe)) yxe). intro. destruct yxe as [t x]. destruct x as [ x e ]. unfold gg. unfold tococonusf. unfold ff. unfold fromcoconusf. simpl. destruct e. apply idpath. assert (efg: forall x:_, paths (ff (gg x)) x). intro. apply idpath. apply (gradth _ _ efg egf ). Defined. Definition weqtococonusf { X Y : UU } ( f : X -> Y ) : weq X ( coconusf f ) := weqpair _ ( isweqtococonusf f ) . Corollary isweqfromcoconusf { X Y : UU } (f:X-> Y): isweq (fromcoconusf f). Proof. intros. set (ff:= fromcoconusf f). set (gg:= tococonusf f). assert (egf: forall yxe:_, paths (gg (ff yxe)) yxe). intro. destruct yxe as [t x]. destruct x as [ x e ]. unfold gg. unfold tococonusf. unfold ff. unfold fromcoconusf. simpl. destruct e. apply idpath. assert (efg: forall x:_, paths (ff (gg x)) x). intro. apply idpath. apply (gradth _ _ egf efg). Defined. Definition weqfromcoconusf { X Y : UU } ( f : X -> Y ) : weq ( coconusf f ) X := weqpair _ ( isweqfromcoconusf f ) . Corollary isweqdeltap (T:UU) : isweq (deltap T). Proof. intros. set (ff:=deltap T). set (gg:= fun z:pathsspace T => pr1 z). assert (egf: forall t:T, paths (gg (ff t)) t). intro. apply idpath. assert (efg: forall tte: pathsspace T, paths (ff (gg tte)) tte). intro. destruct tte as [ t x ]. destruct x as [ x0 e ]. destruct e. apply idpath. apply (gradth _ _ egf efg). Defined. Corollary isweqpr1pr1 (T:UU) : isweq (fun a: pathsspace' T => (pr1 (pr1 a))). Proof. intros. set (f:= (fun a:_ => (pr1 (pr1 a))): pathsspace' T -> T). set (g:= (fun t:T => tpair _ (dirprodpair t t) (idpath t)): T -> pathsspace' T). assert (efg: forall t:T, paths (f (g t)) t). intro. apply idpath. assert (egf: forall a: pathsspace' T, paths (g (f a)) a). intro. destruct a as [ t x ]. destruct t. destruct x. simpl. apply idpath. apply (gradth _ _ egf efg). Defined. Lemma hfibershomotftog { X Y : UU } ( f g : X -> Y ) ( h : forall x : X , paths ( f x ) ( g x ) ) ( y : Y ) : hfiber f y -> hfiber g y . Proof. intros X Y f g h y xe . destruct xe as [ x e ] . split with x . apply ( pathscomp0 ( pathsinv0 ( h x ) ) e ) . Defined . Lemma hfibershomotgtof { X Y : UU } ( f g : X -> Y ) ( h : forall x : X , paths ( f x ) ( g x ) ) ( y : Y ) : hfiber g y -> hfiber f y . Proof. intros X Y f g h y xe . destruct xe as [ x e ] . split with x . apply ( pathscomp0 ( h x ) e ) . Defined . Theorem weqhfibershomot { X Y : UU } ( f g : X -> Y ) ( h : forall x : X , paths ( f x ) ( g x ) ) ( y : Y ) : weq ( hfiber f y ) ( hfiber g y ) . Proof . intros . set ( ff := hfibershomotftog f g h y ) . set ( gg := hfibershomotgtof f g h y ) . split with ff . assert ( effgg : forall xe : _ , paths ( ff ( gg xe ) ) xe ) . intro . destruct xe as [ x e ] . simpl . assert ( eee: paths ( pathscomp0 (pathsinv0 (h x)) (pathscomp0 (h x) e) ) (pathscomp0 (maponpaths g ( idpath x ) ) e ) ) . simpl . destruct e . destruct ( h x ) . simpl . apply idpath . set ( xe1 := hfiberpair g x ( pathscomp0 (pathsinv0 (h x)) (pathscomp0 (h x) e) ) ) . set ( xe2 := hfiberpair g x e ) . apply ( hfibertriangle2 g xe1 xe2 ( idpath x ) eee ) . assert ( eggff : forall xe : _ , paths ( gg ( ff xe ) ) xe ) . intro . destruct xe as [ x e ] . simpl . assert ( eee: paths ( pathscomp0 (h x) (pathscomp0 (pathsinv0 (h x)) e) ) (pathscomp0 (maponpaths f ( idpath x ) ) e ) ) . simpl . destruct e . destruct ( h x ) . simpl . apply idpath . set ( xe1 := hfiberpair f x ( pathscomp0 (h x) (pathscomp0 (pathsinv0 (h x)) e) ) ) . set ( xe2 := hfiberpair f x e ) . apply ( hfibertriangle2 f xe1 xe2 ( idpath x ) eee ) . apply ( gradth _ _ eggff effgg ) . Defined . (** *** The 2-out-of-3 property of weak equivalences. Theorems showing that if any two of three functions f, g, gf are weak equivalences then so is the third - the 2-out-of-3 property. *) Theorem twooutof3a { X Y Z : UU } (f:X->Y) (g:Y->Z) (isgf: isweq (fun x:X => g (f x))) (isg: isweq g) : isweq f. Proof. intros. set ( gw := weqpair g isg ) . set ( gfw := weqpair _ isgf ) . set (invg:= invmap gw ). set (invgf:= invmap gfw ). set (invf := (fun y:Y => invgf (g y))). assert (efinvf: forall y:Y, paths (f (invf y)) y). intro. assert (int1: paths (g (f (invf y))) (g y)). unfold invf. apply (homotweqinvweq gfw ( g y ) ). apply (invmaponpathsweq gw _ _ int1). assert (einvff: forall x: X, paths (invf (f x)) x). intro. unfold invf. apply (homotinvweqweq gfw x). apply (gradth f invf einvff efinvf). Defined. Corollary isweqcontrcontr { X Y : UU } (f:X -> Y) (isx: iscontr X) (isy: iscontr Y): isweq f. Proof. intros. set (py:= (fun y:Y => tt)). apply (twooutof3a f py (isweqcontrtounit isx) (isweqcontrtounit isy)). Defined. Definition weqcontrcontr { X Y : UU } ( isx : iscontr X) (isy: iscontr Y) := weqpair _ ( isweqcontrcontr ( fun x : X => pr1 isy ) isx isy ) . Theorem twooutof3b { X Y Z : UU } (f:X->Y) (g:Y->Z) (isf: isweq f) (isgf: isweq (fun x:X => g(f x))) : isweq g. Proof. intros. set ( wf := weqpair f isf ) . set ( wgf := weqpair _ isgf ) . set (invf:= invmap wf ). set (invgf:= invmap wgf ). set (invg := (fun z:Z => f ( invgf z))). set (gf:= fun x:X => (g (f x))). assert (eginvg: forall z:Z, paths (g (invg z)) z). intro. apply (homotweqinvweq wgf z). assert (einvgg: forall y:Y, paths (invg (g y)) y). intro. assert (isinvf: isweq invf). apply isweqinvmap. assert (isinvgf: isweq invgf). apply isweqinvmap. assert (int1: paths (g y) (gf (invf y))). apply (maponpaths g (pathsinv0 (homotweqinvweq wf y))). assert (int2: paths (gf (invgf (g y))) (gf (invf y))). assert (int3: paths (gf (invgf (g y))) (g y)). apply (homotweqinvweq wgf ). destruct int1. assumption. assert (int4: paths (invgf (g y)) (invf y)). apply (invmaponpathsweq wgf ). assumption. assert (int5:paths (invf (f (invgf (g y)))) (invgf (g y))). apply (homotinvweqweq wf ). assert (int6: paths (invf (f (invgf (g (y))))) (invf y)). destruct int4. assumption. apply (invmaponpathsweq ( weqpair invf isinvf ) ). assumption. apply (gradth g invg einvgg eginvg). Defined. Lemma isweql3 { X Y : UU } (f:X-> Y) (g:Y->X) (egf: forall x:X, paths (g (f x)) x): isweq f -> isweq g. Proof. intros X Y f g egf X0. set (gf:= fun x:X => g (f x)). assert (int1: isweq gf). apply (isweqhomot (fun x:X => x) gf (fun x:X => (pathsinv0 (egf x)))). apply idisweq. apply (twooutof3b f g X0 int1). Defined. Theorem twooutof3c { X Y Z : UU } (f:X->Y) (g:Y->Z) (isf: isweq f) (isg: isweq g) : isweq (fun x:X => g(f x)). Proof. intros. set ( wf := weqpair f isf ) . set ( wg := weqpair _ isg ) . set (gf:= fun x:X => g (f x)). set (invf:= invmap wf ). set (invg:= invmap wg ). set (invgf:= fun z:Z => invf (invg z)). assert (egfinvgf: forall x:X, paths (invgf (gf x)) x). unfold gf. unfold invgf. intro x. assert (int1: paths (invf (invg (g (f x)))) (invf (f x))). apply (maponpaths invf (homotinvweqweq wg (f x))). assert (int2: paths (invf (f x)) x). apply homotinvweqweq. destruct int1. assumption. assert (einvgfgf: forall z:Z, paths (gf (invgf z)) z). unfold gf. unfold invgf. intro z. assert (int1: paths (g (f (invf (invg z)))) (g (invg z))). apply (maponpaths g (homotweqinvweq wf (invg z))). assert (int2: paths (g (invg z)) z). apply (homotweqinvweq wg z). destruct int1. assumption. apply (gradth gf invgf egfinvgf einvgfgf). Defined. Definition weqcomp { X Y Z : UU } (w1 : weq X Y) (w2 : weq Y Z) : (weq X Z) := weqpair (fun x:X => (pr1 w2 (pr1 w1 x))) (twooutof3c _ _ (pr2 w1) (pr2 w2)). (** *** Associativity of [ total2 ] *) Lemma total2asstor { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) : total2 Q -> total2 ( fun x : X => total2 ( fun p : P x => Q ( tpair P x p ) ) ) . Proof. intros X P Q xpq . destruct xpq as [ xp q ] . destruct xp as [ x p ] . split with x . split with p . assumption . Defined . Lemma total2asstol { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) : total2 ( fun x : X => total2 ( fun p : P x => Q ( tpair P x p ) ) ) -> total2 Q . Proof. intros X P Q xpq . destruct xpq as [ x pq ] . destruct pq as [ p q ] . split with ( tpair P x p ) . assumption . Defined . Theorem weqtotal2asstor { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) : weq ( total2 Q ) ( total2 ( fun x : X => total2 ( fun p : P x => Q ( tpair P x p ) ) ) ). Proof. intros . set ( f := total2asstor P Q ) . set ( g:= total2asstol P Q ) . split with f . assert ( egf : forall xpq : _ , paths ( g ( f xpq ) ) xpq ) . intro . destruct xpq as [ xp q ] . destruct xp as [ x p ] . apply idpath . assert ( efg : forall xpq : _ , paths ( f ( g xpq ) ) xpq ) . intro . destruct xpq as [ x pq ] . destruct pq as [ p q ] . apply idpath . apply ( gradth _ _ egf efg ) . Defined. Definition weqtotal2asstol { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) : weq ( total2 ( fun x : X => total2 ( fun p : P x => Q ( tpair P x p ) ) ) ) ( total2 Q ) := invweq ( weqtotal2asstor P Q ) . (** *** Associativity and commutativity of [ dirprod ] *) Definition weqdirprodasstor ( X Y Z : UU ) : weq ( dirprod ( dirprod X Y ) Z ) ( dirprod X ( dirprod Y Z ) ) . Proof . intros . apply weqtotal2asstor . Defined . Definition weqdirprodasstol ( X Y Z : UU ) : weq ( dirprod X ( dirprod Y Z ) ) ( dirprod ( dirprod X Y ) Z ) := invweq ( weqdirprodasstor X Y Z ) . Definition weqdirprodcomm ( X Y : UU ) : weq ( dirprod X Y ) ( dirprod Y X ) . Proof. intros . set ( f := fun xy : dirprod X Y => dirprodpair ( pr2 xy ) ( pr1 xy ) ) . set ( g := fun yx : dirprod Y X => dirprodpair ( pr2 yx ) ( pr1 yx ) ) . assert ( egf : forall xy : _ , paths ( g ( f xy ) ) xy ) . intro . destruct xy . apply idpath . assert ( efg : forall yx : _ , paths ( f ( g yx ) ) yx ) . intro . destruct yx . apply idpath . split with f . apply ( gradth _ _ egf efg ) . Defined . (** *** Coproducts and direct products *) Definition rdistrtocoprod ( X Y Z : UU ): dirprod X (coprod Y Z) -> coprod (dirprod X Y) (dirprod X Z). Proof. intros X Y Z X0. destruct X0 as [ t x ]. destruct x as [ y | z ] . apply (ii1 (dirprodpair t y)). apply (ii2 (dirprodpair t z)). Defined. Definition rdistrtoprod (X Y Z:UU): coprod (dirprod X Y) (dirprod X Z) -> dirprod X (coprod Y Z). Proof. intros X Y Z X0. destruct X0 as [ d | d ]. destruct d as [ t x ]. apply (dirprodpair t (ii1 x)). destruct d as [ t x ]. apply (dirprodpair t (ii2 x)). Defined. Theorem isweqrdistrtoprod (X Y Z:UU): isweq (rdistrtoprod X Y Z). Proof. intros. set (f:= rdistrtoprod X Y Z). set (g:= rdistrtocoprod X Y Z). assert (egf: forall a:_, paths (g (f a)) a). intro. destruct a as [ d | d ] . destruct d. apply idpath. destruct d. apply idpath. assert (efg: forall a:_, paths (f (g a)) a). intro. destruct a as [ t x ]. destruct x. apply idpath. apply idpath. apply (gradth f g egf efg). Defined. Definition weqrdistrtoprod (X Y Z: UU):= weqpair _ (isweqrdistrtoprod X Y Z). Corollary isweqrdistrtocoprod (X Y Z:UU): isweq (rdistrtocoprod X Y Z). Proof. intros. apply (isweqinvmap ( weqrdistrtoprod X Y Z ) ) . Defined. Definition weqrdistrtocoprod (X Y Z: UU):= weqpair _ (isweqrdistrtocoprod X Y Z). (** *** Total space of a family over a coproduct *) Definition fromtotal2overcoprod { X Y : UU } ( P : coprod X Y -> UU ) ( xyp : total2 P ) : coprod ( total2 ( fun x : X => P ( ii1 x ) ) ) ( total2 ( fun y : Y => P ( ii2 y ) ) ) . Proof. intros . set ( PX := fun x : X => P ( ii1 x ) ) . set ( PY := fun y : Y => P ( ii2 y ) ) . destruct xyp as [ xy p ] . destruct xy as [ x | y ] . apply ( ii1 ( tpair PX x p ) ) . apply ( ii2 ( tpair PY y p ) ) . Defined . Definition tototal2overcoprod { X Y : UU } ( P : coprod X Y -> UU ) ( xpyp : coprod ( total2 ( fun x : X => P ( ii1 x ) ) ) ( total2 ( fun y : Y => P ( ii2 y ) ) ) ) : total2 P . Proof . intros . destruct xpyp as [ xp | yp ] . destruct xp as [ x p ] . apply ( tpair P ( ii1 x ) p ) . destruct yp as [ y p ] . apply ( tpair P ( ii2 y ) p ) . Defined . Theorem weqtotal2overcoprod { X Y : UU } ( P : coprod X Y -> UU ) : weq ( total2 P ) ( coprod ( total2 ( fun x : X => P ( ii1 x ) ) ) ( total2 ( fun y : Y => P ( ii2 y ) ) ) ) . Proof. intros . set ( f := fromtotal2overcoprod P ) . set ( g := tototal2overcoprod P ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . destruct a as [ xy p ] . destruct xy as [ x | y ] . simpl . apply idpath . simpl . apply idpath . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . destruct a as [ xp | yp ] . destruct xp as [ x p ] . simpl . apply idpath . destruct yp as [ y p ] . apply idpath . apply ( gradth _ _ egf efg ) . Defined . (** *** Weak equivalences and pairwise direct products *) Theorem isweqdirprodf { X Y X' Y' : UU } ( w : weq X Y )( w' : weq X' Y' ) : isweq (dirprodf w w' ). Proof. intros. set ( f := dirprodf w w' ) . set ( g := dirprodf ( invweq w ) ( invweq w' ) ) . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . destruct a as [ x x' ] . simpl . apply pathsdirprod . apply ( homotinvweqweq w x ) . apply ( homotinvweqweq w' x' ) . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . destruct a as [ x x' ] . simpl . apply pathsdirprod . apply ( homotweqinvweq w x ) . apply ( homotweqinvweq w' x' ) . apply ( gradth _ _ egf efg ) . Defined . Definition weqdirprodf { X Y X' Y' : UU } ( w : weq X Y ) ( w' : weq X' Y' ) := weqpair _ ( isweqdirprodf w w' ) . Definition weqtodirprodwithunit (X:UU): weq X (dirprod X unit). Proof. intros. set (f:=fun x:X => dirprodpair x tt). split with f. set (g:= fun xu:dirprod X unit => pr1 xu). assert (egf: forall x:X, paths (g (f x)) x). intro. apply idpath. assert (efg: forall xu:_, paths (f (g xu)) xu). intro. destruct xu as [ t x ]. destruct x. apply idpath. apply (gradth f g egf efg). Defined. (** *** Basics on pairwise coproducts (disjoint unions) *) (** In the current version [ coprod ] is a notation, introduced in uuu.v for [ sum ] of types which is defined in Coq.Init *) Definition sumofmaps {X Y Z:UU}(fx: X -> Z)(fy: Y -> Z): (coprod X Y) -> Z := fun xy:_ => match xy with ii1 x => fx x | ii2 y => fy y end. Definition boolascoprod: weq (coprod unit unit) bool. Proof. set (f:= fun xx: coprod unit unit => match xx with ii1 t => true | ii2 t => false end). split with f. set (g:= fun t:bool => match t with true => ii1 tt | false => ii2 tt end). assert (egf: forall xx:_, paths (g (f xx)) xx). intro xx . destruct xx as [ u | u ] . destruct u. apply idpath. destruct u. apply idpath. assert (efg: forall t:_, paths (f (g t)) t). destruct t. apply idpath. apply idpath. apply (gradth f g egf efg). Defined. Definition coprodasstor (X Y Z:UU): coprod (coprod X Y) Z -> coprod X (coprod Y Z). Proof. intros X Y Z X0. destruct X0 as [ c | z ] . destruct c as [ x | y ] . apply (ii1 x). apply (ii2 (ii1 y)). apply (ii2 (ii2 z)). Defined. Definition coprodasstol (X Y Z: UU): coprod X (coprod Y Z) -> coprod (coprod X Y) Z. Proof. intros X Y Z X0. destruct X0 as [ x | c ] . apply (ii1 (ii1 x)). destruct c as [ y | z ] . apply (ii1 (ii2 y)). apply (ii2 z). Defined. Theorem isweqcoprodasstor (X Y Z:UU): isweq (coprodasstor X Y Z). Proof. intros. set (f:= coprodasstor X Y Z). set (g:= coprodasstol X Y Z). assert (egf: forall xyz:_, paths (g (f xyz)) xyz). intro xyz. destruct xyz as [ c | z ] . destruct c. apply idpath. apply idpath. apply idpath. assert (efg: forall xyz:_, paths (f (g xyz)) xyz). intro xyz. destruct xyz as [ x | c ] . apply idpath. destruct c. apply idpath. apply idpath. apply (gradth f g egf efg). Defined. Definition weqcoprodasstor ( X Y Z : UU ) := weqpair _ ( isweqcoprodasstor X Y Z ) . Corollary isweqcoprodasstol (X Y Z:UU): isweq (coprodasstol X Y Z). Proof. intros. apply (isweqinvmap ( weqcoprodasstor X Y Z) ). Defined. Definition weqcoprodasstol (X Y Z:UU):= weqpair _ (isweqcoprodasstol X Y Z). Definition coprodcomm (X Y:UU): coprod X Y -> coprod Y X := fun xy:_ => match xy with ii1 x => ii2 x | ii2 y => ii1 y end. Theorem isweqcoprodcomm (X Y:UU): isweq (coprodcomm X Y). Proof. intros. set (f:= coprodcomm X Y). set (g:= coprodcomm Y X). assert (egf: forall xy:_, paths (g (f xy)) xy). intro. destruct xy. apply idpath. apply idpath. assert (efg: forall yx:_, paths (f (g yx)) yx). intro. destruct yx. apply idpath. apply idpath. apply (gradth f g egf efg). Defined. Definition weqcoprodcomm (X Y:UU):= weqpair _ (isweqcoprodcomm X Y). Theorem isweqii1withneg (X : UU) { Y : UU } (nf:Y -> empty): isweq (@ii1 X Y). Proof. intros. set (f:= @ii1 X Y). set (g:= fun xy:coprod X Y => match xy with ii1 x => x | ii2 y => fromempty (nf y) end). assert (egf: forall x:X, paths (g (f x)) x). intro. apply idpath. assert (efg: forall xy: coprod X Y, paths (f (g xy)) xy). intro. destruct xy as [ x | y ] . apply idpath. apply (fromempty (nf y)). apply (gradth f g egf efg). Defined. Definition weqii1withneg ( X : UU ) { Y : UU } ( nf : neg Y ) := weqpair _ ( isweqii1withneg X nf ) . Theorem isweqii2withneg { X : UU } ( Y : UU ) (nf : X -> empty): isweq (@ii2 X Y). Proof. intros. set (f:= @ii2 X Y). set (g:= fun xy:coprod X Y => match xy with ii1 x => fromempty (nf x) | ii2 y => y end). assert (egf: forall y : Y, paths (g (f y)) y). intro. apply idpath. assert (efg: forall xy: coprod X Y, paths (f (g xy)) xy). intro. destruct xy as [ x | y ] . apply (fromempty (nf x)). apply idpath. apply (gradth f g egf efg). Defined. Definition weqii2withneg { X : UU } ( Y : UU ) ( nf : neg X ) := weqpair _ ( isweqii2withneg Y nf ) . Definition coprodf { X Y X' Y' : UU } (f: X -> X')(g: Y-> Y'): coprod X Y -> coprod X' Y' := fun xy: coprod X Y => match xy with ii1 x => ii1 (f x)| ii2 y => ii2 (g y) end. Definition homotcoprodfcomp { X X' Y Y' Z Z' : UU } ( f : X -> Y ) ( f' : X' -> Y' ) ( g : Y -> Z ) ( g' : Y' -> Z' ) : homot ( funcomp ( coprodf f f' ) ( coprodf g g' ) ) ( coprodf ( funcomp f g ) ( funcomp f' g' ) ) . Proof. intros . intro xx' . destruct xx' as [ x | x' ] . apply idpath . apply idpath . Defined . Definition homotcoprodfhomot { X X' Y Y' } ( f g : X -> Y ) ( f' g' : X' -> Y' ) ( h : homot f g ) ( h' : homot f' g' ) : homot ( coprodf f f') ( coprodf g g') := fun xx' : _ => match xx' with ( ii1 x ) => maponpaths ( @ii1 _ _ ) ( h x ) | ( ii2 x' ) => maponpaths ( @ii2 _ _ ) ( h' x' ) end . Theorem isweqcoprodf { X Y X' Y' : UU } ( w : weq X X' )( w' : weq Y Y' ) : isweq (coprodf w w' ). Proof. intros. set (finv:= invmap w ). set (ginv:= invmap w' ). set (ff:=coprodf w w' ). set (gg:=coprodf finv ginv). assert (egf: forall xy: coprod X Y, paths (gg (ff xy)) xy). intro. destruct xy as [ x | y ] . simpl. apply (maponpaths (@ii1 X Y) (homotinvweqweq w x)). apply (maponpaths (@ii2 X Y) (homotinvweqweq w' y)). assert (efg: forall xy': coprod X' Y', paths (ff (gg xy')) xy'). intro. destruct xy' as [ x | y ] . simpl. apply (maponpaths (@ii1 X' Y') (homotweqinvweq w x)). apply (maponpaths (@ii2 X' Y') (homotweqinvweq w' y)). apply (gradth ff gg egf efg). Defined. Definition weqcoprodf { X Y X' Y' : UU } (w1: weq X Y)(w2: weq X' Y') : weq (coprod X X') (coprod Y Y') := weqpair _ ( isweqcoprodf w1 w2 ) . Lemma negpathsii1ii2 { X Y : UU } (x:X)(y:Y): neg (paths (ii1 x) (ii2 y)). Proof. intros. unfold neg. intro X0. set (dist:= fun xy: coprod X Y => match xy with ii1 x => unit | ii2 y => empty end). apply (transportf dist X0 tt). Defined. Lemma negpathsii2ii1 { X Y : UU } (x:X)(y:Y): neg (paths (ii2 y) (ii1 x)). Proof. intros. unfold neg. intro X0. set (dist:= fun xy: coprod X Y => match xy with ii1 x => empty | ii2 y => unit end). apply (transportf dist X0 tt). Defined. (** *** Fibrations with only one non-empty fiber. Theorem saying that if a fibration has only one non-empty fiber then the total space is weakly equivalent to this fiber. *) Theorem onefiber { X : UU } (P:X -> UU)(x:X)(c: forall x':X, coprod (paths x x') (P x' -> empty)) : isweq (fun p: P x => tpair P x p). Proof. intros. set (f:= fun p: P x => tpair _ x p). set (cx := c x). set (cnew:= fun x':X => match cx with ii1 x0 => match c x' with ii1 ee => ii1 (pathscomp0 (pathsinv0 x0) ee)| ii2 phi => ii2 phi end | ii2 phi => c x' end). set (g:= fun pp: total2 P => match (cnew (pr1 pp)) with ii1 e => transportb P e (pr2 pp) | ii2 phi => fromempty (phi (pr2 pp)) end). assert (efg: forall pp: total2 P, paths (f (g pp)) pp). intro. destruct pp as [ t x0 ]. set (cnewt:= cnew t). unfold g. unfold f. simpl. change (cnew t) with cnewt. destruct cnewt as [ x1 | y ]. apply (pathsinv0 (pr1 (pr2 (constr1 P (pathsinv0 x1))) x0)). destruct (y x0). set (cnewx:= cnew x). assert (e1: paths (cnew x) cnewx). apply idpath. unfold cnew in cnewx. change (c x) with cx in cnewx. destruct cx as [ x0 | e0 ]. assert (e: paths (cnewx) (ii1 (idpath x))). apply (maponpaths (@ii1 (paths x x) (P x -> empty)) (pathsinv0l x0)). assert (egf: forall p: P x, paths (g (f p)) p). intro. simpl in g. unfold g. unfold f. simpl. set (ff:= fun cc:coprod (paths x x) (P x -> empty) => match cc with | ii1 e0 => transportb P e0 p | ii2 phi => fromempty (phi p) end). assert (ee: paths (ff (cnewx)) (ff (@ii1 (paths x x) (P x -> empty) (idpath x)))). apply (maponpaths ff e). assert (eee: paths (ff (@ii1 (paths x x) (P x -> empty) (idpath x))) p). apply idpath. fold (ff (cnew x)). assert (e2: paths (ff (cnew x)) (ff cnewx)). apply (maponpaths ff e1). apply (pathscomp0 (pathscomp0 e2 ee) eee). apply (gradth f g egf efg). unfold isweq. intro y0. destruct (e0 (g y0)). Defined. (** *** Pairwise coproducts as dependent sums of families over [ bool ] *) Fixpoint coprodtobool { X Y : UU } ( xy : coprod X Y ) : bool := match xy with ii1 x => true| ii2 y => false end. Definition boolsumfun (X Y:UU) : bool -> UU := fun t:_ => match t with true => X| false => Y end. Definition coprodtoboolsum ( X Y : UU ) : coprod X Y -> total2 (boolsumfun X Y) := fun xy : _ => match xy with ii1 x => tpair (boolsumfun X Y) true x| ii2 y => tpair (boolsumfun X Y) false y end . Definition boolsumtocoprod (X Y:UU): (total2 (boolsumfun X Y)) -> coprod X Y := (fun xy:_ => match xy with tpair true x => ii1 x| tpair false y => ii2 y end). Theorem isweqcoprodtoboolsum (X Y:UU): isweq (coprodtoboolsum X Y). Proof. intros. set (f:= coprodtoboolsum X Y). set (g:= boolsumtocoprod X Y). assert (egf: forall xy: coprod X Y , paths (g (f xy)) xy). destruct xy. apply idpath. apply idpath. assert (efg: forall xy: total2 (boolsumfun X Y), paths (f (g xy)) xy). intro. destruct xy as [ t x ]. destruct t. apply idpath. apply idpath. apply (gradth f g egf efg). Defined. Definition weqcoprodtoboolsum ( X Y : UU ) := weqpair _ ( isweqcoprodtoboolsum X Y ) . Corollary isweqboolsumtocoprod (X Y:UU): isweq (boolsumtocoprod X Y ). Proof. intros. apply (isweqinvmap ( weqcoprodtoboolsum X Y ) ) . Defined. Definition weqboolsumtocoprod ( X Y : UU ) := weqpair _ ( isweqboolsumtocoprod X Y ) . (** *** Splitting of [ X ] into a coproduct defined by a function [ X -> coprod Y Z ] *) Definition weqcoprodsplit { X Y Z : UU } ( f : X -> coprod Y Z ) : weq X ( coprod ( total2 ( fun y : Y => hfiber f ( ii1 y ) ) ) ( total2 ( fun z : Z => hfiber f ( ii2 z ) ) ) ) . Proof . intros . set ( w1 := weqtococonusf f ) . set ( w2 := weqtotal2overcoprod ( fun yz : coprod Y Z => hfiber f yz ) ) . apply ( weqcomp w1 w2 ) . Defined . (** *** Some properties of [ bool ] *) Definition boolchoice ( x : bool ) : coprod ( paths x true ) ( paths x false ) . Proof. intro . destruct x . apply ( ii1 ( idpath _ ) ) . apply ( ii2 ( idpath _ ) ) . Defined . Definition curry : bool -> UU := fun x : bool => match x with false => empty| true => unit end. Theorem nopathstruetofalse: paths true false -> empty. Proof. intro X. apply (transportf curry X tt). Defined. Corollary nopathsfalsetotrue: paths false true -> empty. Proof. intro X. apply (transportb curry X tt). Defined. Definition truetonegfalse ( x : bool ) : paths x true -> neg ( paths x false ) . Proof . intros x e . rewrite e . unfold neg . apply nopathstruetofalse . Defined . Definition falsetonegtrue ( x : bool ) : paths x false -> neg ( paths x true ) . Proof . intros x e . rewrite e . unfold neg . apply nopathsfalsetotrue . Defined . Definition negtruetofalse (x : bool ) : neg ( paths x true ) -> paths x false . Proof. intros x ne. destruct (boolchoice x) as [t | f]. destruct (ne t). apply f. Defined. Definition negfalsetotrue ( x : bool ) : neg ( paths x false ) -> paths x true . Proof. intros x ne . destruct (boolchoice x) as [t | f]. apply t . destruct (ne f) . Defined. (** ** Basics about fibration sequences. *) (** *** Fibrations sequences and their first "left shifts". The group of constructions related to fibration sequences forms one of the most important computational toolboxes of homotopy theory . Given a pair of functions [ ( f : X -> Y ) ( g : Y -> Z ) ] and a point [ z : Z ] , a structure of the complex on such a triple is a homotopy from the composition [ funcomp f g ] to the constant function [ X -> Z ] corresponding to [ z ] i.e. a term [ ez : forall x:X, paths ( g ( f x ) ) z ]. Specifing such a structure is essentially equivalent to specifing a structure of the form [ ezmap : X -> hfiber g z ]. The mapping in one direction is given in the definition of [ ezmap ] below. The mapping in another is given by [ f := fun x : X => pr1 ( ezmap x ) ] and [ ez := fun x : X => pr2 ( ezmap x ) ]. A complex is called a fibration sequence if [ ezmap ] is a weak equivalence. Correspondingly, the structure of a fibration sequence on [ f g z ] is a pair [ ( ez , is ) ] where [ is : isweq ( ezmap f g z ez ) ]. For a fibration sequence [ f g z fs ] where [ fs : fibseqstr f g z ] and any [ y : Y ] there is defined a function [ diff1 : paths ( g y ) z -> X ] and a structure of the fibration sequence [ fibseqdiff1 ] on the triple [ diff1 g y ]. This new fibration sequence is called the derived fibration sequence of the original one. The first function of the second derived of [ f g z fs ] corresponding to [ ( y : Y ) ( x : X ) ] is of the form [ paths ( f x ) y -> paths ( g y ) z ] and it is homotopic to the function defined by [ e => pathscomp0 ( maponpaths g ( pathsinv0 e) ) ( ez x ) ]. The first function of the third derived of [ f g z fs ] corresponding to [ ( y : Y ) ( x : X ) ( e : paths ( g y ) z ) ] is of the form [ paths ( diff1 e ) x -> paths ( f x ) y ]. Therefore, the third derived of a sequence based on [ X Y Z ] is based entirely on paths types of [ X ], [ Y ] and [ Z ]. When this construction is applied to types of finite h-level (see below) and combined with the fact that the h-level of a path type is strictly lower than the h-level of the ambient type it leads to the possibility of building proofs about types by induction on h-level. There are three important special cases in which fibration sequences arise: ( pr1 - case ) The fibration sequence [ fibseqpr1 P z ] defined by family [ P : Z -> UU ] and a term [ z : Z ]. It is based on the sequence of functions [ ( tpair P z : P z -> total2 P ) ( pr1 : total2 P -> Z ) ]. The corresponding [ ezmap ] is defined by an obvious rule and the fact that it is a weak equivalence is proved in [ isweqfibertohfiber ]. ( g - case ) The fibration sequence [ fibseqg g z ] defined by a function [ g : Y -> Z ] and a term [ z : Z ]. It is based on the sequence of functions [ ( hfiberpr1 : hfiber g z -> Y ) ( g : Y -> Z ) ] and the corresponding [ ezmap ] is the function which takes a term [ ye : hfiber ] to [ hfiberpair g ( pr1 ye ) ( pr2 ye ) ]. If we had eta-concersion for the depndent sums it would be the identiry function. Since we do not have this conversion in Coq this function is only homotopic to the identity function by [ tppr ] which is sufficient to ensure that it is a weak equivalence. The first derived of [ fibseqg g z ] corresponding to [ y : Y ] coincides with [ fibseqpr1 ( fun y' : Y => paths ( g y' ) z ) y ]. ( hf -case ) The fibration sequence of homotopy fibers defined for any pair of functions [ ( f : X -> Y ) ( g : Y -> Z ) ] and any terms [ ( z : Z ) ( ye : hfiber g z ) ]. It is based on functions [ hfiberftogf : hfiber f ( pr1 ye ) -> hfiber ( funcomp f g ) z ] and [ hfibergftog : hfiber ( funcomp f g ) z -> hfiber g z ] which are defined below. *) (** The structure of a complex structure on a composable pair of functions [ ( f : X -> Y ) ( g : Y -> Z ) ] relative to a term [ z : Z ]. *) Definition complxstr { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) := forall x:X, paths (g (f x)) z . (** The structure of a fibration sequence on a complex. *) Definition ezmap { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) (ez : complxstr f g z ) : X -> hfiber g z := fun x:X => hfiberpair g (f x) (ez x). Definition isfibseq { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) (ez : complxstr f g z ) := isweq (ezmap f g z ez). Definition fibseqstr { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) := total2 ( fun ez : complxstr f g z => isfibseq f g z ez ) . Definition fibseqstrpair { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) := tpair ( fun ez : complxstr f g z => isfibseq f g z ez ) . Definition fibseqstrtocomplxstr { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) : fibseqstr f g z -> complxstr f g z := @pr1 _ ( fun ez : complxstr f g z => isfibseq f g z ez ) . Coercion fibseqstrtocomplxstr : fibseqstr >-> complxstr . Definition ezweq { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) ( fs : fibseqstr f g z ) : weq X ( hfiber g z ) := weqpair _ ( pr2 fs ) . (** Construction of the derived fibration sequence. *) Definition d1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( y : Y ) : paths ( g y ) z -> X := fun e : _ => invmap ( ezweq f g z fs ) ( hfiberpair g y e ) . Definition ezmap1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( y : Y ) ( e : paths ( g y ) z ) : hfiber f y . Proof . intros . split with ( d1 f g z fs y e ) . unfold d1 . change ( f ( invmap (ezweq f g z fs) (hfiberpair g y e) ) ) with ( hfiberpr1 _ _ ( ezweq f g z fs ( invmap (ezweq f g z fs) (hfiberpair g y e) ) ) ) . apply ( maponpaths ( hfiberpr1 g z ) ( homotweqinvweq ( ezweq f g z fs ) (hfiberpair g y e) ) ) . Defined . Definition invezmap1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ez : complxstr f g z ) ( y : Y ) : hfiber f y -> paths (g y) z := fun xe: hfiber f y => match xe with tpair x e => pathscomp0 (maponpaths g ( pathsinv0 e ) ) ( ez x ) end. Theorem isweqezmap1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( y : Y ) : isweq ( ezmap1 f g z fs y ) . Proof . intros . set ( ff := ezmap1 f g z fs y ) . set ( gg := invezmap1 f g z ( pr1 fs ) y ) . assert ( egf : forall e : _ , paths ( gg ( ff e ) ) e ) . intro . simpl . apply ( hfibertriangle1inv0 g (homotweqinvweq (ezweq f g z fs) (hfiberpair g y e)) ) . assert ( efg : forall xe : _ , paths ( ff ( gg xe ) ) xe ) . intro . destruct xe as [ x e ] . destruct e . simpl . unfold ff . unfold ezmap1 . unfold d1 . change (hfiberpair g (f x) ( pr1 fs x) ) with ( ezmap f g z fs x ) . apply ( hfibertriangle2 f ( hfiberpair f ( invmap (ezweq f g z fs) (ezmap f g z fs x) ) _ ) ( hfiberpair f x ( idpath _ ) ) ( homotinvweqweq ( ezweq f g z fs ) x ) ) . simpl . set ( e1 := pathsinv0 ( pathscomp0rid (maponpaths f (homotinvweqweq (ezweq f g z fs) x) ) ) ) . assert ( e2 : paths (maponpaths (hfiberpr1 g z) (homotweqinvweq (ezweq f g z fs) ( ( ezmap f g z fs ) x))) (maponpaths f (homotinvweqweq (ezweq f g z fs) x)) ) . set ( e3 := maponpaths ( fun e : _ => maponpaths ( hfiberpr1 g z ) e ) ( pathsinv0 ( homotweqinvweqweq ( ezweq f g z fs ) x ) ) ) . simpl in e3 . set ( e4 := maponpathscomp (ezmap f g z (pr1 fs)) (hfiberpr1 g z) (homotinvweqweq (ezweq f g z fs) x) ) . simpl in e4 . apply ( pathscomp0 e3 e4 ) . apply ( pathscomp0 e2 e1 ) . apply ( gradth _ _ egf efg ) . Defined . Definition ezweq1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( y : Y ) := weqpair _ ( isweqezmap1 f g z fs y ) . Definition fibseq1 { X Y Z : UU } (f:X -> Y) (g:Y->Z) (z:Z) ( fs : fibseqstr f g z )(y:Y) : fibseqstr ( d1 f g z fs y) f y := fibseqstrpair _ _ _ _ ( isweqezmap1 f g z fs y ) . (** Explitcit description of the first map in the second derived sequence. *) Definition d2 { X Y Z : UU } (f:X -> Y) (g:Y->Z) (z:Z) ( fs : fibseqstr f g z ) (y:Y) (x:X) ( e : paths (f x) y ) : paths (g y) z := pathscomp0 ( maponpaths g ( pathsinv0 e ) ) ( ( pr1 fs ) x ) . Definition ezweq2 { X Y Z : UU } (f:X -> Y) (g:Y->Z) (z:Z) ( fs : fibseqstr f g z ) (y:Y) (x:X) : weq ( paths (f x) y ) ( hfiber (d1 f g z fs y) x ) := ezweq1 (d1 f g z fs y) f y ( fibseq1 f g z fs y ) x. Definition fibseq2 { X Y Z : UU } (f:X -> Y) (g:Y->Z) (z:Z) ( fs : fibseqstr f g z ) (y:Y) (x:X) : fibseqstr ( d2 f g z fs y x ) ( d1 f g z fs y ) x := fibseqstrpair _ _ _ _ ( isweqezmap1 (d1 f g z fs y) f y ( fibseq1 f g z fs y ) x ) . (** *** Fibration sequences based on [ ( tpair P z : P z -> total2 P ) ( pr1 : total2 P -> Z ) ] ( the "pr1-case" ) *) (** Construction of the fibration sequence. *) Definition ezmappr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : P z -> hfiber ( @pr1 Z P ) z := fun p : P z => tpair _ ( tpair _ z p ) ( idpath z ). Definition invezmappr1 { Z : UU } ( P : Z -> UU) ( z : Z ) : hfiber ( @pr1 Z P ) z -> P z := fun te : hfiber ( @pr1 Z P ) z => match te with tpair t e => transportf P e ( pr2 t ) end. Definition isweqezmappr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : isweq ( ezmappr1 P z ). Proof. intros. assert ( egf : forall x: P z , paths (invezmappr1 _ z ((ezmappr1 P z ) x)) x). intro. unfold ezmappr1. unfold invezmappr1. simpl. apply idpath. assert ( efg : forall x: hfiber (@pr1 Z P) z , paths (ezmappr1 _ z (invezmappr1 P z x)) x). intros. destruct x as [ x t0 ]. destruct t0. simpl in x. simpl. destruct x. simpl. unfold transportf. unfold ezmappr1. apply idpath. apply (gradth _ _ egf efg ). Defined. Definition ezweqpr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) := weqpair _ ( isweqezmappr1 P z ) . Lemma isfibseqpr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : isfibseq (fun p : P z => tpair _ z p) ( @pr1 Z P ) z (fun p: P z => idpath z ). Proof. intros. unfold isfibseq. unfold ezmap. apply isweqezmappr1. Defined. Definition fibseqpr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : fibseqstr (fun p : P z => tpair _ z p) ( @pr1 Z P ) z := fibseqstrpair _ _ _ _ ( isfibseqpr1 P z ) . (** The main weak equivalence defined by the first derived of [ fibseqpr1 ]. *) Definition ezweq1pr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) ( zp : total2 P ) : weq ( paths ( pr1 zp) z ) ( hfiber ( tpair P z ) zp ) := ezweq1 _ _ z ( fibseqpr1 P z ) zp . (** *** Fibration sequences based on [ ( hfiberpr1 : hfiber g z -> Y ) ( g : Y -> Z ) ] (the "g-case") *) Theorem isfibseqg { Y Z : UU } (g:Y -> Z) (z:Z) : isfibseq (hfiberpr1 g z) g z (fun ye: _ => pr2 ye). Proof. intros. assert (Y0:forall ye': hfiber g z, paths ye' (ezmap (hfiberpr1 g z) g z (fun ye: _ => pr2 ye) ye')). intro. apply tppr. apply (isweqhomot _ _ Y0 (idisweq _ )). Defined. Definition ezweqg { Y Z : UU } (g:Y -> Z) (z:Z) := weqpair _ ( isfibseqg g z ) . Definition fibseqg { Y Z : UU } (g:Y -> Z) (z:Z) : fibseqstr (hfiberpr1 g z) g z := fibseqstrpair _ _ _ _ ( isfibseqg g z ) . (** The first derived of [ fibseqg ]. *) Definition d1g { Y Z : UU} ( g : Y -> Z ) ( z : Z ) ( y : Y ) : paths ( g y ) z -> hfiber g z := hfiberpair g y . (** note that [ d1g ] coincides with [ d1 _ _ _ ( fibseqg g z ) ] which makes the following two definitions possible. *) Definition ezweq1g { Y Z : UU } (g:Y -> Z) (z:Z) (y:Y) : weq (paths (g y) z) (hfiber (hfiberpr1 g z) y) := weqpair _ (isweqezmap1 (hfiberpr1 g z) g z ( fibseqg g z ) y) . Definition fibseq1g { Y Z : UU } (g:Y -> Z) (z:Z) ( y : Y) : fibseqstr (d1g g z y ) ( hfiberpr1 g z ) y := fibseqstrpair _ _ _ _ (isweqezmap1 (hfiberpr1 g z) g z ( fibseqg g z ) y) . (** The second derived of [ fibseqg ]. *) Definition d2g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e: paths (pr1 ye') y ) : paths (g y) z := pathscomp0 ( maponpaths g ( pathsinv0 e ) ) ( pr2 ye' ) . (** note that [ d2g ] coincides with [ d2 _ _ _ ( fibseqg g z ) ] which makes the following two definitions possible. *) Definition ezweq2g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) : weq (paths (pr1 ye') y) (hfiber ( hfiberpair g y ) ye') := ezweq2 _ _ _ ( fibseqg g z ) _ _ . Definition fibseq2g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) : fibseqstr ( d2g g y ye' ) ( hfiberpair g y ) ye' := fibseq2 _ _ _ ( fibseqg g z ) _ _ . (** The third derived of [ fibseqg ] and an explicit description of the corresponding first map. *) Definition d3g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e : paths ( g y ) z ) : paths ( hfiberpair g y e ) ye' -> paths ( pr1 ye' ) y := d2 (d1g g z y) (hfiberpr1 g z) y ( fibseq1g g z y ) ye' e . Lemma homotd3g { Y Z : UU } ( g : Y -> Z ) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e : paths ( g y ) z ) ( ee : paths ( hfiberpair g y e) ye' ) : paths (d3g g y ye' e ee) ( maponpaths ( @pr1 _ _ ) ( pathsinv0 ee ) ) . Proof. intros. unfold d3g . unfold d2 . simpl . apply pathscomp0rid. Defined . Definition ezweq3g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e : paths ( g y ) z ) := ezweq2 (d1g g z y) (hfiberpr1 g z) y ( fibseq1g g z y ) ye' e . Definition fibseq3g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e : paths ( g y ) z ) := fibseq2 (d1g g z y) (hfiberpr1 g z) y ( fibseq1g g z y ) ye' e . (** *** Fibration sequence of h-fibers defined by a composable pair of functions (the "hf-case") We construct a fibration sequence based on [ ( hfibersftogf f g z ye : hfiber f ( pr1 ye ) -> hfiber gf z ) ( hfibersgftog f g z : hfiber gf z -> hfiber g z ) ]. *) Definition hfibersftogf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xe : hfiber f ( pr1 ye ) ) : hfiber ( funcomp f g ) z . Proof . intros . split with ( pr1 xe ) . apply ( pathscomp0 ( maponpaths g ( pr2 xe ) ) ( pr2 ye ) ) . Defined . Definition ezmaphf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xe : hfiber f ( pr1 ye ) ) : hfiber ( hfibersgftog f g z ) ye . Proof . intros . split with ( hfibersftogf f g z ye xe ) . simpl . apply ( hfibertriangle2 g (hfiberpair g (f (pr1 xe)) (pathscomp0 (maponpaths g (pr2 xe)) ( pr2 ye ) )) ye ( pr2 xe ) ) . simpl . apply idpath . Defined . Definition invezmaphf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xee' : hfiber ( hfibersgftog f g z ) ye ) : hfiber f ( pr1 ye ) . Proof . intros . split with ( pr1 ( pr1 xee' ) ) . apply ( maponpaths ( hfiberpr1 _ _ ) ( pr2 xee' ) ) . Defined . Definition ffgg { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xee' : hfiber ( hfibersgftog f g z ) ye ) : hfiber ( hfibersgftog f g z ) ye . Proof . intros . destruct ye as [ y e ] . destruct e . unfold hfibersgftog . unfold hfibersgftog in xee' . destruct xee' as [ xe e' ] . destruct xe as [ x e ] . simpl in e' . split with ( hfiberpair ( funcomp f g ) x ( pathscomp0 ( maponpaths g (maponpaths (hfiberpr1 g (g y)) e') ) ( idpath (g y ))) ) . simpl . apply ( hfibertriangle2 _ (hfiberpair g (f x) (( pathscomp0 ( maponpaths g (maponpaths (hfiberpr1 g (g y)) e') ) ( idpath (g y ))))) ( hfiberpair g y ( idpath _ ) ) ( maponpaths ( hfiberpr1 _ _ ) e' ) ( idpath _ ) ) . Defined . Definition homotffggid { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xee' : hfiber ( hfibersgftog f g z ) ye ) : paths ( ffgg f g z ye xee' ) xee' . Proof . intros . destruct ye as [ y e ] . destruct e . destruct xee' as [ xe e' ] . destruct e' . destruct xe as [ x e ] . destruct e . simpl . apply idpath . Defined . Theorem isweqezmaphf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) : isweq ( ezmaphf f g z ye ) . Proof . intros . set ( ff := ezmaphf f g z ye ) . set ( gg := invezmaphf f g z ye ) . assert ( egf : forall xe : _ , paths ( gg ( ff xe ) ) xe ) . destruct ye as [ y e ] . destruct e . intro xe . apply ( hfibertriangle2 f ( gg ( ff xe ) ) xe ( idpath ( pr1 xe ) ) ) . destruct xe as [ x ex ] . simpl in ex . destruct ( ex ) . simpl . apply idpath . assert ( efg : forall xee' : _ , paths ( ff ( gg xee' ) ) xee' ) . destruct ye as [ y e ] . destruct e . intro xee' . assert ( hint : paths ( ff ( gg xee' ) ) ( ffgg f g ( g y ) ( hfiberpair g y ( idpath _ ) ) xee' ) ) . destruct xee' as [ xe e' ] . destruct xe as [ x e ] . apply idpath . apply ( pathscomp0 hint ( homotffggid _ _ _ _ xee' ) ) . apply ( gradth _ _ egf efg ) . Defined . Definition ezweqhf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) : weq ( hfiber f ( pr1 ye ) ) ( hfiber ( hfibersgftog f g z ) ye ) := weqpair _ ( isweqezmaphf f g z ye ) . Definition fibseqhf { X Y Z : UU } (f:X -> Y)(g: Y -> Z)(z:Z)(ye: hfiber g z) : fibseqstr (hfibersftogf f g z ye) (hfibersgftog f g z) ye := fibseqstrpair _ _ _ _ ( isweqezmaphf f g z ye ) . Definition isweqinvezmaphf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) : isweq ( invezmaphf f g z ye ) := pr2 ( invweq ( ezweqhf f g z ye ) ) . Corollary weqhfibersgwtog { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( z : Z ) : weq ( hfiber ( funcomp w g ) z ) ( hfiber g z ) . Proof. intros . split with ( hfibersgftog w g z ) . intro ye . apply ( iscontrweqf ( ezweqhf w g z ye ) ( ( pr2 w ) ( pr1 ye ) ) ) . Defined . (** ** Fiber-wise weak equivalences. Theorems saying that a fiber-wise morphism between total spaces is a weak equivalence if and only if all the morphisms between the fibers are weak equivalences. *) Definition totalfun { X : UU } ( P Q : X -> UU ) (f: forall x:X, P x -> Q x) := (fun z: total2 P => tpair Q (pr1 z) (f (pr1 z) (pr2 z))). Theorem isweqtotaltofib { X : UU } ( P Q : X -> UU) (f: forall x:X, P x -> Q x): isweq (totalfun _ _ f) -> forall x:X, isweq (f x). Proof. intros X P Q f X0 x. set (totp:= total2 P). set (totq := total2 Q). set (totf:= (totalfun _ _ f)). set (pip:= fun z: totp => pr1 z). set (piq:= fun z: totq => pr1 z). set (hfx:= hfibersgftog totf piq x). simpl in hfx. assert (H: isweq hfx). unfold isweq. intro y. set (int:= invezmaphf totf piq x y). assert (X1:isweq int). apply (isweqinvezmaphf totf piq x y). destruct y as [ t e ]. assert (is1: iscontr (hfiber totf t)). apply (X0 t). apply (iscontrweqb ( weqpair int X1 ) is1). set (ip:= ezmappr1 P x). set (iq:= ezmappr1 Q x). set (h:= fun p: P x => hfx (ip p)). assert (is2: isweq h). apply (twooutof3c ip hfx (isweqezmappr1 P x) H). set (h':= fun p: P x => iq ((f x) p)). assert (ee: forall p:P x, paths (h p) (h' p)). intro. apply idpath. assert (X2:isweq h'). apply (isweqhomot h h' ee is2). apply (twooutof3a (f x) iq X2). apply (isweqezmappr1 Q x). Defined. Definition weqtotaltofib { X : UU } ( P Q : X -> UU ) ( f : forall x : X , P x -> Q x ) ( is : isweq ( totalfun _ _ f ) ) ( x : X ) : weq ( P x ) ( Q x ) := weqpair _ ( isweqtotaltofib P Q f is x ) . Theorem isweqfibtototal { X : UU } ( P Q : X -> UU) (f: forall x:X, weq ( P x ) ( Q x ) ) : isweq (totalfun _ _ f). Proof. intros X P Q f . set (fpq:= totalfun P Q f). set (pr1p:= fun z: total2 P => pr1 z). set (pr1q:= fun z: total2 Q => pr1 z). unfold isweq. intro xq. set (x:= pr1q xq). set (xqe:= hfiberpair pr1q xq (idpath _)). set (hfpqx:= hfibersgftog fpq pr1q x). assert (isint: iscontr (hfiber hfpqx xqe)). assert (isint1: isweq hfpqx). set (ipx:= ezmappr1 P x). set (iqx:= ezmappr1 Q x). set (diag:= fun p:P x => (iqx ((f x) p))). assert (is2: isweq diag). apply (twooutof3c (f x) iqx (pr2 ( f x) ) (isweqezmappr1 Q x)). apply (twooutof3b ipx hfpqx (isweqezmappr1 P x) is2). unfold isweq in isint1. apply (isint1 xqe). set (intmap:= invezmaphf fpq pr1q x xqe). apply (iscontrweqf ( weqpair intmap (isweqinvezmaphf fpq pr1q x xqe) ) isint). Defined. Definition weqfibtototal { X : UU } ( P Q : X -> UU) (f: forall x:X, weq ( P x ) ( Q x ) ) := weqpair _ ( isweqfibtototal P Q f ) . (** ** Homotopy fibers of the function [fpmap: total2 X (P f) -> total2 Y P]. Given [ X Y ] in [ UU ], [ P:Y -> UU ] and [ f: X -> Y ] we get a function [ fpmap: total2 X (P f) -> total2 Y P ]. The main theorem of this section asserts that the homotopy fiber of fpmap over [ yp:total Y P ] is naturally weakly equivalent to the homotopy fiber of [ f ] over [ pr1 yp ]. In particular, if [ f ] is a weak equivalence then so is [ fpmap ]. *) Definition fpmap { X Y : UU } (f: X -> Y) ( P:Y-> UU) : total2 ( fun x => P ( f x ) ) -> total2 P := (fun z:total2 (fun x:X => P (f x)) => tpair P (f (pr1 z)) (pr2 z)). Definition hffpmap2 { X Y : UU } (f: X -> Y) (P:Y-> UU): total2 ( fun x => P ( f x ) ) -> total2 (fun u:total2 P => hfiber f (pr1 u)). Proof. intros X Y f P X0. set (u:= fpmap f P X0). split with u. set (x:= pr1 X0). split with x. simpl. apply idpath. Defined. Definition hfiberfpmap { X Y : UU } (f:X -> Y)(P:Y-> UU)(yp: total2 P): hfiber (fpmap f P) yp -> hfiber f (pr1 yp). Proof. intros X Y f P yp X0. set (int1:= hfibersgftog (hffpmap2 f P) (fun u: (total2 (fun u:total2 P => hfiber f (pr1 u))) => (pr1 u)) yp). set (phi:= invezmappr1 (fun u:total2 P => hfiber f (pr1 u)) yp). apply (phi (int1 X0)). Defined. Lemma centralfiber { X : UU } (P:X -> UU)(x:X): isweq (fun p: P x => tpair (fun u: coconusfromt X x => P ( pr1 u)) (coconusfromtpair X (idpath x)) p). Proof. intros. set (f:= fun p: P x => tpair (fun u: coconusfromt X x => P(pr1 u)) (coconusfromtpair X (idpath x)) p). set (g:= fun z: total2 (fun u: coconusfromt X x => P ( pr1 u)) => transportf P (pathsinv0 (pr2 (pr1 z))) (pr2 z)). assert (efg: forall z: total2 (fun u: coconusfromt X x => P ( pr1 u)), paths (f (g z)) z). intro. destruct z as [ t x0 ]. destruct t as [t x1 ]. simpl. destruct x1. simpl. apply idpath. assert (egf: forall p: P x , paths (g (f p)) p). intro. apply idpath. apply (gradth f g egf efg). Defined. Lemma isweqhff { X Y : UU } (f: X -> Y)(P:Y-> UU): isweq (hffpmap2 f P). Proof. intros. set (int:= total2 (fun x:X => total2 (fun u: coconusfromt Y (f x) => P (pr1 u)))). set (intpair:= tpair (fun x:X => total2 (fun u: coconusfromt Y (f x) => P (pr1 u)))). set (toint:= fun z: (total2 (fun u : total2 P => hfiber f (pr1 u))) => intpair (pr1 (pr2 z)) (tpair (fun u: coconusfromt Y (f (pr1 (pr2 z))) => P (pr1 u)) (coconusfromtpair _ (pr2 (pr2 z))) (pr2 (pr1 z)))). set (fromint:= fun z: int => tpair (fun u:total2 P => hfiber f (pr1 u)) (tpair P (pr1 (pr1 (pr2 z))) (pr2 (pr2 z))) (hfiberpair f (pr1 z) (pr2 (pr1 (pr2 z))))). assert (fromto: forall u:(total2 (fun u : total2 P => hfiber f (pr1 u))), paths (fromint (toint u)) u). simpl in toint. simpl in fromint. simpl. intro u. destruct u as [ t x ]. destruct x. destruct t as [ p0 p1 ] . simpl. unfold toint. unfold fromint. simpl. apply idpath. assert (tofrom: forall u:int, paths (toint (fromint u)) u). intro. destruct u as [ t x ]. destruct x as [ t0 x ]. destruct t0. simpl in x. simpl. unfold fromint. unfold toint. simpl. apply idpath. assert (is: isweq toint). apply (gradth toint fromint fromto tofrom). clear tofrom. clear fromto. clear fromint. set (h:= fun u: total2 (fun x:X => P (f x)) => toint ((hffpmap2 f P) u)). simpl in h. assert (l1: forall x:X, isweq (fun p: P (f x) => tpair (fun u: coconusfromt _ (f x) => P (pr1 u)) (coconusfromtpair _ (idpath (f x))) p)). intro. apply (centralfiber P (f x)). assert (X0:isweq h). apply (isweqfibtototal (fun x:X => P (f x)) (fun x:X => total2 (fun u: coconusfromt _ (f x) => P (pr1 u))) (fun x:X => weqpair _ ( l1 x ) ) ). apply (twooutof3a (hffpmap2 f P) toint X0 is). Defined. Theorem isweqhfiberfp { X Y : UU } (f:X -> Y)(P:Y-> UU)(yp: total2 P): isweq (hfiberfpmap f P yp). Proof. intros. set (int1:= hfibersgftog (hffpmap2 f P) (fun u: (total2 (fun u:total2 P => hfiber f (pr1 u))) => (pr1 u)) yp). assert (is1: isweq int1). simpl in int1 . apply ( pr2 ( weqhfibersgwtog ( weqpair _ ( isweqhff f P ) ) (fun u : total2 (fun u : total2 P => hfiber f (pr1 u)) => pr1 u) yp ) ) . set (phi:= invezmappr1 (fun u:total2 P => hfiber f (pr1 u)) yp). assert (is2: isweq phi). apply ( pr2 ( invweq ( ezweqpr1 (fun u:total2 P => hfiber f (pr1 u)) yp ) ) ) . apply (twooutof3c int1 phi is1 is2). Defined. Corollary isweqfpmap { X Y : UU } ( w : weq X Y )(P:Y-> UU) : isweq (fpmap w P). Proof. intros. unfold isweq. intro y. set (h:=hfiberfpmap w P y). assert (X1:isweq h). apply isweqhfiberfp. assert (is: iscontr (hfiber w (pr1 y))). apply ( pr2 w ). apply (iscontrweqb ( weqpair h X1 ) is). Defined. Definition weqfp { X Y : UU } ( w : weq X Y )(P:Y-> UU) := weqpair _ ( isweqfpmap w P ) . (** *** Total spaces of families over a contractible base *) Definition fromtotal2overunit ( P : unit -> UU ) ( tp : total2 P ) : P tt . Proof . intros . destruct tp as [ t p ] . destruct t . apply p . Defined . Definition tototal2overunit ( P : unit -> UU ) ( p : P tt ) : total2 P := tpair P tt p . Theorem weqtotal2overunit ( P : unit -> UU ) : weq ( total2 P ) ( P tt ) . Proof. intro . set ( f := fromtotal2overunit P ) . set ( g := tototal2overunit P ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . destruct a as [ t p ] . destruct t . apply idpath . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . apply idpath . apply ( gradth _ _ egf efg ) . Defined . (** ** The maps between total spaces of families given by a map between the bases of the families and maps between the corresponding members of the families *) Definition bandfmap { X Y : UU }(f: X -> Y) ( P : X -> UU)(Q: Y -> UU)(fm: forall x:X, P x -> (Q (f x))): total2 P -> total2 Q:= fun xp:_ => match xp with tpair x p => tpair Q (f x) (fm x p) end. Theorem isweqbandfmap { X Y : UU } (w : weq X Y ) (P:X -> UU)(Q: Y -> UU)( fw : forall x:X, weq ( P x) (Q (w x))) : isweq (bandfmap _ P Q fw). Proof. intros. set (f1:= totalfun P _ fw). set (is1:= isweqfibtototal P (fun x:X => Q (w x)) fw ). set (f2:= fpmap w Q). set (is2:= isweqfpmap w Q ). assert (h: forall xp: total2 P, paths (f2 (f1 xp)) (bandfmap w P Q fw xp)). intro. destruct xp. apply idpath. apply (isweqhomot _ _ h (twooutof3c f1 f2 is1 is2)). Defined. Definition weqbandf { X Y : UU } (w : weq X Y ) (P:X -> UU)(Q: Y -> UU)( fw : forall x:X, weq ( P x) (Q (w x))) := weqpair _ ( isweqbandfmap w P Q fw ) . (** ** Homotopy fiber squares *) (** *** Homotopy commutative squares *) Definition commsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) := forall ( z : Z ) , paths ( f' ( g' z ) ) ( f ( g z ) ) . Definition hfibersgtof' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr f f' g g' ) ( x : X ) ( ze : hfiber g x ) : hfiber f' ( f x ) . Proof. intros . destruct ze as [ z e ] . split with ( g' z ) . apply ( pathscomp0 ( h z ) ( maponpaths f e ) ) . Defined . Definition hfibersg'tof { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr f f' g g' ) ( x' : X' ) ( ze : hfiber g' x' ) : hfiber f ( f' x' ) . Proof. intros . destruct ze as [ z e ] . split with ( g z ) . apply ( pathscomp0 ( pathsinv0 ( h z ) ) ( maponpaths f' e ) ) . Defined . Definition transposcommsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) : commsqstr f f' g g' -> commsqstr f' f g' g := fun h : _ => fun z : Z => ( pathsinv0 ( h z ) ) . (** *** Short complexes and homotopy commutative squares *) Lemma complxstrtocommsqstr { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( h : complxstr f g z ) : commsqstr ( fun t : unit => z ) g ( fun x : X => tt ) f . Proof. intros . assumption . Defined . Lemma commsqstrtocomplxstr { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( h : commsqstr ( fun t : unit => z ) g ( fun x : X => tt ) f ) : complxstr f g z . Proof. intros . assumption . Defined . (** *** Homotopy fiber products *) Definition hfp {X X' Y:UU} (f:X -> Y) (f':X' -> Y):= total2 (fun xx' : dirprod X X' => paths ( f' ( pr2 xx' ) ) ( f ( pr1 xx' ) ) ) . Definition hfpg {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : hfp f f' -> X := fun xx'e => ( pr1 ( pr1 xx'e ) ) . Definition hfpg' {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : hfp f f' -> X' := fun xx'e => ( pr2 ( pr1 xx'e ) ) . Definition commsqZtohfp { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr f f' g g' ) : Z -> hfp f f' := fun z : _ => tpair _ ( dirprodpair ( g z ) ( g' z ) ) ( h z ) . Definition commsqZtohfphomot { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr f f' g g' ) : forall z : Z , paths ( hfpg _ _ ( commsqZtohfp _ _ _ _ h z ) ) ( g z ) := fun z : _ => idpath _ . Definition commsqZtohfphomot' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr f f' g g' ) : forall z : Z , paths ( hfpg' _ _ ( commsqZtohfp _ _ _ _ h z ) ) ( g' z ) := fun z : _ => idpath _ . Definition hfpoverX {X X' Y:UU} (f:X -> Y) (f':X' -> Y) := total2 (fun x : X => hfiber f' ( f x ) ) . Definition hfpoverX' {X X' Y:UU} (f:X -> Y) (f':X' -> Y) := total2 (fun x' : X' => hfiber f (f' x' ) ) . Definition weqhfptohfpoverX {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : weq ( hfp f f' ) ( hfpoverX f f' ) . Proof. intros . apply ( weqtotal2asstor ( fun x : X => X' ) ( fun xx' : dirprod X X' => paths ( f' ( pr2 xx' ) ) ( f ( pr1 xx' ) ) ) ) . Defined . Definition weqhfptohfpoverX' {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : weq ( hfp f f' ) ( hfpoverX' f f' ) . Proof. intros . set ( w1 := weqfp ( weqdirprodcomm X X' ) ( fun xx' : dirprod X' X => paths ( f' ( pr1 xx' ) ) ( f ( pr2 xx' ) ) ) ) . simpl in w1 . set ( w2 := weqfibtototal ( fun x'x : dirprod X' X => paths ( f' ( pr1 x'x ) ) ( f ( pr2 x'x ) ) ) ( fun x'x : dirprod X' X => paths ( f ( pr2 x'x ) ) ( f' ( pr1 x'x ) ) ) ( fun x'x : _ => weqpathsinv0 ( f' ( pr1 x'x ) ) ( f ( pr2 x'x ) ) ) ) . set ( w3 := weqtotal2asstor ( fun x' : X' => X ) ( fun x'x : dirprod X' X => paths ( f ( pr2 x'x ) ) ( f' ( pr1 x'x ) ) ) ) . simpl in w3 . apply ( weqcomp ( weqcomp w1 w2 ) w3 ) . Defined . Lemma weqhfpcomm { X X' Y : UU } ( f : X -> Y ) ( f' : X' -> Y ) : weq ( hfp f f' ) ( hfp f' f ) . Proof . intros . set ( w1 := weqfp ( weqdirprodcomm X X' ) ( fun xx' : dirprod X' X => paths ( f' ( pr1 xx' ) ) ( f ( pr2 xx' ) ) ) ) . simpl in w1 . set ( w2 := weqfibtototal ( fun x'x : dirprod X' X => paths ( f' ( pr1 x'x ) ) ( f ( pr2 x'x ) ) ) ( fun x'x : dirprod X' X => paths ( f ( pr2 x'x ) ) ( f' ( pr1 x'x ) ) ) ( fun x'x : _ => weqpathsinv0 ( f' ( pr1 x'x ) ) ( f ( pr2 x'x ) ) ) ) . apply ( weqcomp w1 w2 ) . Defined . Definition commhfp {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : commsqstr f f' ( hfpg f f' ) ( hfpg' f f' ) := fun xx'e : hfp f f' => pr2 xx'e . (** *** Homotopy fiber products and homotopy fibers *) Definition hfibertohfp { X Y : UU } ( f : X -> Y ) ( y : Y ) ( xe : hfiber f y ) : hfp ( fun t : unit => y ) f := tpair ( fun tx : dirprod unit X => paths ( f ( pr2 tx ) ) y ) ( dirprodpair tt ( pr1 xe ) ) ( pr2 xe ) . Definition hfptohfiber { X Y : UU } ( f : X -> Y ) ( y : Y ) ( hf : hfp ( fun t : unit => y ) f ) : hfiber f y := hfiberpair f ( pr2 ( pr1 hf ) ) ( pr2 hf ) . Lemma weqhfibertohfp { X Y : UU } ( f : X -> Y ) ( y : Y ) : weq ( hfiber f y ) ( hfp ( fun t : unit => y ) f ) . Proof . intros . set ( ff := hfibertohfp f y ) . set ( gg := hfptohfiber f y ) . split with ff . assert ( egf : forall xe : _ , paths ( gg ( ff xe ) ) xe ) . intro . destruct xe . apply idpath . assert ( efg : forall hf : _ , paths ( ff ( gg hf ) ) hf ) . intro . destruct hf as [ tx e ] . destruct tx as [ t x ] . destruct t . apply idpath . apply ( gradth _ _ egf efg ) . Defined . (** *** Homotopy fiber squares *) Definition ishfsq { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr f f' g g' ) := isweq ( commsqZtohfp f f' g g' h ) . Definition hfsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) := total2 ( fun h : commsqstr f f' g g' => isweq ( commsqZtohfp f f' g g' h ) ) . Definition hfsqstrpair { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) := tpair ( fun h : commsqstr f f' g g' => isweq ( commsqZtohfp f f' g g' h ) ) . Definition hfsqstrtocommsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) : hfsqstr f f' g g' -> commsqstr f f' g g' := @pr1 _ ( fun h : commsqstr f f' g g' => isweq ( commsqZtohfp f f' g g' h ) ) . Coercion hfsqstrtocommsqstr : hfsqstr >-> commsqstr . Definition weqZtohfp { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) : weq Z ( hfp f f' ) := weqpair _ ( pr2 hf ) . Lemma isweqhfibersgtof' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) ( x : X ) : isweq ( hfibersgtof' f f' g g' hf x ) . Proof. intros . set ( is := pr2 hf ) . set ( h := pr1 hf ) . set ( a := weqtococonusf g ) . set ( c := weqpair _ is ) . set ( d := weqhfptohfpoverX f f' ) . set ( b0 := totalfun _ _ ( hfibersgtof' f f' g g' h ) ) . assert ( h1 : forall z : Z , paths ( d ( c z ) ) ( b0 ( a z ) ) ) . intro . simpl . unfold b0 . unfold a . unfold weqtococonusf . unfold tococonusf . simpl . unfold totalfun . simpl . assert ( e : paths ( h z ) ( pathscomp0 (h z) (idpath (f (g z))) ) ) . apply ( pathsinv0 ( pathscomp0rid _ ) ) . destruct e . apply idpath . assert ( is1 : isweq ( fun z : _ => b0 ( a z ) ) ) . apply ( isweqhomot _ _ h1 ) . apply ( twooutof3c _ _ ( pr2 c ) ( pr2 d ) ) . assert ( is2 : isweq b0 ) . apply ( twooutof3b _ _ ( pr2 a ) is1 ) . apply ( isweqtotaltofib _ _ _ is2 x ) . Defined . Definition weqhfibersgtof' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) ( x : X ) := weqpair _ ( isweqhfibersgtof' _ _ _ _ hf x ) . Lemma ishfsqweqhfibersgtof' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr f f' g g' ) ( is : forall x : X , isweq ( hfibersgtof' f f' g g' h x ) ) : hfsqstr f f' g g' . Proof . intros . split with h . set ( a := weqtococonusf g ) . set ( c0 := commsqZtohfp f f' g g' h ) . set ( d := weqhfptohfpoverX f f' ) . set ( b := weqfibtototal _ _ ( fun x : X => weqpair _ ( is x ) ) ) . assert ( h1 : forall z : Z , paths ( d ( c0 z ) ) ( b ( a z ) ) ) . intro . simpl . unfold b . unfold a . unfold weqtococonusf . unfold tococonusf . simpl . unfold totalfun . simpl . assert ( e : paths ( h z ) ( pathscomp0 (h z) (idpath (f (g z))) ) ) . apply ( pathsinv0 ( pathscomp0rid _ ) ) . destruct e . apply idpath . assert ( is1 : isweq ( fun z : _ => d ( c0 z ) ) ) . apply ( isweqhomot _ _ ( fun z : Z => ( pathsinv0 ( h1 z ) ) ) ) . apply ( twooutof3c _ _ ( pr2 a ) ( pr2 b ) ) . apply ( twooutof3a _ _ is1 ( pr2 d ) ) . Defined . Lemma isweqhfibersg'tof { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) ( x' : X' ) : isweq ( hfibersg'tof f f' g g' hf x' ) . Proof. intros . set ( is := pr2 hf ) . set ( h := pr1 hf ) . set ( a' := weqtococonusf g' ) . set ( c' := weqpair _ is ) . set ( d' := weqhfptohfpoverX' f f' ) . set ( b0' := totalfun _ _ ( hfibersg'tof f f' g g' h ) ) . assert ( h1 : forall z : Z , paths ( d' ( c' z ) ) ( b0' ( a' z ) ) ) . intro . unfold b0' . unfold a' . unfold weqtococonusf . unfold tococonusf . unfold totalfun . simpl . assert ( e : paths ( pathsinv0 ( h z ) ) ( pathscomp0 ( pathsinv0 (h z) ) (idpath (f' (g' z))) ) ) . apply ( pathsinv0 ( pathscomp0rid _ ) ) . destruct e . apply idpath . assert ( is1 : isweq ( fun z : _ => b0' ( a' z ) ) ) . apply ( isweqhomot _ _ h1 ) . apply ( twooutof3c _ _ ( pr2 c' ) ( pr2 d' ) ) . assert ( is2 : isweq b0' ) . apply ( twooutof3b _ _ ( pr2 a' ) is1 ) . apply ( isweqtotaltofib _ _ _ is2 x' ) . Defined . Definition weqhfibersg'tof { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) ( x' : X' ) := weqpair _ ( isweqhfibersg'tof _ _ _ _ hf x' ) . Lemma ishfsqweqhfibersg'tof { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr f f' g g' ) ( is : forall x' : X' , isweq ( hfibersg'tof f f' g g' h x' ) ) : hfsqstr f f' g g' . Proof . intros . split with h . set ( a' := weqtococonusf g' ) . set ( c0' := commsqZtohfp f f' g g' h ) . set ( d' := weqhfptohfpoverX' f f' ) . set ( b' := weqfibtototal _ _ ( fun x' : X' => weqpair _ ( is x' ) ) ) . assert ( h1 : forall z : Z , paths ( d' ( c0' z ) ) ( b' ( a' z ) ) ) . intro . simpl . unfold b' . unfold a' . unfold weqtococonusf . unfold tococonusf . unfold totalfun . simpl . assert ( e : paths ( pathsinv0 ( h z ) ) ( pathscomp0 ( pathsinv0 (h z) ) (idpath (f' (g' z))) ) ) . apply ( pathsinv0 ( pathscomp0rid _ ) ) . destruct e . apply idpath . assert ( is1 : isweq ( fun z : _ => d' ( c0' z ) ) ) . apply ( isweqhomot _ _ ( fun z : Z => ( pathsinv0 ( h1 z ) ) ) ) . apply ( twooutof3c _ _ ( pr2 a' ) ( pr2 b' ) ) . apply ( twooutof3a _ _ is1 ( pr2 d' ) ) . Defined . Theorem transposhfpsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) : hfsqstr f' f g' g . Proof . intros . set ( is := pr2 hf ) . set ( h := pr1 hf ) . set ( th := transposcommsqstr f f' g g' h ) . split with th . set ( w1 := weqhfpcomm f f' ) . assert ( h1 : forall z : Z , paths ( w1 ( commsqZtohfp f f' g g' h z ) ) ( commsqZtohfp f' f g' g th z ) ) . intro . unfold commsqZtohfp . simpl . unfold fpmap . unfold totalfun . simpl . apply idpath . apply ( isweqhomot _ _ h1 ) . apply ( twooutof3c _ _ is ( pr2 w1 ) ) . Defined . (** *** Fiber sequences and homotopy fiber squares *) Theorem fibseqstrtohfsqstr { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( hf : fibseqstr f g z ) : hfsqstr ( fun t : unit => z ) g ( fun x : X => tt ) f . Proof . intros . split with ( pr1 hf ) . set ( ff := ezweq f g z hf ) . set ( ggff := commsqZtohfp ( fun t : unit => z ) g ( fun x : X => tt ) f ( pr1 hf ) ) . set ( gg := weqhfibertohfp g z ) . apply ( pr2 ( weqcomp ff gg ) ) . Defined . Theorem hfsqstrtofibseqstr { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( hf : hfsqstr ( fun t : unit => z ) g ( fun x : X => tt ) f ) : fibseqstr f g z . Proof . intros . split with ( pr1 hf ) . set ( ff := ezmap f g z ( pr1 hf ) ) . set ( ggff := weqZtohfp ( fun t : unit => z ) g ( fun x : X => tt ) f hf ) . set ( gg := weqhfibertohfp g z ) . apply ( twooutof3a ff gg ( pr2 ggff ) ( pr2 gg ) ) . Defined . (** ** Basics about h-levels *) (** *** h-levels of types *) Fixpoint isofhlevel (n:nat) (X:UU): UU:= match n with O => iscontr X | S m => forall x:X, forall x':X, (isofhlevel m (paths x x')) end. Theorem hlevelretract (n:nat) { X Y : UU } ( p : X -> Y ) ( s : Y -> X ) ( eps : forall y : Y , paths ( p ( s y ) ) y ) : isofhlevel n X -> isofhlevel n Y . Proof. intro. induction n as [ | n IHn ]. intros X Y p s eps X0. unfold isofhlevel. apply ( iscontrretract p s eps X0). unfold isofhlevel. intros X Y p s eps X0 x x'. unfold isofhlevel in X0. assert (is: isofhlevel n (paths (s x) (s x'))). apply X0. set (s':= @maponpaths _ _ s x x'). set (p':= pathssec2 s p eps x x'). set (eps':= @pathssec3 _ _ s p eps x x' ). simpl. apply (IHn _ _ p' s' eps' is). Defined. Corollary isofhlevelweqf (n:nat) { X Y : UU } ( f : weq X Y ) : isofhlevel n X -> isofhlevel n Y . Proof. intros n X Y f X0. apply (hlevelretract n f (invmap f ) (homotweqinvweq f )). assumption. Defined. Corollary isofhlevelweqb (n:nat) { X Y : UU } ( f : weq X Y ) : isofhlevel n Y -> isofhlevel n X . Proof. intros n X Y f X0 . apply (hlevelretract n (invmap f ) f (homotinvweqweq f )). assumption. Defined. Lemma isofhlevelsn ( n : nat ) { X : UU } ( f : X -> isofhlevel ( S n ) X ) : isofhlevel ( S n ) X. Proof. intros . simpl . intros x x' . apply ( f x x x'). Defined. Lemma isofhlevelssn (n:nat) { X : UU } ( is : forall x:X, isofhlevel (S n) (paths x x)) : isofhlevel (S (S n)) X. Proof. intros . simpl. intros x x'. change ( forall ( x0 x'0 : paths x x' ), isofhlevel n ( paths x0 x'0 ) ) with ( isofhlevel (S n) (paths x x') ). assert ( X1 : paths x x' -> isofhlevel (S n) (paths x x') ) . intro X2. destruct X2. apply ( is x ). apply ( isofhlevelsn n X1 ). Defined. (** *** h-levels of functions *) Definition isofhlevelf ( n : nat ) { X Y : UU } ( f : X -> Y ) : UU := forall y:Y, isofhlevel n (hfiber f y). Theorem isofhlevelfhomot ( n : nat ) { X Y : UU }(f f':X -> Y)(h: forall x:X, paths (f x) (f' x)): isofhlevelf n f -> isofhlevelf n f'. Proof. intros n X Y f f' h X0. unfold isofhlevelf. intro y . apply ( isofhlevelweqf n ( weqhfibershomot f f' h y ) ( X0 y )) . Defined . Theorem isofhlevelfpmap ( n : nat ) { X Y : UU } ( f : X -> Y ) ( Q : Y -> UU ) : isofhlevelf n f -> isofhlevelf n ( fpmap f Q ) . Proof. intros n X Y f Q X0. unfold isofhlevelf. unfold isofhlevelf in X0. intro y . set (yy:= pr1 y). set ( g := hfiberfpmap f Q y). set (is:= isweqhfiberfp f Q y). set (isy:= X0 yy). apply (isofhlevelweqb n ( weqpair g is ) isy). Defined. Theorem isofhlevelfffromZ ( n : nat ) { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( isz : isofhlevel ( S n ) Z ) : isofhlevelf n f . Proof. intros . intro y . assert ( w : weq ( hfiber f y ) ( paths ( g y ) z ) ) . apply ( invweq ( ezweq1 f g z fs y ) ) . apply ( isofhlevelweqb n w ( isz (g y ) z ) ) . Defined. Theorem isofhlevelXfromg ( n : nat ) { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) : isofhlevelf n g -> isofhlevel n X . Proof. intros n X Y Z f g z fs isf . assert ( w : weq X ( hfiber g z ) ) . apply ( weqpair _ ( pr2 fs ) ) . apply ( isofhlevelweqb n w ( isf z ) ) . Defined . Theorem isofhlevelffromXY ( n : nat ) { X Y : UU } ( f : X -> Y ) : isofhlevel n X -> isofhlevel (S n) Y -> isofhlevelf n f. Proof. intro. induction n as [ | n IHn ] . intros X Y f X0 X1. assert (is1: isofhlevel O Y). split with ( f ( pr1 X0 ) ) . intro t . unfold isofhlevel in X1 . set ( is := X1 t ( f ( pr1 X0 ) ) ) . apply ( pr1 is ). apply (isweqcontrcontr f X0 is1). intros X Y f X0 X1. unfold isofhlevelf. simpl. assert (is1: forall x' x:X, isofhlevel n (paths x' x)). simpl in X0. assumption. assert (is2: forall y' y:Y, isofhlevel (S n) (paths y' y)). simpl in X1. simpl. assumption. assert (is3: forall (y:Y)(x:X)(xe': hfiber f y), isofhlevelf n (d2g f x xe')). intros. apply (IHn _ _ (d2g f x xe') (is1 (pr1 xe') x) (is2 (f x) y)). assert (is4: forall (y:Y)(x:X)(xe': hfiber f y)(e: paths (f x) y), isofhlevel n (paths (hfiberpair f x e) xe')). intros. apply (isofhlevelweqb n ( ezweq3g f x xe' e) (is3 y x xe' e)). intros y xe xe' . destruct xe as [ t x ]. apply (is4 y t xe' x). Defined. Theorem isofhlevelXfromfY ( n : nat ) { X Y : UU } ( f : X -> Y ) : isofhlevelf n f -> isofhlevel n Y -> isofhlevel n X. Proof. intro. induction n as [ | n IHn ] . intros X Y f X0 X1. apply (iscontrweqb ( weqpair f X0 ) X1). intros X Y f X0 X1. simpl. assert (is1: forall (y:Y)(xe xe': hfiber f y), isofhlevel n (paths xe xe')). intros. apply (X0 y). assert (is2: forall (y:Y)(x:X)(xe': hfiber f y), isofhlevelf n (d2g f x xe')). intros. unfold isofhlevel. intro y0. apply (isofhlevelweqf n ( ezweq3g f x xe' y0 ) (is1 y (hfiberpair f x y0) xe')). assert (is3: forall (y' y : Y), isofhlevel n (paths y' y)). simpl in X1. assumption. intros x' x . set (y:= f x'). set (e':= idpath y). set (xe':= hfiberpair f x' e'). apply (IHn _ _ (d2g f x xe') (is2 y x xe') (is3 (f x) y)). Defined. Theorem isofhlevelffib ( n : nat ) { X : UU } ( P : X -> UU ) ( x : X ) ( is : forall x':X, isofhlevel n (paths x' x) ) : isofhlevelf n ( tpair P x ) . Proof . intros . unfold isofhlevelf . intro xp . apply (isofhlevelweqf n ( ezweq1pr1 P x xp) ( is ( pr1 xp ) ) ) . Defined . Theorem isofhlevelfhfiberpr1y ( n : nat ) { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : forall y':Y, isofhlevel n (paths y' y) ) : isofhlevelf n ( hfiberpr1 f y). Proof. intros . unfold isofhlevelf. intro x. apply (isofhlevelweqf n ( ezweq1g f y x ) ( is ( f x ) ) ) . Defined. Theorem isofhlevelfsnfib (n:nat) { X : UU } (P:X -> UU)(x:X) ( is : isofhlevel (S n) (paths x x) ) : isofhlevelf (S n) ( tpair P x ). Proof. intros . unfold isofhlevelf. intro xp. apply (isofhlevelweqf (S n) ( ezweq1pr1 P x xp ) ). apply isofhlevelsn . intro X1 . destruct X1 . assumption . Defined . Theorem isofhlevelfsnhfiberpr1 ( n : nat ) { X Y : UU } (f : X -> Y ) ( y : Y ) ( is : isofhlevel (S n) (paths y y) ) : isofhlevelf (S n) (hfiberpr1 f y). Proof. intros . unfold isofhlevelf. intro x. apply (isofhlevelweqf (S n) ( ezweq1g f y x ) ). apply isofhlevelsn. intro X1. destruct X1. assumption. Defined . Corollary isofhlevelfhfiberpr1 ( n : nat ) { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : isofhlevel (S n) Y ) : isofhlevelf n ( hfiberpr1 f y ) . Proof. intros. apply isofhlevelfhfiberpr1y. intro y' . apply (is y' y). Defined. Theorem isofhlevelff ( n : nat ) { X Y Z : UU } (f : X -> Y ) ( g : Y -> Z ) : isofhlevelf n (fun x : X => g ( f x) ) -> isofhlevelf (S n) g -> isofhlevelf n f. Proof. intros n X Y Z f g X0 X1. unfold isofhlevelf. intro y . set (ye:= hfiberpair g y (idpath (g y))). apply (isofhlevelweqb n ( ezweqhf f g (g y) ye ) (isofhlevelffromXY n _ (X0 (g y)) (X1 (g y)) ye)). Defined. Theorem isofhlevelfgf ( n : nat ) { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) : isofhlevelf n f -> isofhlevelf n g -> isofhlevelf n (fun x:X => g(f x)). Proof. intros n X Y Z f g X0 X1. unfold isofhlevelf. intro z. assert (is1: isofhlevelf n (hfibersgftog f g z)). unfold isofhlevelf. intro ye. apply (isofhlevelweqf n ( ezweqhf f g z ye ) (X0 (pr1 ye))). assert (is2: isofhlevel n (hfiber g z)). apply (X1 z). apply (isofhlevelXfromfY n _ is1 is2). Defined. Theorem isofhlevelfgwtog (n:nat ) { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( is : isofhlevelf n (fun x : X => g ( w x ) ) ) : isofhlevelf n g . Proof. intros . intro z . assert ( is' : isweq ( hfibersgftog w g z ) ) . intro ye . apply ( iscontrweqf ( ezweqhf w g z ye ) ( pr2 w ( pr1 ye ) ) ) . apply ( isofhlevelweqf _ ( weqpair _ is' ) ( is _ ) ) . Defined . Theorem isofhlevelfgtogw (n:nat ) { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( is : isofhlevelf n g ) : isofhlevelf n (fun x : X => g ( w x ) ) . Proof. intros . intro z . assert ( is' : isweq ( hfibersgftog w g z ) ) . intro ye . apply ( iscontrweqf ( ezweqhf w g z ye ) ( pr2 w ( pr1 ye ) ) ) . apply ( isofhlevelweqb _ ( weqpair _ is' ) ( is _ ) ) . Defined . Corollary isofhlevelfhomot2 (n:nat) { X X' Y : UU } (f:X -> Y)(f':X' -> Y)(w : weq X X' )(h:forall x:X, paths (f x) (f' (w x))) : isofhlevelf n f -> isofhlevelf n f'. Proof. intros n X X' Y f f' w h X0. assert (X1: isofhlevelf n (fun x:X => f' (w x))). apply (isofhlevelfhomot n _ _ h X0). apply (isofhlevelfgwtog n w f' X1). Defined. Theorem isofhlevelfonpaths (n:nat) { X Y : UU }(f:X -> Y)(x x':X): isofhlevelf (S n) f -> isofhlevelf n (@maponpaths _ _ f x x'). Proof. intros n X Y f x x' X0. set (y:= f x'). set (xe':= hfiberpair f x' (idpath _ )). assert (is1: isofhlevelf n (d2g f x xe')). unfold isofhlevelf. intro y0 . apply (isofhlevelweqf n ( ezweq3g f x xe' y0 ) (X0 y (hfiberpair f x y0) xe')). assert (h: forall ee:paths x' x, paths (d2g f x xe' ee) (maponpaths f (pathsinv0 ee))). intro. assert (e0: paths (pathscomp0 (maponpaths f (pathsinv0 ee)) (idpath _ )) (maponpaths f (pathsinv0 ee)) ). destruct ee. simpl. apply idpath. apply (e0). apply (isofhlevelfhomot2 n _ _ ( weqpair (@pathsinv0 _ x' x ) (isweqpathsinv0 _ _ ) ) h is1) . Defined. Theorem isofhlevelfsn (n:nat) { X Y : UU } (f:X -> Y): (forall x x':X, isofhlevelf n (@maponpaths _ _ f x x')) -> isofhlevelf (S n) f. Proof. intros n X Y f X0. unfold isofhlevelf. intro y . simpl. intros x x' . destruct x as [ x e ]. destruct x' as [ x' e' ]. destruct e' . set (xe':= hfiberpair f x' ( idpath _ ) ). set (xe:= hfiberpair f x e). set (d3:= d2g f x xe'). simpl in d3. assert (is1: isofhlevelf n (d2g f x xe')). assert (h: forall ee: paths x' x, paths (maponpaths f (pathsinv0 ee)) (d2g f x xe' ee)). intro. unfold d2g. simpl . apply ( pathsinv0 ( pathscomp0rid _ ) ) . assert (is2: isofhlevelf n (fun ee: paths x' x => maponpaths f (pathsinv0 ee))). apply (isofhlevelfgtogw n ( weqpair _ (isweqpathsinv0 _ _ ) ) (@maponpaths _ _ f x x') (X0 x x')). apply (isofhlevelfhomot n _ _ h is2). apply (isofhlevelweqb n ( ezweq3g f x xe' e ) (is1 e)). Defined. Theorem isofhlevelfssn (n:nat) { X Y : UU } (f:X -> Y): (forall x:X, isofhlevelf (S n) (@maponpaths _ _ f x x)) -> isofhlevelf (S (S n)) f. Proof. intros n X Y f X0. unfold isofhlevelf. intro y . assert (forall xe0: hfiber f y, isofhlevel (S n) (paths xe0 xe0)). intro. destruct xe0 as [ x e ]. destruct e . set (e':= idpath ( f x ) ). set (xe':= hfiberpair f x e'). set (xe:= hfiberpair f x e' ). set (d3:= d2g f x xe'). simpl in d3. assert (is1: isofhlevelf (S n) (d2g f x xe')). assert (h: forall ee: paths x x, paths (maponpaths f (pathsinv0 ee)) (d2g f x xe' ee)). intro. unfold d2g . simpl . apply ( pathsinv0 ( pathscomp0rid _ ) ) . assert (is2: isofhlevelf (S n) (fun ee: paths x x => maponpaths f (pathsinv0 ee))). apply (isofhlevelfgtogw ( S n ) ( weqpair _ (isweqpathsinv0 _ _ ) ) (@maponpaths _ _ f x x) ( X0 x )) . apply (isofhlevelfhomot (S n) _ _ h is2). apply (isofhlevelweqb (S n) ( ezweq3g f x xe' e' ) (is1 e')). apply (isofhlevelssn). assumption. Defined. (** ** h -levels of [ pr1 ], fiber inclusions, fibers, total spaces and bases of fibrations *) (** *** h-levelf of [ pr1 ] *) Theorem isofhlevelfpr1 (n:nat) { X : UU } (P:X -> UU)(is: forall x:X, isofhlevel n (P x)) : isofhlevelf n (@pr1 X P). Proof. intros. unfold isofhlevelf. intro x . apply (isofhlevelweqf n ( ezweqpr1 _ x) (is x)). Defined. Lemma isweqpr1 { Z : UU } ( P : Z -> UU ) ( is1 : forall z : Z, iscontr ( P z ) ) : isweq ( @pr1 Z P ) . Proof. intros. unfold isweq. intro y. set (isy:= is1 y). apply (iscontrweqf ( ezweqpr1 P y)) . assumption. Defined. Definition weqpr1 { Z : UU } ( P : Z -> UU ) ( is : forall z : Z , iscontr ( P z ) ) : weq ( total2 P ) Z := weqpair _ ( isweqpr1 P is ) . (** *** h-level of the total space [ total2 ] *) Theorem isofhleveltotal2 ( n : nat ) { X : UU } ( P : X -> UU ) ( is1 : isofhlevel n X )( is2 : forall x:X, isofhlevel n (P x) ) : isofhlevel n (total2 P). Proof. intros. apply (isofhlevelXfromfY n (@pr1 _ _ )). apply isofhlevelfpr1. assumption. assumption. Defined. Corollary isofhleveldirprod ( n : nat ) ( X Y : UU ) ( is1 : isofhlevel n X ) ( is2 : isofhlevel n Y ) : isofhlevel n (dirprod X Y). Proof. intros. apply isofhleveltotal2. assumption. intro. assumption. Defined. (** ** Propositions, inclusions and sets *) (** *** Basics about types of h-level 1 - "propositions" *) Definition isaprop := isofhlevel (S O) . Notation isapropunit := iscontrpathsinunit . Notation isapropdirprod := ( isofhleveldirprod 1 ) . Lemma isapropifcontr { X : UU } ( is : iscontr X ) : isaprop X . Proof. intros . set (f:= fun x:X => tt). assert (isw : isweq f). apply isweqcontrtounit. assumption. apply (isofhlevelweqb (S O) ( weqpair f isw ) ). intros x x' . apply iscontrpathsinunit. Defined. Coercion isapropifcontr : iscontr >-> isaprop . Theorem hlevelntosn ( n : nat ) ( T : UU ) ( is : isofhlevel n T ) : isofhlevel (S n) T. Proof. intro. induction n as [ | n IHn ] . intro. apply isapropifcontr. intro. intro X. change (forall t1 t2:T, isofhlevel (S n) (paths t1 t2)). intros t1 t2 . change (forall t1 t2 : T, isofhlevel n (paths t1 t2)) in X. set (XX := X t1 t2). apply (IHn _ XX). Defined. Corollary isofhlevelcontr (n:nat) { X : UU } ( is : iscontr X ) : isofhlevel n X. Proof. intro. induction n as [ | n IHn ] . intros X X0 . assumption. intros X X0. simpl. intros x x' . assert (is: iscontr (paths x x')). apply (isapropifcontr X0 x x'). apply (IHn _ is). Defined. Lemma isofhlevelfweq ( n : nat ) { X Y : UU } ( f : weq X Y ) : isofhlevelf n f . Proof. intros n X Y f . unfold isofhlevelf. intro y . apply ( isofhlevelcontr n ). apply ( pr2 f ). Defined. Corollary isweqfinfibseq { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( isz : iscontr Z ) : isweq f . Proof. intros . apply ( isofhlevelfffromZ 0 f g z fs ( isapropifcontr isz ) ) . Defined . Corollary weqhfibertocontr { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : iscontr Y ) : weq ( hfiber f y ) X . Proof. intros . split with ( hfiberpr1 f y ) . apply ( isofhlevelfhfiberpr1 0 f y ( hlevelntosn 0 _ is ) ) . Defined. Corollary weqhfibertounit ( X : UU ) : weq ( hfiber ( fun x : X => tt ) tt ) X . Proof. intro . apply ( weqhfibertocontr _ tt iscontrunit ) . Defined. Corollary isofhleveltofun ( n : nat ) ( X : UU ) : isofhlevel n X -> isofhlevelf n ( fun x : X => tt ) . Proof. intros n X is . intro t . destruct t . apply ( isofhlevelweqb n ( weqhfibertounit X ) is ) . Defined . Corollary isofhlevelfromfun ( n : nat ) ( X : UU ) : isofhlevelf n ( fun x : X => tt ) -> isofhlevel n X . Proof. intros n X is . apply ( isofhlevelweqf n ( weqhfibertounit X ) ( is tt ) ) . Defined . Lemma isofhlevelsnprop (n:nat) { X : UU } ( is : isaprop X ) : isofhlevel (S n) X. Proof. intros n X X0. simpl. unfold isaprop in X0. simpl in X0. intros x x' . apply isofhlevelcontr. apply (X0 x x'). Defined. Lemma iscontraprop1 { X : UU } ( is : isaprop X ) ( x : X ) : iscontr X . Proof. intros . unfold iscontr. split with x . intro t . unfold isofhlevel in is . set (is' := is t x ). apply ( pr1 is' ). Defined. Lemma iscontraprop1inv { X : UU } ( f : X -> iscontr X ) : isaprop X . Proof. intros X X0. assert ( H : X -> isofhlevel (S O) X). intro X1. apply (hlevelntosn O _ ( X0 X1 ) ) . apply ( isofhlevelsn O H ) . Defined. Lemma proofirrelevance ( X : UU ) ( is : isaprop X ) : forall x x' : X , paths x x' . Proof. intros . unfold isaprop in is . unfold isofhlevel in is . apply ( pr1 ( is x x' ) ). Defined. Lemma invproofirrelevance ( X : UU ) ( ee : forall x x' : X , paths x x' ) : isaprop X. Proof. intros . unfold isaprop. unfold isofhlevel . intro x . assert ( is1 : iscontr X ). split with x. intro t . apply ( ee t x). assert ( is2 : isaprop X). apply isapropifcontr. assumption. unfold isaprop in is2. unfold isofhlevel in is2. apply (is2 x). Defined. Lemma isweqimplimpl { X Y : UU } ( f : X -> Y ) ( g : Y -> X ) ( isx : isaprop X ) ( isy : isaprop Y ) : isweq f. Proof. intros. assert (isx0: forall x:X, paths (g (f x)) x). intro. apply proofirrelevance . apply isx . assert (isy0 : forall y : Y, paths (f (g y)) y). intro. apply proofirrelevance . apply isy . apply (gradth f g isx0 isy0). Defined. Definition weqimplimpl { X Y : UU } ( f : X -> Y ) ( g : Y -> X ) ( isx : isaprop X ) ( isy : isaprop Y ) := weqpair _ ( isweqimplimpl f g isx isy ) . Theorem isapropempty: isaprop empty. Proof. unfold isaprop. unfold isofhlevel. intros x x' . destruct x. Defined. Theorem isapropifnegtrue { X : UU } ( a : X -> empty ) : isaprop X . Proof . intros . set ( w := weqpair _ ( isweqtoempty a ) ) . apply ( isofhlevelweqb 1 w isapropempty ) . Defined . (** *** Functional extensionality for functions to the empty type *) Axiom funextempty : forall ( X : UU ) ( f g : X -> empty ) , paths f g . (** *** More results on propositions *) Theorem isapropneg (X:UU): isaprop (X -> empty). Proof. intro. apply invproofirrelevance . intros x x' . apply ( funextempty X x x' ) . Defined . (** See also [ isapropneg2 ] *) Corollary isapropdneg (X:UU): isaprop (dneg X). Proof. intro. apply (isapropneg (neg X)). Defined. Definition isaninvprop (X:UU) := isweq (todneg X). Definition invimpl (X:UU) (is: isaninvprop X) : (dneg X) -> X:= invmap ( weqpair (todneg X) is ) . Lemma isapropaninvprop (X:UU): isaninvprop X -> isaprop X. Proof. intros X X0. apply (isofhlevelweqb (S O) ( weqpair (todneg X) X0 ) (isapropdneg X)). Defined. Theorem isaninvpropneg (X:UU): isaninvprop (neg X). Proof. intros. set (f:= todneg (neg X)). set (g:= negf (todneg X)). set (is1:= isapropneg X). set (is2:= isapropneg (dneg X)). apply (isweqimplimpl f g is1 is2). Defined. Theorem isapropdec (X:UU): (isaprop X) -> (isaprop (coprod X (X-> empty))). Proof. intros X X0. assert (X1: forall (x x': X), paths x x'). apply (proofirrelevance _ X0). assert (X2: forall (x x': coprod X (X -> empty)), paths x x'). intros. destruct x as [ x0 | y0 ]. destruct x' as [ x | y ]. apply (maponpaths (fun x:X => ii1 x) (X1 x0 x)). apply (fromempty (y x0)). destruct x' as [ x | y ]. apply (fromempty (y0 x)). assert (e: paths y0 y). apply (proofirrelevance _ (isapropneg X) y0 y). apply (maponpaths (fun f: X -> empty => ii2 f) e). apply (invproofirrelevance _ X2). Defined. (** *** Inclusions - functions of h-level 1 *) Definition isincl { X Y : UU } (f : X -> Y ) := isofhlevelf 1 f . Definition incl ( X Y : UU ) := total2 ( fun f : X -> Y => isincl f ) . Definition inclpair { X Y : UU } ( f : X -> Y ) ( is : isincl f ) : incl X Y := tpair _ f is . Definition pr1incl ( X Y : UU ) : incl X Y -> ( X -> Y ) := @pr1 _ _ . Coercion pr1incl : incl >-> Funclass . Lemma isinclweq ( X Y : UU ) ( f : X -> Y ) : isweq f -> isincl f . Proof . intros X Y f is . apply ( isofhlevelfweq 1 ( weqpair _ is ) ) . Defined . Coercion isinclweq : isweq >-> isincl . Lemma isofhlevelfsnincl (n:nat) { X Y : UU } (f:X -> Y)(is: isincl f): isofhlevelf (S n) f. Proof. intros. unfold isofhlevelf. intro y . apply isofhlevelsnprop. apply (is y). Defined. Definition weqtoincl ( X Y : UU ) : weq X Y -> incl X Y := fun w => inclpair ( pr1 w ) ( pr2 w ) . Coercion weqtoincl : weq >-> incl . Lemma isinclcomp { X Y Z : UU } ( f : incl X Y ) ( g : incl Y Z ) : isincl ( funcomp ( pr1 f ) ( pr1 g ) ) . Proof . intros . apply ( isofhlevelfgf 1 f g ( pr2 f ) ( pr2 g ) ) . Defined . Definition inclcomp { X Y Z : UU } ( f : incl X Y ) ( g : incl Y Z ) : incl X Z := inclpair ( funcomp ( pr1 f ) ( pr1 g ) ) ( isinclcomp f g ) . Lemma isincltwooutof3a { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isg : isincl g ) ( isgf : isincl ( funcomp f g ) ) : isincl f . Proof . intros . apply ( isofhlevelff 1 f g isgf ) . apply ( isofhlevelfsnincl 1 g isg ) . Defined . Lemma isinclgwtog { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( is : isincl ( funcomp w g ) ) : isincl g . Proof . intros . apply ( isofhlevelfgwtog 1 w g is ) . Defined . Lemma isinclgtogw { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( is : isincl g ) : isincl ( funcomp w g ) . Proof . intros . apply ( isofhlevelfgtogw 1 w g is ) . Defined . Lemma isinclhomot { X Y : UU } ( f g : X -> Y ) ( h : homot f g ) ( isf : isincl f ) : isincl g . Proof . intros . apply ( isofhlevelfhomot ( S O ) f g h isf ) . Defined . Definition isofhlevelsninclb (n:nat) { X Y : UU } (f:X -> Y)(is: isincl f) : isofhlevel (S n) Y -> isofhlevel (S n) X:= isofhlevelXfromfY (S n) f (isofhlevelfsnincl n f is). Definition isapropinclb { X Y : UU } ( f : X -> Y ) ( isf : isincl f ) : isaprop Y -> isaprop X := isofhlevelXfromfY 1 _ isf . Lemma iscontrhfiberofincl { X Y : UU } (f:X -> Y): isincl f -> (forall x:X, iscontr (hfiber f (f x))). Proof. intros X Y f X0 x. unfold isofhlevelf in X0. set (isy:= X0 (f x)). apply (iscontraprop1 isy (hfiberpair f _ (idpath (f x)))). Defined. Lemma isweqonpathsincl { X Y : UU } (f:X -> Y) (is: isincl f)(x x':X): isweq (@maponpaths _ _ f x x'). Proof. intros. apply (isofhlevelfonpaths O f x x' is). Defined. Definition weqonpathsincl { X Y : UU } (f:X -> Y) (is: isincl f)(x x':X) := weqpair _ ( isweqonpathsincl f is x x' ) . Definition invmaponpathsincl { X Y : UU } (f:X -> Y) (is: isincl f)(x x':X): paths (f x) (f x') -> paths x x':= invmap ( weqonpathsincl f is x x') . Lemma isinclweqonpaths { X Y : UU } (f:X -> Y): (forall x x':X, isweq (@maponpaths _ _ f x x')) -> isincl f. Proof. intros X Y f X0. apply (isofhlevelfsn O f X0). Defined. Definition isinclpr1 { X : UU } (P:X -> UU)(is: forall x:X, isaprop (P x)): isincl (@pr1 X P):= isofhlevelfpr1 (S O) P is. Theorem samehfibers { X Y Z : UU } (f: X -> Y) (g: Y -> Z) (is1: isincl g) ( y: Y): weq ( hfiber f y ) ( hfiber ( fun x => g ( f x ) ) ( g y ) ) . Proof. intros. split with (@hfibersftogf _ _ _ f g (g y) (hfiberpair g y (idpath _ ))) . set (z:= g y). set (ye:= hfiberpair g y (idpath _ )). unfold isweq. intro xe. set (is3:= isweqezmap1 _ _ _ ( fibseqhf f g z ye ) xe). assert (w1: weq (paths (hfibersgftog f g z xe) ye) (hfiber (hfibersftogf f g z ye) xe)). split with (ezmap (d1 (hfibersftogf f g z ye) (hfibersgftog f g z) ye ( fibseqhf f g z ye ) xe) (hfibersftogf f g z ye) xe ( fibseq1 (hfibersftogf f g z ye) (hfibersgftog f g z) ye ( fibseqhf f g z ye ) xe) ). apply is3. apply (iscontrweqf w1 ). assert (is4: iscontr (hfiber g z)). apply iscontrhfiberofincl. assumption. apply ( isapropifcontr is4 ). Defined. (** *** Basics about types of h-level 2 - "sets" *) Definition isaset ( X : UU ) : UU := forall x x' : X , isaprop ( paths x x' ) . (* Definition isaset := isofhlevel 2 . *) Notation isasetdirprod := ( isofhleveldirprod 2 ) . Lemma isasetunit : isaset unit . Proof . apply ( isofhlevelcontr 2 iscontrunit ) . Defined . Lemma isasetempty : isaset empty . Proof. apply ( isofhlevelsnprop 1 isapropempty ) . Defined . Lemma isasetifcontr { X : UU } ( is : iscontr X ) : isaset X . Proof . intros . apply ( isofhlevelcontr 2 is ) . Defined . Lemma isasetaprop { X : UU } ( is : isaprop X ) : isaset X . Proof . intros . apply ( isofhlevelsnprop 1 is ) . Defined . (** The following lemma assert "uniqueness of identity proofs" (uip) for sets. *) Lemma uip { X : UU } ( is : isaset X ) { x x' : X } ( e e' : paths x x' ) : paths e e' . Proof. intros . apply ( proofirrelevance _ ( is x x' ) e e' ) . Defined . (** For the theorem about the coproduct of two sets see [ isasetcoprod ] below. *) Lemma isofhlevelssnset (n:nat) ( X : UU ) ( is : isaset X ) : isofhlevel ( S (S n) ) X. Proof. intros n X X0. simpl. unfold isaset in X0. intros x x' . apply isofhlevelsnprop. set ( int := X0 x x'). assumption . Defined. Lemma isasetifiscontrloops (X:UU): (forall x:X, iscontr (paths x x)) -> isaset X. Proof. intros X X0. unfold isaset. unfold isofhlevel. intros x x' x0 x0' . destruct x0. set (is:= X0 x). apply isapropifcontr. assumption. Defined. Lemma iscontrloopsifisaset (X:UU): (isaset X) -> (forall x:X, iscontr (paths x x)). Proof. intros X X0 x. unfold isaset in X0. unfold isofhlevel in X0. change (forall (x x' : X) (x0 x'0 : paths x x'), iscontr (paths x0 x'0)) with (forall (x x':X), isaprop (paths x x')) in X0. apply (iscontraprop1 (X0 x x) (idpath x)). Defined. (** A monic subtype of a set is a set. *) Theorem isasetsubset { X Y : UU } (f: X -> Y) (is1: isaset Y) (is2: isincl f): isaset X. Proof. intros. apply (isofhlevelsninclb (S O) f is2). apply is1. Defined. (** The morphism from hfiber of a map to a set is an inclusion. *) Theorem isinclfromhfiber { X Y : UU } (f: X -> Y) (is : isaset Y) ( y: Y ) : @isincl (hfiber f y) X ( @pr1 _ _ ). Proof. intros. apply isofhlevelfhfiberpr1. assumption. Defined. (** Criterion for a function between sets being an inclusion. *) Theorem isinclbetweensets { X Y : UU } ( f : X -> Y ) ( isx : isaset X ) ( isy : isaset Y ) ( inj : forall x x' : X , ( paths ( f x ) ( f x' ) -> paths x x' ) ) : isincl f . Proof. intros . apply isinclweqonpaths . intros x x' . apply ( isweqimplimpl ( @maponpaths _ _ f x x' ) ( inj x x' ) ( isx x x' ) ( isy ( f x ) ( f x' ) ) ) . Defined . (** A map from [ unit ] to a set is an inclusion. *) Theorem isinclfromunit { X : UU } ( f : unit -> X ) ( is : isaset X ) : isincl f . Proof. intros . apply ( isinclbetweensets f ( isofhlevelcontr 2 ( iscontrunit ) ) is ) . intros . destruct x . destruct x' . apply idpath . Defined . (** ** Isolated points and types with decidable equality. *) (** *** Basic results on complements to a point *) Definition compl ( X : UU ) ( x : X ):= total2 (fun x':X => neg (paths x x' ) ) . Definition complpair ( X : UU ) ( x : X ) := tpair (fun x':X => neg (paths x x' ) ) . Definition pr1compl ( X : UU ) ( x : X ) := @pr1 _ (fun x':X => neg (paths x x' ) ) . Lemma isinclpr1compl ( X : UU ) ( x : X ) : isincl ( pr1compl X x ) . Proof. intros . apply ( isinclpr1 _ ( fun x' : X => isapropneg _ ) ) . Defined. Definition recompl ( X : UU ) (x:X): coprod (compl X x) unit -> X := fun u:_ => match u with ii1 x0 => pr1 x0| ii2 t => x end. Definition maponcomplincl { X Y : UU } (f:X -> Y)(is: isincl f)(x:X): compl X x -> compl Y (f x):= fun x0':_ => match x0' with tpair x' neqx => tpair _ (f x') (negf (invmaponpathsincl _ is x x' ) neqx) end. Definition maponcomplweq { X Y : UU } (f : weq X Y ) (x:X):= maponcomplincl f (isofhlevelfweq (S O) f ) x. Theorem isweqmaponcompl { X Y : UU } ( f : weq X Y ) (x:X): isweq (maponcomplweq f x). Proof. intros. set (is1:= isofhlevelfweq (S O) f). set (map1:= totalfun (fun x':X => neg (paths x x' )) (fun x':X => neg (paths (f x) (f x'))) (fun x':X => negf (invmaponpathsincl _ is1 x x' ))). set (map2:= fpmap f (fun y:Y => neg (paths (f x) y ))). assert (is2: forall x':X, isweq (negf (invmaponpathsincl _ is1 x x'))). intro. set (invimpll:= (negf (@maponpaths _ _ f x x'))). apply (isweqimplimpl (negf (invmaponpathsincl _ is1 x x')) (negf (@maponpaths _ _ f x x')) (isapropneg _) (isapropneg _)). assert (is3: isweq map1). unfold map1 . apply ( isweqfibtototal _ _ (fun x':X => weqpair _ ( is2 x' )) ) . assert (is4: isweq map2). apply (isweqfpmap f (fun y:Y => neg (paths (f x) y )) ). assert (h: forall x0':_, paths (map2 (map1 x0')) (maponcomplweq f x x0')). intro. simpl. destruct x0'. simpl. apply idpath. apply (isweqhomot _ _ h (twooutof3c _ _ is3 is4)). Defined. Definition weqoncompl { X Y : UU } (w: weq X Y) ( x : X ) : weq (compl X x) (compl Y (pr1 w x)):= weqpair _ (isweqmaponcompl w x). Definition homotweqoncomplcomp { X Y Z : UU } ( f : weq X Y ) ( g : weq Y Z ) ( x : X ) : homot ( weqcomp ( weqoncompl f x ) ( weqoncompl g ( f x ) ) ) ( weqoncompl ( weqcomp f g ) x ) . Proof . intros . intro x' . destruct x' as [ x' nexx' ] . apply ( invmaponpathsincl _ ( isinclpr1compl Z _ ) _ _ ) . simpl . apply idpath . Defined . (** *** Basic results on types with an isolated point. *) Definition isisolated (X:UU)(x:X):= forall x':X, coprod (paths x x' ) (paths x x' -> empty). Definition isolated ( T : UU ) := total2 ( fun t : T => isisolated T t ) . Definition isolatedpair ( T : UU ) := tpair ( fun t : T => isisolated T t ) . Definition pr1isolated ( T : UU ) := fun x : isolated T => pr1 x . Theorem isaproppathsfromisolated ( X : UU ) ( x : X ) ( is : isisolated X x ) : forall x' : X, isaprop ( paths x x' ) . Proof. intros . apply iscontraprop1inv . intro e . destruct e . set (f:= fun e: paths x x => coconusfromtpair _ e). assert (is' : isweq f). apply (onefiber (fun x':X => paths x x' ) x (fun x':X => is x' )). assert (is2: iscontr (coconusfromt _ x)). apply iscontrcoconusfromt. apply (iscontrweqb ( weqpair f is' ) ). assumption. Defined. Theorem isaproppathstoisolated ( X : UU ) ( x : X ) ( is : isisolated X x ) : forall x' : X, isaprop ( paths x' x ) . Proof . intros . apply ( isofhlevelweqf 1 ( weqpathsinv0 x x' ) ( isaproppathsfromisolated X x is x' ) ) . Defined . Lemma isisolatedweqf { X Y : UU } ( f : weq X Y ) (x:X) (is2: isisolated _ x) : isisolated _ (f x). Proof. intros. unfold isisolated. intro y. set (g:=invmap f ). set (x':= g y). destruct (is2 x') as [ x0 | y0 ]. apply (ii1 (pathsweq1' f x y x0) ). assert (phi: paths y (f x) -> empty). assert (psi: (paths (g y) x -> empty) -> (paths y (f x) -> empty)). intros X0 X1. apply (X0 (pathsinv0 (pathsweq1 f x y (pathsinv0 X1)))). apply (psi ( ( negf ( @pathsinv0 _ _ _ ) ) y0) ) . apply (ii2 ( negf ( @pathsinv0 _ _ _ ) phi ) ). Defined. Theorem isisolatedinclb { X Y : UU } ( f : X -> Y ) ( is : isincl f ) ( x : X ) ( is0 : isisolated _ ( f x ) ) : isisolated _ x . Proof. intros . unfold isisolated . intro x' . set ( a := is0 ( f x' ) ) . destruct a as [ a1 | a2 ] . apply ( ii1 ( invmaponpathsincl f is _ _ a1 ) ) . apply ( ii2 ( ( negf ( @maponpaths _ _ f _ _ ) ) a2 ) ) . Defined. Lemma disjointl1 (X:UU): isisolated (coprod X unit) (ii2 tt). Proof. intros. unfold isisolated. intros x' . destruct x' as [ x | u ] . apply (ii2 (negpathsii2ii1 x tt )). destruct u. apply (ii1 (idpath _ )). Defined. (** *** Weak equivalence [ weqrecompl ] from the coproduct of the complement to an isolated point with [ unit ] and the original type *) Definition invrecompl (X:UU)(x:X)(is: isisolated X x): X -> coprod (compl X x) unit:= fun x':X => match (is x') with ii1 e => ii2 tt| ii2 phi => ii1 (complpair _ _ x' phi) end. Theorem isweqrecompl (X:UU)(x:X)(is:isisolated X x): isweq (recompl _ x). Proof. intros. set (f:= recompl _ x). set (g:= invrecompl X x is). unfold invrecompl in g. simpl in g. assert (efg: forall x':X, paths (f (g x')) x'). intro. destruct (is x') as [ x0 | e ]. destruct x0. unfold f. unfold g. simpl. unfold recompl. simpl. destruct (is x) as [ x0 | e ] . simpl. apply idpath. destruct (e (idpath x)). unfold f. unfold g. simpl. unfold recompl. simpl. destruct (is x') as [ x0 | e0 ]. destruct (e x0). simpl. apply idpath. assert (egf: forall u: coprod (compl X x) unit, paths (g (f u)) u). unfold isisolated in is. intro. destruct (is (f u)) as [ p | e ] . destruct u as [ c | u]. simpl. destruct c as [ t x0 ]. simpl in p. destruct (x0 p). destruct u. assert (e1: paths (g (f (ii2 tt))) (g x)). apply (maponpaths g p). assert (e2: paths (g x) (ii2 tt)). unfold g. destruct (is x) as [ i | e ]. apply idpath. destruct (e (idpath x)). apply (pathscomp0 e1 e2). destruct u. simpl. destruct c as [ t x0 ]. simpl. unfold isisolated in is. unfold g. destruct (is t) as [ p | e0 ] . destruct (x0 p). simpl in g. unfold f. unfold recompl. simpl in e. assert (ee: paths e0 x0). apply (proofirrelevance _ (isapropneg (paths x t))). destruct ee. apply idpath. unfold f. unfold g. simpl. destruct u. destruct (is x). apply idpath. destruct (e (idpath x)). apply (gradth f g egf efg). Defined. Definition weqrecompl ( X : UU ) ( x : X ) ( is : isisolated _ x ) : weq ( coprod ( compl X x ) unit ) X := weqpair _ ( isweqrecompl X x is ) . (** *** Theorem saying that [ recompl ] commutes up to homotopy with [ maponcomplweq ] *) Theorem homotrecomplnat { X Y : UU } ( w : weq X Y ) ( x : X ) : forall a : coprod ( compl X x ) unit , paths ( recompl Y ( w x ) ( coprodf ( maponcomplweq w x ) ( fun x: unit => x ) a ) ) ( w ( recompl X x a ) ) . Proof . intros . destruct a as [ ane | t ] . destruct ane as [ a ne ] . simpl . apply idpath . destruct t . simpl . apply idpath . Defined . (** *** Recomplement on functions *) Definition recomplf { X Y : UU } ( x : X ) ( y : Y ) ( isx : isisolated X x ) ( f : compl X x -> compl Y y ) := funcomp ( funcomp ( invmap ( weqrecompl X x isx ) ) ( coprodf f ( idfun unit ) ) ) ( recompl Y y ) . Definition weqrecomplf { X Y : UU } ( x : X ) ( y : Y ) ( isx : isisolated X x ) ( isy : isisolated Y y ) ( w : weq ( compl X x ) ( compl Y y ) ) := weqcomp ( weqcomp ( invweq ( weqrecompl X x isx ) ) ( weqcoprodf w ( idweq unit ) ) ) ( weqrecompl Y y isy ) . Definition homotrecomplfhomot { X Y : UU } ( x : X ) ( y : Y ) ( isx : isisolated X x ) ( f f' : compl X x -> compl Y y ) ( h : homot f f' ) : homot ( recomplf x y isx f ) ( recomplf x y isx f') . Proof . intros. intro a . unfold recomplf . apply ( maponpaths ( recompl Y y ) ( homotcoprodfhomot _ _ _ _ h ( fun t : unit => idpath t ) (invmap (weqrecompl X x isx) a) ) ) . Defined . Lemma pathsrecomplfxtoy { X Y : UU } ( x : X ) ( y : Y ) ( isx : isisolated X x ) ( f : compl X x -> compl Y y ) : paths ( recomplf x y isx f x ) y . Proof . intros . unfold recomplf . unfold weqrecompl . unfold invmap . simpl . unfold invrecompl . unfold funcomp . destruct ( isx x ) as [ i1 | i2 ] . simpl . apply idpath . destruct ( i2 ( idpath _ ) ) . Defined . Definition homotrecomplfcomp { X Y Z : UU } ( x : X ) ( y : Y ) ( z : Z ) ( isx : isisolated X x ) ( isy : isisolated Y y ) ( f : compl X x -> compl Y y ) ( g : compl Y y -> compl Z z ) : homot ( funcomp ( recomplf x y isx f ) ( recomplf y z isy g ) ) ( recomplf x z isx ( funcomp f g ) ) . Proof . intros. intro x' . unfold recomplf . set ( e := homotinvweqweq ( weqrecompl Y y isy ) (coprodf f ( idfun unit) (invmap ( weqrecompl X x isx ) x')) ) . unfold funcomp . simpl in e . simpl . rewrite e . set ( e' := homotcoprodfcomp f ( idfun unit ) g ( idfun unit ) (invmap (weqrecompl X x isx) x') ) . unfold funcomp in e' . rewrite e' . apply idpath . Defined . Definition homotrecomplfidfun { X : UU } ( x : X ) ( isx : isisolated X x ) : homot ( recomplf x x isx ( idfun ( compl X x ) ) ) ( idfun _ ) . Proof . intros . intro x' . unfold recomplf . unfold weqrecompl . unfold invmap . simpl . unfold invrecompl . unfold funcomp. destruct ( isx x' ) as [ e | ne ] . simpl . apply e . simpl . apply idpath . Defined . Lemma ishomotinclrecomplf { X Y : UU } ( x : X ) ( y : Y ) ( isx : isisolated X x ) ( f : compl X x -> compl Y y ) ( x'n : compl X x ) ( y'n : compl Y y ) ( e : paths ( recomplf x y isx f ( pr1 x'n ) ) ( pr1 y'n ) ) : paths ( f x'n ) y'n . Proof . intros . destruct x'n as [ x' nexx' ] . destruct y'n as [ y' neyy' ] . simpl in e . apply ( invmaponpathsincl _ ( isinclpr1compl _ _ ) ) . simpl . rewrite ( pathsinv0 e ) . unfold recomplf. unfold invmap . unfold coprodf . simpl . unfold funcomp . unfold invrecompl . destruct ( isx x' ) as [ exx' | nexx'' ] . destruct ( nexx' exx' ) . simpl . assert ( ee : paths nexx' nexx'' ) . apply ( proofirrelevance _ ( isapropneg _ ) ) . rewrite ee . apply idpath . Defined . (** *** Standard weak equivalence between [ compl T t1 ] and [ compl T t2 ] for isolated [ t1 t2 ] *) Definition funtranspos0 { T : UU } ( t1 t2 : T ) ( is2 : isisolated T t2 ) ( x :compl T t1 ) : compl T t2 := match ( is2 ( pr1 x ) ) with ii1 e => match ( is2 t1 ) with ii1 e' => fromempty ( pr2 x ( pathscomp0 ( pathsinv0 e' ) e ) ) | ii2 ne' => complpair T t2 t1 ne' end | ii2 ne => complpair T t2 ( pr1 x ) ne end . Definition homottranspos0t2t1t1t2 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : homot ( funcomp ( funtranspos0 t1 t2 is2 ) ( funtranspos0 t2 t1 is1 ) ) ( idfun _ ) . Proof. intros. intro x . unfold funtranspos0 . unfold funcomp . destruct x as [ t net1 ] . simpl . destruct ( is2 t ) as [ et2 | net2 ] . destruct ( is2 t1 ) as [ et2t1 | net2t1 ] . destruct (net1 (pathscomp0 (pathsinv0 et2t1) et2)) . simpl . destruct ( is1 t1 ) as [ e | ne ] . destruct ( is1 t2 ) as [ et1t2 | net1t2 ] . destruct (net2t1 (pathscomp0 (pathsinv0 et1t2) e)) . apply ( invmaponpathsincl _ ( isinclpr1compl _ _ ) _ _ ) . simpl . apply et2 . destruct ( ne ( idpath _ ) ) . simpl . destruct ( is1 t ) as [ et1t | net1t ] . destruct ( net1 et1t ) . apply ( invmaponpathsincl _ ( isinclpr1compl _ _ ) _ _ ) . simpl . apply idpath . Defined . Definition weqtranspos0 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : weq ( compl T t1 ) ( compl T t2 ) . Proof . intros . set ( f := funtranspos0 t1 t2 is2 ) . set ( g := funtranspos0 t2 t1 is1 ) . split with f . assert ( egf : forall x : _ , paths ( g ( f x ) ) x ) . intro x . apply ( homottranspos0t2t1t1t2 t1 t2 is1 is2 ) . assert ( efg : forall x : _ , paths ( f ( g x ) ) x ) . intro x . apply ( homottranspos0t2t1t1t2 t2 t1 is2 is1 ) . apply ( gradth _ _ egf efg ) . Defined . (** *** Transposition of two isolated points *) Definition funtranspos { T : UU } ( t1 t2 : isolated T ) : T -> T := recomplf ( pr1 t1 ) ( pr1 t2 ) ( pr2 t1 ) ( funtranspos0 ( pr1 t1 ) ( pr1 t2 ) ( pr2 t2 ) ) . Definition homottranspost2t1t1t2 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : homot ( funcomp ( funtranspos ( tpair _ t1 is1 ) ( tpair _ t2 is2 ) ) ( funtranspos ( tpair _ t2 is2 ) ( tpair _ t1 is1 ) ) ) ( idfun _ ) . Proof. intros. intro t . unfold funtranspos . rewrite ( homotrecomplfcomp t1 t2 t1 is1 is2 _ _ t ) . set ( e:= homotrecomplfhomot t1 t1 is1 _ ( idfun _ ) ( homottranspos0t2t1t1t2 t1 t2 is1 is2 ) t ) . set ( e' := homotrecomplfidfun t1 is1 t ) . apply ( pathscomp0 e e' ) . Defined . Theorem weqtranspos { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : weq T T . Proof . intros . set ( f := funtranspos ( tpair _ t1 is1) ( tpair _ t2 is2 ) ) . set ( g := funtranspos ( tpair _ t2 is2 ) ( tpair _ t1 is1 ) ) . split with f . assert ( egf : forall t : T , paths ( g ( f t ) ) t ) . intro . apply homottranspost2t1t1t2 . assert ( efg : forall t : T , paths ( f ( g t ) ) t ) . intro . apply homottranspost2t1t1t2 . apply ( gradth _ _ egf efg ) . Defined . Lemma pathsfuntransposoft1 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : paths ( funtranspos ( tpair _ t1 is1 ) ( tpair _ t2 is2 ) t1 ) t2 . Proof . intros . unfold funtranspos . rewrite ( pathsrecomplfxtoy t1 t2 is1 _ ) . apply idpath . Defined . Lemma pathsfuntransposoft2 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : paths ( funtranspos ( tpair _ t1 is1 ) ( tpair _ t2 is2 ) t2 ) t1 . Proof . intros . unfold funtranspos . simpl . unfold funtranspos0 . unfold recomplf . unfold funcomp . unfold coprodf . unfold invmap . unfold weqrecompl . unfold recompl . simpl . unfold invrecompl . destruct ( is1 t2 ) as [ et1t2 | net1t2 ] . apply ( pathsinv0 et1t2 ) . simpl . destruct ( is2 t2 ) as [ et2t2 | net2t2 ] . destruct ( is2 t1 ) as [ et2t1 | net2t1 ] . destruct (net1t2 (pathscomp0 (pathsinv0 et2t1) et2t2) ). simpl . apply idpath . destruct ( net2t2 ( idpath _ ) ) . Defined . Lemma pathsfuntransposofnet1t2 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) ( t : T ) ( net1t : neg ( paths t1 t ) ) ( net2t : neg ( paths t2 t ) ) : paths ( funtranspos ( tpair _ t1 is1 ) ( tpair _ t2 is2 ) t ) t . Proof . intros . unfold funtranspos . simpl . unfold funtranspos0 . unfold recomplf . unfold funcomp . unfold coprodf . unfold invmap . unfold weqrecompl . unfold recompl . simpl . unfold invrecompl . destruct ( is1 t ) as [ et1t | net1t' ] . destruct ( net1t et1t ) . simpl . destruct ( is2 t ) as [ et2t | net2t' ] . destruct ( net2t et2t ) . simpl . apply idpath . Defined . Lemma homotfuntranspos2 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : homot ( funcomp ( funtranspos ( tpair _ t1 is1 ) ( tpair _ t2 is2 ) ) ( funtranspos ( tpair _ t1 is1 ) ( tpair _ t2 is2 ) ) ) ( idfun _ ) . Proof . intros . intro t . unfold funcomp . unfold idfun . destruct ( is1 t ) as [ et1t | net1t ] . rewrite ( pathsinv0 et1t ) . rewrite ( pathsfuntransposoft1 _ _ ) . rewrite ( pathsfuntransposoft2 _ _ ) . apply idpath . destruct ( is2 t ) as [ et2t | net2t ] . rewrite ( pathsinv0 et2t ) . rewrite ( pathsfuntransposoft2 _ _ ) . rewrite ( pathsfuntransposoft1 _ _ ) . apply idpath . rewrite ( pathsfuntransposofnet1t2 _ _ _ _ _ net1t net2t ) . rewrite ( pathsfuntransposofnet1t2 _ _ _ _ _ net1t net2t ) . apply idpath . Defined . (** *** Types with decidable equality *) Definition isdeceq (X:UU) : UU := forall (x x':X), coprod (paths x x' ) (paths x x' -> empty). Lemma isdeceqweqf { X Y : UU } ( w : weq X Y ) ( is : isdeceq X ) : isdeceq Y . Proof. intros . intros y y' . set ( w' := weqonpaths ( invweq w ) y y' ) . set ( int := is ( ( invweq w ) y ) ( ( invweq w ) y' ) ) . destruct int as [ i | ni ] . apply ( ii1 ( ( invweq w' ) i ) ) . apply ( ii2 ( ( negf w' ) ni ) ) . Defined . Lemma isdeceqweqb { X Y : UU } ( w : weq X Y ) ( is : isdeceq Y ) : isdeceq X . Proof . intros . apply ( isdeceqweqf ( invweq w ) is ) . Defined . Theorem isdeceqinclb { X Y : UU } ( f : X -> Y ) ( is : isdeceq Y ) ( is' : isincl f ) : isdeceq X . Proof. intros . intros x x' . set ( w := weqonpathsincl f is' x x' ) . set ( int := is ( f x ) ( f x' ) ) . destruct int as [ i | ni ] . apply ( ii1 ( ( invweq w ) i ) ) . apply ( ii2 ( ( negf w ) ni ) ) . Defined . Lemma isdeceqifisaprop ( X : UU ) : isaprop X -> isdeceq X . Proof. intros X is . intros x x' . apply ( ii1 ( proofirrelevance _ is x x' ) ) . Defined . Theorem isasetifdeceq (X:UU): isdeceq X -> isaset X. Proof. intro X . intro is. intros x x' . apply ( isaproppathsfromisolated X x ( is x ) ) . Defined . Definition booleq { X : UU } ( is : isdeceq X ) ( x x' : X ) : bool . Proof . intros . destruct ( is x x' ) . apply true . apply false . Defined . Lemma eqfromdnegeq (X:UU)(is: isdeceq X)(x x':X): dneg ( paths x x' ) -> paths x x'. Proof. intros X is x x' X0. destruct ( is x x' ) . assumption . destruct ( X0 e ) . Defined . (** *** [ bool ] is a [ deceq ] type and a set *) Theorem isdeceqbool: isdeceq bool. Proof. unfold isdeceq. intros x' x . destruct x. destruct x'. apply (ii1 (idpath true)). apply (ii2 nopathsfalsetotrue). destruct x'. apply (ii2 nopathstruetofalse). apply (ii1 (idpath false)). Defined. Theorem isasetbool: isaset bool. Proof. apply (isasetifdeceq _ isdeceqbool). Defined. (** *** Splitting of [ X ] into a coproduct defined by a function [ X -> bool ] *) Definition subsetsplit { X : UU } ( f : X -> bool ) ( x : X ) : coprod ( hfiber f true ) ( hfiber f false ) . Proof . intros . destruct ( boolchoice ( f x ) ) as [ a | b ] . apply ( ii1 ( hfiberpair f x a ) ) . apply ( ii2 ( hfiberpair f x b ) ) . Defined . Definition subsetsplitinv { X : UU } ( f : X -> bool ) ( ab : coprod (hfiber f true) (hfiber f false) ) : X := match ab with ii1 xt => pr1 xt | ii2 xf => pr1 xf end. Theorem weqsubsetsplit { X : UU } ( f : X -> bool ) : weq X (coprod ( hfiber f true) ( hfiber f false) ) . Proof . intros . set ( ff := subsetsplit f ) . set ( gg := subsetsplitinv f ) . split with ff . assert ( egf : forall a : _ , paths ( gg ( ff a ) ) a ) . intros . unfold ff . unfold subsetsplit . destruct ( boolchoice ( f a ) ) as [ et | ef ] . simpl . apply idpath . simpl . apply idpath . assert ( efg : forall a : _ , paths ( ff ( gg a ) ) a ) . intros . destruct a as [ et | ef ] . destruct et as [ x et' ] . simpl . unfold ff . unfold subsetsplit . destruct ( boolchoice ( f x ) ) as [ e1 | e2 ] . apply ( maponpaths ( @ii1 _ _ ) ) . apply ( maponpaths ( hfiberpair f x ) ) . apply uip . apply isasetbool . destruct ( nopathstruetofalse ( pathscomp0 ( pathsinv0 et' ) e2 ) ) . destruct ef as [ x et' ] . simpl . unfold ff . unfold subsetsplit . destruct ( boolchoice ( f x ) ) as [ e1 | e2 ] . destruct ( nopathsfalsetotrue ( pathscomp0 ( pathsinv0 et' ) e1 ) ) . apply ( maponpaths ( @ii2 _ _ ) ) . apply ( maponpaths ( hfiberpair f x ) ) . apply uip . apply isasetbool . apply ( gradth _ _ egf efg ) . Defined . (** ** Semi-boolean hfiber of functions over isolated points *) Definition eqbx ( X : UU ) ( x : X ) ( is : isisolated X x ) : X -> bool . Proof. intros X x is x' . destruct ( is x' ) . apply true . apply false . Defined . Lemma iscontrhfibereqbx ( X : UU ) ( x : X ) ( is : isisolated X x ) : iscontr ( hfiber ( eqbx X x is ) true ) . Proof. intros . assert ( b : paths ( eqbx X x is x ) true ) . unfold eqbx . destruct ( is x ) . apply idpath . destruct ( e ( idpath _ ) ) . set ( i := hfiberpair ( eqbx X x is ) x b ) . split with i . unfold eqbx . destruct ( boolchoice ( eqbx X x is x ) ) as [ b' | nb' ] . intro t . destruct t as [ x' e ] . assert ( e' : paths x' x ) . destruct ( is x' ) as [ ee | nee ] . apply ( pathsinv0 ee ) . destruct ( nopathsfalsetotrue e ) . apply ( invmaponpathsincl _ ( isinclfromhfiber ( eqbx X x is ) isasetbool true ) ( hfiberpair _ x' e ) i e' ) . destruct ( nopathstruetofalse ( pathscomp0 ( pathsinv0 b ) nb' ) ) . Defined . Definition bhfiber { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : isisolated Y y ) := hfiber ( fun x : X => eqbx Y y is ( f x ) ) true . Lemma weqhfibertobhfiber { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : isisolated Y y ) : weq ( hfiber f y ) ( bhfiber f y is ) . Proof . intros . set ( g := eqbx Y y is ) . set ( ye := pr1 ( iscontrhfibereqbx Y y is ) ) . split with ( hfibersftogf f g true ye ) . apply ( isofhlevelfffromZ 0 _ _ ye ( fibseqhf f g true ye ) ) . apply ( isapropifcontr ) . apply ( iscontrhfibereqbx _ y is ) . Defined . (** *** h-fibers of [ ii1 ] and [ ii2 ] *) Theorem isinclii1 (X Y:UU): isincl (@ii1 X Y). Proof. intros. set (f:= @ii1 X Y). set (g:= coprodtoboolsum X Y). set (gf:= fun x:X => (g (f x))). set (gf':= fun x:X => tpair (boolsumfun X Y) true x). assert (h: forall x:X , paths (gf' x) (gf x)). intro. apply idpath. assert (is1: isofhlevelf (S O) gf'). apply (isofhlevelfsnfib O (boolsumfun X Y) true (isasetbool true true)). assert (is2: isofhlevelf (S O) gf). apply (isofhlevelfhomot (S O) gf' gf h is1). apply (isofhlevelff (S O) _ _ is2 (isofhlevelfweq (S (S O) ) (weqcoprodtoboolsum X Y))). Defined. Corollary iscontrhfiberii1x ( X Y : UU ) ( x : X ) : iscontr ( hfiber ( @ii1 X Y ) ( ii1 x ) ) . Proof. intros . set ( xe1 := hfiberpair ( @ii1 _ _ ) x ( idpath ( @ii1 X Y x ) ) ) . apply ( iscontraprop1 ( isinclii1 X Y ( ii1 x ) ) xe1 ) . Defined . Corollary neghfiberii1y ( X Y : UU ) ( y : Y ) : neg ( hfiber ( @ii1 X Y ) ( ii2 y ) ) . Proof. intros . intro xe . destruct xe as [ x e ] . apply ( negpathsii1ii2 _ _ e ) . Defined. Theorem isinclii2 (X Y:UU): isincl (@ii2 X Y). Proof. intros. set (f:= @ii2 X Y). set (g:= coprodtoboolsum X Y). set (gf:= fun y:Y => (g (f y))). set (gf':= fun y:Y => tpair (boolsumfun X Y) false y). assert (h: forall y:Y , paths (gf' y) (gf y)). intro. apply idpath. assert (is1: isofhlevelf (S O) gf'). apply (isofhlevelfsnfib O (boolsumfun X Y) false (isasetbool false false)). assert (is2: isofhlevelf (S O) gf). apply (isofhlevelfhomot (S O) gf' gf h is1). apply (isofhlevelff (S O) _ _ is2 (isofhlevelfweq (S (S O)) ( weqcoprodtoboolsum X Y))). Defined. Corollary iscontrhfiberii2y ( X Y : UU ) ( y : Y ) : iscontr ( hfiber ( @ii2 X Y ) ( ii2 y ) ) . Proof. intros . set ( xe1 := hfiberpair ( @ii2 _ _ ) y ( idpath ( @ii2 X Y y ) ) ) . apply ( iscontraprop1 ( isinclii2 X Y ( ii2 y ) ) xe1 ) . Defined . Corollary neghfiberii2x ( X Y : UU ) ( x : X ) : neg ( hfiber ( @ii2 X Y ) ( ii1 x ) ) . Proof. intros . intro ye . destruct ye as [ y e ] . apply ( negpathsii2ii1 _ _ e ) . Defined. Lemma negintersectii1ii2 { X Y : UU } (z: coprod X Y): hfiber (@ii1 X Y) z -> hfiber (@ii2 _ _) z -> empty. Proof. intros X Y z X0 X1. destruct X0 as [ t x ]. destruct X1 as [ t0 x0 ]. set (e:= pathscomp0 x (pathsinv0 x0)). apply (negpathsii1ii2 _ _ e). Defined. (** *** [ ii1 ] and [ ii2 ] map isolated points to isoloated points *) Lemma isolatedtoisolatedii1 (X Y:UU)(x:X)(is:isisolated _ x): isisolated ( coprod X Y ) (ii1 x). Proof. intros. unfold isisolated . intro x' . destruct x' as [ x0 | y ] . destruct (is x0) as [ p | e ] . apply (ii1 (maponpaths (@ii1 X Y) p)). apply (ii2 (negf (invmaponpathsincl (@ii1 X Y) (isinclii1 X Y) _ _ ) e)). apply (ii2 (negpathsii1ii2 x y)). Defined. Lemma isolatedtoisolatedii2 (X Y:UU)(y:Y)(is:isisolated _ y): isisolated ( coprod X Y ) (ii2 y). Proof. intros. intro x' . destruct x' as [ x | y0 ] . apply (ii2 (negpathsii2ii1 x y)). destruct (is y0) as [ p | e ] . apply (ii1 (maponpaths (@ii2 X Y) p)). apply (ii2 (negf (invmaponpathsincl (@ii2 X Y) (isinclii2 X Y) _ _ ) e)). Defined. (** *** h-fibers of [ coprodf ] of two functions *) Theorem weqhfibercoprodf1 { X Y X' Y' : UU } (f: X -> X')(g:Y -> Y')(x':X'): weq (hfiber f x') (hfiber (coprodf f g) (ii1 x')). Proof. intros. set ( ix := @ii1 X Y ) . set ( ix' := @ii1 X' Y' ) . set ( fpg := coprodf f g ) . set ( fpgix := fun x : X => ( fpg ( ix x ) ) ) . assert ( w1 : weq ( hfiber f x' ) ( hfiber fpgix ( ix' x' ) ) ) . apply ( samehfibers f ix' ( isinclii1 _ _ ) x' ) . assert ( w2 : weq ( hfiber fpgix ( ix' x' ) ) ( hfiber fpg ( ix' x' ) ) ) . split with (hfibersgftog ix fpg ( ix' x' ) ) . unfold isweq. intro y . set (u:= invezmaphf ix fpg ( ix' x' ) y). assert (is: isweq u). apply isweqinvezmaphf. apply (iscontrweqb ( weqpair u is ) ) . destruct y as [ xy e ] . destruct xy as [ x0 | y0 ] . simpl . apply iscontrhfiberofincl . apply ( isinclii1 X Y ) . apply ( fromempty ( ( negpathsii2ii1 x' ( g y0 ) ) e ) ) . apply ( weqcomp w1 w2 ) . Defined. Theorem weqhfibercoprodf2 { X Y X' Y' : UU } (f: X -> X')(g:Y -> Y')(y':Y'): weq (hfiber g y') (hfiber (coprodf f g) (ii2 y')). Proof. intros. set ( iy := @ii2 X Y ) . set ( iy' := @ii2 X' Y' ) . set ( fpg := coprodf f g ) . set ( fpgiy := fun y : Y => ( fpg ( iy y ) ) ) . assert ( w1 : weq ( hfiber g y' ) ( hfiber fpgiy ( iy' y' ) ) ) . apply ( samehfibers g iy' ( isinclii2 _ _ ) y' ) . assert ( w2 : weq ( hfiber fpgiy ( iy' y' ) ) ( hfiber fpg ( iy' y' ) ) ) . split with (hfibersgftog iy fpg ( iy' y' ) ) . unfold isweq. intro y . set (u:= invezmaphf iy fpg ( iy' y' ) y). assert (is: isweq u). apply isweqinvezmaphf. apply (iscontrweqb ( weqpair u is ) ) . destruct y as [ xy e ] . destruct xy as [ x0 | y0 ] . simpl . apply ( fromempty ( ( negpathsii1ii2 ( f x0 ) y' ) e ) ) . simpl. apply iscontrhfiberofincl . apply ( isinclii2 X Y ) . apply ( weqcomp w1 w2 ) . Defined. (** *** Theorem saying that coproduct of two functions of h-level n is of h-level n *) Theorem isofhlevelfcoprodf (n:nat) { X Y Z T : UU } (f : X -> Z ) ( g : Y -> T )( is1 : isofhlevelf n f ) ( is2 : isofhlevelf n g ) : isofhlevelf n (coprodf f g). Proof. intros. unfold isofhlevelf . intro y . destruct y as [ z | t ] . apply (isofhlevelweqf n (weqhfibercoprodf1 f g z) ). apply ( is1 z ) . apply (isofhlevelweqf n (weqhfibercoprodf2 f g t )). apply ( is2 t ) . Defined. (** *** Theorems about h-levels of coproducts and their component types *) Theorem isofhlevelsnsummand1 ( n : nat ) ( X Y : UU ) : isofhlevel ( S n ) ( coprod X Y ) -> isofhlevel ( S n ) X . Proof. intros n X Y is . apply ( isofhlevelXfromfY ( S n ) ( @ii1 X Y ) ( isofhlevelfsnincl n _ ( isinclii1 _ _ ) ) is ) . Defined. Theorem isofhlevelsnsummand2 ( n : nat ) ( X Y : UU ) : isofhlevel ( S n ) ( coprod X Y ) -> isofhlevel ( S n ) Y . Proof. intros n X Y is . apply ( isofhlevelXfromfY ( S n ) ( @ii2 X Y ) ( isofhlevelfsnincl n _ ( isinclii2 _ _ ) ) is ) . Defined. Theorem isofhlevelssncoprod ( n : nat ) ( X Y : UU ) ( isx : isofhlevel ( S ( S n ) ) X ) ( isy : isofhlevel ( S ( S n ) ) Y ) : isofhlevel ( S ( S n ) ) ( coprod X Y ) . Proof. intros . apply isofhlevelfromfun . set ( f := coprodf ( fun x : X => tt ) ( fun y : Y => tt ) ) . assert ( is1 : isofhlevelf ( S ( S n ) ) f ) . apply ( isofhlevelfcoprodf ( S ( S n ) ) _ _ ( isofhleveltofun _ X isx ) ( isofhleveltofun _ Y isy ) ) . assert ( is2 : isofhlevel ( S ( S n ) ) ( coprod unit unit ) ) . apply ( isofhlevelweqb ( S ( S n ) ) boolascoprod ( isofhlevelssnset n _ ( isasetbool ) ) ) . apply ( isofhlevelfgf ( S ( S n ) ) _ _ is1 ( isofhleveltofun _ _ is2 ) ) . Defined . Lemma isasetcoprod ( X Y : UU ) ( isx : isaset X ) ( isy : isaset Y ) : isaset ( coprod X Y ) . Proof. intros . apply ( isofhlevelssncoprod 0 _ _ isx isy ) . Defined . (** *** h-fibers of the sum of two functions [ sumofmaps f g ] *) Lemma coprodofhfiberstohfiber { X Y Z : UU } ( f : X -> Z ) ( g : Y -> Z ) ( z : Z ) : coprod ( hfiber f z ) ( hfiber g z ) -> hfiber ( sumofmaps f g ) z . Proof. intros X Y Z f g z hfg . destruct hfg as [ hf | hg ] . destruct hf as [ x fe ] . split with ( ii1 x ) . simpl . assumption . destruct hg as [ y ge ] . split with ( ii2 y ) . simpl . assumption . Defined. Lemma hfibertocoprodofhfibers { X Y Z : UU } ( f : X -> Z ) ( g : Y -> Z ) ( z : Z ) : hfiber ( sumofmaps f g ) z -> coprod ( hfiber f z ) ( hfiber g z ) . Proof. intros X Y Z f g z hsfg . destruct hsfg as [ xy e ] . destruct xy as [ x | y ] . simpl in e . apply ( ii1 ( hfiberpair _ x e ) ) . simpl in e . apply ( ii2 ( hfiberpair _ y e ) ) . Defined . Theorem weqhfibersofsumofmaps { X Y Z : UU } ( f : X -> Z ) ( g : Y -> Z ) ( z : Z ) : weq ( coprod ( hfiber f z ) ( hfiber g z ) ) ( hfiber ( sumofmaps f g ) z ) . Proof. intros . set ( ff := coprodofhfiberstohfiber f g z ) . set ( gg := hfibertocoprodofhfibers f g z ) . split with ff . assert ( effgg : forall hsfg : _ , paths ( ff ( gg hsfg ) ) hsfg ) . intro . destruct hsfg as [ xy e ] . destruct xy as [ x | y ] . simpl . apply idpath . simpl . apply idpath . assert ( eggff : forall hfg : _ , paths ( gg ( ff hfg ) ) hfg ) . intro . destruct hfg as [ hf | hg ] . destruct hf as [ x fe ] . simpl . apply idpath . destruct hg as [ y ge ] . simpl . apply idpath . apply ( gradth _ _ eggff effgg ) . Defined . (** *** Theorem saying that the sum of two functions of h-level ( S ( S n ) ) is of hlevel ( S ( S n ) ) *) Theorem isofhlevelfssnsumofmaps ( n : nat ) { X Y Z : UU } ( f : X -> Z ) ( g : Y -> Z ) ( isf : isofhlevelf ( S ( S n ) ) f ) ( isg : isofhlevelf ( S ( S n ) ) g ) : isofhlevelf ( S ( S n ) ) ( sumofmaps f g ) . Proof . intros . intro z . set ( w := weqhfibersofsumofmaps f g z ) . set ( is := isofhlevelssncoprod n _ _ ( isf z ) ( isg z ) ) . apply ( isofhlevelweqf _ w is ) . Defined . (** *** Theorem saying that the sum of two functions of h-level n with non-intersecting images is of h-level n *) Lemma noil1 { X Y Z : UU } ( f : X -> Z ) ( g : Y -> Z ) ( noi : forall ( x : X ) ( y : Y ) , neg ( paths ( f x ) ( g y ) ) ) ( z : Z ) : hfiber f z -> hfiber g z -> empty . Proof. intros X Y Z f g noi z hfz hgz . destruct hfz as [ x fe ] . destruct hgz as [ y ge ] . apply ( noi x y ( pathscomp0 fe ( pathsinv0 ge ) ) ) . Defined . Lemma weqhfibernoi1 { X Y Z : UU } ( f : X -> Z ) ( g : Y -> Z ) ( noi : forall ( x : X ) ( y : Y ) , neg ( paths ( f x ) ( g y ) ) ) ( z : Z ) ( xe : hfiber f z ) : weq ( hfiber ( sumofmaps f g ) z ) ( hfiber f z ) . Proof. intros . set ( w1 := invweq ( weqhfibersofsumofmaps f g z ) ) . assert ( a : neg ( hfiber g z ) ) . intro ye . apply ( noil1 f g noi z xe ye ) . set ( w2 := invweq ( weqii1withneg ( hfiber f z ) a ) ) . apply ( weqcomp w1 w2 ) . Defined . Lemma weqhfibernoi2 { X Y Z : UU } ( f : X -> Z ) ( g : Y -> Z ) ( noi : forall ( x : X ) ( y : Y ) , neg ( paths ( f x ) ( g y ) ) ) ( z : Z ) ( ye : hfiber g z ) : weq ( hfiber ( sumofmaps f g ) z ) ( hfiber g z ) . Proof. intros . set ( w1 := invweq ( weqhfibersofsumofmaps f g z ) ) . assert ( a : neg ( hfiber f z ) ) . intro xe . apply ( noil1 f g noi z xe ye ) . set ( w2 := invweq ( weqii2withneg ( hfiber g z ) a ) ) . apply ( weqcomp w1 w2 ) . Defined . Theorem isofhlevelfsumofmapsnoi ( n : nat ) { X Y Z : UU } ( f : X -> Z ) ( g : Y -> Z ) ( isf : isofhlevelf n f ) ( isg : isofhlevelf n g ) ( noi : forall ( x : X ) ( y : Y ) , neg ( paths ( f x ) ( g y ) ) ) : isofhlevelf n ( sumofmaps f g ) . Proof. intros . intro z . destruct n as [ | n ] . set ( zinx := invweq ( weqpair _ isf ) z ) . set ( ziny := invweq ( weqpair _ isg ) z ) . assert ( ex : paths ( f zinx ) z ) . apply ( homotweqinvweq ( weqpair _ isf ) z ) . assert ( ey : paths ( g ziny ) z ) . apply ( homotweqinvweq ( weqpair _ isg ) z ) . destruct ( ( noi zinx ziny ) ( pathscomp0 ex ( pathsinv0 ey ) ) ) . apply isofhlevelsn . intro hfgz . destruct ( ( invweq ( weqhfibersofsumofmaps f g z ) hfgz ) ) as [ xe | ye ] . apply ( isofhlevelweqb _ ( weqhfibernoi1 f g noi z xe ) ( isf z ) ) . apply ( isofhlevelweqb _ ( weqhfibernoi2 f g noi z ye ) ( isg z ) ) . Defined . (** *** Coproducts and complements *) Definition tocompltoii1x (X Y:UU)(x:X): coprod (compl X x) Y -> compl (coprod X Y) (ii1 x). Proof. intros X Y x X0. destruct X0 as [ c | y ] . split with (ii1 (pr1 c)). assert (e: neg(paths x (pr1 c) )). apply (pr2 c). apply (negf (invmaponpathsincl ( @ii1 _ _ ) (isinclii1 X Y) _ _) e). split with (ii2 y). apply (negf (pathsinv0 ) (negpathsii2ii1 x y)). Defined. Definition fromcompltoii1x (X Y:UU)(x:X): compl (coprod X Y) (ii1 x) -> coprod (compl X x) Y. Proof. intros X Y x X0. destruct X0 as [ t x0 ]. destruct t as [ x1 | y ]. assert (ne: neg (paths x x1 )). apply (negf (maponpaths ( @ii1 _ _ ) ) x0). apply (ii1 (complpair _ _ x1 ne )). apply (ii2 y). Defined. Theorem isweqtocompltoii1x (X Y:UU)(x:X): isweq (tocompltoii1x X Y x). Proof. intros. set (f:= tocompltoii1x X Y x). set (g:= fromcompltoii1x X Y x). assert (egf:forall nexy:_ , paths (g (f nexy)) nexy). intro. destruct nexy as [ c | y ]. destruct c as [ t x0 ]. simpl. assert (e: paths (negf (maponpaths (@ii1 X Y)) (negf (invmaponpathsincl (@ii1 X Y) (isinclii1 X Y) x t) x0)) x0). apply (isapropneg (paths x t) ). apply (maponpaths (fun ee: neg (paths x t ) => ii1 (complpair X x t ee)) e). apply idpath. assert (efg: forall neii1x:_, paths (f (g neii1x)) neii1x). intro. destruct neii1x as [ t x0 ]. destruct t as [ x1 | y ]. simpl. assert (e: paths (negf (invmaponpathsincl (@ii1 X Y) (isinclii1 X Y) x x1 ) (negf (maponpaths (@ii1 X Y) ) x0)) x0). apply (isapropneg (paths _ _ ) ). apply (maponpaths (fun ee: (neg (paths (ii1 x) (ii1 x1))) => (complpair _ _ (ii1 x1) ee)) e). simpl. assert (e: paths (negf pathsinv0 (negpathsii2ii1 x y)) x0). apply (isapropneg (paths _ _ ) ). apply (maponpaths (fun ee: (neg (paths (ii1 x) (ii2 y) )) => (complpair _ _ (ii2 y) ee)) e). apply (gradth f g egf efg). Defined. Definition tocompltoii2y (X Y:UU)(y:Y): coprod X (compl Y y) -> compl (coprod X Y) (ii2 y). Proof. intros X Y y X0. destruct X0 as [ x | c ]. split with (ii1 x). apply (negpathsii2ii1 x y ). split with (ii2 (pr1 c)). assert (e: neg(paths y (pr1 c) )). apply (pr2 c). apply (negf (invmaponpathsincl ( @ii2 _ _ ) (isinclii2 X Y) _ _ ) e). Defined. Definition fromcompltoii2y (X Y:UU)(y:Y): compl (coprod X Y) (ii2 y) -> coprod X (compl Y y). Proof. intros X Y y X0. destruct X0 as [ t x ]. destruct t as [ x0 | y0 ]. apply (ii1 x0). assert (ne: neg (paths y y0 )). apply (negf (maponpaths ( @ii2 _ _ ) ) x). apply (ii2 (complpair _ _ y0 ne)). Defined. Theorem isweqtocompltoii2y (X Y:UU)(y:Y): isweq (tocompltoii2y X Y y). Proof. intros. set (f:= tocompltoii2y X Y y). set (g:= fromcompltoii2y X Y y). assert (egf:forall nexy:_ , paths (g (f nexy)) nexy). intro. destruct nexy as [ x | c ]. apply idpath. destruct c as [ t x ]. simpl. assert (e: paths (negf (maponpaths (@ii2 X Y) ) (negf (invmaponpathsincl (@ii2 X Y) (isinclii2 X Y) y t) x)) x). apply (isapropneg (paths y t ) ). apply (maponpaths (fun ee: neg ( paths y t ) => ii2 (complpair _ y t ee)) e). assert (efg: forall neii2x:_, paths (f (g neii2x)) neii2x). intro. destruct neii2x as [ t x ]. destruct t as [ x0 | y0 ]. simpl. assert (e: paths (negpathsii2ii1 x0 y) x). apply (isapropneg (paths _ _ ) ). apply (maponpaths (fun ee: (neg (paths (ii2 y) (ii1 x0) )) => (complpair _ _ (ii1 x0) ee)) e). simpl. assert (e: paths (negf (invmaponpathsincl _ (isinclii2 X Y) y y0 ) (negf (maponpaths (@ii2 X Y) ) x)) x). apply (isapropneg (paths _ _ ) ). apply (maponpaths (fun ee: (neg (paths (ii2 y) (ii2 y0) )) => (complpair _ _ (ii2 y0) ee)) e). apply (gradth f g egf efg). Defined. Definition tocompltodisjoint (X:UU): X -> compl (coprod X unit) (ii2 tt) := fun x:_ => complpair _ _ (ii1 x) (negpathsii2ii1 x tt). Definition fromcompltodisjoint (X:UU): compl (coprod X unit) (ii2 tt) -> X. Proof. intros X X0. destruct X0 as [ t x ]. destruct t as [ x0 | u ] . assumption. destruct u. apply (fromempty (x (idpath (ii2 tt)))). Defined. Lemma isweqtocompltodisjoint (X:UU): isweq (tocompltodisjoint X). Proof. intros. set (ff:= tocompltodisjoint X). set (gg:= fromcompltodisjoint X). assert (egf: forall x:X, paths (gg (ff x)) x). intro. apply idpath. assert (efg: forall xx:_, paths (ff (gg xx)) xx). intro. destruct xx as [ t x ]. destruct t as [ x0 | u ] . simpl. unfold ff. unfold tocompltodisjoint. simpl. assert (ee: paths (negpathsii2ii1 x0 tt) x). apply (proofirrelevance _ (isapropneg _) ). destruct ee. apply idpath. destruct u. simpl. apply (fromempty (x (idpath _))). apply (gradth ff gg egf efg). Defined. Definition weqtocompltodisjoint ( X : UU ) := weqpair _ ( isweqtocompltodisjoint X ) . Corollary isweqfromcompltodisjoint (X:UU): isweq (fromcompltodisjoint X). Proof. intros. apply (isweqinvmap ( weqtocompltodisjoint X ) ). Defined. (** ** Decidable propositions and decidable inclusions *) (** *** Decidable propositions [ isdecprop ] *) Definition isdecprop ( X : UU ) := iscontr ( coprod X ( neg X ) ) . Lemma isdecproptoisaprop ( X : UU ) ( is : isdecprop X ) : isaprop X . Proof. intros X is . apply ( isofhlevelsnsummand1 0 _ _ ( isapropifcontr is ) ) . Defined . Coercion isdecproptoisaprop : isdecprop >-> isaprop . Lemma isdecpropif ( X : UU ) : isaprop X -> ( coprod X ( neg X ) ) -> isdecprop X . Proof. intros X is a . assert ( is1 : isaprop ( coprod X ( neg X ) ) ) . apply isapropdec . assumption . apply ( iscontraprop1 is1 a ) . Defined. Lemma isdecpropfromiscontr { X : UU } ( is : iscontr X ) : isdecprop X . Proof. intros . apply ( isdecpropif _ ( is ) ( ii1 ( pr1 is ) ) ) . Defined. Lemma isdecpropempty : isdecprop empty . Proof. apply ( isdecpropif _ isapropempty ( ii2 ( fun a : empty => a ) ) ) . Defined. Lemma isdecpropweqf { X Y : UU } ( w : weq X Y ) ( is : isdecprop X ) : isdecprop Y . Proof. intros . apply isdecpropif . apply ( isofhlevelweqf 1 w ( isdecproptoisaprop _ is ) ) . destruct ( pr1 is ) as [ x | nx ] . apply ( ii1 ( w x ) ) . apply ( ii2 ( negf ( invweq w ) nx ) ) . Defined . Lemma isdecpropweqb { X Y : UU } ( w : weq X Y ) ( is : isdecprop Y ) : isdecprop X . Proof. intros . apply isdecpropif . apply ( isofhlevelweqb 1 w ( isdecproptoisaprop _ is ) ) . destruct ( pr1 is ) as [ y | ny ] . apply ( ii1 ( invweq w y ) ) . apply ( ii2 ( ( negf w ) ny ) ) . Defined . Lemma isdecproplogeqf { X Y : UU } ( isx : isdecprop X ) ( isy : isaprop Y ) ( lg : X <-> Y ) : isdecprop Y . Proof . intros. set ( w := weqimplimpl ( pr1 lg ) ( pr2 lg ) isx isy ) . apply ( isdecpropweqf w isx ) . Defined . Lemma isdecproplogeqb { X Y : UU } ( isx : isaprop X ) ( isy : isdecprop Y ) ( lg : X <-> Y ) : isdecprop X . Proof . intros. set ( w := weqimplimpl ( pr1 lg ) ( pr2 lg ) isx isy ) . apply ( isdecpropweqb w isy ) . Defined . Lemma isdecpropfromneg { X : UU } ( ne : neg X ) : isdecprop X . Proof. intros . apply ( isdecpropweqb ( weqtoempty ne ) isdecpropempty ) . Defined . Lemma isdecproppaths { X : UU } ( is : isdeceq X ) ( x x' : X ) : isdecprop ( paths x x' ) . Proof. intros . apply ( isdecpropif _ ( isasetifdeceq _ is x x' ) ( is x x' ) ) . Defined . Lemma isdeceqif { X : UU } ( is : forall x x' : X , isdecprop ( paths x x' ) ) : isdeceq X . Proof . intros . intros x x' . apply ( pr1 ( is x x' ) ) . Defined . Lemma isaninv1 (X:UU): isdecprop X -> isaninvprop X. Proof. intros X is1. unfold isaninvprop. set (is2:= pr1 is1). simpl in is2. assert (adjevinv: dneg X -> X). intro X0. destruct is2 as [ a | b ]. assumption. destruct (X0 b). assert (is3: isaprop (dneg X)). apply (isapropneg (X -> empty)). apply (isweqimplimpl (todneg X) adjevinv is1 is3). Defined. Theorem isdecpropfibseq1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) : isdecprop X -> isaprop Z -> isdecprop Y . Proof . intros X Y Z f g z fs isx isz . assert ( isc : iscontr Z ) . apply ( iscontraprop1 isz z ) . assert ( isweq f ) . apply ( isweqfinfibseq f g z fs isc ) . apply ( isdecpropweqf ( weqpair _ X0 ) isx ) . Defined . Theorem isdecpropfibseq0 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) : isdecprop Y -> isdeceq Z -> isdecprop X . Proof . intros X Y Z f g z fs isy isz . assert ( isg : isofhlevelf 1 g ) . apply ( isofhlevelffromXY 1 g ( isdecproptoisaprop _ isy ) ( isasetifdeceq _ isz ) ) . assert ( isp : isaprop X ) . apply ( isofhlevelXfromg 1 f g z fs isg ) . destruct ( pr1 isy ) as [ y | ny ] . apply ( isdecpropfibseq1 _ _ y ( fibseq1 f g z fs y ) ( isdecproppaths isz ( g y ) z ) ( isdecproptoisaprop _ isy ) ) . apply ( isdecpropif _ isp ( ii2 ( negf f ny ) ) ) . Defined. Theorem isdecpropdirprod { X Y : UU } ( isx : isdecprop X ) ( isy : isdecprop Y ) : isdecprop ( dirprod X Y ) . Proof. intros . assert ( isp : isaprop ( dirprod X Y ) ) . apply ( isofhleveldirprod 1 _ _ ( isdecproptoisaprop _ isx ) ( isdecproptoisaprop _ isy ) ) . destruct ( pr1 isx ) as [ x | nx ] . destruct ( pr1 isy ) as [ y | ny ] . apply ( isdecpropif _ isp ( ii1 ( dirprodpair x y ) ) ) . assert ( nxy : neg ( dirprod X Y ) ) . intro xy . destruct xy as [ x0 y0 ] . apply ( ny y0 ) . apply ( isdecpropif _ isp ( ii2 nxy ) ) . assert ( nxy : neg ( dirprod X Y ) ) . intro xy . destruct xy as [ x0 y0 ] . apply ( nx x0 ) . apply ( isdecpropif _ isp ( ii2 nxy ) ) . Defined. Lemma fromneganddecx { X Y : UU } ( isx : isdecprop X ) ( nf : neg ( dirprod X Y ) ) : coprod ( neg X ) ( neg Y ) . Proof . intros . destruct ( pr1 isx ) as [ x | nx ] . set ( ny := negf ( fun y : Y => dirprodpair x y ) nf ) . apply ( ii2 ny ) . apply ( ii1 nx ) . Defined . Lemma fromneganddecy { X Y : UU } ( isy : isdecprop Y ) ( nf : neg ( dirprod X Y ) ) : coprod ( neg X ) ( neg Y ) . Proof . intros . destruct ( pr1 isy ) as [ y | ny ] . set ( nx := negf ( fun x : X => dirprodpair x y ) nf ) . apply ( ii1 nx ) . apply ( ii2 ny ) . Defined . (** *** Paths to and from an isolated point form a decidable proposition *) Lemma isdecproppathsfromisolated ( X : UU ) ( x : X ) ( is : isisolated X x ) ( x' : X ) : isdecprop ( paths x x' ) . Proof. intros . apply isdecpropif . apply isaproppathsfromisolated . assumption . apply ( is x' ) . Defined . Lemma isdecproppathstoisolated ( X : UU ) ( x : X ) ( is : isisolated X x ) ( x' : X ) : isdecprop ( paths x' x ) . Proof . intros . apply ( isdecpropweqf ( weqpathsinv0 x x' ) ( isdecproppathsfromisolated X x is x' ) ) . Defined . (** *** Decidable inclusions *) Definition isdecincl {X Y:UU} (f :X -> Y) := forall y:Y, isdecprop ( hfiber f y ). Lemma isdecincltoisincl { X Y : UU } ( f : X -> Y ) : isdecincl f -> isincl f . Proof. intros X Y f is . intro y . apply ( isdecproptoisaprop _ ( is y ) ) . Defined. Coercion isdecincltoisincl : isdecincl >-> isincl . Lemma isdecinclfromisweq { X Y : UU } ( f : X -> Y ) : isweq f -> isdecincl f . Proof. intros X Y f iswf . intro y . apply ( isdecpropfromiscontr ( iswf y ) ) . Defined . Lemma isdecpropfromdecincl { X Y : UU } ( f : X -> Y ) : isdecincl f -> isdecprop Y -> isdecprop X . Proof. intros X Y f isf isy . destruct ( pr1 isy ) as [ y | n ] . assert ( w : weq ( hfiber f y ) X ) . apply ( weqhfibertocontr f y ( iscontraprop1 ( isdecproptoisaprop _ isy ) y ) ) . apply ( isdecpropweqf w ( isf y ) ) . apply isdecpropif . apply ( isapropinclb _ isf isy ) . apply ( ii2 ( negf f n ) ) . Defined . Lemma isdecinclii1 (X Y: UU): isdecincl ( @ii1 X Y ) . Proof. intros. intro y . destruct y as [ x | y ] . apply ( isdecpropif _ ( isinclii1 X Y ( ii1 x ) ) ( ii1 (hfiberpair (@ii1 _ _ ) x (idpath _ )) ) ) . apply ( isdecpropif _ ( isinclii1 X Y ( ii2 y ) ) ( ii2 ( neghfiberii1y X Y y ) ) ) . Defined. Lemma isdecinclii2 (X Y: UU): isdecincl ( @ii2 X Y ) . Proof. intros. intro y . destruct y as [ x | y ] . apply ( isdecpropif _ ( isinclii2 X Y ( ii1 x ) ) ( ii2 ( neghfiberii2x X Y x ) ) ) . apply ( isdecpropif _ ( isinclii2 X Y ( ii2 y ) ) ( ii1 (hfiberpair (@ii2 _ _ ) y (idpath _ )) ) ) . Defined. Lemma isdecinclpr1 { X : UU } ( P : X -> UU ) ( is : forall x : X , isdecprop ( P x ) ) : isdecincl ( @pr1 _ P ) . Proof . intros . intro x . assert ( w : weq ( P x ) ( hfiber (@pr1 _ P ) x ) ) . apply ezweqpr1 . apply ( isdecpropweqf w ( is x ) ) . Defined . Theorem isdecinclhomot { X Y : UU } ( f g : X -> Y ) ( h : forall x : X , paths ( f x ) ( g x ) ) ( is : isdecincl f ) : isdecincl g . Proof. intros . intro y . apply ( isdecpropweqf ( weqhfibershomot f g h y ) ( is y ) ) . Defined . Theorem isdecinclcomp { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isf : isdecincl f ) ( isg : isdecincl g ) : isdecincl ( fun x : X => g ( f x ) ) . Proof. intros. intro z . set ( gf := fun x : X => g ( f x ) ) . assert ( wy : forall ye : hfiber g z , weq ( hfiber f ( pr1 ye ) ) ( hfiber ( hfibersgftog f g z ) ye ) ) . apply ezweqhf . assert ( ww : forall y : Y , weq ( hfiber f y ) ( hfiber gf ( g y ) ) ) . intro . apply ( samehfibers f g ) . apply ( isdecincltoisincl _ isg ) . destruct ( pr1 ( isg z ) ) as [ ye | nye ] . destruct ye as [ y e ] . destruct e . apply ( isdecpropweqf ( ww y ) ( isf y ) ) . assert ( wz : weq ( hfiber gf z ) ( hfiber g z ) ) . split with ( hfibersgftog f g z ) . intro ye . destruct ( nye ye ) . apply ( isdecpropweqb wz ( isg z ) ) . Defined . (** The conditions of the following theorem can be weakened by assuming only that the h-fibers of g satisfy [ isdeceq ] i.e. are "sets with decidable equality". *) Theorem isdecinclf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isg : isincl g ) ( isgf : isdecincl ( fun x : X => g ( f x ) ) ) : isdecincl f . Proof. intros . intro y . set ( gf := fun x : _ => g ( f x ) ) . assert ( ww : weq ( hfiber f y ) ( hfiber gf ( g y ) ) ) . apply ( samehfibers f g ) . assumption . apply ( isdecpropweqb ww ( isgf ( g y ) ) ) . Defined . (** *) Theorem isdecinclg { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isf : isweq f ) ( isgf : isdecincl ( fun x : X => g ( f x ) ) ) : isdecincl g . Proof. intros . intro z . set ( gf := fun x : X => g ( f x ) ) . assert ( w : weq ( hfiber gf z ) ( hfiber g z ) ) . split with ( hfibersgftog f g z ) . intro ye . assert ( ww : weq ( hfiber f ( pr1 ye ) ) ( hfiber ( hfibersgftog f g z ) ye ) ) . apply ezweqhf . apply ( iscontrweqf ww ( isf ( pr1 ye ) ) ) . apply ( isdecpropweqf w ( isgf z ) ) . Defined . (** *** Decibadle inclusions and isolated points *) Theorem isisolateddecinclf { X Y : UU } ( f : X -> Y ) ( x : X ) : isdecincl f -> isisolated X x -> isisolated Y ( f x ) . Proof . intros X Y f x isf isx . assert ( is' : forall y : Y , isdecincl ( d1g f y x ) ) . intro y . intro xe . set ( w := ezweq2g f x xe ) . apply ( isdecpropweqf w ( isdecproppathstoisolated X x isx _ ) ) . assert ( is'' : forall y : Y , isdecprop ( paths ( f x ) y ) ) . intro . apply ( isdecpropfromdecincl _ ( is' y ) ( isf y ) ) . intro y' . apply ( pr1 ( is'' y' ) ) . Defined . (** *** Decidable inclusions and coprojections *) Definition negimage { X Y : UU } ( f : X -> Y ) := total2 ( fun y : Y => neg ( hfiber f y ) ) . Definition negimagepair { X Y : UU } ( f : X -> Y ) := tpair ( fun y : Y => neg ( hfiber f y ) ) . Lemma isinclfromcoprodwithnegimage { X Y : UU } ( f : X -> Y ) ( is : isincl f ) : isincl ( sumofmaps f ( @pr1 _ ( fun y : Y => neg ( hfiber f y ) ) ) ) . Proof . intros . assert ( noi : forall ( x : X ) ( nx : negimage f ) , neg ( paths ( f x ) ( pr1 nx ) ) ) . intros x nx e . destruct nx as [ y nhf ] . simpl in e . apply ( nhf ( hfiberpair _ x e ) ) . assert ( is' : isincl ( @pr1 _ ( fun y : Y => neg ( hfiber f y ) ) ) ) . apply isinclpr1 . intro y . apply isapropneg . apply ( isofhlevelfsumofmapsnoi 1 f _ is is' noi ) . Defined . Definition iscoproj { X Y : UU } ( f : X -> Y ) := isweq ( sumofmaps f ( @pr1 _ ( fun y : Y => neg ( hfiber f y ) ) ) ) . Definition weqcoproj { X Y : UU } ( f : X -> Y ) ( is : iscoproj f ) : weq ( coprod X ( negimage f ) ) Y := weqpair _ is . Theorem iscoprojfromisdecincl { X Y : UU } ( f : X -> Y ) ( is : isdecincl f ) : iscoproj f . Proof. intros . set ( p := sumofmaps f ( @pr1 _ ( fun y : Y => neg ( hfiber f y ) ) ) ) . assert ( is' : isincl p ) . apply isinclfromcoprodwithnegimage . apply ( isdecincltoisincl _ is ) . unfold iscoproj . intro y . destruct ( pr1 ( is y ) ) as [ h | nh ] . destruct h as [ x e ] . destruct e . change ( f x ) with ( p ( ii1 x ) ) . apply iscontrhfiberofincl . assumption . change y with ( p ( ii2 ( negimagepair _ y nh ) ) ) . apply iscontrhfiberofincl . assumption . Defined . Theorem isdecinclfromiscoproj { X Y : UU } ( f : X -> Y ) ( is : iscoproj f ) : isdecincl f . Proof . intros . set ( g := ( sumofmaps f ( @pr1 _ ( fun y : Y => neg ( hfiber f y ) ) ) ) ) . set ( f' := fun x : X => g ( ii1 x ) ) . assert ( is' : isdecincl f' ) . apply ( isdecinclcomp _ _ ( isdecinclii1 _ _ ) ( isdecinclfromisweq _ is ) ) . assumption . Defined . (** ** Results using full form of the functional extentionality axioms. Summary: We consider two axioms which address functional extensionality. The first one is etacorrection which compensates for the absense of eta-reduction in Coq8.3 Eta-reduction is expected to be included as a basic property of the language in Coq8.4 which will make this axiom and related lemmas unnecessary. The second axiom [ funcontr ] is the functional extensionality for dependent functions formulated as the condition that the space of section of a family with contractible fibers is contractible. Note : some of the results above this point in code use a very limitted form of functional extensionality . See [ funextempty ] . *) (** *** Axioms and their basic corollaries *) (** etacorrection *) Axiom etacorrection: forall T:UU, forall P:T -> UU, forall f: (forall t:T, P t), paths f (fun t:T => f t). Lemma isweqetacorrection { T : UU } (P:T -> UU): isweq (fun f: forall t:T, P t => (fun t:T => f t)). Proof. intros. apply (isweqhomot (fun f: forall t:T, P t => f) (fun f: forall t:T, P t => (fun t:T => f t)) (fun f: forall t:T, P t => etacorrection _ P f) (idisweq _)). Defined. Definition weqeta { T : UU } (P:T -> UU) := weqpair _ ( isweqetacorrection P ) . Lemma etacorrectiononpaths { T : UU } (P:T->UU)(s1 s2 :forall t:T, P t) : paths (fun t:T => s1 t) (fun t:T => s2 t)-> paths s1 s2. Proof. intros T P s1 s2 X. set (ew := weqeta P). apply (invmaponpathsweq ew s1 s2 X). Defined. Definition etacor { X Y : UU } (f:X -> Y) : paths f (fun x:X => f x) := etacorrection _ (fun T:X => Y) f. Lemma etacoronpaths { X Y : UU } (f1 f2 : X->Y) : paths (fun x:X => f1 x) (fun x:X => f2 x) -> paths f1 f2. Proof. intros X Y f1 f2 X0. set (ec:= weqeta (fun x:X => Y) ). apply (invmaponpathsweq ec f1 f2 X0). Defined. (** Dependent functions and sections up to homotopy I *) Definition toforallpaths { T : UU } (P:T -> UU) (f g :forall t:T, P t) : (paths f g) -> (forall t:T, paths (f t) (g t)). Proof. intros T P f g X t. destruct X. apply (idpath (f t)). Defined. Definition sectohfiber { X : UU } (P:X -> UU): (forall x:X, P x) -> (hfiber (fun f:_ => fun x:_ => pr1 (f x)) (fun x:X => x)) := (fun a : forall x:X, P x => tpair _ (fun x:_ => tpair _ x (a x)) (idpath (fun x:X => x))). Definition hfibertosec { X : UU } (P:X -> UU): (hfiber (fun f:_ => fun x:_ => pr1 (f x)) (fun x:X => x)) -> (forall x:X, P x):= fun se:_ => fun x:X => match se as se' return P x with tpair s e => (transportf P (toforallpaths (fun x:X => X) (fun x:X => pr1 (s x)) (fun x:X => x) e x) (pr2 (s x))) end. Definition sectohfibertosec { X : UU } (P:X -> UU): forall a: forall x:X, P x, paths (hfibertosec _ (sectohfiber _ a)) a := fun a:_ => (pathsinv0 (etacorrection _ _ a)). (** *** Deduction of functional extnsionality for dependent functions (sections) from functional extensionality of usual functions *) Axiom funextfunax : forall (X Y:UU)(f g:X->Y), (forall x:X, paths (f x) (g x)) -> (paths f g). Lemma isweqlcompwithweq { X X' : UU} (w: weq X X') (Y:UU) : isweq (fun a:X'->Y => (fun x:X => a (w x))). Proof. intros. set (f:= (fun a:X'->Y => (fun x:X => a (w x)))). set (g := fun b:X-> Y => fun x':X' => b ( invweq w x')). set (egf:= (fun a:X'->Y => funextfunax X' Y (fun x':X' => (g (f a)) x') a (fun x': X' => maponpaths a (homotweqinvweq w x')))). set (efg:= (fun a:X->Y => funextfunax X Y (fun x:X => (f (g a)) x) a (fun x: X => maponpaths a (homotinvweqweq w x)))). apply (gradth f g egf efg). Defined. Lemma isweqrcompwithweq { Y Y':UU } (w: weq Y Y')(X:UU): isweq (fun a:X->Y => (fun x:X => w (a x))). Proof. intros. set (f:= (fun a:X->Y => (fun x:X => w (a x)))). set (g := fun a':X-> Y' => fun x:X => (invweq w (a' x))). set (egf:= (fun a:X->Y => funextfunax X Y (fun x:X => (g (f a)) x) a (fun x: X => (homotinvweqweq w (a x))))). set (efg:= (fun a':X->Y' => funextfunax X Y' (fun x:X => (f (g a')) x) a' (fun x: X => (homotweqinvweq w (a' x))))). apply (gradth f g egf efg). Defined. Theorem funcontr { X : UU } (P:X -> UU) : (forall x:X, iscontr (P x)) -> iscontr (forall x:X, P x). Proof. intros X P X0 . set (T1 := forall x:X, P x). set (T2 := (hfiber (fun f: (X -> total2 P) => fun x: X => pr1 (f x)) (fun x:X => x))). assert (is1:isweq (@pr1 X P)). apply isweqpr1. assumption. set (w1:= weqpair (@pr1 X P) is1). assert (X1:iscontr T2). apply (isweqrcompwithweq w1 X (fun x:X => x)). apply ( iscontrretract _ _ (sectohfibertosec P ) X1). Defined. Corollary funcontrtwice { X : UU } (P: X-> X -> UU)(is: forall (x x':X), iscontr (P x x')): iscontr (forall (x x':X), P x x'). Proof. intros. assert (is1: forall x:X, iscontr (forall x':X, P x x')). intro. apply (funcontr _ (is x)). apply (funcontr _ is1). Defined. (** Proof of the fact that the [ toforallpaths ] from [paths s1 s2] to [forall t:T, paths (s1 t) (s2 t)] is a weak equivalence - a strong form of functional extensionality for sections of general families. The proof uses only [funcontr] which is an axiom i.e. its type satisfies [ isaprop ]. *) Lemma funextweql1 { T : UU } (P:T -> UU)(g: forall t:T, P t): iscontr (total2 (fun f:forall t:T, P t => forall t:T, paths (f t) (g t))). Proof. intros. set (X:= forall t:T, coconustot _ (g t)). assert (is1: iscontr X). apply (funcontr (fun t:T => coconustot _ (g t)) (fun t:T => iscontrcoconustot _ (g t))). set (Y:= total2 (fun f:forall t:T, P t => forall t:T, paths (f t) (g t))). set (p:= fun z: X => tpair (fun f:forall t:T, P t => forall t:T, paths (f t) (g t)) (fun t:T => pr1 (z t)) (fun t:T => pr2 (z t))). set (s:= fun u:Y => (fun t:T => coconustotpair _ ((pr2 u) t))). set (etap:= fun u: Y => tpair (fun f:forall t:T, P t => forall t:T, paths (f t) (g t)) (fun t:T => ((pr1 u) t)) (pr2 u)). assert (eps: forall u:Y, paths (p (s u)) (etap u)). intro. destruct u as [ t x ]. unfold p. unfold s. unfold etap. simpl. assert (ex: paths x (fun t0:T => x t0)). apply etacorrection. destruct ex. apply idpath. assert (eetap: forall u:Y, paths (etap u) u). intro. unfold etap. destruct u as [t x ]. simpl. set (ff:= fun fe: (total2 (fun f : forall t0 : T, P t0 => forall t0 : T, paths (f t0) (g t0))) => tpair (fun f : forall t0 : T, P t0 => forall t0 : T, paths (f t0) (g t0)) (fun t0:T => (pr1 fe) t0) (pr2 fe)). assert (isweqff: isweq ff). apply (isweqfpmap ( weqeta P ) (fun f: forall t:T, P t => forall t:T, paths (f t) (g t)) ). assert (ee: forall fe: (total2 (fun f : forall t0 : T, P t0 => forall t0 : T, paths (f t0) (g t0))), paths (ff (ff fe)) (ff fe)). intro. apply idpath. assert (eee: forall fe: (total2 (fun f : forall t0 : T, P t0 => forall t0 : T, paths (f t0) (g t0))), paths (ff fe) fe). intro. apply (invmaponpathsweq ( weqpair ff isweqff ) _ _ (ee fe)). apply (eee (tpair _ t x)). assert (eps0: forall u: Y, paths (p (s u)) u). intro. apply (pathscomp0 (eps u) (eetap u)). apply ( iscontrretract p s eps0). assumption. Defined. Theorem isweqtoforallpaths { T : UU } (P:T -> UU)( f g: forall t:T, P t) : isweq (toforallpaths P f g). Proof. intros. set (tmap:= fun ff: total2 (fun f0: forall t:T, P t => paths f0 g) => tpair (fun f0:forall t:T, P t => forall t:T, paths (f0 t) (g t)) (pr1 ff) (toforallpaths P (pr1 ff) g (pr2 ff))). assert (is1: iscontr (total2 (fun f0: forall t:T, P t => paths f0 g))). apply (iscontrcoconustot _ g). assert (is2:iscontr (total2 (fun f0:forall t:T, P t => forall t:T, paths (f0 t) (g t)))). apply funextweql1. assert (X: isweq tmap). apply (isweqcontrcontr tmap is1 is2). apply (isweqtotaltofib (fun f0: forall t:T, P t => paths f0 g) (fun f0:forall t:T, P t => forall t:T, paths (f0 t) (g t)) (fun f0:forall t:T, P t => (toforallpaths P f0 g)) X f). Defined. Theorem weqtoforallpaths { T : UU } (P:T -> UU)(f g : forall t:T, P t) : weq (paths f g) (forall t:T, paths (f t) (g t)) . Proof. intros. split with (toforallpaths P f g). apply isweqtoforallpaths. Defined. Definition funextsec { T : UU } (P: T-> UU) (s1 s2 : forall t:T, P t) : (forall t:T, paths (s1 t) (s2 t)) -> paths s1 s2 := invmap (weqtoforallpaths _ s1 s2) . Definition funextfun { X Y:UU } (f g:X->Y) : (forall x:X, paths (f x) (g x)) -> (paths f g):= funextsec (fun x:X => Y) f g. (** I do not know at the moment whether [funextfun] is equal (homotopic) to [funextfunax]. It is advisable in all cases to use [funextfun] or, equivalently, [funextsec], since it can be produced from [funcontr] and therefore is well defined up to a canonbical equivalence. In addition it is a homotopy inverse of [toforallpaths] which may be true or not for [funextsecax]. *) Theorem isweqfunextsec { T : UU } (P:T -> UU)(f g : forall t:T, P t) : isweq (funextsec P f g). Proof. intros. apply (isweqinvmap ( weqtoforallpaths _ f g ) ). Defined. Definition weqfunextsec { T : UU } (P:T -> UU)(f g : forall t:T, P t) : weq (forall t:T, paths (f t) (g t)) (paths f g) := weqpair _ ( isweqfunextsec P f g ) . (** ** Sections of "double fibration" [(P: T -> UU)(PP: forall t:T, P t -> UU)] and pairs of sections *) (** *** General case *) Definition totaltoforall { X : UU } (P : X -> UU ) ( PP : forall x:X, P x -> UU ) : total2 (fun s0: forall x:X, P x => forall x:X, PP x (s0 x)) -> forall x:X, total2 (PP x). Proof. intros X P PP X0 x. destruct X0 as [ t x0 ]. split with (t x). apply (x0 x). Defined. Definition foralltototal { X : UU } ( P : X -> UU ) ( PP : forall x:X, P x -> UU ): (forall x:X, total2 (PP x)) -> total2 (fun s0: forall x:X, P x => forall x:X, PP x (s0 x)). Proof. intros X P PP X0. split with (fun x:X => pr1 (X0 x)). apply (fun x:X => pr2 (X0 x)). Defined. Lemma lemmaeta1 { X : UU } (P:X->UU) (Q:(forall x:X, P x) -> UU)(s0: forall x:X, P x)(q: Q (fun x:X => (s0 x))): paths (tpair (fun s: (forall x:X, P x) => Q (fun x:X => (s x))) s0 q) (tpair (fun s: (forall x:X, P x) => Q (fun x:X => (s x))) (fun x:X => (s0 x)) q). Proof. intros. set (ff:= fun tp:total2 (fun s: (forall x:X, P x) => Q (fun x:X => (s x))) => tpair _ (fun x:X => pr1 tp x) (pr2 tp)). assert (X0 : isweq ff). apply (isweqfpmap ( weqeta P ) Q ). assert (ee: paths (ff (tpair (fun s : forall x : X, P x => Q (fun x : X => s x)) s0 q)) (ff (tpair (fun s : forall x : X, P x => Q (fun x : X => s x)) (fun x : X => s0 x) q))). apply idpath. apply (invmaponpathsweq ( weqpair ff X0 ) _ _ ee). Defined. Definition totaltoforalltototal { X : UU } ( P : X -> UU ) ( PP : forall x:X, P x -> UU )( ss : total2 (fun s0: forall x:X, P x => forall x:X, PP x (s0 x)) ): paths (foralltototal _ _ (totaltoforall _ _ ss)) ss. Proof. intros. destruct ss as [ t x ]. unfold foralltototal. unfold totaltoforall. simpl. set (et:= fun x:X => t x). assert (paths (tpair (fun s0 : forall x0 : X, P x0 => forall x0 : X, PP x0 (s0 x0)) t x) (tpair (fun s0 : forall x0 : X, P x0 => forall x0 : X, PP x0 (s0 x0)) et x)). apply (lemmaeta1 P (fun s: forall x:X, P x => forall x:X, PP x (s x)) t x). assert (ee: paths (tpair (fun s0 : forall x0 : X, P x0 => forall x0 : X, PP x0 (s0 x0)) et x) (tpair (fun s0 : forall x0 : X, P x0 => forall x0 : X, PP x0 (s0 x0)) et (fun x0 : X => x x0))). assert (eee: paths x (fun x0:X => x x0)). apply etacorrection. destruct eee. apply idpath. destruct ee. apply pathsinv0. assumption. Defined. Definition foralltototaltoforall { X : UU } ( P : X -> UU ) ( PP : forall x:X, P x -> UU ) ( ss : forall x:X, total2 (PP x)): paths (totaltoforall _ _ (foralltototal _ _ ss)) ss. Proof. intros. unfold foralltototal. unfold totaltoforall. simpl. assert (ee: forall x:X, paths (tpair (PP x) (pr1 (ss x)) (pr2 (ss x))) (ss x)). intro. apply (pathsinv0 (tppr (ss x))). apply (funextsec). assumption. Defined. Theorem isweqforalltototal { X : UU } ( P : X -> UU ) ( PP : forall x:X, P x -> UU ) : isweq (foralltototal P PP). Proof. intros. apply (gradth (foralltototal P PP) (totaltoforall P PP) (foralltototaltoforall P PP) (totaltoforalltototal P PP)). Defined. Theorem isweqtotaltoforall { X : UU } (P:X->UU)(PP:forall x:X, P x -> UU): isweq (totaltoforall P PP). Proof. intros. apply (gradth (totaltoforall P PP) (foralltototal P PP) (totaltoforalltototal P PP) (foralltototaltoforall P PP)). Defined. Definition weqforalltototal { X : UU } ( P : X -> UU ) ( PP : forall x:X, P x -> UU ) := weqpair _ ( isweqforalltototal P PP ) . Definition weqtotaltoforall { X : UU } ( P : X -> UU ) ( PP : forall x:X, P x -> UU ) := invweq ( weqforalltototal P PP ) . (** *** Functions to a dependent sum (to a [ total2 ]) *) Definition weqfuntototaltototal ( X : UU ) { Y : UU } ( Q : Y -> UU ) : weq ( X -> total2 Q ) ( total2 ( fun f : X -> Y => forall x : X , Q ( f x ) ) ) := weqforalltototal ( fun x : X => Y ) ( fun x : X => Q ) . (** *** Functions to direct product *) (** Note: we give direct proofs for this special case. *) Definition funtoprodtoprod { X Y Z : UU } ( f : X -> dirprod Y Z ) : dirprod ( X -> Y ) ( X -> Z ) := dirprodpair ( fun x : X => pr1 ( f x ) ) ( fun x : X => ( pr2 ( f x ) ) ) . Definition prodtofuntoprod { X Y Z : UU } ( fg : dirprod ( X -> Y ) ( X -> Z ) ) : X -> dirprod Y Z := match fg with tpair f g => fun x : X => dirprodpair ( f x ) ( g x ) end . Theorem weqfuntoprodtoprod ( X Y Z : UU ) : weq ( X -> dirprod Y Z ) ( dirprod ( X -> Y ) ( X -> Z ) ) . Proof. intros. set ( f := @funtoprodtoprod X Y Z ) . set ( g := @prodtofuntoprod X Y Z ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . apply funextfun . intro x . simpl . apply pathsinv0 . apply tppr . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . destruct a as [ fy fz ] . apply pathsdirprod . simpl . apply pathsinv0 . apply etacorrection . simpl . apply pathsinv0 . apply etacorrection . apply ( gradth _ _ egf efg ) . Defined . (** ** Homotopy fibers of the map [forall x:X, P x -> forall x:X, Q x] *) (** *** General case *) Definition maponsec { X:UU } (P Q : X -> UU) (f: forall x:X, P x -> Q x): (forall x:X, P x) -> (forall x:X, Q x) := fun s: forall x:X, P x => (fun x:X => (f x) (s x)). Definition maponsec1 { X Y : UU } (P:Y -> UU)(f:X-> Y): (forall y:Y, P y) -> (forall x:X, P (f x)) := fun sy: forall y:Y, P y => (fun x:X => sy (f x)). Definition hfibertoforall { X : UU } (P Q : X -> UU) (f: forall x:X, P x -> Q x)(s: forall x:X, Q x): hfiber (@maponsec _ _ _ f) s -> forall x:X, hfiber (f x) (s x). Proof. intro. intro. intro. intro. intro. unfold hfiber. set (map1:= totalfun (fun pointover : forall x : X, P x => paths (fun x : X => f x (pointover x)) s) (fun pointover : forall x : X, P x => forall x:X, paths ((f x) (pointover x)) (s x)) (fun pointover: forall x:X, P x => toforallpaths _ (fun x : X => f x (pointover x)) s )). set (map2 := totaltoforall P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))). set (themap := fun a:_ => map2 (map1 a)). assumption. Defined. Definition foralltohfiber { X : UU } ( P Q : X -> UU) (f: forall x:X, P x -> Q x)(s: forall x:X, Q x): (forall x:X, hfiber (f x) (s x)) -> hfiber (maponsec _ _ f) s. Proof. intro. intro. intro. intro. intro. unfold hfiber. set (map2inv := foralltototal P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))). set (map1inv := totalfun (fun pointover : forall x : X, P x => forall x:X, paths ((f x) (pointover x)) (s x)) (fun pointover : forall x : X, P x => paths (fun x : X => f x (pointover x)) s) (fun pointover: forall x:X, P x => funextsec _ (fun x : X => f x (pointover x)) s)). set (themap := fun a:_=> map1inv (map2inv a)). assumption. Defined. Theorem isweqhfibertoforall { X : UU } (P Q :X -> UU) (f: forall x:X, P x -> Q x)(s: forall x:X, Q x): isweq (hfibertoforall _ _ f s). Proof. intro. intro. intro. intro. intro. set (map1:= totalfun (fun pointover : forall x : X, P x => paths (fun x : X => f x (pointover x)) s) (fun pointover : forall x : X, P x => forall x:X, paths ((f x) (pointover x)) (s x)) (fun pointover: forall x:X, P x => toforallpaths _ (fun x : X => f x (pointover x)) s)). set (map2 := totaltoforall P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))). assert (is1: isweq map1). apply (isweqfibtototal _ _ (fun pointover: forall x:X, P x => weqtoforallpaths _ (fun x : X => f x (pointover x)) s )). assert (is2: isweq map2). apply isweqtotaltoforall. apply (twooutof3c map1 map2 is1 is2). Defined. Definition weqhfibertoforall { X : UU } (P Q :X -> UU) (f: forall x:X, P x -> Q x)(s: forall x:X, Q x) := weqpair _ ( isweqhfibertoforall P Q f s ) . Theorem isweqforalltohfiber { X : UU } (P Q : X -> UU) (f: forall x:X, P x -> Q x)(s: forall x:X, Q x): isweq (foralltohfiber _ _ f s). Proof. intro. intro. intro. intro. intro. set (map2inv := foralltototal P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))). assert (is2: isweq map2inv). apply (isweqforalltototal P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))). set (map1inv := totalfun (fun pointover : forall x : X, P x => forall x:X, paths ((f x) (pointover x)) (s x)) (fun pointover : forall x : X, P x => paths (fun x : X => f x (pointover x)) s) (fun pointover: forall x:X, P x => funextsec _ (fun x : X => f x (pointover x)) s)). assert (is1: isweq map1inv). (* ??? in this place 8.4 (actually trunk to 8.5) hangs if the next command is apply (isweqfibtototal _ _ (fun pointover: forall x:X, P x => weqfunextsec _ (fun x : X => f x (pointover x)) s ) ). and no -no-sharing option is turned on. It also hangs on exact (isweqfibtototal (fun pointover : forall x : X, P x => forall x : X, paths (f x (pointover x)) (s x)) (fun pointover : forall x : X, P x => paths (fun x : X => f x (pointover x)) s) (fun pointover: forall x:X, P x => weqfunextsec Q (fun x : X => f x (pointover x)) s ) ). for at least 2hrs. After adding "Opaque funextsec ." the "exact" commend goes through in <1sec and so does the "apply". If "Transparent funextsec." added after the "apply" the compilation hangs on "Define". *) Opaque funextsec . apply (isweqfibtototal _ _ (fun pointover: forall x:X, P x => weqfunextsec _ (fun x : X => f x (pointover x)) s ) ). apply (twooutof3c map2inv map1inv is2 is1). Defined. Transparent funextsec. Definition weqforalltohfiber { X : UU } (P Q : X -> UU) (f: forall x:X, P x -> Q x)(s: forall x:X, Q x) := weqpair _ ( isweqforalltohfiber P Q f s ) . (** *** The weak equivalence between section spaces (dependent products) defined by a family of weak equivalences [ weq ( P x ) ( Q x ) ] *) Corollary isweqmaponsec { X : UU } (P Q : X-> UU) (f: forall x:X, weq ( P x ) ( Q x) ) : isweq (maponsec _ _ f). Proof. intros. unfold isweq. intro y. assert (is1: iscontr (forall x:X, hfiber (f x) (y x))). assert (is2: forall x:X, iscontr (hfiber (f x) (y x))). intro x. apply ( ( pr2 ( f x ) ) (y x)). apply funcontr. assumption. apply (iscontrweqb (weqhfibertoforall P Q f y) is1 ). Defined. Definition weqonseqfibers { X : UU } (P Q : X-> UU) (f: forall x:X, weq ( P x ) ( Q x )) := weqpair _ ( isweqmaponsec P Q f ) . (** *** Composition of functions with a weak equivalence on the right *) Definition weqffun ( X : UU ) { Y Z : UU } ( w : weq Y Z ) : weq ( X -> Y ) ( X -> Z ) := weqonseqfibers _ _ ( fun x : X => w ) . (** ** The map between section spaces (dependent products) defined by the map between the bases [ f: Y -> X ] *) (** *** General case *) Definition maponsec1l0 { X : UU } (P:X -> UU)(f:X-> X)(h: forall x:X, paths (f x) x)(s: forall x:X, P x): (forall x:X, P x) := (fun x:X => transportf P (h x) (s (f x))). Lemma maponsec1l1 { X : UU } (P:X -> UU)(x:X)(s:forall x:X, P x): paths (maponsec1l0 P (fun x:X => x) (fun x:X => idpath x) s x) (s x). Proof. intros. unfold maponsec1l0. apply idpath. Defined. Lemma maponsec1l2 { X : UU } (P:X -> UU)(f:X-> X)(h: forall x:X, paths (f x) x)(s: forall x:X, P x)(x:X): paths (maponsec1l0 P f h s x) (s x). Proof. intros. set (map:= fun ff: total2 (fun f0:X->X => forall x:X, paths (f0 x) x) => maponsec1l0 P (pr1 ff) (pr2 ff) s x). assert (is1: iscontr (total2 (fun f0:X->X => forall x:X, paths (f0 x) x))). apply funextweql1. assert (e: paths (tpair (fun f0:X->X => forall x:X, paths (f0 x) x) f h) (tpair (fun f0:X->X => forall x:X, paths (f0 x) x) (fun x0:X => x0) (fun x0:X => idpath x0))). apply proofirrelevancecontr. assumption. apply (maponpaths map e). Defined. Theorem isweqmaponsec1 { X Y : UU } (P:Y -> UU)(f: weq X Y ) : isweq (maponsec1 P f). Proof. intros. set (map:= maponsec1 P f). set (invf:= invmap f). set (e1:= homotweqinvweq f). set (e2:= homotinvweqweq f ). set (im1:= fun sx: forall x:X, P (f x) => (fun y:Y => sx (invf y))). set (im2:= fun sy': forall y:Y, P (f (invf y)) => (fun y:Y => transportf _ (homotweqinvweq f y) (sy' y))). set (invmapp := (fun sx: forall x:X, P (f x) => im2 (im1 sx))). assert (efg0: forall sx: (forall x:X, P (f x)), forall x:X, paths ((map (invmapp sx)) x) (sx x)). intro. intro. unfold map. unfold invmapp. unfold im1. unfold im2. unfold maponsec1. simpl. fold invf. set (ee:=e2 x). fold invf in ee. set (e3x:= fun x0:X => invmaponpathsweq f (invf (f x0)) x0 (homotweqinvweq f (f x0))). set (e3:=e3x x). assert (e4: paths (homotweqinvweq f (f x)) (maponpaths f e3)). apply (pathsinv0 (pathsweq4 f (invf (f x)) x _)). assert (e5:paths (transportf P (homotweqinvweq f (f x)) (sx (invf (f x)))) (transportf P (maponpaths f e3) (sx (invf (f x))))). apply (maponpaths (fun e40:_ => (transportf P e40 (sx (invf (f x))))) e4). assert (e6: paths (transportf P (maponpaths f e3) (sx (invf (f x)))) (transportf (fun x:X => P (f x)) e3 (sx (invf (f x))))). apply (pathsinv0 (functtransportf f P e3 (sx (invf (f x))))). set (ff:= fun x:X => invf (f x)). assert (e7: paths (transportf (fun x : X => P (f x)) e3 (sx (invf (f x)))) (sx x)). apply (maponsec1l2 (fun x:X => P (f x)) ff e3x sx x). apply (pathscomp0 (pathscomp0 e5 e6) e7). assert (efg: forall sx: (forall x:X, P (f x)), paths (map (invmapp sx)) sx). intro. apply (funextsec _ _ _ (efg0 sx)). assert (egf0: forall sy: (forall y:Y, P y), forall y:Y, paths ((invmapp (map sy)) y) (sy y)). intros. unfold invmapp. unfold map. unfold im1. unfold im2. unfold maponsec1. set (ff:= fun y:Y => f (invf y)). fold invf. apply (maponsec1l2 P ff ( homotweqinvweq f ) sy y). assert (egf: forall sy: (forall y:Y, P y), paths (invmapp (map sy)) sy). intro. apply (funextsec _ _ _ (egf0 sy)). apply (gradth map invmapp egf efg). Defined. Definition weqonsecbase { X Y : UU } ( P : Y -> UU ) ( f : weq X Y ) := weqpair _ ( isweqmaponsec1 P f ) . (** *** Composition of functions with a weak equivalence on the left *) Definition weqbfun { X Y : UU } ( Z : UU ) ( w : weq X Y ) : weq ( Y -> Z ) ( X -> Z ) := weqonsecbase _ w . (** ** Sections of families over an empty type and over coproducts *) (** *** General case *) Definition iscontrsecoverempty ( P : empty -> UU ) : iscontr ( forall x : empty , P x ) . Proof . intro . split with ( fun x : empty => fromempty x ) . intro t . apply funextsec . intro t0 . destruct t0 . Defined . Definition iscontrsecoverempty2 { X : UU } ( P : X -> UU ) ( is : neg X ) : iscontr ( forall x : X , P x ) . Proof . intros . set ( w := weqtoempty is ) . set ( w' := weqonsecbase P ( invweq w ) ) . apply ( iscontrweqb w' ( iscontrsecoverempty _ ) ) . Defined . Definition secovercoprodtoprod { X Y : UU } ( P : coprod X Y -> UU ) ( a: forall xy : coprod X Y , P xy ) : dirprod ( forall x : X , P ( ii1 x ) ) ( forall y : Y , P ( ii2 y ) ) := dirprodpair ( fun x : X => a ( ii1 x ) ) ( fun y : Y => a ( ii2 y ) ) . Definition prodtosecovercoprod { X Y : UU } ( P : coprod X Y -> UU ) ( a : dirprod ( forall x : X , P ( ii1 x ) ) ( forall y : Y , P ( ii2 y ) ) ) : forall xy : coprod X Y , P xy . Proof . intros . destruct xy as [ x | y ] . apply ( pr1 a x ) . apply ( pr2 a y ) . Defined . Definition weqsecovercoprodtoprod { X Y : UU } ( P : coprod X Y -> UU ) : weq ( forall xy : coprod X Y , P xy ) ( dirprod ( forall x : X , P ( ii1 x ) ) ( forall y : Y , P ( ii2 y ) ) ) . Proof . intros . set ( f := secovercoprodtoprod P ) . set ( g := prodtosecovercoprod P ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro . apply funextsec . intro t . destruct t as [ x | y ] . apply idpath . apply idpath . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro . destruct a as [ ax ay ] . apply ( pathsdirprod ) . apply funextsec . intro x . apply idpath . apply funextsec . intro y . apply idpath . apply ( gradth _ _ egf efg ) . Defined . (** *** Functions from the empty type *) Theorem iscontrfunfromempty ( X : UU ) : iscontr ( empty -> X ) . Proof . intro . split with fromempty . intro t . apply funextfun . intro x . destruct x . Defined . Theorem iscontrfunfromempty2 ( X : UU ) { Y : UU } ( is : neg Y ) : iscontr ( Y -> X ) . Proof. intros . set ( w := weqtoempty is ) . set ( w' := weqbfun X ( invweq w ) ) . apply ( iscontrweqb w' ( iscontrfunfromempty X ) ) . Defined . (** *** Functions from a coproduct *) Definition funfromcoprodtoprod { X Y Z : UU } ( f : coprod X Y -> Z ) : dirprod ( X -> Z ) ( Y -> Z ) := dirprodpair ( fun x : X => f ( ii1 x ) ) ( fun y : Y => f ( ii2 y ) ) . Definition prodtofunfromcoprod { X Y Z : UU } ( fg : dirprod ( X -> Z ) ( Y -> Z ) ) : coprod X Y -> Z := match fg with tpair f g => sumofmaps f g end . Theorem weqfunfromcoprodtoprod ( X Y Z : UU ) : weq ( coprod X Y -> Z ) ( dirprod ( X -> Z ) ( Y -> Z ) ) . Proof. intros . set ( f := @funfromcoprodtoprod X Y Z ) . set ( g := @prodtofunfromcoprod X Y Z ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . apply funextfun . intro xy . destruct xy as [ x | y ] . apply idpath . apply idpath . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . destruct a as [ fx fy ] . simpl . apply pathsdirprod . simpl . apply pathsinv0 . apply etacorrection . simpl . apply pathsinv0 . apply etacorrection . apply ( gradth _ _ egf efg ) . Defined . (** ** Sections of families over contractible types and over [ total2 ] (over dependent sums) *) (** *** General case *) Definition tosecoverunit ( P : unit -> UU ) ( p : P tt ) : forall t : unit , P t . Proof . intros . destruct t . apply p . Defined . Definition weqsecoverunit ( P : unit -> UU ) : weq ( forall t : unit , P t ) ( P tt ) . Proof . intro. set ( f := fun a : forall t : unit , P t => a tt ) . set ( g := tosecoverunit P ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro . apply funextsec . intro t . destruct t . apply idpath . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intros . apply idpath . apply ( gradth _ _ egf efg ) . Defined . Definition weqsecovercontr { X : UU } ( P : X -> UU ) ( is : iscontr X ) : weq ( forall x : X , P x ) ( P ( pr1 is ) ) . Proof . intros . set ( w1 := weqonsecbase P ( wequnittocontr is ) ) . apply ( weqcomp w1 ( weqsecoverunit _ ) ) . Defined . Definition tosecovertotal2 { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) ( a : forall x : X , forall p : P x , Q ( tpair _ x p ) ) : forall xp : total2 P , Q xp . Proof . intros . destruct xp as [ x p ] . apply ( a x p ) . Defined . Definition weqsecovertotal2 { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) : weq ( forall xp : total2 P , Q xp ) ( forall x : X , forall p : P x , Q ( tpair _ x p ) ) . Proof . intros . set ( f := fun a : forall xp : total2 P , Q xp => fun x : X => fun p : P x => a ( tpair _ x p ) ) . set ( g := tosecovertotal2 P Q ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro . apply funextsec . intro xp . destruct xp as [ x p ] . apply idpath . assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro . apply funextsec . intro x . apply funextsec . intro p . apply idpath . apply ( gradth _ _ egf efg ) . Defined . (** *** Functions from [ unit ] and from contractible types *) Definition weqfunfromunit ( X : UU ) : weq ( unit -> X ) X := weqsecoverunit _ . Definition weqfunfromcontr { X : UU } ( Y : UU ) ( is : iscontr X ) : weq ( X -> Y ) Y := weqsecovercontr _ is . (** *** Functions from [ total2 ] *) Definition weqfunfromtotal2 { X : UU } ( P : X -> UU ) ( Y : UU ) : weq ( total2 P -> Y ) ( forall x : X , P x -> Y ) := weqsecovertotal2 P _ . (** *** Functions from direct product *) Definition weqfunfromdirprod ( X X' Y : UU ) : weq ( dirprod X X' -> Y ) ( forall x : X , X' -> Y ) := weqsecovertotal2 _ _ . (** ** Theorem saying that if each member of a family is of h-level n then the space of sections of the family is of h-level n. *) (** *** General case *) Theorem impred (n:nat) { T : UU } (P:T -> UU): (forall t:T, isofhlevel n (P t)) -> (isofhlevel n (forall t:T, P t)). Proof. intro. induction n as [ | n IHn ] . intros T P X. apply (funcontr P X). intros T P X. unfold isofhlevel in X. unfold isofhlevel. intros x x' . assert (is: forall t:T, isofhlevel n (paths (x t) (x' t))). intro. apply (X t (x t) (x' t)). assert (is2: isofhlevel n (forall t:T, paths (x t) (x' t))). apply (IHn _ (fun t0:T => paths (x t0) (x' t0)) is). set (u:=toforallpaths P x x'). assert (is3:isweq u). apply isweqtoforallpaths. set (v:= invmap ( weqpair u is3) ). assert (is4: isweq v). apply isweqinvmap. apply (isofhlevelweqf n ( weqpair v is4 )). assumption. Defined. Corollary impredtwice (n:nat) { T T' : UU } (P:T -> T' -> UU): (forall (t:T)(t':T'), isofhlevel n (P t t')) -> (isofhlevel n (forall (t:T)(t':T'), P t t')). Proof. intros n T T' P X. assert (is1: forall t:T, isofhlevel n (forall t':T', P t t')). intro. apply (impred n _ (X t)). apply (impred n _ is1). Defined. Corollary impredfun (n:nat)(X Y:UU)(is: isofhlevel n Y) : isofhlevel n (X -> Y). Proof. intros. apply (impred n (fun x:_ => Y) (fun x:X => is)). Defined. Theorem impredtech1 (n:nat)(X Y: UU) : (X -> isofhlevel n Y) -> isofhlevel n (X -> Y). Proof. intro. induction n as [ | n IHn ] . intros X Y X0. simpl. split with (fun x:X => pr1 (X0 x)). intro t . assert (s1: forall x:X, paths (t x) (pr1 (X0 x))). intro. apply proofirrelevancecontr. apply (X0 x). apply funextsec. assumption. intros X Y X0. simpl. assert (X1: X -> isofhlevel (S n) (X -> Y)). intro X1 . apply impred. assumption. intros x x' . assert (s1: isofhlevel n (forall xx:X, paths (x xx) (x' xx))). apply impred. intro t . apply (X0 t). assert (w: weq (forall xx:X, paths (x xx) (x' xx)) (paths x x')). apply (weqfunextsec _ x x' ). apply (isofhlevelweqf n w s1). Defined. (** *** Functions to a contractible type *) Theorem iscontrfuntounit ( X : UU ) : iscontr ( X -> unit ) . Proof . intro . split with ( fun x : X => tt ) . intro f . apply funextfun . intro x . destruct ( f x ) . apply idpath . Defined . Theorem iscontrfuntocontr ( X : UU ) { Y : UU } ( is : iscontr Y ) : iscontr ( X -> Y ) . Proof . intros . set ( w := weqcontrtounit is ) . set ( w' := weqffun X w ) . apply ( iscontrweqb w' ( iscontrfuntounit X ) ) . Defined . (** *** Functions to a proposition *) Lemma isapropimpl ( X Y : UU ) ( isy : isaprop Y ) : isaprop ( X -> Y ) . Proof. intros. apply impred. intro. assumption. Defined. (** *** Functions to an empty type (generalization of [ isapropneg ]) *) Theorem isapropneg2 ( X : UU ) { Y : UU } ( is : neg Y ) : isaprop ( X -> Y ) . Proof . intros . apply impred . intro . apply ( isapropifnegtrue is ) . Defined . (** ** Theorems saying that [ iscontr T ], [ isweq f ] etc. are of h-level 1 *) Theorem iscontriscontr { X : UU } ( is : iscontr X ) : iscontr ( iscontr X ). Proof. intros X X0 . assert (is0: forall (x x':X), paths x x'). apply proofirrelevancecontr. assumption. assert (is1: forall cntr:X, iscontr (forall x:X, paths x cntr)). intro. assert (is2: forall x:X, iscontr (paths x cntr)). assert (is2: isaprop X). apply isapropifcontr. assumption. unfold isaprop in is2. unfold isofhlevel in is2. intro x . apply (is2 x cntr). apply funcontr. assumption. set (f:= @pr1 X (fun cntr:X => forall x:X, paths x cntr)). assert (X1:isweq f). apply isweqpr1. assumption. change (total2 (fun cntr : X => forall x : X, paths x cntr)) with (iscontr X) in X1. apply (iscontrweqb ( weqpair f X1 ) ) . assumption. Defined. Theorem isapropiscontr (T:UU): isaprop (iscontr T). Proof. intros. unfold isaprop. unfold isofhlevel. intros x x' . assert (is: iscontr(iscontr T)). apply iscontriscontr. apply x. assert (is2: isaprop (iscontr T)). apply ( isapropifcontr is ) . apply (is2 x x'). Defined. Theorem isapropisweq { X Y : UU } (f:X-> Y) : isaprop (isweq f). Proof. intros. unfold isweq. apply (impred (S O) (fun y:Y => iscontr (hfiber f y)) (fun y:Y => isapropiscontr (hfiber f y))). Defined. Theorem isapropisisolated ( X : UU ) ( x : X ) : isaprop ( isisolated X x ) . Proof. intros . apply isofhlevelsn . intro is . apply impred . intro x' . apply ( isapropdec _ ( isaproppathsfromisolated X x is x' ) ) . Defined . Theorem isapropisdeceq (X:UU): isaprop (isdeceq X). Proof. intro. apply ( isofhlevelsn 0 ) . intro is . unfold isdeceq. apply impred . intro x . apply ( isapropisisolated X x ) . Defined . Definition isapropisdecprop ( X : UU ) : isaprop ( isdecprop X ) := isapropiscontr ( coprod X ( neg X ) ) . Theorem isapropisofhlevel (n:nat)(X:UU): isaprop (isofhlevel n X). Proof. intro. unfold isofhlevel. induction n as [ | n IHn ] . apply isapropiscontr. intro X . assert (X0: forall (x x':X), isaprop ((fix isofhlevel (n0 : nat) (X0 : UU) {struct n0} : UU := match n0 with | O => iscontr X0 | S m => forall x0 x'0 : X0, isofhlevel m (paths x0 x'0) end) n (paths x x'))). intros. apply (IHn (paths x x')). assert (is1: (forall x:X, isaprop (forall x' : X, (fix isofhlevel (n0 : nat) (X1 : UU) {struct n0} : UU := match n0 with | O => iscontr X1 | S m => forall x0 x'0 : X1, isofhlevel m (paths x0 x'0) end) n (paths x x')))). intro. apply (impred ( S O ) _ (X0 x)). apply (impred (S O) _ is1). Defined. Corollary isapropisaprop (X:UU) : isaprop (isaprop X). Proof. intro. apply (isapropisofhlevel (S O)). Defined. Corollary isapropisaset (X:UU): isaprop (isaset X). Proof. intro. apply (isapropisofhlevel (S (S O))). Defined. Theorem isapropisofhlevelf ( n : nat ) { X Y : UU } ( f : X -> Y ) : isaprop ( isofhlevelf n f ) . Proof . intros . unfold isofhlevelf . apply impred . intro y . apply isapropisofhlevel . Defined . Definition isapropisincl { X Y : UU } ( f : X -> Y ) := isapropisofhlevelf 1 f . (** ** Theorems saying that various [ pr1 ] maps are inclusions *) Theorem isinclpr1weq ( X Y : UU ) : isincl ( @pr1 _ ( fun f : X -> Y => isweq f ) ) . Proof. intros . apply isinclpr1 . intro f. apply isapropisweq . Defined . Theorem isinclpr1isolated ( T : UU ) : isincl ( pr1isolated T ) . Proof . intro . apply ( isinclpr1 _ ( fun t : T => isapropisisolated T t ) ) . Defined . (** ** Various weak equivalences between spaces of weak equivalences *) (** *** Composition with a weak quivalence is a weak equivalence on weak equivalences *) Theorem weqfweq ( X : UU ) { Y Z : UU } ( w : weq Y Z ) : weq ( weq X Y ) ( weq X Z ) . Proof. intros . set ( f := fun a : weq X Y => weqcomp a w ) . set ( g := fun b : weq X Z => weqcomp b ( invweq w ) ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun . intro x . apply ( homotinvweqweq w ( a x ) ) . assert ( efg : forall b : _ , paths ( f ( g b ) ) b ) . intro b . apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun . intro x . apply ( homotweqinvweq w ( b x ) ) . apply ( gradth _ _ egf efg ) . Defined . Theorem weqbweq { X Y : UU } ( Z : UU ) ( w : weq X Y ) : weq ( weq Y Z ) ( weq X Z ) . Proof. intros . set ( f := fun a : weq Y Z => weqcomp w a ) . set ( g := fun b : weq X Z => weqcomp ( invweq w ) b ) . split with f . assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun . intro y . apply ( maponpaths a ( homotweqinvweq w y ) ) . assert ( efg : forall b : _ , paths ( f ( g b ) ) b ) . intro b . apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun . intro x . apply ( maponpaths b ( homotinvweqweq w x ) ) . apply ( gradth _ _ egf efg ) . Defined . (** *** Invertion on weak equivalences as a weak equivalence *) (** Comment : note that full form of [ funextfun ] is only used in the proof of this theorem in the form of [ isapropisweq ]. The rest of the proof can be completed using eta-conversion . *) Theorem weqinvweq ( X Y : UU ) : weq ( weq X Y ) ( weq Y X ) . Proof . intros . set ( f := fun w : weq X Y => invweq w ) . set ( g := fun w : weq Y X => invweq w ) . split with f . assert ( egf : forall w : _ , paths ( g ( f w ) ) w ) . intro . apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun . intro x . unfold f. unfold g . unfold invweq . simpl . unfold invmap . simpl . apply idpath . assert ( efg : forall w : _ , paths ( f ( g w ) ) w ) . intro . apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun . intro x . unfold f. unfold g . unfold invweq . simpl . unfold invmap . simpl . apply idpath . apply ( gradth _ _ egf efg ) . Defined . (** ** h-levels of spaces of weak equivalences *) (** *** Weak equivalences to and from types of h-level ( S n ) *) Theorem isofhlevelsnweqtohlevelsn ( n : nat ) ( X Y : UU ) ( is : isofhlevel ( S n ) Y ) : isofhlevel ( S n ) ( weq X Y ) . Proof . intros . apply ( isofhlevelsninclb n _ ( isinclpr1weq _ _ ) ) . apply impred . intro . apply is . Defined . Theorem isofhlevelsnweqfromhlevelsn ( n : nat ) ( X Y : UU ) ( is : isofhlevel ( S n ) Y ) : isofhlevel ( S n ) ( weq Y X ) . Proof. intros . apply ( isofhlevelweqf ( S n ) ( weqinvweq X Y ) ( isofhlevelsnweqtohlevelsn n X Y is ) ) . Defined . (** *** Weak equivalences to and from contractible types *) Theorem isapropweqtocontr ( X : UU ) { Y : UU } ( is : iscontr Y ) : isaprop ( weq X Y ) . Proof . intros . apply ( isofhlevelsnweqtohlevelsn 0 _ _ ( isapropifcontr is ) ) . Defined . Theorem isapropweqfromcontr ( X : UU ) { Y : UU } ( is : iscontr Y ) : isaprop ( weq Y X ) . Proof. intros . apply ( isofhlevelsnweqfromhlevelsn 0 X _ ( isapropifcontr is ) ) . Defined . (** *** Weak equivalences to and from propositions *) Theorem isapropweqtoprop ( X Y : UU ) ( is : isaprop Y ) : isaprop ( weq X Y ) . Proof . intros . apply ( isofhlevelsnweqtohlevelsn 0 _ _ is ) . Defined . Theorem isapropweqfromprop ( X Y : UU )( is : isaprop Y ) : isaprop ( weq Y X ) . Proof. intros . apply ( isofhlevelsnweqfromhlevelsn 0 X _ is ) . Defined . (** *** Weak equivalences to and from sets *) Theorem isasetweqtoset ( X Y : UU ) ( is : isaset Y ) : isaset ( weq X Y ) . Proof . intros . apply ( isofhlevelsnweqtohlevelsn 1 _ _ is ) . Defined . Theorem isasetweqfromset ( X Y : UU )( is : isaset Y ) : isaset ( weq Y X ) . Proof. intros . apply ( isofhlevelsnweqfromhlevelsn 1 X _ is ) . Defined . (** *** Weak equivalences to an empty type *) Theorem isapropweqtoempty ( X : UU ) : isaprop ( weq X empty ) . Proof . intro . apply ( isofhlevelsnweqtohlevelsn 0 _ _ ( isapropempty ) ) . Defined . Theorem isapropweqtoempty2 ( X : UU ) { Y : UU } ( is : neg Y ) : isaprop ( weq X Y ) . Proof. intros . apply ( isofhlevelsnweqtohlevelsn 0 _ _ ( isapropifnegtrue is ) ) . Defined . (** *** Weak equivalences from an empty type *) Theorem isapropweqfromempty ( X : UU ) : isaprop ( weq empty X ) . Proof . intro . apply ( isofhlevelsnweqfromhlevelsn 0 X _ ( isapropempty ) ) . Defined . Theorem isapropweqfromempty2 ( X : UU ) { Y : UU } ( is : neg Y ) : isaprop ( weq Y X ) . Proof. intros . apply ( isofhlevelsnweqfromhlevelsn 0 X _ ( isapropifnegtrue is ) ) . Defined . (** *** Weak equivalences to and from [ unit ] *) Theorem isapropweqtounit ( X : UU ) : isaprop ( weq X unit ) . Proof . intro . apply ( isofhlevelsnweqtohlevelsn 0 _ _ ( isapropunit ) ) . Defined . Theorem isapropweqfromunit ( X : UU ) : isaprop ( weq unit X ) . Proof. intros . apply ( isofhlevelsnweqfromhlevelsn 0 X _ ( isapropunit ) ) . Defined . (** ** Weak auto-equivalences of a type with an isolated point *) Definition cutonweq { T : UU } ( t : T ) ( is : isisolated T t ) ( w : weq T T ) : dirprod ( isolated T ) ( weq ( compl T t ) ( compl T t ) ) := dirprodpair ( isolatedpair T ( w t ) ( isisolatedweqf w t is ) ) ( weqcomp ( weqoncompl w t ) ( weqtranspos0 ( w t ) t ( isisolatedweqf w t is ) is ) ) . Definition invcutonweq { T : UU } ( t : T ) ( is : isisolated T t ) ( t'w : dirprod ( isolated T ) ( weq ( compl T t ) ( compl T t ) ) ) : weq T T := weqcomp ( weqrecomplf t t is is ( pr2 t'w ) ) ( weqtranspos t ( pr1 ( pr1 t'w ) ) is ( pr2 ( pr1 t'w ) ) ) . Lemma pathsinvcuntonweqoft { T : UU } ( t : T ) ( is : isisolated T t ) ( t'w : dirprod ( isolated T ) ( weq ( compl T t ) ( compl T t ) ) ) : paths ( invcutonweq t is t'w t ) ( pr1 ( pr1 t'w ) ) . Proof. intros . unfold invcutonweq . simpl . unfold recompl . unfold coprodf . unfold invmap . simpl . unfold invrecompl . destruct ( is t ) as [ ett | nett ] . apply pathsfuntransposoft1 . destruct ( nett ( idpath _ ) ) . Defined . Definition weqcutonweq ( T : UU ) ( t : T ) ( is : isisolated T t ) : weq ( weq T T ) ( dirprod ( isolated T ) ( weq ( compl T t ) ( compl T t ) ) ) . Proof . intros . set ( f := cutonweq t is ) . set ( g := invcutonweq t is ) . split with f . assert ( egf : forall w : _ , paths ( g ( f w ) ) w ) . intro w . apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) _ _ ) . apply funextfun . intro t' . simpl . unfold invmap . simpl . unfold coprodf . unfold invrecompl . destruct ( is t' ) as [ ett' | nett' ] . simpl . rewrite ( pathsinv0 ett' ) . apply pathsfuntransposoft1 . simpl . unfold funtranspos0 . simpl . destruct ( is ( w t ) ) as [ etwt | netwt ] . destruct ( is ( w t' ) ) as [ etwt' | netwt' ] . destruct (negf (invmaponpathsincl w (isofhlevelfweq 1 w) t t') nett' (pathscomp0 (pathsinv0 etwt) etwt')) . simpl . assert ( newtt'' := netwt' ) . rewrite etwt in netwt' . apply ( pathsfuntransposofnet1t2 t ( w t ) is _ ( w t' ) newtt'' netwt' ) . simpl . destruct ( is ( w t' ) ) as [ etwt' | netwt' ] . simpl . change ( w t' ) with ( pr1 w t' ) in etwt' . rewrite ( pathsinv0 etwt' ). apply ( pathsfuntransposoft2 t ( w t ) is _ ) . simpl . assert ( ne : neg ( paths ( w t ) ( w t' ) ) ) . apply ( negf ( invmaponpathsweq w _ _ ) nett' ) . apply ( pathsfuntransposofnet1t2 t ( w t ) is _ ( w t' ) netwt' ne ) . assert ( efg : forall xw : _ , paths ( f ( g xw ) ) xw ) . intro . destruct xw as [ x w ] . destruct x as [ t' is' ] . simpl in w . apply pathsdirprod . apply ( invmaponpathsincl _ ( isinclpr1isolated _ ) ) . simpl . unfold recompl . unfold coprodf . unfold invmap . simpl . unfold invrecompl . destruct ( is t ) as [ ett | nett ] . apply pathsfuntransposoft1 . destruct ( nett ( idpath _ ) ) . simpl . apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) _ _ ) . apply funextfun . intro x . destruct x as [ x netx ] . unfold g . unfold invcutonweq . simpl . set ( int := funtranspos ( tpair _ t is ) ( tpair _ t' is' ) (recompl T t (coprodf w (fun x0 : unit => x0) (invmap (weqrecompl T t is) t))) ) . assert ( eee : paths int t' ) . unfold int . unfold recompl . unfold coprodf . unfold invmap . simpl . unfold invrecompl . destruct ( is t ) as [ ett | nett ] . apply ( pathsfuntransposoft1 ) . destruct ( nett ( idpath _ ) ) . assert ( isint : isisolated _ int ) . rewrite eee . apply is' . apply ( ishomotinclrecomplf _ _ isint ( funtranspos0 _ _ _ ) _ _ ) . simpl . change ( recomplf int t isint (funtranspos0 int t is) ) with ( funtranspos ( tpair _ int isint ) ( tpair _ t is ) ) . assert ( ee : paths ( tpair _ int isint) ( tpair _ t' is' ) ) . apply ( invmaponpathsincl _ ( isinclpr1isolated _ ) _ _ ) . simpl . apply eee . rewrite ee . set ( e := homottranspost2t1t1t2 t t' is is' (recompl T t (coprodf w (fun x0 : unit => x0) (invmap (weqrecompl T t is) x))) ) . unfold funcomp in e . unfold idfun in e . rewrite e . unfold recompl . unfold coprodf . unfold invmap . simpl . unfold invrecompl . destruct ( is x ) as [ etx | netx' ] . destruct ( netx etx ) . apply ( maponpaths ( @pr1 _ _ ) ) . apply ( maponpaths w ) . apply ( invmaponpathsincl _ ( isinclpr1compl _ _ ) _ _ ) . simpl . apply idpath . apply ( gradth _ _ egf efg ) . Defined . (* Coprojections i.e. functions which are weakly equivalent to functions of the form ii1: X -> coprod X Y Definition locsplit (X:UU)(Y:UU)(f:X -> Y):= forall y:Y, coprod (hfiber f y) (hfiber f y -> empty). Definition dnegimage (X:UU)(Y:UU)(f:X -> Y):= total2 Y (fun y:Y => dneg(hfiber f y)). Definition dnegimageincl (X Y:UU)(f:X -> Y):= pr1 Y (fun y:Y => dneg(hfiber f y)). Definition xtodnegimage (X:UU)(Y:UU)(f:X -> Y): X -> dnegimage f:= fun x:X => tpair (f x) ((todneg _) (hfiberpair f (f x) x (idpath (f x)))). Definition locsplitsec (X:UU)(Y:UU)(f:X->Y)(ls: locsplit f): dnegimage f -> X := fun u: _ => match u with tpair y psi => match (ls y) with ii1 z => pr1 z| ii2 phi => fromempty (psi phi) end end. Definition locsplitsecissec (X Y:UU)(f:X->Y)(ls: locsplit f)(u:dnegimage f): paths (xtodnegimage f (locsplitsec f ls u)) u. Proof. intros. set (p:= xtodnegimage f). set (s:= locsplitsec f ls). assert (paths (pr1 (p (s u))) (pr1 u)). unfold p. unfold xtodnegimage. unfold s. unfold locsplitsec. simpl. induction u. set (lst:= ls t). induction lst. simpl. apply (pr2 x0). induction (x y). assert (is: isofhlevelf (S O) (dnegimageincl f)). apply (isofhlevelfpr1 (S O) (fun y:Y => isapropdneg (hfiber f y))). assert (isw: isweq (maponpaths (dnegimageincl f) (p (s u)) u)). apply (isofhlevelfonpaths O _ is). apply (invmap _ isw X0). Defined. Definition negimage (X:UU)(Y:UU)(f:X -> Y):= total2 Y (fun y:Y => neg(hfiber f y)). Definition negimageincl (X Y:UU)(f:X -> Y):= pr1 Y (fun y:Y => neg(hfiber f y)). Definition imsum (X:UU)(Y:UU)(f:X -> Y): coprod (dnegimage f) (negimage f) -> Y:= fun u:_ => match u with ii1 z => pr1 z| ii2 z => pr1 z end. *) Voevodsky-Coq/Generalities/._uuu.v000777 000765 000024 00000000256 12346040720 020044 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/Generalities/uuu.v000777 000765 000024 00000004754 12346040720 017636 0ustar00nicolastaff000000 000000 (** * Introduction. Vladimir Voevodsky . Feb. 2010 - Sep. 2011 This is the first in the group of files which contain the (current state of) the mathematical library for theproof assistant Coq based on the Univalent Foundations. It contains some new notations for constructions defined in Coq.Init library as well as the definition of dependent sum as a record. *) (** Preambule. *) Unset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *) (** Universe structure *) Notation UUU := Set . (** Empty type. The empty type is introduced in Coq.Init.Datatypes by the line: [ Inductive Empty_set : Set := . ] *) Notation empty := Empty_set. (** Identity Types. Idenity types are introduced in Coq.Init.Datatypes by the lines : [ Inductive identity ( A : Type ) ( a : A ) : A -> Type := identity_refl : identity _ a a . Hint Resolve identity_refl : core . ] *) Notation paths := identity . Notation idpath := identity_refl . (** Coproducts . The coproduct of two types is introduced in Coq.Init.Datatypes by the lines: [ Inductive sum (A B:Type) : Type := | inl : A -> sum A B | inr : B -> sum A B. ] *) Notation coprod := sum . Notation ii1fun := inl . Notation ii2fun := inr . Notation ii1 := inl . Notation ii2 := inr . Implicit Arguments ii1 [ A B ] . Implicit Arguments ii2 [ A B ] . (** Dpendent sums. One can not use a new record each time one needs it because the general theorems about this construction would not apply to new instances of "Record" due to the "generativity" of inductive definitions in Coq. One could use "Inductive" instead of "Record" here but using "Record" which is equivalent to "Structure" allows us later to use the mechanism of canonical structures with total2. *) Record total2 { T: Type } ( P: T -> Type ) := tpair : forall t : T , forall tp : P t , total2 P . Definition pr1 { T: Type } { P : T -> Type } ( tp : total2 P ) : T := match tp with tpair t p => t end . Definition pr2 { T: Type } { P : T -> Type } ( tp : total2 P ) : P ( pr1 tp ) := match tp as a return P ( pr1 a ) with tpair t p => p end . (* (** The phantom type family ( following George Gonthier ) *) Inductive Phant ( T : Type ) := phant : Phant T . *) (** The following command checks wheather the patch which modifies the universe level assignement for inductive types have been installed. With the patch it returns [ paths 0 0 : UUU ] . Without the patch it returns [ paths 0 0 : Prop ]. *) Check (paths O O) . (* End of the file uuu.v *) Voevodsky-Coq/Coq_patch/._coq-8.4-ufpatches.diff000777 000765 000024 00000000256 12346040720 022230 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/Coq_patch/coq-8.4-ufpatches.diff000777 000765 000024 00000026430 12346040720 022015 0ustar00nicolastaff000000 000000 This patch file allows coq 8.4 to compile an updated version of Voevodsky's Foundations library, and is based on the patches he recommends using against coq 8.3. It should be applied against the source code of coq version 8.4pl3, available at http://coq.inria.fr/distrib/8.4pl3/files/coq-8.4pl3.tar.gz (Under Mac OS X, we recommend using homebrew from http://brew.sh to install ocaml, which is required to compile coq. Homebrew and the various packages it can install for you are normally placed in /usr/local, but they can be placed in an arbitrary alternative location, such as in $HOME/homebrew, where its files will not conflict with your other installations of those packages, if any. To use it from there, you may add $HOME/homebrew/bin to your PATH environment variable, by adding the line export PATH=$HOME/homebrew/bin:$PATH to your file $HOME/.profile ). The following commands will download, build, and install coq (replace $HOME/local below by your desired install location, and replace /tmp/ by the path to this file): wget http://coq.inria.fr/distrib/8.4pl3/files/coq-8.4pl3.tar.gz tar xzf coq-8.4pl3.tar.gz cd coq-8.4pl3 patch -p1 < /tmp/coq-8.4-ufpatches.diff ./configure -coqide no -opt -with-doc no -prefix $HOME/local make make install (If you have curl but not wget, replace the wget command above with curl http://coq.inria.fr/distrib/8.4pl3/files/coq-8.4pl3.tar.gz -o coq-8.4pl3.tar.gz ). The commands above will make a directory called "coq-8.4pl3" in your current directory, and the source code for coq will be there. The files will be installed in your directory $HOME/local, and the programs coqc, coqtop, etc., will be installed in $HOME/local/bin, which should be added to your PATH environment variable (if you replace $HOME/local with /usr/local, that will typically not be necessary). Note: we've also patched coq so it accepts the option '-indices-matter', but it has no effect on the running of the program, as the corresponding part of the patch is unconditional. Note: an updated version of Voevodsky's Foundations library usable with the coq built by the instructions above is available from github. The commands to download it into a new directory called "Foundations" and to build it are: git clone -b vv-master-for-coq8.4pl3patched git@github.com:UniMath/UniMath.git Foundations cd Foundations make make install -- Dan Grayson ============================================================================= diff -ur coq-8.4pl3-pristine/configure coq-8.4pl3/configure --- a/configure 2013-12-21 03:03:14.000000000 -0500 +++ b/configure 2014-04-07 14:52:05.000000000 -0400 @@ -111,7 +111,7 @@ coq_profile_flag= coq_annotate_flag= best_compiler=opt -cflags="-fno-defer-pop -Wall -Wno-unused" +cflags="-Wall -Wno-unused" natdynlink=yes local=false diff -ur coq-8.4pl3-pristine/kernel/indtypes.ml coq-8.4pl3/kernel/indtypes.ml --- a/kernel/indtypes.ml 2013-12-21 03:03:14.000000000 -0500 +++ b/kernel/indtypes.ml 2014-04-07 14:39:19.000000000 -0400 @@ -150,11 +150,15 @@ if Array.length lc >= 2 then sup type0_univ lev else lev let inductive_levels arities inds = - let levels = Array.map pi3 arities in - let cstrs_levels = Array.map extract_level inds in + (* index levels matter patch applied *) + let levels = Array.map (fun (_,_,_,lev) -> lev) arities in + let arsign_levels = Array.map (fun (_,_,arlev,_) -> arlev) arities in + let inds_levels = Array.map extract_level inds in + (* Add the constraints coming from the real arguments *) + let inds_levels = array_map2 sup arsign_levels inds_levels in (* Take the transitive closure of the system of constructors *) (* level constraints and remove the recursive dependencies *) - solve_constraints_system levels cstrs_levels + solve_constraints_system levels inds_levels (* This (re)computes informations relevant to extraction and the sort of an arity or type constructor; we do not to recompute universes constraints *) @@ -173,9 +177,14 @@ let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in (* compute *) let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in - (info,lc'',level,cst) +let rel_context_level env sign = + fst (List.fold_right + (fun (_,_,t as d) (lev,env) -> + sup (univ_of_sort (fst (infer_type env t)).utj_type) lev, push_rel d env) + sign (type0m_univ,env)) + (* Type-check an inductive definition. Does not check positivity conditions. *) let typecheck_inductive env mie = @@ -205,10 +214,12 @@ let lev = (* Decide that if the conclusion is not explicitly Type *) (* then the inductive type is not polymorphic *) - match kind_of_term ((strip_prod_assum arity.utj_val)) with + match kind_of_term (strip_prod_assum arity.utj_val) with | Sort (Type u) -> Some u | _ -> None in - (cst,env_ar',(id,full_arity,lev)::l)) + let arsign, _ = dest_arity env_params arity.utj_val in + let arsign_lev = rel_context_level env_params arsign in + (cst,env_ar',(id,full_arity,arsign_lev,lev)::l)) (cst1,env,[]) mie.mind_entry_inds in @@ -253,18 +264,18 @@ (* Compute/check the sorts of the inductive types *) let ind_min_levels = inductive_levels arities inds in let inds, cst = - array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst -> + array_fold_map2' (fun ((id,full_arity,arsign_level,ind_level),cn,info,lc,_) lev cst -> let sign, s = try dest_arity env full_arity with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) in let status,cst = match s with - | Type u when ar_level <> None (* Explicitly polymorphic *) + | Type u when ind_level <> None (* Explicitly polymorphic *) && no_upper_constraints u cst -> (* The polymorphic level is a function of the level of the *) (* conclusions of the parameters *) (* We enforce [u >= lev] in case [lev] has a strict upper *) - (* constraints over [u] *) + (* constraint over [u] *) Inr (param_ccls, lev), enforce_geq u lev cst | Type u (* Not an explicit occurrence of Type *) -> Inl (info,full_arity,s), enforce_geq u lev cst diff -ur coq-8.4pl3-pristine/kernel/inductive.ml coq-8.4pl3/kernel/inductive.ml --- a/kernel/inductive.ml 2013-12-21 03:03:14.000000000 -0500 +++ b/kernel/inductive.ml 2014-04-07 14:39:19.000000000 -0400 @@ -201,13 +201,14 @@ (* The max of an array of universes *) -let cumulate_constructor_univ u = function - | Prop Null -> u - | Prop Pos -> sup type0_univ u - | Type u' -> sup u u' + (* index levels matter patch applied *) +let univ_of_sort = function + | Prop Pos -> type0m_univ + | Prop Null -> type0_univ + | Type u -> u let max_inductive_sort = - Array.fold_left cumulate_constructor_univ type0m_univ + Array.fold_left (fun u s -> sup u (univ_of_sort s)) type0m_univ (************************************************************************) (* Type of a constructor *) diff -ur coq-8.4pl3-pristine/kernel/inductive.mli coq-8.4pl3/kernel/inductive.mli --- a/kernel/inductive.mli 2013-12-21 03:03:14.000000000 -0500 +++ b/kernel/inductive.mli 2014-04-07 14:39:19.000000000 -0400 @@ -94,6 +94,9 @@ val type_of_inductive_knowing_parameters : ?polyprop:bool -> env -> one_inductive_body -> types array -> types + (* index levels matter patch applied *) +val univ_of_sort : sorts -> universe + val max_inductive_sort : sorts array -> universe val instantiate_universes : env -> rel_context -> diff -ur coq-8.4pl3-pristine/kernel/reduction.ml coq-8.4pl3/kernel/reduction.ml --- a/kernel/reduction.ml 2013-12-21 03:03:14.000000000 -0500 +++ b/kernel/reduction.ml 2014-04-07 14:39:19.000000000 -0400 @@ -190,10 +190,8 @@ if c1 = c2 then cuniv else raise NotConvertible | (Prop c1, Type u) when pb = CUMUL -> assert (is_univ_variable u); cuniv | (Type u1, Type u2) -> - assert (is_univ_variable u2); - (match pb with - | CONV -> enforce_eq u1 u2 cuniv - | CUMUL -> enforce_geq u2 u1 cuniv) + (* Type in Type patch applied *) + cuniv | (_, _) -> raise NotConvertible diff -ur coq-8.4pl3-pristine/pretyping/evd.ml coq-8.4pl3/pretyping/evd.ml --- a/pretyping/evd.ml 2013-12-21 03:03:14.000000000 -0500 +++ b/pretyping/evd.ml 2014-04-07 14:39:19.000000000 -0400 @@ -532,21 +532,8 @@ Univ.is_univ_variable u || u = Univ.type0_univ let set_leq_sort ({evars = (sigma, (us, sm))} as d) s1 s2 = - match is_eq_sort s1 s2 with - | None -> d - | Some (u1, u2) -> - match s1, s2 with - | Prop c, Prop c' -> - if c = Null && c' = Pos then d - else (raise (Univ.UniverseInconsistency (Univ.Le, u1, u2))) - | Type u, Prop c -> - if c = Pos then - add_constraints d (Univ.enforce_geq Univ.type0_univ u Univ.empty_constraint) - else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2)) - | _, Type u -> - if is_univ_var_or_set u then - add_constraints d (Univ.enforce_geq u2 u1 Univ.empty_constraint) - else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2)) + (* further patch for Type in Type *) + d let is_univ_level_var us u = match Univ.universe_level u with diff -ur coq-8.4pl3-pristine/scripts/coqc.ml coq-8.4pl3/scripts/coqc.ml --- a/scripts/coqc.ml 2013-12-21 03:03:14.000000000 -0500 +++ b/scripts/coqc.ml 2014-04-07 14:39:19.000000000 -0400 @@ -144,7 +144,7 @@ | ("-notactics"|"-debug"|"-nolib"|"-boot" |"-batch"|"-nois"|"-noglob"|"-no-glob" |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" - |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" + |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit"|"-no-sharing"|"-indices-matter" |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs" |"-impredicative-set"|"-vm" as o) :: rem -> parse (cfiles,o::args) rem diff -ur coq-8.4pl3-pristine/toplevel/coqtop.ml coq-8.4pl3/toplevel/coqtop.ml --- a/toplevel/coqtop.ml 2013-12-21 03:03:14.000000000 -0500 +++ b/toplevel/coqtop.ml 2014-04-07 14:39:19.000000000 -0400 @@ -184,6 +184,8 @@ | "-byte" :: rem -> warning "option -byte deprecated, call with .byte suffix\n"; parse rem | "-full" :: rem -> warning "option -full deprecated\n"; parse rem + | "-no-sharing" :: rem -> Closure.share := false; parse rem + | "-indices-matter" :: rem -> parse rem (* we've hard-wired this option on *) | "-batch" :: rem -> set_batch_mode (); parse rem | "-boot" :: rem -> boot := true; no_load_rc (); parse rem | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem diff -ur coq-8.4pl3-pristine/toplevel/usage.ml coq-8.4pl3/toplevel/usage.ml --- a/toplevel/usage.ml 2013-12-21 03:03:14.000000000 -0500 +++ b/toplevel/usage.ml 2014-04-07 14:39:19.000000000 -0400 @@ -69,6 +69,8 @@ \n -xml export XML files either to the hierarchy rooted in\ \n the directory $COQ_XML_LIBRARY_ROOT (if set) or to\ \n stdout (if unset)\ +\n -no-sharing turn off sharing\ +\n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives (ALWAYS ON)\ \n -quality improve the legibility of the proof terms produced by\ \n some tactics\ \n -h, --help print this list of options\ Voevodsky-Coq/Coq_patch/._README.md000777 000765 000024 00000000256 12346040720 017604 0ustar00nicolastaff000000 000000 Mac OS X  2|®ATTR®˜˜com.apple.quarantineq/0002;53a84fd2;Mail;Voevodsky-Coq/Coq_patch/README.md000777 000765 000024 00000014736 12346040720 017377 0ustar00nicolastaff000000 000000 # Installation of patched Coq 8.4pl3 We start with instructions on how to generate Coq binaries which are needed to work with this version of Foundations library. The information on the history and content of the patch file is in the second part of this file. These instructions were verified to work on OSX and Linux Debian. It is probably possible to compile the library under Microsoft Windows using the Cygwin environment ## Prerequisites You need standard developer tools `make` and `patch`. These are either installed on your system or easily available through a package manager, such as [Homebrew](http://brew.sh/) on OSX. You need the OCaml compiler version 4 or later. Again, check your package manager for availability or consult the [OCaml web page](http://ocaml.org/). ## Installation To generate the Coq binaries follow these steps: 1. Open a terminal window and `cd` to main Foundation directory cd where `` is the location of the Foundations library. 2. Download the sources of Coq-8.4pl3 from http://coq.inria.fr/distrib/8.4pl3/files/coq-8.4pl3.tar.gz and unpack them into directory `coq-8.4pl3-uf` (if you do not have `wget` use a browser): wget http://coq.inria.fr/distrib/8.4pl3/files/coq-8.4pl3.tar.gz tar xfz coq-8.4pl3.tar.gz mv coq-8.4pl3 coq-8.4pl3-uf This directory should in particular contain the `Makefile` which comes with the sources. 3. Apply the patch: cd coq-8.4pl3-uf patch -p1 < ../Coq_patch/coq-8.4-ufpatches.diff 4. Compile Coq (continuing to work in `coq-8.4pl3-uf`): ./configure -coqide no -opt -with-doc no -local make GOTO_STAGE=2 coqbinaries states This will create a minimal installation of Coq sufficient for this library. To get other "standard library" files which come with Coq use `make` instead of `make GOTO ...` above. The Coq binary files are now in `coq-8.4pl3-uf/bin/`. If you are planning to generate the HTML version of the Coq files (good idea), you should also type make bin/coqdoc 5. Add `coq-8.4pl3-uf/bin/` to your `PATH` variable of the shell where coq will be called from. In a Bourne style shell this is done by export PATH=/coq-8.4pl3-uf/bin:$PATH where you replace `` with the *absolute path* to the Foundations directory. You can also permanently add the directory to your path by adding the line above to `.profile` in your home directory. 6. To test that things worked well one may type coqc -v which should generate something like this: The Coq Proof Assistant, version 8.4pl3 (April 2014) compiled on Apr 24 2014 18:25:32 with OCaml 4.01.0 with the date and time being the date when you ran `make`. You can also type which coqc to see the exact location of `coqc`. It should point to the version you compiled. ## Description of the Coq patch The patch file in this directory was created by Dan Grayson by combining together several earlier patch files written by Dan Grayson and Hugo Herbelin. The following description is from the earlier version where these patch files where separate: Hugo's patches `inductive-indice-levels-matter-8.3.patch` and `patch.type-in-type` are intended only as a temporary solution for the universe management issues in Coq which arise in connection with the univalent approach. The first of these patches changes the way the universe level of inductive types is computed for those definitions which do not specify `Set` or `Prop` as the target of the inductive construction explicitly. The new computation rule for the universe level takes into account not only the universe levels of the types occurring in the constructors but also the universe levels of types occurring in "pseudo-parameters", i.e., in the `forall` expressions in the type of the inductive definition. For example, in the definition: Inductive Ind ( a1 : A1 ) : forall a2 : A2 , Type := ... The universe level of `Ind` will be the maximum of the universe level computed on the basis of types occurring in the constructors and the universe level of `A2`. The universe level of `A1` which the type of a parameter `a1` (as opposed to a pseudo-parameter `a2) is not taken into account. The second patch switches off the universe consistency checking in Coq which is a temporary measure which allows us to formalize interesting constructions such as `ishinh` and `setquot` without having the resizing rules. Dan's patches have the following functions (see also comments in the individual patches): 1. `grayson-closedir-after-opendir.patch` improves the management of file openings/closing and eliminates in most cases the complaint that there are too many open files (this has now been included in the standard Coq). 2. `fix-hanging-at-end-of-proof.patch` if I understand correctly, this is a temporary fix for a bug in the current version of Coq's "sharing" version of the normalization algorithm. The patch uses a flag previously installed in the source code to switch off some optimization features of the algorithm. The need for this patch arose because of several cases when Coq process would hang after `Admitted`. In practice the patch prevents hanging but makes compilation of some of the code slower. In particular, with this patch installed the current standard library file `Cycllic31.v` does not compile in a reasonable amount of time (see the suggestion of how to compile Coq without much of the standard library below). It also affect the time of compilation for some of the "computation tests" in the Foundations library increasing the compilation time by a factor of >5. Hopefully, the actual bug will be located and removed in the next update. (This has not been fixed as of April 2014 but the behavior can now be controlled by the `-no-sharing` flag). 3. `grayson-improved-abstraction-version2-8.3pl2.patch` this patch dramatically improves the behavior of the `destruct` tactic making it applicable in many the cases when dependencies are present. It is not creating any complicated proof terms but simply uses the eliminator for inductive definitions in a more intelligent way than the standard `destruct` (this has now been included in the standard Coq). 4. `grayson-fix-infinite-loop.patch` fixes another hanging situation by terminating a certain tactic involving nested quantified hypotheses after 10 attempts. Voevodsky-Coq/Coq_patch/README.txt000777 000765 000024 00000000000 12352047726 021062 2README.mdustar00nicolastaff000000 000000