[
  {
    "path": ".gitignore",
    "content": ".#*\n*.html\n*.css\n*.vo\n*.glob\n*.v.d\nTAGS\n.#*\nhtml\n"
  },
  {
    "path": "Coq_patches/README",
    "content": "This directory contains patches for Coq-8.3pl2 written by Hugo Hereblin and Dan Grayson which are needed for proper compilation of the \"Foundations\" library. The source code for Coq-8.3pl2 can be found at http://coq.inria.fr/distrib/  .\n\nHugo'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. \n\nThe 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 explicitely. The new computation rule for the universe level takes into account not only the u-levels of the types occuring in the constructors but also the u-levels of types occuring in \"pseudo-parametrs\" i.e. in the [ forall ] expressions in the type of the inductive definition. For example, in the definition:\n\n[ Inductive Ind ( a1 : A1 ) : forall a2 : A2 , Type := ... ]\n\nThe u-level of [ Ind ] will be the maximum of the u-level computed on the basis of types occuring in the constructors and the u-level of [ A2 ]. The u-level of [ A1 ] which the type of a parameter [ a1 ] ( as opposed to a pseudo-parameter [ a2 ] ) is not taken into account. \n\nThe 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. \n\nDan's patches have the following functions (see also comments in the individual patches):\n\n1. \"grayson-closedir-after-opendir.patch\" imporoves the management of file openings/closing and eliminates in most cases the complaint that there arev too many open files.\n\n2. \"grayson-fix-infinite-loop.patch\" this is a temporary fix for a bug in the current version of Coq's \"call by need\" normnalization algorithm. The patch uses a flag previously installed in the source code to switch off some optimization features of the algorthim. The need for this patch has arised because of several cases when Coq process would hang after \"Admitted\". In practice the patch prevents hangings 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 actuall bug will be located and removed in the next update.\n\n3. \"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 ] .\n\n\n4. \"grayson-fix-infinite-loop.patch\" fixes another hanging situation.   \n\nThe following is a copy of the terminal session on my mac with the application of the patches which shows in particular the \"-p\" levels which have to be used in each case. It also shows how one can compile all of the Coq which is needed for the Foundations library without compiling most of the Standard Library (it takes about 5 min instead of 20 min on my computer to do it the way suggested here):\n\n\nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ ./configure --prefix /opt/local\nYou have GNU Make >= 3.81. Good!\nYou have Objective-Caml 3.11.2. Good!\nLablGtk2 not found: CoqIde will not be available.\npngtopnm was not found; documentation will not be available\n\n  Coq top directory                 : /Applications/coq-8.3pl2_two_patches_and_Dan_3\n  Architecture                      : i386\n  Coq VM bytecode link flags        : -custom\n  Coq tools bytecode link flags     : -custom\n  OS dependent libraries            : -cclib -lunix\n  Objective-Caml/Camlp4 version     : 3.11.2\n  Objective-Caml/Camlp4 binaries in : /opt/local/bin\n  Objective-Caml library in         : /opt/local/lib/ocaml\n  Camlp4 library in                 : +camlp5\n  Native dynamic link support       : true\n  Documentation                     : None\n  CoqIde                            : no\n  Web browser                       : firefox -remote \"OpenURL(%s,new-tab)\" || firefox %s &\n  Coq web site                      : http://coq.inria.fr/\n\n  Paths for true installation:\n    binaries      will be copied in /opt/local/bin\n    library       will be copied in /opt/local/lib/coq\n    man pages     will be copied in /opt/local/man\n    documentation will be copied in /opt/local/share/doc/coq\n    emacs mode    will be copied in /opt/local/share/emacs/site-lisp\n\nIf anything in the above is wrong, please restart './configure'.\n\n*Warning* To compile the system for a new architecture\n          don't forget to do a 'make archclean' before './configure'.\nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p1 < inductive-indice-levels-matter-8.3.patch\npatching file kernel/indtypes.ml\npatching file kernel/inductive.ml\npatching file kernel/inductive.mli\nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p3 < patch.type-in-type\npatching file kernel/reduction.ml\nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < fix-hanging-at-end-of-proof.patch \npatching file kernel/closure.ml\nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < grayson-fix-infinite-loop.patch \npatching file ./tactics/tactics.ml\nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < grayson-improved-abstraction-version2-8.3pl2.patch \npatching file ./configure\npatching file ./pretyping/evd.ml\npatching file ./pretyping/evd.mli\npatching file ./pretyping/pretype_errors.ml\npatching file ./pretyping/pretype_errors.mli\npatching file ./pretyping/unification.ml\npatching file ./pretyping/unification.mli\npatching file ./proofs/logic.ml\npatching file ./tactics/tactics.ml\npatching file ./test-suite/success/unification.v\npatching file ./test-suite/success/unification2.v\npatching file ./toplevel/himsg.ml\nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ \nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < grayson-closedir-after-opendir.patch \npatching file ./lib/system.ml\nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ sudo make GOTO_STAGE=2 coqbinaries states\n....\nfuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ sudo make install .\n\n\n(Note : install may give error messages because some of the files it wants to move are not created by this version of the compilation process. Just ignore it. )\n\n \n\n\n\n\n\n\n\n"
  },
  {
    "path": "Coq_patches/fix-hanging-at-end-of-proof.patch",
    "content": "diff -ub coq-8.3pl2-clean/kernel/closure.ml coq-8.3pl2-no-universe-constraints--index-levels-matter/kernel/closure.ml\n--- kernel/closure.ml\t2010-07-28 07:22:04.000000000 -0500\n+++ kernel/closure.ml\t2011-10-03 14:48:17.000000000 -0500\n@@ -17,7 +17,7 @@\n open Esubst\n \n let stats = ref false\n-let share = ref true\n+let share = ref false\n \n (* Profiling *)\n let beta = ref 0\n"
  },
  {
    "path": "Coq_patches/grayson-closedir-after-opendir.patch",
    "content": "This patch will leave many few file descriptors unclosed.\n\n     Dan Grayson\n\ndiff -ur ../coq-8.3pl2-clean/lib/system.ml ./lib/system.ml\n--- ../coq-8.3pl2-clean/lib/system.ml\t2010-12-24 03:55:54.000000000 -0600\n+++ ./lib/system.ml\t2011-10-14 12:49:30.000000000 -0500\n@@ -103,7 +103,7 @@\n (* All subdirectories, recursively *)\n \n let exists_dir dir =\n-  try let _ = opendir dir in true with Unix_error _ -> false\n+  try let _ = closedir (opendir dir) in true with Unix_error _ -> false\n \n let skipped_dirnames = ref [\"CVS\"; \"_darcs\"]\n \n"
  },
  {
    "path": "Coq_patches/grayson-fix-infinite-loop.patch",
    "content": "This \"fixes\" a seemingly infinite loop by abandoning the routine after ten repetitions.\nA better fix would involve understanding what the code was supposed to do.\n\n   Dan Grayson\n\ndiff -ubr ../coq-8.3pl2-clean/tactics/tactics.ml ./tactics/tactics.ml\n--- ../coq-8.3pl2-clean/tactics/tactics.ml\t2011-04-08 11:59:26.000000000 -0500\n+++ ./tactics/tactics.ml\t2011-10-07 09:55:24.000000000 -0500\n@@ -522,7 +522,10 @@\n \n let pf_lookup_hypothesis_as_renamed_gen red h gl =\n   let env = pf_env gl in\n+  let infinite_loop_detector = ref 0 in \n   let rec aux ccl =\n+    incr infinite_loop_detector;\n+    if !infinite_loop_detector > 10 then raise Redelimination;\n     match pf_lookup_hypothesis_as_renamed env ccl h with\n       | None when red ->\n           aux\n"
  },
  {
    "path": "Coq_patches/grayson-improved-abstraction-version2-8.3pl2.patch",
    "content": "diff -ur ../coq-8.3pl2-patched/configure ./configure\n--- ../coq-8.3pl2-patched/configure\t2011-04-19 02:19:00.000000000 -0500\n+++ ./configure\t2011-09-12 18:25:27.000000000 -0500\n@@ -6,7 +6,7 @@\n # \n ##################################\n \n-VERSION=8.3pl2\n+VERSION=8.3pl2+improved-abstraction\n VOMAGIC=08300\n STATEMAGIC=58300\n DATE=`LANG=C date +\"%B %Y\"`\n@@ -323,8 +323,8 @@\n if [ \"$MAKE\" != \"\" ]; then\n   MAKEVERSION=`$MAKE -v | head -1`\n   case $MAKEVERSION in\n-    \"GNU Make 3.8\"[12])\n-      echo \"You have GNU Make >= 3.81. Good!\";;\n+    \"GNU Make 3.8\"[1-9] | \"GNU Make 3.8\"[1-9].* | \"GNU Make 3.\"[0-9]  | \"GNU Make 3.\"[0-9].* | \"GNU Make \"[4-9].* )\n+      echo \"You have GNU Make $MAKEVERSION >= 3.81. Good!\";;\n     *)\n       OK=\"no\"\n       if [ -x ./make ]; then\ndiff -ur ../coq-8.3pl2-patched/pretyping/evd.ml ./pretyping/evd.ml\n--- ../coq-8.3pl2-patched/pretyping/evd.ml\t2011-03-10 09:50:24.000000000 -0600\n+++ ./pretyping/evd.ml\t2011-09-11 06:30:25.000000000 -0500\n@@ -675,6 +675,11 @@\n         metas = Metamap.add mv (Clval(na,(mk_freelisted v,pb),ty)) evd.metas }\n   | _ -> anomaly \"meta_reassign: not yet defined\"\n \n+let meta_unassign mv evd =\n+  match Metamap.find mv evd.metas with\n+  | Clval(na,_,ty) -> { evd with metas = Metamap.add mv (Cltyp(na,ty)) evd.metas }\n+  | _ -> anomaly \"meta_unassign: not yet defined\"\n+\n (* If the meta is defined then forget its name *)\n let meta_name evd mv =\n   try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous\ndiff -ur ../coq-8.3pl2-patched/pretyping/evd.mli ./pretyping/evd.mli\n--- ../coq-8.3pl2-patched/pretyping/evd.mli\t2011-03-10 09:50:24.000000000 -0600\n+++ ./pretyping/evd.mli\t2011-09-11 06:30:39.000000000 -0500\n@@ -224,6 +224,7 @@\n   metavariable -> types -> ?name:name -> evar_map -> evar_map\n val meta_assign    : metavariable -> constr * instance_status -> evar_map -> evar_map\n val meta_reassign  : metavariable -> constr * instance_status -> evar_map -> evar_map\n+val meta_unassign  : metavariable -> evar_map -> evar_map\n \n (* [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)\n val meta_merge : evar_map -> evar_map -> evar_map\ndiff -ur ../coq-8.3pl2-patched/pretyping/pretype_errors.ml ./pretyping/pretype_errors.ml\n--- ../coq-8.3pl2-patched/pretyping/pretype_errors.ml\t2010-07-24 10:57:30.000000000 -0500\n+++ ./pretyping/pretype_errors.ml\t2011-09-13 16:23:06.000000000 -0500\n@@ -34,6 +34,7 @@\n   | CannotGeneralize of constr\n   | NoOccurrenceFound of constr * identifier option\n   | CannotFindWellTypedAbstraction of constr * constr list\n+  | CannotFindAbstraction of Evd.evar_map * constr * constr list * string\n   | AbstractionOverMeta of name * name\n   | NonLinearUnification of name * constr\n   (* Pretyping *)\n@@ -178,6 +179,9 @@\n let error_cannot_find_well_typed_abstraction env sigma p l =\n   raise (PretypeError (env_ise sigma env,CannotFindWellTypedAbstraction (p,l)))\n \n+let error_cannot_find_abstraction env sigma c l msg =\n+  raise (PretypeError (env_ise sigma env,CannotFindAbstraction (sigma,c,l,msg)))\n+\n let error_abstraction_over_meta env sigma hdmeta metaarg =\n   let m = Evd.meta_name sigma hdmeta and n = Evd.meta_name sigma metaarg in\n   raise (PretypeError (env_ise sigma env,AbstractionOverMeta (m,n)))\ndiff -ur ../coq-8.3pl2-patched/pretyping/pretype_errors.mli ./pretyping/pretype_errors.mli\n--- ../coq-8.3pl2-patched/pretyping/pretype_errors.mli\t2010-07-24 10:57:30.000000000 -0500\n+++ ./pretyping/pretype_errors.mli\t2011-09-13 16:22:42.000000000 -0500\n@@ -35,6 +35,7 @@\n   | CannotGeneralize of constr\n   | NoOccurrenceFound of constr * identifier option\n   | CannotFindWellTypedAbstraction of constr * constr list\n+  | CannotFindAbstraction of Evd.evar_map * constr * constr list * string\n   | AbstractionOverMeta of name * name\n   | NonLinearUnification of name * constr\n   (* Pretyping *)\n@@ -107,6 +108,9 @@\n val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map ->\n       constr -> constr list -> 'b\n \n+val error_cannot_find_abstraction : env -> Evd.evar_map ->\n+      constr -> constr list -> string -> 'b\n+\n val error_abstraction_over_meta : env -> Evd.evar_map ->\n   metavariable -> metavariable -> 'b\n \ndiff -ur ../coq-8.3pl2-patched/pretyping/unification.ml ./pretyping/unification.ml\n--- ../coq-8.3pl2-patched/pretyping/unification.ml\t2010-07-26 17:12:43.000000000 -0500\n+++ ./pretyping/unification.ml\t2011-09-13 17:03:34.000000000 -0500\n@@ -28,6 +28,109 @@\n open Coercion.Default\n open Recordops\n \n+let rec take n x = \n+  if n = 0 then [] else\n+  match x with\n+    [] -> raise Not_found\n+  | e::x -> e::(take (n-1) x)\n+\n+let rec last x = match x with \n+    |    [] -> error \"internal error: empty list\"\n+    |   [e] -> e\n+    |  _::x -> last x\n+\n+let all_but_last x = List.rev (List.tl (List.rev x))\n+\n+let is_well_typed env evd t = try ignore(Typing.type_of env evd t); true with Type_errors.TypeError _ -> false\n+\n+let meta_name evd mv =\n+  match find_meta evd mv with\n+    | Cltyp(na,_) -> na\n+    | Clval(na,_,_) -> na\n+\n+let abstract_metas evd mvs t = List.fold_right\n+    (fun mv t -> \n+      mkLambda( meta_name evd mv, Typing.meta_type evd mv, replace_term (mkMeta mv) (mkRel 1) t))\n+    mvs t\n+\n+let occurrence_count term subterm = \n+  let n = ref 0 in \n+  let rec f c = if eq_constr subterm c then incr n else iter_constr f c in\n+  iter_constr f term;\n+  !n\n+\n+let subsets n =\n+  assert (n >= 0);\n+  let rec subsets n =\n+    if n = 0 then [[]]\n+    else\n+      let m = n-1 in\n+      let s = subsets m in\n+      List.append s (List.map (fun t -> m :: t) s) in\n+  List.map List.rev (subsets n)\n+let cartprod2 x y = List.flatten (List.map (fun t -> List.map (fun u -> t::u) y) x)\n+let cartprod z = List.fold_right cartprod2 z [[]]\n+let subsetsn l = cartprod (List.map subsets l)\n+\n+let replace_term_occ occs c by_c in_t =\n+  let ctr = ref 0 in\n+  let rec f x = (\n+    if eq_constr c x\n+    then (\n+      let x' = if List.mem !ctr occs then by_c else x in\n+      incr ctr;\n+      x'\n+     )\n+    else map_constr f x    \n+   ) in\n+  f in_t\n+\n+let select f x =\n+  let rec select f = function\n+    | [] -> []\n+    | a::x -> if f a then a :: select f x else select f x in\n+  select f x\n+\n+let abstract_list_search_warning = ref (function (env:env) -> function (evd:evar_map) -> function (survivors:constr list) -> assert false)\n+\n+let always_search = true\t\t(* true for development, false for production *)\n+\n+let abstract_list_search env evd2 typ c l =\n+  let c_orig = c in\n+  let l_orig = l in\n+  let elimA = List.rev (take (List.length l) (List.map fst (meta_list evd2))) in\n+  let k = last l in\n+  let l = all_but_last l in\n+  let psvar = all_but_last elimA in\n+  let evd = List.fold_right meta_unassign psvar evd2 in\n+  let psvalpairs = List.map (fun mv -> (mv,meta_value evd2 mv)) psvar in\n+  let ispsval t =\n+    let rec f = function [] -> None | (mv,v)::rest -> if eq_constr t v then Some mv else f rest in\n+    f psvalpairs in\n+  let c = replace_term k (mkMeta (last elimA)) c in\n+  let c = \n+    let rec f t = match ispsval t with Some mv -> mkMeta mv | None -> map_constr f t in\n+    map_constr f c in\n+  let psvargoalcount = List.map (occurrence_count c) (List.map mkMeta psvar) in\n+  let totcount = List.fold_right (+) psvargoalcount 0 in\n+  if totcount > 16 then error_cannot_find_abstraction env evd2 c_orig l_orig \"attempted, more than 16 replacement spots\";\n+  let psvaroccs = subsetsn psvargoalcount in\n+  let possibilities = List.map\n+      (fun occlist -> List.fold_right2 (fun occ (mv,vl) goal -> replace_term_occ occ (mkMeta mv) vl goal) occlist psvalpairs c)\n+      psvaroccs in\n+  let survivors = select (is_well_typed env evd) possibilities in\n+  let survivors = List.map (abstract_metas evd elimA) survivors in\n+  begin\n+    match List.length survivors with\n+      0 -> error_cannot_find_abstraction env evd2 c_orig l_orig \"possible\"\n+    | 1 -> ()\n+    | _ -> !abstract_list_search_warning env evd2 survivors\n+  end;\n+  let p = List.hd survivors in\n+  if is_conv_leq env evd2 (Typing.type_of env evd2 p) typ\n+  then p\n+  else error \"internal error: abstraction not convertible?\"\n+\n let occur_meta_or_undefined_evar evd c =\n   let rec occrec c = match kind_of_term c with\n     | Meta _ -> raise Occur\n@@ -930,7 +1033,8 @@\n   let (evd',cllist) =\n     w_unify_to_subterm_list env flags allow_K p oplist typ evd in\n   let typp = Typing.meta_type evd' p in\n-  let pred = abstract_list_all env evd' typp typ cllist in\n+  let pred = try abstract_list_all env evd' typp typ cllist\n+    with PretypeError _ -> abstract_list_search env evd' typp typ cllist in\n   w_merge env false flags (evd',[p,pred,(ConvUpToEta 0,TypeProcessed)],[])\n \n let w_unify2 env flags allow_K cv_pb ty1 ty2 evd =\ndiff -ur ../coq-8.3pl2-patched/pretyping/unification.mli ./pretyping/unification.mli\n--- ../coq-8.3pl2-patched/pretyping/unification.mli\t2010-07-24 10:57:30.000000000 -0500\n+++ ./pretyping/unification.mli\t2011-09-12 12:27:16.000000000 -0500\n@@ -52,3 +52,6 @@\n (* (exported for inv.ml) *)\n val abstract_list_all :\n   env -> evar_map -> constr -> constr -> constr list -> constr\n+\n+\n+val abstract_list_search_warning : (env -> evar_map -> Term.constr list -> unit) ref\ndiff -ur ../coq-8.3pl2-patched/proofs/logic.ml ./proofs/logic.ml\n--- ../coq-8.3pl2-patched/proofs/logic.ml\t2010-07-26 17:12:43.000000000 -0500\n+++ ./proofs/logic.ml\t2011-09-12 11:47:14.000000000 -0500\n@@ -58,7 +58,7 @@\n   (* unification errors *)\n   | PretypeError(_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _\n \t\t   |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _\n-\t\t   |CannotFindWellTypedAbstraction _|OccurCheck _\n+\t\t   |CannotFindAbstraction _|CannotFindWellTypedAbstraction _|OccurCheck _\n \t\t   |UnsolvableImplicit _)) -> true\n   | Typeclasses_errors.TypeClassError\n       (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true\ndiff -ur ../coq-8.3pl2-patched/tactics/tactics.ml ./tactics/tactics.ml\n--- ../coq-8.3pl2-patched/tactics/tactics.ml\t2011-10-11 07:28:57.000000000 -0500\n+++ ./tactics/tactics.ml\t2011-10-10 16:38:28.000000000 -0500\n@@ -134,7 +134,9 @@\n       errorlabstrm \"\" (pr_id id ++ str \" is used in conclusion.\")\n   | Evarutil.OccurHypInSimpleClause (Some id') ->\n       errorlabstrm \"\"\n-        (pr_id id ++ strbrk \" is used in hypothesis \" ++ pr_id id' ++ str\".\")\n+        (pr_id id ++ strbrk \" is used in hypothesis \" ++ pr_id id' ++ str\".\" ++ fnl() ++ fnl()\n+\t   ++ str \"The context:\" ++ fnl() ++ str \"  \" ++ Printer.pr_context_of env\n+\t)\n   | Evarutil.EvarTypingBreak ev ->\n       errorlabstrm \"\"\n         (str \"Cannot remove \" ++ pr_id id ++\n@@ -1912,13 +1914,8 @@\n       let argl = snd (decompose_app indtyp) in\n       let c = List.nth argl (i-1) in\n       match kind_of_term c with\n-\t| Var id when not (List.exists (occur_var (pf_env gl) id) avoid) ->\n-\t    atomize_one (i-1) ((mkVar id)::avoid) gl\n \t| Var id ->\n-\t    let x = fresh_id [] id gl in\n-\t    tclTHEN\n-\t      (letin_tac None (Name x) (mkVar id) None allHypsAndConcl)\n-\t      (atomize_one (i-1) ((mkVar x)::avoid)) gl\n+\t    atomize_one (i-1) ((mkVar id)::avoid) gl\n \t| _ ->\n \t    let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)\n \t\t       Anonymous in\ndiff -ur ../coq-8.3pl2-patched/test-suite/success/unification.v ./test-suite/success/unification.v\n--- ../coq-8.3pl2-patched/test-suite/success/unification.v\t2010-04-07 17:01:23.000000000 -0500\n+++ ./test-suite/success/unification.v\t2011-09-12 17:55:41.000000000 -0500\n@@ -136,3 +136,4 @@\n Proof.\n   intros.\n   rewrite H.\n+Abort.\ndiff -ur ../coq-8.3pl2-patched/test-suite/success/unification2.v ./test-suite/success/unification2.v\n--- ../coq-8.3pl2-patched/test-suite/success/unification2.v\t2011-10-11 07:31:05.000000000 -0500\n+++ ./test-suite/success/unification2.v\t2011-09-12 18:11:59.000000000 -0500\n@@ -0,0 +1,35 @@\n+(* tests to go with Grayson's patch to \"destruct\" for handling Univalent Foundations *)\n+\n+Unset Automatic Introduction.\n+\n+(* Voevodsky's original example: *)\n+\n+Definition test ( X : Type ) ( x : X ) ( fxe : forall x1 : X , identity x1 x1 ) : identity ( fxe x ) ( fxe x ).\n+Proof. intros. destruct ( fxe x ). apply identity_refl. Defined.\n+\n+(* a harder example *)\n+\n+Definition UU := Type .\n+Inductive paths {T:Type}(t:T): T -> UU := idpath: paths t t.\n+Inductive foo (X0:UU) (x0:X0) : forall (X:UU)(x:X) , UU := newfoo : foo X0 x0 X0 x0.\n+Definition idonfoo {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo X0 x0 X1 x1 -> foo X0 x0 X1 x1.\n+Proof. intros * t. exact t. Defined.\n+\n+Lemma hA (T:UU) (t:T) (k : foo T t T t) : paths k (idonfoo k).\n+Proof. intros.\n+   destruct k.\n+   unfold idonfoo.\n+   apply idpath.\n+Defined.\n+\n+(* an example with two constructors *)\n+\n+Inductive foo' (X0:UU) (x0:X0) : forall (X:UU)(x:X) , UU := newfoo1 : foo' X0 x0 X0 x0 | newfoo2 : foo' X0 x0 X0 x0 .\n+Definition idonfoo' {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo' X0 x0 X1 x1 -> foo' X0 x0 X1 x1.\n+Proof. intros * t. exact t. Defined.\n+Lemma tryb2 (T:UU) (t:T) (k : foo' T t T t) : paths k (idonfoo' k).\n+Proof. intros.\n+   destruct k.\n+   unfold idonfoo'. apply idpath.\n+   unfold idonfoo'. apply idpath.\n+Defined.\ndiff -ur ../coq-8.3pl2-patched/toplevel/himsg.ml ./toplevel/himsg.ml\n--- ../coq-8.3pl2-patched/toplevel/himsg.ml\t2010-09-24 17:23:07.000000000 -0500\n+++ ./toplevel/himsg.ml\t2011-09-13 17:07:40.000000000 -0500\n@@ -439,6 +439,16 @@\n   str \"leads to a term\" ++ spc () ++ pr_lconstr_env env p ++ spc () ++\n   str \"which is ill-typed.\"\n \n+let explain_cannot_find_abstraction env evd c l msg =\n+  str \"Abstraction over the \" ++\n+    str (plural (List.length l) \"term\") ++ spc () ++\n+    hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++\n+    str \"not\" ++ spc() ++ str msg ++ str \".\" ++\n+    fnl() ++ fnl() ++ str \"The context:\" ++ fnl() ++\n+    str \"  \" ++ pr_context_of env ++\n+    fnl() ++ fnl() ++ str \"The term to be abstracted: \" ++ fnl() ++ fnl() ++\n+    str \"  \" ++ pr_constr c\n+\n let explain_abstraction_over_meta _ m n =\n   strbrk \"Too complex unification problem: cannot find a solution for both \" ++\n   pr_name m ++ spc () ++ str \"and \" ++ pr_name n ++ str \".\"\n@@ -502,6 +512,8 @@\n   | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n\n   | CannotFindWellTypedAbstraction (p,l) ->\n       explain_cannot_find_well_typed_abstraction env p l\n+  | CannotFindAbstraction (evd,c,l,msg) ->\n+      explain_cannot_find_abstraction env evd c l msg\n   | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n\n   | NonLinearUnification (m,c) -> explain_non_linear_unification env m c\n \n@@ -850,3 +862,8 @@\n            pr_enum pr_call calls ++ strbrk kind_of_last_call)\n   else\n     mt ()\n+\n+let _ =\n+  Unification.abstract_list_search_warning := \n+  function env -> function evd -> function l -> \n+    msgnl(str \"warning: multiple well-typed abstractions found:\" ++ (fnl()) ++ prlist_with_sep fnl pr_constr l)\n"
  },
  {
    "path": "Coq_patches/inductive-indice-levels-matter-8.3.patch",
    "content": "diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml\nindex df3670d..3e33ffb 100644\n--- a/kernel/indtypes.ml\n+++ b/kernel/indtypes.ml\n@@ -161,11 +161,14 @@ let extract_level (_,_,_,lc,lev) =\n   if Array.length lc >= 2 then sup type0_univ lev else lev\n \n let inductive_levels arities inds =\n-  let levels = Array.map pi3 arities in\n-  let cstrs_levels = Array.map extract_level inds in\n+  let levels = Array.map (fun (_,_,_,lev) -> lev) arities in\n+  let arsign_levels = Array.map (fun (_,_,arlev,_) -> arlev) arities in\n+  let inds_levels = Array.map extract_level inds in\n+  (* Add the constraints coming from the real arguments *)\n+  let inds_levels = array_map2 sup arsign_levels inds_levels in\n   (* Take the transitive closure of the system of constructors *)\n   (* level constraints and remove the recursive dependencies *)\n-  solve_constraints_system levels cstrs_levels\n+  solve_constraints_system levels inds_levels\n \n (* This (re)computes informations relevant to extraction and the sort of an\n    arity or type constructor; we do not to recompute universes constraints *)\n@@ -184,9 +187,14 @@ let infer_constructor_packet env_ar_par params lc =\n   let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in\n   (* compute *)\n   let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in\n-\n   (info,lc'',level,cst)\n \n+let rel_context_level env sign =\n+  fst (List.fold_right\n+    (fun (_,_,t as d) (lev,env) ->\n+     sup (univ_of_sort (fst (infer_type env t)).utj_type) lev, push_rel d env)\n+    sign (type0m_univ,env))\n+\n (* Type-check an inductive definition. Does not check positivity\n    conditions. *)\n let typecheck_inductive env mie =\n@@ -216,10 +224,12 @@ let typecheck_inductive env mie =\n \t let lev =\n \t   (* Decide that if the conclusion is not explicitly Type *)\n \t   (* then the inductive type is not polymorphic *)\n-\t   match kind_of_term ((strip_prod_assum arity.utj_val)) with\n+\t   match kind_of_term (strip_prod_assum arity.utj_val) with\n \t   | Sort (Type u) -> Some u\n \t   | _ -> None in\n-         (cst,env_ar',(id,full_arity,lev)::l))\n+         let arsign, _ = dest_arity env_params arity.utj_val in\n+         let arsign_lev = rel_context_level env_params arsign in\n+         (cst,env_ar',(id,full_arity,arsign_lev,lev)::l))\n       (cst1,env,[])\n       mie.mind_entry_inds in\n \n@@ -255,15 +265,15 @@ let typecheck_inductive env mie =\n   (* Compute/check the sorts of the inductive types *)\n   let ind_min_levels = inductive_levels arities inds in\n   let inds, cst =\n-    array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst ->\n+    array_fold_map2' (fun ((id,full_arity,arsign_level,ind_level),cn,info,lc,_) lev cst ->\n       let sign, s = dest_arity env full_arity in\n       let status,cst = match s with\n-      | Type u when ar_level <> None (* Explicitly polymorphic *)\n+      | Type u when ind_level <> None (* Explicitly polymorphic *)\n             && no_upper_constraints u cst ->\n \t  (* The polymorphic level is a function of the level of the *)\n \t  (* conclusions of the parameters *)\n           (* We enforce [u >= lev] in case [lev] has a strict upper *)\n-          (* constraints over [u] *)\n+          (* constraint over [u] *)\n \t  Inr (param_ccls, lev), enforce_geq u lev cst\n       | Type u (* Not an explicit occurrence of Type *) ->\n \t  Inl (info,full_arity,s), enforce_geq u lev cst\ndiff --git a/kernel/inductive.ml b/kernel/inductive.ml\nindex 24b0751..a81531e 100644\n--- a/kernel/inductive.ml\n+++ b/kernel/inductive.ml\n@@ -202,13 +202,13 @@ let type_of_inductive env (_,mip) =\n \n (* The max of an array of universes *)\n \n-let cumulate_constructor_univ u = function\n-  | Prop Null -> u\n-  | Prop Pos -> sup type0_univ u\n-  | Type u' -> sup u u'\n+let univ_of_sort = function\n+  | Prop Pos -> type0m_univ\n+  | Prop Null -> type0_univ\n+  | Type u -> u\n \n let max_inductive_sort =\n-  Array.fold_left cumulate_constructor_univ type0m_univ\n+  Array.fold_left (fun u s -> sup u (univ_of_sort s)) type0m_univ\n \n (************************************************************************)\n (* Type of a constructor *)\ndiff --git a/kernel/inductive.mli b/kernel/inductive.mli\nindex a0fba8e..188a1cb 100644\n--- a/kernel/inductive.mli\n+++ b/kernel/inductive.mli\n@@ -88,6 +88,8 @@ val check_cofix : env -> cofixpoint -> unit\n val type_of_inductive_knowing_parameters :\n   env -> one_inductive_body -> types array -> types\n \n+val univ_of_sort : sorts -> universe\n+\n val max_inductive_sort : sorts array -> universe\n \n val instantiate_universes : env -> rel_context ->\n"
  },
  {
    "path": "Coq_patches/patch.type-in-type",
    "content": "diff --git a/branches/v8.3/kernel/reduction.ml b/branches/v8.3/kernel/reduction.ml\nindex aa50f78..77e6072 100644\n--- a/branches/v8.3/kernel/reduction.ml\n+++ b/branches/v8.3/kernel/reduction.ml\n@@ -183,10 +183,13 @@ let sort_cmp pb s0 s1 cuniv =\n         if c1 = c2 then cuniv else raise NotConvertible\n     | (Prop c1, Type u) when pb = CUMUL -> assert (is_univ_variable u); cuniv\n     | (Type u1, Type u2) ->\n+        cuniv\n+(*\n \tassert (is_univ_variable u2);\n \t(match pb with\n            | CONV -> enforce_eq u1 u2 cuniv\n \t   | CUMUL -> enforce_geq u2 u1 cuniv)\n+*)\n     | (_, _) -> raise NotConvertible\n \n \n"
  },
  {
    "path": "Current_work/2013_from_poset.v",
    "content": "Unset Automatic Introduction.\n\nAdd LoadPath \"..\" .\n\nRequire Export Foundations.hlevel2.finitesets.\n\n(* Standard finite posets and order preserving functions between them. *)  \n\nNotation \" 'stnel' ( i , j ) \" := ( stnpair _ _  ( ctlong natlth isdecrelnatlth j i ( idpath true ) ) ) ( at level 70 ) .\n\nDefinition stnposet ( i : nat ) : Poset .\nProof. 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. \n\nDefinition issmaller { X : Poset } ( x1 x2 : X ) := dirprod ( pr2 X x1 x2 ) ( neg ( paths x1 x2 ) ) . \n\nDefinition ndchains ( i : nat ) ( X : Poset ) := total2 ( fun ndccar: forall j : stn i , X => forall ( j1 j2 : stn i ) ( is : natlth j1 j2 ) , issmaller (ndccar j1 ) (ndccar j2 ) ) . \n\nDefinition ndchainstosequences ( i : nat ) ( X : Poset ) : ndchains i X -> ( stn i ) -> X := fun xstar => fun k => ( pr1 xstar ) k . \nCoercion ndchainstosequences : ndchains >-> Funclass .\n\nLemma natlthinndchainstn { i j : nat } ( ch : ndchains j ( stnposet i ) ) { j1 j2 : stn j } ( is : natlth j1 j2 ) : natlth ( stntonat _ ( ch j1 ) ) ( stntonat _ ( ch j2 ) ) .\nProof .  intros . \nassert ( is10 : natleh ( stntonat _ ( ch j1 ) ) ( stntonat _ ( ch j2 ) ) ) . apply ( pr1 ( pr2 ch j1 j2 is ) ) . \nassert ( is110 : neg ( paths ( ch j1 ) ( ch j2 ) ) ) . apply ( pr2 ( pr2 ch j1 j2 is ) ) .  \nassert ( is11 : natneq ( stntonat _ ( ch j1 ) ) ( stntonat _ ( ch j2 ) ) ) .  apply ( negf ( invmaponpathsincl ( stntonat _ ) ( isinclstntonat _ ) (ch j1 ) ( ch j2 )  ) is110 ) .  \ndestruct ( natlehchoice _ _ is10 ) as [ l | e ].  apply l . destruct ( is11 e ) .  Defined. \n\n\nDefinition ndchainsrestr { i j : nat } { X : Poset } ( chs : ndchains j ( stnposet i ) ) ( chX : ndchains i X ) : ndchains j X .\nProof . intros .  split with ( fun k : stn j =>  chX ( chs k ) ) .  intros j1 j2 . intro is . apply ( pr2 chX _ _ ( natlthinndchainstn chs is ) ) . Defined.      \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\nDefinition Ind_tuple ( i : nat ) : total2 ( fun \n\nFSkXtoUUcat : forall ( X : Poset ) , UU (* FSkXtoUUcat X := sk_i(N(X)) -> N(UU_cat) *)\n\n=> total2 ( fun XtoT : total2 ( fun \n\nFSkXtoT : forall ( X : Poset ) ( T : UU ) , UU (* FSkXtoT X T := sk_i(N(X)) -> N(T) *)\n\n=>\n\nforall ( X : Poset ) ( T : UU ) ( F : T -> UU ) , FSkXtoT X T -> FSkXtoUUcat X \n\n)\n\n=> dirprod \n\n( forall a : FSkXtoUUcat ( stnposet  ( S ( S i ) ) ) , UU ) (* a : sk_i(Delta^{i+1}) -> N(UU_cat) => the type of extensions of a to Delta^{i+1}->N(UU_cat) *)\n\n( total2 ( fun \n\nPhi :forall ( j : nat ) ( is : natgeh j i ) ( X : Poset ) ( xstar : ndchains ( S j ) X ) ( d : FSkXtoUUcat X )  , FSkXtoUUcat ( stnposet ( S j ) ) \n\n=> \n\nforall ( j : nat ) ( is : natgeh j ( S i ) ) ( X : Poset ) ( xstar : ndchains ( S j ) X ) ( di : FSkXtoUUcat X )  ( xstar0 : ndchains ( S ( S i ) ) ( stnposet ( S j ) ) ) ,  paths ( (Phi (S i) (natgehsnn i) (stnposet (S j)) xstar0 (Phi j (istransnatgeh j (S i) i is (natgehsnn i)) X xstar di))) ( Phi (S i) (natgehsnn i) X (ndchainsrestr xstar0 xstar) di )  \n\n)))) .\nProof. intros .   induction i as [ | i IHi].  \n\n(* i=0 *)\n\nsplit with ( fun X : Poset => ( X -> UU ) ) .\nsplit . \nsplit with ( fun X => fun T => ( X -> T ) ) .  \nexact ( fun X => fun T => fun F => ( fun d => fun x => F ( d x ) ) ) . \nsplit with ( fun f : stnposet 2 -> UU  => ( f ( stnel(2,0) ) -> f ( stnel(2,1) ) ) ) . \nsplit with  ( fun j => fun is => fun X => fun xstar => fun d => fun k => d ( xstar k ) ) . \n\nintros . apply idpath.  \n\n(* i+1 *)\n\nset ( FSkXtoUUcat := pr1 IHi ) . set ( FSkXtoT := pr1 ( pr1 ( pr2 IHi ) ) ) . set ( FSkXtoTcomp := pr2 ( pr1 ( pr2 IHi ) ) ) . set ( FDT := pr1 ( pr2 ( pr2 IHi ) ) ) . set ( Phi := pr1 ( pr2 ( pr2 ( pr2 IHi ) ) ) ) . set ( h := pr2 ( pr2 ( pr2 ( pr2 IHi ) ) ) ) .  simpl in Phi .  simpl in FSkXtoT . simpl in FDT.  simpl in h . \n\n(*\n\nFSkXtoUUcat X = Hom ( sk_i(N(X)) , N(UU_cat) ) \n\nFSkXtoT X T := Hom ( sk_i(N(X)) , N(T) )\n\nFSkXtoTcomp X T F := fun d : sk_i(N(X)) -> N(T) => F \\circ d \n\nFDT d = the type of extensions of d : sk_i(Delta^{i+1}) -> N(UU_cat) to functions Delta^{i+1} -> N(UU_cat) \n\nPhi j is X xstar = restriction map Hom ( sk_i(N(X)) , N(UU_cat) ) -> Hom ( sk_i(Delta^j), N(UU_cat) ) defined by the map xstar:Delta^j -> N(X)\n\n*)\n\n(* First split with Hom ( sk_{i+1}(N(X)), N(UU_cat) ) *)\n\nsplit with ( fun X => total2 ( fun d : FSkXtoUUcat X => forall xstar : ndchains ( S ( S i ) ) X , FDT ( Phi ( S i ) ( natgehsnn i ) X xstar d ) ) )  . \n\nsplit. \n\n(* we need to define for a poset X and a type T the type of functions sk_{i+1}(N(X)) -> N(T) . We try the following definition. *)\n\nsplit with ( fun X => fun T => total2 ( fun d : FSkXtoT X T => forall F : T -> UU, forall xstar : ndchains ( S ( S i ) ) X , FDT ( Phi ( S i ) ( natgehsnn i ) X xstar ( FSkXtoTcomp X T F d ) ) ) ) . \n\n(* now we need the composition map d : sk_i(N(X)) -> N(T) => F \\circ d where F : T -> UU *)\n\nintros X T F dsi . destruct dsi as [ d dall ] .  split with ( FSkXtoTcomp X T F d ) .  apply ( dall F ) .  \n\n\nsplit.\n\n(* now we need to define for any dsi : sk_{i+1}(Delta^{i+2})-> N(UU_cat) the type of the extensions of dsi to a \"functor\" Delta^{i+2} -> N(UU_cat) *)\n\nintro dsi . destruct dsi as [ d dfill ] .  \n\nadmit. \n\nassert ( Phi0 : forall j : nat,\n               natgeh j (S i) ->\n               forall X : Poset,\n               ndchains (S j) X ->\n               total2\n                 (fun d : FSkXtoUUcat X =>\n                  forall xstar0 : ndchains (S (S i)) X,\n                  FDT (Phi (S i) (natgehsnn i) X xstar0 d)) ->\n               total2\n                 (fun d0 : FSkXtoUUcat (stnposet (S j)) =>\n                  forall xstar0 : ndchains (S (S i)) (stnposet (S j)),\n                  FDT (Phi (S i) (natgehsnn i) (stnposet (S j)) xstar0 d0)) ).\n\n\nintros j is X xstar. \n\n(* Now we need to define for all j >= i+1 the restriction maps Hom ( sk_{i+1}(N(X)) , N(UU_cat) ) -> Hom ( sk_{i+1}(Delta^j), N(UU_cat) ) defined by\nxstar : Delta^j -> N(X) *)\n\nintro d . destruct d as [ di dfdt ] . split with ( Phi j (istransnatgeh _ _ _ is (natgehsnn i)) X xstar di ) . \n\nintro xstar0.\n\nset ( xstar1 := ndchainsrestr xstar0 xstar ) . \n\n(* Now we have xstar0 : Delta^{i+1} -> Delta^j , xstar : Delta^j -> N(X) and di : sk_i(N(X)) -> N(UU_cat) and need to define an extension to Delta^{i+1} of the map sk_i(Delta^{i+1}) -> ( sk_i(Delta^{j}) -> sk_i(N(X)) -> N(UU_cat) ) . The idea is that this map equals to the map\nsk_i(Delta^{i+1}->Delta^j->N(X)) -> N(UU_cat) for which we have an extesnion  dfdt xstar1 *)\n\nsimpl in h . rewrite h . apply ( dfdt xstar1 ) . \n\nsplit with Phi0 . \n\nintros . "
  },
  {
    "path": "Current_work/bsystem.v",
    "content": "Require Export Foundations.Generalities.uu0.\n\nUnset Automatic Introduction.\n\n\n(** ** To ustream files of the library *)\n\nNotation hfppru := hfpg' .\n\nNotation hfpprl := hfpg . \n\nNotation fromunit := termfun .\n\n\n(** To hfiber. *)\n\n\nDefinition tohfiber { X Y : UU } ( f : X -> Y ) ( x : X ) : hfiber f ( f x ) := hfiberpair f x ( idpath _ ) . \n\n(** To hfp *)\n\nDefinition hfptriple { X X' Y:UU} (f:X -> Y) (f':X' -> Y) ( x : X ) ( x' : X' ) ( h : paths ( f' x' ) ( f x ) ) : hfp f f' := tpair ( fun xx' : dirprod X X'  => paths ( f' ( pr2 xx' ) ) ( f ( pr1 xx' ) ) )  ( dirprodpair x x' ) h . \n\n(** Functoriality of hfp. *)\n\nLemma hfplhomot { X Y Z : UU } { fl1 fl2 : X -> Y } ( h : homot fl1 fl2 ) ( gr : Z -> Y ) : weq ( hfp fl1 gr ) ( hfp fl2 gr ) .\nProof . intros . refine ( weqgradth _ _ _ _ ) .  \n\n{ intro xze . destruct xze as [ xz e ] . split with xz .  exact (pathscomp0 e (h (pr1 xz))) . }\n\n{ intro xze . destruct xze as [ xz e ] . split with xz .  exact (pathscomp0 e ( pathsinv0 (h (pr1 xz)))) . }\n\n{ intro xze . destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) .  destruct ( h ( pr1 xz ) ) . destruct e . apply idpath . } \n\n{  intro xze .  destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) . destruct (h (pr1 xz)) . destruct e . apply idpath . }\n\nDefined . \n\nLemma hfprhomot { X Y Z : UU } ( fl : X -> Y ) { gr1 gr2 : Z -> Y } ( h : homot gr1 gr2 ) : weq ( hfp fl gr1 ) ( hfp fl gr2 ) .\nProof . intros . refine ( weqgradth _ _ _ _ ) .  \n\n{ intro xze . destruct xze as [ xz e ] . split with xz .  exact (pathscomp0 ( pathsinv0 (h (pr2 xz))) e) . }\n\n{ intro xze . destruct xze as [ xz e ] . split with xz .  exact (pathscomp0 (h (pr2 xz)) e) . }\n\n{ intro xze . destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) .  destruct ( h ( pr2 xz ) ) . destruct e . apply idpath . } \n\n{  intro xze .  destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) . destruct (h (pr2 xz)) . destruct e . apply idpath . }\n\nDefined . \n\n\nLemma hfpfunct { X X' Y Z Zt Xt' : UU } ( f : X -> Y ) ( g : Z -> X ) ( f' : X' -> Y ) ( g' : Z -> X' ) ( gt : Zt -> X ) ( ft' : Xt' -> Y ) ( gt' : Zt -> Xt' ) ( h_front : commsqstr g' f' g f ) ( h_down : commsqstr gt' ft' gt f ) ( x : hfp gt g ) : hfp ft' f' . \nProof . intros .  split with ( dirprodpair ( gt' ( pr1 ( pr1 x ) ) ) ( g' ( pr2 ( pr1 x ) ) ) ) . destruct x as [ x e ] . simpl .  destruct x as [ zt z ] . \n simpl .  simpl in e .  destruct ( pathsinv0 ( h_front z ) ) . destruct ( pathsinv0 ( h_down zt ) ) . exact ( maponpaths f e ) . Defined.\n\nLemma hfpfunct_h_back { X X' Y Z Zt Xt' : UU } ( f : X -> Y ) ( g : Z -> X ) ( f' : X' -> Y ) ( g' : Z -> X' ) ( gt : Zt -> X ) ( ft' : Xt' -> Y ) ( gt' : Zt -> Xt' ) ( h_front : commsqstr g' f' g f ) ( h_down : commsqstr gt' ft' gt f ) : commsqstr ( hfpfunct f g f' g' gt ft' gt' h_front h_down ) ( hfpprl ft' f' ) ( hfpprl gt g ) gt'  . \nProof. intros .  intro z . apply idpath . Defined.\n\n\nLemma hfpfunct_h_up { X X' Y Z Zt Xt' : UU } ( f : X -> Y ) ( g : Z -> X ) ( f' : X' -> Y ) ( g' : Z -> X' ) ( gt : Zt -> X ) ( ft' : Xt' -> Y ) ( gt' : Zt -> Xt' ) ( h_front : commsqstr g' f' g f ) ( h_down : commsqstr gt' ft' gt f ) : commsqstr ( hfpfunct f g f' g' gt ft' gt' h_front h_down )  ( hfppru ft' f' ) ( hfppru gt g ) g' . \nProof. intros .  intro z . apply idpath . Defined.\n\n\n(** Double pull-backs  ( cf. two_pullbacks_isequiv in hott-limits ) . *)\n\nDefinition doublehfp_from { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) ( xyh' : hfp f'l ( hfpprl fl gr ) ) : hfp ( funcomp f'l fl ) gr . \nProof. intros . destruct xyh' as [ [ x' [ [ x y ] h ] ] h' ] . set ( hflh' :=  pathscomp0 h ( maponpaths fl h' ) ) . exact ( hfptriple ( funcomp f'l fl ) gr x' y hflh' ) . Defined. \n\n \nDefinition doublehfp_to { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr )  ( x'yh' : hfp ( funcomp f'l fl ) gr ) : hfp f'l ( hfpprl fl gr ) . \nProof. intros . destruct x'yh' as [ [ x' y ] h' ] . exact ( hfptriple f'l ( hfpprl fl gr ) x' ( hfptriple fl gr ( f'l x' ) y h' ) ( idpath _ ) ) . Defined. \n\n\nDefinition doublehfp_to_from { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr )  : homot ( funcomp ( doublehfp_to f'l fl gr ) ( doublehfp_from f'l fl gr ) ) ( idfun ( hfp ( funcomp f'l fl ) gr ) ). \nProof. intros . intro xyh . destruct xyh as [ [ x y ] h ] .  unfold doublehfp_to . unfold doublehfp_from. unfold funcomp . unfold hfppru. unfold hfpprl . unfold idfun .  simpl .  simpl in h . rewrite ( @pathscomp0rid _ _ (fl (f'l x)) h ) .  apply idpath . Defined . \n\nLemma doublehfp_from_to_l1 { Tll Tlr Tur } ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) ( x0 : Tll ) ( z : hfiber ( hfpprl fl gr ) x0 ) : hfiber ( hfpprl fl gr ) x0 .\nProof . intros .  destruct z as [ [ [ x y ] h ] h0 ] .  exact ( tohfiber ( hfpprl fl gr ) ( hfptriple fl gr x0 y ( pathscomp0 h ( maponpaths fl h0 ) ) ) ) . Defined.  \n\nLemma doublehfp_from_to_l2 { Tll Tlr Tur } ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) ( x0 : Tll ) : homot ( doublehfp_from_to_l1 fl gr x0 ) ( idfun _ ) . \nProof. intros . intro z .  destruct z as [ [ [ x y ] h ] h0 ] . destruct h0 . unfold idfun . simpl .  unfold hfpprl .    simpl . rewrite ( @pathscomp0rid _ ( gr y ) ( fl x ) h ) . apply idpath . Defined . \n\nDefinition doublehfp_from_to { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr )  : homot ( funcomp  ( doublehfp_from f'l fl gr ) ( doublehfp_to f'l fl gr ) ) ( idfun ( hfp f'l ( hfpprl fl gr ) ) ).\nProof. intros .  intro x'yh' . destruct x'yh' as [ [ x' xyh ] h' ] .  simpl in h'. unfold hfpprl in h' .   simpl in h'.  unfold idfun . unfold funcomp. unfold doublehfp_to. unfold doublehfp_from. unfold hfpprl . unfold hfppru .   simpl . \n  set ( x0 := f'l x' ) .  set ( e := doublehfp_from_to_l2 fl gr x0 ( hfiberpair ( hfpprl fl gr ) xyh h' ) ) .  set ( phi := fun xyhh' : hfiber ( hfpprl fl gr ) x0 => hfptriple f'l ( hfpprl fl gr ) x' ( pr1 xyhh') ( pr2 xyhh' ) ) . destruct xyh as [ [ x y ] h ] .   exact ( maponpaths phi e ) .   Defined.       \n \n\nLemma isweq_doublehfp_from { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) : isweq ( doublehfp_from f'l fl gr ) . \nProof . intros . apply gradth with ( doublehfp_to f'l fl gr ) .  exact ( doublehfp_from_to f'l fl gr ) . exact ( doublehfp_to_from f'l fl gr ) . Defined. \n\n\n(** Note: change these in uu0.v *)\n \nDefinition hfibersgtof'  { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( x : X ) ( ze : hfiber g x ) : hfiber f' ( f x )  .\nProof. intros . split with ( g' ( pr1 ze ) ) .    apply ( pathscomp0  ( h ( pr1 ze ) )  ( maponpaths f ( pr2 ze ) )  ) . Defined . \n\nDefinition hfibersg'tof  { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( x' : X' ) ( ze : hfiber g' x' ) : hfiber f ( f' x' )  .\nProof. intros . split with ( g ( pr1 ze ) ) .    apply ( pathscomp0 ( pathsinv0 ( h ( pr1 ze ) ) ) ( maponpaths f' ( pr2 ze ) ) ) . Defined . \n\n\n\n\n(** ** Pre-towers and towers of types \n\nA tower of types can be viewed either as an infinite sequence of functions ... -> T_{n+1} -> T_n -> ... -> T_0 or as a coinductive object as in [tower] below.\nWe call such infinite sequences of functions pre-towers and coinductive opbjects towers. \nIn its coinductive version a tower is essentially a rooted tree of infinite (countable) depth with the collection of branches leaving each node parametrized by a  arbitrary type. \n\n\n*)\n\n(** *** Pre-towers of types - the sequence of functions definition. *)\n\nDefinition pretower := total2 ( fun T : nat -> Type => forall n : nat , T ( S n ) -> T n ) . \n\nDefinition pretowerpair ( T : nat -> Type ) ( p : forall n : nat , T ( S n ) -> T n ) : pretower := tpair ( fun T : nat -> Type => forall n : nat , T ( S n ) -> T n ) T p . \n\nDefinition preTn ( pT : pretower ) ( n : nat ) : Type := pr1 pT n .\n\nCoercion preTn : pretower >-> Funclass .  \n\nDefinition pretowerpn ( pT : pretower ) ( n : nat ) : pT ( S n ) -> pT n := pr2 pT n . \n\n\n(** Pre-tower functions. *)\n\nDefinition pretowerfun ( pT pT' : pretower ) : Type := total2 ( fun fn : forall n : nat , pT n -> pT' n => forall n : nat , homot ( funcomp ( fn ( S n ) ) ( pretowerpn pT' n ) ) ( funcomp ( pretowerpn pT n ) ( fn n ) ) ) . \n\nDefinition pretowerfunconstr ( pT pT' : pretower ) ( fn : forall n : nat , pT n -> pT' n ) ( hn : forall n : nat , homot ( funcomp ( fn ( S n ) ) ( pretowerpn pT' n ) ) ( funcomp ( pretowerpn pT n ) ( fn n ) ) ) : pretowerfun pT pT' := tpair _ fn hn . \n\nDefinition prefn { pT pT' : pretower } ( f : pretowerfun pT pT' ) ( n : nat ) : pT n -> pT' n := pr1 f n . \n\nCoercion prefn : pretowerfun >-> Funclass .  \n\nDefinition prehn { pT pT' : pretower }  ( f : pretowerfun pT pT' ) ( n : nat ) : homot ( funcomp ( prefn f ( S n ) ) ( pretowerpn pT' n ) ) ( funcomp ( pretowerpn pT n ) ( prefn f n ) ) := pr2 f n . \n\nDefinition pretowerweq ( pT pT' : pretower ) : Type := total2 ( fun f : pretowerfun pT pT' => forall n : nat , isweq ( prefn f n ) ) . \n\nDefinition pretoweridfun ( T : pretower ) : pretowerfun T T := pretowerfunconstr T T ( fun n => idfun _ ) ( fun n => fun z => idpath _ ) .\n\nDefinition pretowerfuncomp { T T' T'' : pretower } ( f : pretowerfun T T' ) ( g : pretowerfun T' T'' ) : pretowerfun T T'' := pretowerfunconstr T T'' ( fun n => funcomp ( f n ) ( g n ) ) ( fun n => fun z => pathscomp0 ( prehn g n ( f ( S n ) z ) ) ( maponpaths ( g n ) ( prehn f n z ) ) ) . \n\n\n(** Pre-tower shifts *)\n\nDefinition pretoweroneshift ( pT : pretower )  : pretower := pretowerpair ( fun n => pT ( S n ) ) ( fun n => pretowerpn pT ( S n ) ) .   \n\nDefinition pretowerfunoneshift { pT pT' : pretower } ( f : pretowerfun pT pT' ) : pretowerfun ( pretoweroneshift pT ) ( pretoweroneshift pT' ) := pretowerfunconstr   ( pretoweroneshift pT ) ( pretoweroneshift pT' ) ( fun n => f ( S n ) ) ( fun n => prehn f ( S n ) ) . \n\n(** Pre-tower pull-backs *) \n\n\nDefinition pretowerpb_a ( pT : pretower ) { X : Type } ( f : X -> pT 0 ) ( n : nat ) : total2 ( fun pretowerpbsn : Type => pretowerpbsn -> pT n ) . \nProof . intros . induction n .\n\nsplit with X . exact f . \n\nsplit with ( hfp ( pr2 IHn ) ( pretowerpn pT n ) ) . exact ( hfppru ( pr2 IHn ) ( pretowerpn pT n ) ) .  Defined. \n\nDefinition pretowerpb ( pT : pretower ) { X : Type } ( f : X -> pT 0 ) : pretower := pretowerpair ( fun n => pr1 ( pretowerpb_a pT f n ) ) ( fun n => hfpprl ( pr2 ( pretowerpb_a pT f n ) ) ( pretowerpn pT n ) ) .\n\nDefinition pretowerpbpr ( pT : pretower ) { X : Type } ( f : X -> pT 0 ) : pretowerfun ( pretowerpb pT f ) pT := pretowerfunconstr ( pretowerpb pT f ) pT ( fun n => pr2 ( pretowerpb_a pT f n ) ) ( fun n => commhfp ( pr2 ( pretowerpb_a pT f n ) ) ( pretowerpn pT n ) ) . \n\n\n\nDefinition pretowerfunct_a { pT' pT : pretower } { X X' : Type } ( g' : X' -> pT' 0 ) ( f' : pretowerfun pT' pT ) ( g : X' -> X ) ( f : X -> pT 0 ) ( h : commsqstr g f g' ( f' 0 ) ) ( n : nat ) : total2 ( fun fto : pretowerpb pT' g' n -> pretowerpb pT f n => commsqstr  fto ( pretowerpbpr pT f n ) ( pretowerpbpr pT' g' n ) ( f' n ) ) .  \nProof. intros. induction n as [ | n IHn ] . \n\nrefine ( tpair _ _ _ ) .  { exact g . } { exact h . }\n\ndestruct IHn as [ fto hn ] . refine ( tpair _ _ _ ) . \n\n{ exact ( hfpfunct ( f' n ) ( pretowerpn pT' n ) ( pretowerpn pT n ) ( f' ( S n ) ) ( pretowerpbpr pT' g' n ) ( pretowerpbpr pT f n ) fto ( prehn f' n ) hn ) . } \n\n{ exact ( fun z => idpath _ ) . } Defined. \n\n\n \nDefinition pretowerpbfunct { pT' pT : pretower } { X X' : Type } ( g' : X' -> pT' 0 ) ( f' : pretowerfun pT' pT ) ( g : X' -> X ) ( f : X -> pT 0 ) ( h : commsqstr g f g' ( f' 0 ) ) : pretowerfun ( pretowerpb pT' g' ) ( pretowerpb pT f ) . \nProof. intros . split with ( fun n => pr1 ( pretowerfunct_a g' f' g f h n ) ) . intro n . intro xze . destruct xze as [ [ x z ] e ] . apply idpath . exact ( hfpfunct_h_back  ( f' n ) ( pretowerpn pT' n ) ( pretowerpn pT n ) ( f' ( S n ) ) ( pretowerpbpr pT' g' n ) ( pretowerpbpr pT f n ) ( pr1 ( pretowerfunct_a g' f' g f h n ) ) ( prehn f' n ) ( pr2 ( pretowerfunct_a g' f' g f h n ) ) n ) . \n\n\n\n\n\n\n\nDefinition doublepretowerpb_from_a ( pT : pretower ) { X X' : Type } ( g : X' -> X ) ( f : X -> pT 0 ) ( n : nat ) : total2 ( fun fto : pretowerpb pT ( funcomp g f ) n -> pretowerpb ( pretowerpb pT f ) g n => homot ( pretowerpbpr pT ( funcomp g f ) n ) ( funcomp ( funcomp fto ( pretowerpbpr ( pretowerpb pT f ) g n ) ) ( pretowerpbpr pT f n ) ) ) .\nProof. intros .  induction n as [ | n IHn ] .\n\n{ split with ( fun x => x ) . intro . apply idpath . }\n\n{ set ( fn := pretowerpbpr pT f n ) . set ( gn := pretowerpbpr ( pretowerpb pT f ) g n ) . set ( pn := pretowerpn pT n ) . destruct IHn as [ fto en ] . refine ( tpair _ _ _ ) .  \n\n  { intro xze .  set ( xze' := hfplhomot en ( pretowerpn pT n ) xze : hfp ( funcomp ( funcomp fto gn ) fn ) pn  ) .  unfold  pretowerpb . unfold pretowerpb .  simpl . change ( hfp gn ( hfpprl fn pn ) ) . apply doublehfp_to . \n apply ( hfppru fto ( hfpprl ( funcomp gn fn ) pn ) ) .  apply doublehfp_to . apply xze' . }\n\n  { intro xze .  destruct xze as [ [ x z ] e ] . apply idpath . }} \n\nDefined . \n\n\nDefinition doublepretowerpb_from ( pT : pretower ) { X X' : Type } ( g : X' -> X ) ( f : X -> pT 0 ) : pretowerfun ( pretowerpb pT ( funcomp g f ) ) ( pretowerpb ( pretowerpb pT f ) g ) . \nProof. intros . refine ( pretowerfunconstr _ _ _ _ ) . \n\n{ intro n .  exact ( pr1 ( pretowerpb_trans_a pT g f n ) ) . } \n\n{ intro n .  intro xze . destruct xze as [ [ x z ] e ] . simpl .  destruct ( pretowerpb_trans_a pT g f n ) . apply idpath . } \n\nDefined. \n\n\n(** Pre-tower fibers *)\n\n\n\nDefinition pretfib { pT : pretower } ( t : pT 0 ) : pretower := pretoweroneshift ( pretowerpb pT ( fromunit t ) ) . \n\nDefinition pretfibj { pT : pretower } ( t : pT 0 ) : pretowerfun ( pretfib t ) ( pretoweroneshift pT ) := pretowerfunoneshift ( pretowerpbpr pT ( fromunit t ) ) . \n\n\n(* To be removed:\n\nDefinition pretfib_Tn_jn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : total2 ( fun pretfibn : Type => pretfibn -> pT ( S n ) ) .\nProof . intros . induction n .  \n\nsplit with (hfiber ( pretowerpn pT O ) t ) .  exact pr1 . \n\nsplit with ( hfp ( pr2 IHn ) ( pretowerpn pT ( S n ) ) ) . exact ( hfppru ( pr2 IHn ) ( pretowerpn pT ( S n ) ) ) . Defined. \n\nDefinition pretfib_Tn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : Type := pr1 ( pretfib_Tn_jn pT t n ) . \n\nDefinition pretfib_jn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : pretfib_Tn pT t n -> pT ( S n ) := pr2 (  pretfib_Tn_jn pT t n ) . \n\nDefinition pretfib_pn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : pretfib_Tn pT t ( S n ) -> pretfib_Tn pT t n .\nProof. intros pT t n .  exact ( hfpprl ( pr2 ( pretfib_Tn_jn pT t n ) ) ( pretowerpn pT ( S n ) ) ) . Defined. \n\nDefinition pretfib { pT : pretower } ( t : pT 0 ) : pretower := pretowerpair ( pretfib_Tn pT t ) ( pretfib_pn pT t ) . \n\nLemma pr0pretfib ( pT : pretower ) ( t : pT 0 ) : paths ( pretfib t  0 ) ( hfiber ( pretowerpn pT O ) t ) . \nProof. intros. apply idpath .  Defined. \n\nDefinition pretowerfuntfib_a { pT pT' : pretower } ( f : pretowerfun pT pT' ) ( t : pT 0 ) ( n : nat ) : total2 ( fun funtfibn : ( pretfib t n ) -> ( pretfib ( f 0 t ) n ) => commsqstr ( f ( S n ) ) ( pretfibj ( f 0 t ) n ) ( pretfibj t n ) funtfibn ) .\nProof. intros pT pT' f t n . induction n as [ | n IHn ] .  \n\nsplit with ( hfibersgtof' ( f 0 ) ( pretowerpn pT' 0 ) ( pretowerpn pT 0 ) ( f 1 ) ( prehn f 0 ) t ) . intro . About commsqstr .  apply idpath . ???\n\n\nsplit with ( hfpfunct ( f ( S n ) ) ( pretowerpn pT ( S n ) ) ( pretowerpn pT' ( S n ) ) ( f ( S ( S n ) ) )  ( pretfibj pT t n ) ( pretfibj pT' ( f 0 t ) n ) ( pr1 IHn ) ( prehn f ( S n ) ) ( pr2 IHn ) ) .  intro. apply idpath .  Defined. \n\n*)\n\nDefinition pretowerfuntfib { pT pT' : pretower } ( f : pretowerfun pT pT' ) ( t : pT 0 ) : pretowerfun ( pretfib t ) ( pretfib ( f 0 t ) ) .\nProof. intros.  apply pretowerfunoneshift.  apply ( pretowerpb_trans pT ( fromunit t ) ???? . \n\n\nDefinition pretfibtopretoweroneshift ( pT : pretower ) ( t0 : pT 0 ) : pretowerfun ( pretfib t0 ) ( pretoweroneshift pT ) := pretowerfunconstr ( pretfib t0 ) ( pretoweroneshift pT ) ( pretfibj pT t0 ) ( fun n => fun z => ( pr2 z ) ) .  \n\nDefinition pretfibofpretoweroneshift_a ( pT : pretower ) ( t1 : pT 1 ) ( n : nat ) ( t : @pretfib ( pretoweroneshift pT ) t1 n ) : @pretfib ( @pretfib pT ( pretowerpn pT 0 t1 ) ) ( tohfiber ( pretowerpn pT 0 ) t1 ) n . \nProof. intros .  induction n .  ???\n\nDefinition pretfibofpretoweroneshift ( pT : pretower ) ( t1 : pT 1 ) : pretowerfun ( @pretfib ( pretoweroneshift pT ) t1 ) ( @pretfib ( @pretfib pT ( pretowerpn pT 0 t1 ) ) ( tohfiber ( pretowerpn pT 0 ) t1 ) ) .\nProof.   intros . ???\n\n\n\n\n\nDefinition prenshift ( n : nat ) ( pT : pretower ) : pretower .\nProof. intros . induction n as [| n IHn] . exact pT . exact ( pretoweroneshift IHn ). Defined. \n\n\n\n\n\n\n\n\n(** *** Towers of types - the coinductive definition. *)\n\nCoInductive tower := towerconstr : forall T0 : Type, ( T0 -> tower ) -> tower .\n\nDefinition pr0 ( T : tower ) : Type .\nProof. intro . destruct T as [ T' S' ] . exact T' . Defined. \n\nDefinition tfib { T : tower } ( t : pr0 T ) : tower .\nProof. intro. destruct T as [ T' S' ] . exact S' . Defined. \n\nDefinition oneshift ( T : tower ) : tower := towerconstr ( total2 ( fun t : pr0 T => pr0 ( tfib t ) ) ) ( fun tf => tfib ( pr2 tf ) ) .\n\nDefinition nshift ( n : nat ) ( T : tower ) : tower .\nProof. intros . induction n as [| n IHn] . exact T . exact (oneshift IHn). Defined. \n\n\n\nCoInductive towerfun : forall ( T T' : tower ) , Type := towerfunconstr : forall ( T T' : tower ) ( f0 : pr0 T -> pr0 T' ) ( ff : forall t0 : pr0 T , towerfun ( tfib t0 ) ( tfib ( f0 t0 ) ) ) , towerfun T T' . \n\nDefinition towerfunpr0 { T T' : tower } ( f : towerfun T T' ) : pr0 T -> pr0 T' .\nProof. intros T1 T2 f G . destruct f as [ T T' f0 ff ] .  exact ( f0 G ) . Defined. \n\nDefinition towerfuntfib { T T' : tower } ( f : towerfun T T' ) ( t : pr0 T ) : towerfun ( tfib t ) ( tfib ( towerfunpr0 f t ) ) .\nProof. intros. destruct f as [ T T' f0 ff ] . exact ( ff t ).  Defined.\n\nCoFixpoint toweridfun ( T : tower ) : towerfun T T := towerfunconstr T T ( fun x => x ) ( fun t0 => toweridfun ( tfib t0 ) ) .\n\nCoFixpoint towerfuncomp { T T' T'' : tower } ( f : towerfun T T' ) ( g : towerfun T' T'' ) : towerfun T T'' := towerfunconstr T T'' ( fun x => towerfunpr0 g ( towerfunpr0 f x ) ) ( fun x : pr0 T => @towerfuncomp ( tfib x ) ( tfib ( towerfunpr0 f x ) ) ( tfib ( towerfunpr0 g ( towerfunpr0 f x ) ) ) ( towerfuntfib f x ) ( towerfuntfib g ( towerfunpr0 f x ) ) )  . \n\n\n\n\n\n\n(** *** Equivalence between towers and pre-towers *)\n\n(** Towers from pre-towers *)\n\n\n\nCoFixpoint towerfrompretower ( pT : pretower )  : tower := towerconstr ( prepr0 pT ) ( fun t => towerfrompretower ( @pretfib pT t ) ) .\n\nCoFixpoint towerfrompretowerfun { pT pT' : pretower } ( f : pretowerfun pT pT' ) : towerfun ( towerfrompretower pT ) ( towerfrompretower pT' ) := towerfunconstr ( towerfrompretower pT ) ( towerfrompretower pT' )  ( f 0 ) ( fun t0 => @towerfrompretowerfun ( @pretfib pT t0 ) ( @pretfib pT' ( f 0 t0 ) ) ( pretowerfuntfib f t0 ) ) . \nDefinition tfib_t_from_pt ( pT: pretower ) ( t : pT O ) : paths ( towerfrompretower ( @pretfib pT t ) ) ( @tfib ( towerfrompretower pT ) t ) . \nProof. intros .   apply idpath . Defined .\n\nLemma oneshift_t_from_pt_to ( pT : pretower ) : towerfun ( towerfrompretower ( pretoweroneshift pT ) ) ( oneshift ( towerfrompretower pT ) ) . \nProof. intro . cofix. split with ( tococonusf ( pretowerpn pT O ) ) .  intro t1 .  \n\nset (tinhfiber := pr2 ( tococonusf ( pretowerpn pT O ) t1 )  : hfiber ( pretowerpn pT 0 ) ( pretowerpn pT 0 t1 ) ) . change (@tfib ( oneshift ( towerfrompretower pT ) ) (tococonusf (pretowerpn pT 0) t1 ) ) with (@tfib ( towerfrompretower ( @pretfib pT ( pretowerpn pT 0 t1 ) ) )  tinhfiber ) . \n\napply ( fun f => @towerfuntfib ( towerfrompretower ( pretoweroneshift pT ) ) ( towerfrompretower (  @pretfib pT ( pretowerpn pT 0 t1 ) ) ) f t1 ) .   . simpl . \n\n\n  Defined. \n\n\n(** Pre-towers from towers *)\n\nDefinition Tn ( T : tower ) ( n : nat ) : Type := pr0 (nshift n T).\n\nCoercion Tn : tower >-> Funclass . \n\nLemma TSn ( T :tower ) ( n : nat ) : paths ( T ( S n ) ) ( total2 ( fun t : T n => pr0 ( tfib t ) ) ) .  \nProof. intros . apply idpath . Defined. \n\n\nDefinition pn ( T : tower ) ( n : nat ) : T ( S n ) -> T n := @pr1 _ ( fun t : pr0 ( nshift n T ) => pr0 ( tfib t ) ) . \n\nDefinition pretowerfromtower ( T : tower ) : pretower := pretowerpair ( fun n => T n ) ( fun n => pn T n ) . \n\n\n(** Pre-towers from towers from pre-towers *)\n\nDefinition TnpretopreTn ( pT : pretower ) ( n : nat ) : Tn ( towerfrompretower pT ) n  -> preTn pT n .\nProof. intros pT n .  induction n . \n\nintro x . exact x .\n\nintro x . unfold towerfrompretower in x . unfold Tn in x .  simpl in x .  \n\n\n\n\nDefinition weqTnpre ( pT : pretower ) ( n : nat ) : weq ( towerfrompretower pT n ) ( preTn pT n ) . \nProof. intros . \n\nassert   \n\n\n\nLemma pttpt_to_id_fun ( pT : pretower ) : pretowerfun ( pretowerfromtower ( towerfrompretower pT ) ) pT .\nProof. intro. \n\n\n\n\n\n\n\n\nDefinition fiberfloor { n : nat } { T : tower } ( tn : T n ) := pr0 ( tfib tn ) . \n\n(* Useful formulas:\n\ntowerfloor (1+n) T := total2 ( fun G : towerfoloor n T => fiberfloor G ) \n\n@tfib (1+n) T ( tpair _ G G' ) := @tfib (tfib G) G'\n\n*) \n\nDefinition fiberfloortotowerfloor { n : nat } { T : tower } ( tn : T n ) ( t' : fiberfloor tn ) : T ( S n ) := tpair _ tn t' .\n\n\n\n(** *** The type of functions berween towers *)\n\n\n\n\nDefinition towerfunfiberfloor { T T' : tower } ( f : towerfun T T' ) { G : pr0 T } : @fiberfloor 0 _ G -> @fiberfloor 0 _ ( towerfunpr0 f G ) := towerfunpr0 ( towerfuntfib f G ) .\n\nDefinition towerfunnshift { T T' : tower } ( n : nat ) ( f : towerfun T T' ) : towerfun ( nshift n T ) ( nshift n T' ) .\nProof.  intros . induction n as [ | n IHn ] .  exact f .  apply towerfunconstr with ( fun tf => tpair _ ( towerfunpr0 IHn (pr1 tf) ) ( towerfunfiberfloor IHn (pr2 tf) ) ) .  intro t0 . apply ( towerfuntfib ( towerfuntfib IHn ( pr1 t0 ) ) ( pr2 t0 ) ) . Defined. \n\nDefinition towerfunonfloors { n : nat } { T T' : tower } ( f : towerfun T T' ) :  T n -> T' n := towerfunpr0 ( towerfunnshift n f ) . \n\nDefinition towerfunontowersovers  { n : nat } { T T' : tower } ( f : towerfun T T' ) ( G : T n ) : towerfun ( tfib G ) ( tfib ( towerfunonfloors f G ) ) := towerfuntfib ( towerfunnshift n f ) G .\n\n\n(** An example of a function between towers *)\n\n\nCoFixpoint towerstrmap ( T : tower ) ( t0 : pr0 T ) : towerfun ( tfib t0 ) T := towerfunconstr _ _ ( fun x => t0 ) ( fun t1 => towerstrmap ( tfib t0 ) t1 ) .   \n \n\n(** *** The type of homotopies between functions of towers *)\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(* Some constructions related to tower shifts *)\n\n\nDefinition mnshiftfun ( m n : nat ) ( T : tower ) : towerfun ( nshift m ( nshift n T ) ) ( nshift ( m + n ) T ) .\nProof. intros . induction m . \n\napply toweridfun . \n\nset ( onfloors := ( fun G' => tpair _ (towerfunpr0 IHm (pr1 G')) (towerfunfiberfloor IHm  (pr2 G' ) ) )  :  (nshift n T) (S m) -> T (S (m + n))) .   \n\nsplit with onfloors . intro G .  apply ( towerfuntfib ( towerfuntfib IHm (pr1 G) ) (pr2 G) ) . Defined. \n\nDefinition mnfloorfun { m n : nat } { T : tower } ( G : ( nshift n T ) m  ) : T ( m + n )  := towerfunpr0 ( mnshiftfun m n T ) G . \n\n\nDefinition tfibtotop { n : nat } { T : tower } ( G : T n  ) : towerfun ( tfib G ) ( nshift  ( S n ) T ).\nProof. intros. \n\nsplit with ( fun G' : pr0 ( tfib G ) => tpair ( fun G : T n  => pr0 ( tfib G ) ) G G' ) .  \n\nintro G' . apply toweridfun . Defined. \n\nDefinition fiberfloortofloor { n m : nat } { T : tower } ( G : T n  ) ( G' : ( tfib G ) m  ) : T ( m + ( S n ) )  . \nProof. intros. apply ( mnfloorfun ( towerfunonfloors ( tfibtotop G ) G' ) ) . Defined. \n\n\n(* Extending a tower with a unit type *)\n\nDefinition towerunitext ( T : tower ) : tower := towerconstr unit ( fun x : unit => T ) . \n\n(* Extended tower over a node G : T n *)\n\nDefinition tfibplus { n : nat } { T : tower } ( G : T n ) := towerconstr unit ( fun x => tfib G ) . \n\nDefinition fromtfibplus { n : nat } { T : tower } ( G : T n ) : towerfun ( tfibplus G ) ( nshift n T ) .\nProof .  intros .  split with ( fun x => G ) . intro . apply ( toweridfun (tfib G) ) .  Defined. \n\n\n\n(* The type of carriers of B-systems - towers together with a one step ramification at each floor except for the ground floor. *)\n\n\nDefinition bsyscar := total2 ( fun T : tower => forall ( n : nat ) ( GT : T ( S n )  ) , Type ) . \nDefinition bsyscarpair ( T : tower ) ( btilde : forall ( n : nat ) ( GT : T ( S n )  ) , Type ) : bsyscar := tpair _ T btilde . \n\nDefinition bsyscartotower ( B : bsyscar ) := pr1 B .\n\nCoercion bsyscartotower : bsyscar >-> tower.\n\n\nDefinition Btilde { n : nat } { B : bsyscar } ( GT : B ( S n ) ) : Type := pr2 B n GT . \n\nDefinition bsyscarover { n : nat } { B : bsyscar } ( G : B n ) : bsyscar := bsyscarpair ( tfibplus G ) ( fun m : nat => fun DT : ( tfibplus G ) ( S m )  => @Btilde ( ( m + n ) ) B ( towerfunpr0 ( mnshiftfun ( S m ) n B ) ( towerfunonfloors ( fromtfibplus G ) DT ) ) ) .    \n\n\n\n\n(* The type of functions between bsystemcarrier's *)\n\nDefinition bsyscarfun ( B B' : bsyscar ) := total2 ( fun f : towerfun B B' => forall ( n : nat ) ( GT : B ( S n ) ) , Btilde GT -> Btilde ( @towerfunonfloors (S n) _ _ f GT ) ) . \n\nDefinition bsyscarfuntotowerfun ( B B' : bsyscar ) : bsyscarfun B B' -> towerfun B B' := pr1 .\nCoercion bsyscarfuntotowerfun : bsyscarfun >-> towerfun .\n\nDefinition Bnfun { n : nat } { B B' : bsyscar } ( f : bsyscarfun B B' ) ( G : B n ) : B' n := @towerfunonfloors n _ _ f G .\n\nDefinition Btildefun { n : nat } { B B' : bsyscar } ( f : bsyscarfun B B' ) { GT : B (S n ) } ( t : Btilde GT ) : Btilde ( Bnfun f GT ) := pr2 f n GT t .\n\n(* Structures on bsystemcarriers which together form the data of a B-system. *)\n\n(* Operation Tops : ( Gamma, x:T |- ) => ( Gamma , Delta |- ) => ( Gamma, x:T, Delta |- ) *)\n\nDefinition Tops ( B : bsyscar ) := forall ( n : nat ) ( G : B n ) ( GT : pr0 ( tfib G ) ) , towerfun ( tfib G ) ( tfib GT ) .\n\n(* Operation Ttildeops : ( Gamma, x:T |- ) => ( Gamma , Delta |- s : S ) => ( Gamma, x:T, Delta |- s : S ) *)\n\nDefinition Ttildeops ( B : bsyscar ) ( Top : Tops B ) := forall ( n m : nat ) ( G : towerfloor n B ) ( GT : tfib G ) ( GDS : towerfloor ( S m ) ( tfib G ) ) ( s : BT ( fiberfloortofloor ( pr1 GT ) GDS ) ) , BT ( fiberfloortofloor GT ( towerfunonfloors ( Top _ GT ) GDS ) ) .  \n\n(* note - B for bsyscar, G : towerfloor n B , T : tfib G *)\n\n\n(* Operation Sops : ( Gamma |- s : S ) => ( Gamma , x:S, Delta |- ) => ( Gamma, Delta[s/x] |- ) *)\n\nDefinition Sops ( B : bsyscar ) := forall ( n : nat ) ( G : towerfloor ( S n ) B ) ( s : BT G ) , towerfun ( @tfib (nshift (S n) B ) G ) ( @tfib (nshift n B ) ( pr1 G ) ) . \n\n(* Operation Stildeops : ( Gamma |- s : S ) => ( Gamma , x:S, Delta |- r : R ) => ( Gamma, Delta[s/x] |- r[s/x]:R[s/x]) *)\n\nDefinition Stildeops ( B : bsyscar ) ( Sop : Sops B ) := forall ( n m : nat ) ( GS : pr0 ( nshift ( S n ) B ) ) ( s : BT GS ) ( GSDR : towerfloor ( S m ) ( tfib GS ) ) ( r : BT ( fiberfloortofloor GS GSDR ) ) , BT ( fiberfloortofloor ( pr1 GS ) ( towerfunonfloors ( Sop _ _ s ) GSDR ) ) .  \n\n(* Operation deltaops : ( Gamma, x:T |- ) => ( Gamma, x : T |- x : T ) *)\n\nDefinition deltaops ( B : bsyscar ) ( Top : Tops B ) := forall ( n : nat ) ( GT : towerfloor ( S n ) B ) , BT ( fiberfloortotowerfloor GT ( towerfunpr0 ( Top n GT ) ( pr2 GT )  ) ) .   \n\n\n(* End of the file bsystems.v *)"
  },
  {
    "path": "Current_work/semisimplicial.v",
    "content": "Add Rec LoadPath \"..\".\n\nRequire Export Foundations.hlevel2.finitesets .\n\nUnset Automatic Introduction.\n\n\nVariable Delta : forall (i j : nat) , UU . (* This should be defined as the type of order preserving injections from {0,...i} to {0,...,j}. I introduced these axiomatically to save the time. *)\n\nVariable gamma : forall ( i j k : nat ) ( s1 : Delta i j ) (s2 : Delta j k ) , Delta i k . (* This should be defined as compositions of injections. *)\n\nVariable rl : forall ( j k : nat )( s : Delta j k )( a : stn (j+1) ) , stn (k + 1) . (* This should be defined as the obvious function from order preserving injections to all funcions. *) \n\nDefinition Intrec1 ( n : nat ) := total2 ( fun \n\nSS : UU => total2 ( fun \n\nmapsfromsks : forall ( X : SS ) ( m : nat ) ( c : natleh m n )  (i : nat ) , UU  => \n\n(* restr: *) forall ( X : SS )  ( m : nat ) ( c : natleh m n )  (i j : nat ) ( s : Delta i j ) ( f : mapsfromsks X m c j ) , mapsfromsks X m c i ) ) .\n\nDefinition SS ( n : nat ) ( XX : Intrec1 n ) := pr1 XX .\n\nDefinition mapsfromsks ( n : nat ) ( XX : Intrec1 n ) := pr1 (pr2 XX ) . \n\nDefinition restr ( n : nat ) ( XX : Intrec1 n ) :=  pr2 ( pr2 XX ) . \n\n\n(* We are now going to attempt to construct for each n : nat an object SEMISIPL n of Intrec1 n such that:\n\nSS n ( SEMISIMPL n ) - is the type of semi-simplicial types of dimension n.\n\nmapsfromsks n ( SEMISIMPL n ) X m c i - the type of functions sk_m Delta^i -> X from the m-th skeleton of Delta^i into X.\n\nrestr n ( SEMISIMPL n ) X m c i j s f - the composition of sk_m (s) where s : Delta^i -> Delta^j with f : sk_m Delta^k -> X.\n\nWe will do it by induction on n . To apply induction we need to construct for each n : nat a function Intrec1 n -> Intrec1 ( S n ) . We will be construcing it in a sequence of lemmas below, constructing first a function \n\nSSSn n : Intrec1 n -> UU \n\nthen a function  \n\nmapsfromsksSn n : forall IHn : Intrec1 n , ( forall ( X : SSSn n IHn ) ( m : nat ) ( c : natleh m ( S n ) )  (i : nat ) , UU ) \n\nand then restrSn n.\n\n\n*)\n\n\nDefinition SSSn ( n : nat ) ( IHn : Intrec1 n ) : UU := total2 ( fun Xn : SS n IHn => forall f : mapsfromsks n IHn Xn n (isreflnatleh n) ( S n ) , UU ) .\n\nDefinition mapsfromsksSn ( n : nat ) ( IHn : Intrec1 n ) : forall ( X : SSSn n IHn ) ( m : nat ) ( c : natleh m ( S n ) ) ( i : nat ) , UU .\nProof.  intros . set ( cc := natlehchoice2 _ _ c ) . destruct cc .\nsimpl in h . change (pr1 (natleh m n ) ) in h . exact ( mapsfromsks n IHn ( pr1 X ) m h i ) .   \nexact ( total2 ( fun f : mapsfromsks n IHn ( pr1 X ) n ( isreflnatleh n ) i => forall s : Delta ( S n ) i , (pr2 X) (restr n IHn (pr1 X) n (isreflnatleh n) ( S n ) i s f ) ) ). Defined.\n\nDefinition SEMISIMPL ( n : nat ) : Intrec1 n .\nProof . induction n as [ | n IHn ] .\n\n(* n=0 *)  unfold Intrec1. split with UU . split with (fun X => fun i => fun c => fun j => ( stn (j+1) -> X )) . About rl .  exact ( fun X => fun i => fun c => fun j => fun k => fun a => fun f => fun phi => f (rl j k a phi) ). \n\n(* n => Sn *) set ( SSn := SS n IHn ) . set (mapsfromsksn := mapsfromsks n IHn ) . set (restrn := restr n IHn ) .\n\nset ( SSSn := total2 ( fun Xn : SSn => forall f : mapsfromsksn Xn n (isreflnatleh n) ( S n ) , UU ) ) . split with SSSn . \n\nsplit with (fun X => fun i => fun c => fun j => mapsfromsksSn n IHn X i c j ) . \n\nintros X i c j k . unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc  as [ isle | iseq ] . apply restrn . \n\nintros s f. destruct f as [fn ff]. simpl in restrn .  change (pr1 IHn) with SSn in restrn . change (pr1 (pr2 IHn)) with mapsfromsksn in restrn.  split with (restrn (pr1 X) n (isreflnatleh n) j k s fn ).  \n\nintros . set ( s1 := gamma ( S n ) j k s0 s ) . set ( ffint := ff s1 ) . \n\nset ( fs1 := restrn (pr1 X) n (isreflnatleh n) (S n) k s1 fn ) . set (fs0s := restr n IHn (pr1 X) n (isreflnatleh n) (S n) j s0 (restrn (pr1 X) n (isreflnatleh n) j k s fn)). \n\nsimpl in fs1 . simpl in fs0s. \n\nassert ( e : paths (restrn (pr1 X) n (isreflnatleh n) (S n) k s1 fn) (restr n IHn (pr1 X) n (isreflnatleh n) (S n) j s0 (restrn (pr1 X) n (isreflnatleh n) j k s fn )) ).\n\n(* At this point the goal is to prove a certain equality which asserts \"transitivity\" or \"naturality\" of restriction maps. This equlity will be provable as a strict equality in HTS. The proof is by induction and if attempt it for \"paths\" we get into problems with the need to take into acount transports of increasing complexity with each new induction step. Here we use \"admit\" . *) admit . \n\napply ( transportf ( fun z : _ => pr2 X z ) e ) .   apply ffint . Defined. \n\n\n\nDefinition SEMISIMPL0 : Intrec1 0.\nProof . unfold Intrec1. split with UU . split with (fun X => fun i => fun c => fun j => ( stn (j+1) -> X )) .  exact ( fun X => fun i => fun c => fun j => fun k => fun a => fun f => fun phi => f (rl j k a phi ) ). Defined.\n\nDefinition SEMISIMPL1 : Intrec1 1.\nProof.  set ( IHn := SEMISIMPL0 ) . set ( SSn := SS 0 IHn ) . set (mapsfromsksn := mapsfromsks 0 IHn ) . set (restrn := restr 0 IHn ) .\n\nset ( SSSn := total2 ( fun Xn : SSn => forall f : mapsfromsksn Xn 0 (isreflnatleh 0) ( S 0 ) , UU ) ) . split with SSSn . \nsplit with (fun X => fun i => fun c => fun j => mapsfromsksSn 0 IHn X i c j ) . \n\nintros X i c j k.  unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc . apply restrn . \n\nintros. destruct f as [fn ff]. simpl in restrn .  change (pr1 IHn) with SSn in restrn . change (pr1 (pr2 IHn)) with mapsfromsksn in restrn.  split with (restrn (pr1 X) 0 (isreflnatleh 0) j k s fn).  \n\nintros . set ( s1 := gamma ( S 0 ) j k s0 s ) . set ( ffint := ff s1 ) . \n\nset ( fs1 := restrn (pr1 X) 0 (isreflnatleh 0) (S 0) k s1 fn) . set (fs0s := restr 0 IHn (pr1 X) 0 (isreflnatleh 0) (S 0) j s0 (restrn (pr1 X) 0 (isreflnatleh 0) j k s fn )). \n\nsimpl in fs1 . simpl in fs0s.\n\nassert ( e : paths (restrn (pr1 X) 0 (isreflnatleh 0) (S 0) k s1 fn) (restr 0 IHn (pr1 X) 0 (isreflnatleh 0) (S 0) j s0 (restrn (pr1 X) 0 (isreflnatleh 0) j k s fn ) ) ).\n\nsimpl.  unfold IHn. unfold restrn. unfold restr. unfold IHn .   unfold SEMISIMPL0.  simpl . apply funextfun . intro .  apply ( maponpaths fn ) . \n\nCheck (restrn (pr1 X) 0 (isreflnatleh 0) (S 0) k s1 fn).\n\n\n\n\n\n\n\n\n(* End of the file semisimplicial.v *)\n\n\n"
  },
  {
    "path": "Current_work/semisimplicial2.v",
    "content": "Add Rec LoadPath \"../Foundations/Generalities\".\nAdd Rec LoadPath \"../Foundations/hlevel1\".\nAdd Rec LoadPath \"../Foundations/hlevel2\".\n\nRequire Export \"../Foundations/hlevel2/finitesets\" .\n\nUnset Automatic Introduction.\n\nPrint identity_rect.\n\nVariable Delta : forall (i j : nat) , UU . (* This should be defined as the type of order preserving injections from {0,...i} to {0,...,j}. I introduced these axiomatically to save the time. *)\n\nVariable gamma : forall ( i j k : nat ) ( s1 : Delta i j ) (s2 : Delta j k ) , Delta i k . (* This should be defined as compositions of injections. *)\n\nVariable rl : forall ( j k : nat )( s : Delta j k )( a : stn (j+1) ) , stn (k + 1) . (* This should be defined as the obvious function from order preserving injections to all funcions. *) \n\nDefinition Intrec1 ( n : nat ) := total2 ( fun \n\nSS : UU => total2 ( fun \n\nmapsfromsks : forall ( X : SS ) ( m : nat ) ( c : natleh m n )  (i : nat ) , UU  => total2 ( fun \n\nrestr: forall ( X : SS )  ( m : nat ) ( c : natleh m n )  (i j : nat ) ( s : Delta i j ) ( f : mapsfromsks X m c j ) , mapsfromsks X m c i =>\n\n(* pbn : *) forall ( X : SS )  ( m : nat ) ( c : natleh m n ) ( i j k : nat ) ( s1 : Delta i j ) ( s2 : Delta j k ) ( f : mapsfromsks X m c k ) , paths  ( restr X m c i k ( gamma i j k s1 s2 ) f ) ( restr X m c i j s1 ( restr X m c j k s2 f ) ) ) ) ) .    \n\nDefinition SS ( n : nat ) ( XX : Intrec1 n ) := pr1 XX .\n\nDefinition mapsfromsks ( n : nat ) ( XX : Intrec1 n ) := pr1 (pr2 XX ) . \n\nDefinition restr ( n : nat ) ( XX : Intrec1 n ) := pr1 ( pr2 ( pr2 XX ) ). \n\nDefinition pbn ( n : nat ) ( XX : Intrec1 n ) := pr2 ( pr2 ( pr2 XX ) ) . \n\n(* We are now going to construct for each n : nat an object SEMISIPL n of Intrec1 n such that:\n\nSS n ( SEMISIMPL n ) - is the type of semi-simplicial types of dimension n.\n\nmapsfromsks n ( SEMISIMPL n ) X m c i - the type of functions sk_m Delta^i -> X from the m-th skeleton of Delta^i into X.\n\nrestr n ( SEMISIMPL n ) X m c i j s f - the composition of sk_m (s) where s : Delta^i -> Delta^j with f : sk_m Delta^k -> X.\n\npbn n ( SEMISIMPL n ) X m c i j k s1 s2 f - the \"associativity\" of the form ( ( f sk_m(s2) ) sk_m(s1) ) = f ( sk_m ( s2 s1 ) ) \n\nWe will do it by induction on n . To apply induction we need to construct for each n : nat a function Intrec1 n -> Intrec1 ( S n ) . We will be construcing it in a sequence of lemmas below, constructing first a function \n\nSSSn n : Intrec1 n -> UU \n\nthen a function  \n\nmapsfromsksSn n : forall IHn : Intrec1 n , ( forall ( X : SSSn n IHn ) ( m : nat ) ( c : natleh m ( S n ) )  (i : nat ) , UU ) \n\nand then restrSn n and pbnSn n . \n\n\n*)\n\n\nDefinition SSSn ( n : nat ) ( IHn : Intrec1 n ) : UU := total2 ( fun Xn : SS n IHn => forall f : mapsfromsks n IHn Xn n (isreflnatleh n) ( S n ) , UU ) .\n\nDefinition mapsfromsksSn ( n : nat ) ( IHn : Intrec1 n ) : forall ( X : SSSn n IHn ) ( m : nat ) ( c : natleh m ( S n ) ) ( i : nat ) , UU .\nProof.  intros . set ( cc := natlehchoice2 _ _ c ) . destruct cc .\nsimpl in h . change (pr1 (natleh m n ) ) in h . exact ( mapsfromsks n IHn ( pr1 X ) m h i ) .   \nexact ( total2 ( fun f : mapsfromsks n IHn ( pr1 X ) n ( isreflnatleh n ) i => forall s : Delta ( S n ) i , (pr2 X) (restr n IHn (pr1 X) n (isreflnatleh n) ( S n ) i s f ) ) ). Defined.\n\nDefinition restrSn ( n : nat ) ( IHn : Intrec1 n ) : forall ( X : SSSn n IHn ) ( m : nat ) ( c : natleh m ( S n ) )  (i j : nat ) ( s : Delta i j ) ( f : mapsfromsksSn n IHn X m c j ) , mapsfromsksSn n IHn X m c i.\nProof . intros n IHn.  \n\nintros X m c i j. unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc . apply ( restr n IHn ). \n\nintros. destruct f as [fn ff].   split with (restr n IHn (pr1 X) n (isreflnatleh n) i j s fn ).  \n\nintros . set ( s1 := gamma ( S n ) i j s0 s ) . set ( ffint := ff s1 ) . \n\nset ( fs1 := restr n IHn (pr1 X) n (isreflnatleh n) (S n) j s1 fn ) . set (fs0s := restr n IHn (pr1 X) n (isreflnatleh n) (S n) i s0 (restr n IHn (pr1 X) n (isreflnatleh n) i j s fn)). \n\nsimpl in fs1 . simpl in fs0s.\n\nassert ( e : paths (restr n IHn (pr1 X) n (isreflnatleh n) (S n) j s1 fn) (restr n IHn (pr1 X) n (isreflnatleh n) (S n) i s0 (restr n IHn (pr1 X) n (isreflnatleh n) i j s fn )) ). unfold s1. apply ( pbn n IHn ) . \n\nchange (restr n IHn (pr1 X) n (isreflnatleh n) (S n) i s0\n           (restr n IHn (pr1 X) n (isreflnatleh n) i j s fn)) with fs0s in e . apply (transportf _ e ffint ) . Defined. \n\n(* \n\nDefinition pbnSn ( n : nat ) ( IHn : Intrec1 n ) : forall ( X : SSSn n IHn )  ( m : nat ) ( c : natleh m ( S n ) ) ( i j k : nat ) ( s1 : Delta i j ) ( s2 : Delta j k ) ( f : mapsfromsksSn  n IHn X m c k ) , paths  ( restrSn n IHn X m c i k ( gamma i j k s1 s2 ) f ) ( restrSn n IHn X m c i j s1 ( restrSn n IHn X m c j k s2 f ) ) .\nProof .  intros n IHn X m c i j k s1 s2 . unfold mapsfromsksSn . unfold restrSn. set ( cc := natlehchoice2 _ _ c ) . destruct cc .\n\napply ( pbn n IHn ) . \n\nintro f . destruct f as [ f sf ] .  \n\nassert ( inte1 : paths (tpair _ (restr n IHn (pr1 X) n (isreflnatleh n) i k (gamma i j k s1 s2) f) ( fun s0 : Delta (S n) i =>\n            transportf (pr2 X)\n              (pbn n IHn (pr1 X) n (isreflnatleh n) \n                 (S n) i k s0 (gamma i j k s1 s2) f)\n              (sf (gamma (S n) i k s0 (gamma i j k s1 s2))) ) ) \n                        (tpair _ (restr n IHn (pr1 X) n (isreflnatleh n) i j s1\n              (restr n IHn (pr1 X) n (isreflnatleh n) j k s2 f)) ( fun s0 : Delta ( S n ) i => \ntransportf (pr2 X)\n              (pbn n IHn (pr1 X) n (isreflnatleh n) \n                 (S n) i k s0 (gamma i j k s1 s2) f)\ntransportf (pr2 X)\n              (pbn n IHn (pr1 X) n (isreflnatleh n) \n                 (S n) i k s0 (gamma i j k s1 s2) f)\n              (sf (gamma (S n) i k s0 (gamma i j k s1 s2))) \n\n\nset ( P := fun g : mapsfromsks n IHn ( pr1 X ) n ( isreflnatleh n ) i =>  forall s0 : Delta ( S n ) i , pr2 X\n         ( restr n IHn (pr1 X) n (isreflnatleh n) (S n) i s0 g) ) . \n\n(restr n IHn (pr1 X) n (isreflnatleh n) i k\n               (gamma i j k s1 s2) f)\n\n\nset ( e := pbn n IHn ( pr1 X ) n (isreflnatleh n) i j k s1 s2 f  : paths ( restr n IHn (pr1 X) n (isreflnatleh n) i k (gamma i j k s1 s2) f ) ( restr n IHn (pr1 X) n (isreflnatleh n) i j s1\n              (restr n IHn (pr1 X) n (isreflnatleh n) j k s2 f) ) ) .  rewrite e .    \n\n*)\n\n\nDefinition SEMISIMPL ( n : nat ) : Intrec1 n .\nProof . induction n .\n\n(* n=0 *)  unfold Intrec1. split with UU . split with (fun X => fun i => fun c => fun j => ( stn (j+1) -> X )) .  exact ( fun X => fun i => fun c => fun j => fun k => fun f => fun phi => fun a => f (rl j k phi a ) ). \n\n(* n => Sn *) set ( SSn := SS n IHn ) . set (mapsfromsksn := mapsfromsks n IHn ) . set (restrn := restr n IHn ) .\n\nset ( SSSn := total2 ( fun Xn : SSn => forall f : mapsfromsksn Xn n (isreflnatleh n) ( S n ) , UU ) ) . split with SSSn . \n\nsplit with (fun X => fun i => fun c => fun j => mapsfromsksSn n IHn X i c j ) . \n\nintro. intro. intro. intro. intro.   unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc . apply restrn . \n\nintros. destruct f as [fn ff]. simpl in restrn .  change (pr1 IHn) with SSn in restrn . change (pr1 (pr2 IHn)) with mapsfromsksn in restrn.  split with (restrn (pr1 X) n (isreflnatleh n) j k s fn ).  \n\nintros . set ( s1 := gamma ( S n ) j k s0 s ) . set ( ffint := ff s1 ) . \n\nset ( fs1 := restrn (pr1 X) n (isreflnatleh n) (S n) k s1 fn ) . set (fs0s := restr n IHn (pr1 X) n (isreflnatleh n) (S n) j s0 (restrn (pr1 X) n (isreflnatleh n) j k s fn)). \n\nsimpl in fs1 . simpl in fs0s.\n\nassert ( e : paths (restrn (pr1 X) n (isreflnatleh n) (S n) k s1 fn) (restr n IHn (pr1 X) n (isreflnatleh n) (S n) j s0 (restrn (pr1 X) n (isreflnatleh n) j k s fn )) ).\n\n(* At this point the remaining goal is to prove a certain equality. This equlity will hold definitionally in TS (if I am not mistaken). *)\n\nCheck (restrn (pr1 X) n (isreflnatleh n) (S n) k s1 fn).\n\nAdmitted.\n\n\nDefinition SEMISIMPL0 : Intrec1 0.\nProof . unfold Intrec1. split with UU . split with (fun X => fun i => fun c => fun j => ( stn (j+1) -> X )) .  exact ( fun X => fun i => fun c => fun j => fun k => fun f => fun phi => fun a => f (rl j k phi a ) ). Defined.\n\nDefinition SEMISIMPL1 : Intrec1 1.\nProof.  set ( IHn := SEMISIMPL0 ) . set ( SSn := SS 0 IHn ) . set (mapsfromsksn := mapsfromsks 0 IHn ) . set (restrn := restr 0 IHn ) .\n\nset ( SSSn := total2 ( fun Xn : SSn => forall f : mapsfromsksn Xn 0 (isreflnatleh 0) ( S 0 ) , UU ) ) . split with SSSn . \nsplit with (fun X => fun i => fun c => fun j => mapsfromsksSn 0 IHn X i c j ) . \n\nintro. intro. intro. intro. intro.   unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc . apply restrn . \n\nintros. destruct f as [fn ff]. simpl in restrn .  change (pr1 IHn) with SSn in restrn . change (pr1 (pr2 IHn)) with mapsfromsksn in restrn.  split with (restrn (pr1 X) 0 (isreflnatleh 0) j k s fn).  \n\nintros . set ( s1 := gamma ( S 0 ) j k s0 s ) . set ( ffint := ff s1 ) . \n\nset ( fs1 := restrn (pr1 X) 0 (isreflnatleh 0) (S 0) k s1 fn) . set (fs0s := restr 0 IHn (pr1 X) 0 (isreflnatleh 0) (S 0) j s0 (restrn (pr1 X) 0 (isreflnatleh 0) j k s fn )). \n\nsimpl in fs1 . simpl in fs0s.\n\nassert ( e : paths (restrn (pr1 X) 0 (isreflnatleh 0) (S 0) k s1 fn) (restr 0 IHn (pr1 X) 0 (isreflnatleh 0) (S 0) j s0 (restrn (pr1 X) 0 (isreflnatleh 0) j k s fn ) ) ).\n\nsimpl.  unfold IHn. unfold restrn. unfold restr. unfold IHn .   unfold SEMISIMPL0.  simpl . apply funextfun . intro .  apply ( maponpaths fn ) . \n\nCheck (restrn (pr1 X) 0 (isreflnatleh 0) (S 0) k s1 fn).\n\n\n\n\n\n\n\n\n(* End of the file semisimplicial.v *)\n\n\n\n\n\n(* \n*** Local Variables: ***\n*** coq-prog-name: \"/opt/local/bin/coqtop\" ***\n*** coq-prog-args: (\"-emacs-U\") ***\n*** End: ***\n *)\n\n"
  },
  {
    "path": "Generalities/uu0.v",
    "content": "(** * Univalent Basics. Vladimir Voevodsky. Feb. 2010 - Sep. 2011. Port to coq trunk (8.4-8.5) in March 2014.  \n\nThis 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.  \n\n\n *) \n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *)\n\n(** Imports *)\n\nAdd LoadPath \"../../\".\n\nRequire Export Foundations.Generalities.uuu.\n\n(** Universe structure *)\n\nDefinition UU := Type .\n\n(* end of \"Preambule\". *)\n\n\n\n\n(** ** Some standard constructions not using identity types (paths) *)\n\n(** *** Canonical functions from [ empty ] and to [ unit ] *)\n\nDefinition fromempty { X : UU } : empty -> X.\nProof. intros X H.  destruct H. Defined. \n\nDefinition tounit { X : UU } : X -> unit := fun x : X => tt .\n\n(** *** Functions from [ unit ] corresponding to terms *)\n\nDefinition termfun { X : UU } ( x : X ) : unit -> X := fun t : unit => x .\n\n\n(** *** Identity functions and function composition *)\n\nDefinition idfun ( T : UU ) := fun t : T => t .\n\nDefinition funcomp { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) := fun x : X => g ( f x ) . \n\n(** *** Iteration of an endomorphism *)\n\nFixpoint iteration { T : UU } ( f : T -> T ) ( n : nat ) : T -> T := match n with \nO => idfun T |\nS m => funcomp ( iteration f m ) f \nend .\n\n\n(** ***  Basic constructions related to the adjoint evaluation function [ X -> ( ( X -> Y ) -> Y ) ] *)\n\nDefinition adjev { X Y : UU } ( x : X ) ( f : X -> Y ) : Y := f x.\n\nDefinition adjev2 { X Y : UU } ( phi : ( ( X -> Y ) -> Y ) -> Y ) : X -> Y  :=  (fun  x : X => phi ( fun f : X -> Y => f x ) ) .\n\n\n(** *** Pairwise direct products *)\n\nDefinition dirprod ( X Y : UU ) := total2 ( fun x : X => Y ) .\nDefinition dirprodpair { X Y : UU } := tpair ( fun x : X => Y ) .\n\nDefinition dirprodadj { X Y Z : UU } ( f : dirprod X Y -> Z ) : X -> Y -> Z :=  fun x : X => fun y : Y => f ( dirprodpair x y ) .\n\nDefinition 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' ) ) .  \n\nDefinition ddualand { X Y P : UU } (xp : ( X -> P ) -> P ) ( yp : ( Y -> P ) -> P ) : ( dirprod X Y -> P ) -> P.\nProof. 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 . \n\n(** *** Negation and double negation *)\n\n\nDefinition neg ( X : UU ) : UU := X -> empty.\n\nDefinition negf { X Y : UU } ( f : X -> Y ) : neg Y -> neg X := fun phi : Y -> empty => fun x : X => phi ( f x ) .\n\nDefinition dneg ( X : UU ) : UU := ( X -> empty ) -> empty .\n\nDefinition dnegf { X Y : UU } ( f : X -> Y ) : dneg X -> dneg Y := negf ( negf f ) .\n\nDefinition todneg ( X : UU ) : X -> dneg X := adjev .\n\nDefinition dnegnegtoneg { X : UU } : dneg ( neg X ) ->  neg X := adjev2  .\n\nLemma dneganddnegl1 { X Y : UU } ( dnx : dneg X ) ( dny : dneg Y ) : neg ( X -> neg Y ) .\nProof. intros. intro X2. assert ( X3 : dneg X -> neg Y ) . apply ( fun xx : dneg X => dnegnegtoneg ( dnegf X2 xx ) ) .  apply ( dny ( X3 dnx ) ) . Defined.\n\nDefinition dneganddnegimpldneg { X Y : UU } ( dnx : dneg X ) ( dny : dneg Y ) : dneg ( dirprod X Y ) := ddualand dnx dny. \n\n\n(** *** Logical equivalence *)\n\n\nDefinition logeq ( X Y : UU ) := dirprod ( X -> Y ) ( Y -> X ) .\nNotation \" X <-> Y \" := ( logeq X Y ) : type_scope .  \n\n\nDefinition logeqnegs { X Y : UU } ( l : X <-> Y ) : ( neg X ) <-> ( neg Y ) := dirprodpair ( negf ( pr2 l ) ) ( negf ( pr1 l ) ) . \n\n\n\n\n(* end of \"Some standard constructions not using idenity types (paths)\". *)\n\n\n\n\n\n\n(** ** Operations on [ paths ] *)\n\n\n\n(** *** Composition of paths and inverse paths *)\n\n \nDefinition pathscomp0 { X : UU } { a b c : X } ( e1 : paths a b ) ( e2 : paths b c ) : paths a c .\nProof. intros. destruct e1. apply e2 . Defined.\nHint Resolve @pathscomp0 : pathshints .\n\nDefinition pathscomp0rid { X : UU } { a b : X } ( e1 : paths a b ) : paths ( pathscomp0 e1 ( idpath b ) ) e1 . \nProof. intros. destruct e1. simpl. apply idpath.  Defined. \n\n(** 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 ] *)\n\nDefinition pathsinv0 { X : UU } { a b : X } ( e : paths a b ) : paths b a .\nProof. intros. destruct e.  apply idpath. Defined. \nHint Resolve @pathsinv0 : pathshints .\n\nDefinition pathsinv0l { X : UU } { a b : X } ( e : paths a b ) : paths ( pathscomp0 ( pathsinv0 e ) e ) ( idpath _ ) .\nProof. intros. destruct e.  apply idpath. Defined. \n\nDefinition pathsinv0r { X : UU } { a b : X } ( e : paths a b ) : paths ( pathscomp0 e ( pathsinv0 e ) ) ( idpath _ ) .\nProof. intros. destruct e.  apply idpath. Defined. \n\nDefinition pathsinv0inv0 { X : UU } { x x' : X } ( e : paths x x' ) : paths ( pathsinv0 ( pathsinv0 e ) ) e .\nProof. intros. destruct e. apply idpath. Defined.  \n\n\n\n(** *** Direct product of paths  *)\n\nDefinition 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 ) .\nProof . intros . destruct ex . destruct ey . apply idpath . Defined . \n\n\n(** *** The function [ maponpaths ] between paths types defined by a function between abmbient types and its behavior relative to [ pathscomp0 ] and [ pathsinv0 ] *)\n\nDefinition maponpaths { T1 T2 : UU } ( f : T1 -> T2 ) { t1 t2 : T1 } ( e: paths t1 t2 ) : paths ( f t1 ) ( f t2 ) .\nProof. intros .  destruct e . apply idpath. Defined. \n\nDefinition 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 ) ) .\nProof. intros.  destruct e1. destruct e2.  simpl. apply idpath. Defined. \n\nDefinition maponpathsinv0 { X Y : UU } ( f : X -> Y ) { x1 x2 : X } ( e : paths x1 x2 ) : paths ( maponpaths f ( pathsinv0 e ) ) ( pathsinv0 ( maponpaths f e ) ) .\nProof. intros . destruct e . apply idpath . Defined .  \n\n\n\n(** *** [ maponpaths ] for the identity functions and compositions of functions *)\n\nLemma maponpathsidfun { X : UU } { x x' : X } ( e : paths x x' ) : paths ( maponpaths ( idfun X ) e ) e . \nProof. intros. destruct e. apply idpath . Defined. \n\nLemma 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) .\nProof. intros. destruct e.  apply idpath. Defined. \n\n\n\n\n\n(** 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. *) \n\n\nDefinition 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'))).\n\n\nLemma 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')))).\nProof. 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 .  \nassert (eee: paths (idpath (f x)) (pathscomp0  (h x)  (pathsinv0 (h x)))). apply (pathsinv0  (pathsinv0r  (h x))). apply (pathscomp0   ee eee). Defined. \n\n\nLemma 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.\nProof. intros. destruct hx. destruct hx'. destruct e.  simpl. apply idpath. Defined. \n\n\nLemma 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.\nProof.  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. \n\n\n(** Here we consider the behavior of maponpaths in the case of a projection [ p ] with a section [ s ]. *)\n\n\n\nDefinition 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 ) .  \n\nDefinition 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'.\nProof. intros . set ( e' := pathssec1 s p eps _ _ e ) . apply ( pathscomp0 e' ( eps x' ) ) . Defined .\n\nDefinition 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 ) .\nProof. 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 \n(pathscomp0  (pathscomp0 (pathsinv0 (eps x)) (idpath (p (s x)))) (eps x)) \n(pathscomp0 (pathsinv0 (eps x)) (eps x))). \napply (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. \n\n\nDefinition 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.\nProof. intros. destruct e.  simpl. unfold pathssec2. unfold pathssec1.  simpl. apply pathssec2id.  Defined. \n\n\n(* end of \"Operations on [ paths ]\". *) \n\n\n\n\n\n\n\n\n\n(** ** Fibrations and paths *)\n\n\nDefinition tppr { T : UU } { P : T -> UU } ( x : total2 P ) : paths x ( tpair _ (pr1 x) (pr2 x) ) .\nProof. intros. destruct x. apply idpath. Defined. \n\nDefinition 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 ) ) ) . \nProof. 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. \n\nDefinition transportf { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : P x -> P x' := pr1 ( constr1 P e ) .\n\nDefinition transportb { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : P x' -> P x := transportf P ( pathsinv0 e ) .\n\n\nLemma 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 ) .\nProof.  intros.  destruct e. apply idpath. Defined.   \n\n\n\n\n(** ** First homotopy notions *)\n\n(** *** Homotopy between functions *)\n\n\nDefinition homot { X Y : UU } ( f g : X -> Y ) := forall x : X , paths ( f x ) ( g x ) .\n\n\n(** *** Contractibility, homotopy fibers etc. *)\n\n\n(** Contractible types. *)\n\nDefinition iscontr (T:UU) : UU := total2 (fun cntr:T => forall t:T, paths t cntr).\nDefinition iscontrpair { T : UU }  := tpair (fun cntr:T => forall t:T, paths t cntr).\nDefinition iscontrpr1 { T : UU } := @pr1 T ( fun cntr:T => forall t:T, paths t cntr ) .\n\nLemma iscontrretract { X Y : UU } ( p : X -> Y ) ( s : Y -> X ) ( eps : forall y : Y, paths ( p ( s y ) ) y  ) ( is : iscontr X ) : iscontr Y.\nProof . 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 .    \n\nLemma proofirrelevancecontr { X : UU }(is: iscontr X) ( x x' : X ): paths x x'.\nProof. intros. unfold iscontr in is.  destruct is as [ t x0 ]. set (e:= x0 x). set (e':= pathsinv0 (x0 x')). apply (pathscomp0 e e'). Defined. \n\n\n(** Coconuses - spaces of paths which begin or end at a given point. *)  \n\n\nDefinition coconustot ( T : UU ) ( t : T ) := total2 (fun t':T => paths t' t).\nDefinition coconustotpair ( T : UU ) { t t' : T } (e: paths t' t) : coconustot T t := tpair (fun t':T => paths t' t) t' e.\nDefinition coconustotpr1 ( T : UU ) ( t : T ) := @pr1 _ (fun t':T => paths t' t) . \n\nLemma connectedcoconustot { T : UU }  { t : T } ( c1 c2 : coconustot T t ) : paths c1 c2.\nProof. intros. destruct c1 as [ x0 x ]. destruct x. destruct c2 as [ x1 x ]. destruct x. apply idpath. Defined. \n\nLemma iscontrcoconustot ( T : UU ) (t:T) : iscontr (coconustot T t).\nProof. intros. unfold iscontr.  set (t0:= tpair (fun t':T => paths t' t) t (idpath t)).  split with t0. intros. apply  connectedcoconustot. Defined.\n\n\n\nDefinition coconusfromt ( T : UU ) (t:T) :=  total2 (fun t':T => paths t t').\nDefinition coconusfromtpair ( T : UU ) { t t' : T } (e: paths t t') : coconusfromt T t := tpair (fun t':T => paths t t') t' e.\nDefinition coconusfromtpr1 ( T : UU ) ( t : T ) := @pr1 _ (fun t':T => paths t t') .\n\nLemma connectedcoconusfromt { T : UU } { t : T } ( e1 e2 : coconusfromt T t ) : paths e1 e2.\nProof. intros. destruct e1 as [x0 x]. destruct x. destruct e2 as [ x1 x ]. destruct x. apply idpath. Defined.\n\nLemma iscontrcoconusfromt ( T : UU ) (t:T) : iscontr (coconusfromt T t).\nProof. intros. unfold iscontr.  set (t0:= tpair (fun t':T => paths t t') t (idpath t)).  split with t0. intros. apply  connectedcoconusfromt. Defined.\n\n(** Pathsspace of a type. *)\n\nDefinition pathsspace (T:UU) := total2 (fun t:T => coconusfromt T t).\nDefinition pathsspacetriple ( T : UU ) { t1 t2 : T } (e: paths t1 t2): pathsspace T := tpair _ t1 (coconusfromtpair T e). \n\nDefinition deltap ( T : UU ) : T -> pathsspace T := (fun t:T => pathsspacetriple T (idpath t)). \n\nDefinition pathsspace' ( T : UU ) := total2 (fun xy : dirprod T T => (match xy with tpair _ x y => paths x y end)).\n\n\n(** Homotopy fibers. *)\n\nDefinition hfiber { X Y : UU } (f:X -> Y) (y:Y) : UU := total2 (fun pointover:X => paths (f pointover) y). \nDefinition 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 .\nDefinition hfiberpr1 { X Y : UU } ( f : X -> Y ) ( y : Y ) := @pr1 _ (fun pointover:X => paths (f pointover) y) . \n\n\n\n(** Paths in homotopy fibers. *)\n\nLemma 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)).\nProof. intros. destruct e.  simpl. apply idpath. Defined. \n\nLemma 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 ) .\nProof . intros . destruct e .   apply idpath . Defined .\n\n\nLemma 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.\nProof. 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. \n\n\n(** Coconus of a function - the total space of the family of h-fibers. *)\n\nDefinition coconusf { X Y : UU } (f: X -> Y):= total2 (fun y:_ => hfiber f y).\nDefinition fromcoconusf { X Y : UU } (f: X -> Y) : coconusf  f -> X := fun yxe:_ => pr1  (pr2 yxe).\nDefinition tococonusf { X Y:UU } (f: X -> Y) : X -> coconusf  f := fun x:_ => tpair  _  (f x) (hfiberpair f x (idpath _ ) ).   \n\n\n(** Total spaces of families and homotopies *)\n\nDefinition famhomotfun { X : UU } { P Q : X -> UU } ( h : homot P Q ) ( xp : total2 P ) : total2 Q . \nProof . intros. destruct xp as [ x p ] . split with x .  destruct ( h x ) . apply p .  Defined.\n\nDefinition 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 ) .\nProof . intros .  intro xp .  destruct xp as [x p] . simpl . apply ( maponpaths ( fun q => tpair Q x q ) ) .  destruct ( H x ) . apply idpath .  Defined. \n\n\n\n\n\n\n\n\n\n\n\n(** ** Weak equivalences *)\n\n(** *** Basics *)\n\n\nDefinition isweq { X Y : UU } ( f : X -> Y) : UU := forall y:Y, iscontr (hfiber f y) .\n\nLemma idisweq (T:UU) : isweq (fun t:T => t).\nProof. intros. \nunfold isweq.\nintro y .\nassert (y0: hfiber (fun t : T => t) y). apply (tpair (fun pointover:T => paths ((fun t:T => t) pointover) y) y (idpath y)). \nsplit with y0. intro t.  \ndestruct y0 as [x0 e0].    destruct t as [x1 e1].  destruct  e0.  destruct e1.  apply idpath. Defined. \n\n\n\nDefinition weq ( X Y : UU )  : UU := total2 (fun f:X->Y => isweq f) .\nDefinition pr1weq ( X Y : UU):= @pr1 _ _ : weq X Y -> (X -> Y).\nCoercion pr1weq : weq >-> Funclass. \nDefinition weqpair { X Y : UU } (f:X-> Y) (is: isweq f) : weq X Y := tpair (fun f:X->Y => isweq f) f is. \nDefinition idweq (X:UU) : weq X X :=  tpair (fun f:X->X => isweq f) (fun x:X => x) ( idisweq X ) .\n\n\nDefinition isweqtoempty { X : UU } (f : X -> empty ) : isweq f.\nProof. intros. intro y.  apply (fromempty y). Defined. \n\nDefinition weqtoempty { X : UU } ( f : X -> empty )  := weqpair _ ( isweqtoempty f ) .\n\nLemma isweqtoempty2 { X Y : UU } ( f : X -> Y ) ( is : neg Y ) : isweq f .\nProof. intros . intro y . destruct ( is y ) . Defined . \n\nDefinition weqtoempty2 { X Y : UU } ( f : X -> Y ) ( is : neg Y ) := weqpair _ ( isweqtoempty2 f is ) .\n\nDefinition invmap { X Y : UU } ( w : weq X Y ) : Y -> X .\nProof. intros X Y w y . apply (pr1  (pr1  ( pr2 w y ))). Defined.\n\n\n(** 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. *)\n\n\n\nDefinition homotweqinvweq { T1 T2 : UU } ( w : weq T1 T2 ) : forall t2:T2, paths ( w ( invmap w t2 ) ) t2.\nProof. intros. unfold invmap. simpl. apply (pr2  (pr1 ( pr2 w t2 ) ) ) . Defined.\n\n\nDefinition homotinvweqweq0  { X Y : UU } ( w : weq X Y ) ( x : X ) : paths x ( invmap w ( w x ) ) .\nProof. intros. set (isfx:= ( pr2 w ( w x ) ) ). set (pr1fx:= @pr1 X (fun x':X => paths ( w x' ) ( w x ))).\nset (xe1:= (hfiberpair  w x (idpath ( w x)))). apply  (maponpaths pr1fx  (pr2 isfx xe1)). Defined.\n\nDefinition homotinvweqweq { X Y : UU } ( w : weq X Y )  ( x : X ) : paths (invmap w ( w x ) ) x := pathsinv0  (homotinvweqweq0 w x).\n\nLemma 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.\nProof. intros.  destruct e1. simpl. simpl in ee. assumption. Defined. \n\nDefinition homotweqinvweqweq { X Y : UU } ( w : weq X Y ) ( x : X ) : paths  (maponpaths w (homotinvweqweq w x)) (homotweqinvweq w ( w x)).\nProof. 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.\napply (diaglemma2 w (homotinvweqweq0 w x) ( homotweqinvweq w ( w x ) ) ee ). Defined.\n\n\nDefinition 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 ) _ _ .\n\nDefinition 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.\n\n\nDefinition 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 ) _ _ .\n\nDefinition 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).\n\n\nDefinition 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 ) _ .\n\nDefinition 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.  \nProof. 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 ). \nassert (e1: paths (maponpaths f  eee) e). \nassert (e2: paths (maponpaths g  (maponpaths f  eee)) (maponpaths g  e)). \nassert (e3: paths (maponpaths g  (maponpaths f  eee)) (maponpaths gf  eee)). apply maponpathscomp. \nassert (e4: paths (maponpaths gf eee) ee). apply maponpathshomid2. apply (pathscomp0   e3 e4). \nset (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 ). \nassert (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)). \nassert (X0: paths  (invmaponpathsweq w x x' (maponpaths f eee)) eee). apply (pathsweq3 w ). \nassert (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). \nassumption. Defined. \n\n\n\n\n\n\n\n\n\n\n(** *** Weak equivalences between contractible types (other implications are proved below) *)\n\n\n\nLemma iscontrweqb { X Y : UU } ( w : weq X Y ) ( is : iscontr Y ) : iscontr X.\nProof. intros . apply ( iscontrretract (invmap w ) w (homotinvweqweq w ) is ).  Defined. \n\n\n\n\n(** *** Functions between fibers defined by a path on the base are weak equivalences *)\n\n\n\n\n\n\nLemma isweqtransportf { X : UU } (P:X -> UU) { x x' : X } (e:paths x x'): isweq (transportf P e).\nProof. intros. destruct e. apply idisweq. Defined. \n\n\nLemma isweqtransportb { X : UU } (P:X -> UU) { x x' : X } (e:paths x x'): isweq (transportb P e).\nProof. intros. apply (isweqtransportf  _ (pathsinv0  e)). Defined. \n\n\n\n\n\n(** *** [ unit ] and contractibility *)\n\n(** [ unit ] is contractible (recall that [ tt ] is the name of the canonical term of the type [ unit ]). *)\n\nLemma unitl0: paths tt tt -> coconustot _ tt.\nProof. intros X. apply (coconustotpair _ X). Defined.\n\nLemma unitl1: coconustot _ tt -> paths tt tt.\nProof. intro X. destruct X as [ x t ]. destruct x.  assumption.  Defined.\n\nLemma unitl2: forall e: paths tt tt, paths  (unitl1 (unitl0 e)) e.\nProof. intros. unfold unitl0. simpl.  apply idpath.  Defined.\n\nLemma unitl3: forall e:paths tt tt, paths  e (idpath tt).\nProof. intros.\nassert (e0: paths (unitl0 (idpath tt)) (unitl0 e)). eapply connectedcoconustot.\nassert (e1:paths  (unitl1 (unitl0 (idpath tt))) (unitl1 (unitl0 e))).   apply (maponpaths  unitl1  e0).    \nassert (e2:  paths  (unitl1 (unitl0 e)) e). eapply unitl2.\nassert (e3: paths   (unitl1 (unitl0 (idpath tt))) (idpath tt)). eapply unitl2.\n destruct e1. clear e0. destruct e2. assumption.  Defined. \n\n\nTheorem iscontrunit: iscontr (unit).\nProof. assert (pp:forall x:unit, paths x tt). intros. destruct x. apply (idpath _).\napply (tpair (fun cntr:unit => forall t:unit, paths  t cntr) tt pp). Defined. \n\n\n(** [ paths ] in [ unit ] are contractible. *)\n\nTheorem iscontrpathsinunit ( x x' : unit ) : iscontr ( paths x x' ) .\nProof. intros . assert (c:paths x x'). destruct x. destruct x'. apply idpath.\nassert (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.  \n\n\n\n(**  A type [ T : UU ] is contractible if and only if [ T -> unit ] is a weak equivalence. *)\n\n\nLemma ifcontrthenunitl0 ( e1 e2 : paths tt tt ) : paths e1 e2.\nProof. intros. assert (e3: paths e1 (idpath tt) ). apply unitl3.\nassert (e4: paths e2 (idpath tt)). apply unitl3. destruct e3.  destruct e4. apply idpath. Defined. \n\n\nLemma isweqcontrtounit { T : UU } (is : iscontr T) : (isweq (fun t:T => tt)).\nProof. intros T X. unfold isweq. intro y. destruct y.\nassert (c: hfiber  (fun x:T => tt) tt). destruct X as [ t x0 ]. eapply (hfiberpair _ t (idpath tt)).\nassert (e: forall d: (hfiber (fun x:T => tt) tt), paths d c). intros. destruct c as [ t x] . destruct d as [ t0 x0 ]. \nassert (e': paths  x x0). apply ifcontrthenunitl0 .\nassert (e'': paths  t t0). destruct X as [t1 x1 ].\nassert (e''': paths t t1). apply x1.\nassert (e'''': paths t0 t1). apply x1. \ndestruct e''''. assumption.\ndestruct e''. destruct e'. apply idpath. apply (iscontrpair c e). Defined. \n\nDefinition weqcontrtounit { T : UU } ( is : iscontr T ) := weqpair _ ( isweqcontrtounit is ) . \n\nTheorem iscontrifweqtounit { X : UU } ( w : weq X unit ) : iscontr X.\nProof. intros X X0.  apply (iscontrweqb X0 ). apply iscontrunit. Defined. \n\n\n\n\n\n(** *** A homotopy equivalence is a weak equivalence *)\n\n\nDefinition 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 ) .\n\n\nLemma 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')). \nProof. intros.  destruct z0 as [ y e ]. \n\nassert (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. \n\nset (int1:=constr1 (fun y:Y => paths (g y) x0 ) eint). destruct int1 as [ t x ].\nset (int2:=hfiberpair  (fun x0 : X => g (f x0)) x0 (t e)).   split with int2.  apply x.  Defined. \n\n\nLemma 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).\nProof. 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)). \nset (efg1:= (fun y1:Y1 => pathsinv0 ( pr2  (constr2 f g efg x0 y1 ) ) ) ) .  simpl in efg1. apply ( iscontrretract  f1 g1 efg1). assumption.   Defined. \n\n\nLemma 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).\nProof. intros X Y f1 f2 h y X0. \n\nset (f:= (fun z:(hfiber  f1 y) =>\nmatch z with \n(tpair _ x e) => hfiberpair  f2 x (pathscomp0   (h x) e)\nend)). \n\nset (g:= (fun z:(hfiber  f2 y) =>\nmatch z with\n(tpair _ x e) => hfiberpair  f1 x (pathscomp0   (pathsinv0 (h x)) e)\nend)). \n\nassert (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 .\n\napply ( iscontrretract  g f egf X0). Defined.\n\nCorollary isweqhomot { X Y : UU } ( f1 f2 : X-> Y ) (h: forall x:X, paths (f1 x) (f2 x)): isweq f1 -> isweq f2.\nProof. intros X Y f1 f2 h X0. unfold isweq. intro y. set (Y0:= X0 y).  apply (iscontrhfiberl2  f2 f1 h). assumption. Defined. \n\n\n\nTheorem 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.\nProof. intros.  unfold isweq.  intro z. \nassert (iscontr (hfiber  (fun y:Y => (f (g y))) z)). \nassert (efg': forall y:Y, paths y (f (g y))). intros. set (e1:= efg y). apply pathsinv0. assumption. \napply (iscontrhfiberl2  (fun y:Y => (f (g y)))  (fun  y:Y => y)  efg' z (idisweq Y z)). \napply (iscontrhfiberl1  g f egf z). assumption. \nDefined.\n\nDefinition 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 ) . \n \n\n\n(** *** Some basic weak equivalences *)\n\n\n\nCorollary isweqinvmap { X Y : UU } ( w : weq X Y ) : isweq (invmap w ).\nProof. intros. set (invf:= invmap w ). assert (efinvf: forall y:Y, paths ( w (invf y)) y). apply homotweqinvweq. \nassert (einvff: forall x:X, paths (invf ( w x)) x). apply homotinvweqweq. apply ( gradth _ _ efinvf einvff ) . Defined. \n\nDefinition invweq { X Y : UU } ( w : weq X Y ) : weq Y X := weqpair  (invmap w ) (isweqinvmap w ).\n\nCorollary invinv { X Y :UU } ( w : weq X Y ) ( x : X ) : paths  ( invweq ( invweq w ) x) (w x).\nProof. intros. unfold invweq . unfold invmap . simpl . apply idpath . Defined .  \n\n\nCorollary iscontrweqf { X Y : UU } ( w : weq X Y ) : iscontr X -> iscontr Y.\nProof. intros X Y w X0 . apply (iscontrweqb ( invweq w ) ). assumption. Defined.\n\n(** The standard weak equivalence from [ unit ] to a contractible type *)\n\nDefinition wequnittocontr { X : UU } ( is : iscontr X ) : weq unit X .\nProof . intros . set ( f := fun t : unit => pr1 is ) . set ( g := fun x : X => tt ) . split with f .\nassert ( egf : forall a : _ , paths ( g ( f a )) a ) . intro .  destruct a . apply idpath . \nassert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro . simpl .  apply ( pathsinv0 ( pr2 is a ) ) .  \napply ( gradth _ _ egf efg ) . Defined . \n\n\n(** A weak equivalence bwteen types defines weak equivalences on the corresponding [ paths ] types. *)\n\n\nCorollary isweqmaponpaths { X Y : UU } ( w : weq X Y ) ( x x' : X ) : isweq (@maponpaths _ _ w x x').\nProof. intros. apply (gradth  (@maponpaths _ _ w x x') (@invmaponpathsweq _ _ w x x') (@pathsweq3 _ _ w x x')  (@pathsweq4 _ _ w x x')). Defined.  \n\nDefinition weqonpaths { X Y : UU } ( w : weq X Y ) ( x x' : X ) := weqpair _ ( isweqmaponpaths w x x' ) .\n\n\nCorollary isweqpathsinv0 { X : UU } (x x':X): isweq (@pathsinv0 _ x x').\nProof. intros.  apply (gradth  (@pathsinv0 _ x x') (@pathsinv0 _ x' x) (@pathsinv0inv0 _ _ _  ) (@pathsinv0inv0  _ _ _ )). Defined.\n\nDefinition weqpathsinv0 { X : UU } ( x x' : X ) := weqpair _ ( isweqpathsinv0 x x' ) .\n\nCorollary isweqpathscomp0r { X : UU } (x : X ) { x' x'' : X } (e': paths x' x''): isweq (fun e:paths x x' => pathscomp0   e e').\nProof. intros. set (f:= fun e:paths x x' => pathscomp0   e e'). set (g:= fun e'': paths x x'' => pathscomp0   e'' (pathsinv0 e')). \nassert (egf: forall e:_ , paths (g (f e)) e).   intro. destruct e.  simpl. destruct e'.  simpl.  apply idpath.\nassert (efg: forall e'':_, paths (f (g e'')) e''). intro. destruct e''. simpl. destruct e'. simpl.   apply idpath. \napply (gradth  f g egf efg). Defined. \n\n\nCorollary isweqtococonusf { X Y : UU } (f:X-> Y): isweq ( tococonusf  f) .\nProof . intros. set (ff:= fromcoconusf  f). set (gg:= tococonusf  f).\nassert (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.  \nassert (efg: forall x:_, paths (ff (gg x)) x). intro. apply idpath.\napply (gradth _ _ efg egf ). Defined.\n\nDefinition weqtococonusf { X Y : UU } ( f : X -> Y ) : weq X ( coconusf f ) := weqpair _ ( isweqtococonusf f ) .\n\n\nCorollary  isweqfromcoconusf { X Y : UU } (f:X-> Y): isweq (fromcoconusf  f).\nProof. intros. set (ff:= fromcoconusf  f). set (gg:= tococonusf  f).\nassert (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.  \nassert (efg: forall x:_, paths (ff (gg x)) x). intro. apply idpath.\napply (gradth _ _ egf efg). Defined.\n\nDefinition weqfromcoconusf { X Y : UU } ( f : X -> Y ) : weq ( coconusf f ) X := weqpair _ ( isweqfromcoconusf f ) .\n\nCorollary isweqdeltap (T:UU) : isweq (deltap T).\nProof. intros. set (ff:=deltap T). set (gg:= fun z:pathsspace T => pr1  z). \nassert (egf: forall t:T, paths (gg (ff t)) t). intro. apply idpath.\nassert (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. \napply (gradth _ _ egf efg). Defined. \n\n\nCorollary isweqpr1pr1 (T:UU) : isweq (fun a: pathsspace' T => (pr1  (pr1  a))).\nProof. 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). \nassert (efg: forall t:T, paths (f (g t)) t). intro. apply idpath. \nassert (egf: forall a: pathsspace' T, paths (g (f a)) a). intro. destruct a as [ t x ].  destruct t. destruct x.   simpl. apply idpath. \napply (gradth _ _  egf efg). Defined. \n\n\nLemma 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 .\nProof. intros X Y f g h y xe .  destruct xe as [ x e ] .  split with x .  apply ( pathscomp0 ( pathsinv0 ( h x ) ) e  ) . Defined .\n\n\nLemma 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 .\nProof. intros X Y f g h y xe .  destruct xe as [ x e ] .  split with x .  apply ( pathscomp0  ( h x ) e  ) . Defined .\n\n\nTheorem 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 ) .\nProof . intros . set ( ff := hfibershomotftog f g h y ) . set ( gg :=  hfibershomotgtof f g h y ) .  split with ff .\nassert ( effgg : forall xe : _ , paths ( ff ( gg xe ) ) xe ) . intro . destruct xe as [ x e ] . simpl . \nassert ( 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 . \nset ( 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 ) .  \nassert ( eggff : forall xe : _ , paths ( gg ( ff xe ) ) xe ) . intro . destruct xe as [ x e ] . simpl .\nassert ( 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 . \nset ( 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 ) .  \napply ( gradth _ _ eggff effgg ) . Defined .\n\n\n\n\n\n(** *** The 2-out-of-3 property of weak equivalences.\n\nTheorems 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. *)\n\n\n\n\n\nTheorem twooutof3a { X Y Z : UU } (f:X->Y) (g:Y->Z) (isgf: isweq (fun x:X => g (f x))) (isg: isweq g) : isweq f.\nProof. 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))). \n\nassert (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). \n\nassert (einvff: forall x: X, paths (invf (f x)) x). intro. unfold invf. apply (homotinvweqweq gfw x).\n\napply (gradth  f invf einvff efinvf).  Defined.\n\n\nCorollary isweqcontrcontr { X Y : UU } (f:X -> Y) (isx: iscontr X) (isy: iscontr Y): isweq f.\nProof. intros. set (py:= (fun y:Y => tt)). apply (twooutof3a f py (isweqcontrtounit isx) (isweqcontrtounit isy)). Defined. \n\nDefinition weqcontrcontr { X Y : UU } ( isx : iscontr X) (isy: iscontr Y) := weqpair _ ( isweqcontrcontr ( fun x : X => pr1 isy ) isx isy ) . \n\nTheorem twooutof3b { X Y Z : UU } (f:X->Y) (g:Y->Z) (isf: isweq f) (isgf: isweq (fun x:X => g(f x))) : isweq g.\nProof. 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))). \n\nassert (eginvg: forall z:Z, paths (g (invg z)) z). intro. apply (homotweqinvweq wgf z).  \n\nassert (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.\n\n\n\nLemma isweql3 { X Y : UU } (f:X-> Y) (g:Y->X) (egf: forall x:X, paths (g (f x)) x): isweq f -> isweq g.\nProof. 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. \n\nTheorem twooutof3c { X Y Z : UU } (f:X->Y) (g:Y->Z) (isf: isweq f) (isg: isweq g) : isweq  (fun x:X => g(f x)).\nProof. 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. \nassert (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. \n\n\nDefinition 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)). \n\n\n\n(** *** Associativity of [ total2 ]  *)\n\nLemma 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 ) ) ) .\nProof. intros X P Q xpq .  destruct xpq as [ xp q ] . destruct xp as [ x p ] . split with x . split with p . assumption . Defined .\n\nLemma 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 .\nProof. intros X P Q xpq .  destruct xpq as [ x pq ] . destruct pq as [ p q ] . split with ( tpair P x p ) . assumption . Defined .\n\n\nTheorem 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 ) ) ) ).\nProof. intros . set ( f := total2asstor P Q ) . set ( g:= total2asstol P Q ) .  split with f .\nassert ( egf : forall xpq : _ , paths ( g ( f xpq ) ) xpq ) . intro . destruct xpq as [ xp q ] . destruct xp as [ x p ] . apply idpath . \nassert ( efg : forall xpq : _ , paths ( f ( g xpq ) ) xpq ) . intro . destruct xpq as [ x pq ] . destruct pq as [ p q ] . apply idpath .\napply ( gradth _ _ egf efg ) . Defined.\n\nDefinition 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 ) .\n\n\n\n(** *** Associativity and commutativity of [ dirprod ] *) \n\nDefinition weqdirprodasstor ( X Y Z : UU ) : weq ( dirprod ( dirprod X Y ) Z ) ( dirprod X ( dirprod Y Z ) ) .\nProof . intros . apply weqtotal2asstor . Defined . \n\nDefinition weqdirprodasstol ( X Y Z : UU ) : weq  ( dirprod X ( dirprod Y Z ) ) ( dirprod ( dirprod X Y ) Z ) := invweq ( weqdirprodasstor X Y Z ) .\n\nDefinition weqdirprodcomm ( X Y : UU ) : weq ( dirprod X Y ) ( dirprod Y X ) .\nProof. 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 ) ) .\nassert ( egf : forall xy : _ , paths ( g ( f xy ) ) xy ) . intro . destruct xy . apply idpath .\nassert ( efg : forall yx : _ , paths ( f ( g yx ) ) yx ) . intro . destruct yx . apply idpath .\nsplit with f . apply ( gradth _ _ egf  efg ) . Defined . \n \n\n\n\n\n\n(** *** Coproducts and direct products *)\n\n\nDefinition rdistrtocoprod ( X Y Z : UU ): dirprod X (coprod Y Z) -> coprod (dirprod X Y) (dirprod X Z).\nProof. 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.\n\n\nDefinition rdistrtoprod (X Y Z:UU): coprod (dirprod X Y) (dirprod X Z) ->  dirprod X (coprod Y Z).\nProof. 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. \n\n\nTheorem isweqrdistrtoprod (X Y Z:UU): isweq (rdistrtoprod X Y Z).\nProof. intros. set (f:= rdistrtoprod X Y Z). set (g:= rdistrtocoprod X Y Z). \nassert (egf: forall a:_, paths (g (f a)) a).  intro. destruct a as [ d | d ] . destruct d. apply idpath. destruct d. apply idpath. \nassert (efg: forall a:_, paths (f (g a)) a). intro. destruct a as [ t x ]. destruct x.  apply idpath. apply idpath.\napply (gradth  f g egf efg). Defined.\n\nDefinition weqrdistrtoprod (X Y Z: UU):= weqpair  _ (isweqrdistrtoprod X Y Z).\n\nCorollary isweqrdistrtocoprod (X Y Z:UU): isweq (rdistrtocoprod X Y Z).\nProof. intros. apply (isweqinvmap ( weqrdistrtoprod X Y Z  ) ) . Defined.\n\nDefinition weqrdistrtocoprod (X Y Z: UU):= weqpair  _ (isweqrdistrtocoprod X Y Z).\n \n\n\n(** *** Total space of a family over a coproduct *)\n\n\nDefinition 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 ) ) ) .\nProof. 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 .\n\nDefinition 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 .\nProof . 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 . \n \nTheorem 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 ) ) ) ) .\nProof. intros .  set ( f := fromtotal2overcoprod P ) . set ( g := tototal2overcoprod P ) . split with f . \nassert ( 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 .     \nassert ( 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 .\napply ( gradth _ _ egf efg ) . Defined . \n\n\n\n(** *** Weak equivalences and pairwise direct products *)\n\n\nTheorem isweqdirprodf { X Y X' Y' : UU } ( w : weq X Y )( w' : weq X' Y' ) : isweq (dirprodf w w' ).\nProof. intros. set ( f := dirprodf w w' ) . set ( g := dirprodf ( invweq w ) ( invweq w' ) ) . \nassert ( 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' ) . \nassert ( 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' ) .\napply ( gradth _ _ egf efg ) . Defined .   \n\nDefinition weqdirprodf { X Y X' Y' : UU } ( w : weq X Y ) ( w' : weq X' Y' ) := weqpair _ ( isweqdirprodf w w' ) .\n\nDefinition weqtodirprodwithunit (X:UU): weq X (dirprod X unit).\nProof. intros. set (f:=fun x:X => dirprodpair x tt). split with f.  set (g:= fun xu:dirprod X unit => pr1  xu). \nassert (egf: forall x:X, paths (g (f x)) x). intro. apply idpath.\nassert (efg: forall xu:_, paths (f (g xu)) xu). intro. destruct xu as  [ t x ]. destruct x. apply idpath.    \napply (gradth  f g egf efg). Defined.\n\n\n\n\n(** *** Basics on pairwise coproducts (disjoint unions)  *)\n\n\n\n(** In the current version [ coprod ] is a notation, introduced in uuu.v for [ sum ] of types which is defined in Coq.Init *)\n\n\n\nDefinition 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.\n\n\nDefinition boolascoprod: weq (coprod unit unit) bool.\nProof. set (f:= fun xx: coprod unit unit => match xx with ii1 t => true | ii2 t => false end). split with f. \nset (g:= fun t:bool => match t with true => ii1  tt | false => ii2  tt end). \nassert (egf: forall xx:_, paths (g (f xx)) xx). intro xx .  destruct xx as [ u | u ] . destruct u. apply idpath. destruct u. apply idpath. \nassert (efg: forall t:_, paths (f (g t)) t). destruct t. apply idpath. apply idpath. \napply (gradth  f g egf efg). Defined.  \n\n\nDefinition coprodasstor (X Y Z:UU): coprod (coprod X Y) Z -> coprod X (coprod Y Z).\nProof. 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.\n\nDefinition coprodasstol (X Y Z: UU): coprod X (coprod Y Z) -> coprod (coprod X Y) Z.\nProof. 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.\n\nTheorem isweqcoprodasstor (X Y Z:UU): isweq (coprodasstor X Y Z).\nProof. intros. set (f:= coprodasstor X Y Z). set (g:= coprodasstol X Y Z).\nassert (egf: forall xyz:_, paths (g (f xyz)) xyz). intro xyz. destruct xyz as [ c | z ] .  destruct c. apply idpath. apply idpath. apply idpath. \nassert (efg: forall xyz:_, paths (f (g xyz)) xyz). intro xyz.  destruct xyz as [ x | c ] .  apply idpath.  destruct c. apply idpath. apply idpath.\napply (gradth  f g egf efg). Defined. \n\nDefinition weqcoprodasstor ( X Y Z : UU ) := weqpair _ ( isweqcoprodasstor X Y Z ) .\n\nCorollary isweqcoprodasstol (X Y Z:UU): isweq (coprodasstol X Y Z).\nProof. intros. apply (isweqinvmap ( weqcoprodasstor X Y Z)  ). Defined.\n\nDefinition weqcoprodasstol (X Y Z:UU):= weqpair  _ (isweqcoprodasstol X Y Z).\n\nDefinition coprodcomm (X Y:UU): coprod X Y -> coprod Y X := fun xy:_ => match xy with ii1 x => ii2  x | ii2 y => ii1  y end. \n\nTheorem isweqcoprodcomm (X Y:UU): isweq (coprodcomm X Y).\nProof. intros. set (f:= coprodcomm X Y). set (g:= coprodcomm Y X).\nassert (egf: forall xy:_, paths (g (f xy)) xy). intro. destruct xy. apply idpath. apply idpath.\nassert (efg: forall yx:_, paths (f (g yx)) yx). intro. destruct yx. apply idpath. apply idpath.\napply (gradth  f g egf efg). Defined. \n\nDefinition weqcoprodcomm (X Y:UU):= weqpair  _ (isweqcoprodcomm X Y). \n\nTheorem isweqii1withneg  (X : UU) { Y : UU } (nf:Y -> empty): isweq (@ii1 X Y).\nProof. 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).  \nassert (egf: forall x:X, paths (g (f x)) x). intro. apply idpath. \nassert (efg: forall xy: coprod X Y, paths (f (g xy)) xy). intro. destruct xy as [ x | y ] . apply idpath. apply (fromempty (nf y)).  \napply (gradth  f g egf efg). Defined.  \n\nDefinition weqii1withneg ( X : UU ) { Y : UU } ( nf : neg Y ) := weqpair _ ( isweqii1withneg X nf ) .\n\nTheorem isweqii2withneg  { X  : UU } ( Y : UU ) (nf : X -> empty): isweq (@ii2 X Y).\nProof. 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).  \nassert (egf: forall y : Y, paths (g (f y)) y). intro. apply idpath. \nassert (efg: forall xy: coprod X Y, paths (f (g xy)) xy). intro. destruct xy as [ x | y ] . apply (fromempty (nf x)).  apply idpath. \napply (gradth  f g egf efg). Defined.  \n\nDefinition weqii2withneg { X : UU } ( Y : UU ) ( nf : neg X ) := weqpair _ ( isweqii2withneg Y nf ) .\n\n\n\nDefinition coprodf { X Y X' Y' : UU } (f: X -> X')(g: Y-> Y'): coprod X Y -> coprod X' Y' := fun xy: coprod X Y =>\nmatch xy with\nii1 x => ii1  (f x)|\nii2 y => ii2  (g y)\nend. \n\n\nDefinition 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' ) ) .\nProof. intros . intro xx' . destruct xx' as [ x | x' ] . apply idpath . apply idpath . Defined .  \n\n\nDefinition 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  .\n\n\nTheorem isweqcoprodf { X Y X' Y' : UU } ( w : weq X X' )( w' : weq Y Y' ) : isweq (coprodf w w' ).\nProof. intros. set (finv:= invmap w ). set (ginv:= invmap w' ). set (ff:=coprodf w w' ). set (gg:=coprodf   finv ginv). \nassert (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)).\nassert (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)). \napply (gradth  ff gg egf efg). Defined. \n\n\nDefinition 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 ) .\n\n\nLemma negpathsii1ii2 { X Y : UU } (x:X)(y:Y): neg (paths (ii1  x) (ii2  y)).\nProof. 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.\n\nLemma negpathsii2ii1 { X Y : UU } (x:X)(y:Y): neg (paths (ii2  y) (ii1  x)).\nProof. 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.\n\n\n\n\n\n\n\n(** *** Fibrations with only one non-empty fiber. \n\nTheorem saying that if a fibration has only one non-empty fiber then the total space is weakly equivalent to this fiber. *)\n\n\n\nTheorem 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).\nProof. intros.  \n\nset (f:= fun p: P x => tpair _ x p). \n\nset (cx := c x). \nset (cnew:=  fun x':X  =>\nmatch cx with \nii1 x0 =>\nmatch c x' with \nii1 ee => ii1  (pathscomp0   (pathsinv0  x0) ee)|\nii2 phi => ii2  phi\nend |\nii2 phi => c x'\nend).\n\nset (g:= fun pp: total2 P => \nmatch (cnew (pr1  pp)) with\nii1 e => transportb P  e (pr2  pp) |\nii2 phi =>  fromempty (phi (pr2  pp))\nend).\n\n\nassert (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). \n\n \nset (cnewx:= cnew x). \nassert (e1: paths (cnew x) cnewx). apply idpath. \nunfold cnew in cnewx. change (c x) with cx in cnewx.  \ndestruct cx as [ x0 | e0 ].  \nassert (e: paths (cnewx) (ii1  (idpath x))).  apply (maponpaths (@ii1 (paths x x) (P x -> empty))  (pathsinv0l x0)). \n\n\n\n\nassert (egf: forall p: P x, paths (g (f p)) p).  intro. simpl in g. unfold g.  unfold f.   simpl.   \n\nset (ff:= fun cc:coprod (paths x x) (P x -> empty) => \nmatch cc with\n     | ii1 e0 => transportb P e0 p\n     | ii2 phi => fromempty  (phi p)\n     end).\nassert (ee: paths (ff (cnewx)) (ff (@ii1 (paths x x) (P x -> empty) (idpath x)))).  apply (maponpaths ff  e). \nassert (eee: paths  (ff (@ii1 (paths x x) (P x -> empty) (idpath x))) p). apply idpath.  fold (ff (cnew x)). \nassert (e2: paths (ff (cnew x)) (ff cnewx)). apply (maponpaths ff  e1). \napply (pathscomp0   (pathscomp0   e2 ee) eee).\napply (gradth  f g egf efg).\n\nunfold isweq.  intro y0. destruct (e0 (g y0)). Defined.\n\n\n\n\n\n(** *** Pairwise coproducts as dependent sums of families over [ bool ] *)\n\n\nFixpoint coprodtobool { X Y : UU } ( xy : coprod X Y ) : bool :=\nmatch xy with\nii1 x => true|\nii2 y => false\nend.\n \n\nDefinition boolsumfun (X Y:UU) : bool -> UU := fun t:_ => \nmatch t with\ntrue => X|\nfalse => Y\nend.\n\nDefinition coprodtoboolsum ( X Y : UU ) : coprod X Y -> total2 (boolsumfun X Y) := fun xy : _ =>\nmatch xy with\nii1 x => tpair (boolsumfun X Y) true x|\nii2 y => tpair (boolsumfun X Y) false y\nend .\n\n\nDefinition boolsumtocoprod (X Y:UU): (total2 (boolsumfun X Y)) -> coprod X Y := (fun xy:_ =>\nmatch xy with \ntpair _ true x => ii1  x|\ntpair _ false y => ii2  y\nend).\n\n\n\nTheorem isweqcoprodtoboolsum (X Y:UU): isweq (coprodtoboolsum X Y).\nProof. intros. set (f:= coprodtoboolsum X Y). set (g:= boolsumtocoprod X Y). \nassert (egf: forall xy: coprod X Y , paths (g (f xy)) xy). destruct xy. apply idpath. apply idpath. \nassert (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.\n\nDefinition weqcoprodtoboolsum ( X Y : UU ) := weqpair _ ( isweqcoprodtoboolsum X Y ) .\n\nCorollary isweqboolsumtocoprod (X Y:UU): isweq (boolsumtocoprod X Y ).\nProof. intros. apply (isweqinvmap ( weqcoprodtoboolsum X Y ) ) . Defined.\n\nDefinition weqboolsumtocoprod ( X Y : UU ) := weqpair _ ( isweqboolsumtocoprod X Y ) .\n\n\n\n\n\n\n\n\n(** *** Splitting of [ X ] into a coproduct defined by a function [ X -> coprod Y Z ] *)\n\n\nDefinition 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 ) ) ) ) .\nProof . intros . set ( w1 := weqtococonusf f ) .  set ( w2 := weqtotal2overcoprod ( fun yz : coprod Y Z => hfiber f yz ) ) . apply ( weqcomp w1 w2 ) .  Defined . \n\n\n\n(** *** Some properties of [ bool ] *)\n\nDefinition boolchoice ( x : bool ) : coprod ( paths x true ) ( paths x false ) .\nProof. intro . destruct x . apply ( ii1 ( idpath _ ) ) .  apply ( ii2 ( idpath _ ) ) . Defined . \n\nDefinition curry :  bool -> UU := fun x : bool =>\nmatch x  with\nfalse => empty|\ntrue => unit\nend.\n\n\nTheorem nopathstruetofalse: paths true false -> empty.\nProof. intro X.  apply (transportf curry  X tt).  Defined.\n\nCorollary nopathsfalsetotrue: paths false true -> empty.\nProof. intro X. apply (transportb curry  X tt). Defined. \n\nDefinition truetonegfalse ( x : bool ) : paths x true -> neg ( paths x false ) .\nProof . intros x e . rewrite e . unfold neg . apply nopathstruetofalse . Defined . \n\nDefinition falsetonegtrue ( x : bool ) : paths x false -> neg ( paths x true ) .\nProof . intros x e . rewrite e . unfold neg . apply nopathsfalsetotrue . Defined .  \n\nDefinition negtruetofalse (x : bool ) : neg ( paths x true ) -> paths x false .\nProof. intros x ne. destruct (boolchoice x) as [t | f]. destruct (ne t). apply f. Defined. \n\nDefinition negfalsetotrue ( x : bool ) : neg ( paths x false ) -> paths x true . \nProof. intros x ne . destruct (boolchoice x) as [t | f].  apply t . destruct (ne f) . Defined. \n\n\n\n\n\n\n\n\n\n\n\n(** ** Basics about fibration sequences. *)\n\n\n\n(** *** Fibrations sequences and their first \"left shifts\". \n\nThe group of constructions related to fibration sequences forms one of the most important computational toolboxes of homotopy theory .   \n\nGiven 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 ) ].\n\nA 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.  \n\nThe 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.  \n\nThere are three important special cases in which fibration sequences arise:\n\n( 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 ].\n\n( 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 ].\n\n( 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.    \n\n\n*)\n\n\n(** The structure of a complex structure on a composable pair of functions [ ( f : X -> Y ) ( g : Y -> Z ) ] relative to a term [ z : Z ]. *) \n\nDefinition complxstr  { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) := forall x:X, paths (g (f x)) z .\n\n \n\n(** The structure of a fibration sequence on a complex. *)\n\nDefinition 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).\n\nDefinition isfibseq { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) (ez : complxstr f g z ) := isweq (ezmap f g z ez). \n\nDefinition 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 ) .\nDefinition 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 ) .\nDefinition 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 ) .\nCoercion fibseqstrtocomplxstr : fibseqstr >-> complxstr . \n\nDefinition 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 ) . \n\n\n\n(** Construction of the derived fibration sequence. *)\n\n\nDefinition 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 ) .\n\nDefinition 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  .\nProof . 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 .      \n\nDefinition 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 :=  \nfun xe: hfiber  f y =>\nmatch xe with\ntpair _ x e => pathscomp0 (maponpaths g  ( pathsinv0 e ) ) ( ez x )\nend.\n\nTheorem 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 ) .\nProof . intros . set ( ff := ezmap1 f g z fs y ) . set ( gg := invezmap1 f g z ( pr1 fs ) y ) . \nassert ( egf : forall e : _ , paths ( gg ( ff e ) ) e ) . intro .  simpl . apply ( hfibertriangle1inv0 g (homotweqinvweq (ezweq f g z fs) (hfiberpair g y e)) ) . \nassert ( 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 ) . \napply ( gradth _ _ egf efg ) . Defined . \n\nDefinition 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 ) . \nDefinition 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 ) . \n\n\n\n(** Explitcit description of the first map in the second derived sequence. *)\n\nDefinition 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 ) . \nDefinition 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.\nDefinition 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 ) .\n\n\n\n\n\n(** *** Fibration sequences based on [ ( tpair P z : P z -> total2 P ) ( pr1 : total2 P -> Z ) ] (  the \"pr1-case\" )    *) \n\n\n\n(** Construction of the fibration sequence. *)\n\nDefinition 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 ).\n\nDefinition invezmappr1 { Z : UU } ( P : Z -> UU) ( z : Z ) : hfiber ( @pr1 Z P ) z  -> P z := fun te  : hfiber ( @pr1 Z P ) z =>\nmatch te with \ntpair _ t e => transportf P e ( pr2 t ) \nend.\n\nDefinition isweqezmappr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : isweq ( ezmappr1 P z ).\nProof. intros. \nassert ( egf : forall x: P z , paths (invezmappr1 _ z ((ezmappr1 P z ) x)) x). intro. unfold ezmappr1. unfold invezmappr1. simpl. apply idpath. \nassert ( 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. \napply (gradth _ _ egf efg ). Defined. \n\nDefinition ezweqpr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) := weqpair _ ( isweqezmappr1 P z ) .\n\nLemma 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 ).\nProof. intros. unfold isfibseq. unfold ezmap.  apply isweqezmappr1. Defined.\n\nDefinition fibseqpr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : fibseqstr (fun p : P z => tpair _ z p) ( @pr1 Z P ) z := fibseqstrpair _ _ _ _ ( isfibseqpr1 P z ) .\n\n\n(** The main weak equivalence defined by the first derived of [ fibseqpr1 ]. *)\n\nDefinition 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 .   \n\n\n\n\n\n\n\n(** *** Fibration sequences based on [ ( hfiberpr1 : hfiber g z -> Y ) ( g : Y -> Z ) ] (the \"g-case\")  *)\n\n\nTheorem isfibseqg { Y Z : UU } (g:Y -> Z) (z:Z) : isfibseq  (hfiberpr1  g z) g z (fun ye: _ => pr2  ye).\nProof. 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.\n\nDefinition ezweqg { Y Z : UU } (g:Y -> Z) (z:Z) := weqpair _ ( isfibseqg g z ) .\nDefinition fibseqg { Y Z : UU } (g:Y -> Z) (z:Z) : fibseqstr (hfiberpr1  g z) g z := fibseqstrpair _ _ _ _ ( isfibseqg g z ) . \n\n\n(** The first derived of [ fibseqg ].  *)\n\nDefinition d1g  { Y Z : UU} ( g : Y -> Z ) ( z : Z ) ( y : Y ) : paths ( g y ) z -> hfiber g z := hfiberpair g y . \n\n(** note that [ d1g ] coincides with [ d1 _ _ _ ( fibseqg g z ) ] which makes the following two definitions possible. *)\n\nDefinition 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) .\nDefinition 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) . \n\n\n(** The second derived of [ fibseqg ]. *) \n\nDefinition 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' ) .\n\n(** note that [ d2g ] coincides with [ d2 _ _ _ ( fibseqg g z ) ] which makes the following two definitions possible. *)\n\nDefinition 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 ) _ _ .\nDefinition 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 ) _ _ . \n\n\n(** The third derived of [ fibseqg ] and an explicit description of the corresponding first map. *)\n\nDefinition 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 . \n\nLemma 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 ) ) .\nProof. intros. unfold d3g . unfold d2 .  simpl .  apply pathscomp0rid. Defined .  \n\nDefinition 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 . \nDefinition 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 .\n\n\n\n\n\n(** *** Fibration sequence of h-fibers defined by a composable pair of functions (the \"hf-case\") \n\nWe 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 ) ]. *) \n\n\n\n\nDefinition 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 .\nProof . intros . split with ( pr1 xe ) .  apply ( pathscomp0 ( maponpaths g ( pr2 xe ) ) ( pr2 ye ) ) .  Defined .  \n\n\n\nDefinition 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 .\nProof . 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 . \n\nDefinition 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 ) .\nProof . intros .  split with ( pr1 ( pr1 xee' ) ) .  apply ( maponpaths ( hfiberpr1 _ _ ) ( pr2 xee' ) ) . Defined . \n\nDefinition 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 .\nProof . 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 .\n\nDefinition 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' .\nProof . 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 . \n\nTheorem isweqezmaphf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) : isweq ( ezmaphf f g z ye ) . \nProof . intros . set ( ff := ezmaphf f g z ye ) . set ( gg := invezmaphf f g z ye ) . \nassert ( 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 . \nassert ( efg : forall xee' : _ , paths ( ff ( gg xee' ) ) xee' ) . destruct ye as [ y e ] . destruct e .  intro xee' . \nassert ( 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 . \napply ( pathscomp0 hint ( homotffggid _ _ _ _ xee' ) ) . \napply ( gradth _ _ egf efg ) . Defined .  \n\n\nDefinition 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 ) . \nDefinition 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 ) . \n\nDefinition 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 ) ) .\n\n\nCorollary weqhfibersgwtog { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( z : Z ) : weq ( hfiber ( funcomp w g ) z ) ( hfiber g z ) .\nProof. intros . split with ( hfibersgftog w g z ) .  intro ye . apply ( iscontrweqf ( ezweqhf w g z ye ) ( ( pr2 w ) ( pr1 ye ) ) ) . Defined .\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** Fiber-wise weak equivalences. \n\n\nTheorems 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. *)\n\n\nDefinition 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))).\n\n\nTheorem isweqtotaltofib { X : UU } ( P Q : X -> UU) (f: forall x:X, P x -> Q x):\nisweq (totalfun _ _ f) -> forall x:X, isweq (f x).\nProof. 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). \n\nset (hfx:= hfibersgftog totf piq x).  simpl in hfx. \nassert (H: isweq hfx). unfold isweq. intro y. \nset (int:= invezmaphf totf piq x y). \nassert (X1:isweq int). apply (isweqinvezmaphf totf piq x y). destruct y as [ t e ]. \nassert (is1: iscontr (hfiber  totf t)). apply (X0 t). apply (iscontrweqb  ( weqpair int X1 ) is1).   \nset (ip:= ezmappr1 P x). set (iq:= ezmappr1 Q x). set (h:= fun p: P x => hfx (ip p)).  \nassert (is2: isweq h). apply (twooutof3c ip hfx (isweqezmappr1 P x) H). set (h':= fun p: P x => iq ((f x) p)). \nassert (ee: forall p:P x, paths (h p) (h' p)). intro. apply idpath.  \nassert (X2:isweq h'). apply (isweqhomot   h h' ee is2). \napply (twooutof3a (f x) iq X2). \napply (isweqezmappr1 Q x). Defined.\n\n\nDefinition 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 ) . \n \n\nTheorem isweqfibtototal { X : UU } ( P Q : X -> UU) (f: forall x:X, weq ( P x ) ( Q x ) ) : isweq (totalfun _ _ f).\nProof. 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). \n\nassert (isint: iscontr (hfiber  hfpqx xqe)). \nassert (isint1: isweq hfpqx). set (ipx:= ezmappr1 P x). set (iqx:= ezmappr1 Q x).   set (diag:= fun p:P x => (iqx ((f x) p))). \nassert (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). \nset (intmap:= invezmaphf  fpq pr1q x xqe). apply (iscontrweqf  ( weqpair intmap (isweqinvezmaphf fpq pr1q x xqe) ) isint). \nDefined.\n\nDefinition weqfibtototal { X : UU } ( P Q : X -> UU) (f: forall x:X, weq ( P x ) ( Q x ) ) := weqpair _ ( isweqfibtototal P Q f ) .\n\n\n\n\n\n\n(** ** Homotopy fibers of the function [fpmap: total2 X (P f) -> total2 Y P].\n\nGiven [ 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 ]. *)\n\n\nDefinition fpmap { X Y : UU } (f: X -> Y) ( P:Y-> UU) : total2 ( fun x => P ( f x ) ) -> total2 P := \n(fun z:total2 (fun x:X => P (f x)) => tpair P (f (pr1  z)) (pr2  z)).\n\n\nDefinition 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)).\nProof. 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.\n\n\nDefinition hfiberfpmap { X Y : UU } (f:X -> Y)(P:Y-> UU)(yp: total2 P): hfiber  (fpmap f P) yp -> hfiber  f (pr1  yp).\nProof. 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. \n\n\n\nLemma 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).\nProof. 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)).  \n\nassert (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. \n\nassert (egf: forall p: P x , paths (g (f p)) p).  intro. apply idpath.  \n\napply (gradth f g egf efg). Defined. \n\n\nLemma isweqhff { X Y : UU } (f: X -> Y)(P:Y-> UU): isweq (hffpmap2  f P). \nProof. 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.\n\nset (h:= fun u: total2 (fun x:X => P (f x)) => toint ((hffpmap2  f P) u)). simpl in h. \n\nassert (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)).  \n\nassert (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 ) ) ).   \n\napply (twooutof3a (hffpmap2  f P) toint X0 is). Defined. \n\n\n\n\nTheorem isweqhfiberfp { X Y : UU } (f:X -> Y)(P:Y-> UU)(yp: total2 P): isweq (hfiberfpmap  f P yp).\nProof. 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. \n\n\nCorollary isweqfpmap { X Y : UU } ( w : weq X Y )(P:Y-> UU) :  isweq (fpmap w P).\nProof. intros. unfold isweq.   intro y.  set (h:=hfiberfpmap w P y). \nassert (X1:isweq h). apply isweqhfiberfp. \nassert (is: iscontr (hfiber w (pr1  y))). apply ( pr2 w ). apply (iscontrweqb  ( weqpair h X1 ) is). Defined. \n\nDefinition weqfp { X Y : UU } ( w : weq X Y )(P:Y-> UU) := weqpair _ ( isweqfpmap w P ) .\n\n\n(** *** Total spaces of families over a contractible base *)\n\nDefinition fromtotal2overunit ( P : unit -> UU ) ( tp : total2 P ) : P tt .\nProof . intros . destruct tp as [ t p ] . destruct t . apply p . Defined .\n\nDefinition tototal2overunit   ( P : unit -> UU ) ( p : P tt ) : total2 P  := tpair P tt p . \n\nTheorem weqtotal2overunit ( P : unit -> UU ) : weq ( total2 P ) ( P tt ) .\nProof. intro . set ( f := fromtotal2overunit P ) . set ( g := tototal2overunit P ) . split with f . \nassert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . destruct a as [ t p ] . destruct t . apply idpath .\nassert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . apply idpath .    \napply ( gradth _ _ egf efg ) . Defined . \n\n\n\n(** ** 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 *)\n\n\nDefinition 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:_ =>\nmatch xp with\ntpair _ x p => tpair Q (f x) (fm x p)\nend.\n\nTheorem 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).\nProof. 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 ). \nassert (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.\n\nDefinition 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 ) .\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** Homotopy fiber squares *)\n\n\n\n\n(** *** Homotopy commutative squares *)\n\n\nDefinition commsqstr { X X' Y Z : UU } ( g' : Z -> X' ) ( f' : X' -> Y ) ( g : Z -> X ) ( f : X -> Y ) := forall ( z : Z ) , paths   ( f' ( g' z ) ) ( f ( g z ) ) .\n\n\nDefinition hfibersgtof'  { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( x : X ) ( ze : hfiber g x ) : hfiber f' ( f x )  .\nProof. intros . destruct ze as [ z e ] . split with ( g' z ) .    apply ( pathscomp0  ( h z )  ( maponpaths f e )  ) . Defined . \n\nDefinition hfibersg'tof  { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( x' : X' ) ( ze : hfiber g' x' ) : hfiber f ( f' x' )  .\nProof. intros . destruct ze as [ z e ] . split with ( g z ) .    apply ( pathscomp0 ( pathsinv0 ( h z ) ) ( maponpaths f' e ) ) . Defined . \n\n\nDefinition transposcommsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) : commsqstr g' f' g f -> commsqstr g f g' f' := fun h : _ => fun z : Z => ( pathsinv0 ( h z ) ) . \n\n\n(** *** Short complexes and homotopy commutative squares *)\n\nLemma complxstrtocommsqstr { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( h : complxstr f g z ) : commsqstr f g ( fun x : X => tt ) ( fun t : unit => z ) .\nProof. intros .  assumption .   Defined . \n\n\nLemma commsqstrtocomplxstr { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( h : commsqstr f  g ( fun x : X => tt ) ( fun t : unit => z ) ) : complxstr f g z .\nProof. intros . assumption .   Defined . \n\n\n(** *** Homotopy fiber products *)\n\n\n\nDefinition hfp {X X' Y:UU} (f:X -> Y) (f':X' -> Y):= total2 (fun xx' : dirprod X X'  => paths ( f' ( pr2 xx' ) ) ( f ( pr1 xx' ) ) ) .\nDefinition hfpg {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : hfp f f' -> X := fun xx'e => ( pr1 ( pr1 xx'e ) ) .\nDefinition hfpg' {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : hfp f f' -> X' := fun xx'e => ( pr2 ( pr1 xx'e ) ) .\n\nDefinition commsqZtohfp { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) : Z -> hfp f f' := fun z : _ => tpair _ ( dirprodpair ( g z ) ( g' z ) ) ( h z ) .\n\nDefinition commsqZtohfphomot  { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f  ) : forall z : Z , paths ( hfpg _ _ ( commsqZtohfp _ _ _ _ h z ) ) ( g z ) := fun z : _ => idpath _ . \n\nDefinition commsqZtohfphomot'  { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f  ) : forall z : Z , paths ( hfpg' _ _ ( commsqZtohfp _ _ _ _ h z ) ) ( g' z ) := fun z : _ => idpath _ . \n\n\nDefinition hfpoverX {X X' Y:UU} (f:X -> Y) (f':X' -> Y) := total2 (fun x : X => hfiber  f' ( f x ) ) .\nDefinition hfpoverX' {X X' Y:UU} (f:X -> Y) (f':X' -> Y) := total2 (fun x' : X' => hfiber  f (f' x' ) ) .\n\n\nDefinition weqhfptohfpoverX {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : weq ( hfp f f' ) ( hfpoverX f f' ) .\nProof. intros . apply ( weqtotal2asstor ( fun x : X => X' ) ( fun  xx' : dirprod X X'  => paths  ( f' ( pr2 xx' ) ) ( f ( pr1 xx' ) ) ) ) .   Defined . \n\n\nDefinition weqhfptohfpoverX' {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : weq ( hfp f f' ) ( hfpoverX' f f' ) .\nProof. intros .  set ( w1 := weqfp ( weqdirprodcomm X X' ) ( fun xx' : dirprod X' X  => paths ( f' ( pr1 xx' ) ) ( f ( pr2 xx' ) ) ) ) .  simpl in w1 .  \nset ( 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 . \n\n\nLemma weqhfpcomm { X X' Y : UU } ( f : X -> Y ) ( f' : X' -> Y ) : weq ( hfp f f' ) ( hfp f' f ) .\nProof . 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 . \n\n\nDefinition commhfp {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : commsqstr ( hfpg' f f' ) f' ( hfpg f f' ) f := fun xx'e : hfp f f' => pr2 xx'e . \n\n\n(** *** Homotopy fiber products and homotopy fibers *)\n\nDefinition  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 )  . \n\nDefinition 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 ) .\n\nLemma weqhfibertohfp  { X Y : UU } ( f : X -> Y ) ( y : Y ) : weq ( hfiber f y )  ( hfp ( fun t : unit => y ) f ) .\nProof . intros . set ( ff := hfibertohfp f y ) . set ( gg := hfptohfiber f y ) . split with ff .\nassert ( egf : forall xe : _ , paths ( gg ( ff xe ) ) xe ) . intro . destruct xe . apply idpath .\nassert ( efg : forall hf : _ , paths ( ff ( gg hf ) ) hf ) . intro . destruct hf as [ tx e ] . destruct tx as [ t x ] . destruct t .   apply idpath .\napply ( gradth _ _ egf efg ) . Defined .  \n\n\n\n\n\n\n\n(** *** Homotopy fiber squares *)\n\n\nDefinition ishfsq { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f  ) :=  isweq ( commsqZtohfp f f' g g' h ) .\n\nDefinition hfsqstr  { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) := total2 ( fun h : commsqstr g' f' g f  => isweq ( commsqZtohfp f f' g g' h ) ) .\nDefinition hfsqstrpair { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) := tpair ( fun h : commsqstr g' f' g f  => isweq ( commsqZtohfp f f' g g' h ) ) .\nDefinition hfsqstrtocommsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) : hfsqstr f f' g g' -> commsqstr g' f' g f  := @pr1 _ ( fun h : commsqstr g' f' g f  => isweq ( commsqZtohfp f f' g g' h ) ) .\nCoercion hfsqstrtocommsqstr : hfsqstr >-> commsqstr . \n\nDefinition 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 ) .\n\nLemma 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 ) .\nProof. intros . set ( is := pr2 hf ) . set ( h := pr1 hf ) . \nset ( a := weqtococonusf g ) . set ( c := weqpair _ is ) .  set ( d := weqhfptohfpoverX f f' ) .  set ( b0 := totalfun _ _ ( hfibersgtof' f f' g g' h ) ) .    \nassert ( 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 .\nassert ( is1 : isweq ( fun z : _ => b0 ( a z ) ) ) . apply ( isweqhomot _ _ h1 ) .   apply ( twooutof3c _ _ ( pr2 c ) ( pr2 d ) ) .  \nassert ( is2 : isweq b0 ) . apply ( twooutof3b _ _ ( pr2 a ) is1 ) .  apply ( isweqtotaltofib _ _ _ is2 x ) .   Defined . \n\nDefinition 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 ) .\n\nLemma ishfsqweqhfibersgtof' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f  ) ( is : forall x : X , isweq ( hfibersgtof' f f' g g' h x ) ) :  hfsqstr f f' g g' . \nProof .  intros . split with h . \nset ( 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 ) ) ) .    \nassert ( 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 .\nassert ( is1 : isweq ( fun z : _ => d ( c0 z ) ) ) . apply ( isweqhomot _ _ ( fun z : Z => ( pathsinv0 ( h1 z ) ) ) ) .   apply ( twooutof3c _ _ ( pr2 a ) ( pr2 b ) ) .  \n apply ( twooutof3a _ _ is1 ( pr2 d ) ) .    Defined .  \n\n\nLemma 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' ) . \nProof. intros . set ( is := pr2 hf ) . set ( h := pr1 hf ) .\nset ( a' := weqtococonusf g' ) . set ( c' := weqpair _ is ) .  set ( d' := weqhfptohfpoverX' f f' ) .  set ( b0' := totalfun _ _ ( hfibersg'tof f f' g g' h ) ) .    \nassert ( 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 .\nassert ( is1 : isweq ( fun z : _ => b0' ( a' z ) ) ) . apply ( isweqhomot _ _ h1 ) .   apply ( twooutof3c _ _ ( pr2 c' ) ( pr2 d' ) ) .  \nassert ( is2 : isweq b0' ) . apply ( twooutof3b _ _ ( pr2 a' ) is1 ) .  apply ( isweqtotaltofib _ _ _ is2 x' ) .   Defined . \n\nDefinition 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' ) .\n\nLemma ishfsqweqhfibersg'tof { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( is : forall x' : X' , isweq ( hfibersg'tof f f' g g' h x' ) ) :  hfsqstr f f' g g' . \nProof .  intros . split with h . \nset ( 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' ) ) ) .    \nassert ( 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 .\nassert ( is1 : isweq ( fun z : _ => d' ( c0' z ) ) ) . apply ( isweqhomot _ _ ( fun z : Z => ( pathsinv0 ( h1 z ) ) ) ) .   apply ( twooutof3c _ _ ( pr2 a' ) ( pr2 b' ) ) .  \n apply ( twooutof3a _ _ is1 ( pr2 d' ) ) .    Defined .  \n\nTheorem 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 .\nProof . intros . set ( is := pr2 hf ) . set ( h := pr1 hf ) . set ( th := transposcommsqstr f f' g g' h ) . split with th . \nset ( 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 . \n\n    \n(** *** Fiber sequences and homotopy fiber squares *)\n\nTheorem 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 .\nProof . 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 ) . \napply ( pr2 ( weqcomp ff gg ) ) .  Defined . \n\n\nTheorem 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 .\nProof . 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 ) . \napply ( twooutof3a ff gg ( pr2 ggff ) ( pr2 gg ) ) .  Defined . \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** Basics about h-levels *)\n\n\n\n(** *** h-levels of types *)\n\n\nFixpoint isofhlevel (n:nat) (X:UU): UU:=\nmatch n with\nO => iscontr X |\nS m => forall x:X, forall x':X, (isofhlevel m (paths x x'))\nend.\n\n\nTheorem 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 .\nProof. intro. induction n as [ | n IHn ].  intros X Y p s eps X0. unfold isofhlevel.  apply ( iscontrretract p s eps X0). \n 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. \n\nCorollary  isofhlevelweqf (n:nat) { X Y : UU } ( f : weq X Y ) : isofhlevel n X  ->  isofhlevel n Y .\nProof. intros n X Y f X0.  apply (hlevelretract n  f (invmap f ) (homotweqinvweq  f )). assumption. Defined. \n\nCorollary  isofhlevelweqb (n:nat) { X Y : UU } ( f : weq X Y ) : isofhlevel n Y  ->  isofhlevel n X .\nProof. intros n X Y f X0 .  apply (hlevelretract n  (invmap  f ) f (homotinvweqweq  f )). assumption. Defined. \n\nLemma isofhlevelsn ( n : nat ) { X : UU } ( f : X -> isofhlevel ( S n ) X ) : isofhlevel ( S n ) X.\nProof. intros . simpl . intros x x' . apply ( f x x x'). Defined.\n\nLemma isofhlevelssn (n:nat) { X : UU } ( is : forall x:X, isofhlevel (S n) (paths x x)) : isofhlevel (S (S n)) X.\nProof. 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') ). \nassert ( X1 : paths x x' -> isofhlevel (S n) (paths x x') ) . intro X2. destruct X2. apply ( is x ). apply  ( isofhlevelsn n X1 ). Defined. \n\n\n\n\n\n\n\n(** *** h-levels of functions *)\n\n\nDefinition isofhlevelf ( n : nat ) { X Y : UU } ( f : X -> Y ) : UU := forall y:Y, isofhlevel n (hfiber  f y).\n\n\nTheorem 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'.\nProof. intros n X Y f f' h X0. unfold isofhlevelf. intro y . apply ( isofhlevelweqf n ( weqhfibershomot f f' h y ) ( X0 y )) .   Defined .\n\n\nTheorem isofhlevelfpmap ( n : nat ) { X Y : UU } ( f : X -> Y ) ( Q : Y -> UU ) : isofhlevelf n  f -> isofhlevelf n ( fpmap f Q ) .\nProof. 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. \n\n\n\nTheorem 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 .\nProof. 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. \n\n\nTheorem 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  .\nProof.  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 .\n\n\nTheorem isofhlevelffromXY ( n : nat ) { X Y : UU } ( f : X -> Y ) : isofhlevel n X -> isofhlevel (S n) Y -> isofhlevelf n f.\nProof. intro. induction n as [ | n IHn ] .  intros X Y f X0 X1.\nassert (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 ). \napply (isweqcontrcontr  f X0 is1).\n\nintros X Y f X0 X1.  unfold isofhlevelf. simpl.  \nassert  (is1: forall x' x:X, isofhlevel n (paths x' x)). simpl in X0.  assumption.  \nassert (is2: forall y' y:Y, isofhlevel (S n) (paths y' y)). simpl in X1.  simpl. assumption.\nassert (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)). \nassert (is4: forall (y:Y)(x:X)(xe': hfiber  f y)(e: paths (f x) y), isofhlevel n (paths (hfiberpair  f x e) xe')). intros.\napply (isofhlevelweqb n  ( ezweq3g f x xe' e)  (is3 y x xe' e)).\nintros y xe xe' .  destruct xe as [ t x ]. apply (is4 y t xe' x). Defined.\n\n\n\nTheorem isofhlevelXfromfY ( n : nat ) { X Y : UU } ( f : X -> Y ) : isofhlevelf n f -> isofhlevel n Y -> isofhlevel n X.\nProof. 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.\nassert (is1: forall (y:Y)(xe xe': hfiber  f y), isofhlevel n (paths xe xe')). intros. apply (X0 y). \nassert (is2: forall (y:Y)(x:X)(xe': hfiber  f y), isofhlevelf n  (d2g  f x xe')). intros. unfold isofhlevel. intro y0.\napply (isofhlevelweqf n ( ezweq3g  f x xe' y0 ) (is1 y (hfiberpair  f x y0) xe')). \nassert (is3: forall (y' y : Y), isofhlevel n (paths y' y)). simpl in X1. assumption.\nintros x' x .  \nset (y:= f x').  set (e':= idpath y). set (xe':= hfiberpair  f x' e').\napply (IHn  _ _ (d2g  f x xe') (is2 y x xe') (is3 (f x) y)). Defined. \n\n\n\n\n\n\nTheorem  isofhlevelffib ( n : nat ) { X : UU } ( P : X -> UU ) ( x : X ) ( is : forall x':X, isofhlevel n (paths x' x) ) : isofhlevelf n ( tpair P x ) .\nProof . intros . unfold isofhlevelf . intro xp .   apply (isofhlevelweqf n ( ezweq1pr1 P x xp) ( is ( pr1 xp ) ) ) . Defined . \n\n\n\nTheorem 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).\nProof.  intros .  unfold isofhlevelf. intro x.  apply (isofhlevelweqf n ( ezweq1g f y x ) ( is ( f x ) ) ) . Defined. \n\n\n\n\n\n\nTheorem isofhlevelfsnfib (n:nat) { X : UU } (P:X -> UU)(x:X) ( is : isofhlevel (S n) (paths x x) ) : isofhlevelf (S n) ( tpair P x ).\nProof. intros .  unfold isofhlevelf. intro xp. apply (isofhlevelweqf (S n) ( ezweq1pr1 P x xp ) ).  apply isofhlevelsn . intro X1 . destruct X1 . assumption .  Defined .   \n\n\n\n\nTheorem isofhlevelfsnhfiberpr1 ( n : nat ) { X Y : UU } (f : X -> Y ) ( y : Y ) ( is : isofhlevel (S n) (paths y y) ) : isofhlevelf (S n) (hfiberpr1 f y).\nProof.  intros .  unfold isofhlevelf. intro x. apply (isofhlevelweqf (S n)  ( ezweq1g f y x ) ). apply isofhlevelsn. intro X1. destruct X1.  assumption. Defined . \n\n\n\n\nCorollary isofhlevelfhfiberpr1 ( n : nat ) { X Y : UU }  ( f : X -> Y ) ( y : Y ) ( is : isofhlevel (S n) Y ) : isofhlevelf n ( hfiberpr1 f y ) .\nProof. intros. apply isofhlevelfhfiberpr1y. intro y' . apply (is y' y).   Defined. \n\n\n\n\n\n\nTheorem 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.\nProof. intros n X Y Z f g X0 X1. unfold isofhlevelf. intro y . set (ye:= hfiberpair  g  y (idpath (g y))). \napply (isofhlevelweqb n  ( ezweqhf  f g (g y) ye ) (isofhlevelffromXY n  _ (X0 (g y)) (X1 (g y)) ye)). Defined.\n\n\n\nTheorem 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)).\nProof. intros n X Y Z f g X0 X1.  unfold isofhlevelf. intro z. \nassert (is1: isofhlevelf n  (hfibersgftog  f g z)). unfold isofhlevelf. intro ye. apply (isofhlevelweqf n ( ezweqhf  f g z ye ) (X0 (pr1  ye))). \nassert (is2: isofhlevel n (hfiber  g z)). apply (X1 z).\napply (isofhlevelXfromfY n  _ is1 is2). Defined.\n\n\n\nTheorem 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  .\nProof. 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 . \n\n\n\nTheorem 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 ) ) .\nProof. 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 . \n\n\n\nCorollary 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'.  \nProof. 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). \napply (isofhlevelfgwtog n  w f' X1). Defined.\n\n\n\n\nTheorem isofhlevelfonpaths (n:nat) { X Y : UU }(f:X -> Y)(x x':X): isofhlevelf (S n)  f -> isofhlevelf n  (@maponpaths _ _ f x x').\nProof. intros n X Y f x x' X0. \nset (y:= f x'). set (xe':= hfiberpair  f x' (idpath _ )). \nassert (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')). \nassert (h: forall ee:paths x' x, paths (d2g  f x xe' ee) (maponpaths f  (pathsinv0  ee))). intro.\nassert (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. \n\n\n\nTheorem isofhlevelfsn (n:nat) { X Y : UU } (f:X -> Y): (forall x x':X, isofhlevelf n  (@maponpaths _ _ f x x')) -> isofhlevelf (S n)  f.\nProof. 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.  \nassert (is1: isofhlevelf n  (d2g  f x xe')). \nassert (h: forall ee: paths x' x, paths (maponpaths f  (pathsinv0  ee)) (d2g  f x xe' ee)). intro. unfold d2g. simpl .  apply ( pathsinv0 ( pathscomp0rid _ ) ) . \nassert (is2: isofhlevelf n  (fun ee: paths x' x => maponpaths f  (pathsinv0  ee))).  apply (isofhlevelfgtogw n  ( weqpair _ (isweqpathsinv0  _ _  ) ) (@maponpaths _ _ f x x') (X0 x x')). \napply (isofhlevelfhomot n  _ _  h is2). \napply (isofhlevelweqb n  (  ezweq3g f x xe' e )  (is1 e)).  Defined.\n\n\nTheorem isofhlevelfssn (n:nat) { X Y : UU } (f:X -> Y): (forall x:X, isofhlevelf (S n)  (@maponpaths _ _ f x x)) -> isofhlevelf (S (S n))  f.\nProof.  intros n X Y f X0.  unfold isofhlevelf. intro y .\nassert (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.  \nassert (is1: isofhlevelf (S n)  (d2g  f x xe')). \nassert (h: forall ee: paths x x, paths (maponpaths f  (pathsinv0  ee))  (d2g  f x xe' ee)). intro. unfold d2g . simpl . apply ( pathsinv0 ( pathscomp0rid _ ) ) .  \nassert (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 )) . \napply (isofhlevelfhomot (S n) _ _  h is2). \napply (isofhlevelweqb (S n)  ( ezweq3g  f x xe' e' )  (is1 e')).  \napply (isofhlevelssn).  assumption. Defined.\n\n\n\n(** ** h -levels of [ pr1 ], fiber inclusions, fibers, total spaces and bases of fibrations *)\n\n\n(** *** h-levelf of [ pr1 ] *)\n\n\nTheorem isofhlevelfpr1 (n:nat) { X : UU } (P:X -> UU)(is: forall x:X, isofhlevel n (P x)) : isofhlevelf n  (@pr1 X P).\nProof. intros. unfold isofhlevelf. intro x .  apply (isofhlevelweqf n  ( ezweqpr1  _ x)    (is x)). Defined.\n\nLemma isweqpr1 { Z : UU } ( P : Z -> UU ) ( is1 : forall z : Z, iscontr ( P z ) ) : isweq ( @pr1 Z P ) .\nProof. intros. unfold isweq.  intro y. set (isy:= is1 y). apply (iscontrweqf ( ezweqpr1 P y)) . assumption. Defined. \n\nDefinition weqpr1 { Z : UU } ( P : Z -> UU ) ( is : forall z : Z , iscontr ( P z ) ) : weq ( total2 P ) Z := weqpair _ ( isweqpr1 P is ) . \n\n\n\n\n(** *** h-level of the total space [ total2 ] *)  \n\nTheorem isofhleveltotal2 ( n : nat ) { X : UU } ( P : X -> UU ) ( is1 : isofhlevel n X )( is2 : forall x:X, isofhlevel n (P x) ) : isofhlevel n (total2 P).\nProof. intros. apply (isofhlevelXfromfY n  (@pr1 _ _ )). apply isofhlevelfpr1. assumption. assumption. Defined. \n\nCorollary isofhleveldirprod ( n : nat ) ( X Y : UU ) ( is1 : isofhlevel n X ) ( is2 : isofhlevel n Y ) : isofhlevel n (dirprod X Y).\nProof. intros. apply isofhleveltotal2. assumption. intro. assumption. Defined. \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** Propositions, inclusions  and sets *)\n\n\n\n\n\n\n\n(** *** Basics about types of h-level 1 - \"propositions\" *)\n\n\nDefinition isaprop  := isofhlevel (S O) . \n\nNotation isapropunit := iscontrpathsinunit .\n\nNotation isapropdirprod := ( isofhleveldirprod 1 ) . \n\nLemma isapropifcontr { X : UU } ( is : iscontr X ) : isaprop X .\nProof. 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.\nCoercion isapropifcontr : iscontr >-> isaprop  .  \n\nTheorem hlevelntosn ( n : nat ) ( T : UU )  ( is : isofhlevel n T ) : isofhlevel (S n) T.\nProof. 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.\n\nCorollary isofhlevelcontr (n:nat) { X : UU } ( is : iscontr X ) : isofhlevel n X.\nProof. intro. induction n as [ | n IHn ] . intros X X0 . assumption. \nintros X X0. simpl. intros x x' . assert (is: iscontr (paths x x')). apply (isapropifcontr X0 x x'). apply (IHn _ is). Defined.\n\nLemma isofhlevelfweq ( n : nat ) { X Y : UU } ( f : weq X Y ) :  isofhlevelf n f .\nProof. intros n X Y f .  unfold isofhlevelf.   intro y . apply ( isofhlevelcontr n ). apply ( pr2 f ). Defined.\n\nCorollary isweqfinfibseq  { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z  ) ( isz : iscontr Z ) : isweq f .\nProof. intros . apply ( isofhlevelfffromZ 0 f g z fs ( isapropifcontr isz ) ) .  Defined .\n\nCorollary weqhfibertocontr { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : iscontr Y ) : weq ( hfiber f y ) X .\nProof. intros . split with ( hfiberpr1 f y ) . apply ( isofhlevelfhfiberpr1 0 f y ( hlevelntosn 0 _ is ) ) . Defined.\n\n\n\nCorollary weqhfibertounit ( X : UU ) : weq ( hfiber ( fun x : X => tt ) tt ) X .\nProof.  intro . apply ( weqhfibertocontr _ tt iscontrunit ) . Defined.  \n\nCorollary isofhleveltofun ( n : nat ) ( X : UU ) : isofhlevel n X -> isofhlevelf n ( fun x : X => tt ) .\nProof. intros n X is .  intro t . destruct t . apply ( isofhlevelweqb n ( weqhfibertounit X ) is ) .  Defined .\n\nCorollary isofhlevelfromfun ( n : nat ) ( X : UU ) : isofhlevelf n ( fun x : X => tt ) ->  isofhlevel n X .\nProof. intros n X is .  apply ( isofhlevelweqf n ( weqhfibertounit X ) ( is tt ) ) .  Defined .\n\n\n\n\n\n\n\nLemma isofhlevelsnprop (n:nat) { X : UU } ( is : isaprop X ) : isofhlevel (S n) X.\nProof. intros n X X0. simpl. unfold isaprop in X0.  simpl in X0. intros x x' . apply isofhlevelcontr. apply (X0 x x'). Defined. \n\nLemma iscontraprop1 { X : UU } ( is : isaprop X ) ( x : X ) : iscontr X .\nProof. intros . unfold iscontr. split with x . intro t .  unfold isofhlevel in is .  set (is' := is t x ). apply ( pr1 is' ). \nDefined. \n\nLemma iscontraprop1inv { X : UU } ( f : X -> iscontr X ) : isaprop X .\nProof. intros X X0. assert ( H : X -> isofhlevel (S O) X). intro X1.  apply (hlevelntosn O _ ( X0 X1 ) ) . apply ( isofhlevelsn O H ) . Defined.\n\nLemma proofirrelevance ( X : UU ) ( is : isaprop X ) : forall x x' : X , paths x x' . \nProof. intros . unfold isaprop in is . unfold isofhlevel in is .   apply ( pr1 ( is x x' ) ). Defined. \n\nLemma invproofirrelevance ( X : UU ) ( ee : forall x x' : X , paths x x' ) : isaprop X.\nProof. intros . unfold isaprop. unfold isofhlevel .  intro x .  \nassert ( is1 : iscontr X ).  split with x. intro t .  apply ( ee t x). assert ( is2 : isaprop X).  apply isapropifcontr. assumption.   \nunfold isaprop in is2. unfold isofhlevel in is2.  apply (is2 x). Defined. \n\nLemma isweqimplimpl { X Y : UU } ( f : X -> Y ) ( g : Y -> X ) ( isx : isaprop X ) ( isy : isaprop Y ) : isweq f.\nProof. intros. \nassert (isx0: forall x:X, paths (g (f x)) x). intro. apply proofirrelevance . apply isx . \nassert (isy0 : forall y : Y, paths (f (g y)) y). intro. apply proofirrelevance . apply isy . \napply (gradth  f g isx0 isy0).  Defined. \n\nDefinition weqimplimpl { X Y : UU } ( f : X -> Y ) ( g : Y -> X ) ( isx : isaprop X ) ( isy : isaprop Y ) := weqpair _ ( isweqimplimpl f g isx isy ) .\n\nTheorem isapropempty: isaprop empty.\nProof. unfold isaprop. unfold isofhlevel. intros x x' . destruct x. Defined. \n\n\nTheorem isapropifnegtrue { X : UU } ( a : X -> empty ) : isaprop X .\nProof . intros . set ( w := weqpair _ ( isweqtoempty a ) ) . apply ( isofhlevelweqb 1 w isapropempty ) .  Defined .\n\n\n\n\n(** *** Functional extensionality for functions to the empty type *)\n\nAxiom funextempty : forall ( X : UU ) ( f g : X -> empty ) , paths f g . \n\n\n\n(** *** More results on propositions *)\n\n\nTheorem isapropneg (X:UU): isaprop (X -> empty).\nProof. intro.  apply invproofirrelevance . intros x x' .   apply ( funextempty X x x' ) . Defined .  \n\n(** See also [ isapropneg2 ] *) \n\n\nCorollary isapropdneg (X:UU): isaprop (dneg X).\nProof. intro. apply (isapropneg (neg X)). Defined.\n\n\nDefinition isaninvprop (X:UU) := isweq  (todneg X).\n\nDefinition invimpl (X:UU) (is: isaninvprop X) : (dneg X) -> X:= invmap  ( weqpair (todneg X) is ) . \n\n\nLemma isapropaninvprop (X:UU): isaninvprop X -> isaprop X.\nProof. intros X X0. \napply (isofhlevelweqb (S O) ( weqpair (todneg X) X0 ) (isapropdneg X)). Defined. \n\n\nTheorem isaninvpropneg (X:UU): isaninvprop (neg X).\nProof. intros. \nset (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.\n\n\nTheorem isapropdec (X:UU): (isaprop X) -> (isaprop (coprod X (X-> empty))).\nProof. intros X X0. \nassert (X1: forall (x x': X), paths x x'). apply (proofirrelevance _ X0).  \nassert (X2: forall (x x': coprod X (X -> empty)), paths x x'). intros.  \ndestruct x as  [ x0 | y0 ].  destruct x' as [ x | y ].   apply (maponpaths (fun x:X => ii1  x)  (X1 x0 x)).    \napply (fromempty (y x0)).\ndestruct x' as [ x | y ].   apply (fromempty (y0 x)). \nassert (e: paths y0 y). apply (proofirrelevance _ (isapropneg X) y0 y). apply (maponpaths (fun f: X -> empty => ii2  f)  e).\napply (invproofirrelevance _ X2).  Defined. \n\n\n\n(** *** Inclusions - functions of h-level 1 *)\n\n\nDefinition isincl { X Y : UU } (f : X -> Y ) := isofhlevelf 1 f .\n\nDefinition incl ( X Y : UU ) := total2 ( fun f : X -> Y => isincl f ) .\nDefinition inclpair { X Y : UU } ( f : X -> Y ) ( is : isincl f ) : incl X Y := tpair _ f is . \nDefinition pr1incl ( X Y : UU ) : incl X Y -> ( X -> Y ) := @pr1 _ _ .\nCoercion pr1incl : incl >-> Funclass .\n\nLemma isinclweq ( X Y : UU ) ( f : X -> Y ) : isweq f -> isincl f .\nProof . intros X Y f is . apply ( isofhlevelfweq 1 ( weqpair _ is ) ) .  Defined .\nCoercion isinclweq : isweq >-> isincl .\n\nLemma isofhlevelfsnincl (n:nat) { X Y : UU } (f:X -> Y)(is: isincl  f): isofhlevelf (S n)  f.\nProof. intros. unfold isofhlevelf.  intro y . apply isofhlevelsnprop. apply (is y). Defined.  \n\nDefinition weqtoincl ( X Y : UU ) : weq X Y -> incl X Y :=  fun w => inclpair ( pr1 w ) ( pr2 w ) .  \nCoercion weqtoincl : weq >-> incl . \n\nLemma isinclcomp { X Y Z : UU } ( f : incl X Y ) ( g : incl Y Z ) : isincl ( funcomp ( pr1 f ) ( pr1 g ) ) .\nProof . intros . apply ( isofhlevelfgf 1 f g ( pr2 f ) ( pr2 g ) ) . Defined .\n\nDefinition 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 ) . \n\nLemma isincltwooutof3a { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isg : isincl g ) ( isgf : isincl ( funcomp f g ) ) : isincl f .\nProof . intros . apply ( isofhlevelff 1 f g isgf ) .  apply ( isofhlevelfsnincl 1 g isg ) . Defined .\n\nLemma isinclgwtog { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( is : isincl ( funcomp w g ) ) : isincl g .\nProof . intros . apply ( isofhlevelfgwtog 1 w g is ) .  Defined . \n\nLemma isinclgtogw { X Y Z : UU }  ( w : weq X Y ) ( g : Y -> Z ) ( is : isincl g ) : isincl ( funcomp w g ) .\nProof . intros . apply  ( isofhlevelfgtogw 1 w g is ) . Defined . \n\n\nLemma isinclhomot { X Y : UU } ( f g : X -> Y ) ( h : homot f g ) ( isf : isincl f ) : isincl g .\nProof . intros . apply ( isofhlevelfhomot ( S O ) f g h isf ) . Defined . \n\n\n\nDefinition 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).  \n\nDefinition  isapropinclb { X Y : UU } ( f : X -> Y ) ( isf : isincl f ) : isaprop Y ->  isaprop X := isofhlevelXfromfY 1 _ isf .\n\n\nLemma iscontrhfiberofincl { X Y : UU } (f:X -> Y): isincl  f -> (forall x:X, iscontr (hfiber  f (f x))).\nProof. intros X Y f X0 x. unfold isofhlevelf in X0. set (isy:= X0 (f x)).  apply (iscontraprop1 isy (hfiberpair  f _ (idpath (f x)))). Defined.\n\n\nLemma isweqonpathsincl { X Y : UU } (f:X -> Y) (is: isincl  f)(x x':X): isweq (@maponpaths _ _ f x x').\nProof. intros. apply (isofhlevelfonpaths O  f x x' is). Defined.\n\nDefinition weqonpathsincl  { X Y : UU } (f:X -> Y) (is: isincl  f)(x x':X) := weqpair _ ( isweqonpathsincl f is x x' ) .\n\nDefinition 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') .\n\n\nLemma isinclweqonpaths { X Y : UU } (f:X -> Y): (forall x x':X, isweq (@maponpaths _ _ f x x')) -> isincl  f.\nProof. intros X Y f X0.  apply (isofhlevelfsn O  f X0). Defined.\n\n\nDefinition isinclpr1 { X : UU } (P:X -> UU)(is: forall x:X, isaprop (P x)): isincl  (@pr1 X P):= isofhlevelfpr1 (S O) P is.\n\n\n\n\n\n\nTheorem 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 ) ) .\nProof. intros. split with (@hfibersftogf  _ _ _ f g (g y) (hfiberpair  g y (idpath _ ))) .\n\nset (z:= g y). set (ye:= hfiberpair  g y (idpath _ )).  unfold isweq. intro xe.  \nset (is3:= isweqezmap1 _ _ _ ( fibseqhf f g z ye ) xe). \nassert (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 ). \nassert (is4: iscontr (hfiber g z)). apply iscontrhfiberofincl. assumption.\napply ( isapropifcontr is4  ). Defined.\n\n\n\n\n\n\n\n\n(** *** Basics about types of h-level 2 - \"sets\" *)\n\nDefinition isaset ( X : UU ) : UU := forall x x' : X , isaprop ( paths x x' ) .\n\n(* Definition isaset := isofhlevel 2 . *)\n\nNotation isasetdirprod := ( isofhleveldirprod 2 ) .\n\nLemma isasetunit : isaset unit .\nProof . apply ( isofhlevelcontr 2 iscontrunit ) . Defined .\n\nLemma isasetempty : isaset empty .\nProof. apply ( isofhlevelsnprop 1 isapropempty ) .  Defined . \n\nLemma isasetifcontr { X : UU } ( is : iscontr X ) : isaset X .\nProof . intros . apply ( isofhlevelcontr 2 is ) . Defined .\n\nLemma isasetaprop { X : UU } ( is : isaprop X ) : isaset X .\nProof . intros . apply ( isofhlevelsnprop 1 is ) . Defined . \n\n(** The following lemma assert \"uniqueness of identity proofs\" (uip) for sets. *)\n\nLemma uip { X : UU } ( is : isaset X ) { x x' : X } ( e e' : paths x x' ) : paths e e' .\nProof. intros . apply ( proofirrelevance _ ( is x x' ) e e' ) . Defined .  \n\n(** For the theorem about the coproduct of two sets see [ isasetcoprod ] below. *)\n\n\nLemma isofhlevelssnset (n:nat) ( X : UU ) ( is : isaset X ) : isofhlevel ( S (S n) ) X.\nProof. intros n X X0. simpl. unfold isaset in X0.   intros x x' . apply isofhlevelsnprop. set ( int := X0 x x'). assumption . Defined. \n\nLemma isasetifiscontrloops (X:UU): (forall x:X, iscontr (paths x x)) -> isaset X.\nProof. intros X X0. unfold isaset. unfold isofhlevel. intros x x' x0 x0' .   destruct x0. set (is:= X0 x). apply isapropifcontr. assumption.  Defined. \n\nLemma iscontrloopsifisaset (X:UU): (isaset X) -> (forall x:X, iscontr (paths x x)).\nProof. 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.\n\n\n\n(**  A monic subtype of a set is a set. *)\n\nTheorem isasetsubset { X Y : UU } (f: X -> Y) (is1: isaset Y) (is2: isincl  f): isaset X.\nProof. intros. apply  (isofhlevelsninclb (S O)  f is2). apply is1. Defined. \n\n\n\n(** The morphism from hfiber of a map to a set is an inclusion. *)\n\nTheorem isinclfromhfiber { X Y : UU } (f: X -> Y) (is : isaset Y) ( y: Y ) : @isincl (hfiber  f y) X ( @pr1 _ _  ).\nProof. intros. apply isofhlevelfhfiberpr1. assumption. Defined. \n\n\n(** Criterion for a function between sets being an inclusion.  *)\n\n\nTheorem 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 .\nProof. intros .  apply isinclweqonpaths .  intros x x' .  apply ( isweqimplimpl ( @maponpaths _ _ f x x' ) (  inj x x' ) ( isx x x' ) ( isy ( f x ) ( f x' ) ) ) . Defined .   \n\n(** A map from [ unit ] to a set is an inclusion. *)\n\nTheorem isinclfromunit { X : UU } ( f : unit -> X ) ( is : isaset X ) : isincl f .\nProof. intros . apply ( isinclbetweensets f ( isofhlevelcontr 2 ( iscontrunit ) )  is ) .  intros .  destruct x . destruct x' . apply idpath . Defined . \n\n\n\n\n(** ** Isolated points and types with decidable equality. *)\n\n\n(** *** Basic results on complements to a point *)\n\n\nDefinition compl ( X : UU ) ( x : X ):= total2 (fun x':X => neg (paths x x' ) ) .\nDefinition complpair ( X : UU ) ( x : X ) := tpair (fun x':X => neg (paths x x' ) ) .\nDefinition pr1compl ( X : UU ) ( x : X ) := @pr1 _ (fun x':X => neg (paths x x' ) ) .\n\n\nLemma isinclpr1compl ( X : UU ) ( x : X ) : isincl ( pr1compl X x ) .\nProof. intros . apply ( isinclpr1 _ ( fun x' : X => isapropneg _ ) ) . Defined. \n\n\nDefinition recompl ( X : UU ) (x:X): coprod (compl X x) unit -> X := fun u:_ =>\nmatch u with\nii1 x0 => pr1  x0|\nii2 t => x\nend.\n\nDefinition maponcomplincl { X Y : UU } (f:X -> Y)(is: isincl f)(x:X): compl X x -> compl Y (f x):= fun x0':_ =>\nmatch x0' with\ntpair _ x' neqx => tpair _ (f x') (negf  (invmaponpathsincl  _ is x x' ) neqx)\nend.\n\nDefinition maponcomplweq { X Y : UU } (f : weq X Y ) (x:X):= maponcomplincl  f (isofhlevelfweq (S O) f ) x.\n\n\nTheorem isweqmaponcompl { X Y : UU } ( f : weq X Y ) (x:X): isweq (maponcomplweq  f x).\nProof. 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 ))). \nassert (is2: forall x':X, isweq  (negf  (invmaponpathsincl  _ is1 x x'))). intro. \nset (invimpll:= (negf  (@maponpaths _ _ f x x'))). apply (isweqimplimpl  (negf  (invmaponpathsincl  _ is1 x x')) (negf  (@maponpaths _ _ f x x')) (isapropneg _) (isapropneg _)). \nassert (is3: isweq map1).  unfold map1 . apply ( isweqfibtototal  _ _  (fun x':X => weqpair _  ( is2 x' )) ) .  \nassert (is4: isweq map2). apply (isweqfpmap  f  (fun y:Y => neg (paths (f x) y )) ).\nassert (h: forall x0':_, paths (map2 (map1 x0')) (maponcomplweq  f x x0')). intro.  simpl. destruct x0'. simpl. apply idpath.\napply (isweqhomot _ _ h (twooutof3c _ _ is3 is4)).\nDefined.\n\n\nDefinition weqoncompl { X Y : UU } (w: weq X Y) ( x : X ) : weq (compl X x) (compl Y (pr1  w x)):= weqpair  _ (isweqmaponcompl w x).\n\nDefinition 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 ) .\nProof . intros . intro x' . destruct x' as [ x' nexx' ] . apply ( invmaponpathsincl _ ( isinclpr1compl Z _ ) _ _ ) . simpl .  apply idpath .    Defined . \n\n\n\n\n\n(** *** Basic results on types with an isolated point. *)\n\n\n\n\nDefinition isisolated (X:UU)(x:X):= forall x':X, coprod (paths x x' ) (paths x x' -> empty).\n\nDefinition isolated ( T : UU ) := total2 ( fun t : T => isisolated T t ) .\nDefinition isolatedpair ( T : UU ) := tpair ( fun t : T => isisolated T t ) . \nDefinition pr1isolated ( T : UU )  := fun x : isolated T => pr1 x . \n\n\nTheorem isaproppathsfromisolated ( X : UU ) ( x : X ) ( is : isisolated X x ) : forall x' : X, isaprop ( paths x x' ) .\nProof. intros . apply iscontraprop1inv .  intro e .  destruct e . \nset (f:= fun e: paths x x => coconusfromtpair _ e). \nassert (is' : isweq f). apply (onefiber (fun x':X => paths x x' ) x (fun x':X => is x' )).\nassert (is2: iscontr (coconusfromt _ x)). apply iscontrcoconusfromt. \napply (iscontrweqb ( weqpair f is' ) ). assumption. Defined. \n\nTheorem isaproppathstoisolated  ( X : UU ) ( x : X ) ( is : isisolated X x ) : forall x' : X, isaprop ( paths x' x ) .\nProof . intros . apply ( isofhlevelweqf 1 ( weqpathsinv0 x x' ) ( isaproppathsfromisolated X x is x' ) ) . Defined . \n\n\nLemma isisolatedweqf { X Y : UU } (  f : weq X Y ) (x:X) (is2: isisolated _ x) : isisolated _ (f x).\nProof.  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) ). \nassert (phi: paths y (f x)  -> empty). \nassert (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.\n\n\nTheorem isisolatedinclb { X Y : UU } ( f : X -> Y ) ( is : isincl f ) ( x : X ) ( is0 : isisolated _ ( f x ) ) : isisolated _ x .\nProof. 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. \n\n\nLemma disjointl1 (X:UU): isisolated (coprod X unit) (ii2  tt).\nProof. intros.  unfold isisolated. intros x' .  destruct x' as [ x | u ] . apply (ii2  (negpathsii2ii1 x tt )).  destruct u.  apply (ii1  (idpath _ )). Defined.\n\n\n(** *** Weak equivalence [ weqrecompl ] from the coproduct of the complement to an isolated point with [ unit ] and the original type *)\n\nDefinition invrecompl (X:UU)(x:X)(is: isisolated X x): X -> coprod (compl X x) unit:=\nfun x':X => match (is x') with\nii1 e => ii2  tt|\nii2 phi => ii1  (complpair _ _ x' phi)\nend.\n\n\n\nTheorem isweqrecompl (X:UU)(x:X)(is:isisolated X x): isweq (recompl _ x).\nProof. intros. set (f:= recompl _ x). set (g:= invrecompl X x is). unfold invrecompl in g. simpl in g. \n\nassert (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. \n\n\nassert (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). \n\ndestruct u.   \nassert (e1: paths  (g (f (ii2 tt))) (g x)). apply (maponpaths g  p). \nassert (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. \n unfold f. unfold recompl. simpl in e. \nassert (ee: paths e0 x0). apply (proofirrelevance _ (isapropneg (paths x t))). destruct ee.  apply idpath. \nunfold f. unfold g. simpl. destruct u. destruct (is x).  apply idpath. destruct (e (idpath x)).\napply (gradth  f g egf efg). Defined.\n\nDefinition weqrecompl ( X : UU ) ( x : X ) ( is : isisolated _ x ) : weq ( coprod ( compl X x ) unit ) X := weqpair _ ( isweqrecompl X x is ) .\n\n\n(** *** Theorem saying that [ recompl ] commutes up to homotopy with [ maponcomplweq ] *)\n\n\nTheorem 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 ) )  .   \nProof . intros . destruct a as [ ane | t ] . destruct ane as [ a ne ] .  simpl . apply idpath . destruct t . simpl . apply idpath .  Defined . \n\n\n\n(** *** Recomplement on functions *)\n\n\nDefinition 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 ) .\n\nDefinition 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 ) . \n\nDefinition 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') .\nProof . intros. intro a . unfold recomplf . apply ( maponpaths ( recompl Y y ) ( homotcoprodfhomot _ _ _ _ h ( fun t : unit => idpath t ) (invmap (weqrecompl X x isx) a) ) ) .  Defined .  \n\nLemma 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 .\nProof .  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 . \n\nDefinition 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 ) ) .\nProof . 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 . \n\n\nDefinition homotrecomplfidfun { X : UU } ( x : X ) ( isx : isisolated X x ) : homot ( recomplf x x isx ( idfun ( compl X x ) ) ) ( idfun _ ) .\nProof . 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 . \n\n\n\nLemma 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 .\nProof . 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 . \n \n\n\n\n\n(** *** Standard weak equivalence between [ compl T t1 ] and [ compl T t2 ] for isolated [ t1 t2 ] *) \n\nDefinition funtranspos0 { T : UU } ( t1 t2 : T ) ( is2 : isisolated T t2 ) ( x :compl T t1 ) : compl T t2  :=  match ( is2 ( pr1 x ) ) with \nii1 e => match ( is2 t1 ) with ii1 e' => fromempty ( pr2 x ( pathscomp0 ( pathsinv0 e' ) e ) ) | ii2 ne' => complpair T t2 t1 ne' end | \nii2 ne => complpair T t2 ( pr1 x ) ne end .\n\nDefinition 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 _ ) .\nProof. 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 . \n\nDefinition weqtranspos0 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : weq ( compl T t1 ) ( compl T t2 ) . \nProof . intros . set ( f := funtranspos0 t1 t2 is2 ) . set ( g := funtranspos0 t2 t1 is1 ) . split with f .\nassert ( egf : forall x : _ , paths ( g ( f x ) ) x ) . intro x . apply ( homottranspos0t2t1t1t2 t1 t2 is1 is2 ) . \nassert ( efg : forall x : _ , paths ( f ( g x ) ) x ) . intro x . apply ( homottranspos0t2t1t1t2 t2 t1 is2 is1 ) . \napply ( gradth _ _ egf efg ) . Defined .\n\n\n(** *** Transposition of two isolated points *)\n\n\nDefinition funtranspos { T : UU } ( t1 t2 : isolated T )  : T -> T := recomplf ( pr1 t1 ) ( pr1 t2 ) ( pr2 t1 ) ( funtranspos0 ( pr1 t1 ) ( pr1 t2 ) ( pr2 t2 ) ) .\n\nDefinition 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 _ ) .\nProof. 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 . \n\n\nTheorem weqtranspos { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : weq T T .\nProof . intros . set ( f := funtranspos ( tpair _ t1 is1) ( tpair _ t2 is2 ) ) . set ( g := funtranspos ( tpair _ t2 is2 ) ( tpair _ t1 is1 ) ) . split with f .\nassert ( egf : forall t : T , paths ( g ( f t ) ) t ) . intro . apply homottranspost2t1t1t2 .\nassert ( efg : forall t : T , paths ( f ( g t ) ) t ) . intro .  apply homottranspost2t1t1t2 .\napply ( gradth _ _ egf efg ) . Defined .  \n\n\nLemma pathsfuntransposoft1 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1  ) ( is2 : isisolated T t2 ) : paths ( funtranspos ( tpair _ t1 is1 ) ( tpair _ t2 is2 ) t1 ) t2 .\nProof . intros . unfold funtranspos . rewrite ( pathsrecomplfxtoy t1 t2 is1 _ ) . apply idpath .  Defined .\n\nLemma pathsfuntransposoft2 { T : UU } ( t1 t2 : T ) ( is1 : isisolated T t1 ) ( is2 : isisolated T t2 ) : paths ( funtranspos ( tpair _ t1 is1 ) ( tpair _ t2 is2 ) t2 ) t1 .\nProof . 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 .  \n\nLemma 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 .\nProof . 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 . \n\nLemma 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 _ ) .\nProof . intros . intro t .   unfold funcomp . unfold idfun .   \ndestruct ( is1 t ) as [ et1t | net1t ] .  rewrite ( pathsinv0 et1t ) .  rewrite ( pathsfuntransposoft1 _ _ ) .   rewrite ( pathsfuntransposoft2 _ _ ) .  apply idpath . \ndestruct ( is2 t ) as [ et2t | net2t ] .  rewrite ( pathsinv0 et2t ) .  rewrite ( pathsfuntransposoft2 _ _ ) .   rewrite ( pathsfuntransposoft1 _ _ ) .  apply idpath .\nrewrite ( pathsfuntransposofnet1t2 _ _ _ _ _ net1t net2t ) . rewrite ( pathsfuntransposofnet1t2 _ _ _ _ _ net1t net2t ) . apply idpath . Defined . \n\n\n\n\n\n(** *** Types with decidable equality *)\n\n\nDefinition isdeceq (X:UU) : UU :=  forall (x x':X), coprod (paths x x' ) (paths x x' -> empty).\n\nLemma isdeceqweqf { X Y : UU } ( w : weq X Y ) ( is : isdeceq X ) : isdeceq Y .\nProof. 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 . \n\nLemma isdeceqweqb { X Y : UU } ( w : weq X Y ) ( is : isdeceq Y ) : isdeceq X .\nProof . intros . apply ( isdeceqweqf ( invweq w ) is ) . Defined . \n\nTheorem isdeceqinclb { X Y : UU } ( f : X -> Y ) ( is : isdeceq Y ) ( is' : isincl f ) : isdeceq X .\nProof.  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 . \n \nLemma isdeceqifisaprop ( X : UU ) : isaprop X -> isdeceq X .\nProof. intros X is . intros x x' . apply ( ii1 ( proofirrelevance _ is x x' ) ) .  Defined .\n\nTheorem isasetifdeceq (X:UU): isdeceq X -> isaset X.\nProof. intro X . intro is. intros x x' . apply ( isaproppathsfromisolated X x ( is x ) ) .   Defined . \n\n\n\nDefinition booleq { X : UU } ( is : isdeceq X ) ( x x' : X ) : bool .\nProof . intros . destruct ( is x x' ) . apply true . apply false . Defined .    \n\n\nLemma eqfromdnegeq (X:UU)(is: isdeceq X)(x x':X): dneg ( paths x x' ) -> paths x x'.\nProof. intros X is x x' X0. destruct ( is x x' ) . assumption .   destruct ( X0 e ) . Defined .\n\n\n\n\n(** *** [ bool ] is a [ deceq ] type and a set *)\n\n\nTheorem isdeceqbool: isdeceq bool.\nProof. 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. \n\nTheorem isasetbool: isaset bool.\nProof. apply (isasetifdeceq _ isdeceqbool). Defined. \n\n\n\n\n(** *** Splitting of [ X ] into a coproduct defined by a function [ X -> bool ] *)\n\n\nDefinition subsetsplit { X : UU } ( f : X -> bool ) ( x : X ) : coprod ( hfiber f true ) ( hfiber f false ) .\nProof . intros . destruct ( boolchoice ( f x ) ) as [ a | b ] .  apply ( ii1 ( hfiberpair f x a ) ) . apply ( ii2 ( hfiberpair f x b ) ) .  Defined . \n\nDefinition 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.\n\n\nTheorem weqsubsetsplit { X : UU } ( f : X -> bool ) : weq X (coprod ( hfiber f true) ( hfiber f false) ) .\nProof . intros . set ( ff := subsetsplit f ) . set ( gg := subsetsplitinv f ) . split with ff .\nassert ( 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 . \nassert ( 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 . \napply ( gradth _ _ egf efg ) . Defined . \n\n\n\n\n(** ** Semi-boolean hfiber of functions over isolated points *)\n\n\nDefinition eqbx ( X : UU ) ( x : X ) ( is : isisolated X x ) : X -> bool .\nProof. intros X x is x' . destruct ( is x' ) . apply true . apply false . Defined .\n\nLemma iscontrhfibereqbx ( X : UU ) ( x : X ) ( is : isisolated X x ) : iscontr ( hfiber ( eqbx X x is ) true ) .\nProof. 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 . \nunfold 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 . \n\nDefinition bhfiber { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : isisolated Y y ) := hfiber ( fun x : X => eqbx Y y is ( f x ) ) true .\n\nLemma weqhfibertobhfiber { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : isisolated Y y ) : weq ( hfiber f y ) ( bhfiber f y is ) .\nProof . 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 .  \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** *** h-fibers of [ ii1 ] and [ ii2 ] *)\n\n\nTheorem isinclii1 (X Y:UU): isincl  (@ii1 X Y).\nProof. 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). \nassert (h: forall x:X , paths (gf' x) (gf x)). intro. apply idpath. \nassert (is1: isofhlevelf (S O)  gf'). apply (isofhlevelfsnfib O (boolsumfun X Y) true (isasetbool true true)).\nassert (is2: isofhlevelf (S O)  gf). apply (isofhlevelfhomot (S O)  gf' gf h is1).  \napply (isofhlevelff (S O) _ _ is2  (isofhlevelfweq (S (S O) )  (weqcoprodtoboolsum X Y))). Defined. \n\n\nCorollary iscontrhfiberii1x ( X Y : UU ) ( x : X ) : iscontr ( hfiber ( @ii1 X Y ) ( ii1 x ) ) .\nProof. intros . set ( xe1 :=  hfiberpair ( @ii1 _ _ ) x ( idpath ( @ii1 X Y x ) ) ) . apply ( iscontraprop1 ( isinclii1 X Y ( ii1 x ) ) xe1 ) .  Defined .\n\nCorollary neghfiberii1y ( X Y : UU ) ( y : Y ) : neg ( hfiber ( @ii1 X Y ) ( ii2 y ) ) .\nProof. intros . intro xe . destruct xe as [ x e ] . apply ( negpathsii1ii2 _ _ e ) .  Defined. \n\n\n\n\n\nTheorem isinclii2 (X Y:UU): isincl  (@ii2 X Y).\nProof. 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). \nassert (h: forall y:Y , paths (gf' y) (gf y)). intro. apply idpath. \nassert (is1: isofhlevelf (S O)  gf'). apply (isofhlevelfsnfib O (boolsumfun X Y) false (isasetbool false false)).\nassert (is2: isofhlevelf (S O)  gf). apply (isofhlevelfhomot (S O)  gf' gf h is1).  \napply (isofhlevelff (S O)  _ _ is2 (isofhlevelfweq (S (S O)) ( weqcoprodtoboolsum X Y))). Defined. \n\n\nCorollary iscontrhfiberii2y ( X Y : UU ) ( y : Y ) : iscontr ( hfiber ( @ii2 X Y ) ( ii2 y ) ) .\nProof. intros . set ( xe1 :=  hfiberpair ( @ii2 _ _ ) y ( idpath ( @ii2 X Y y ) ) ) . apply ( iscontraprop1 ( isinclii2 X Y ( ii2 y ) ) xe1 ) .  Defined .\n\nCorollary neghfiberii2x ( X Y : UU ) ( x : X ) : neg ( hfiber ( @ii2 X Y ) ( ii1 x ) ) .\nProof. intros . intro ye . destruct ye as [ y e ] . apply ( negpathsii2ii1 _ _ e ) .  Defined. \n\n\n\n\nLemma negintersectii1ii2 { X Y : UU } (z: coprod X Y): hfiber  (@ii1 X Y) z -> hfiber  (@ii2 _ _) z -> empty.\nProof. intros X Y z X0 X1. destruct X0 as [ t x ]. destruct X1 as [ t0 x0 ].  \nset (e:= pathscomp0   x (pathsinv0 x0)). apply (negpathsii1ii2 _ _  e). Defined. \n\n\n(** *** [ ii1 ] and [ ii2 ] map isolated points to isoloated points *)\n\nLemma isolatedtoisolatedii1 (X Y:UU)(x:X)(is:isisolated _ x): isisolated ( coprod X Y ) (ii1 x).\nProof. 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. \n\n\nLemma isolatedtoisolatedii2 (X Y:UU)(y:Y)(is:isisolated _ y): isisolated ( coprod X Y ) (ii2 y).\nProof. 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. \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** *** h-fibers of [ coprodf ] of two functions *)\n\n\nTheorem weqhfibercoprodf1 { X Y X' Y' : UU } (f: X -> X')(g:Y -> Y')(x':X'): weq (hfiber  f x') (hfiber  (coprodf   f g) (ii1  x')).\nProof. intros.  set ( ix := @ii1 X Y ) . set ( ix' := @ii1 X' Y' ) . set ( fpg := coprodf f g ) . set ( fpgix := fun x : X => ( fpg ( ix x ) ) ) .\n\nassert ( w1 : weq ( hfiber f x' ) ( hfiber fpgix ( ix' x' ) ) ) . apply ( samehfibers f ix' ( isinclii1 _ _ ) x' ) .\nassert ( w2 : weq ( hfiber fpgix ( ix' x' ) ) ( hfiber fpg ( ix' x' ) ) ) . split with (hfibersgftog  ix fpg ( ix' x' ) ) . unfold isweq. intro y .  \n\nset (u:= invezmaphf ix fpg ( ix' x' ) y).\nassert (is: isweq u). apply isweqinvezmaphf. \n\napply  (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 ) ) .\n\napply ( weqcomp w1 w2 ) .\nDefined.\n\n\nTheorem weqhfibercoprodf2 { X Y X' Y' : UU } (f: X -> X')(g:Y -> Y')(y':Y'): weq (hfiber  g y') (hfiber  (coprodf   f g) (ii2  y')).\nProof. intros.  set ( iy := @ii2 X Y ) . set ( iy' := @ii2 X' Y' ) . set ( fpg := coprodf f g ) . set ( fpgiy := fun y : Y => ( fpg ( iy y ) ) ) .\n\nassert ( w1 : weq ( hfiber g y' ) ( hfiber fpgiy ( iy' y' ) ) ) . apply ( samehfibers g iy' ( isinclii2 _ _ ) y' ) .\nassert ( w2 : weq ( hfiber fpgiy ( iy' y' ) ) ( hfiber fpg ( iy' y' ) ) ) . split with (hfibersgftog  iy fpg ( iy' y' ) ) . unfold isweq. intro y .  \n\nset (u:= invezmaphf iy fpg ( iy' y' ) y).\nassert (is: isweq u). apply isweqinvezmaphf. \n\napply  (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 ) . \n\napply ( weqcomp w1 w2 ) .\nDefined.\n\n \n\n\n\n(** *** Theorem saying that coproduct of two functions of h-level n is of h-level n *)\n\n\n\nTheorem 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).\nProof. 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. \n\n\n\n\n\n(** *** Theorems about h-levels of coproducts and their component types *)\n\n\nTheorem isofhlevelsnsummand1 ( n : nat ) ( X Y : UU ) : isofhlevel ( S n ) ( coprod X Y ) -> isofhlevel ( S n ) X .\nProof. intros n X Y is . apply ( isofhlevelXfromfY ( S n ) ( @ii1 X Y ) ( isofhlevelfsnincl n _ ( isinclii1 _ _ ) ) is ) .  Defined.\n\n\nTheorem isofhlevelsnsummand2 ( n : nat ) ( X Y : UU ) : isofhlevel ( S n ) ( coprod X Y ) -> isofhlevel ( S n ) Y .\nProof. intros n X Y is . apply ( isofhlevelXfromfY ( S n ) ( @ii2 X Y ) ( isofhlevelfsnincl n _ ( isinclii2 _ _ ) ) is ) .  Defined.\n\n\nTheorem 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 ) .\nProof. 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 . \n\n\nLemma isasetcoprod ( X Y : UU ) ( isx : isaset X ) ( isy : isaset Y ) : isaset ( coprod X Y ) .\nProof. intros . apply ( isofhlevelssncoprod 0 _ _ isx isy ) . Defined . \n\n\n\n(** *** h-fibers of the sum of two functions [ sumofmaps f g ] *)\n\n\nLemma 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 .\nProof. 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 .  \nDefined.\n\nLemma 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 ) .\nProof. 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 .\n\nTheorem 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 ) .\nProof. intros . set ( ff := coprodofhfiberstohfiber f g z ) . set ( gg := hfibertocoprodofhfibers f g z ) . split with ff .  \nassert ( 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 . \nassert ( 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 .\napply ( gradth _ _ eggff effgg ) . Defined .  \n\n\n\n\n(** *** Theorem saying that the sum of two functions of h-level ( S ( S n ) ) is of hlevel ( S ( S n ) ) *)\n\n\nTheorem 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 ) .\nProof . intros . intro z .  set ( w := weqhfibersofsumofmaps f g z ) .  set ( is := isofhlevelssncoprod n _ _ ( isf z ) ( isg z ) ) .  apply ( isofhlevelweqf _ w is ) .  Defined . \n\n\n\n(** *** Theorem saying that the sum of two functions of h-level n with non-intersecting images is of h-level n *)\n\n\nLemma 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 .\nProof. 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 . \n\n\nLemma 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 ) .\nProof. 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 .  \n\nLemma 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 ) .\nProof. 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 .  \n\n\n\nTheorem 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 ) .\nProof. 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 ) ) ) . \napply 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 . \n\n\n\n\n\n\n\n(** *** Coproducts and complements *)\n\n\nDefinition tocompltoii1x (X Y:UU)(x:X): coprod (compl X x) Y -> compl (coprod X Y) (ii1  x).\nProof. intros X Y x X0. destruct X0 as [ c | y ] .  split with (ii1  (pr1  c)). \nassert (e: neg(paths x (pr1 c) )). apply (pr2  c). apply (negf  (invmaponpathsincl  ( @ii1 _ _ ) (isinclii1 X Y) _ _) e). \nsplit with (ii2  y). apply (negf  (pathsinv0 ) (negpathsii2ii1 x y)). Defined.\n\n\nDefinition fromcompltoii1x (X Y:UU)(x:X): compl (coprod X Y) (ii1  x) ->  coprod (compl X x) Y.\nProof. intros X Y x X0. destruct X0 as [ t x0 ].  destruct t as [ x1 | y ]. \nassert (ne: neg (paths x x1 )). apply (negf  (maponpaths ( @ii1 _ _ ) ) x0). apply (ii1  (complpair _ _ x1 ne )). apply (ii2  y). Defined. \n\n\nTheorem isweqtocompltoii1x (X Y:UU)(x:X): isweq (tocompltoii1x X Y x).\nProof. intros. set (f:= tocompltoii1x X Y x). set (g:= fromcompltoii1x X Y x).\nassert (egf:forall nexy:_ , paths (g (f nexy)) nexy). intro. destruct nexy as [ c | y ]. destruct c as [ t x0 ]. simpl. \nassert (e: paths (negf (maponpaths (@ii1 X Y)) (negf (invmaponpathsincl  (@ii1 X Y) (isinclii1 X Y) x t) x0)) x0). apply (isapropneg (paths x t) ). \napply (maponpaths (fun ee: neg (paths x t ) => ii1  (complpair X x t ee))  e). apply idpath.\n\nassert (efg: forall neii1x:_, paths (f (g neii1x)) neii1x). intro.  destruct neii1x as [ t x0 ]. destruct t as [ x1 | y ].  simpl. \nassert (e: paths  (negf (invmaponpathsincl (@ii1 X Y) (isinclii1 X Y) x x1 ) (negf (maponpaths (@ii1 X Y) ) x0)) x0). apply (isapropneg (paths _ _ )  ).\napply (maponpaths (fun ee: (neg (paths (ii1 x) (ii1 x1))) => (complpair _ _ (ii1 x1) ee))  e). simpl. \nassert (e: paths (negf pathsinv0 (negpathsii2ii1 x y)) x0). apply (isapropneg (paths _ _ ) ).\napply (maponpaths   (fun ee: (neg (paths (ii1 x) (ii2 y) )) => (complpair _ _ (ii2 y) ee))  e). \napply (gradth  f g egf efg). Defined.\n\n\nDefinition tocompltoii2y (X Y:UU)(y:Y): coprod X (compl Y y) -> compl (coprod X Y) (ii2  y).\nProof. intros X Y y X0. destruct X0 as [ x | c ]. split with (ii1  x). apply (negpathsii2ii1 x y ). \nsplit with (ii2  (pr1  c)). assert (e: neg(paths y (pr1  c) )). apply (pr2  c). apply (negf  (invmaponpathsincl  ( @ii2 _ _ ) (isinclii2 X Y) _ _ ) e). \nDefined.\n\n\n\nDefinition fromcompltoii2y (X Y:UU)(y:Y): compl (coprod X Y) (ii2  y) ->  coprod X (compl Y y).\nProof. intros X Y y X0. destruct X0 as [ t x ].  destruct t as [ x0 | y0 ]. apply (ii1  x0). \nassert (ne: neg (paths y y0 )). apply (negf  (maponpaths ( @ii2 _ _ ) ) x). apply (ii2  (complpair _ _ y0 ne)). Defined. \n\n\nTheorem isweqtocompltoii2y (X Y:UU)(y:Y): isweq (tocompltoii2y X Y y).\nProof. intros. set (f:= tocompltoii2y X Y y). set (g:= fromcompltoii2y X Y y).\nassert (egf:forall nexy:_ , paths (g (f nexy)) nexy). intro. destruct nexy as [ x | c ]. \napply idpath. destruct c as [ t x ]. simpl. \nassert (e: paths (negf (maponpaths (@ii2 X Y) ) (negf (invmaponpathsincl (@ii2 X Y) (isinclii2 X Y) y t) x)) x). apply (isapropneg (paths y t ) ). \napply (maponpaths (fun ee: neg ( paths y t ) => ii2  (complpair _ y t ee))  e). \n\nassert (efg: forall neii2x:_, paths (f (g neii2x)) neii2x). intro.  destruct neii2x as [ t x ]. destruct t as [ x0 | y0 ].  simpl. \nassert (e: paths (negpathsii2ii1 x0 y) x). apply (isapropneg (paths _ _ ) ).\napply (maponpaths   (fun ee: (neg (paths (ii2 y) (ii1 x0)  )) => (complpair _ _ (ii1 x0) ee))  e). simpl.\nassert (e: paths  (negf (invmaponpathsincl _ (isinclii2 X Y) y y0 ) (negf (maponpaths (@ii2 X Y) ) x)) x). apply (isapropneg (paths _ _ )  ).\napply (maponpaths (fun ee: (neg (paths (ii2 y) (ii2 y0)  )) => (complpair _ _ (ii2 y0) ee))  e). \napply (gradth f g egf efg). Defined.\n\n\n\n\n\n\n\nDefinition tocompltodisjoint (X:UU): X -> compl (coprod X unit) (ii2  tt) := fun x:_ => complpair _ _ (ii1  x) (negpathsii2ii1 x tt).\n\nDefinition fromcompltodisjoint (X:UU): compl (coprod X unit) (ii2  tt) -> X.\nProof. intros X X0. destruct X0 as [ t x ].  destruct t as [ x0 | u ] . assumption.  destruct u. apply (fromempty (x (idpath (ii2 tt)))). Defined.\n\n\nLemma isweqtocompltodisjoint (X:UU): isweq (tocompltodisjoint X).\nProof. intros. set (ff:= tocompltodisjoint X). set (gg:= fromcompltodisjoint X). \nassert (egf: forall x:X, paths (gg (ff x)) x).  intro.  apply idpath.\nassert (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. \n\n\nDefinition weqtocompltodisjoint ( X : UU ) := weqpair _ ( isweqtocompltodisjoint X ) .\n\nCorollary isweqfromcompltodisjoint (X:UU): isweq (fromcompltodisjoint X).\nProof. intros. apply (isweqinvmap  ( weqtocompltodisjoint X ) ). Defined. \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** Decidable propositions and decidable inclusions *)\n\n(** *** Decidable propositions [ isdecprop ] *)\n\nDefinition isdecprop ( X : UU ) := iscontr ( coprod X ( neg X ) ) .\n\n\nLemma isdecproptoisaprop ( X : UU ) ( is : isdecprop X ) : isaprop X .\nProof. intros X is . apply ( isofhlevelsnsummand1 0 _ _ ( isapropifcontr is ) ) . Defined .  \nCoercion isdecproptoisaprop : isdecprop >-> isaprop .\n\nLemma isdecpropif ( X : UU ) : isaprop X -> ( coprod X ( neg X ) ) -> isdecprop X .\nProof. intros X is a . assert ( is1 : isaprop ( coprod X ( neg X ) ) ) . apply isapropdec . assumption .   apply ( iscontraprop1 is1 a ) . Defined.\n\nLemma isdecpropfromiscontr { X : UU } ( is : iscontr X ) : isdecprop X .\nProof. intros . apply ( isdecpropif _ (  is ) ( ii1 ( pr1 is ) ) ) . Defined.\n\nLemma isdecpropempty : isdecprop empty .\nProof. apply ( isdecpropif _ isapropempty ( ii2 ( fun a : empty => a ) ) ) . Defined.\n\nLemma isdecpropweqf { X Y : UU } ( w : weq X Y ) ( is : isdecprop X ) : isdecprop Y .\nProof. 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 .\n\nLemma isdecpropweqb { X Y : UU } ( w : weq X Y ) ( is : isdecprop Y ) : isdecprop X .\nProof. 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 .\n\nLemma isdecproplogeqf { X Y : UU } ( isx : isdecprop X ) ( isy : isaprop Y ) ( lg : X <-> Y ) : isdecprop Y .\nProof . intros. set ( w := weqimplimpl ( pr1 lg ) ( pr2 lg ) isx isy ) . apply ( isdecpropweqf w isx ) . Defined .\n\nLemma isdecproplogeqb { X Y : UU } ( isx : isaprop X ) ( isy : isdecprop Y ) ( lg : X <-> Y ) : isdecprop X .\nProof . intros. set ( w := weqimplimpl ( pr1 lg ) ( pr2 lg ) isx isy ) . apply ( isdecpropweqb w isy ) . Defined .    \n\n\n\nLemma isdecpropfromneg { X : UU } ( ne : neg X ) : isdecprop X .\nProof. intros . apply ( isdecpropweqb ( weqtoempty ne ) isdecpropempty ) . Defined .  \n\nLemma isdecproppaths { X : UU } ( is : isdeceq X ) ( x x' : X ) : isdecprop ( paths x x' ) .\nProof. intros . apply ( isdecpropif _ ( isasetifdeceq _ is x x' ) ( is x x' ) ) .  Defined .\n\nLemma isdeceqif { X : UU } ( is : forall x x' : X , isdecprop ( paths x x' ) ) : isdeceq X .\nProof . intros . intros x x' . apply ( pr1 ( is x x' ) ) . Defined . \n\nLemma isaninv1 (X:UU): isdecprop X  -> isaninvprop X.\nProof. intros X is1. unfold isaninvprop. set (is2:= pr1  is1). simpl in is2. \nassert (adjevinv: dneg X -> X). intro X0.  destruct is2 as [ a | b ].  assumption. destruct (X0 b). \nassert (is3: isaprop (dneg X)). apply (isapropneg (X -> empty)). apply (isweqimplimpl  (todneg X) adjevinv is1 is3). Defined. \n\n\nTheorem isdecpropfibseq1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) : isdecprop X -> isaprop Z -> isdecprop Y .\nProof . 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 .\n\nTheorem isdecpropfibseq0 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) : isdecprop Y -> isdeceq Z -> isdecprop X .\nProof . intros X Y Z f g z fs isy isz . assert ( isg : isofhlevelf 1 g ) . apply ( isofhlevelffromXY 1 g ( isdecproptoisaprop _ isy ) ( isasetifdeceq _ isz ) ) . \nassert ( isp : isaprop X ) . apply ( isofhlevelXfromg 1 f g z fs isg ) . \ndestruct ( pr1 isy ) as [ y | ny ] .  apply ( isdecpropfibseq1 _ _ y ( fibseq1 f g z fs y ) ( isdecproppaths isz ( g y ) z ) ( isdecproptoisaprop _ isy ) ) . \napply ( isdecpropif _ isp ( ii2  ( negf f ny ) ) ) . Defined. \n\nTheorem isdecpropdirprod { X Y : UU } ( isx : isdecprop X ) ( isy : isdecprop Y ) : isdecprop ( dirprod X Y ) .\nProof. 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.\n\nLemma fromneganddecx { X Y : UU } ( isx : isdecprop X ) ( nf : neg ( dirprod X Y ) ) : coprod ( neg X ) ( neg Y ) .\nProof . intros .  destruct ( pr1 isx ) as [ x | nx ] .  set ( ny := negf ( fun y : Y => dirprodpair x y ) nf ) . apply ( ii2 ny ) .   apply ( ii1 nx ) . Defined .\n\nLemma fromneganddecy { X Y : UU } ( isy : isdecprop Y ) ( nf : neg ( dirprod X Y ) ) : coprod ( neg X ) ( neg Y ) .\nProof . intros .  destruct ( pr1 isy ) as [ y | ny ] .  set ( nx := negf ( fun x : X => dirprodpair x y ) nf ) . apply ( ii1 nx ) . apply ( ii2 ny ) .   Defined .\n\n\n(** *** Paths to and from an isolated point form a decidable proposition *)\n\nLemma isdecproppathsfromisolated ( X : UU ) ( x : X ) ( is : isisolated X x ) ( x' : X ) : isdecprop ( paths x x' ) .\nProof. intros . apply isdecpropif . apply isaproppathsfromisolated .   assumption .  apply ( is x' ) .  Defined .\n\nLemma isdecproppathstoisolated  ( X : UU ) ( x : X ) ( is : isisolated X x ) ( x' : X ) : isdecprop ( paths x' x ) .\nProof . intros . apply ( isdecpropweqf ( weqpathsinv0 x x' ) ( isdecproppathsfromisolated X x is x' ) ) . Defined .  \n\n\n(** *** Decidable inclusions *)\n\n\n\nDefinition isdecincl {X Y:UU} (f :X -> Y) := forall y:Y, isdecprop ( hfiber f y ). \nLemma isdecincltoisincl { X Y : UU } ( f : X -> Y ) : isdecincl f -> isincl f .\nProof. intros X Y f is . intro y . apply ( isdecproptoisaprop _ ( is y ) ) . Defined.\nCoercion isdecincltoisincl : isdecincl >-> isincl .\n\nLemma isdecinclfromisweq { X Y : UU } ( f : X -> Y ) : isweq f -> isdecincl f .\nProof. intros X Y f iswf .  intro y .  apply ( isdecpropfromiscontr ( iswf y ) ) . Defined .\n\nLemma isdecpropfromdecincl { X Y : UU } ( f : X -> Y ) : isdecincl f -> isdecprop Y -> isdecprop X .\nProof. 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 . \n\n\nLemma isdecinclii1 (X Y: UU): isdecincl ( @ii1 X Y ) .\nProof. intros. intro y . destruct y as [ x | y ] . apply ( isdecpropif _ ( isinclii1 X Y ( ii1 x ) ) ( ii1 (hfiberpair  (@ii1 _ _ )  x (idpath _ )) ) ) .   \n apply ( isdecpropif _ ( isinclii1 X Y ( ii2 y ) ) ( ii2 ( neghfiberii1y X Y y ) ) ) .  Defined. \n\n \nLemma isdecinclii2 (X Y: UU): isdecincl ( @ii2 X Y ) .\nProof. intros. intro y . destruct y as [ x | y ] .  apply ( isdecpropif _ ( isinclii2 X Y ( ii1 x ) ) ( ii2 ( neghfiberii2x X Y x ) ) ) . \napply ( isdecpropif _ ( isinclii2 X Y ( ii2 y ) ) ( ii1 (hfiberpair  (@ii2 _ _ )  y (idpath _ )) ) ) .   Defined. \n\n\nLemma isdecinclpr1 { X : UU } ( P : X -> UU ) ( is : forall x : X , isdecprop ( P x ) ) : isdecincl ( @pr1 _ P ) .\nProof . intros . intro x . assert ( w : weq ( P x ) ( hfiber (@pr1 _ P )  x ) ) . apply ezweqpr1 .  apply ( isdecpropweqf w ( is x ) ) . Defined . \n\n\nTheorem isdecinclhomot { X Y : UU } ( f g : X -> Y ) ( h : forall x : X , paths ( f x ) ( g x ) ) ( is : isdecincl f ) : isdecincl g .\nProof. intros . intro y . apply ( isdecpropweqf ( weqhfibershomot f g h y ) ( is y ) ) . Defined . \n\n\nTheorem isdecinclcomp { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isf : isdecincl f ) ( isg : isdecincl g ) : isdecincl ( fun x : X => g ( f x ) ) .\nProof. 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 .  \nassert ( ww : forall y : Y , weq ( hfiber f y ) ( hfiber gf ( g y ) ) ) . intro .  apply ( samehfibers f g ) . apply ( isdecincltoisincl _ isg ) .  \n  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 .\n\n(** 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\". *)\n\nTheorem isdecinclf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isg : isincl g ) ( isgf : isdecincl ( fun x : X => g ( f x ) ) ) : isdecincl f .\nProof. 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 . \n\n(** *)\n\n\nTheorem isdecinclg { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isf : isweq f ) ( isgf : isdecincl ( fun x : X => g ( f x ) ) ) : isdecincl g .\nProof. 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 . \n\n\n\n(** *** Decibadle inclusions and isolated points *)\n\nTheorem isisolateddecinclf { X Y : UU } ( f : X -> Y ) ( x : X ) : isdecincl f -> isisolated X x -> isisolated Y ( f x ) .\nProof .  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 . \n\n\n\n(** *** Decidable inclusions and coprojections *)\n\n\nDefinition negimage { X Y : UU } ( f : X -> Y ) := total2 ( fun y : Y => neg ( hfiber f y ) ) .\nDefinition negimagepair { X Y : UU } ( f : X -> Y ) := tpair ( fun y : Y => neg ( hfiber f y ) ) .\n\nLemma isinclfromcoprodwithnegimage { X Y : UU } ( f : X -> Y ) ( is : isincl f ) : isincl ( sumofmaps f ( @pr1 _ ( fun y : Y => neg ( hfiber f y ) ) ) ) . \nProof .  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 . \n\n\nDefinition iscoproj { X Y : UU } ( f : X -> Y ) := isweq ( sumofmaps f ( @pr1 _ ( fun y : Y => neg ( hfiber f y ) ) ) ) . \n\nDefinition weqcoproj { X Y : UU } ( f : X -> Y ) ( is : iscoproj f ) : weq ( coprod X ( negimage f ) ) Y := weqpair _ is . \n\nTheorem iscoprojfromisdecincl { X Y : UU } ( f : X -> Y ) ( is : isdecincl f ) : iscoproj f .\nProof. 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 . \n\nTheorem isdecinclfromiscoproj { X Y : UU } ( f : X -> Y ) ( is : iscoproj f ) : isdecincl f .\nProof . 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 . \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** Results using full form of the functional extentionality axioms. \n\nSummary: 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.\n\nNote : some of the results above this point in code use a very limitted form of functional extensionality . See [ funextempty ] .  \n\n*)\n\n\n(** *** Axioms and their basic corollaries *)\n\n(** etacorrection *)\n\nAxiom etacorrection: forall T:UU, forall P:T -> UU, forall f: (forall t:T, P t), paths f (fun t:T => f t). \n\nLemma isweqetacorrection { T : UU } (P:T -> UU): isweq (fun f: forall t:T, P t => (fun t:T => f t)).\nProof. 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. \n\nDefinition weqeta { T : UU } (P:T -> UU) := weqpair _ ( isweqetacorrection P ) .\n\nLemma 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. \nProof. intros T P s1 s2 X. set (ew := weqeta P). apply (invmaponpathsweq ew s1 s2 X). Defined. \n\nDefinition etacor { X Y : UU } (f:X -> Y) : paths f (fun x:X => f x) := etacorrection _ (fun T:X => Y) f.\n\nLemma etacoronpaths { X Y : UU } (f1 f2 : X->Y) : paths (fun x:X => f1 x) (fun x:X => f2 x) -> paths f1 f2. \nProof. intros X Y f1 f2 X0. set (ec:= weqeta (fun x:X => Y) ). apply (invmaponpathsweq  ec f1 f2 X0). Defined.\n\n\n(** Dependent functions and sections up to homotopy I *)\n\n\nDefinition toforallpaths { T : UU }  (P:T -> UU) (f g :forall t:T, P t) : (paths f g) -> (forall t:T, paths (f t) (g t)).\nProof. intros T P f g X t. destruct X. apply (idpath (f t)). Defined. \n\n\nDefinition 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))).\n\nDefinition 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.\n\nDefinition sectohfibertosec { X : UU } (P:X -> UU): forall a: forall x:X, P x, paths (hfibertosec _  (sectohfiber _ a)) a := fun a:_ => (pathsinv0 (etacorrection _ _ a)).\n\n\n\n(** *** Deduction of functional extnsionality for dependent functions (sections) from functional extensionality of usual functions *)\n\nAxiom funextfunax : forall (X Y:UU)(f g:X->Y),  (forall x:X, paths (f x) (g x)) -> (paths f g). \n\n\nLemma isweqlcompwithweq { X X' : UU} (w: weq X X') (Y:UU) : isweq (fun a:X'->Y => (fun x:X => a (w x))).\nProof. 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')). \nset (egf:= (fun a:X'->Y => funextfunax X' Y (fun x':X' => (g (f a)) x') a (fun x': X' =>  maponpaths a  (homotweqinvweq w x')))).\nset (efg:= (fun a:X->Y => funextfunax X Y (fun x:X => (f (g a)) x) a (fun x: X =>  maponpaths a  (homotinvweqweq w x)))). \napply (gradth  f g egf efg). Defined.\n\n\n\nLemma isweqrcompwithweq { Y Y':UU } (w: weq Y Y')(X:UU): isweq (fun a:X->Y => (fun x:X => w (a x))).\nProof. 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))). \nset (egf:= (fun a:X->Y => funextfunax X Y (fun x:X => (g (f a)) x) a (fun x: X => (homotinvweqweq w (a x))))).\nset (efg:= (fun a':X->Y' => funextfunax X Y' (fun x:X => (f (g a')) x) a' (fun x: X =>  (homotweqinvweq w (a' x))))). \napply (gradth  f g egf efg). Defined.\n\n\n\nTheorem funcontr { X : UU } (P:X -> UU) : (forall x:X, iscontr (P x)) -> iscontr (forall x:X, P x).\nProof. 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).  \nassert (X1:iscontr T2).  apply (isweqrcompwithweq  w1 X (fun x:X => x)). \napply ( iscontrretract  _ _  (sectohfibertosec P ) X1). Defined. \n\nCorollary funcontrtwice { X : UU } (P: X-> X -> UU)(is: forall (x x':X), iscontr (P x x')): iscontr (forall (x x':X), P x x').\nProof. intros. \nassert (is1: forall x:X, iscontr (forall x':X, P x x')). intro. apply (funcontr _ (is x)). apply (funcontr _ is1). Defined. \n\n\n(** 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 \nof functional extensionality for sections of general families. The proof uses only [funcontr] which is an axiom i.e. its type satisfies [ isaprop ].  *)\n\n\nLemma 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))).\nProof. 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)).\n\nassert (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. \n\nassert (eetap: forall u:Y, paths (etap u) u). intro. unfold etap. destruct u as [t x ]. simpl.\n\n\nset (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)). \n\nassert (isweqff: isweq ff). apply (isweqfpmap  ( weqeta P ) (fun f: forall t:T, P t => forall t:T, paths (f t) (g t)) ). \n\nassert (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)).  \n\napply (eee (tpair _ t x)). assert (eps0: forall u: Y, paths (p (s u)) u). intro. apply (pathscomp0   (eps u) (eetap u)). \n \napply ( iscontrretract p s eps0). assumption. Defined. \n\n\n\nTheorem isweqtoforallpaths { T : UU } (P:T -> UU)( f g: forall t:T, P t) : isweq (toforallpaths P f g). \nProof. 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.  \nassert (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. \n\n\nTheorem 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)) .\nProof. intros. split with (toforallpaths P f g). apply isweqtoforallpaths. Defined. \n\n\nDefinition 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) .\n\nDefinition 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.\n\n(** 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]. *) \n\nTheorem isweqfunextsec { T : UU } (P:T -> UU)(f g : forall t:T, P t) : isweq (funextsec P f g).\nProof. intros. apply (isweqinvmap ( weqtoforallpaths _  f g ) ). Defined. \n\nDefinition 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 ) .\n\n\n\n \n\n\n(** ** Sections of \"double fibration\" [(P: T -> UU)(PP: forall t:T, P t -> UU)] and pairs of sections *)\n\n\n\n(** *** General case *)\n\nDefinition 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).\nProof. intros X P PP X0 x. destruct X0 as [ t x0 ]. split with (t x). apply (x0 x). Defined.\n\n\nDefinition 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)).\nProof. intros X P PP X0. split with (fun x:X => pr1  (X0 x)). apply (fun x:X => pr2  (X0 x)). Defined.\n\nLemma 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). \nProof. 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 ). \nassert (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. \n\napply (invmaponpathsweq ( weqpair ff X0 ) _ _ ee). Defined. \n\n\n\nDefinition 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.\nProof. intros.  destruct ss as [ t x ]. unfold foralltototal. unfold totaltoforall.  simpl.  set (et:= fun x:X => t x). \n\nassert (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).  \n\nassert (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))). \nassert (eee: paths x (fun x0:X => x x0)). apply etacorrection. destruct eee. apply idpath. destruct ee. apply pathsinv0. assumption. Defined. \n\n\n\nDefinition 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.\nProof. 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.\n\nTheorem isweqforalltototal { X : UU } ( P : X -> UU ) ( PP : forall x:X, P x -> UU ) : isweq (foralltototal P PP).\nProof. intros.  apply (gradth  (foralltototal P PP) (totaltoforall P PP) (foralltototaltoforall P PP) (totaltoforalltototal P PP)). Defined. \n\nTheorem isweqtotaltoforall { X : UU } (P:X->UU)(PP:forall x:X, P x -> UU): isweq (totaltoforall P PP).\nProof. intros.  apply (gradth   (totaltoforall P PP) (foralltototal P PP)  (totaltoforalltototal P PP) (foralltototaltoforall P PP)). Defined. \n\nDefinition weqforalltototal { X : UU } ( P : X -> UU ) ( PP : forall x:X, P x -> UU ) := weqpair _ ( isweqforalltototal P PP ) .\n\nDefinition weqtotaltoforall { X : UU } ( P : X -> UU ) ( PP : forall x:X, P x -> UU ) := invweq ( weqforalltototal P PP ) . \n\n\n\n(** *** Functions to a dependent sum (to a [ total2 ]) *)\n\nDefinition 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 ) .\n\n\n(** *** Functions to direct product *)\n\n(** Note: we give direct proofs for this special case. *)\n\n\nDefinition 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 ) ) ) .\n\nDefinition 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 .\n\nTheorem weqfuntoprodtoprod ( X Y Z : UU ) : weq ( X -> dirprod Y Z ) ( dirprod ( X -> Y ) ( X -> Z ) ) .\nProof. intros. set ( f := @funtoprodtoprod X Y Z ) . set ( g := @prodtofuntoprod X Y Z ) . split with f . \nassert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . apply funextfun .  intro x .  simpl . apply pathsinv0 . apply tppr . \nassert ( 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 .\napply ( gradth _ _ egf efg ) . Defined .    \n  \n\n\n\n\n\n\n(** ** Homotopy fibers of the map [forall x:X, P x -> forall x:X, Q x] *) \n\n(** *** General case *)\n\nDefinition 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) := \nfun s: forall x:X, P x => (fun x:X => (f x) (s x)).\n\nDefinition 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)).\n\n\n\nDefinition 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).\nProof. intro. intro. intro. intro. intro.  unfold hfiber. \n\nset (map1:= totalfun (fun pointover : forall x : X, P x =>\n      paths (fun x : X => f x (pointover x)) s) (fun pointover : forall x : X, P x =>\n      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 )).\n\nset (map2 := totaltoforall P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))).  \n\nset (themap := fun a:_ => map2 (map1 a)). assumption. Defined. \n\n\n\nDefinition 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.\nProof.  intro. intro. intro. intro.   intro. unfold hfiber. \n\nset (map2inv := foralltototal P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))).\nset (map1inv :=  totalfun (fun pointover : forall x : X, P x =>\n      forall x:X, paths  ((f x) (pointover x)) (s x)) (fun pointover : forall x : X, P x =>\n      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)).\nset (themap := fun a:_=> map1inv (map2inv a)). assumption. Defined. \n\n\nTheorem 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).\nProof. intro. intro. intro. intro. intro. \n\nset (map1:= totalfun (fun pointover : forall x : X, P x =>\n      paths  (fun x : X => f x (pointover x)) s) (fun pointover : forall x : X, P x =>\n      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)).\n\nset (map2 := totaltoforall P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))).  \n\nassert (is1: isweq map1). apply (isweqfibtototal _ _ (fun pointover: forall x:X, P x => weqtoforallpaths _ (fun x : X => f x (pointover x)) s )).\n\nassert (is2: isweq map2). apply isweqtotaltoforall.\n\napply (twooutof3c map1 map2 is1 is2). Defined.\n\n\nDefinition 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 ) .\n\n\n\nTheorem 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).\nProof. intro. intro. intro. intro. intro. \n\nset (map2inv := foralltototal P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))).\n\nassert (is2: isweq map2inv). apply (isweqforalltototal P (fun x:X => (fun pointover : P x => paths (f x pointover) (s x)))).\n\nset (map1inv :=  totalfun (fun pointover : forall x : X, P x =>\n      forall x:X, paths  ((f x) (pointover x)) (s x)) (fun pointover : forall x : X, P x =>\n      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)).\n\nassert (is1: isweq map1inv). \n\n(* ??? in this place 8.4 (actually trunk to 8.5) hangs if the next command is \n\napply (isweqfibtototal _ _ (fun pointover: forall x:X, P x => weqfunextsec _ (fun x : X => f x (pointover x)) s ) ).\n\nand no -no-sharing option is turned on. It also hangs on\n\nexact (isweqfibtototal (fun pointover : forall x : X, P x =>\n                forall x : X, paths (f x (pointover x)) (s x)) (fun pointover : forall x : X, P x =>\n                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 ) ).\n\nfor 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\". \n\n*)\n\nOpaque funextsec . apply (isweqfibtototal _ _ (fun pointover: forall x:X, P x => weqfunextsec _ (fun x : X => f x (pointover x)) s ) ). \napply (twooutof3c map2inv map1inv is2 is1). Defined. \n\nTransparent funextsec.\n\nDefinition 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 ) .\n\n\n\n(** *** The weak equivalence  between section spaces (dependent products) defined by a family of weak equivalences  [ weq ( P x ) ( Q x ) ] *)\n\n\n\n\nCorollary isweqmaponsec { X : UU } (P Q : X-> UU) (f: forall x:X, weq ( P x ) ( Q x) ) : isweq (maponsec _ _ f). \nProof. intros. unfold isweq.  intro y.\nassert (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. \napply (iscontrweqb  (weqhfibertoforall P Q f y) is1 ). Defined. \n\nDefinition weqonseqfibers { X : UU } (P Q : X-> UU) (f: forall x:X, weq ( P x ) ( Q x )) := weqpair _ ( isweqmaponsec P Q f ) .\n\n\n(** *** Composition of functions with a weak equivalence on the right *)\n\nDefinition  weqffun ( X : UU ) { Y Z : UU } ( w : weq Y Z ) : weq ( X -> Y ) ( X -> Z ) := weqonseqfibers _ _ ( fun x : X => w ) . \n\n\n\n\n\n\n\n\n(** ** The map between section spaces (dependent products) defined by the map between the bases [ f: Y -> X ] *)\n\n\n(** *** General case *)\n\n\nDefinition 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))).\n\nLemma 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). \nProof. intros. unfold maponsec1l0.   apply idpath. Defined. \n\n\nLemma 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).\nProof. intros.  \n\nset (map:= fun ff: total2 (fun f0:X->X => forall x:X, paths (f0 x) x) => maponsec1l0 P (pr1  ff) (pr2  ff) s x).\nassert (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. \n\n\nTheorem isweqmaponsec1 { X Y : UU } (P:Y -> UU)(f: weq X Y ) : isweq (maponsec1 P f).\nProof. intros.\n \nset (map:= maponsec1  P f).\nset (invf:= invmap f). set (e1:= homotweqinvweq f). set (e2:= homotinvweqweq f ).\nset (im1:= fun sx: forall x:X, P (f x) => (fun y:Y => sx (invf y))).\nset (im2:= fun sy': forall y:Y, P (f (invf y)) => (fun y:Y => transportf _ (homotweqinvweq f y) (sy' y))).\nset (invmapp := (fun sx: forall x:X, P (f x) => im2 (im1 sx))). \n\nassert (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.\n\nset (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 _)).\n\nassert  (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).\n\nassert (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))))).\n\nset (ff:= fun x:X => invf (f x)).\nassert (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).\n\nassert (efg: forall sx: (forall x:X, P (f x)), paths  (map (invmapp sx)) sx). intro. apply (funextsec _ _ _ (efg0 sx)).\n\nassert (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. \n\nset (ff:= fun y:Y => f (invf y)). fold invf. apply (maponsec1l2 P ff ( homotweqinvweq f ) sy y). \nassert (egf: forall sy: (forall y:Y, P y), paths  (invmapp (map sy)) sy). intro. apply (funextsec _ _ _ (egf0 sy)). \n\napply (gradth  map invmapp egf efg). Defined. \n\nDefinition weqonsecbase { X Y : UU } ( P : Y -> UU ) ( f : weq X Y ) := weqpair _ ( isweqmaponsec1 P f ) .  \n\n\n(** *** Composition of functions with a weak equivalence on the left *)\n\n\nDefinition  weqbfun  { X Y : UU } ( Z : UU ) ( w : weq X Y ) : weq ( Y -> Z ) ( X -> Z ) := weqonsecbase _ w . \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** Sections of families over an empty type and over coproducts *)\n\n(** *** General case *)\n\nDefinition iscontrsecoverempty ( P : empty -> UU ) : iscontr ( forall x : empty , P x ) .\nProof . intro . split with ( fun x : empty => fromempty x )  .  intro t .  apply funextsec .  intro t0 . destruct t0 . Defined . \n\nDefinition iscontrsecoverempty2 { X : UU } ( P : X -> UU ) ( is : neg X ) : iscontr ( forall x : X , P x ) .\nProof . intros .  set ( w := weqtoempty is ) . set ( w' := weqonsecbase P ( invweq w ) ) .   apply ( iscontrweqb w' ( iscontrsecoverempty _ ) ) . Defined . \n\nDefinition 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 ) )  .\n\nDefinition 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 .\nProof . intros . destruct xy as [ x | y ] . apply ( pr1 a x ) .    apply ( pr2 a y ) . Defined . \n\n\nDefinition 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 ) ) ) .\nProof . intros . set ( f := secovercoprodtoprod P ) .  set ( g := prodtosecovercoprod P ) . split with f . \nassert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro . apply funextsec .  intro t .  destruct t as [ x | y ] .  apply idpath . apply idpath . \nassert ( 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 .\napply ( gradth _ _ egf efg ) . Defined .\n\n\n\n(** *** Functions from the empty type *)\n\nTheorem iscontrfunfromempty ( X : UU ) : iscontr ( empty -> X ) .\nProof . intro . split with fromempty . intro t .  apply funextfun .  intro x . destruct x . Defined .\n\nTheorem iscontrfunfromempty2 ( X : UU ) { Y : UU } ( is : neg Y ) : iscontr ( Y -> X ) .\nProof. intros . set ( w := weqtoempty is ) . set ( w' := weqbfun X ( invweq w ) ) .  apply ( iscontrweqb w' ( iscontrfunfromempty X ) ) . Defined . \n\n\n\n(** *** Functions from a coproduct *)\n\nDefinition 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 ) ) .\n\nDefinition 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 .\n\nTheorem weqfunfromcoprodtoprod ( X Y Z : UU ) : weq ( coprod X Y -> Z ) ( dirprod ( X -> Z ) ( Y -> Z ) ) .\nProof. intros . set ( f := @funfromcoprodtoprod X Y Z ) . set ( g := @prodtofunfromcoprod X Y Z ) . split with f . \nassert ( egf : forall a : _ , paths ( g ( f a ) ) a ) .  intro a . apply funextfun .   intro xy .  destruct xy as [ x | y ] .  apply idpath . apply idpath . \nassert ( 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 .\napply ( gradth _ _ egf efg ) . Defined .\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** Sections of families over contractible types and over [ total2 ] (over dependent sums) *)\n\n\n\n(** *** General case *)\n\n\nDefinition tosecoverunit ( P : unit -> UU ) ( p : P tt ) : forall t : unit , P t .\nProof . intros . destruct t . apply p . Defined .   \n \nDefinition weqsecoverunit ( P : unit -> UU ) : weq ( forall t : unit , P t ) ( P tt ) .\nProof . intro. set ( f := fun a : forall t : unit , P t => a tt ) . set ( g := tosecoverunit P ) . split with f . \nassert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro . apply funextsec .  intro t . destruct t . apply idpath .  \nassert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intros . apply idpath .\napply ( gradth _ _ egf efg ) . Defined .   \n\n\nDefinition weqsecovercontr { X : UU } ( P : X -> UU ) ( is : iscontr X ) : weq ( forall x : X , P x ) ( P ( pr1 is ) ) .\nProof . intros . set ( w1 := weqonsecbase P ( wequnittocontr is ) ) . apply ( weqcomp w1 ( weqsecoverunit _ ) ) .  Defined . \n\nDefinition 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 .\nProof . intros . destruct xp as [ x p ] . apply ( a x p ) . Defined .  \n\n\nDefinition 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 ) ) .\nProof . 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 .\nassert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro . apply funextsec .  intro xp . destruct xp as [ x p ] . apply idpath .  \nassert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro . apply funextsec . intro x . apply funextsec . intro p . apply idpath .  \napply ( gradth _ _ egf efg ) . Defined .\n\n\n(** *** Functions from [ unit ] and from contractible types *) \n\n\nDefinition weqfunfromunit ( X : UU ) : weq ( unit -> X ) X := weqsecoverunit _ . \n\nDefinition  weqfunfromcontr { X : UU } ( Y : UU ) ( is : iscontr X ) : weq ( X -> Y ) Y := weqsecovercontr _ is . \n\n\n(** *** Functions from [ total2 ] *)\n\nDefinition weqfunfromtotal2 { X : UU } ( P : X -> UU ) ( Y : UU ) : weq ( total2 P -> Y ) ( forall x : X , P x -> Y ) := weqsecovertotal2 P _ .\n\n(** *** Functions from direct product *)\n\nDefinition weqfunfromdirprod ( X X' Y : UU ) : weq ( dirprod X X' -> Y ) ( forall x : X , X' -> Y ) := weqsecovertotal2 _ _ . \n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** 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. *)\n\n(** *** General case *)\n\nTheorem impred (n:nat) { T : UU } (P:T -> UU): (forall t:T, isofhlevel n (P t)) -> (isofhlevel n (forall t:T, P t)).\nProof. 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' . \n\nassert (is: forall t:T, isofhlevel n (paths (x t) (x' t))).  intro. apply (X t (x t) (x' t)).  \nassert (is2: isofhlevel n (forall t:T, paths (x t) (x' t))). apply (IHn _ (fun t0:T => paths (x t0) (x' t0)) is).\nset (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.\n\nCorollary 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')).\nProof.  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.\n\n\nCorollary impredfun (n:nat)(X Y:UU)(is: isofhlevel n Y) : isofhlevel n (X -> Y).\nProof. intros. apply (impred n (fun x:_ => Y) (fun x:X => is)). Defined. \n\n\nTheorem impredtech1 (n:nat)(X Y: UU) : (X -> isofhlevel n Y) -> isofhlevel n (X -> Y).\nProof. intro. induction n as [ | n IHn ] . intros X Y X0. simpl. split with (fun x:X => pr1  (X0 x)).  intro t . \nassert (s1: forall x:X, paths (t x) (pr1  (X0 x))). intro. apply proofirrelevancecontr. apply (X0 x). \napply funextsec. assumption. \n\nintros X Y X0. simpl. assert (X1: X -> isofhlevel (S n) (X -> Y)). intro X1 . apply impred. assumption. intros x x' .\nassert (s1: isofhlevel n (forall xx:X, paths (x xx) (x' xx))). apply impred. intro t . apply (X0 t). \nassert (w: weq (forall xx:X, paths (x xx) (x' xx)) (paths x x')). apply (weqfunextsec  _ x x' ). apply (isofhlevelweqf n w s1). Defined. \n\n\n\n(** ***  Functions to a contractible type *)\n\nTheorem iscontrfuntounit ( X : UU ) : iscontr ( X -> unit ) .\nProof . intro . split with ( fun x : X => tt ) . intro f .   apply funextfun . intro x . destruct ( f x ) .  apply idpath . Defined .\n\nTheorem iscontrfuntocontr ( X : UU ) { Y : UU } ( is : iscontr Y ) : iscontr ( X -> Y ) .\nProof . intros . set ( w := weqcontrtounit is ) .   set ( w' := weqffun X w ) .  apply ( iscontrweqb w' ( iscontrfuntounit X ) ) . Defined .  \n\n\n(** *** Functions to a proposition *)\n\nLemma isapropimpl ( X Y : UU ) ( isy : isaprop Y ) : isaprop ( X -> Y ) .\nProof. intros. apply impred. intro.   assumption.  Defined. \n\n\n\n(** *** Functions to an empty type (generalization of [ isapropneg ]) *)\n\n\nTheorem isapropneg2 ( X : UU ) { Y : UU } ( is : neg Y ) : isaprop ( X -> Y ) .\nProof . intros .  apply impred . intro . apply ( isapropifnegtrue  is ) . Defined .   \n\n\n\n\n\n(** ** Theorems saying that  [ iscontr T ], [ isweq f ] etc. are of h-level 1 *)\n\n\n\nTheorem iscontriscontr { X : UU } ( is : iscontr X ) : iscontr ( iscontr X ).\nProof. intros X X0 . \n\nassert (is0: forall (x x':X), paths x x'). apply proofirrelevancecontr. assumption.\n\nassert (is1: forall cntr:X, iscontr (forall x:X, paths x cntr)). intro. \nassert (is2: forall x:X, iscontr (paths x cntr)). \nassert (is2: isaprop X). apply isapropifcontr. assumption.  \nunfold isaprop in is2. unfold isofhlevel in is2. intro x . apply (is2 x cntr).\napply funcontr. assumption. \n\nset (f:= @pr1 X (fun cntr:X => forall x:X, paths x cntr)). \nassert (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. \n\n\n\nTheorem isapropiscontr (T:UU): isaprop (iscontr T).\nProof. 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.  \n\n\nTheorem isapropisweq { X Y : UU } (f:X-> Y) : isaprop (isweq f).\nProof. intros. unfold isweq.  apply (impred (S O) (fun y:Y => iscontr (hfiber f y)) (fun y:Y => isapropiscontr (hfiber  f y))).  Defined. \n\n\nTheorem isapropisisolated ( X : UU ) ( x : X ) : isaprop ( isisolated X x ) .\nProof. intros . apply isofhlevelsn .  intro is . apply impred . intro x' .  apply ( isapropdec _ ( isaproppathsfromisolated X x is x' ) ) .  Defined .  \n\nTheorem isapropisdeceq (X:UU): isaprop (isdeceq X).\nProof. intro. apply ( isofhlevelsn 0 ) .  intro is . unfold isdeceq. apply impred . intro x .  apply ( isapropisisolated X x ) .   Defined . \n\nDefinition isapropisdecprop ( X : UU ) : isaprop ( isdecprop X ) := isapropiscontr ( coprod X ( neg X ) ) .\n\n\n\nTheorem isapropisofhlevel (n:nat)(X:UU): isaprop (isofhlevel n X).\nProof. intro.  unfold isofhlevel.    induction n as [ | n IHn ] . apply isapropiscontr.  intro X . \nassert (X0: forall (x x':X), isaprop  ((fix isofhlevel (n0 : nat) (X0 : UU) {struct n0} : UU :=\n         match n0 with\n         | O => iscontr X0\n         | S m => forall x0 x'0 : X0, isofhlevel m (paths x0 x'0)\n         end) n (paths x x'))). intros. apply (IHn (paths x x')). \nassert (is1: \n     (forall x:X, isaprop (forall  x' : X,\n      (fix isofhlevel (n0 : nat) (X1 : UU) {struct n0} : UU :=\n         match n0 with\n         | O => iscontr X1\n         | S m => forall x0 x'0 : X1, isofhlevel m (paths x0 x'0)\n         end) n (paths x x')))). intro.  apply (impred ( S O ) _  (X0 x)). apply (impred (S O) _ is1). Defined. \n\nCorollary isapropisaprop (X:UU) : isaprop (isaprop X).\nProof. intro. apply (isapropisofhlevel (S O)). Defined. \n\nCorollary isapropisaset (X:UU): isaprop (isaset X).\nProof. intro. apply (isapropisofhlevel (S (S O))). Defined.\n\n\nTheorem isapropisofhlevelf ( n : nat ) { X Y : UU } ( f : X -> Y ) : isaprop ( isofhlevelf n f ) .\nProof . intros . unfold isofhlevelf .    apply impred . intro y . apply isapropisofhlevel .  Defined .\n\nDefinition isapropisincl { X Y : UU } ( f : X -> Y ) := isapropisofhlevelf 1 f . \n\n\n\n\n(** ** Theorems saying that various [ pr1 ] maps are inclusions *)\n\n\nTheorem isinclpr1weq ( X Y : UU ) : isincl ( @pr1 _ ( fun f : X -> Y => isweq f ) ) .\nProof. intros . apply isinclpr1 . intro f.   apply isapropisweq .  Defined . \n\nTheorem isinclpr1isolated ( T : UU ) : isincl ( pr1isolated T ) .\nProof . intro . apply ( isinclpr1 _ ( fun t : T => isapropisisolated T t ) ) . Defined . \n\n\n\n\n\n\n\n\n\n\n\n\n\n(** ** Various weak equivalences between spaces of weak equivalences *)\n\n(** *** Composition with a weak quivalence is a weak equivalence on weak equivalences *)\n\nTheorem weqfweq ( X : UU ) { Y Z : UU } ( w : weq Y Z ) : weq ( weq X Y ) ( weq X Z ) .\nProof. 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 . \nassert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun .  intro x .  apply ( homotinvweqweq w ( a x ) ) .   \nassert ( efg : forall b : _ , paths ( f ( g b ) ) b ) . intro b .  apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun . intro x . apply ( homotweqinvweq w ( b x ) ) .  \napply ( gradth _ _ egf efg ) . Defined .\n\nTheorem weqbweq  { X Y : UU } ( Z : UU ) ( w : weq X Y ) : weq ( weq Y Z ) ( weq X Z ) .\nProof. 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 . \nassert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a .  apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun .  intro y .  apply ( maponpaths a ( homotweqinvweq w y ) ) .   \nassert ( efg : forall b : _ , paths ( f ( g b ) ) b ) . intro b .  apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) ) . apply funextfun . intro x . apply ( maponpaths b ( homotinvweqweq w x ) ) .  \napply ( gradth _ _ egf efg ) . Defined . \n\n\n\n(** *** Invertion on weak equivalences as a weak equivalence *)\n\n(** 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 . *)\n\nTheorem weqinvweq ( X Y : UU ) : weq ( weq X Y ) ( weq Y X ) .\nProof . intros . set ( f := fun w : weq X Y => invweq w ) . set ( g := fun w : weq Y X => invweq w ) . split with f .\nassert ( 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 . \nassert ( 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 .\napply ( gradth _ _ egf efg ) . Defined .  \n\n\n\n(** ** h-levels of spaces of weak equivalences *)\n\n\n(** *** Weak equivalences to and from types of h-level ( S n ) *)\n\nTheorem isofhlevelsnweqtohlevelsn ( n : nat ) ( X Y : UU ) ( is : isofhlevel ( S n ) Y ) : isofhlevel ( S n ) ( weq X Y ) .\nProof . intros .  apply ( isofhlevelsninclb n _ ( isinclpr1weq _ _ ) ) .  apply impred . intro .  apply is .  Defined .  \n\nTheorem isofhlevelsnweqfromhlevelsn ( n : nat ) ( X Y : UU ) ( is : isofhlevel ( S n ) Y ) : isofhlevel ( S n ) ( weq Y X ) .\nProof. intros .  apply ( isofhlevelweqf ( S n ) ( weqinvweq X Y ) ( isofhlevelsnweqtohlevelsn n X Y is ) ) .  Defined . \n\n\n\n\n(** *** Weak equivalences to and from contractible types *)\n\nTheorem isapropweqtocontr ( X : UU ) { Y : UU } ( is : iscontr Y ) : isaprop ( weq X Y ) .\nProof . intros .  apply ( isofhlevelsnweqtohlevelsn 0 _ _ ( isapropifcontr is ) ) . Defined .  \n\nTheorem isapropweqfromcontr ( X : UU ) { Y : UU } ( is : iscontr Y ) : isaprop ( weq Y X ) .\nProof. intros .  apply ( isofhlevelsnweqfromhlevelsn 0 X _ ( isapropifcontr is ) ) . Defined . \n\n\n(** *** Weak equivalences to and from propositions *)\n\n\nTheorem isapropweqtoprop ( X  Y : UU ) ( is : isaprop Y ) : isaprop ( weq X Y ) .\nProof . intros .  apply ( isofhlevelsnweqtohlevelsn 0 _ _ is ) . Defined .  \n\nTheorem isapropweqfromprop ( X Y : UU )( is : isaprop Y ) : isaprop ( weq Y X ) .\nProof. intros .  apply ( isofhlevelsnweqfromhlevelsn 0 X _ is ) . Defined . \n\n\n(** *** Weak equivalences to and from sets *)\n\nTheorem isasetweqtoset ( X  Y : UU ) ( is : isaset Y ) : isaset ( weq X Y ) .\nProof . intros .  apply ( isofhlevelsnweqtohlevelsn 1 _ _ is ) . Defined .  \n\nTheorem isasetweqfromset ( X Y : UU )( is : isaset Y ) : isaset ( weq Y X ) .\nProof. intros .  apply ( isofhlevelsnweqfromhlevelsn 1 X _ is ) . Defined . \n\n\n\n(** *** Weak equivalences to an empty type *)\n\nTheorem isapropweqtoempty  ( X : UU ) : isaprop ( weq X empty ) .\nProof . intro . apply ( isofhlevelsnweqtohlevelsn 0 _ _ ( isapropempty ) ) . Defined . \n\n\nTheorem isapropweqtoempty2 ( X : UU ) { Y : UU } ( is : neg Y ) : isaprop ( weq X Y ) .\nProof. intros . apply ( isofhlevelsnweqtohlevelsn 0 _ _ ( isapropifnegtrue is ) ) . Defined . \n\n\n(** *** Weak equivalences from an empty type *)\n\nTheorem isapropweqfromempty ( X : UU ) : isaprop ( weq empty X ) .\nProof . intro . apply ( isofhlevelsnweqfromhlevelsn 0 X _ ( isapropempty ) ) . Defined . \n\nTheorem isapropweqfromempty2 ( X : UU ) { Y : UU } ( is : neg Y ) : isaprop ( weq Y X ) .\nProof. intros .  apply ( isofhlevelsnweqfromhlevelsn 0 X _ ( isapropifnegtrue is ) ) .  Defined .\n\n\n\n(** *** Weak equivalences to and from [ unit ] *)\n\nTheorem isapropweqtounit ( X : UU ) : isaprop ( weq X unit ) .\nProof . intro .  apply ( isofhlevelsnweqtohlevelsn 0 _ _ ( isapropunit ) ) . Defined .  \n\nTheorem isapropweqfromunit ( X : UU ) : isaprop ( weq unit X ) .\nProof. intros . apply ( isofhlevelsnweqfromhlevelsn 0 X _ ( isapropunit ) ) .  Defined . \n\n\n\n\n\n\n\n\n(** ** Weak auto-equivalences of a type with an isolated point *)\n\n\n\nDefinition 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 ) ) . \n\nDefinition 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 ) ) ) .   \n\nLemma 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 ) ) .\nProof. 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 . \n\nDefinition weqcutonweq ( T : UU ) ( t : T ) ( is : isisolated T t ) : weq ( weq T T ) ( dirprod ( isolated T ) ( weq ( compl T t ) ( compl T t ) ) ) .\nProof . intros . set ( f := cutonweq t is  ) . set ( g := invcutonweq t is ) . split with f .\n\nassert ( 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 ) . \n\nassert ( efg : forall xw : _ , paths ( f ( g xw ) ) xw ) . intro . destruct xw as [ x w ] .  destruct x as [ t' is' ] .  simpl in w .  apply pathsdirprod .\n\napply ( invmaponpathsincl _ ( isinclpr1isolated _ ) ) .  simpl .   unfold recompl . unfold coprodf . unfold invmap .    simpl .  unfold invrecompl . destruct ( is t ) as [ ett | nett ] .  apply pathsfuntransposoft1 . destruct ( nett ( idpath _ ) ) .\n\nsimpl .  apply ( invmaponpathsincl _ ( isinclpr1weq _ _ ) _ _ ) . apply funextfun . intro x .  destruct x as [ x netx ] .  unfold g . unfold invcutonweq .  simpl . \n\nset ( int := funtranspos ( tpair _ t is ) ( tpair _ t' is' ) (recompl T t (coprodf w (fun x0 : unit => x0) (invmap (weqrecompl T t is) t))) ) . \nassert ( 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 _ ) ) .   \n\nassert ( isint : isisolated _ int ) . rewrite eee . apply is' .    \n\napply ( ishomotinclrecomplf _ _ isint ( funtranspos0 _ _ _ ) _ _ ) .  simpl .  change ( recomplf int t isint (funtranspos0 int t is) ) with ( funtranspos ( tpair _ int isint ) ( tpair _ t is ) ) .\n\nassert ( ee : paths ( tpair _ int isint) ( tpair _ t' is' ) ) . apply ( invmaponpathsincl _ ( isinclpr1isolated _ ) _ _ ) .  simpl . apply eee . \n\nrewrite 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 .\n\napply ( gradth _ _ egf efg ) . Defined .\n  \n\n\n\n\n\n\n(* Coprojections i.e. functions which are weakly equivalent to functions of the form ii1: X -> coprod X Y \n\n\nDefinition locsplit (X:UU)(Y:UU)(f:X -> Y):= forall y:Y, coprod (hfiber  f y) (hfiber  f y -> empty).\n\nDefinition dnegimage (X:UU)(Y:UU)(f:X -> Y):= total2 Y (fun y:Y => dneg(hfiber  f y)).\nDefinition dnegimageincl (X Y:UU)(f:X -> Y):= pr1 Y (fun y:Y => dneg(hfiber  f y)).\n\nDefinition 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)))). \n\nDefinition locsplitsec (X:UU)(Y:UU)(f:X->Y)(ls: locsplit  f): dnegimage  f -> X := fun u: _ =>\nmatch u with\ntpair y psi =>\nmatch (ls y) with \nii1 z => pr1  z|\nii2 phi => fromempty  (psi phi)\nend\nend.\n\n\nDefinition locsplitsecissec  (X Y:UU)(f:X->Y)(ls: locsplit  f)(u:dnegimage  f): paths (xtodnegimage  f (locsplitsec  f ls u)) u.\nProof. intros.  set (p:= xtodnegimage  f). set (s:= locsplitsec  f ls).  \nassert (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).  \nassert (is: isofhlevelf (S O)  (dnegimageincl  f)). apply (isofhlevelfpr1 (S O)  (fun y:Y => isapropdneg (hfiber  f y))).  \nassert (isw: isweq (maponpaths (dnegimageincl  f) (p (s u)) u)). apply (isofhlevelfonpaths O   _ is). \napply (invmap  _ isw X0). Defined.\n\n\n\nDefinition negimage (X:UU)(Y:UU)(f:X -> Y):= total2 Y (fun y:Y => neg(hfiber  f y)).\nDefinition negimageincl (X Y:UU)(f:X -> Y):= pr1 Y (fun y:Y => neg(hfiber  f y)).\n\n\nDefinition imsum (X:UU)(Y:UU)(f:X -> Y): coprod (dnegimage  f) (negimage  f) -> Y:= fun u:_ =>\nmatch u with\nii1 z => pr1  z|\nii2 z => pr1  z\nend.\n\n*)\n \n\n"
  },
  {
    "path": "Generalities/uuu.v",
    "content": "(** * Introduction. Vladimir Voevodsky . Feb. 2010 - Sep. 2011 \n\nThis 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.\n\n\n*)\n\n\n\n\n(** Preambule. *)\n\nUnset Automatic Introduction.  (** This line has to be removed for the file to compile with Coq8.2 *)\n\n(** Universe structure *)\n\nNotation UUU := Set .\n\n(** Empty type.  The empty type is introduced in Coq.Init.Datatypes by the line:\n\n[ Inductive Empty_set : Set := . ]\n\n*)\n\nNotation empty := Empty_set. \n\n(** Identity Types. Idenity types are introduced in Coq.Init.Datatypes by the lines : \n\n[ Inductive identity ( A : Type ) ( a : A ) : A -> Type := identity_refl : identity _ a a . \nHint Resolve identity_refl : core . ] \n\n*)\n\nNotation paths := identity .\nNotation idpath := identity_refl .\n\n(** Coproducts . \n\nThe coproduct of two types is introduced in Coq.Init.Datatypes by the lines:\n\n[ Inductive sum (A B:Type) : Type :=\n  | inl : A -> sum A B\n  | inr : B -> sum A B. ]\n*)\n\nNotation coprod := sum .\n\nNotation ii1fun := inl .\nNotation ii2fun := inr .\n\nNotation ii1 := inl .\nNotation ii2 := inr .\nImplicit Arguments ii1 [ A B ] .\nImplicit Arguments ii2 [ A B ] .\n\n\n(** Dpendent sums. \n\nOne 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. *)\n\nRecord total2 { T: Type } ( P: T -> Type ) := tpair : forall t : T , forall tp : P t , total2 P . \n\nDefinition pr1 { T: Type } { P : T -> Type } ( tp : total2 P ) : T := match tp with tpair _ t p => t end .\nDefinition 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 . \n\n\n\n(*\n\n(** The phantom type family ( following George Gonthier ) *)\n\nInductive Phant ( T : Type ) := phant : Phant T .\n\n\n*)\n\n(** 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 ]. *)\n\nCheck (paths O O) .\n\n\n\n(* End of the file uuu.v *)\n"
  },
  {
    "path": "Makefile",
    "content": "all : hlevel2/hq.vo hlevel2/finitesets.vo  Proof_of_Extensionality/funextfun.vo\n\nhlevel2/hq.vo : hlevel2/hq.v hlevel2/hz.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 hq\nhlevel2/hz.vo : hlevel2/hz.v hlevel2/hnat.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 hz\n\nhlevel2/finitesets.vo : hlevel2/finitesets.v hlevel2/stnfsets.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 finitesets\nhlevel2/stnfsets.vo : hlevel2/stnfsets.v hlevel2/hnat.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 stnfsets\n\nhlevel2/hnat.vo : hlevel2/hnat.v hlevel2/algebra1d.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 hnat\nhlevel2/algebra1d.vo : hlevel2/algebra1d.v hlevel2/algebra1c.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 algebra1d\nhlevel2/algebra1c.vo : hlevel2/algebra1c.v hlevel2/algebra1b.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 algebra1c\nhlevel2/algebra1b.vo : hlevel2/algebra1b.v hlevel2/algebra1a.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 algebra1b\nhlevel2/algebra1a.vo : hlevel2/algebra1a.v hlevel2/hSet.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 algebra1a\n\nhlevel2/hSet.vo : hlevel2/hSet.v hlevel1/hProp.vo\n\tcd hlevel2/ && coqc -no-sharing -R . Foundations.hlevel2 hSet\n\nhlevel1/hProp.vo : hlevel1/hProp.v Generalities/uu0.vo\n\tcd hlevel1/ && coqc -no-sharing -R . Foundations.hlevel1 hProp\n\nProof_of_Extensionality/funextfun.vo : Proof_of_Extensionality/funextfun.v Generalities/uu0.vo\n\tcd Proof_of_Extensionality/ && coqc -no-sharing -R . Foundations.Proof_of_Extensionality funextfun\n\nGeneralities/uu0.vo : Generalities/uu0.v Generalities/uuu.vo\n\tcd Generalities/ && coqc -no-sharing -R . Foundations.Generalities uu0\nGeneralities/uuu.vo : Generalities/uuu.v\n\tcd Generalities/ && coqc -no-sharing -R . Foundations.Generalities uuu\n\n\nclean : \n\trm -f Generalities/*.vo Proof_of_Extensionality/*.vo hlevel1/*.vo hlevel2/*.vo\n\trm -f Generalities/*.glob Proof_of_Extensionality/*.glob hlevel1/*.glob hlevel2/*.glob\n\n\n\n#\n# The following is copied from a makefile generated by coq_makefile V8.3pl5\n#\n\n\nVFILES:=Generalities/uuu.v\\\n  Generalities/uu0.v\\\n  Proof_of_Extensionality/funextfun.v\\\n  hlevel1/hProp.v\\\n  hlevel2/hSet.v\\\n  hlevel2/algebra1a.v\\\n  hlevel2/algebra1b.v\\\n  hlevel2/algebra1c.v\\\n  hlevel2/algebra1d.v\\\n  hlevel2/hnat.v\\\n  hlevel2/stnfsets.v\\\n  hlevel2/finitesets.v\\\n  hlevel2/hz.v\\\n  hlevel2/hq.v\nVOFILES:=$(VFILES:.v=.vo)\n\nCOQLIB:=$(shell $(COQBIN)coqtop -where | sed -e 's/\\\\/\\\\\\\\/g')\n\ninstall : \n\tmkdir -p $(COQLIB)/user-contrib\n\t(for i in $(VOFILES); do \\\n\t install -d `dirname $(COQLIB)/user-contrib/Foundations/$$i`; \\\n\t install $$i $(COQLIB)/user-contrib/Foundations/$$i; \\\n\t done)\n\n"
  },
  {
    "path": "Proof_of_Extensionality/funextfun.v",
    "content": "(** * Univalence axiom and functional extensionality.  Vladimir Voevodsky. Feb. 2010 - Sep. 2011 \n\nThis file contains the formulation of the univalence axiom and the proof that it implies functional extensionality for functions - Theorem funextfun.   \n   \n*)\n\n\n(** *** Preamble. *)\n\n(** *** Imports. *)\n\nUnset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)\n\nAdd LoadPath \"../..\".\n\n\nRequire Export Foundations.Generalities.uu0.\n\n\n(** ** Univalence axiom. *)\n\n\nDefinition eqweqmap { T1 T2 : UU } ( e: paths T1 T2 ) : weq T1 T2 .\nProof. intros. destruct e . apply idweq. Defined. \n\nAxiom univalenceaxiom :  forall T1 T2 : UU ,  isweq ( @eqweqmap T1 T2 ).\n \nDefinition weqtopaths { T1 T2 : UU } ( w : weq T1 T2 ) : paths T1 T2  :=  invmap ( weqpair _ ( univalenceaxiom T1 T2 ) ) w.\n\n\nDefinition weqpathsweq { T1 T2 : UU } ( w : weq T1 T2 ) : paths ( eqweqmap ( weqtopaths w ) ) w  :=  homotweqinvweq ( weqpair _ ( univalenceaxiom T1 T2 ) ) w.\n\n(** We show that [ univalenceaxiom ] is equivalent to the axioms [ weqtopaths0 ] and [ weqpathsweq0 ] stated below . *)\n\n\nAxiom weqtopaths0 : forall ( T1 T2 : UU ) ( w : weq T1 T2 ) , paths T1 T2.\n\nAxiom weqpathsweq0 : forall ( T1 T2 : UU ) ( w : weq T1 T2 ) ,  paths ( eqweqmap ( weqtopaths0 _ _ w ) ) w.\n\nTheorem univfromtwoaxioms ( T1 T2 : UU ) : isweq ( @eqweqmap T1 T2 ).\nProof. 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 ) . \n\nset ( h := fun a1 : Z1 =>  pr1 ( pr1 a1 ) ) .\nassert ( egf0 : forall a1 : Z1 ,  paths ( pr1 ( g ( f a1 ) ) ) (  pr1 a1 ) ). intro. apply  idpath.  \nassert ( egf1 : forall a1 a1' : Z1 ,  paths ( pr1 a1' ) (  pr1 a1 ) ->  paths a1' a1 ). intros.  set ( X' :=  maponpaths ( @pr1 _ _ ) X ). \nassert ( is : isweq h ).  apply isweqpr1pr1 . apply ( invmaponpathsweq ( weqpair h is ) _ _ X' ).\nset ( egf := fun a1  => ( egf1 _ _ ( egf0 a1 ) ) ). \nset ( is2 := gradth _ _ egf efg ). \napply ( isweqtotaltofib P1 P2  ( fun XY : dirprod UU UU => match XY with  tpair _ X Y => @eqweqmap X Y end ) is2 ( dirprodpair T1 T2 ) ). Defined. \n\n\n(** Conjecture :  the pair [weqtopaths0] and [weatopathsweq0] is well defined up to a canonical equality. **)\n\n\n\n\n\n\n(** ** Transport theorem. \n\nTheorem 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. *)\n\n\nLemma isweqtransportf10 { X : UU } ( P : X -> UU ) { x x' : X } ( e :  paths x x' ) : isweq ( transportf P e ).\nProof. intros. destruct e.  apply idisweq. Defined.\n\nLemma isweqtransportb10 { X : UU } ( P : X -> UU ) { x x' : X } ( e :  paths x x' ) : isweq ( transportb P e ).\nProof. intros. apply ( isweqtransportf10 _ ( pathsinv0 e ) ). Defined. \n\n\nLemma 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' ).\nProof. intro. intro. intro. intro. intro. destruct ee. simpl. intro. intro. apply r. Defined.\n\n\nTheorem 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' ).\nProof. intros. set ( uv := weqtopaths w ).   set ( v := eqweqmap uv ). \n\nassert ( e : paths v w ) . unfold weqtopaths in uv.  apply ( homotweqinvweq ( weqpair _ ( univalenceaxiom X X' ) ) w ).\n\nassert ( 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.\n\ndestruct ee. apply l1. assumption. Defined.\n\n\n\nCorollary 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' ).\nProof. 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. \n\nassert ( is1 : isweq ( transportb P ( weqtopaths w ) ) ). apply isweqtransportb10.  \napply ( isweqhomot ( transportb P ( weqtopaths w ) ) ( fun p'  :  P X' => R X X' w p' ) ee is1 ).  Defined. \n\n\n\n    \n\n(** Theorem saying that composition with a weak equivalence is a weak equivalence on function spaces. *)\n\n\n\n\nTheorem isweqcompwithweq { X X' : UU } ( w : weq X X' ) ( Y : UU ) :  isweq ( fun f : X' -> Y => ( fun x : X => f ( w x ) ) ).\nProof. intros. \nset ( P := fun X0 : UU => ( X0 -> Y ) ). \nset ( R := fun X0 : UU => ( fun X0' : UU => ( fun w1 : X0 -> X0' =>  ( fun  f : P X0'  => ( fun x : X0 => f ( w1 x ) ) ) ) ) ). \nset ( r := fun X0 : UU => ( fun f : X0 -> Y => pathsinv0 ( etacor f ) ) ).\napply ( isweqweqtransportb P R r X X' w ). Defined.\n\n\n\n\n(** ** Proof of the functional extensionality for functions *) \n\n\nLemma 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. \nProof. intros. apply ( invmaponpathsweq ( weqpair _ ( isweqcompwithweq w Y ) ) f1 f2 ). assumption.  Defined. \n\n\nLemma apathpr1topr ( T : UU ) : paths ( fun z :  pathsspace T => pr1 z ) ( fun z : pathsspace T => pr1 ( pr2 z ) ).\nProof. intro. apply ( eqcor0  ( weqpair _ ( isweqdeltap T ) ) _ ( fun z :  pathsspace T => pr1 z ) ( fun z :  pathsspace T => pr1 ( pr2 z ) ) ( idpath ( idfun T ) ) ) . Defined.     \n\n\nTheorem funextfun { X Y : UU } ( f1 f2 : X -> Y ) ( e :  forall x : X , paths ( f1 x ) ( f2 x ) ) : paths f1 f2.\nProof. 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. \n\n(* End of the file funextfun.v *)    \n"
  },
  {
    "path": "README",
    "content": "This library is now a part of the UniMath repository, available at\nhttps://github.com/UniMath/UniMath . The recommended way to obtain this\nlibrary is to install UniMath. Instructions for installing UniMath can\nbe found on the UniMath web page. The below installation instructions\nshould be considered as obsolete (September 2014).  \n\nBy Vladimir  Voevodsky Feb. 2010 - Dec. 2013 .\n\nThis is the current version of the mathematical library for the proof assistant Coq based on the univalent semantics for the calculus of inductive constructions. The best way to see in detail what the files in these subdirectories are about is to generate the corresponding tables of content with coqdoc . Here we give a brief outline of the library structure .   \n\nImportant : files in the library starting with hProp.v will not compile without a type_in_type patch which turns off the universe consistency checking . This is a temporary situation which will be corrected when better universe management is implememnted in Coq . We also use a patch which modifies the rule by which the universe level of inductive definitions is computed . If the later patch is applied correctly then the compilation of the first file uuu.v should produce a message of the form [ paths 0 0 : UUU ] . Without a patch the message will be [ paths 0 0 : Prop ] . \n\nThe library contains subdirectories Generalities/ hlevel1/ hlevel2/ and /Proof_of_Extensionality . \n\nDirectory Generalities/ contains files uuu.v and uu0.v .  The file uuu.v contains some new notations for the constructions defined in Coq.Init library as well as the definition of \"dependent sum\" [ total2 ] . The 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 resizings rules (see below) are used and these files should compile with the standard version of Coq. \n\nDirectory hlevel1/ 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-assigment\" 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 .  \n\nDirectory hlevel2/ contains files with constructions and results related to types of hlevel 2 i.e. to types corresponding to sets in our formalization . \n\nThe first file is hSet.v . It contains most general definitions related to sets including the constructions related to set-quotients of types . \n\nThe 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. The files also contain definitions and results about the relations on algebraic structures .  \n\nThe next file is hnat.v which contains many simple lemmas about arithmetic and comparisons on natural numbers . \n\nThen the hierarchy branches. \n\nOn one branch  there are files stnfsets.v and finitesets.v which introduce constructions related to standard and general finite sets respectively.\n\nOn 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. \n\nAt the end of files finitesets.v,  hz.v and hq.v there are sample computations which show that despite our use of stnadard extensionality axioms the relevant terms of types [ bool ] and [ nat ] fully normalize. The last computation example in hq.v which evaluates the integral part of 10/-3 takes relatively long time ( about 30 sec. on my computer, it should work much faster with the stnadard optimized version of the \"call by need\" normalization algorithm which is switched off by one of the patches which I use, see the explanation in the README file of the patches directory) and it might make sense to comment it out.  \n\nDirectory Proof_of_Extensionality/ contains the formulation of general Univalence Axiom and a proof that it implies functional extensionality . \n\nThe easiest way to compile the library is by typing \"make\" in this directory. For this to work one should have GNU Make installed which is easly to find on the web. \n\nOnce the library is compiled the individual files of the library can be followed line-by-line in CoqIDE or Proof General. \n\nBy running \"make install\" one can install the compiled library to the /user-contrib/ directory of Coq.\n"
  },
  {
    "path": "hlevel1/hProp.v",
    "content": "(** * Generalities on hProp.  Vladimir Voevodsky . May - Sep. 2011 . \n\nIn 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 :\n\nResizing Rule RR1 ( U1 U2 : Univ ) ( X : U1 ) ( is : isaprop X ) |- X : U2 .\n\nFurther 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 :\n\nResizing Rule RR2 ( U1 U2 : Univ ) |- @hProp U1 : U2 . \n\nSince 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 . \n\nOne 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.\n\n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *)\n\n(** Imports *)\n\nAdd LoadPath \"../../\" .\n\nRequire Export Foundations.Generalities.uu0.\n\n(** Universe structure *)\n\n(* Definition UU0 := UU . *)\n\n(* end of \" Preambule \" . *)\n\n\n(** ** To upstream files *)\n\n\n\n(** ** The type [ hProp ] of types of h-level 1 *)\n\n \nDefinition hProp := total2 ( fun X : UU => isaprop X ) .\nDefinition hProppair ( X : UU ) ( is : isaprop X ) : hProp := tpair (fun X : UU => isaprop X ) X is .\nDefinition hProptoType := @pr1 _ _ : hProp -> Type .\nCoercion hProptoType: hProp >-> Sortclass.\n\n(** ** The type [ tildehProp ] of pairs ( P , p : P ) where [ P : hProp ] *)\n\nDefinition tildehProp := total2 ( fun P : hProp => P ) .\nDefinition tildehProppair { P : hProp } ( p : P ) : tildehProp := tpair _ P p . \n\n\n(** 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 .\n\n\n(** *** Re-definitions of some of the standard constructions of uu0.v which lift these contructions from UU to hProp . *)\n\n\nDefinition iscontr ( X : UU ) : hProp := hProppair _ ( isapropiscontr X ) . \n\nDefinition isweq { X Y : UU } ( f : X -> Y ) : hProp := hProppair _ ( isapropisweq f ) . \n\nDefinition isofhlevel ( n : nat ) ( X : UU ) : hProp := hProppair _ ( isapropisofhlevel n X ) .\n\nDefinition isaprop ( X : UU ) : hProp := hProppair ( isaprop X ) ( isapropisaprop X ) .\n\nDefinition isaset ( X : UU ) : hProp := hProppair _ ( isapropisaset X ) .\n\nDefinition isisolated ( X : UU ) ( x : X ) : hProp := hProppair _ ( isapropisisolated X x ) .\n\nDefinition isdecEq ( X : UU ) : hProp := hProppair _ ( isapropisdeceq X ) .   \n\n*)\n\n\n(** ** Intuitionistic logic on [ hProp ] *)\n\n\n(** *** The [ hProp ] version of the \"inhabited\" construction. *)\n\n\n\nDefinition ishinh_UU ( X : UU ) := forall P: hProp, ( ( X -> P ) -> P ). \n\nLemma isapropishinh ( X : UU ) : isaprop ( ishinh_UU X ). \nProof. intro. apply impred . intro P . apply impred.  intro. apply ( pr2 P ) .  Defined . \n\nDefinition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) ( isapropishinh X ) .\n(* Canonical Structure ishinh .  (** RR1 *) *)\n\n\nDefinition hinhpr ( X : UU ) : X -> ishinh X := fun x : X => fun P : hProp  => fun f : X -> P => f x .\n\nDefinition 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 ) ) .\n\n(** 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 ] *)\n\nDefinition hinhuniv { X : UU } { P : hProp } ( f : X -> P ) ( wit : ishinh_UU X ) : P :=  wit P f .\n\n\nDefinition hinhand { X Y : UU } ( inx1 : ishinh_UU X ) ( iny1 : ishinh_UU Y) : ishinh ( dirprod X Y ) := fun P:_  => ddualand (inx1 P) (iny1 P).\n\nDefinition 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 ) . \n\nDefinition 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 ) .\n\nDefinition hinhunivcor1 ( P : hProp ) : ishinh_UU P -> P := hinhuniv ( idfun P ).\nNotation hinhprinv := hinhunivcor1 .\n\n\n(** *** [ ishinh ] and negation [ neg ] *)\n\n\nLemma weqishinhnegtoneg ( X : UU ) : weq ( ishinh ( neg X ) ) ( neg X ) .\nProof . 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 . \n\nLemma weqnegtonegishinh ( X : UU ) : weq ( neg X ) ( neg ( ishinh X ) ) .\nProof . 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 . \n\n \n(** *** [ ishinh ] and [ coprod ] *)\n\n\nLemma hinhcoprod ( X Y : UU ) ( is : ishinh ( coprod ( ishinh X ) ( ishinh Y ) ) )  : ishinh ( coprod X Y ) .\nProof. 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).\n assert ( f : coprod ( ishinh X ) ( ishinh Y ) -> P ) .  apply ( sumofmaps ( hinhuniv CPX ) ( hinhuniv CPY ) ).   apply (is1P f ) . Defined. \n\n \n\n(** *** Intuitionistic logic on [ hProp ]. *)\n\n\nDefinition htrue : hProp := hProppair unit isapropunit.\n\nDefinition hfalse : hProp := hProppair empty isapropempty.\n\nDefinition hconj ( P Q : hProp ) : hProp := hProppair ( dirprod P Q ) ( isapropdirprod _ _ ( pr2 P ) ( pr2 Q ) ). \n\nDefinition hdisj ( P Q : UU ) : hProp :=  ishinh ( coprod P Q ) . \n\nDefinition hneg ( P : UU ) : hProp := hProppair ( neg P ) ( isapropneg P ) . \n\nDefinition himpl ( P : UU ) ( Q : hProp ) : hProp.\nProof. intros. split with ( P -> Q ) . apply impred. intro. apply (pr2  Q). Defined. \n\nDefinition hexists { X : UU } ( P : X -> UU ) := ishinh ( total2 P ) .\n\nDefinition wittohexists { X : UU } ( P : X -> UU ) ( x : X ) ( is : P x ) : hexists P := hinhpr ( total2 P ) (tpair _ x is ) .\n\nDefinition total2tohexists { X : UU } ( P : X -> UU ) : total2 P -> hexists P := hinhpr _ . \n\nDefinition weqneghexistsnegtotal2   { X : UU } ( P : X -> UU ) : weq ( neg ( hexists P ) ) ( neg ( total2 P ) ) .\nProof . 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 . \n\n\n(** *** Associativity and commutativity of [ hdisj ] and [ hconj ] up to logical equivalence *)\n\nLemma islogeqcommhdisj { P Q : hProp } : hdisj P Q <-> hdisj Q P .\nProof . intros . split . simpl .  apply hinhfun .  apply coprodcomm .  simpl .  apply hinhfun .  apply coprodcomm . Defined . \n \n\n\n(** *** 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/ *)\n\n\nLemma hconjtohdisj ( P Q : UU ) ( R : hProp ) :  hconj ( himpl P R ) ( himpl Q R ) -> himpl ( hdisj P Q ) R .\nProof.  intros P Q R X0. \nassert (s1: hdisj P Q -> R) . intro X1.  \nassert (s2: coprod P Q -> R ) . intro X2. destruct X2 as [ XP | XQ ].  apply X0. apply XP . apply ( pr2 X0 ). apply XQ . \napply ( hinhuniv s2 ). apply X1 .   unfold himpl. simpl . apply s1 .  Defined.\n\n\n\n\n(** *** Negation and quantification.\n\nThere 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 ??? . *)\n\nLemma hexistsnegtonegforall { X : UU } ( F : X -> UU ) : hexists ( fun x : X => neg ( F x ) ) -> neg ( forall x : X , F x ) .\nProof . 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 .\n\nLemma forallnegtoneghexists { X : UU } ( F : X -> UU ) : ( forall x : X , neg ( F x ) ) -> neg ( hexists F ) .\nProof. intros X F nf . change ( ( ishinh_UU ( total2 F ) ) -> hfalse ) . apply hinhuniv .   intro t2 . destruct t2 as [ x f ] .  apply ( nf x f ) . Defined . \n\nLemma neghexisttoforallneg { X : UU } ( F : X -> UU ) : neg ( hexists F ) -> forall x : X , neg ( F x ) .\nProof . intros X F nhe x . intro fx .  apply ( nhe ( hinhpr _ ( tpair F x fx ) ) ) . Defined . \n\nDefinition weqforallnegtonegexists { X : UU } ( F : X -> UU ) : weq ( forall x : X , neg ( F x ) ) ( neg ( hexists F ) ) .\nProof . intros . apply ( weqimplimpl ( forallnegtoneghexists F ) ( neghexisttoforallneg F ) ) . apply impred .   intro x . apply isapropneg . apply isapropneg . Defined . \n\n\n\n(** *** Negation and conjunction ( \"and\" ) and disjunction ( \"or\" ) . \n\nThere 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 ] .  *)\n\nLemma tonegdirprod { X Y : UU } ( is : hdisj ( neg X ) ( neg Y ) ) : neg ( dirprod X Y ) .\nProof. 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 .\n\nLemma tonegcoprod { X Y : UU } ( is : dirprod ( neg X ) ( neg Y ) ) : neg ( coprod X Y ) . \nProof . intros. intro c . destruct c as [ x | y ] . apply ( pr1 is x ) . apply ( pr2 is y ) . Defined . \n\nLemma toneghdisj { X Y : UU } ( is : dirprod ( neg X ) ( neg Y ) ) : neg ( hdisj X Y ) .\nProof . intros . unfold hdisj.  apply ( weqnegtonegishinh ) . apply tonegcoprod .  apply is .  Defined . \n\nLemma fromnegcoprod { X Y : UU } ( is : neg ( coprod X Y ) ) : dirprod ( neg X ) ( neg Y ) .\nProof .  intros . split .  exact ( fun x => is ( ii1 x ) ) . exact ( fun y => is ( ii2 y ) ) . Defined .\n\nLemma hdisjtoimpl { P : UU } { Q : hProp } : hdisj P Q -> ( neg P -> Q ) .\nProof . 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 . \n\n\n\n(** *** Property of being decidable and [ hdisj ] ( \"or\" ) .\n\nFor being deidable [ hconj ] see [ isdecpropdirprod ] in uu0.v  *)\n\nLemma isdecprophdisj { X Y : UU } ( isx : isdecprop X ) ( isy : isdecprop Y ) : isdecprop ( hdisj X Y ) .\nProof . 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 .    \n\n\n\n \n\n(** *** The double negation version of [ hinhabited ] ( does not require RR1 ) . *)\n\n\nDefinition isinhdneg ( X : UU ) : hProp := hProppair ( dneg X ) ( isapropdneg X ) .\n\nDefinition inhdnegpr (X:UU): X -> isinhdneg X := todneg X.\n\nDefinition inhdnegfun { X Y : UU } (f:X -> Y): isinhdneg X -> isinhdneg Y := dnegf  f.\n\nDefinition inhdneguniv (X: UU)(P:UU)(is:isweq  (todneg P)): (X -> P) -> ((isinhdneg X) -> P) := fun xp:_ => fun inx0:_ => (invmap ( weqpair _ is ) (dnegf  xp inx0)).\n\nDefinition inhdnegand (X Y:UU)(inx0: isinhdneg X)(iny0: isinhdneg Y) : isinhdneg (dirprod X Y) := dneganddnegimpldneg  inx0 iny0.\n\nDefinition hinhimplinhdneg (X:UU)(inx1: ishinh X): isinhdneg X := inx1 hfalse.\n\n\n(** ** Univalence axiom for hProp \n\nWe 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. \n\nThe proof of theorem [ univfromtwoaxiomshProp ] is modeled on the proof of [ univfromtwoaxioms ] from univ01.v \n\n\n*)\n\n\nAxiom uahp : forall P P':hProp,  (P -> P') -> (P' -> P) -> @paths hProp P P'.\n\nDefinition eqweqmaphProp { P P': hProp }  ( e: @paths hProp P P' ) : weq P P'.\nProof. intros . destruct e . apply idweq.  Defined.\n\nDefinition  weqtopathshProp { P P' : hProp } (w: weq P P' ): @paths hProp P P' := uahp P P' w ( invweq w ) .\n\nDefinition weqpathsweqhProp { P P' : hProp } (w : weq P P'): paths (eqweqmaphProp (weqtopathshProp w)) w.\nProof. intros. apply proofirrelevance . apply (isapropweqtoprop P P' (pr2 P')). Defined.\n\n\nTheorem univfromtwoaxiomshProp (P P':hProp): isweq (@eqweqmaphProp P P').\nProof. intros. \n\nset (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)). \n\nset (h:= fun a1:Z1 => (pr1 ( pr1 a1))).\nassert (egf0: forall a1:Z1,  paths ( pr1 (g (f a1))) ( pr1 a1)). intro. apply  idpath.  \nassert (egf1: forall a1 a1':Z1,  paths ( pr1 a1') ( pr1 a1) -> paths a1' a1). intros ? ? X .  set (X':=  maponpaths ( @pr1 _ _ )  X). \nassert (is:  isweq h). apply ( isweqpr1pr1 hProp ). apply ( invmaponpathsweq ( weqpair h is ) _ _ X').\nset (egf:= fun a1:_ => (egf1 _ _ (egf0 a1))). \nset (is2:= gradth _ _ egf efg). \napply ( isweqtotaltofib P1 P2  (fun XY: dirprod hProp hProp => (match XY with  tpair _ X Y => @eqweqmaphProp X Y end)) is2 ( dirprodpair P P')). Defined. \n\nDefinition weqeqweqhProp ( P P' : hProp ) := weqpair _ ( univfromtwoaxiomshProp P P' ) .\n\nCorollary isasethProp : isaset hProp.\nProof. unfold isaset.  simpl. intros x x'. apply (isofhlevelweqb (S O) ( weqeqweqhProp x x' ) (isapropweqtoprop x x' (pr2 x'))). Defined.\n\n\nLemma iscontrtildehProp : iscontr tildehProp .\nProof . 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 .\n\nLemma isaproptildehProp : isaprop tildehProp .\nProof . apply ( isapropifcontr iscontrtildehProp ) .  Defined .\n\nLemma isasettildehProp : isaset tildehProp .\nProof . apply ( isasetifcontr iscontrtildehProp ) . Defined .  \n\n\n\n(* End of the file hProp.v *)\n"
  },
  {
    "path": "hlevel2/algebra1a.v",
    "content": "(** * Algebra 1 . Part A .  Generalities. Vladimir Voevodsky. Aug. 2011 - . \n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)\n\n\n(** Imports *)\n\nAdd LoadPath \"../../\" .\n\nRequire Export Foundations.hlevel2.hSet .\n\n\n(** To upstream files *)\n\n\n\n(** ** Sets with one and two binary operations *)\n\n(** *** Binary operations *)\n\n(** **** General definitions *)\n\nDefinition binop ( X : UU ) := X -> X -> X .\n\nDefinition islcancelable { X : UU } ( opp : binop X ) ( x : X ) := isincl ( fun x0 : X => opp x x0 ) .\n\nDefinition isrcancelable { X : UU } ( opp : binop X ) ( x : X ) := isincl ( fun x0 : X => opp x0 x ) .\n\nDefinition iscancelable { X : UU } ( opp : binop X ) ( x : X )  := dirprod ( islcancelable opp x ) ( isrcancelable opp x ) . \n\nDefinition islinvertible { X : UU } ( opp : binop X ) ( x : X ) := isweq ( fun x0 : X => opp x x0 ) .\n\nDefinition isrinvertible { X : UU } ( opp : binop X ) ( x : X ) := isweq ( fun x0 : X => opp x0 x ) .\n\nDefinition isinvertible { X : UU } ( opp : binop X ) ( x : X ) := dirprod ( islinvertible opp x ) ( isrinvertible opp x ) . \n\n\n\n(** **** Standard conditions on one binary operation on a set *)\n\n(** *)\n\nDefinition isassoc { X : hSet} ( opp : binop X ) := forall x x' x'' , paths ( opp ( opp x x' ) x'' ) ( opp x ( opp x' x'' ) ) .\n\nLemma isapropisassoc { X : hSet } ( opp : binop X ) : isaprop ( isassoc opp ) .\nProof . intros . apply impred . intro x . apply impred . intro x' . apply impred . intro x'' . simpl . apply ( setproperty X ) . Defined .\n\n(** *)\n\nDefinition islunit { X : hSet} ( opp : binop X ) ( un0 : X ) := forall x : X , paths ( opp un0 x ) x .\n\nLemma isapropislunit { X : hSet} ( opp : binop X ) ( un0 : X ) : isaprop ( islunit opp un0 ) . \nProof . intros . apply impred . intro x . simpl . apply ( setproperty X ) .  Defined .  \n\nDefinition isrunit { X : hSet} ( opp : binop X ) ( un0 : X ) := forall x : X , paths ( opp x un0 ) x  .\n\nLemma isapropisrunit { X : hSet} ( opp : binop X ) ( un0 : X ) : isaprop ( isrunit opp un0 ) .\nProof . intros . apply impred . intro x . simpl . apply ( setproperty X ) .  Defined .  \n\nDefinition isunit { X : hSet} ( opp : binop X ) ( un0 : X ) := dirprod ( islunit opp un0 ) ( isrunit opp un0 ) .\n\nDefinition isunital { X : hSet} ( opp : binop X ) := total2 ( fun un0 : X => isunit opp un0 ) .\nDefinition isunitalpair { X : hSet } { opp : binop X } ( un0 : X ) ( is : isunit opp un0 ) : isunital opp := tpair _ un0 is .  \n\nLemma isapropisunital { X : hSet} ( opp : binop X )  : isaprop ( isunital opp ) .\nProof . 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 . \n\n\n(** *)\n\nDefinition ismonoidop { X : hSet } ( opp : binop X ) := dirprod ( isassoc opp ) ( isunital opp ) .\nDefinition assocax_is { X : hSet } { opp : binop X } : ismonoidop opp -> isassoc opp := @pr1 _ _ .  \nDefinition unel_is { X : hSet } { opp : binop X } ( is : ismonoidop opp ) : X := pr1 ( pr2 is ) .\nDefinition lunax_is { X : hSet } { opp : binop X } ( is : ismonoidop opp ) := pr1 ( pr2 ( pr2 is ) ) . \nDefinition runax_is { X : hSet } { opp : binop X } ( is : ismonoidop opp ) := pr2 ( pr2 ( pr2 is ) ) . \n\n\nLemma isapropismonoidop { X : hSet } ( opp : binop X ) : isaprop ( ismonoidop opp ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply ( isapropisassoc ) .  apply ( isapropisunital ) .  Defined .  \n\n\n\n(** *)\n\nDefinition islinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) := forall x : X , paths ( opp ( inv0 x ) x ) un0 .\n\nLemma isapropislinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) : isaprop ( islinv opp un0 inv0 ) .\nProof . intros . apply impred . intro x .  apply ( setproperty X (opp (inv0 x) x) un0 ) . Defined .\n\nDefinition isrinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) := forall x : X , paths ( opp x ( inv0 x ) ) un0 .\n\nLemma isapropisrinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) : isaprop ( isrinv opp un0 inv0 ) .\nProof . intros . apply impred . intro x .  apply ( setproperty X ) . Defined .\n\nDefinition isinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) := dirprod ( islinv opp un0 inv0 ) ( isrinv opp un0 inv0 ) . \n\nLemma isapropisinv { X : hSet } ( opp : binop X ) ( un0 : X ) ( inv0 : X -> X ) : isaprop ( isinv opp un0 inv0 ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply isapropislinv .  apply isapropisrinv . Defined .  \n\nDefinition invstruct { X : hSet } ( opp : binop X ) ( is : ismonoidop opp  ) := total2 ( fun inv0 : X -> X =>  isinv opp ( unel_is is ) inv0 ) .\n\nDefinition isgrop { X : hSet } ( opp : binop X ) := total2 ( fun is : ismonoidop opp => invstruct opp is ) .\nDefinition 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 . \nDefinition pr1isgrop ( X : hSet ) ( opp : binop X ) : isgrop opp -> ismonoidop opp := @pr1 _ _ .\nCoercion pr1isgrop : isgrop >-> ismonoidop . \n\nDefinition grinv_is { X : hSet } { opp : binop X } ( is : isgrop opp ) : X -> X := pr1 ( pr2 is ) . \n\nDefinition grlinvax_is { X : hSet } { opp : binop X } ( is : isgrop opp ) := pr1 ( pr2 ( pr2 is ) ) . \n\nDefinition grrinvax_is { X : hSet } { opp : binop X } ( is : isgrop opp ) := pr2 ( pr2 ( pr2 is ) ) . \n\n\nLemma isweqrmultingr_is { X : hSet } { opp : binop X } ( is : isgrop opp ) ( x0 : X ) : isrinvertible opp x0 .\nProof . 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 * |-  . \nassert ( 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 ) .  \nassert ( 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 ) .  \napply ( gradth _ _ egf efg ) . Defined .  \n\nLemma isweqlmultingr_is { X : hSet } { opp : binop X } ( is : isgrop opp )  ( x0 : X ) : islinvertible opp x0 .\nProof . 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 * |-  . \nassert ( 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 ) .  \nassert ( 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 ) .  \napply ( gradth _ _ egf efg ) . Defined .  \n\n\nLemma isapropinvstruct { X : hSet } { opp : binop X } ( is : ismonoidop opp ) : isaprop ( invstruct opp is ) . \nProof . 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 . \n\nLemma isapropisgrop { X : hSet } ( opp : binop X ) : isaprop ( isgrop opp ) .\nProof . intros . apply ( isofhleveltotal2 1 ) . apply isapropismonoidop . apply isapropinvstruct . Defined .  \n\n(* (** Unitary monoid where all elements are invertible is a group *)\n\nDefinition 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 ) .   \n\n*)\n\n\n(** The following lemma is an analog of [ Bourbaki , Alg. 1 , ex. 2 , p. 132 ] *)\n\nLemma 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 . \nProof . 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 .  \n\nassert ( 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' ) .  \n\nassert ( 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 . \n\nassert ( 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' ) .  \n\nassert ( 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 . \n\nsimpl . 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 . \n\n\n\n(** *)\n\nDefinition iscomm { X : hSet} ( opp : binop X ) := forall x x' : X , paths ( opp x x' ) ( opp x' x ) . \n\nLemma isapropiscomm { X : hSet } ( opp : binop X ) : isaprop ( iscomm opp ) .\nProof . intros . apply impred . intros x . apply impred . intro x' . simpl . apply ( setproperty X ) . Defined . \n\nDefinition isabmonoidop { X : hSet } ( opp : binop X ) := dirprod ( ismonoidop opp ) ( iscomm opp ) . \nDefinition pr1isabmonoidop ( X : hSet ) ( opp : binop X ) : isabmonoidop opp -> ismonoidop opp := @pr1 _ _ .\nCoercion pr1isabmonoidop : isabmonoidop >-> ismonoidop .\n\nDefinition commax_is { X : hSet} { opp : binop X } ( is : isabmonoidop opp ) : iscomm opp := pr2 is . \n\nLemma isapropisabmonoidop { X : hSet } ( opp : binop X ) : isaprop ( isabmonoidop opp ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply isapropismonoidop . apply isapropiscomm . Defined . \n\nLemma 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 ) ) .\nProof . 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 . \n\n\n\n\n(** *)\n\n\nLemma weqlcancelablercancelable { X : hSet } ( opp : binop X ) ( is : iscomm opp ) ( x : X ) : weq ( islcancelable opp x ) ( isrcancelable opp x ) .\nProof . intros . \n\nassert ( f : ( islcancelable opp x ) -> ( isrcancelable opp x ) ) . unfold islcancelable . unfold isrcancelable .  intro isl . apply ( fun h : _ => isinclhomot _ _ h isl ) .  intro x0 . apply is .  \nassert ( g : ( isrcancelable opp x ) -> ( islcancelable opp x ) ) . unfold islcancelable . unfold isrcancelable .  intro isr . apply ( fun h : _ => isinclhomot _ _ h isr ) .  intro x0 . apply is . \n\nsplit with f . apply ( isweqimplimpl f g ( isapropisincl ( fun x0 : X => opp x x0 ) )  ( isapropisincl ( fun x0 : X => opp x0 x ) ) ) .  Defined .  \n\n\n\nLemma weqlinvertiblerinvertible { X : hSet } ( opp : binop X ) ( is : iscomm opp ) ( x : X ) : weq ( islinvertible opp x ) ( isrinvertible opp x ) .\nProof . intros . \n\nassert ( f : ( islinvertible opp x ) -> ( isrinvertible opp x ) ) . unfold islinvertible . unfold isrinvertible .  intro isl . apply ( fun h : _ => isweqhomot _ _ h isl ) .  apply is .  \nassert ( g : ( isrinvertible opp x ) -> ( islinvertible opp x ) ) . unfold islinvertible . unfold isrinvertible .  intro isr . apply ( fun h : _ => isweqhomot _ _ h isr ) .  intro x0 . apply is . \n\nsplit with f . apply ( isweqimplimpl f g ( isapropisweq ( fun x0 : X => opp x x0 ) )  ( isapropisweq ( fun x0 : X => opp x0 x ) ) ) .  Defined .  \n\n\nLemma weqlunitrunit { X : hSet } ( opp : binop X ) ( is : iscomm opp ) ( un0 : X ) : weq ( islunit opp un0 ) ( isrunit opp un0 ) .\nProof . intros . \n\nassert ( f : ( islunit opp un0 ) -> ( isrunit opp un0 ) ) . unfold islunit . unfold isrunit .  intro isl .  intro x .  destruct ( is un0 x ) .  apply ( isl x ) .  \nassert ( g : ( isrunit opp un0 ) -> ( islunit opp un0 ) ) . unfold islunit . unfold isrunit .  intro isr . intro x .  destruct ( is x un0 ) .  apply ( isr x ) .  \n\nsplit with f . apply ( isweqimplimpl f g ( isapropislunit opp un0 )  ( isapropisrunit opp un0 ) ) .  Defined .  \n\n\nLemma weqlinvrinv { X : hSet } ( opp : binop X ) ( is : iscomm opp ) ( un0 : X ) ( inv0 : X -> X ) : weq ( islinv opp un0 inv0 ) ( isrinv opp un0 inv0 ) .\nProof . intros . \n\nassert ( 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 ) .  \nassert ( 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 ) .  \n\nsplit with f . apply ( isweqimplimpl f g ( isapropislinv opp un0 inv0 )  ( isapropisrinv opp un0 inv0 ) ) .  Defined .  \n\n\nOpaque abmonoidoprer .\n\n\n(** *)\n\nDefinition isabgrop { X : hSet } ( opp : binop X ) := dirprod ( isgrop opp ) ( iscomm opp ) .\nDefinition pr1isabgrop ( X : hSet ) ( opp : binop X ) : isabgrop opp -> isgrop opp := @pr1 _ _ .\nCoercion pr1isabgrop : isabgrop >-> isgrop .\n\nDefinition isabgroptoisabmonoidop ( X : hSet ) ( opp : binop X ) : isabgrop opp -> isabmonoidop opp := fun is : _ => dirprodpair ( pr1 ( pr1 is ) ) ( pr2 is ) .\nCoercion isabgroptoisabmonoidop : isabgrop >-> isabmonoidop .\n\nLemma isapropisabgrop { X : hSet } ( opp : binop X ) : isaprop ( isabgrop opp ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply isapropisgrop . apply isapropiscomm . Defined .  \n\n\n\n\n\n\n\n\n(** **** Standard conditions on a pair of binary operations on a set *)\n\n(** *)\n\nDefinition 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' ) ) .\n\nLemma isapropisldistr { X : hSet} ( opp1 opp2 : binop X ) : isaprop ( isldistr opp1 opp2 ) .\nProof . intros . apply impred . intro x . apply impred . intro x' . apply impred . intro x'' . simpl . apply ( setproperty X ) . Defined .   \n\nDefinition 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'' ) ) .\n\nLemma isapropisrdistr { X : hSet} ( opp1 opp2 : binop X ) : isaprop ( isrdistr opp1 opp2 ) .\nProof . intros . apply impred . intro x . apply impred . intro x' . apply impred . intro x'' . simpl . apply ( setproperty X ) . Defined .   \n\nDefinition isdistr { X : hSet } ( opp1 opp2 : binop X ) := dirprod ( isldistr opp1 opp2 ) ( isrdistr opp1 opp2 ) .\n\nLemma isapropisdistr { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( isdistr opp1 opp2  ) .\nProof . intros . apply ( isofhleveldirprod 1 _ _ ( isapropisldistr _ _ ) ( isapropisrdistr _ _ ) ) . Defined .  \n\n(** *)\n\nLemma weqldistrrdistr { X : hSet} ( opp1 opp2 : binop X ) ( is : iscomm opp2 ) : weq ( isldistr opp1 opp2 ) ( isrdistr opp1 opp2 ) .\nProof .  intros . \n\nassert ( 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'' ) .  \nassert ( 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'' ) .   \n\nsplit with f . apply ( isweqimplimpl f g ( isapropisldistr opp1 opp2 )  ( isapropisrdistr opp1 opp2 ) ) .  Defined . \n\n\n(** *)\n\n\nDefinition 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 ) .\n    \nDefinition rigop1axs_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> isabmonoidop opp1 := fun is : _ => pr1 ( pr1 ( pr1 is ) ) .\nDefinition rigop2axs_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> ismonoidop opp2 := fun is : _ => pr2 ( pr1 ( pr1 is ) ) .\nDefinition rigdistraxs_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> isdistr opp1 opp2 := fun is : _ =>  pr2 is .\nDefinition rigldistrax_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> isldistr opp1 opp2 := fun is : _ => pr1 ( pr2 is ) .\nDefinition rigrdistrax_is { X : hSet } { opp1 opp2 : binop X } : isrigops opp1 opp2 -> isrdistr opp1 opp2 := fun is : _ => pr2 ( pr2 is ) .\nDefinition rigunel1_is { X : hSet } { opp1 opp2 : binop X } ( is : isrigops opp1 opp2 ) : X := pr1 (pr2 (pr1 (rigop1axs_is is))) .\nDefinition rigunel2_is { X : hSet } { opp1 opp2 : binop X } ( is : isrigops opp1 opp2 ) : X := (pr1 (pr2 (rigop2axs_is is))) .\nDefinition 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 .\nDefinition 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 .\n\n\nLemma isapropisrigops { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( isrigops opp1 opp2 ) .\nProof . 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 . \n\n\n\n\n(** *)\n\n\nDefinition isrngops { X : hSet } ( opp1 opp2 : binop X ) := dirprod ( dirprod ( isabgrop opp1 ) ( ismonoidop opp2 ) ) ( isdistr opp1 opp2 ) . \n\nDefinition rngop1axs_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> isabgrop opp1 := fun is : _ => pr1 ( pr1 is ) .\nDefinition rngop2axs_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> ismonoidop opp2 := fun is : _ => pr2 ( pr1 is ) .\nDefinition rngdistraxs_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> isdistr opp1 opp2 := fun is : _ =>  pr2 is .\nDefinition rngldistrax_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> isldistr opp1 opp2 := fun is : _ => pr1 ( pr2 is ) .\nDefinition rngrdistrax_is { X : hSet } { opp1 opp2 : binop X } : isrngops opp1 opp2 -> isrdistr opp1 opp2 := fun is : _ => pr2 ( pr2 is ) .\nDefinition rngunel1_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) : X := unel_is ( pr1 ( pr1 is ) ) .\nDefinition rngunel2_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) : X := unel_is ( pr2 ( pr1 is ) ) .\n\n\nLemma isapropisrngops { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( isrngops opp1 opp2 ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply ( isofhleveldirprod 1 ) . apply isapropisabgrop . apply isapropismonoidop. apply isapropisdistr . Defined . \n\nLemma 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 ) )  .\nProof . 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 .\n\nOpaque multx0_is_l .\n\nLemma 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 ) ) .\nProof . 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 .\n\nOpaque mult0x_is_l .\n\n\n\nDefinition minus1_is_l { X : hSet } { opp1 opp2 : binop X } ( is1 : isgrop opp1 ) ( is2 : ismonoidop opp2 ) := ( grinv_is is1 ) ( unel_is is2 ) . \n\nLemma 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 ) ) .\nProof . 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 . \n\nOpaque islinvmultwithminus1_is_l .\n\nLemma 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 ) ) .\nProof . 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 . \n\nOpaque isrinvmultwithminus1_is_l . \n\n\nLemma 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 ) .\nProof . 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 . \n\nOpaque isminusmultwithminus1_is_l . \n\nLemma isrngopsif { X : hSet } { opp1 opp2 : binop X } ( is1 : isgrop opp1 ) ( is2 : ismonoidop opp2 ) ( is12 : isdistr opp1 opp2 ) : isrngops opp1 opp2 .\nProof . intros .  set ( assoc1 := pr1 ( pr1 is1 ) ) . split . split .  split with is1 . \nintros 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 .\n\nDefinition rngmultx0_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) := multx0_is_l ( rngop1axs_is is ) ( rngop2axs_is is ) ( rngdistraxs_is is )  .\n\nDefinition rngmult0x_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) := mult0x_is_l ( rngop1axs_is is ) ( rngop2axs_is is ) ( rngdistraxs_is is )  .\n\nDefinition rngminus1_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) := minus1_is_l ( rngop1axs_is is ) ( rngop2axs_is is ) .\n\nDefinition rngmultwithminus1_is { X : hSet } { opp1 opp2 : binop X } ( is : isrngops opp1 opp2 ) := isminusmultwithminus1_is_l ( rngop1axs_is is ) ( rngop2axs_is is ) ( rngdistraxs_is is ) .\n \nDefinition isrngopstoisrigops ( X : hSet ) ( opp1 opp2 : binop X ) ( is : isrngops opp1 opp2 ) : isrigops opp1 opp2 .\nProof. 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 . \n\nCoercion isrngopstoisrigops : isrngops >-> isrigops . \n\n\n\n(** *)\n\nDefinition iscommrigops { X : hSet } ( opp1 opp2 : binop X )  :=  dirprod ( isrigops opp1 opp2 ) ( iscomm opp2 ) .\nDefinition pr1iscommrigops ( X : hSet ) ( opp1 opp2 : binop X ) : iscommrigops opp1 opp2 -> isrigops opp1 opp2 := @pr1 _ _ .\nCoercion pr1iscommrigops : iscommrigops >-> isrigops .  \n\nDefinition rigiscommop2_is { X : hSet } { opp1 opp2 : binop X } ( is : iscommrigops opp1 opp2 ) : iscomm opp2 := pr2 is . \n\nLemma isapropiscommrig  { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( iscommrigops opp1 opp2 ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply isapropisrigops . apply isapropiscomm . Defined .\n\n\n\n\n\n\n(** *) \n\nDefinition iscommrngops { X : hSet } ( opp1 opp2 : binop X )  :=  dirprod ( isrngops opp1 opp2 ) ( iscomm opp2 ) . \nDefinition pr1iscommrngops ( X : hSet ) ( opp1 opp2 : binop X ) : iscommrngops opp1 opp2 -> isrngops opp1 opp2 := @pr1 _ _ .\nCoercion pr1iscommrngops : iscommrngops >-> isrngops .  \n\nDefinition rngiscommop2_is { X : hSet } { opp1 opp2 : binop X } ( is : iscommrngops opp1 opp2 ) : iscomm opp2 := pr2 is . \n\nLemma isapropiscommrng  { X : hSet } ( opp1 opp2 : binop X ) : isaprop ( iscommrngops opp1 opp2 ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply isapropisrngops . apply isapropiscomm . Defined . \n\nDefinition iscommrngopstoiscommrigops ( X : hSet ) ( opp1 opp2 : binop X ) ( is : iscommrngops opp1 opp2 ) : iscommrigops opp1 opp2 := dirprodpair ( isrngopstoisrigops _ _ _ ( pr1 is ) ) ( pr2 is ) .\nCoercion iscommrngopstoiscommrigops : iscommrngops >-> iscommrigops . \n\n\n\n\n(** *** Sets with one binary operation *)\n\n(** **** General definitions *)\n\n\nDefinition setwithbinop := total2 ( fun X : hSet => binop X ) . \nDefinition setwithbinoppair ( X : hSet ) ( opp : binop X ) : setwithbinop := tpair ( fun X : hSet => binop X ) X opp .\nDefinition pr1setwithbinop : setwithbinop -> hSet := @pr1 _ ( fun X : hSet => binop X ) .\nCoercion pr1setwithbinop : setwithbinop >-> hSet .\n\n\nDefinition op { X : setwithbinop } : binop X := pr2 X . \n\nNotation \"x + y\" := ( op x y ) : addoperation_scope .\nNotation \"x * y\" := ( op x y ) : multoperation_scope .  \n\n\n\n(** **** Functions compatible with a binary operation ( homomorphisms ) and their properties *)\n\nDefinition isbinopfun { X Y : setwithbinop } ( f : X -> Y ) := forall x x' : X , paths ( f ( op x x' ) ) ( op ( f x ) ( f x' ) ) . \n\nLemma isapropisbinopfun { X Y : setwithbinop } ( f : X -> Y ) : isaprop ( isbinopfun f ) .\nProof . intros . apply impred . intro x . apply impred . intro x' . apply ( setproperty Y ) . Defined .\n\nDefinition binopfun ( X Y : setwithbinop ) : UU := total2 ( fun f : X -> Y => isbinopfun f ) .\nDefinition binopfunpair { X Y : setwithbinop } ( f : X -> Y ) ( is : isbinopfun f ) : binopfun X Y := tpair _ f is . \nDefinition pr1binopfun ( X Y : setwithbinop ) : binopfun X Y -> ( X -> Y ) := @pr1 _ _ . \nCoercion pr1binopfun : binopfun >-> Funclass . \n\nLemma isasetbinopfun  ( X Y : setwithbinop ) : isaset ( binopfun X Y ) .\nProof . intros . apply ( isasetsubset ( pr1binopfun X Y  ) ) . change ( isofhlevel 2 ( X -> Y ) ) . apply impred .  intro . apply ( setproperty Y ) . apply isinclpr1 .  intro .  apply isapropisbinopfun . Defined .  \n\nLemma isbinopfuncomp { X Y Z : setwithbinop } ( f : binopfun X Y ) ( g : binopfun Y Z ) : isbinopfun ( funcomp ( pr1 f ) ( pr1 g ) ) .\nProof . 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 .  \n\nOpaque isbinopfuncomp . \n\nDefinition 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 ) . \n\n\nDefinition binopmono ( X Y : setwithbinop ) : UU := total2 ( fun f : incl X Y => isbinopfun ( pr1 f ) ) .\nDefinition binopmonopair { X Y : setwithbinop } ( f : incl X Y ) ( is : isbinopfun f ) : binopmono X Y := tpair _  f is .\nDefinition pr1binopmono ( X Y : setwithbinop ) : binopmono X Y -> incl X Y := @pr1 _ _ .\nCoercion pr1binopmono : binopmono >-> incl .\n\nDefinition binopincltobinopfun ( X Y : setwithbinop ) : binopmono X Y -> binopfun X Y := fun f => binopfunpair ( pr1 ( pr1 f ) ) ( pr2 f ) .\nCoercion binopincltobinopfun : binopmono >-> binopfun . \n\n\nDefinition 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 ) . \n\nDefinition binopiso ( X Y : setwithbinop ) : UU := total2 ( fun f : weq X Y => isbinopfun f ) .   \nDefinition binopisopair { X Y : setwithbinop } ( f : weq X Y ) ( is : isbinopfun f ) : binopiso X Y := tpair _  f is .\nDefinition pr1binopiso ( X Y : setwithbinop ) : binopiso X Y -> weq X Y := @pr1 _ _ .\nCoercion pr1binopiso : binopiso >-> weq .\n\nDefinition binopisotobinopmono ( X Y : setwithbinop ) : binopiso X Y -> binopmono X Y := fun f => binopmonopair ( pr1 f ) ( pr2 f ) .\nCoercion binopisotobinopmono : binopiso >-> binopmono . \n\nDefinition 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 ) .\n\nLemma isbinopfuninvmap { X Y : setwithbinop } ( f : binopiso X Y ) : isbinopfun ( invmap ( pr1 f ) ) . \nProof . 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 .\n\nOpaque isbinopfuninvmap .  \n\nDefinition invbinopiso { X Y : setwithbinop } ( f : binopiso X Y ) : binopiso Y X := binopisopair ( invweq ( pr1 f ) ) ( isbinopfuninvmap f ) .\n\n\n\n(** **** Transport of properties of a binary operation  *)\n\n\nLemma isincltwooutof3a { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isg : isincl g ) ( isgf : isincl ( funcomp f g ) ) : isincl f .\nProof . intros . apply ( isofhlevelff 1 f g isgf ) .  apply ( isofhlevelfsnincl 1 g isg ) . Defined .\n\n\nLemma islcancelablemonob { X Y : setwithbinop } ( f : binopmono X Y ) ( x : X ) ( is : islcancelable ( @op Y ) ( f x ) ) : islcancelable ( @op X ) x .\nProof . intros .  unfold islcancelable . apply ( isincltwooutof3a (fun x0 : X => op x x0) f ( pr2 ( pr1 f ) ) ) .    \n\nassert ( 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 ) ) . \n\napply ( isinclhomot _ _ h ) . apply ( isinclcomp f ( inclpair _ is ) ) .  Defined .\n\n\nLemma isrcancelablemonob { X Y : setwithbinop } ( f : binopmono X Y ) ( x : X ) ( is : isrcancelable ( @op Y ) ( f x ) ) : isrcancelable ( @op X ) x .\nProof . intros .  unfold islcancelable . apply ( isincltwooutof3a (fun x0 : X => op x0 x) f ( pr2 ( pr1 f ) ) ) .    \n\nassert ( 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 ) ) . \n\napply ( isinclhomot _ _ h ) . apply ( isinclcomp f ( inclpair _ is ) ) .  Defined .\n\n\nLemma iscancelablemonob { X Y : setwithbinop } ( f : binopmono X Y ) ( x : X ) ( is : iscancelable ( @op Y ) ( f x ) ) : iscancelable ( @op X ) x . \nProof . intros . apply ( dirprodpair ( islcancelablemonob f x ( pr1 is ) ) ( isrcancelablemonob f x ( pr2 is ) ) ) . Defined .\n\nNotation islcancelableisob := islcancelablemonob . \nNotation isrcancelableisob := isrcancelablemonob . \nNotation iscancelableisob := iscancelablemonob .\n\n\nLemma islinvertibleisob  { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : islinvertible ( @op Y ) ( f x ) ) : islinvertible ( @op X ) x .\nProof . intros .  unfold islinvertible . apply ( twooutof3a (fun x0 : X => op x x0) f ) .     \n\nassert ( 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 ) ) . \n\napply ( isweqhomot _ _ h ) . apply ( pr2 ( weqcomp f ( weqpair _ is ) ) ) . apply ( pr2 ( pr1 f ) ) . Defined .  \n\nLemma isrinvertibleisob { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : isrinvertible ( @op Y ) ( f x ) ) : isrinvertible ( @op X ) x .\nProof . intros .  unfold islinvertible . apply ( twooutof3a (fun x0 : X => op x0 x) f ) .    \n\nassert ( 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 ) ) . \n\napply ( isweqhomot _ _ h ) . apply ( pr2 ( weqcomp f ( weqpair _ is ) ) ) . apply ( pr2 ( pr1 f ) ) . Defined .\n\n\nLemma isinvertiblemonob { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : isinvertible ( @op Y ) ( f x ) ) : isinvertible ( @op X ) x . \nProof . intros . apply ( dirprodpair ( islinvertibleisob f x ( pr1 is ) ) ( isrinvertibleisob f x ( pr2 is ) ) ) . Defined .\n\n\nDefinition islinvertibleisof  { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : islinvertible ( @op X ) x ) : islinvertible ( @op Y ) ( f x ) .\nProof . intros . unfold islinvertible . apply ( twooutof3b f ) .  apply ( pr2 ( pr1 f ) ) .    \n\nassert ( 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 ) .\n\napply ( isweqhomot _ _ h ) . apply ( pr2 ( weqcomp ( weqpair _ is ) f ) ) . Defined .  \n\nDefinition isrinvertibleisof  { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : isrinvertible ( @op X ) x ) : isrinvertible ( @op Y ) ( f x ) .\nProof . intros . unfold isrinvertible . apply ( twooutof3b f ) .  apply ( pr2 ( pr1 f ) ) .    \n\nassert ( 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 ) .\n\napply ( isweqhomot _ _ h ) . apply ( pr2 ( weqcomp ( weqpair _ is ) f ) ) . Defined . \n\nLemma isinvertiblemonof { X Y : setwithbinop } ( f : binopiso X Y ) ( x : X ) ( is : isinvertible ( @op X ) x ) : isinvertible ( @op Y ) ( f x ) . \nProof . intros . apply ( dirprodpair ( islinvertibleisof f x ( pr1 is ) ) ( isrinvertibleisof f x ( pr2 is ) ) ) . Defined .\n\n\nLemma isassocmonob { X Y : setwithbinop } ( f : binopmono X Y ) ( is : isassoc ( @op Y ) ) : isassoc ( @op X ) .\nProof . 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 .   \n\nOpaque isassocmonob .\n\nLemma iscommmonob { X Y : setwithbinop } ( f : binopmono X Y ) ( is : iscomm ( @op Y ) ) : iscomm ( @op X ) .\nProof . 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 .  \n\nOpaque iscommmonob .\n\nNotation isassocisob := isassocmonob .\nNotation iscommisob := iscommmonob . \n\nLemma isassocisof  { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isassoc ( @op X ) ) : isassoc ( @op Y ) .\nProof . intros . apply ( isassocmonob ( invbinopiso f ) is ) . Defined .  \n\nOpaque isassocisof .\n\nLemma iscommisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : iscomm ( @op X ) ) : iscomm ( @op Y ) .\nProof . intros .  apply ( iscommmonob ( invbinopiso f ) is ) . Defined . \n\nOpaque iscommisof . \n\nLemma isunitisof { X Y : setwithbinop } ( f : binopiso X Y ) ( unx : X ) ( is : isunit ( @op X ) unx ) : isunit ( @op Y ) ( f unx ) .\nProof . intros . set ( axf := pr2 f ) .  split . \n\nintro 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 ) .  \n\nintro 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 .   \n\nOpaque isunitisof . \n\nDefinition 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 ) ) .\n\nLemma isunitisob { X Y : setwithbinop } ( f : binopiso X Y ) ( uny : Y ) ( is : isunit ( @op Y ) uny ) : isunit ( @op X ) ( ( invmap f ) uny ) .\nProof . intros . set ( int := isunitisof ( invbinopiso f ) ) .  simpl . simpl in int . apply int .  apply is .  Defined .\n\nOpaque isunitisob .\n\nDefinition 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 ) ) .\n\n\nDefinition ismonoidopisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : ismonoidop ( @op X ) ) : ismonoidop ( @op Y ) := dirprodpair ( isassocisof f ( pr1 is ) ) ( isunitalisof f ( pr2 is ) ) . \n\nDefinition ismonoidopisob { X Y : setwithbinop } ( f : binopiso X Y ) ( is : ismonoidop ( @op Y ) ) : ismonoidop ( @op X ) := dirprodpair ( isassocisob f ( pr1 is ) ) ( isunitalisob f ( pr2 is ) ) . \n\nLemma 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 ) ) ) .\nProof . intros . set ( axf := pr2 f ) . set ( axinvf := pr2 ( invbinopiso f ) ) .  simpl in axf . simpl in axinvf . unfold funcomp . split .\n\nintro 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 ) .   \n\nintro 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 .      \n\nOpaque isinvisof .\n\nDefinition 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 ) ) ) ) .  \n\nLemma 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 ) ) ) ) .\nProof . intros . apply ( isinvisof ( invbinopiso f ) uny invy is ) . Defined .  \n\nOpaque isinvisob .\n\nDefinition 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 ) ) ) ) .\n\nDefinition isabmonoidopisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isabmonoidop ( @op X ) ) : isabmonoidop ( @op Y ) := tpair _ ( ismonoidopisof f is ) ( iscommisof f ( commax_is is ) )  . \n\nDefinition isabmonoidopisob { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isabmonoidop ( @op Y ) ) : isabmonoidop ( @op X ) := tpair _ ( ismonoidopisob f is ) ( iscommisob f ( commax_is is ) )  .\n\n\nDefinition isabgropisof { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isabgrop ( @op X ) ) : isabgrop ( @op Y ) := tpair _ ( isgropisof f is ) ( iscommisof f ( commax_is is ) )  . \n\nDefinition isabgropisob { X Y : setwithbinop } ( f : binopiso X Y ) ( is : isabgrop ( @op Y ) ) : isabgrop ( @op X ) := tpair _ ( isgropisob f is ) ( iscommisob f ( commax_is is ) )  .\n\n \n\n\n   \n\n\n(** **** Subobjects *)\n\nDefinition issubsetwithbinop { X : hSet } ( opp : binop X ) ( A : hsubtypes X ) := forall a a' : A , A ( opp ( pr1 a ) ( pr1 a' ) ) .\n\nLemma isapropissubsetwithbinop { X : hSet } ( opp : binop X ) ( A : hsubtypes X ) : isaprop ( issubsetwithbinop opp A ) .\nProof .  intros .  apply impred .  intro a . apply impred . intros a' . apply ( pr2 ( A ( opp (pr1 a) (pr1 a')) ) ) . Defined .\n\nDefinition subsetswithbinop { X : setwithbinop } := total2 ( fun A : hsubtypes X => issubsetwithbinop ( @op X ) A ) .\nDefinition subsetswithbinoppair { X : setwithbinop } := tpair ( fun A : hsubtypes X => issubsetwithbinop ( @op X ) A ) . \nDefinition subsetswithbinopconstr { X : setwithbinop } := @subsetswithbinoppair X .  \nDefinition pr1subsetswithbinop ( X : setwithbinop ) : @subsetswithbinop X -> hsubtypes X := @pr1 _ ( fun A : hsubtypes X => issubsetwithbinop ( @op X ) A ) . \nCoercion pr1subsetswithbinop : subsetswithbinop >-> hsubtypes .\n\nDefinition totalsubsetwithbinop ( X : setwithbinop ) : @subsetswithbinop X .\nProof . intros .  split with ( fun x : X => htrue ) . intros x x' .  apply tt . Defined .  \n\n\nDefinition carrierofasubsetwithbinop { X : setwithbinop } ( A : @subsetswithbinop X ) : setwithbinop .\nProof . intros . set ( aset := ( hSetpair ( carrier A ) ( isasetsubset ( pr1carrier A ) ( setproperty X ) ( isinclpr1carrier A ) ) ) : hSet ) . split with aset . \nset ( 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 . \n\nCoercion carrierofasubsetwithbinop : subsetswithbinop >-> setwithbinop . \n\n\n\n\n\n\n(** **** Relations compatible with a binary operation and quotient objects *)\n\nDefinition 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 ) ) .\n\nDefinition isbinophrellogeqf { X : setwithbinop } { L R : hrel X } ( lg : hrellogeq L R ) ( isl : isbinophrel L ) : isbinophrel R .\nProof . 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 .     \n\nLemma isapropisbinophrel { X : setwithbinop } ( R : hrel X ) : isaprop ( isbinophrel R ) . \nProof . 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 .\n  \nLemma 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 . \nProof . intros . split with isl .  intros a b c rab .  destruct ( is c a ) . destruct ( is c b ) . apply ( isl _ _ _ rab ) . Defined .  \n \nLemma iscompbinoptransrel { X : setwithbinop } ( R : hrel X ) ( ist : istrans R )  ( isb : isbinophrel R ) : iscomprelrelfun2 R R ( @op X ) . \nProof . 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 .  \n\nLemma isbinopreflrel { X : setwithbinop } ( R : hrel X ) ( isr : isrefl R )  ( isb : iscomprelrelfun2 R R ( @op X ) ) : isbinophrel R .\nProof . 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 . \n\n\nDefinition binophrel { X : setwithbinop } := total2 ( fun R : hrel X => isbinophrel R ) .\nDefinition binophrelpair { X : setwithbinop } := tpair ( fun R : hrel X => isbinophrel R ) .\nDefinition pr1binophrel ( X : setwithbinop ) : @binophrel X -> hrel X := @pr1 _ ( fun R : hrel X => isbinophrel R ) .\nCoercion pr1binophrel : binophrel >-> hrel . \n\nDefinition binoppo { X : setwithbinop } := total2 ( fun R : po X => isbinophrel R ) .\nDefinition binoppopair { X : setwithbinop } := tpair ( fun R : po X => isbinophrel R ) .\nDefinition pr1binoppo ( X : setwithbinop ) : @binoppo X -> po X := @pr1 _ ( fun R : po X => isbinophrel R ) .\nCoercion pr1binoppo : binoppo >-> po . \n\nDefinition binopeqrel { X : setwithbinop } := total2 ( fun R : eqrel X => isbinophrel R ) .\nDefinition binopeqrelpair { X : setwithbinop } := tpair ( fun R : eqrel X => isbinophrel R ) .\nDefinition pr1binopeqrel ( X : setwithbinop ) : @binopeqrel X -> eqrel X := @pr1 _ ( fun R : eqrel X => isbinophrel R ) .\nCoercion pr1binopeqrel : binopeqrel >-> eqrel . \n\nDefinition setwithbinopquot { X : setwithbinop } ( R : @binopeqrel X ) : setwithbinop .\nProof . intros . split with ( setquotinset R )  .  set ( qt  := setquot R ) . set ( qtset := setquotinset R ) .  \nassert ( iscomp : iscomprelrelfun2 R R op ) . apply ( iscompbinoptransrel R ( eqreltrans R ) ( pr2 R ) ) .\nset ( qtmlt := setquotfun2 R R op iscomp ) .   simpl . unfold binop . apply qtmlt . Defined . \n\n\nDefinition 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 ) ) .\n\nDefinition isbinoptoispartbinop { X : setwithbinop } ( S : hsubtypes X ) ( L : hrel X ) ( is : isbinophrel L ) : ispartbinophrel S L .\nProof . 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 .  \n\nDefinition ispartbinophrellogeqf { X : setwithbinop } ( S : hsubtypes X ) { L R : hrel X } ( lg : hrellogeq L R ) ( isl : ispartbinophrel S L ) : ispartbinophrel S R .\nProof . 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 .    \n\nLemma 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 .\nProof . intros .  split with isl .  intros a b c s rab .  destruct ( is c a ) . destruct ( is c b ) . apply ( isl _ _ _ s rab ) . Defined .  \n  \n\n\n(** **** Relations inversely compatible with a binary operation *)\n\nDefinition 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 ) .\n\nDefinition isinvbinophrellogeqf { X : setwithbinop } { L R : hrel X } ( lg : hrellogeq L R ) ( isl : isinvbinophrel L ) : isinvbinophrel R .\nProof . 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 .  \n\nLemma isapropisinvbinophrel { X : setwithbinop } ( R : hrel X ) : isaprop ( isinvbinophrel R ) . \nProof . 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 .     \n\nLemma 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 . \nProof . intros . split with isl .  intros a b c rab .  destruct ( is c a ) . destruct ( is c b ) . apply ( isl _ _ _ rab ) . Defined . \n\n\n\n \n \nDefinition 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 ) .\n\nDefinition isinvbinoptoispartinvbinop { X : setwithbinop } ( S : hsubtypes X ) ( L : hrel X ) ( is : isinvbinophrel L ) : ispartinvbinophrel S L .\nProof . 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 .  \n\nDefinition ispartinvbinophrellogeqf { X : setwithbinop } ( S : hsubtypes X ) { L R : hrel X } ( lg : hrellogeq L R ) ( isl : ispartinvbinophrel S L ) : ispartinvbinophrel S R .\nProof . 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 .  \n\nLemma 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 .\nProof . intros .  split with isl .  intros a b c s rab .  destruct ( is c a ) . destruct ( is c b ) . apply ( isl _ _ _ s rab ) . Defined .   \n\n\n(** **** Homomorphisms and relations *)\n\nLemma 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' ) ) . \nProof . intros . set ( ish := ( pr2 f ) : forall a0 b0 , paths ( f ( op a0 b0 ) ) ( op ( f a0 ) ( f b0 ) ) ) . split . \n\nintros a b c r . rewrite ( ish _ _ ) .   rewrite ( ish _ _ ) .  apply ( pr1 is ) . apply r . \n\nintros a b c r . rewrite ( ish _ _ ) .   rewrite ( ish _ _ ) .  apply ( pr2 is ) . apply r . Defined . \n\n\nLemma 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' ) ) . \nProof . intros . set ( ish := ( pr2 f ) : forall a0 b0 , paths ( f ( op a0 b0 ) ) ( op ( f a0 ) ( f b0 ) ) ) . split . \n\nintros a b c s r . rewrite ( ish _ _ ) .   rewrite ( ish _ _ ) .  apply ( ( pr1 is ) _ _ _ ( iss _ s ) r ) .  \n\nintros a b c s r . rewrite ( ish _ _ ) .   rewrite ( ish _ _ ) .  apply ( ( pr2 is ) _ _ _ ( iss _ s ) r ) . Defined .  \n\nLemma 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' ) ) .\nProof . intros .  set ( ish := ( pr2 f ) : forall a0 b0 , paths ( f ( op a0 b0 ) ) ( op ( f a0 ) ( f b0 ) ) ) . split . \n\nintros a b c r . rewrite ( ish _ _ ) in r .   rewrite ( ish _ _ ) in r .  apply ( ( pr1 is ) _ _ _ r ) .  \n\nintros a b c r . rewrite ( ish _ _ ) in r .   rewrite ( ish _ _ ) in r .  apply ( ( pr2 is ) _ _ _ r ) . Defined . \n \n\nLemma 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' ) ) . \nProof . intros .  set ( ish := ( pr2 f ) : forall a0 b0 , paths ( f ( op a0 b0 ) ) ( op ( f a0 ) ( f b0 ) ) ) . split . \n\nintros a b c s r . rewrite ( ish _ _ ) in r .   rewrite ( ish _ _ ) in r .  apply ( ( pr1 is ) _ _ _ ( iss _ s ) r ) .  \n\nintros a b c s r . rewrite ( ish _ _ ) in r .   rewrite ( ish _ _ ) in r .  apply ( ( pr2 is ) _ _ _ ( iss _ s ) r ) . Defined . \n\n\n(** **** Quotient relations *)\n\nLemma isbinopquotrel { X : setwithbinop } ( R : @binopeqrel X ) { L : hrel X } ( is : iscomprelrel R L ) ( isl : isbinophrel L ) : @isbinophrel ( setwithbinopquot R ) ( quotrel is ) . \nProof .  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 )  . \n 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 .  \n\n\n\n(** **** Direct products *)\n\nDefinition setwithbinopdirprod ( X Y : setwithbinop ) : setwithbinop .\nProof . intros . split with ( setdirprod X Y ) . unfold binop .  simpl . \n\n(* ??? 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 -> .. *)\n\napply ( fun xy xy' : dirprod X Y => dirprodpair ( op ( pr1 xy ) ( pr1 xy' ) ) ( op ( pr2 xy ) ( pr2 xy' ) ) ) . Defined .  \n\n\n\n\n\n\n(** *** Sets with two binary operations *)\n\n(** **** General definitions *)\n\n\nDefinition setwith2binop := total2 ( fun X : hSet => dirprod ( binop X ) ( binop X ) ) . \nDefinition setwith2binoppair ( X : hSet ) ( opps : dirprod ( binop X ) ( binop X ) ) : setwith2binop := tpair ( fun X : hSet => dirprod ( binop X ) ( binop X ) ) X opps .\nDefinition pr1setwith2binop : setwith2binop -> hSet := @pr1 _ ( fun X : hSet => dirprod ( binop X ) ( binop X ) ) .\nCoercion pr1setwith2binop : setwith2binop >-> hSet . \n\nDefinition op1 { X : setwith2binop } : binop X := pr1 ( pr2 X ) .\nDefinition op2 { X : setwith2binop } : binop X := pr2 ( pr2 X ) .\n\nDefinition setwithbinop1 ( X : setwith2binop ) : setwithbinop := setwithbinoppair ( pr1 X ) ( @op1 X ) . \nDefinition setwithbinop2 ( X : setwith2binop ) : setwithbinop := setwithbinoppair ( pr1 X ) ( @op2 X ) . \n\nNotation \"x + y\" := ( op1 x y ) : twobinops_scope .\nNotation \"x * y\" := ( op2 x y ) : twobinops_scope .   \n\n\n(** **** Functions compatible with a pair of binary operation ( homomorphisms ) and their properties *)\n\nDefinition 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' ) ) )  . \n\nLemma isapropistwobinopfun { X Y : setwith2binop } ( f : X -> Y ) : isaprop ( istwobinopfun f ) .\nProof . 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 .\n\nDefinition twobinopfun ( X Y : setwith2binop ) : UU := total2 ( fun f : X -> Y => istwobinopfun f ) .\nDefinition twobinopfunpair { X Y : setwith2binop } ( f : X -> Y ) ( is : istwobinopfun f ) : twobinopfun X Y := tpair _ f is . \nDefinition pr1twobinopfun ( X Y : setwith2binop ) : twobinopfun X Y -> ( X -> Y ) := @pr1 _ _ . \nCoercion pr1twobinopfun : twobinopfun >-> Funclass .\n\nDefinition binop1fun { X Y : setwith2binop } ( f : twobinopfun X Y ) : binopfun ( setwithbinop1 X ) ( setwithbinop1 Y ) := @binopfunpair ( setwithbinop1 X ) ( setwithbinop1 Y ) ( pr1 f ) ( pr1 ( pr2 f ) ) .\n\nDefinition binop2fun { X Y : setwith2binop } ( f : twobinopfun X Y ) : binopfun ( setwithbinop2 X ) ( setwithbinop2 Y ) := @binopfunpair ( setwithbinop2 X ) ( setwithbinop2 Y ) ( pr1 f ) ( pr2 ( pr2 f ) ) .  \nLemma isasettwobinopfun  ( X Y : setwith2binop ) : isaset ( twobinopfun X Y ) .\nProof . intros . apply ( isasetsubset ( pr1twobinopfun X Y  ) ) . change ( isofhlevel 2 ( X -> Y ) ) . apply impred .  intro . apply ( setproperty Y ) . apply isinclpr1 .  intro .  apply isapropistwobinopfun . Defined . \n \n\nLemma istwobinopfuncomp { X Y Z : setwith2binop } ( f : twobinopfun X Y ) ( g : twobinopfun Y Z ) : istwobinopfun ( funcomp ( pr1 f ) ( pr1 g ) ) .\nProof . intros . set ( ax1f := pr1 ( pr2 f ) ) . set ( ax2f := pr2 ( pr2 f ) ) . set ( ax1g := pr1 ( pr2 g ) ) . set ( ax2g := pr2 ( pr2 g ) ) .  split.\n\nintros a b . unfold funcomp .  rewrite ( ax1f a b ) . rewrite ( ax1g ( pr1 f a ) ( pr1 f b ) ) .  apply idpath .\nintros a b . unfold funcomp .  rewrite ( ax2f a b ) . rewrite ( ax2g ( pr1 f a ) ( pr1 f b ) ) .  apply idpath . Defined . \n \nOpaque istwobinopfuncomp . \n\nDefinition 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 ) . \n\n\nDefinition twobinopmono ( X Y : setwith2binop ) : UU := total2 ( fun f : incl X Y => istwobinopfun f ) .\nDefinition twobinopmonopair { X Y : setwith2binop } ( f : incl X Y ) ( is : istwobinopfun f ) : twobinopmono X Y := tpair _  f is .\nDefinition pr1twobinopmono ( X Y : setwith2binop ) : twobinopmono X Y -> incl X Y := @pr1 _ _ .\nCoercion pr1twobinopmono : twobinopmono >-> incl .\n\nDefinition twobinopincltotwobinopfun ( X Y : setwith2binop ) : twobinopmono X Y -> twobinopfun X Y := fun f => twobinopfunpair ( pr1 ( pr1 f ) ) ( pr2 f ) .\nCoercion twobinopincltotwobinopfun : twobinopmono >-> twobinopfun . \n\nDefinition binop1mono { X Y : setwith2binop } ( f : twobinopmono X Y ) : binopmono ( setwithbinop1 X ) ( setwithbinop1 Y ) := @binopmonopair ( setwithbinop1 X ) ( setwithbinop1 Y ) ( pr1 f ) ( pr1 ( pr2 f ) ) .\n\nDefinition binop2mono { X Y : setwith2binop } ( f : twobinopmono X Y ) : binopmono ( setwithbinop2 X ) ( setwithbinop2 Y ) := @binopmonopair ( setwithbinop2 X ) ( setwithbinop2 Y ) ( pr1 f ) ( pr2 ( pr2 f ) ) .  \n\nDefinition 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 ) . \n\nDefinition twobinopiso ( X Y : setwith2binop ) : UU := total2 ( fun f : weq X Y => istwobinopfun f ) .   \nDefinition twobinopisopair { X Y : setwith2binop } ( f : weq X Y ) ( is : istwobinopfun f ) : twobinopiso X Y := tpair _  f is .\nDefinition pr1twobinopiso ( X Y : setwith2binop ) : twobinopiso X Y -> weq X Y := @pr1 _ _ .\nCoercion pr1twobinopiso : twobinopiso >-> weq .\n\nDefinition twobinopisototwobinopmono ( X Y : setwith2binop ) : twobinopiso X Y -> twobinopmono X Y := fun f => twobinopmonopair ( pr1 f ) ( pr2 f ) .\nCoercion twobinopisototwobinopmono : twobinopiso >-> twobinopmono . \n\nDefinition binop1iso { X Y : setwith2binop } ( f : twobinopiso X Y ) : binopiso ( setwithbinop1 X ) ( setwithbinop1 Y ) := @binopisopair ( setwithbinop1 X ) ( setwithbinop1 Y ) ( pr1 f ) ( pr1 ( pr2 f ) ) .\n\nDefinition binop2iso { X Y : setwith2binop } ( f : twobinopiso X Y ) : binopiso ( setwithbinop2 X ) ( setwithbinop2 Y ) := @binopisopair ( setwithbinop2 X ) ( setwithbinop2 Y ) ( pr1 f ) ( pr2 ( pr2 f ) ) .  \nDefinition 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 ) .\n\nLemma istwobinopfuninvmap { X Y : setwith2binop } ( f : twobinopiso X Y ) : istwobinopfun ( invmap ( pr1 f ) ) . \nProof . intros . set ( ax1f := pr1 ( pr2 f ) ) . set ( ax2f := pr2 ( pr2 f ) ) . split .\n\n\nintros 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 .\nintros 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 .\n\nOpaque istwobinopfuninvmap .  \n\nDefinition invtwobinopiso { X Y : setwith2binop } ( f : twobinopiso X Y ) : twobinopiso Y X := twobinopisopair ( invweq ( pr1 f ) ) ( istwobinopfuninvmap f ) .\n\n\n\n\n\n(** **** Transport of properties of a pair binary operations *)\n\nLemma isldistrmonob { X Y : setwith2binop } ( f : twobinopmono X Y ) ( is : isldistr ( @op1 Y ) ( @op2 Y ) ) : isldistr ( @op1 X ) ( @op2 X ) .\nProof . 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)))\n     ( (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 . \n\nOpaque isldistrmonob .\n\n\nLemma isrdistrmonob { X Y : setwith2binop } ( f : twobinopmono X Y ) ( is : isrdistr ( @op1 Y ) ( @op2 Y ) ) : isrdistr ( @op1 X ) ( @op2 X ) .\nProof . 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))\n     ( (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 . \n\nOpaque isrdistrmonob .\n\nDefinition 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 ) ) .\n\nNotation isldistrisob := isldistrmonob .\nNotation isrdistrisob := isrdistrmonob .\nNotation isdistrisob := isdistrmonob .\n\nLemma isldistrisof  { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isldistr ( @op1 X ) ( @op2 X ) ) : isldistr ( @op1 Y ) ( @op2 Y ) .\nProof . intros . apply ( isldistrisob ( invtwobinopiso f ) is ) . Defined .   \n\nLemma isrdistrisof  { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isrdistr ( @op1 X ) ( @op2 X ) ) : isrdistr ( @op1 Y ) ( @op2 Y ) .\nProof . intros . apply ( isrdistrisob ( invtwobinopiso f ) is ) . Defined . \n\nLemma isdistrisof  { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isdistr ( @op1 X ) ( @op2 X ) ) : isdistr ( @op1 Y ) ( @op2 Y ) .\nProof . intros . apply ( isdistrisob ( invtwobinopiso f ) is ) . Defined . \n\n\nDefinition isrigopsisof { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isrigops ( @op1 X ) ( @op2 X ) ) : isrigops ( @op1 Y ) ( @op2 Y ) .\nProof . 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 . \n\nDefinition isrigopsisob { X Y : setwith2binop } ( f : twobinopiso X Y ) ( is : isrigops ( @op1 Y ) ( @op2 Y ) ) : isrigops ( @op1 X ) ( @op2 X ) .\nProof. intros . apply ( isrigopsisof ( invtwobinopiso f ) is ) . Defined . \n\n\nDefinition 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 ) ) .\n\nDefinition 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 ) ) .\n\n\nDefinition 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 ) ) .\n\nDefinition 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 ) ) .\n\n\n\n\n(** **** Subobjects *)\n\nDefinition 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' ) ) ) .\n\nLemma isapropissubsetwith2binop { X : setwith2binop } ( A : hsubtypes X ) : isaprop ( issubsetwith2binop A ) .\nProof . intros . apply ( isofhleveldirprod 1 ) .\n 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 .\n\nDefinition subsetswith2binop { X : setwith2binop } := total2 ( fun A : hsubtypes X => issubsetwith2binop A ) .\nDefinition subsetswith2binoppair { X : setwith2binop } := tpair ( fun A : hsubtypes X => issubsetwith2binop A ) . \nDefinition subsetswith2binopconstr { X : setwith2binop } := @subsetswith2binoppair X .  \nDefinition pr1subsetswith2binop ( X : setwith2binop ) : @subsetswith2binop X -> hsubtypes X := @pr1 _ ( fun A : hsubtypes X => issubsetwith2binop A ) . \nCoercion pr1subsetswith2binop : subsetswith2binop >-> hsubtypes .\n\nDefinition totalsubsetwith2binop ( X : setwith2binop ) : @subsetswith2binop X .\nProof . intros .  split with ( fun x : X => htrue ) . split . intros x x' .  apply tt .  intros . apply tt . Defined .  \n\n\nDefinition carrierofsubsetwith2binop { X : setwith2binop } ( A : @subsetswith2binop X ) : setwith2binop .\nProof . intros . set ( aset := ( hSetpair ( carrier A ) ( isasetsubset ( pr1carrier A ) ( setproperty X ) ( isinclpr1carrier A ) ) ) : hSet ) . split with aset . \nset ( subopp1 := ( fun a a' : A => carrierpair A ( op1 ( pr1carrier _ a ) ( pr1carrier _ a' ) ) ( pr1 ( pr2 A ) a a' ) ) : ( A -> A -> A ) ) . \nset ( subopp2 := ( fun a a' : A => carrierpair A ( op2 ( pr1carrier _ a ) ( pr1carrier _ a' ) ) ( pr2 ( pr2 A ) a a' ) ) : ( A -> A -> A ) ) .\nsimpl .  apply ( dirprodpair subopp1 subopp2 ) .  Defined . \n\nCoercion carrierofsubsetwith2binop : subsetswith2binop >-> setwith2binop . \n\n\n(** **** Quotient objects *)\n\nDefinition is2binophrel { X : setwith2binop } ( R : hrel X ) := dirprod ( @isbinophrel ( setwithbinop1 X ) R ) ( @isbinophrel ( setwithbinop2 X ) R ) . \n\nLemma isapropis2binophrel { X : setwith2binop } ( R : hrel X ) : isaprop ( is2binophrel R ) . \nProof . intros . apply ( isofhleveldirprod 1 ) .  apply isapropisbinophrel . apply isapropisbinophrel .  \nDefined .    \n\nLemma iscomp2binoptransrel { X : setwith2binop } ( R : hrel X ) ( is : istrans R ) ( isb : is2binophrel R ) : dirprod ( iscomprelrelfun2 R R ( @op1 X ) ) ( iscomprelrelfun2 R R ( @op2 X ) ) .\nProof . intros . split . apply ( @iscompbinoptransrel ( setwithbinop1 X ) R is ( pr1 isb ) ) . apply ( @iscompbinoptransrel ( setwithbinop2 X ) R is ( pr2 isb ) ) .  Defined .\n\n\nDefinition twobinophrel { X : setwith2binop } := total2 ( fun R : hrel X => is2binophrel R ) .\nDefinition twobinophrelpair { X : setwith2binop } := tpair ( fun R : hrel X => is2binophrel R ) .\nDefinition pr1twobinophrel ( X : setwith2binop ) : @twobinophrel X -> hrel X := @pr1 _ ( fun R : hrel X => is2binophrel R ) .\nCoercion pr1twobinophrel : twobinophrel >-> hrel . \n\nDefinition twobinoppo { X : setwith2binop } := total2 ( fun R : po X => is2binophrel R ) .\nDefinition twobinoppopair { X : setwith2binop } := tpair ( fun R : po X => is2binophrel R ) .\nDefinition pr1twobinoppo ( X : setwith2binop ) : @twobinoppo X -> po X := @pr1 _ ( fun R : po X => is2binophrel R ) .\nCoercion pr1twobinoppo : twobinoppo >-> po . \n\nDefinition twobinopeqrel { X : setwith2binop } := total2 ( fun R : eqrel X => is2binophrel R ) .\nDefinition twobinopeqrelpair { X : setwith2binop } := tpair ( fun R : eqrel X => is2binophrel R ) .\nDefinition pr1twobinopeqrel ( X : setwith2binop ) : @twobinopeqrel X -> eqrel X := @pr1 _ ( fun R : eqrel X => is2binophrel R ) .\nCoercion pr1twobinopeqrel : twobinopeqrel >-> eqrel . \n\nDefinition setwith2binopquot { X : setwith2binop } ( R : @twobinopeqrel X ) : setwith2binop .\nProof . intros . split with ( setquotinset R )  .  set ( qt  := setquot R ) . set ( qtset := setquotinset R ) .  \nassert ( iscomp1 : iscomprelrelfun2 R R ( @op1 X ) ) . apply ( pr1 ( iscomp2binoptransrel ( pr1 R ) ( eqreltrans _ ) ( pr2 R ) ) ) .  set ( qtop1 := setquotfun2 R R ( @op1 X ) iscomp1 ) .   \nassert ( iscomp2 : iscomprelrelfun2 R R ( @op2 X ) ) . apply ( pr2 ( iscomp2binoptransrel ( pr1 R ) ( eqreltrans _ ) ( pr2 R ) ) ) .  set ( qtop2 := setquotfun2 R R ( @op2 X ) iscomp2 ) .  \nsimpl . apply ( dirprodpair qtop1 qtop2 )  . Defined . \n\n\n(** **** Direct products *)\n\nDefinition setwith2binopdirprod ( X Y : setwith2binop ) : setwith2binop .\nProof . intros . split with ( setdirprod X Y ) . simpl .\n\n(* ??? same issue as with setwithbinopdirpro above *)\n\napply ( 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 .  \n\n\n\n\n\n\n\n(* End of the file algebra1a.v *)\n"
  },
  {
    "path": "hlevel2/algebra1b.v",
    "content": "(** * Algebra I. Part B.  Monoids, abelian monoids groups, abelian groups. Vladimir Voevodsky. Aug. 2011 - . \n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)\n\n\n(** Imports *)\n\nAdd LoadPath \"../../\" .\n\nRequire Export Foundations.hlevel2.algebra1a .\n\n\n(** To upstream files *)\n\n\n(** ** Standard Algebraic Structures *)\n\n\n(** *** Monoids *)\n\n\n(** ****  Basic definitions *)\n\n\n\nDefinition monoid := total2 ( fun X : setwithbinop => ismonoidop ( @op X ) ) .\nDefinition monoidpair := tpair ( fun X : setwithbinop => ismonoidop ( @op X ) ) .\nDefinition monoidconstr := monoidpair .\nDefinition pr1monoid : monoid -> setwithbinop := @pr1 _ _ . \nCoercion pr1monoid : monoid >-> setwithbinop .\n\nDefinition assocax ( X : monoid ) : isassoc ( @op X ) := pr1 ( pr2 X ) .\nDefinition unel ( X : monoid) : X := pr1 ( pr2 ( pr2 X ) ) .\nDefinition lunax ( X : monoid ) : islunit ( @op X ) ( unel X ) := pr1 ( pr2 ( pr2 ( pr2 X ) ) ) .  \nDefinition runax ( X : monoid ) : isrunit ( @op X ) ( unel X ) := pr2 ( pr2 ( pr2 ( pr2 X ) ) ) . \n\nNotation \"x + y\" := ( op x y ) : addmonoid_scope . \nNotation \"0\" := ( unel _ ) : addmonoid_scope .   \n\nDelimit Scope addmonoid_scope with addmonoid. \n\nNotation \"x * y\" := ( op x y ) : multmonoid_scope . \nNotation \"1\" := ( unel _ ) : multmonoid_scope .   \n\nDelimit Scope multmonoid_scope with multmonoid. \n\n\n\n(** **** Functions betweens monoids compatible with structure ( homomorphisms ) and their properties *)\n\n\nDefinition ismonoidfun { X Y : monoid } ( f : X -> Y ) := dirprod ( isbinopfun f ) ( paths ( f ( unel X ) ) ( unel Y ) ) . \n\nLemma isapropismonoidfun { X Y : monoid } ( f : X -> Y ) : isaprop ( ismonoidfun f ) .\nProof . intros . apply isofhleveldirprod . apply isapropisbinopfun .  apply ( setproperty Y ) . Defined .\n\nDefinition monoidfun ( X Y : monoid ) : UU := total2 ( fun f : X -> Y => ismonoidfun f ) .\nDefinition monoidfunconstr { X Y : monoid } { f : X -> Y } ( is : ismonoidfun f ) : monoidfun X Y := tpair _ f is . \nDefinition pr1monoidfun ( X Y : monoid ) : monoidfun X Y -> ( X -> Y ) := @pr1 _ _ . \n\nDefinition monoidfuntobinopfun ( X Y : monoid ) : monoidfun X Y -> binopfun X Y := fun f => binopfunpair ( pr1 f ) ( pr1 ( pr2 f ) ) .\nCoercion monoidfuntobinopfun : monoidfun >-> binopfun .  \n\n\nLemma isasetmonoidfun  ( X Y : monoid ) : isaset ( monoidfun X Y ) .\nProof . intros . apply ( isasetsubset ( pr1monoidfun X Y  ) ) . change ( isofhlevel 2 ( X -> Y ) ) . apply impred .  intro . apply ( setproperty Y ) . apply isinclpr1 .  intro .  apply isapropismonoidfun . Defined .  \n\n\nLemma ismonoidfuncomp { X Y Z : monoid } ( f : monoidfun X Y ) ( g : monoidfun Y Z ) : ismonoidfun ( funcomp ( pr1 f ) ( pr1 g ) ) .\nProof . intros . split with ( isbinopfuncomp f g ) . unfold funcomp .  rewrite ( pr2 ( pr2 f ) ) .  apply ( pr2 ( pr2 g ) ) . Defined .  \n\nOpaque ismonoidfuncomp . \n\nDefinition monoidfuncomp { X Y Z : monoid } ( f : monoidfun X Y ) ( g : monoidfun Y Z ) : monoidfun X Z := monoidfunconstr ( ismonoidfuncomp f g ) . \n\n\nDefinition monoidmono ( X Y : monoid ) : UU := total2 ( fun f : incl X Y => ismonoidfun f ) .\nDefinition monoidmonopair { X Y : monoid } ( f : incl X Y ) ( is : ismonoidfun f ) : monoidmono X Y := tpair _  f is .\nDefinition pr1monoidmono ( X Y : monoid ) : monoidmono X Y -> incl X Y := @pr1 _ _ .\nCoercion pr1monoidmono : monoidmono >-> incl .\n\nDefinition monoidincltomonoidfun ( X Y : monoid ) : monoidmono X Y -> monoidfun X Y := fun f => monoidfunconstr ( pr2 f ) .\nCoercion monoidincltomonoidfun : monoidmono >-> monoidfun . \n\nDefinition monoidmonotobinopmono ( X Y : monoid ) : monoidmono X Y -> binopmono X Y := fun f => binopmonopair ( pr1 f ) ( pr1 ( pr2 f ) ) .\nCoercion monoidmonotobinopmono : monoidmono >-> binopmono .  \n\nDefinition 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 ) . \n\n\nDefinition monoidiso ( X Y : monoid ) : UU := total2 ( fun f : weq X Y => ismonoidfun f ) .   \nDefinition monoidisopair { X Y : monoid } ( f : weq X Y ) ( is : ismonoidfun f ) : monoidiso X Y := tpair _  f is .\nDefinition pr1monoidiso ( X Y : monoid ) : monoidiso X Y -> weq X Y := @pr1 _ _ .\nCoercion pr1monoidiso : monoidiso >-> weq .\n\nDefinition monoidisotomonoidmono ( X Y : monoid ) : monoidiso X Y -> monoidmono X Y := fun f => monoidmonopair ( pr1 f ) ( pr2 f ) .\nCoercion monoidisotomonoidmono : monoidiso >-> monoidmono . \n\nDefinition monoidisotobinopiso ( X Y : monoid ) : monoidiso X Y -> binopiso X Y := fun f => binopisopair ( pr1 f ) ( pr1 ( pr2 f ) ) .\nCoercion monoidisotobinopiso : monoidiso >-> binopiso .  \n\n\nLemma ismonoidfuninvmap { X Y : monoid } ( f : monoidiso X Y ) : ismonoidfun ( invmap ( pr1 f ) ) . \nProof . intros . split with ( isbinopfuninvmap f ) .  apply ( invmaponpathsweq ( pr1 f ) ) .  rewrite ( homotweqinvweq ( pr1 f ) ) . apply ( pathsinv0 ( pr2 ( pr2 f ) ) ) . Defined .\n\nOpaque ismonoidfuninvmap .  \n\nDefinition invmonoidiso { X Y : monoid } ( f : monoidiso X Y ) : monoidiso Y X := monoidisopair ( invweq ( pr1 f ) ) ( ismonoidfuninvmap f ) .\n\n\n\n\n(** **** Subobjects *)\n\nDefinition issubmonoid { X : monoid } ( A : hsubtypes X ) := dirprod ( issubsetwithbinop ( @op X ) A ) ( A ( unel X ) ) . \n\nLemma isapropissubmonoid { X : monoid } ( A : hsubtypes X ) : isaprop ( issubmonoid A ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply isapropissubsetwithbinop . apply ( pr2 ( A ( unel X ) ) ) . Defined .  \n\nDefinition submonoids { X : monoid } := total2 ( fun A : hsubtypes X => issubmonoid A )  . \nDefinition submonoidpair { X : monoid } := tpair ( fun A : hsubtypes X => issubmonoid A ) . \nDefinition submonoidconstr { X : monoid } := @submonoidpair X . \nDefinition pr1submonoids ( X : monoid ) : @submonoids X -> hsubtypes X := @pr1 _ _ . \n\nDefinition totalsubmonoid  ( X : monoid ) : @submonoids X .\nProof . intro . split with ( fun x : _ => htrue ) . split . intros x x' . apply tt . apply tt . Defined .   \n\nDefinition submonoidstosubsetswithbinop ( X : monoid ) : @submonoids X -> @subsetswithbinop X := fun A : _ => subsetswithbinoppair ( pr1 A ) ( pr1 ( pr2 A ) ) . \nCoercion  submonoidstosubsetswithbinop : submonoids >-> subsetswithbinop .\n\nLemma ismonoidcarrier { X : monoid } ( A : @submonoids X ) : ismonoidop ( @op A ) . \nProof . 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 . \n\nDefinition carrierofsubmonoid { X : monoid } ( A : @submonoids X ) : monoid .\nProof . intros . split with A . apply ismonoidcarrier . Defined . \n\nCoercion carrierofsubmonoid : submonoids >-> monoid . \n\n\n\n\n(** **** Quotient objects *)\n\nLemma isassocquot { X : monoid } ( R : @binopeqrel X ) : isassoc ( @op ( setwithbinopquot R ) ) . \nProof . 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 . \n\nOpaque isassocquot .\n    \n\nLemma isunitquot { X : monoid } ( R : @binopeqrel X ) : isunit ( @op ( setwithbinopquot R ) ) ( setquotpr R ( pr1 ( pr2 ( pr2 X ) ) ) ) .\nProof . intros .  set ( qun := setquotpr R ( pr1 ( pr2 ( pr2 X ) ) ) ) . set ( qsetwithop := setwithbinopquot R ) .  split .  \n\nintro x . apply ( setquotunivprop R ( fun x => @eqset qsetwithop ( ( @op qsetwithop ) qun x ) x ) ) .  simpl . intro x0 .   apply ( maponpaths ( setquotpr R ) ( lunax X x0 ) ) . \n\nintro x . apply ( setquotunivprop R ( fun x => @eqset qsetwithop ( ( @op qsetwithop ) x qun ) x ) ) .  simpl . intro x0 . apply ( maponpaths ( setquotpr R ) ( runax X x0 ) ) . Defined .\n\nOpaque isunitquot . \n\n\nDefinition ismonoidquot { X : monoid } ( R : @binopeqrel X ) : ismonoidop ( @op ( setwithbinopquot R ) ) := tpair _ ( isassocquot R ) ( tpair _ ( setquotpr R ( pr1 ( pr2 ( pr2 X ) ) ) ) ( isunitquot R ) ) .  \n\nDefinition monoidquot { X : monoid } ( R : @binopeqrel X ) : monoid .\nProof . intros . split with ( setwithbinopquot R ) . apply ismonoidquot . Defined . \n\n\n(** **** Direct products *)\n\nLemma isassocdirprod ( X Y : monoid ) : isassoc ( @op ( setwithbinopdirprod X Y ) ) .\nProof . intros .  simpl . intros xy xy' xy'' .  simpl . apply pathsdirprod .  apply ( assocax X ) .  apply ( assocax Y ) .  Defined . \n\nOpaque isassocdirprod .\n\nLemma isunitindirprod ( X Y : monoid ) : isunit ( @op ( setwithbinopdirprod X Y ) ) ( dirprodpair ( unel X ) ( unel Y ) ) .\nProof . split . \n\nintro xy . destruct xy as [ x y ] . simpl . apply pathsdirprod .  apply ( lunax X ) .  apply ( lunax Y ) . \nintro xy .  destruct xy as [ x y ] . simpl . apply pathsdirprod .  apply ( runax X ) .  apply ( runax Y ) . Defined . \n\nOpaque isunitindirprod . \n\nDefinition ismonoiddirprod ( X Y : monoid ) : ismonoidop ( @op ( setwithbinopdirprod X Y ) ) := tpair _ ( isassocdirprod X Y ) ( tpair _ ( dirprodpair ( unel X ) ( unel Y ) ) ( isunitindirprod X Y ) ) .  \n\nDefinition monoiddirprod ( X Y : monoid ) : monoid .\nProof . intros . split with ( setwithbinopdirprod X Y ) . apply ismonoiddirprod . Defined .  \n\n\n\n\n\n\n(** *** Abelian ( commutative ) monoids *)\n\n\n(** **** Basic definitions *)\n\n\nDefinition abmonoid := total2 ( fun X : setwithbinop =>  isabmonoidop ( @op X ) ) .\nDefinition abmonoidpair := tpair ( fun X : setwithbinop =>  isabmonoidop ( @op X ) ) .\nDefinition abmonoidconstr := abmonoidpair .\n\nDefinition abmonoidtomonoid : abmonoid -> monoid := fun X : _ => monoidpair ( pr1 X ) ( pr1 ( pr2 X ) ) .\nCoercion abmonoidtomonoid : abmonoid >-> monoid .\n\nDefinition commax ( X : abmonoid ) : iscomm ( @op X ) := pr2 ( pr2 X ) .\n\nDefinition 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 .  \n\n\n(** **** Subobjects *)\n\nDefinition subabmonoids { X : abmonoid } := @submonoids X .\nIdentity Coercion id_subabmonoids : subabmonoids >-> submonoids . \n\nLemma iscommcarrier { X : abmonoid } ( A : @submonoids X ) : iscomm ( @op A ) . \nProof . intros .   intros a a' .  apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) .  simpl . apply ( pr2 ( pr2 X ) ) . Defined .\n\nOpaque iscommcarrier . \n\nDefinition  isabmonoidcarrier  { X : abmonoid } ( A : @submonoids X ) : isabmonoidop ( @op A ) := dirprodpair ( ismonoidcarrier A ) ( iscommcarrier A ) . \n\nDefinition carrierofsubabmonoid { X : abmonoid } ( A : @subabmonoids X ) : abmonoid .\nProof . intros . unfold subabmonoids in A . split with A . apply isabmonoidcarrier . Defined . \n\nCoercion carrierofsubabmonoid : subabmonoids >-> abmonoid . \n\n\n\n\n(** **** Quotient objects *)\n\nLemma iscommquot { X : abmonoid } ( R : @binopeqrel X ) : iscomm ( @op ( setwithbinopquot R ) ) .\nProof . 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 .\n\nOpaque iscommquot . \n\nDefinition isabmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : isabmonoidop ( @op ( setwithbinopquot R ) ) := dirprodpair ( ismonoidquot R ) ( iscommquot R ) . \n\nDefinition abmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : abmonoid .\nProof . intros . split with  ( setwithbinopquot R )  . apply isabmonoidquot . Defined .  \n\n\n(** **** Direct products *)\n\nLemma iscommdirprod ( X Y : abmonoid ) : iscomm ( @op ( setwithbinopdirprod X Y ) ) .\nProof . intros . intros xy xy' . destruct xy as [ x y ] . destruct xy' as [ x' y' ] .  simpl .  apply pathsdirprod .  apply ( commax X ) .  apply ( commax Y ) .  Defined .\n\nOpaque iscommdirprod . \n\nDefinition isabmonoiddirprod ( X Y : abmonoid ) : isabmonoidop ( @op ( setwithbinopdirprod X Y ) ) := dirprodpair ( ismonoiddirprod X Y ) ( iscommdirprod X Y ) .\n\nDefinition abmonoiddirprod ( X Y : abmonoid ) : abmonoid .\nProof . intros . split with ( setwithbinopdirprod X Y ) . apply isabmonoiddirprod .  Defined . \n\n\n\n\n(** **** Monoid of fractions of an abelian monoid \n\nNote : the following construction uses onbly associativity and commutativity of the [ abmonoid ] operations but does not use the unit element . *)\n\nOpen Scope addmonoid_scope .\n\nDefinition abmonoidfracopint ( X : abmonoid ) ( A : @submonoids X ) : binop ( dirprod X A ) := @op ( setwithbinopdirprod X A ) .\n\nDefinition  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 ) ) ) ) . \n\nLemma iseqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : iseqrel ( hrelabmonoidfrac X A ) .\nProof . intros . set ( assoc := assocax X ) . set ( comm := commax X ) . set ( R := hrelabmonoidfrac X A ) .\n\nassert ( 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 ) . \n\nassert ( 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 . \n\nassert ( refl : isrefl R ) . intro xa .  simpl .  apply hinhpr . split with ( pr2 xa ) . apply idpath .  \n\napply ( iseqrelconstr trans refl symm ) . Defined .\n\nOpaque iseqrelabmonoidfrac .  \n\nDefinition eqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : eqrel ( setwithbinopdirprod X A ) := eqrelpair ( hrelabmonoidfrac X A ) ( iseqrelabmonoidfrac X A ) .\n\nLemma isbinophrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : @isbinophrel ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) . \nProof . 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 .\n\nOpaque isbinophrelabmonoidfrac .\n \nDefinition 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 ) ) ) . \n\nDefinition binopeqrelabmonoidfrac ( X : abmonoid ) ( A : @subabmonoids X ) : @binopeqrel ( abmonoiddirprod X A ) := @binopeqrelpair ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) ( isbinophrelabmonoidfrac X A ) .   \n\nDefinition abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : abmonoid := abmonoidquot ( binopeqrelabmonoidfrac X A ) . \n\nDefinition prabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : X -> A -> abmonoidfrac X A := fun ( x : X ) ( a : A ) => setquotpr ( eqrelabmonoidfrac X A ) ( dirprodpair x a ) . \n\n(* ??? could the use of [ issubabmonoid ] in [ binopeqrelabmonoidfrac ] and [ submonoid ] in [ abmonoidfrac ] lead to complications for the unification machinery? See also [ abmonoidfracisbinoprelint ] below . *)\n\nLemma invertibilityinabmonoidfrac  ( X : abmonoid ) ( A : @submonoids X ) : forall a a' : A , isinvertible ( @op ( abmonoidfrac X A ) ) ( prabmonoidfrac X A ( pr1 a ) a' ) .  \nProof . intros . set ( R := eqrelabmonoidfrac X A ) .   unfold isinvertible .  \n\nassert ( 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 ) .\nassert ( 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 . \nassert ( 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 .\napply ( gradth _ _ egf efg ) . \n\napply ( dirprodpair isl ( weqlinvertiblerinvertible ( @op ( abmonoidfrac X A ) ) ( commax ( abmonoidfrac X A ) ) ( prabmonoidfrac X A ( pr1 a ) a' ) isl ) ) . \nDefined .  \n\n\n(** **** Canonical homomorphism to the monoid of fractions *)\n\nDefinition toabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) ( x : X ) : abmonoidfrac X A := setquotpr _ ( dirprodpair x ( unel A ) ) . \n\nLemma isbinopfuntoabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : isbinopfun ( toabmonoidfrac X A ) .\nProof . 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 . \n\nLemma isunitalfuntoabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : paths ( toabmonoidfrac X A ( unel X ) ) ( unel ( abmonoidfrac X A ) ) .\nProof . intros . apply idpath . Defined .  \n\nDefinition ismonoidfuntoabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : ismonoidfun ( toabmonoidfrac X A ) := dirprodpair ( isbinopfuntoabmonoidfrac X A ) ( isunitalfuntoabmonoidfrac X A ) .\n\n\n(** **** Abelian monoid of fractions in the case when elements of the localziation submonoid are cancelable *)\n\nDefinition  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 ) ) ) .\n\nLemma 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' ) .\nProof . intros .  unfold eqrelabmonoidfrac .  unfold hrelabmonoidfrac . simpl .  apply weqimplimpl .  \n\napply ( @hinhuniv _ ( eqset (pr1 xa + pr1 (pr2 xa')) (pr1 xa' + pr1 (pr2 xa)) ) ) .  intro ae .  destruct ae as [ a eq ] .  apply ( invmaponpathsincl _ ( iscanc a ) _ _ eq ) . \nintro eq . apply hinhpr . split with ( unel A ) . rewrite ( runax X )  .  rewrite ( runax X ) .  apply eq . apply ( isapropishinh _ ) .  apply ( setproperty X ) .   Defined .\n\n\nLemma 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' ) .\nProof . 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 .\n\nDefinition 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 ) .   \n\n\nLemma isdeceqabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) ( iscanc : forall a : A , isrcancelable ( @op X ) ( pr1carrier _ a ) ) ( is : isdeceq X ) : isdeceq ( abmonoidfrac X A ) .\nProof . 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 . \n\n\n\n(** **** Relations on the abelian monoid of fractions *) \n\nDefinition 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 ) ) ) .    \n\nLemma iscomprelabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) : iscomprelrel ( eqrelabmonoidfrac X A ) ( abmonoidfracrelint X A L ) . \nProof . 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 ) ) . \n\nintros 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 )  . \n\nintros 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 . \n\nOpaque iscomprelabmonoidfracrelint . \n\nDefinition abmonoidfracrel ( X : abmonoid ) ( A : @submonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) := quotrel ( iscomprelabmonoidfracrelint X A is ) . \n\nLemma istransabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : istrans L ) : istrans ( abmonoidfracrelint X A L ) .\nProof . 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 ) ) ) ) . \n\nassert ( 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 ) . \n\nassert ( 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 ) .  \n\nassert ( 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 . \n\ndestruct e . apply ( isl _ _ _ ll1 ll2 ) . Defined . \n\nOpaque istransabmonoidfracrelint . \n\nLemma istransabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : istrans L ) : istrans ( abmonoidfracrel X A is ) .\nProof . intros .  apply istransquotrel . apply istransabmonoidfracrelint .  apply is . apply isl . Defined . \n\nLemma issymmabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : issymm L ) : issymm ( abmonoidfracrelint X A L ) .\nProof . 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 . \n\nOpaque issymmabmonoidfracrelint .\n\nLemma issymmabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : issymm L ) : issymm ( abmonoidfracrel X A is ) .\nProof . intros .  apply issymmquotrel . apply issymmabmonoidfracrelint .  apply is . apply isl . Defined . \n\nLemma isreflabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isrefl L ) : isrefl ( abmonoidfracrelint X A L ) .\nProof . intros . intro xa . unfold abmonoidfracrelint .  simpl . apply hinhpr . split with ( unel A ) .  apply ( isl _ ) . Defined .\n\nLemma isreflabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isrefl L ) : isrefl ( abmonoidfracrel X A is ) .\nProof . intros .  apply isreflquotrel . apply isreflabmonoidfracrelint .  apply is . apply isl . Defined . \n\nLemma ispoabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : ispo L ) : ispo ( abmonoidfracrelint X A L ) .\nProof . intros . split with ( istransabmonoidfracrelint X A is ( pr1 isl ) ) .  apply ( isreflabmonoidfracrelint X A is ( pr2 isl ) ) .  Defined . \n\nLemma ispoabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : ispo L ) : ispo ( abmonoidfracrel X A is ) .\nProof . intros .  apply ispoquotrel . apply ispoabmonoidfracrelint .  apply is . apply isl . Defined . \n\nLemma iseqrelabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iseqrel L ) : iseqrel ( abmonoidfracrelint X A L ) .\nProof . intros . split with ( ispoabmonoidfracrelint X A is ( pr1 isl ) ) .  apply ( issymmabmonoidfracrelint X A is ( pr2 isl ) ) .  Defined . \n\nLemma iseqrelabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iseqrel L ) : iseqrel ( abmonoidfracrel X A is ) .\nProof . intros .  apply iseqrelquotrel . apply iseqrelabmonoidfracrelint .  apply is . apply isl . Defined .\n\nLemma isirreflabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isirrefl L ) : isirrefl ( abmonoidfracrelint X A L ) .\nProof . intros . unfold isirrefl.  intro xa .  unfold abmonoidfracrelint . simpl .  unfold neg . apply ( @hinhuniv _ ( hProppair _ isapropempty ) ) .  intro t2 . apply ( isl _ ( pr2 t2 ) ) .  Defined . \n\nLemma isirreflabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isirrefl L ) : isirrefl ( abmonoidfracrel X A is ) .\nProof . intros . apply isirreflquotrel . apply isirreflabmonoidfracrelint .  apply is . apply isl .  Defined . \n\nLemma isasymmabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isasymm L ) : isasymm ( abmonoidfracrelint X A L ) .\nProof . 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 ) ) . \n\nassert ( 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 .  \n\nassert ( 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 .\n\napply ( isl _ _ ll1 ll2 ) . Defined .\n\nOpaque  isasymmabmonoidfracrelint .\n\n\nLemma isasymmabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isasymm L ) : isasymm ( abmonoidfracrel X A is ) .\nProof . intros . apply isasymmquotrel . apply isasymmabmonoidfracrelint . apply is . apply isl .    Defined .\n\n\nLemma iscoasymmabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iscoasymm L ) : iscoasymm ( abmonoidfracrelint X A L ) .\nProof . 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 . \n\nOpaque  isasymmabmonoidfracrelint .\n\nLemma iscoasymmabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iscoasymm L ) : iscoasymm ( abmonoidfracrel X A is ) .\nProof . intros . apply iscoasymmquotrel . apply iscoasymmabmonoidfracrelint . apply is . apply isl .   Defined .\n\n\nLemma istotalabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : istotal L ) : istotal ( abmonoidfracrelint X A L ) .\nProof . 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 .  \n\nLemma istotalabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : istotal L ) : istotal ( abmonoidfracrel X A is ) .\nProof . intros .  apply istotalquotrel . apply istotalabmonoidfracrelint .  apply is . apply isl . Defined .\n\n\nLemma iscotransabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iscotrans L ) : iscotrans ( abmonoidfracrelint X A L ) .\nProof . 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 ) ) .     \n\nassert ( 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 ] .\n\napply ii1 .  apply hinhpr .  split with ( ( pr2 xa3 ) + c0a ) . change ( L ( x1 + a2 + ( a3 + c0 ) ) ( x2 + a1 + ( a3 + c0 ) ) ) . rewrite ( rer _ a2 a3 _ ) . apply l12 . \n\napply 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 .    \n\nOpaque iscotransabmonoidfracrelint . \n\nLemma iscotransabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : iscotrans L ) : iscotrans ( abmonoidfracrel X A is ) .\nProof . intros .  apply iscotransquotrel . apply iscotransabmonoidfracrelint .  apply is . apply isl . Defined .\n\n\n\n\nLemma isantisymmnegabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isantisymmneg L ) : isantisymmneg ( abmonoidfracrel X A is ) .\nProof . 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 .  \n\nOpaque  isantisymmnegabmonoidfracrel .\n\n\nLemma isantisymmabmonoidfracrel ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) ( isl : isantisymm L ) : isantisymm ( abmonoidfracrel X A is ) .\nProof . 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 ) ) ) .  \n\nassert ( 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 .  \n\nassert ( 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 .\n\napply ( isl _ _ ll1 ll2 ) . Defined .\n\nOpaque  isantisymmabmonoidfracrel .\n\n\n\n\n \nLemma 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 ) . \nProof . 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 . \n\nOpaque ispartbinopabmonoidfracrelint . \n\n(* ??? Coq 8.4-8.5 trunk hangs here on the following line: \n\nAxiom 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' ) .\n\n*)\n\nLemma 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' ) .\nProof . 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 .   \n\nchange ( 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 . \n\nOpaque ispartlbinopabmonoidfracrel . \n\n\nLemma 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' ) ) .\nProof . 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 .  \n\nchange ( 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 . \n\nOpaque ispartrbinopabmonoidfracrel .\n\n\nLemma 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'  .\nProof . intros .  generalize ql .  apply quotrelimpl .  intros x0 x0' .  unfold abmonoidfracrelint .  simpl .  apply hinhfun .  intro t2 . split with ( pr1 t2 ) .   apply ( impl _ _ ( pr2 t2 ) ) . Defined . \n\n\nOpaque abmonoidfracrelimpl . \n\n\nLemma 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' ) .\nProof . intros .   apply quotrellogeq .  intros x0 x0' .  split . \n\nunfold abmonoidfracrelint .  simpl .  apply hinhfun .  intro t2 . split with ( pr1 t2 ) .   apply ( pr1 ( lg _ _ ) ( pr2 t2 ) ) .\nunfold abmonoidfracrelint .  simpl .  apply hinhfun .  intro t2 . split with ( pr1 t2 ) .   apply ( pr2 ( lg _ _ ) ( pr2 t2 ) ) . Defined . \n\nOpaque abmonoidfracrellogeq . \n\n\n\nDefinition isdecabmonoidfracrelint ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( is : ispartinvbinophrel A L ) ( isl : isdecrel L ) : isdecrel ( abmonoidfracrelint X A L ) . \nProof . 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 . \n\nDefinition 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 ) .  \nProof . intros . apply isdecquotrel . apply isdecabmonoidfracrelint .   apply isi . apply isl . Defined . \n\n\n\n(** **** Relations and the canonical homomorphism to [ abmonoidfrac ] *)\n\nLemma iscomptoabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) { L : hrel X } ( is : ispartbinophrel A L ) : iscomprelrelfun L ( abmonoidfracrel X A is ) ( toabmonoidfrac X A ) .\nProof . 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 .\n\nOpaque iscomptoabmonoidfrac .   \n\n\n\nClose Scope addmonoid_scope . \n\n\n\n(** *** Groups *)\n\n(** **** Basic definitions *)\n\nDefinition gr := total2 ( fun X : setwithbinop =>  isgrop ( @op X ) ) .\nDefinition grpair := tpair ( fun X : setwithbinop => isgrop ( @op X ) ) .\nDefinition grconstr := grpair .\nDefinition grtomonoid : gr -> monoid := fun X : _ => monoidpair ( pr1 X ) ( pr1 ( pr2 X ) ) . \nCoercion grtomonoid : gr >-> monoid .\n\nDefinition grinv ( X : gr ) : X -> X := pr1 ( pr2 ( pr2 X ) ) .\nDefinition grlinvax ( X : gr ) : islinv ( @op X ) ( unel X ) ( grinv X ) := pr1 ( pr2 ( pr2 ( pr2 X ) ) ) .\nDefinition grrinvax ( X : gr ) : isrinv ( @op X ) ( unel X ) ( grinv X ) := pr2 ( pr2 ( pr2 ( pr2 X ) ) ) .\n\nLemma monoidfuninvtoinv { X Y : gr } ( f : monoidfun X Y ) ( x : X ) : paths ( f ( grinv X x ) ) ( grinv Y ( f x ) ) .\nProof . intros . apply ( invmaponpathsweq ( weqpair _ ( isweqrmultingr_is ( pr2 Y ) ( f x ) ) ) ) . simpl . change ( paths (op (pr1 f (grinv X x)) (pr1 f x))\n     (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 .  \n\n\n(** **** Computation lemmas for groups *)\n\nDefinition weqlmultingr ( X : gr ) ( x0 : X ) := weqpair _ ( isweqlmultingr_is ( pr2 X ) x0 ) .\n\nDefinition weqrmultingr ( X : gr ) ( x0 : X ) := weqpair _ ( isweqrmultingr_is ( pr2 X ) x0 ) .\n\nLemma grlcan ( X : gr ) { a b : X } ( c : X ) ( e : paths ( op c a ) ( op c b ) ) : paths a b .\nProof . intros . apply ( invmaponpathsweq ( weqlmultingr X c ) _ _ e ) .  Defined .  \n\nLemma grrcan ( X : gr ) { a b : X } ( c : X ) ( e : paths ( op a c ) ( op b c ) ) : paths a b .\nProof . intros . apply ( invmaponpathsweq ( weqrmultingr X c ) _ _ e ) .  Defined .  \n\nLemma grinvunel ( X : gr ) : paths ( grinv X ( unel X ) ) ( unel X ) .\nProof . intro . apply ( grrcan X ( unel X ) ) . rewrite ( grlinvax X ) . rewrite ( runax X ) . apply idpath .  Defined .   \n\nLemma grinvinv ( X : gr ) ( a : X ) : paths ( grinv X ( grinv X a ) ) a . \nProof . intros . apply ( grlcan X ( grinv X a ) ) .  rewrite ( grlinvax X a ) . rewrite ( grrinvax X _ ) . apply idpath . Defined . \n\nLemma grinvmaponpathsinv ( X : gr ) { a b : X } ( e : paths ( grinv X a ) ( grinv X b ) ) : paths a b . \nProof . 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 .\n\nLemma grinvandmonoidfun ( X Y : gr ) { f : X -> Y } ( is : ismonoidfun f ) ( x : X ) : paths ( f ( grinv X x ) ) ( grinv Y ( f x ) ) .\nProof . intros . apply ( grrcan Y ( f x ) ) .  rewrite ( pathsinv0 ( pr1 is _ _ ) ) . rewrite ( grlinvax X ) .  rewrite ( grlinvax Y ) .  apply ( pr2 is ) .  Defined . \n\n\n \n\n(** **** Relations on groups *)\n\nLemma isinvbinophrelgr ( X : gr ) { R : hrel X } ( is : isbinophrel R ) : isinvbinophrel R .\nProof . intros . set ( is1 := pr1 is ) . set ( is2 := pr2 is ) .   split . \n\nintros 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' .   \n\nintros 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 .\n\nOpaque isinvbinophrelgr .\n\nLemma isbinophrelgr ( X : gr ) { R : hrel X } ( is : isinvbinophrel R ) : isbinophrel R .\nProof . intros . set ( is1 := pr1 is ) . set ( is2 := pr2 is ) .   split . \n\nintros 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 ) . \n\nintros 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 .\n\nOpaque isbinophrelgr . \n\nLemma grfromgtunel ( X : gr ) { R : hrel X } ( is : isbinophrel R ) { x : X } ( isg : R x ( unel X ) ) : R ( unel X ) ( grinv X x ) .\nProof . intros . assert ( r := ( pr2 is ) _ _ ( grinv X x ) isg ) . rewrite ( grrinvax X x ) in r .  rewrite ( lunax X _ ) in r . apply r . Defined .    \n\nLemma grtogtunel ( X : gr ) { R : hrel X } ( is : isbinophrel R ) { x : X } ( isg : R ( unel X ) ( grinv X x )  ) : R x ( unel X )  .\nProof . intros . assert ( r := ( pr2 is ) _ _ x isg ) . rewrite ( grlinvax X x ) in r .  rewrite ( lunax X _ ) in r . apply r . Defined .    \n    \nLemma grfromltunel ( X : gr ) { R : hrel X } ( is : isbinophrel R ) { x : X } ( isg : R ( unel X ) x ) : R ( grinv X x ) ( unel X ) .\nProof . intros . assert ( r := ( pr1 is ) _ _ ( grinv X x ) isg ) . rewrite ( grlinvax X x ) in r .  rewrite ( runax X _ ) in r . apply r . Defined . \n\nLemma grtoltunel ( X : gr ) { R : hrel X } ( is : isbinophrel R ) { x : X } ( isg :  R ( grinv X x ) ( unel X ) ) : R ( unel X ) x .\nProof . intros . assert ( r := ( pr1 is ) _ _ x isg ) . rewrite ( grrinvax X x ) in r .  rewrite ( runax X _ ) in r . apply r . Defined .\n\n\n(** **** Subobjects *)\n\nDefinition issubgr { X : gr } ( A : hsubtypes X ) := dirprod ( issubmonoid A ) ( forall x : X , A x -> A ( grinv X x ) ) . \n\nLemma isapropissubgr { X : gr } ( A : hsubtypes X ) : isaprop ( issubgr A ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply isapropissubmonoid . apply impred . intro x .   apply impred . intro a . apply ( pr2 (A ( grinv X x)) ) . Defined . \n\n\n \n\nDefinition subgrs { X : gr } := total2 ( fun A : hsubtypes X => issubgr A ) .\nDefinition subgrpair { X : gr } := tpair ( fun A : hsubtypes X => issubgr A ) . \nDefinition subgrconstr { X : gr } := @subgrpair X .  \nDefinition subgrstosubmonoids ( X : gr ) : @subgrs X -> @submonoids X := fun A : _ => submonoidpair ( pr1 A ) ( pr1 ( pr2 A ) ) . \nCoercion subgrstosubmonoids : subgrs >-> submonoids .\n\nLemma 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 ) ) ) .\nProof . intros . split .\n\nintro a .  apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) .  simpl . apply ( grlinvax X ( pr1 a ) ) .  \nintro a .  apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) .  simpl . apply ( grrinvax X ( pr1 a ) ) . Defined .  \n\nDefinition 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 ) ) . \n\nDefinition carrierofasubgr { X : gr } ( A : @subgrs X ) : gr .\nProof . intros . split with A . apply ( isgrcarrier A ) . Defined .   \n\n\nCoercion carrierofasubgr : subgrs >-> gr . \n\n\n\n(** **** Quotient objects *)\n\nLemma grquotinvcomp { X : gr } ( R : @binopeqrel X ) : iscomprelrelfun R R (grinv X) .\nProof . 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 . \n\nOpaque grquotinvcomp . \n\nDefinition invongrquot { X : gr } ( R : @binopeqrel X ) : setquot R -> setquot R := setquotfun R R ( grinv X ) ( grquotinvcomp R ) .\n  \nLemma isinvongrquot { X : gr } ( R : @binopeqrel X ) : isinv ( @op ( setwithbinopquot R ) ) ( setquotpr R ( unel X ) ) ( invongrquot R ) . \nProof . intros . split .\n\nunfold 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 ) . \n\nunfold 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 .\n\nOpaque isinvongrquot . \n\nDefinition isgrquot { X : gr } ( R : @binopeqrel X ) : isgrop ( @op ( setwithbinopquot R ) ) := tpair _ ( ismonoidquot R ) ( tpair _ ( invongrquot R ) ( isinvongrquot R ) ) . \n\nDefinition grquot { X : gr } ( R : @binopeqrel X ) : gr .\nProof . intros . split with ( setwithbinopquot R ) . apply isgrquot . Defined .  \n\n\n(** **** Direct products *)\n\n\nLemma isgrdirprod ( X Y : gr ) : isgrop ( @op ( setwithbinopdirprod X Y ) ) .\nProof . intros . split with ( ismonoiddirprod X Y ) .  split with ( fun xy : _ => dirprodpair ( grinv X ( pr1 xy ) ) ( grinv Y ( pr2 xy ) ) ) .  split .\n\nintro xy . destruct xy as [ x y ] .  unfold unel_is . simpl . apply pathsdirprod . apply ( grlinvax X x ) .  apply ( grlinvax Y y ) . \nintro xy . destruct xy as [ x y ] .  unfold unel_is . simpl .  apply pathsdirprod . apply ( grrinvax X x ) .  apply ( grrinvax Y y ) . Defined .\n\nDefinition grdirprod ( X Y : gr ) : gr .\nProof . intros . split with ( setwithbinopdirprod X Y ) . apply isgrdirprod . Defined .   \n\n\n\n\n(** *** Abelian groups *)\n\n\n(** **** Basic definitions *)\n\n\nDefinition abgr := total2 ( fun X : setwithbinop =>  isabgrop ( @op X ) ) .\nDefinition abgrpair ( X : setwithbinop ) ( is : isabgrop ( @op X ) ) : abgr  := tpair ( fun X : setwithbinop =>  isabgrop ( @op X ) ) X is .\nDefinition 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 ) ) .\nDefinition abgrtogr : abgr -> gr := fun X : _ => grpair ( pr1 X ) ( pr1 ( pr2 X ) ) . \nCoercion abgrtogr : abgr >-> gr .\n\nDefinition abgrtoabmonoid : abgr -> abmonoid := fun X : _ => abmonoidpair ( pr1 X ) ( dirprodpair ( pr1 ( pr1 ( pr2 X ) ) ) ( pr2 ( pr2 X ) ) )  .  \nCoercion abgrtoabmonoid : abgr >-> abmonoid .\n\n\n(** **** Subobjects *)\n\n\nDefinition subabgrs { X : abgr } := @subgrs X .\nIdentity Coercion id_subabgrs : subabgrs >-> subgrs .\n\nLemma isabgrcarrier { X : abgr } ( A : @subgrs X ) : isabgrop ( @op A ) .\nProof . intros . split with ( isgrcarrier A ) . apply ( pr2 ( @isabmonoidcarrier X A ) ) .  Defined . \n\nDefinition carrierofasubabgr { X : abgr } ( A : @subabgrs X ) : abgr .\nProof . intros . split with A . apply isabgrcarrier .  Defined . \n\nCoercion carrierofasubabgr : subabgrs >-> abgr . \n\n\n\n(** **** Quotient objects *)\n\nLemma isabgrquot { X : abgr } ( R : @binopeqrel X ) : isabgrop ( @op ( setwithbinopquot R ) ) .\nProof . intros . split with ( isgrquot R ) . apply ( pr2 ( @isabmonoidquot X R ) ) .  Defined . \n\n\nDefinition abgrquot { X : abgr } ( R : @binopeqrel X ) : abgr .\nProof . intros . split with ( setwithbinopquot R ) . apply isabgrquot . Defined . \n\n\n(** **** Direct products *)\n\nLemma isabgrdirprod ( X Y : abgr ) : isabgrop ( @op ( setwithbinopdirprod X Y ) ) .\nProof . intros . split with ( isgrdirprod X Y ) .  apply ( pr2 ( isabmonoiddirprod X Y ) ) .  Defined . \n\nDefinition abgrdirprod ( X Y : abgr ) : abgr .\nProof . intros . split with ( setwithbinopdirprod X Y ) . apply isabgrdirprod . Defined . \n\n\n(** **** Abelian group of fractions of an abelian unitary monoid *)\n\nOpen Scope addmonoid_scope . \n\nDefinition 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 ) ) . \n\nDefinition abgrfracphi ( X : abmonoid ) ( xa : dirprod X X ) : dirprod X ( totalsubtype X ) := dirprodpair ( pr1 xa ) ( carrierpair ( fun x : X => htrue ) ( pr2 xa ) tt ) .  \n\nDefinition hrelabgrfrac' ( X : abmonoid ) : hrel ( dirprod X X ) :=  fun xa1 xa2 =>  eqrelabmonoidfrac X ( totalsubmonoid X ) ( abgrfracphi X xa1 ) ( abgrfracphi X xa2 )  .\n\nLemma logeqhrelsabgrfrac ( X : abmonoid ) : hrellogeq ( hrelabgrfrac' X ) ( hrelabgrfrac X ) . \nProof . 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 . \n\n\nLemma iseqrelabgrfrac ( X : abmonoid ) : iseqrel ( hrelabgrfrac X ) .\nProof . 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 .\n\nOpaque iseqrelabgrfrac . \n\nDefinition eqrelabgrfrac ( X : abmonoid ) : @eqrel ( abmonoiddirprod X X ) := eqrelpair _ ( iseqrelabgrfrac X ) .\n\nLemma isbinophrelabgrfrac ( X : abmonoid ) : @isbinophrel ( abmonoiddirprod X X ) ( hrelabgrfrac X ) .\nProof . 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 .  \n\nOpaque isbinophrelabgrfrac .\n\nDefinition binopeqrelabgrfrac ( X : abmonoid ) : @binopeqrel ( abmonoiddirprod X X ) := binopeqrelpair ( eqrelabgrfrac X ) ( isbinophrelabgrfrac X ) .\n\nDefinition abgrfraccarrier ( X : abmonoid ) : abmonoid := @abmonoidquot ( abmonoiddirprod X X ) ( binopeqrelabgrfrac X ) .\n\nDefinition abgrfracinvint ( X : abmonoid ) :  dirprod X X -> dirprod X X := fun xs : _ => dirprodpair ( pr2 xs ) ( pr1 xs ) . \n\nLemma  abgrfracinvcomp ( X : abmonoid ) : iscomprelrelfun ( hrelabgrfrac X ) ( eqrelabgrfrac X ) ( abgrfracinvint X ) .   \nProof . 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 . \n\nOpaque abgrfracinvcomp . \n\nDefinition abgrfracinv ( X : abmonoid ) : abgrfraccarrier X -> abgrfraccarrier X := setquotfun ( hrelabgrfrac X ) ( eqrelabgrfrac X ) ( abgrfracinvint X ) ( abgrfracinvcomp X ) .   \n\nLemma abgrfracisinv ( X : abmonoid ) : isinv ( @op ( abgrfraccarrier X ) ) ( unel ( abgrfraccarrier X ) ) ( abgrfracinv X ) . \nProof . intros . set ( R := eqrelabgrfrac X ) . \n\nassert ( 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 .\n\napply ( dirprodpair isl ( weqlinvrinv ( @op ( abgrfraccarrier X ) ) ( commax ( abgrfraccarrier X ) ) ( unel ( abgrfraccarrier X ) ) ( abgrfracinv X ) isl ) ) .   Defined . \n\n\nOpaque abgrfracisinv . \n\nDefinition abgrfrac ( X : abmonoid ) : abgr := abgrconstr ( abgrfraccarrier X ) ( abgrfracinv X ) ( abgrfracisinv X ) .  \n\nDefinition prabgrfrac ( X : abmonoid ) : X -> X -> abgrfrac X := fun x x' : X => setquotpr ( eqrelabgrfrac X ) ( dirprodpair x x' ) .\n\n\n\n(** **** Abelian group of fractions and abelian monoid of fractions *)\n\nDefinition weqabgrfracint ( X : abmonoid ) : weq ( dirprod X X ) ( dirprod X ( totalsubtype X ) ) := weqdirprodf ( idweq X ) ( invweq ( weqtotalsubtype X ) ) . \n\nDefinition weqabgrfrac ( X : abmonoid ) : weq ( abgrfrac X ) ( abmonoidfrac X ( totalsubmonoid X ) ) .\nProof . intros . apply ( weqsetquotweq ( eqrelabgrfrac X ) ( eqrelabmonoidfrac  X ( totalsubmonoid X ) ) ( weqabgrfracint X ) ) .   \n\nsimpl .  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 .\n\nsimpl .  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 . \nDefined . \n\n\n\n\n(** **** Canonical homomorphism to the abelian group of fractions *)\n\nDefinition toabgrfrac ( X : abmonoid ) ( x : X ) : abgrfrac X := setquotpr _ ( dirprodpair x ( unel X ) ) . \n\nLemma isbinopfuntoabgrfrac ( X : abmonoid ) : isbinopfun ( toabgrfrac X ) .\nProof . 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 . \n\nLemma isunitalfuntoabgrfrac ( X : abmonoid )  : paths ( toabgrfrac X ( unel X ) ) ( unel ( abgrfrac X ) ) .\nProof . intros . apply idpath . Defined .  \n\nDefinition ismonoidfuntoabgrfrac ( X : abmonoid ) : ismonoidfun ( toabgrfrac X ) := dirprodpair ( isbinopfuntoabgrfrac X ) ( isunitalfuntoabgrfrac X ) .\n\n\n\n\n\n(** **** Abelian group of fractions in the case when all elements are cancelable *) \n\n\nLemma isinclprabgrfrac ( X : abmonoid ) ( iscanc : forall x : X , isrcancelable ( @op X ) x ) : forall x' : X , isincl ( fun x => prabgrfrac X x x' ) .\nProof . intros . set ( int := isinclprabmonoidfrac X ( totalsubmonoid X ) ( fun a : totalsubmonoid X => iscanc ( pr1 a ) ) ( carrierpair ( fun x : X => htrue ) x' tt ) ) . \nset ( int1 := isinclcomp ( inclpair _ int ) ( invweq ( weqabgrfrac X ) ) ) . apply int1 .  Defined . \n\nDefinition isincltoabgrfrac ( X : abmonoid ) ( iscanc : forall x : X , isrcancelable ( @op X ) x ) : isincl ( toabgrfrac X ) := isinclprabgrfrac X iscanc ( unel X ) . \n\nLemma isdeceqabgrfrac ( X : abmonoid ) ( iscanc : forall x : X , isrcancelable ( @op X ) x ) ( is : isdeceq X ) : isdeceq ( abgrfrac X ) .\nProof . intros . apply ( isdeceqweqf ( invweq ( weqabgrfrac X ) ) ) .   apply ( isdeceqabmonoidfrac X ( totalsubmonoid X ) ( fun a : totalsubmonoid X => iscanc ( pr1 a ) ) is ) . Defined .  \n\n\n\n\n\n\n\n(** **** Relations on the abelian group of fractions *) \n\nDefinition 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 ) ) .\n\nDefinition abgrfracrelint' ( X : abmonoid ) ( L : hrel X ) : hrel ( setwithbinopdirprod X X ) := fun xa1 xa2 => abmonoidfracrelint _ ( totalsubmonoid X ) L ( abgrfracphi X xa1 )  ( abgrfracphi X xa2 ) . \n\nLemma logeqabgrfracrelints ( X : abmonoid ) ( L : hrel X ) : hrellogeq ( abgrfracrelint' X L ) ( abgrfracrelint X L ) .\nProof . 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 .\n\nLemma iscomprelabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : iscomprelrel ( eqrelabgrfrac X ) ( abgrfracrelint X L ) . \nProof . 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 . \n\nOpaque iscomprelabgrfracrelint . \n\nDefinition abgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) := quotrel ( iscomprelabgrfracrelint X is ) .\n\nDefinition 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' )  .\n \nDefinition logeqabgrfracrels ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : hrellogeq ( abgrfracrel' X is ) ( abgrfracrel X is ) .\nProof . intros X L is x1 x2 . split . \n\nassert ( 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' ) ) . \n\n\nassert ( 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 . \n\n\nLemma istransabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : istrans L ) : istrans ( abgrfracrelint X L ) .\nProof . intros .  apply ( istranslogeqf ( logeqabgrfracrelints X L ) ) .  intros a b c rab rbc . apply ( istransabmonoidfracrelint _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl _ _ _ rab rbc ) .  Defined . \n\nOpaque istransabgrfracrelint . \n\nLemma istransabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : istrans L ) : istrans ( abgrfracrel X is ) .\nProof . intros . apply istransquotrel .  apply istransabgrfracrelint . apply is . apply isl . Defined . \n\n\nLemma issymmabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : issymm L ) : issymm ( abgrfracrelint X L ) .\nProof . intros . apply ( issymmlogeqf ( logeqabgrfracrelints X L ) ) .  intros a b rab . apply ( issymmabmonoidfracrelint _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl _ _ rab ) .  Defined . \n\nOpaque issymmabgrfracrelint .\n\nLemma issymmabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : issymm L ) : issymm ( abgrfracrel X is ) .\nProof . intros .  apply issymmquotrel . apply issymmabgrfracrelint .  apply is . apply isl . Defined . \n\nLemma isreflabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isrefl L ) : isrefl ( abgrfracrelint X L ) .\nProof . intros . intro xa . unfold abgrfracrelint .  simpl . apply hinhpr . split with ( unel X ) .  apply ( isl _ ) . Defined .\n\nLemma isreflabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isrefl L ) : isrefl ( abgrfracrel X is ) .\nProof . intros .  apply isreflquotrel . apply isreflabgrfracrelint .  apply is . apply isl . Defined . \n\nLemma ispoabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : ispo L ) : ispo ( abgrfracrelint X L ) .\nProof . intros . split with ( istransabgrfracrelint X is ( pr1 isl ) ) .  apply ( isreflabgrfracrelint X is ( pr2 isl ) ) .  Defined . \n\nLemma ispoabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : ispo L ) : ispo ( abgrfracrel X is ) .\nProof . intros .  apply ispoquotrel . apply ispoabgrfracrelint .  apply is . apply isl . Defined . \n\nLemma iseqrelabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : iseqrel L ) : iseqrel ( abgrfracrelint X L ) .\nProof . intros . split with ( ispoabgrfracrelint X is ( pr1 isl ) ) .  apply ( issymmabgrfracrelint X is ( pr2 isl ) ) .  Defined . \n\nLemma iseqrelabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : iseqrel L ) : iseqrel ( abgrfracrel X is ) .\nProof . intros .  apply iseqrelquotrel . apply iseqrelabgrfracrelint .  apply is . apply isl . Defined .\n\n\nLemma isantisymmnegabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isantisymmneg L ) : isantisymmneg ( abgrfracrel X is ) .\nProof . 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 . \n\nLemma isantisymmabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isantisymm L ) : isantisymm ( abgrfracrel X is ) .\nProof . 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 .\n\nOpaque  isantisymmabgrfracrel .\n\n\nLemma isirreflabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isirrefl L ) : isirrefl ( abgrfracrel X is ) .\nProof . intros .  apply ( isirrefllogeqf ( logeqabgrfracrels X is ) ) .  intros a raa . apply ( isirreflabmonoidfracrel _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl ( weqabgrfrac X a ) raa ) . Defined .\n\nOpaque isirreflabgrfracrel .\n\n\nLemma isasymmabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : isasymm L ) : isasymm ( abgrfracrel X is ) .\nProof . 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 .\n\nOpaque  isasymmabgrfracrel .\n\nLemma iscoasymmabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : iscoasymm L ) : iscoasymm ( abgrfracrel X is ) .\nProof . 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 .\n\nOpaque  iscoasymmabgrfracrel .\n\nLemma istotalabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : istotal L ) : istotal ( abgrfracrel X is ) .\nProof . intros . apply ( istotallogeqf ( logeqabgrfracrels X is ) ) .  intros a b . apply ( istotalabmonoidfracrel _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) isl ( weqabgrfrac X a ) ( weqabgrfrac X b ) ) . Defined .\n\nOpaque istotalabgrfracrel . \n\nLemma iscotransabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isl : iscotrans L ) : iscotrans ( abgrfracrel X is ) .\nProof . 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 .\n\nOpaque iscotransabgrfracrel . \n\n\n\n\nLemma 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'  .\nProof . intros .   generalize ql .  apply quotrelimpl .  intros x0 x0' .  simpl .  apply hinhfun .  intro t2 . split with ( pr1 t2 ) .   apply ( impl _ _ ( pr2 t2 ) ) . Defined . \n\n\nOpaque abgrfracrelimpl . \n\n\nLemma 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' ) .\nProof . intros .   apply quotrellogeq .  intros x0 x0' .  split . \n\nsimpl .  apply hinhfun .  intro t2 . split with ( pr1 t2 ) .   apply ( pr1 ( lg _ _ ) ( pr2 t2 ) ) .\nsimpl .  apply hinhfun .  intro t2 . split with ( pr1 t2 ) .   apply ( pr2 ( lg _ _ ) ( pr2 t2 ) ) . Defined . \n\nOpaque abgrfracrellogeq . \n  \n\nLemma isbinopabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : @isbinophrel ( setwithbinopdirprod X X ) ( abgrfracrelint X L ) . \nProof . intros . apply ( isbinophrellogeqf ( logeqabgrfracrelints X L ) ) . split .  \n\nintros a b c lab . apply ( pr1 ( ispartbinopabmonoidfracrelint _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) ) ( abgrfracphi X a ) ( abgrfracphi X b ) ( abgrfracphi X c ) tt lab ) . \n\nintros a b c lab . apply ( pr2 ( ispartbinopabmonoidfracrelint _ ( totalsubmonoid X ) ( isbinoptoispartbinop _ _ is ) ) ( abgrfracphi X a ) ( abgrfracphi X b ) ( abgrfracphi X c ) tt lab ) . Defined . \n\nOpaque isbinopabgrfracrelint . \n\nLemma isbinopabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : @isbinophrel ( abgrfrac X ) ( abgrfracrel X is ) . \nProof . intros . apply ( isbinopquotrel ( binopeqrelabgrfrac X ) ( iscomprelabgrfracrelint X is ) ) . apply ( isbinopabgrfracrelint X is ) .  Defined . \n\n\nDefinition isdecabgrfracrelint ( X : abmonoid ) { L : hrel X } ( is : isinvbinophrel L ) ( isl : isdecrel L ) : isdecrel ( abgrfracrelint X L ) . \nProof . 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 . \n\nDefinition isdecabgrfracrel ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) ( isi : isinvbinophrel L ) ( isl : isdecrel L ) : isdecrel ( abgrfracrel X is ) .  \nProof . intros . apply isdecquotrel . apply isdecabgrfracrelint .   apply isi . apply isl . Defined .  \n\n\n(** **** Relations and the canonical homomorphism to [ abgrfrac ] *)\n\nLemma iscomptoabgrfrac ( X : abmonoid ) { L : hrel X } ( is : isbinophrel L ) : iscomprelrelfun L ( abgrfracrel X is ) ( toabgrfrac X ) .\nProof . 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 .\n\nOpaque iscomptoabgrfrac .   \n\n\n\n\nClose Scope addmonoid_scope . \n\n\n\n\n\n\n\n\n\n\n\n(* End of the file algebra1b.v *)\n"
  },
  {
    "path": "hlevel2/algebra1c.v",
    "content": "(** * Algebra I. Part C.  Rigs and rings. Vladimir Voevodsky. Aug. 2011 - . \n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)\n\n\n(** Imports *)\n\nAdd LoadPath \"../..\" .\n\nRequire Export Foundations.hlevel2.algebra1b .\n\n\n(** To upstream files *)\n\n\n(** ** Standard Algebraic Structures (cont.) *)\n\n\n(** *** Rigs - semirings with 1 , 0 and x*0 = 0*x=0 *)\n\n(** **** General definitions *)\n\n\n\nDefinition rig := total2 ( fun X : setwith2binop =>  isrigops ( @op1 X ) ( @op2 X ) )  .\nDefinition rigpair { X : setwith2binop } ( is : isrigops ( @op1 X ) ( @op2 X ) ) : rig  := tpair ( fun X : setwith2binop =>  isrigops ( @op1 X ) ( @op2 X ) ) X is .\nDefinition pr1rig : rig -> setwith2binop := @pr1 _ ( fun X : setwith2binop =>  isrigops ( @op1 X ) ( @op2 X ) ) .\nCoercion pr1rig : rig >-> setwith2binop . \n\nDefinition rigaxs ( X : rig ) : isrigops ( @op1 X ) ( @op2 X ) := pr2 X . \n\nDefinition rigop1axs ( X : rig ) : isabmonoidop ( @op1 X ) := rigop1axs_is ( pr2 X ) .\nDefinition rigassoc1 ( X : rig ) : isassoc ( @op1 X ) := assocax_is ( rigop1axs X ) . \nDefinition rigunel1 { X : rig } : X := unel_is ( rigop1axs X ) . \nDefinition riglunax1 ( X : rig ) : islunit op1 ( @rigunel1 X ) := lunax_is ( rigop1axs X ) .\nDefinition rigrunax1 ( X : rig ) : isrunit op1 ( @rigunel1 X ) := runax_is ( rigop1axs X ) .\nDefinition rigmult0x ( X : rig ) : forall x : X , paths ( op2 ( @rigunel1 X ) x ) ( @rigunel1 X ) := rigmult0x_is ( pr2 X ) . \nDefinition rigmultx0 ( X : rig ) : forall x : X , paths ( op2 x ( @rigunel1 X ) ) ( @rigunel1 X ) := rigmultx0_is ( pr2 X ) . \nDefinition rigcomm1 ( X : rig ) : iscomm ( @op1 X ) := commax_is ( rigop1axs X ) .\n \n\nDefinition rigop2axs ( X : rig ) : ismonoidop ( @op2 X ) := rigop2axs_is ( pr2 X ) .\nDefinition rigassoc2 ( X : rig ) : isassoc ( @op2 X ) := assocax_is ( rigop2axs X ) . \nDefinition rigunel2 { X : rig } : X := unel_is ( rigop2axs X ) . \nDefinition riglunax2 ( X : rig ) : islunit op2 ( @rigunel2 X ) := lunax_is ( rigop2axs X ) .\nDefinition rigrunax2 ( X : rig ) : isrunit op2 ( @rigunel2 X ) := runax_is ( rigop2axs X ) .\n\n\nDefinition rigdistraxs ( X : rig ) : isdistr ( @op1 X ) ( @op2 X ) := pr2 ( pr2 X ) .\nDefinition rigldistr ( X : rig ) : isldistr ( @op1 X ) ( @op2 X ) := pr1 ( pr2 ( pr2 X ) ) .\nDefinition rigrdistr ( X : rig ) : isrdistr ( @op1 X ) ( @op2 X ) := pr2 ( pr2 ( pr2 X ) ) .  \n\nDefinition 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 .\nProof. intros. split with  ( setwith2binoppair X ( dirprodpair opp1 opp2 ) ) . split . split with ( dirprodpair ( dirprodpair ax11 ax12 ) ax2 ) . apply ( dirprodpair m0x mx0 ) . apply dax . Defined .  \n\nDefinition rigaddabmonoid ( X : rig ) : abmonoid := abmonoidpair ( setwithbinoppair X op1 ) ( rigop1axs X ) .\nDefinition rigmultmonoid ( X : rig ) : monoid := monoidpair  ( setwithbinoppair X op2 ) ( rigop2axs X ) .\n\nNotation \"x + y\" := ( op1 x y ) : rig_scope .\nNotation \"x * y\" := ( op2 x y ) : rig_scope . \nNotation \"0\" := ( rigunel1 ) : rig_scope .   \nNotation \"1\" := ( rigunel2 ) : rig_scope .\n\nDelimit Scope rig_scope with rig . \n\n\n\n  \n\n\n(** **** Homomorphisms of rigs (rig functions) *)\n\nDefinition isrigfun { X Y : rig } ( f : X -> Y ) := dirprod ( @ismonoidfun ( rigaddabmonoid X ) ( rigaddabmonoid Y ) f ) ( @ismonoidfun ( rigmultmonoid X ) ( rigmultmonoid Y ) f ) .  \n\nDefinition rigfun ( X Y : rig ) := total2 ( fun f : X -> Y => isrigfun f ) .\nDefinition rigfunconstr { X Y : rig } { f : X -> Y } ( is : isrigfun f ) : rigfun X Y := tpair _ f is .   \nDefinition pr1rigfun ( X Y : rig ) : rigfun X Y  -> ( X -> Y ) := @pr1 _ _ .\nCoercion pr1rigfun : rigfun >-> Funclass. \n\nDefinition rigaddfun { X Y : rig } ( f : rigfun X Y ) : monoidfun ( rigaddabmonoid X ) ( rigaddabmonoid Y ) := monoidfunconstr ( pr1 ( pr2 f ) ) . \nDefinition rigmultfun { X Y : rig } ( f : rigfun X Y ) : monoidfun ( rigmultmonoid X ) ( rigmultmonoid Y ) := monoidfunconstr ( pr2 ( pr2 f ) ) . \n\nDefinition rigiso ( X Y : rig ) := total2 ( fun f : weq X Y => isrigfun f ) .   \nDefinition rigisopair { X Y : rig } ( f : weq X Y ) ( is : isrigfun f ) : rigiso X Y := tpair _  f is .\nDefinition pr1rigiso ( X Y : rig ) : rigiso X Y -> weq X Y := @pr1 _ _ .\nCoercion pr1rigiso : rigiso >-> weq .\n\nDefinition rigaddiso { X Y : rig } ( f : rigiso X Y ) : monoidiso ( rigaddabmonoid X ) ( rigaddabmonoid Y ) := @monoidisopair ( rigaddabmonoid X ) ( rigaddabmonoid Y ) ( pr1 f ) ( pr1 ( pr2 f ) ) . \nDefinition rigmultiso { X Y : rig } ( f : rigiso X Y ) : monoidiso ( rigmultmonoid X ) ( rigmultmonoid Y ) := @monoidisopair ( rigmultmonoid X )  ( rigmultmonoid Y ) ( pr1 f ) ( pr2 ( pr2 f ) ) . \n\nLemma isrigfuninvmap { X Y : rig } ( f : rigiso X Y ) : isrigfun ( invmap f ) .\nProof . intros . split . apply ( ismonoidfuninvmap ( rigaddiso f ) ) . apply  ( ismonoidfuninvmap ( rigmultiso f ) ) . Defined .   \n\n\n\n(** **** Relations similar to \"greater\" or \"greater or equal\" on rigs *)\n\nDefinition 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 ) ) . \n\nDefinition 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 ) . \n\n\n(** **** Subobjects *)\n\nDefinition issubrig { X : rig } ( A : hsubtypes X ) := dirprod ( @issubmonoid ( rigaddabmonoid X ) A ) ( @issubmonoid ( rigmultmonoid X ) A ) . \n\nLemma isapropissubrig { X : rig } ( A : hsubtypes X ) : isaprop ( issubrig A ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply isapropissubmonoid . apply isapropissubmonoid . Defined . \n\nDefinition subrigs ( X : rig ) := total2 ( fun  A : hsubtypes X => issubrig A ) .\nDefinition subrigpair { X : rig } := tpair ( fun  A : hsubtypes X => issubrig A ) .\nDefinition pr1subrig ( X : rig ) : @subrigs X -> hsubtypes X := @pr1 _ (fun  A : hsubtypes X => issubrig A ) .\n\nDefinition subrigtosubsetswith2binop ( X : rig ) : subrigs X -> @subsetswith2binop X := fun A : _ => subsetswith2binoppair ( pr1 A ) ( dirprodpair ( pr1 ( pr1 ( pr2 A ) ) ) ( pr1 ( pr2 ( pr2 A ) ) ) ) . \nCoercion subrigtosubsetswith2binop : subrigs >-> subsetswith2binop . \n\nDefinition rigaddsubmonoid { X : rig } : subrigs X -> @subabmonoids ( rigaddabmonoid X ) := fun A : _ => @submonoidpair ( rigaddabmonoid X ) ( pr1 A ) ( pr1 ( pr2 A ) ) .\nDefinition rigmultsubmonoid { X : rig } : subrigs X -> @submonoids ( rigmultmonoid X ) := fun A : _ => @submonoidpair ( rigmultmonoid X ) ( pr1 A ) ( pr2 ( pr2 A ) ) .  \n\nLemma isrigcarrier { X : rig } ( A : subrigs X ) : isrigops ( @op1 A ) ( @op2 A ) .\nProof . intros . split . split with ( dirprodpair ( isabmonoidcarrier ( rigaddsubmonoid A ) ) ( ismonoidcarrier ( rigmultsubmonoid A ) ) ) . split . \n\nintro a . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply rigmult0x .   \nintro a .  apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) . simpl . apply rigmultx0 .  split . \n\nintros a b c . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) .  simpl . apply rigldistr .  \nintros a b c . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) .  simpl . apply rigrdistr . Defined .   \n\nDefinition carrierofasubrig ( X : rig ) ( A : subrigs X ) : rig .\nProof . intros . split with A . apply isrigcarrier .  Defined . \n\nCoercion carrierofasubrig : subrigs >-> rig .  \n\n\n(** **** Quotient objects *) \n\n\nDefinition rigeqrel { X : rig } := @twobinopeqrel X .\nIdentity Coercion id_rigeqrel : rigeqrel >-> twobinopeqrel .\n\nDefinition addabmonoideqrel { X : rig } ( R : @rigeqrel X ) : @binopeqrel ( rigaddabmonoid X ) := @binopeqrelpair ( rigaddabmonoid X ) ( pr1 R ) ( pr1 ( pr2 R ) ) .     \n\nDefinition multmonoideqrel { X : rig } ( R : @rigeqrel X ) : @binopeqrel ( rigmultmonoid X ) := @binopeqrelpair ( rigmultmonoid X ) ( pr1 R ) ( pr2 ( pr2 R ) ) .\n\nLemma isrigquot { X : rig } ( R : @rigeqrel X ) : isrigops ( @op1 ( setwith2binopquot R ) ) ( @op2 ( setwith2binopquot R ) ) . \nProof . 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 . \n\napply  ( setquotunivprop R ( fun x  => hProppair _ ( setproperty ( setwith2binopquot R ) ( opp2 zr x ) zr ) ) ) .  intro x .   apply ( maponpaths ( setquotpr R ) ( rigmult0x X x ) ) .  \napply  ( setquotunivprop R ( fun x  => hProppair _ ( setproperty ( setwith2binopquot R ) ( opp2 x zr ) zr ) ) ) .  intro x .   apply ( maponpaths ( setquotpr R ) ( rigmultx0 X x ) ) .\n\nset ( opp1 := @op1 ( setwith2binopquot R ) ) . set ( opp2 := @op2 ( setwith2binopquot R ) ) .  split . \n\n\nunfold 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'' ) ) .  \n\nunfold 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 .\n\nDefinition rigquot { X : rig } ( R : @rigeqrel X ) : rig := @rigpair ( setwith2binopquot R ) ( isrigquot R ) .   \n\n\n\n(** **** Direct products *)\n\nLemma isrigdirprod ( X Y : rig ) : isrigops ( @op1 ( setwith2binopdirprod X Y ) ) ( @op2 ( setwith2binopdirprod X Y ) ) .\nProof . intros . split .   split with ( dirprodpair ( isabmonoiddirprod ( rigaddabmonoid X ) ( rigaddabmonoid Y ) ) ( ismonoiddirprod ( rigmultmonoid X ) ( rigmultmonoid Y ) ) ) . simpl .  split . \n\nintro xy . unfold setwith2binopdirprod . unfold op1 . unfold op2 . unfold ismonoiddirprod . unfold unel_is .   simpl .  apply pathsdirprod .  apply ( rigmult0x X ) .  apply ( rigmult0x Y ) . \nintro xy . unfold setwith2binopdirprod . unfold op1 . unfold op2 . unfold ismonoiddirprod . unfold unel_is .   simpl .  apply pathsdirprod .  apply ( rigmultx0 X ) .  apply ( rigmultx0 Y ) . split . \n\nintros xy xy' xy'' . unfold setwith2binopdirprod . unfold op1 . unfold op2 .  simpl . apply pathsdirprod .  apply ( rigldistr X ) .  apply ( rigldistr Y ) . \nintros xy xy' xy'' . unfold setwith2binopdirprod . unfold op1 . unfold op2 .  simpl . apply pathsdirprod .  apply ( rigrdistr X ) .  apply ( rigrdistr Y ) .  Defined . \n\n\nDefinition rigdirprod ( X Y : rig ) := @rigpair ( setwith2binopdirprod X Y ) ( isrigdirprod X Y ) . \n\n\n\n\n\n(** *** Commutative rigs *)\n\n(** **** General definitions *)\n\n\nDefinition commrig := total2 ( fun X : setwith2binop => iscommrigops ( @op1 X ) ( @op2 X ) ) .\nDefinition commrigpair ( X : setwith2binop ) ( is : iscommrigops ( @op1 X ) ( @op2 X ) ) : commrig := tpair ( fun X : setwith2binop => iscommrigops ( @op1 X ) ( @op2 X ) ) X is .\n\nDefinition 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 .\nProof. 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 . \n\nDefinition commrigtorig : commrig -> rig := fun X : _ => @rigpair ( pr1 X ) ( pr1 ( pr2 X ) ) . \nCoercion commrigtorig : commrig >-> rig .\n\nDefinition rigcomm2 ( X : commrig ) : iscomm ( @op2 X ) := pr2 ( pr2 X ) . \nDefinition commrigop2axs ( X : commrig ) : isabmonoidop ( @op2 X ) := tpair _ ( rigop2axs X ) ( rigcomm2 X ) . \n\n\nDefinition commrigmultabmonoid ( X : commrig ) : abmonoid := abmonoidpair ( setwithbinoppair X op2 ) ( dirprodpair ( rigop2axs X ) ( rigcomm2 X ) ) .\n\n\n \n(** **** Relations similar to \"greater\" on commutative rigs *)\n\n\nLemma 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 . \nProof . 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 . \n\n\n\n(** **** Subobjects *)\n\nLemma iscommrigcarrier { X : commrig } ( A : @subrigs X ) : iscommrigops ( @op1 A ) ( @op2 A ) .\nProof . intros . split with ( isrigcarrier A ) . apply ( pr2 ( @isabmonoidcarrier ( commrigmultabmonoid X ) ( rigmultsubmonoid A ) ) ) .  Defined . \n\n(* ??? slows down at the last [ apply ] and at [ Defined ] ( oct.16.2011 - does not slow down anymore with two Dan's patches ) *)\n\nDefinition carrierofasubcommrig { X : commrig } ( A : @subrigs X ) : commrig := commrigpair A ( iscommrigcarrier A ) . \n\n\n(** **** Quotient objects *)\n\nLemma iscommrigquot { X : commrig } ( R : @rigeqrel X ) : iscommrigops ( @op1 ( setwith2binopquot R ) ) ( @op2 ( setwith2binopquot R ) ) . \nProof . intros . split with ( isrigquot R ) . apply ( pr2 ( @isabmonoidquot  ( commrigmultabmonoid X ) ( multmonoideqrel R ) ) ) .  Defined . \n\nDefinition commrigquot { X : commrig } ( R : @rigeqrel X ) := commrigpair ( setwith2binopquot R ) ( iscommrigquot R ) . \n\n\n\n\n(** **** Direct products *)\n\nLemma iscommrigdirprod ( X Y : commrig ) : iscommrigops ( @op1 ( setwith2binopdirprod X Y ) ) ( @op2 ( setwith2binopdirprod X Y ) ) .\nProof . intros . split with ( isrigdirprod X Y ) . apply ( pr2 ( isabmonoiddirprod ( commrigmultabmonoid X ) ( commrigmultabmonoid Y ) ) ) . Defined . \n\nDefinition commrigdirprod ( X Y : commrig ) := commrigpair ( setwith2binopdirprod X Y ) ( iscommrigdirprod X Y ) . \n\n\n\n\n(** *** Rings *)\n\n\n(** **** General definitions *)\n\n\nDefinition rng := total2 ( fun X : setwith2binop =>  isrngops ( @op1 X ) ( @op2 X ) )  .\nDefinition rngpair { X : setwith2binop } ( is : isrngops ( @op1 X ) ( @op2 X ) ) : rng  := tpair ( fun X : setwith2binop =>  isrngops ( @op1 X ) ( @op2 X ) ) X is .\nDefinition pr1rng : rng -> setwith2binop := @pr1 _ ( fun X : setwith2binop =>  isrngops ( @op1 X ) ( @op2 X ) ) .\nCoercion pr1rng : rng >-> setwith2binop .  \n\n\nDefinition rngaxs ( X : rng ) : isrngops ( @op1 X ) ( @op2 X ) := pr2 X . \n\nDefinition rngop1axs ( X : rng ) : isabgrop ( @op1 X ) := pr1 ( pr1 ( pr2 X ) ) .\nDefinition rngassoc1 ( X : rng ) : isassoc ( @op1 X ) := assocax_is ( rngop1axs X ) . \nDefinition rngunel1 { X : rng } : X := unel_is ( rngop1axs X ) . \nDefinition rnglunax1 ( X : rng ) : islunit op1 ( @rngunel1 X ) := lunax_is ( rngop1axs X ) .\nDefinition rngrunax1 ( X : rng ) : isrunit op1 ( @rngunel1 X ) := runax_is ( rngop1axs X ) .\nDefinition rnginv1 { X : rng } : X -> X := grinv_is ( rngop1axs X ) .\nDefinition rnglinvax1 ( X : rng ) : forall x : X , paths ( op1 ( rnginv1 x ) x ) rngunel1 := grlinvax_is ( rngop1axs X ) .\nDefinition rngrinvax1 ( X : rng ) : forall x : X , paths ( op1 x ( rnginv1 x ) ) rngunel1 := grrinvax_is ( rngop1axs X ) . \nDefinition rngcomm1 ( X : rng ) : iscomm ( @op1 X ) := commax_is ( rngop1axs X ) .\n \n\nDefinition rngop2axs ( X : rng ) : ismonoidop ( @op2 X ) := pr2 ( pr1 ( pr2 X ) ) .\nDefinition rngassoc2 ( X : rng ) : isassoc ( @op2 X ) := assocax_is ( rngop2axs X ) . \nDefinition rngunel2 { X : rng } : X := unel_is ( rngop2axs X ) . \nDefinition rnglunax2 ( X : rng ) : islunit op2 ( @rngunel2 X ) := lunax_is ( rngop2axs X ) .\nDefinition rngrunax2 ( X : rng ) : isrunit op2 ( @rngunel2 X ) := runax_is ( rngop2axs X ) .\n\n\nDefinition rngdistraxs ( X : rng ) : isdistr ( @op1 X ) ( @op2 X ) := pr2 ( pr2 X ) .\nDefinition rngldistr ( X : rng ) : isldistr ( @op1 X ) ( @op2 X ) := pr1 ( pr2 ( pr2 X ) ) .\nDefinition rngrdistr ( X : rng ) : isrdistr ( @op1 X ) ( @op2 X ) := pr2 ( pr2 ( pr2 X ) ) .  \n\nDefinition 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 ) .   \n\nDefinition rngmultx0 ( X : rng ) : forall x : X , paths ( op2 x rngunel1 ) rngunel1 := rngmultx0_is ( rngaxs X ) .  \nDefinition rngmult0x ( X : rng ) : forall x : X , paths ( op2 rngunel1 x ) rngunel1 := rngmult0x_is ( rngaxs X ) .\nDefinition rngminus1 { X : rng } : X := rngminus1_is ( rngaxs X ) . \nDefinition rngmultwithminus1 ( X : rng ) : forall x : X , paths ( op2 rngminus1 x ) ( rnginv1 x ) := rngmultwithminus1_is ( rngaxs X ) .\n  \n\nDefinition rngaddabgr ( X : rng ) : abgr := abgrpair ( setwithbinoppair X op1 ) ( rngop1axs X ) .\nDefinition rngmultmonoid ( X : rng ) : monoid := monoidpair  ( setwithbinoppair X op2 ) ( rngop2axs X ) .\n\nNotation \"x + y\" := ( op1 x y ) : rng_scope .\nNotation \"x - y\" := ( op1 x ( rnginv1 y ) ) .\nNotation \"x * y\" := ( op2 x y ) : rng_scope . \nNotation \"0\" := ( rngunel1 ) : rng_scope .   \nNotation \"1\" := ( rngunel2 ) : rng_scope .\nNotation \"-1\" := ( rngminus1 ) ( at level 0 ) : rng_scope . \nNotation \" - x \" := ( rnginv1 x ) : rng_scope .\n\nDelimit Scope rng_scope with rng . \n\n\nDefinition rngtorig ( X : rng ) : rig := @rigpair _ ( pr2 X ) . \nCoercion rngtorig : rng >-> rig .\n\n(** **** Homomorphisms of rings *)\n\nDefinition isrngfun { X Y : rng } ( f : X -> Y ) := @isrigfun X Y f .  \n\nDefinition rngfun ( X Y : rng ) := rigfun X Y .\nDefinition rngfunconstr { X Y : rng } { f : X -> Y } ( is : isrngfun f ) : rngfun X Y := rigfunconstr is .   \nIdentity Coercion id_rngfun : rngfun >-> rigfun. \n\nDefinition rngaddfun { X Y : rng } ( f : rngfun X Y ) : monoidfun ( rngaddabgr X ) ( rngaddabgr Y ) := monoidfunconstr ( pr1 ( pr2 f ) ) . \nDefinition rngmultfun { X Y : rng } ( f : rngfun X Y ) : monoidfun ( rngmultmonoid X ) ( rngmultmonoid Y ) := monoidfunconstr ( pr2 ( pr2 f ) ) . \n\nDefinition rngiso ( X Y : rng ) := rigiso X Y .   \nDefinition rngisopair { X Y : rng } ( f : weq X Y ) ( is : isrngfun f ) : rngiso X Y := tpair _  f is .\nIdentity Coercion id_rngiso : rngiso >-> rigiso .\n\nDefinition isrngfuninvmap { X Y : rng } ( f : rngiso X Y ) : isrngfun ( invmap f ) := isrigfuninvmap f . \n   \n\n\n\n\n\n\n(** **** Computation lemmas for rings *)\n\nOpen Scope rng_scope . \n\nDefinition rnginvunel1 ( X : rng ) : paths ( - 0 ) 0 := grinvunel ( rngaddabgr X ) .\n\nLemma rngismultlcancelableif ( X : rng ) ( x : X ) ( isl: forall y , paths ( x * y ) 0 -> paths y 0 ) : islcancelable op2 x . \nProof . 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 .\n\nOpaque  rngismultlcancelableif .\n\nLemma rngismultrcancelableif ( X : rng ) ( x : X ) ( isr: forall y , paths ( y * x ) 0 -> paths y 0 ) : isrcancelable op2 x . \nProof . 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 .\n\nOpaque  rngismultrcancelableif .\n\nLemma 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 .\nProof . intros . apply ( dirprodpair ( rngismultlcancelableif X x isl ) ( rngismultrcancelableif X x isr ) ) . Defined . \n\nLemma rnglmultminus ( X : rng ) ( a b : X ) : paths ( ( - a ) * b ) ( - ( a * b ) ) .\nProof . 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 . \n\nOpaque rnglmultminus .\n\nLemma rngrmultminus ( X : rng ) ( a b : X ) : paths ( a * ( - b ) ) ( - ( a * b ) ) .\nProof . 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 . \n \nOpaque rngrmultminus .\n\nLemma rngmultminusminus ( X : rng ) ( a b : X ) : paths ( -a * - b ) ( a * b ) .\nProof . 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 .\n\nOpaque rngmultminusminus .  \n\nLemma rngminusminus ( X : rng ) ( a : X ) : paths ( - - a ) a .\nProof . intros . apply  ( grinvinv ( rngaddabgr X ) a ) . Defined . \n\nDefinition rnginvmaponpathsminus ( X : rng ) { a b : X } ( e : paths ( - a ) ( - b ) ) : paths a b := grinvmaponpathsinv ( rngaddabgr X ) e . \n\n\n(** **** Relations compatible with the additive structure on rings *)\n\n\nDefinition 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 . \n\nDefinition 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 . \n\nDefinition 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 . \n\nDefinition 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 .\n\n\n(** **** Relations compatible with the multiplicative structure on rings *)\n \n\nDefinition isrngmultgt ( X : rng ) ( R : hrel X ) := forall a b , R a 0 -> R b 0 -> R ( a * b ) 0 . \n\nLemma 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 ) .\nProof . 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 . \n\nOpaque rngmultgt0lt0 . \n\nLemma 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 ) .\nProof . 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 . \n\nOpaque rngmultlt0gt0 .\n\nLemma 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 .\nProof . intros . assert ( rx := rngfromlt0 _ is0 isx ) .   assert ( ry := rngfromlt0 _ is0 isy ) . assert ( int := is _ _ rx ry ) . rewrite ( rngmultminusminus X _ _ ) in int .   apply int . Defined . \n\nOpaque rngmultlt0lt0 .\n\nLemma 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 ) . \nProof . 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 . \n\nOpaque isrngmultgttoislrngmultgt .\n\nLemma 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 . \nProof . intros . intros a b ra rb . set ( int := is b 0 a ra rb ) .  clearbody int .  rewrite ( rngmultx0 X _ ) in int .  apply int . Defined . \n\nOpaque islrngmultgttoisrngmultgt . \n\nLemma 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 ) . \nProof . 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 . \n\nOpaque isrngmultgttoisrrngmultgt . \n\nLemma 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 . \nProof . intros . intros a b ra rb . set ( int := is1 _ _ _ rb ra ) .  clearbody int .  rewrite ( rngmult0x X _ ) in int .  apply int . Defined . \n\nOpaque isrrngmultgttoisrngmultgt .\n\n\nLemma isrngmultgtaspartbinophrel ( X : rng ) ( R : hrel X ) ( is0 : @isbinophrel ( rngaddabgr X ) R ) : ( isrngmultgt X R ) <-> ( @ispartbinophrel ( rngmultmonoid X ) ( fun a => R a 0 ) R ) . \nProof . intros . split .  intro ism . split .  apply ( isrngmultgttoislrngmultgt X is0 ism ) .   apply ( isrngmultgttoisrrngmultgt X is0 ism ) . intro isp . apply ( islrngmultgttoisrngmultgt X ( pr1 isp ) ) . Defined .  \n\n\nLemma isrngmultgttoisrigmultgt ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isrngmultgt X R ) : isrigmultgt X R .\nProof . 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 .  \nset ( 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 . \n\nOpaque isrngmultgttoisrigmultgt . \n\nLemma isrigmultgttoisrngmultgt ( X : rng ) { R : hrel X } ( is : isrigmultgt X R ) : isrngmultgt X R .\nProof . 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 . \n\nOpaque isrigmultgttoisrngmultgt .\n\n\n(** **** Relations \"inversely compatible\" with the multiplicative structure on rings *)\n\n\n\nDefinition 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  ) .\n\n\nLemma 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 . \nProof . 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 . \n\nOpaque isinvrngmultgttoislinvrngmultgt .\n\nLemma 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 . \nProof . 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 . \n\nOpaque isinvrngmultgttoisrinvrngmultgt . \n\n\nLemma 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 . \nProof . intros . split . \n\nintros a b rab ra . rewrite ( pathsinv0 ( rngmultx0 X a ) ) in rab . apply ( isl _ _ _ ra rab ) .  \nintros a b rab rb . rewrite ( pathsinv0 ( rngmult0x X b ) ) in rab . apply ( isr _ _ _ rb rab ) .  Defined . \n\nOpaque islrinvrngmultgttoisinvrngmultgt .\n\n\nLemma isinvrngmultgtaspartinvbinophrel ( X : rng ) ( R : hrel X ) ( is0 : @isbinophrel ( rngaddabgr X ) R ) : ( isinvrngmultgt X R ) <-> ( @ispartinvbinophrel ( rngmultmonoid X ) ( fun a => R a 0 ) R ) . \nProof . 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 .   \n\n\nLemma isinvrngmultgttoisinvrigmultgt ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is : isinvrngmultgt X R ) : isinvrigmultgt X R .\nProof . intros .  set ( rer := abmonoidrer ( rngaddabgr X ) ) . simpl in rer .   split .  \n\nintros 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''. \n\nintros 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 . \n\nOpaque isinvrngmultgttoisinvrigmultgt .\n\n\n(** **** Relations on rings and ring homomorphisms *)\n\nLemma 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' ) ) .\nProof . intros . apply ( binophrelandfun ( rngaddfun f ) R isr ) .   Defined . \n\nLemma 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' ) ) .\nProof . 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 .  \n\nLemma 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' ) ) .\nProof . 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 . \nintros a b rab ra . rewrite ax0 in ra . rewrite ax0 in rab . rewrite ax0 . rewrite ( ax1 _ _  ) in rab .  apply ( ( pr1 isr ) _ _ rab ra ) . \n\nintros a b rab rb . rewrite ax0 in rb . rewrite ax0 in rab . rewrite ax0 . rewrite ( ax1 _ _  ) in rab .  apply ( ( pr2 isr ) _ _ rab rb ) . Defined .  \n\n\n\nClose Scope rng_scope . \n \n\n(** **** Subobjects *)\n\nDefinition issubrng { X : rng } ( A : hsubtypes X ) := dirprod ( @issubgr ( rngaddabgr X ) A ) ( @issubmonoid ( rngmultmonoid X ) A ) . \n\nLemma isapropissubrng { X : rng } ( A : hsubtypes X ) : isaprop ( issubrng A ) .\nProof . intros . apply ( isofhleveldirprod 1 ) . apply isapropissubgr . apply isapropissubmonoid . Defined . \n\nDefinition subrngs ( X : rng ) := total2 ( fun  A : hsubtypes X => issubrng A ) .\nDefinition subrngpair { X : rng } := tpair ( fun  A : hsubtypes X => issubrng A ) .\nDefinition pr1subrng ( X : rng ) : @subrngs X -> hsubtypes X := @pr1 _ (fun  A : hsubtypes X => issubrng A ) .\n\nDefinition subrngtosubsetswith2binop ( X : rng ) : subrngs X -> @subsetswith2binop X := fun A : _ => subsetswith2binoppair ( pr1 A ) ( dirprodpair ( pr1 ( pr1 ( pr1 ( pr2 A ) ) ) ) ( pr1 ( pr2 ( pr2 A ) ) ) ) . \nCoercion subrngtosubsetswith2binop : subrngs >-> subsetswith2binop . \n\nDefinition addsubgr { X : rng } : subrngs X -> @subgrs ( rngaddabgr X ) := fun A : _ => @subgrpair ( rngaddabgr X ) ( pr1 A ) ( pr1 ( pr2 A ) ) .\nDefinition multsubmonoid { X : rng } : subrngs X -> @submonoids ( rngmultmonoid X ) := fun A : _ => @submonoidpair ( rngmultmonoid X ) ( pr1 A ) ( pr2 ( pr2 A ) ) .  \n\nLemma isrngcarrier { X : rng } ( A : subrngs X ) : isrngops ( @op1 A ) ( @op2 A ) .\nProof . intros . split with ( dirprodpair ( isabgrcarrier ( addsubgr A ) ) ( ismonoidcarrier ( multsubmonoid A ) ) ) . split .    \n\nintros a b c . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) .  simpl . apply rngldistr .  \nintros a b c . apply ( invmaponpathsincl _ ( isinclpr1carrier A ) ) .  simpl . apply rngrdistr . Defined .   \n\nDefinition carrierofasubrng ( X : rng ) ( A : subrngs X ) : rng .\nProof . intros . split with A . apply isrngcarrier .  Defined . \n\nCoercion carrierofasubrng : subrngs >-> rng .  \n\n\n\n(** **** Quotient objects *)\n\nDefinition rngeqrel { X : rng } := @twobinopeqrel X .\nIdentity Coercion id_rngeqrel : rngeqrel >-> twobinopeqrel .\n\nDefinition rngaddabgreqrel { X : rng } ( R : @rngeqrel X ) : @binopeqrel ( rngaddabgr X ) := @binopeqrelpair ( rngaddabgr X ) ( pr1 R ) ( pr1 ( pr2 R ) ) .     \n\nDefinition rngmultmonoideqrel { X : rng } ( R : @rngeqrel X ) : @binopeqrel ( rngmultmonoid X ) := @binopeqrelpair ( rngmultmonoid X ) ( pr1 R ) ( pr2 ( pr2 R ) ) .\n\nLemma isrngquot { X : rng } ( R : @rngeqrel X ) : isrngops ( @op1 ( setwith2binopquot R ) ) ( @op2 ( setwith2binopquot R ) ) . \nProof . intros . split with ( dirprodpair ( isabgrquot ( rngaddabgreqrel R ) ) ( ismonoidquot ( rngmultmonoideqrel R ) ) ) .  simpl . set ( opp1 := @op1 ( setwith2binopquot R ) ) . set ( opp2 := @op2 ( setwith2binopquot R ) ) .  split .   \n\nunfold 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'' ) ) .  \n\nunfold 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 .\n\nDefinition rngquot { X : rng } ( R : @rngeqrel X ) : rng := @rngpair ( setwith2binopquot R ) ( isrngquot R ) .   \n\n\n\n(** **** Direct products *)\n\nLemma isrngdirprod ( X Y : rng ) : isrngops ( @op1 ( setwith2binopdirprod X Y ) ) ( @op2 ( setwith2binopdirprod X Y ) ) .\nProof . intros . split with ( dirprodpair ( isabgrdirprod ( rngaddabgr X ) ( rngaddabgr Y ) ) ( ismonoiddirprod ( rngmultmonoid X ) ( rngmultmonoid Y ) ) ) . simpl .  split . \n\nintros xy xy' xy'' . unfold setwith2binopdirprod . unfold op1 . unfold op2 .  simpl . apply pathsdirprod .  apply ( rngldistr X ) .  apply ( rngldistr Y ) . \nintros xy xy' xy'' . unfold setwith2binopdirprod . unfold op1 . unfold op2 .  simpl . apply pathsdirprod .  apply ( rngrdistr X ) .  apply ( rngrdistr Y ) .  Defined . \n\n\nDefinition rngdirprod ( X Y : rng ) := @rngpair ( setwith2binopdirprod X Y ) ( isrngdirprod X Y ) . \n\n\n\n\n(** **** Ring of differences associated with a rig *)\n\nOpen Scope rig_scope . \n\nDefinition rigtorngaddabgr ( X : rig ) : abgr := abgrfrac ( rigaddabmonoid X ) . \n\nDefinition rigtorngcarrier ( X : rig ) : hSet := pr1 ( pr1 ( rigtorngaddabgr X ) ) . \n\nDefinition rigtorngop1int ( X : rig ) : binop ( dirprod X X ) := fun x x' => dirprodpair ( ( pr1 x ) + ( pr1 x' ) ) ( ( pr2 x ) + ( pr2 x' ) ) .\n\nDefinition rigtorngop1 ( X : rig ) :  binop ( rigtorngcarrier X ) := @op ( rigtorngaddabgr X ) . \n\nDefinition rigtorngop1axs ( X : rig ) : isabgrop ( rigtorngop1 X ) := pr2 ( rigtorngaddabgr X ) . \n\nDefinition rigtorngunel1 ( X : rig ) : rigtorngcarrier X := unel ( rigtorngaddabgr X ) . \n\nDefinition eqrelrigtorng (  X : rig ) : eqrel ( dirprod X X ) := eqrelabgrfrac ( rigaddabmonoid X ) .\n\nDefinition 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' ) . \n\nDefinition rigtorngunel2int ( X : rig ) : dirprod X X := dirprodpair 1 0 . \n\nLemma rigtorngop2comp ( X : rig ) : iscomprelrelfun2 ( eqrelrigtorng X ) ( eqrelrigtorng X ) ( rigtorngop2int X ) .\nProof . 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 ) ) .  \n\nrewrite ( 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 ) ) . \n\nrewrite ( 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 . \n\nintros 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 ) ) .\n\nrewrite ( 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 ) ) . \n\nrewrite ( 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 .  \n\n\nOpaque rigtorngop2comp .\n\nDefinition rigtorngop2 ( X : rig ) : binop ( rigtorngcarrier X ) := setquotfun2 ( eqrelrigtorng X ) ( eqrelrigtorng X ) ( rigtorngop2int X ) ( rigtorngop2comp X ) . \n\nLemma rigtorngassoc2 ( X : rig ) : isassoc ( rigtorngop2 X ) .\nProof . 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'' ) ) ) ) . \napply ( 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 .  \n\nrewrite ( 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 . \n\nrewrite ( 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 . \n\nOpaque rigtorngassoc2 .\n\nDefinition rigtorngunel2 ( X : rig ) : rigtorngcarrier X := setquotpr ( eqrelrigtorng X ) ( rigtorngunel2int X ) .   \n\nLemma rigtornglunit2 ( X : rig ) : islunit ( rigtorngop2 X ) ( rigtorngunel2 X ) . \nProof . 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 . \n\nrewrite ( lu2 x1 ) . rewrite ( m0x x2 ) . apply ( ru1 x1 ) . \nrewrite ( lu2 x2 ) . rewrite ( m0x x1 ) . apply ( ru1 x2 ) .  Defined . \n\nOpaque rigtornglunit2 .\n\n\nLemma rigtorngrunit2 ( X : rig ) : isrunit ( rigtorngop2 X ) ( rigtorngunel2 X ) . \nProof . 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 . \n\nrewrite ( ru2 x1 ) . rewrite ( mx0 x2 ) . apply ( ru1 x1 ) . \nrewrite ( ru2 x2 ) . rewrite ( mx0 x1 ) . apply ( lu1 x2 ) .  Defined . \n\nOpaque rigtorngrunit2 .\n\nDefinition rigtorngisunit ( X : rig ) : isunit  ( rigtorngop2 X ) ( rigtorngunel2 X ) := dirprodpair ( rigtornglunit2 X ) ( rigtorngrunit2 X ) . \n\nDefinition rigtorngisunital ( X : rig ) : isunital ( rigtorngop2 X ) := tpair _ ( rigtorngunel2 X ) ( rigtorngisunit X ) .  \n\nDefinition rigtorngismonoidop2 ( X : rig ) : ismonoidop ( rigtorngop2 X ) := dirprodpair ( rigtorngassoc2 X ) ( rigtorngisunital X ) . \n\nLemma rigtorngldistr ( X : rig ) : isldistr ( rigtorngop1 X ) ( rigtorngop2 X ) . \nProof . 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 .  \n\nrewrite ( ld _ _ ( pr1 x'' ) ) . rewrite ( ld _ _ ( pr2 x'' ) ) . apply ( rr _ ( pr1 x'' * pr1 x' ) (pr2 x'' * pr2 x ) _ ) . \nrewrite ( ld _ _ ( pr1 x'' ) ) . rewrite ( ld _ _ ( pr2 x'' ) ) . apply ( rr _ (pr1 x'' * pr2 x' ) ( pr2 x'' * pr1 x ) _ ) . Defined . \n\nOpaque rigtorngldistr . \n\n\nLemma rigtorngrdistr ( X : rig ) : isrdistr ( rigtorngop1 X ) ( rigtorngop2 X ) . \nProof . 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 .  \n\nrewrite ( rd _ _ ( pr1 x'' ) ) . rewrite ( rd _ _ ( pr2 x'' ) ) . apply ( rr _ ( pr1 x' * pr1 x'' ) (pr2 x * pr2 x'' ) _ ) . \nrewrite ( rd _ _ ( pr1 x'' ) ) . rewrite ( rd _ _ ( pr2 x'' ) ) . apply ( rr _ (pr1 x' * pr2 x'' ) ( pr2 x * pr1 x'' ) _ ) . Defined . \n\nOpaque rigtorngrdistr . \n\nDefinition rigtorngdistr ( X : rig ) : isdistr  ( rigtorngop1 X ) ( rigtorngop2 X )  := dirprodpair ( rigtorngldistr X ) ( rigtorngrdistr X ) .\n\nDefinition rigtorng ( X : rig ) : rng .\nProof . intro . split with ( @setwith2binoppair ( rigtorngcarrier X ) ( dirprodpair ( rigtorngop1 X ) ( rigtorngop2 X ) ) ) . split . apply ( dirprodpair ( rigtorngop1axs X ) ( rigtorngismonoidop2 X ) ) . apply ( rigtorngdistr X ) .  Defined . \n\n\n(** **** Canonical homomorphism to the ring associated with a rig (ring of differences) *)\n\nDefinition torngdiff ( X : rig ) ( x : X ) : rigtorng X := setquotpr _ ( dirprodpair x 0 ) .\n\nLemma isbinop1funtorngdiff ( X : rig ) : @isbinopfun ( rigaddabmonoid X ) ( rngaddabgr ( rigtorng X ) ) ( torngdiff X ) . \nProof . intros . unfold isbinopfun . intros x x' .  apply ( isbinopfuntoabgrfrac ( rigaddabmonoid X ) x x' ) . Defined . \n\nOpaque isbinop1funtorngdiff .\n\nLemma isunital1funtorngdiff ( X : rig ) : paths ( torngdiff X 0 ) 0%rng .\nProof . intro. apply idpath . Defined .\n\nOpaque isunital1funtorngdiff .  \n\nDefinition isaddmonoidfuntorngdiff ( X : rig ) : @ismonoidfun  ( rigaddabmonoid X ) ( rngaddabgr ( rigtorng X ) ) ( torngdiff X ) := dirprodpair ( isbinop1funtorngdiff X ) ( isunital1funtorngdiff X ) . \n\nLemma isbinop2funtorngdiff  ( X : rig ) : @isbinopfun ( rigmultmonoid X ) ( rngmultmonoid ( rigtorng X ) ) ( torngdiff X ) . \nProof . 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 . \n\nrewrite ( rigmultx0 X _ ) .  rewrite  ( rigrunax1 X _ ) . apply idpath .  \n\nrewrite ( rigmult0x X _ ) . rewrite ( rigmultx0 X _ ) .  rewrite ( rigrunax1 X _ ) . apply idpath . Defined . \n\nLemma isunital2funtorngdiff  ( X : rig ) : paths ( torngdiff X 1 ) 1%rng .\nProof . intro. apply idpath . Defined .\n\nOpaque isunital2funtorngdiff .   \n\nDefinition ismultmonoidfuntorngdiff  ( X : rig ) : @ismonoidfun  ( rigmultmonoid X ) ( rngmultmonoid ( rigtorng X ) ) ( torngdiff X ) := dirprodpair ( isbinop2funtorngdiff X ) ( isunital2funtorngdiff X ) . \n\nDefinition isrigfuntorngdiff ( X : rig ) : @isrigfun X ( rigtorng X ) ( torngdiff X ) := dirprodpair ( isaddmonoidfuntorngdiff X ) ( ismultmonoidfuntorngdiff X ) .\n\nDefinition isincltorngdiff ( X : rig ) ( iscanc : forall x : X , @isrcancelable X ( @op1 X ) x ) : isincl ( torngdiff X ) := isincltoabgrfrac ( rigaddabmonoid X ) iscanc .   \n\n\n(** **** Relations similar to \"greater\" or \"greater or equal\"  on the ring associated with a rig *)\n\nDefinition rigtorngrel ( X : rig ) { R : hrel X } ( is : @isbinophrel ( rigaddabmonoid X ) R ) : hrel ( rigtorng X ) := abgrfracrel ( rigaddabmonoid X ) is .\n\nLemma isrngrigtorngmultgt  ( X : rig ) { R : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) R ) ( is : isrigmultgt X R ) : isrngmultgt ( rigtorng X ) ( rigtorngrel X is0 ) .\nProof . 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 ) .\n\nassert ( 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 ) ) ) .  \n\n\nintros 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 . \n \nOpaque isrngrigtorngmultgt . \n\nDefinition isdecrigtorngrel ( X : rig ) { R : hrel X } ( is : @isbinophrel ( rigaddabmonoid X ) R ) ( is' : @isinvbinophrel ( rigaddabmonoid X ) R )  ( isd : isdecrel R ) : isdecrel ( rigtorngrel X is ) .\nProof . intros . apply ( isdecabgrfracrel ( rigaddabmonoid X ) is is' isd ) . Defined . \n\n\nLemma 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 ) .\nProof . intros .  split .  \n\nassert ( 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 ) ) ) . \n\nintros 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' ) . \n\nassert ( 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 ) ) ) . \n\nintros 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 .\n\nOpaque isinvrngrigtorngmultgt . \n\n\n(** **** Realations and the canonical homomorphism to the ring associated with a rig (ring of differences) *)\n\n\nDefinition iscomptorngdiff ( X : rig ) { L : hrel X } ( is0 : @isbinophrel ( rigaddabmonoid X ) L ) : iscomprelrelfun L ( rigtorngrel X is0 ) ( torngdiff X ) := iscomptoabgrfrac ( rigaddabmonoid X ) is0 . \n\nOpaque iscomptorngdiff . \n\nClose Scope rig_scope . \n\n\n\n\n(** *** Commutative rings *)\n\n(** **** General definitions *)\n\nDefinition iscommrng ( X : setwith2binop ) := iscommrngops ( @op1 X ) ( @op2 X ) .\n\nDefinition commrng := total2 ( fun X : setwith2binop => iscommrngops ( @op1 X ) ( @op2 X ) ) .\nDefinition commrngpair ( X : setwith2binop ) ( is : iscommrngops ( @op1 X ) ( @op2 X ) ) := tpair ( fun X : setwith2binop => iscommrngops ( @op1 X ) ( @op2 X ) ) X is .\n\nDefinition 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 ) . \n\nDefinition commrngtorng : commrng -> rng := fun X : _ => @rngpair ( pr1 X ) ( pr1 ( pr2 X ) ) . \nCoercion commrngtorng : commrng >-> rng .\n\nDefinition rngcomm2 ( X : commrng ) : iscomm ( @op2 X ) := pr2 ( pr2 X ) . \nDefinition commrngop2axs ( X : commrng ) : isabmonoidop ( @op2 X ) := tpair _ ( rngop2axs X ) ( rngcomm2 X ) . \n\n\nDefinition rngmultabmonoid ( X : commrng ) : abmonoid := abmonoidpair ( setwithbinoppair X op2 ) ( dirprodpair ( rngop2axs X ) ( rngcomm2 X ) ) . \n\nDefinition commrngtocommrig ( X : commrng ) : commrig := commrigpair _ ( pr2 X ) .\nCoercion commrngtocommrig : commrng >-> commrig . \n\n(** **** Computational lemmas for commutative rings *)\n\nOpen Scope rng_scope.\n\nLemma commrngismultcancelableif ( X : commrng ) ( x : X ) ( isl : forall y , paths ( x * y ) 0 -> paths y 0 ) : iscancelable op2 x .\nProof . 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 .  \n\nOpaque commrngismultcancelableif .\n\n\nClose Scope rng_scope. \n\n\n(** **** Subobjects *)\n\nLemma iscommrngcarrier { X : commrng } ( A : @subrngs X ) : iscommrngops ( @op1 A ) ( @op2 A ) .\nProof . intros . split with ( isrngcarrier A ) . apply ( pr2 ( @isabmonoidcarrier ( rngmultabmonoid X ) ( multsubmonoid A ) ) ) .  Defined . \n\nDefinition carrierofasubcommrng { X : commrng } ( A : @subrngs X ) : commrng := commrngpair A ( iscommrngcarrier A ) . \n\n\n(** **** Quotient objects *)\n\nLemma iscommrngquot { X : commrng } ( R : @rngeqrel X ) : iscommrngops ( @op1 ( setwith2binopquot R ) ) ( @op2 ( setwith2binopquot R ) ) . \nProof . intros . split with ( isrngquot R ) . apply ( pr2 ( @isabmonoidquot  ( rngmultabmonoid X ) ( rngmultmonoideqrel R ) ) ) .  Defined . \n\nDefinition commrngquot { X : commrng } ( R : @rngeqrel X ) : commrng := commrngpair ( setwith2binopquot R ) ( iscommrngquot R ) . \n\n\n\n\n(** **** Direct products *)\n\nLemma iscommrngdirprod ( X Y : commrng ) : iscommrngops ( @op1 ( setwith2binopdirprod X Y ) ) ( @op2 ( setwith2binopdirprod X Y ) ) .\nProof . intros . split with ( isrngdirprod X Y ) . apply ( pr2 ( isabmonoiddirprod ( rngmultabmonoid X ) ( rngmultabmonoid Y ) ) ) . Defined . \n\nDefinition commrngdirprod ( X Y : commrng ) := commrngpair ( setwith2binopdirprod X Y ) ( iscommrngdirprod X Y ) . \n\n\n(** **** Commutative rigs to commuttaive rings *)\n\nOpen Scope rig_scope . \n\nLemma commrigtocommrngcomm2 ( X : commrig ) : iscomm ( rigtorngop2 X ) .\nProof . 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 ) ) ) . \napply ( maponpaths ( setquotpr ( eqrelrigtorng X ) ) ) . unfold rigtorngop2int . set ( cm1 := rigcomm1 X ) . set ( cm2 := rigcomm2 X ) .  apply pathsdirprod .  \n\nrewrite ( cm2 ( pr1 x ) ( pr1 x' ) ) . rewrite ( cm2 ( pr2 x ) ( pr2 x' ) ) .   apply idpath . \nrewrite ( cm2 ( pr1 x ) ( pr2 x' ) ) . rewrite ( cm2 ( pr2 x ) ( pr1 x' ) ) .  apply cm1 . Defined . \n\nOpaque commrigtocommrngcomm2 . \n\nDefinition commrigtocommrng ( X : commrig ) : commrng .\nProof . intro . split with ( rigtorng X ) . split .   apply ( pr2 ( rigtorng X ) ) . apply ( commrigtocommrngcomm2 X ) .  Defined . \n\nClose Scope rig_scope . \n\n\n   \n\n(** **** Rings of fractions *)\n\nOpen Scope rng_scope . \n\nDefinition 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 ) )  .\n\nDefinition commrngfracop2int (  X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : binop ( dirprod X S ) := abmonoidfracopint ( rngmultabmonoid X ) S . \n\nDefinition commrngfracunel1int ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : dirprod X S := dirprodpair 0 ( unel S ) .\n\nDefinition commrngfracunel2int ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : dirprod X S := dirprodpair 1 ( unel S ) . \n\nDefinition commrngfracinv1int  ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : dirprod X S -> dirprod X S := fun xs : _ => dirprodpair ( ( -1 ) * ( pr1 xs ) ) ( pr2 xs ) .\n\nDefinition eqrelcommrngfrac (  X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : eqrel ( dirprod X S ) := eqrelabmonoidfrac ( rngmultabmonoid X ) S . \n\nLemma 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 ) ) .\nProof . intros . set ( rdistr := rngrdistr X ) . set ( assoc2 := rngassoc2 X ) . set ( op2axs := commrngop2axs X ) . set ( comm2 := rngcomm2 X ) . set ( rer := abmonoidoprer op2axs ) . \n\nrewrite ( 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 .  \n\nassert ( 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 .  \n\nassert ( 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 .  \n\ndestruct e1 . destruct e2 . apply idpath . Defined .  \n\nOpaque commrngfracl1 .  \n\nLemma commrngfracop1comp ( X : commrng ) ( S :  @subabmonoids ( rngmultabmonoid X ) ) : iscomprelrelfun2 ( eqrelcommrngfrac X S ) ( eqrelcommrngfrac X S )  ( commrngfracop1int X S ) .\nProof . 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 . \napply ( 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 . \n\nOpaque commrngfracop1comp .\n\nDefinition 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 ) .\n\nLemma 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'' ) ) ) ) .\nProof. 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 .\n\nOpaque commrngfracl2 .\n\n\nLemma commrngfracassoc1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isassoc ( commrngfracop1 X S ) .\nProof . intros . set ( R := eqrelcommrngfrac X S ) . set ( add1int := commrngfracop1int X S ) . set ( add1 := commrngfracop1 X S ) .  unfold isassoc . \nassert ( 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'')) ) . \n\napply ( setquotuniv3prop R ( fun x x' x'' : setquotinset R => @eqset ( setquotinset R ) ( add1 ( add1 x x' ) x'') ( add1 x ( add1 x' x'') ) ) int ) . Defined .   \n  \nOpaque commrngfracassoc1 .\n\nLemma commrngfraccomm1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : iscomm ( commrngfracop1 X S ) .\nProof . 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 .  \n\nchange ( paths ( ( s' * x) + ( s * x' ) ) ( ( s * x' ) + ( s' * x ) ) ) . destruct ( rngcomm1 X ( s' * x ) ( s * x' ) ) . apply idpath . \n\napply ( invmaponpathsincl _ ( isinclpr1carrier ( pr1 S ) ) ) .  simpl .  change (  paths ( s * s' ) ( s' * s ) ) . apply ( rngcomm2 X ) . Defined . \n\nOpaque commrngfraccomm1 .\n\n\nDefinition commrngfracunel1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) := setquotpr  ( eqrelcommrngfrac X S ) ( commrngfracunel1int X S ) .\n\nDefinition commrngfracunel2 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) := setquotpr  ( eqrelcommrngfrac X S ) ( commrngfracunel2int X S ) . \n\nLemma commrngfracinv1comp ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : iscomprelrelfun ( eqrelcommrngfrac X S ) ( eqrelcommrngfrac X S ) ( commrngfracinv1int X S ) .\nProof . 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 .   \n\nDefinition commrngfracinv1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) := setquotfun ( eqrelcommrngfrac X S ) ( eqrelcommrngfrac X S ) ( commrngfracinv1int X S ) ( commrngfracinv1comp X S ) . \n\nLemma commrngfracisinv1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isinv ( commrngfracop1 X S ) ( commrngfracunel1 X S ) ( commrngfracinv1 X S ) .\nProof . intros .  \n\nassert ( 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 ) ) .\n\napply ( dirprodpair isl ( weqlinvrinv ( commrngfracop1 X S ) ( commrngfraccomm1 X S ) ( commrngfracunel1 X S ) ( commrngfracinv1 X S ) isl ) ) .  Defined .  \n\nOpaque commrngfracisinv1 . \n\n\nLemma commrngfraclunit1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : islunit ( commrngfracop1 X S ) ( commrngfracunel1 X S ) .\nProof . intros .  set ( R := eqrelcommrngfrac X S ) . set ( add1int := commrngfracop1int X S ) . set ( add1 := commrngfracop1 X S ) . set ( un1 := commrngfracunel1 X S ). \nunfold islunit .  apply ( setquotunivprop R ( fun x : _ => @eqset ( setquotinset R ) (add1 un1 x) x ) ) .  intro xs . \nassert ( 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 .\n\nOpaque commrngfraclunit1 .\n\nLemma commrngfracrunit1 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isrunit ( commrngfracop1 X S ) ( commrngfracunel1 X S ) .\nProof . intros . apply ( weqlunitrunit (commrngfracop1 X S) ( commrngfraccomm1 X S ) (commrngfracunel1 X S) ( commrngfraclunit1 X S ) ) .  Defined .  \n\nOpaque commrngfracrunit1 .\n\nDefinition 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 ) ) ) . \n\n\nDefinition commrngfracop2 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : binop ( setquotinset ( eqrelcommrngfrac X S ) ) := abmonoidfracop ( rngmultabmonoid X ) S .\n\nLemma commrngfraccomm2 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : iscomm ( commrngfracop2 X S ) .\nProof . intros . apply ( commax ( abmonoidfrac ( rngmultabmonoid X ) S ) ) . Defined .   \n\nOpaque commrngfraccomm2 .\n\n\nLemma commrngfracldistr  ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isldistr ( commrngfracop1 X S ) ( commrngfracop2 X S ) .\nProof . 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' ) ) ) . \n\ndestruct 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 ) . \ndestruct s as [ s iss ] .  destruct s' as [ s' iss' ] . simpl . \n\nchange ( paths ( ( ( x'' * ( ( s' * x ) + ( s * x' ) ) ) * ( ( s'' * s ) * ( s'' * s' ) ) ) * 1 ) ( ( ( ( ( s'' * s') * ( x'' * x ) ) + ( ( s'' * s ) * ( x'' * x' ) ) ) * ( s'' * ( s * s' ) ) ) * 1 ) ) . \n\nrewrite ( 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 ) ) . \n\nassert ( 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 . \n\nassert ( 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 .\n\nrewrite e1 .  rewrite e2 . apply idpath . Defined .  \n\nOpaque commrngfracldistr .\n\n\nLemma commrngfracrdistr  ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : isrdistr ( commrngfracop1 X S ) ( commrngfracop2 X S ) .\nProof . intros . apply ( weqldistrrdistr (commrngfracop1 X S) ( commrngfracop2 X S ) ( commrngfraccomm2 X S ) ( commrngfracldistr X S ) ) .  Defined .  \n\n\n  \n\n(** Notes : \n\n1. 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 . \n\n2. 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 . \n\n*) \n\nDefinition commrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : commrng .   \nProof .  intros .  set ( R := eqrelcommrngfrac  X S ) . set ( mult1 := commrngfracop2 X S ) . set ( add1 := commrngfracop1 X S ) . set ( uset := setquotinset R ) . apply ( commrngconstr add1 mult1 ) . \nsplit 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 . \n\nDefinition prcommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : X -> S -> commrngfrac X S := fun x s => setquotpr _ ( dirprodpair x s ) .\n\nLemma invertibilityincommrngfrac  ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : forall a a' : S , isinvertible ( @op2 ( commrngfrac X S ) ) ( prcommrngfrac X S ( pr1 a ) a' ) .  \nProof . intros . apply ( invertibilityinabmonoidfrac ( rngmultabmonoid X ) S ) . Defined . \n\n\n\n(** **** Canonical homomorphism to the ring of fractions *)\n\nDefinition tocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) ( x : X ) : commrngfrac X S := setquotpr _ ( dirprodpair x ( unel S ) ) .\n\nLemma isbinop1funtocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @isbinopfun ( rngaddabgr X ) ( rngaddabgr ( commrngfrac X S ) ) ( tocommrngfrac X S ) .\nProof . 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 .  \n\nrewrite ( rnglunax2 X _ ) . rewrite ( rnglunax2 X _ ) .  apply idpath . \n\nchange ( paths ( unel S ) ( op ( unel S ) ( unel S ) ) ) . apply ( pathsinv0 ( runax S _ ) ) . Defined . \n\nOpaque isbinop1funtocommrngfrac .\n\nLemma isunital1funtocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : paths ( tocommrngfrac X S 0 ) 0 .\nProof . intros. apply idpath . Defined .\n\nOpaque isunital1funtocommrngfrac .  \n\nDefinition isaddmonoidfuntocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @ismonoidfun  ( rngaddabgr X ) ( rngaddabgr ( commrngfrac X S ) ) ( tocommrngfrac X S ) := dirprodpair ( isbinop1funtocommrngfrac X S ) ( isunital1funtocommrngfrac X S ) . \n\nDefinition tocommrngfracandminus0 ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) ( x : X ) : paths ( tocommrngfrac X S ( - x ) ) ( - tocommrngfrac X S x ) := grinvandmonoidfun _ _ ( isaddmonoidfuntocommrngfrac X S ) x .\n\nDefinition tocommrngfracandminus ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) ( x y : X ) : paths ( tocommrngfrac X S ( x - y ) ) ( tocommrngfrac X S x - tocommrngfrac X S y ) .\nProof . 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 .   \n\nOpaque tocommrngfracandminus .\n\nDefinition isbinop2funtocommrngfrac  ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @isbinopfun ( rngmultmonoid X ) ( rngmultmonoid ( commrngfrac X S ) ) ( tocommrngfrac X S ) := isbinopfuntoabmonoidfrac ( rngmultabmonoid X ) S . \n\nOpaque isbinop2funtocommrngfrac .\n\nLemma isunital2funtocommrngfrac  ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : paths ( tocommrngfrac X S 1 ) 1 .\nProof . intros. apply idpath . Defined .\n\nOpaque isunital2funtocommrngfrac .   \n\nDefinition ismultmonoidfuntocommrngfrac  ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @ismonoidfun  ( rngmultmonoid X ) ( rngmultmonoid ( commrngfrac X S ) ) ( tocommrngfrac X S ) := dirprodpair ( isbinop2funtocommrngfrac X S ) ( isunital2funtocommrngfrac X S ) . \n \nDefinition isrngfuntocommrngfrac ( X : commrng ) ( S : @subabmonoids ( rngmultabmonoid X ) ) : @isrngfun X ( commrngfrac X S ) ( tocommrngfrac X S ) := dirprodpair ( isaddmonoidfuntocommrngfrac X S ) ( ismultmonoidfuntocommrngfrac X S ) .\n\n\n\n\n(** **** Ring of fractions in the case when all elements which are being inverted are cancelable *) \n\nDefinition  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 ) ) ) .\n\nLemma 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' ) .\nProof . intros .  unfold eqrelabmonoidfrac .  unfold hrelabmonoidfrac . simpl .  apply weqimplimpl .  \n\napply ( @hinhuniv _ ( eqset (pr1 xa * pr1 (pr2 xa')) (pr1 xa' * pr1 (pr2 xa)) ) ) .  intro ae .  destruct ae as [ a eq ] .  apply ( invmaponpathsincl _ ( iscanc a ) _ _ eq ) . \nintro eq . apply hinhpr . split with ( unel S ) . rewrite ( rngrunax2 X )  .  rewrite ( rngrunax2 X ) .  apply eq . apply ( isapropishinh _ ) .  apply ( setproperty X ) .   Defined .\n\nOpaque weqhrelhrel0abmonoidfrac .\n\n\nLemma 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' ) .\nProof . 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 . \n\nDefinition 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 ) . \n\nLemma isdeceqcommrngfrac ( X : commrng ) ( S : @submonoids ( rngmultabmonoid  X ) ) ( iscanc : forall a : S , isrcancelable ( @op2 X ) ( pr1carrier _ a ) ) ( is : isdeceq X ) : isdeceq ( commrngfrac X S ) .\nProof . 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 . \n\n\n\n(** **** Relations similar to \"greater\" or \"greater or equal\"  on the rings of fractions *)\n\n\n\nLemma 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 .  \nProof . intros . split . \n\nintros a b c s rab . apply ( isrngmultgttoislrngmultgt X is0 is1 _ _ _ ( is2 c s ) rab ) . \nintros a b c s rab . apply ( isrngmultgttoisrrngmultgt X is0 is1 _ _ _ ( is2 c s ) rab ) .  Defined .    \n\nDefinition 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 ) .\n\nLemma 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 ) . \nProof . intros . set ( rer2 := ( abmonoidrer ( rngmultabmonoid X )) : forall a b c d : X , paths ( ( a * b ) * ( c * d ) ) ( ( a * c ) * ( b * d ) ) ) . apply islrngmultgttoisrngmultgt . \n\nassert ( 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 ) . \n\nsimpl 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 . \n\nOpaque isrngmultcommrngfracgt .\n\nLemma 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 ) . \nProof .  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 ) . \n\nassert ( 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 . \n\nOpaque isrngaddcommrngfracgt .\n\n\nDefinition 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 ) .\nProof . intros . apply ( isdecabmonoidfracrel ( rngmultabmonoid X ) S ( ispartbinopcommrngfracgt X S is0 is1 is2 ) is' isd ) . Defined .   \n\n\n\n(** **** Realations and the canonical homomorphism to the ring of fractions *)\n\n\nDefinition 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 ) . \n\nOpaque iscomptocommrngfrac . \n \n\n\n\nClose Scope rng_scope . \n\n\n\n\n\n\n\n\n\n\n\n\n\n(* End of the file algebra1c.v *)\n"
  },
  {
    "path": "hlevel2/algebra1d.v",
    "content": "(** * Algebra I. Part D.  Integral domains and fileds. Vladimir Voevodsky. Aug. 2011 - . \n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)\n\n\n(** Imports *)\n\nAdd LoadPath \"../..\" .\n\nRequire Export Foundations.hlevel2.algebra1c .\n\n\n(** To upstream files *)\n\n\n(** To one binary operation *)\n\nLemma 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 . \nProof . intros . apply isinclbetweensets . apply ( setproperty X ) . apply ( setproperty X ) . apply is .  Defined . \n\nLemma 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 . \nProof . intros . apply isinclbetweensets . apply ( setproperty X ) . apply ( setproperty X ) . apply is .  Defined . \n\nDefinition 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 ) . \n\n\n(** To monoids *)\n\nOpen Local Scope  multmonoid_scope. \n\nDefinition linvpair ( X : monoid ) ( x : X ) := total2 ( fun x' : X => paths ( x' * x ) 1 ) .\nDefinition pr1linvpair ( X : monoid ) ( x : X ) : linvpair X x -> X := @pr1 _ _ .\n\nDefinition linvpairxy ( X : monoid ) ( x y : X ) ( x' : linvpair X x ) ( y' : linvpair X y ) : linvpair X ( x * y ) .\nProof . 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 .   \n\nDefinition lcanfromlinv ( X : monoid ) ( a b c : X ) ( c' : linvpair X c ) ( e : paths ( c * a ) ( c * b ) ) : paths a b .\nProof . 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.\n\n\nDefinition rinvpair ( X : monoid ) ( x : X ) := total2 ( fun x' : X => paths ( x * x' ) 1 ) .\nDefinition pr1rinvpair ( X : monoid ) ( x : X ) : rinvpair X x -> X := @pr1 _ _ .\n\nDefinition rinvpairxy ( X : monoid ) ( x y : X ) ( x' : rinvpair X x ) ( y' : rinvpair X y ) : rinvpair X ( x * y ) .\nProof . 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 . \n\nDefinition rcanfromrinv ( X : monoid ) ( a b c : X ) ( c' : rinvpair X c ) ( e : paths ( a * c  ) ( b * c ) ) : paths a b .\nProof . 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.\n\nLemma pathslinvtorinv ( X : monoid ) ( x : X ) ( x' : linvpair X x ) ( x'' : rinvpair X x ) : paths ( pr1 x' ) ( pr1 x'' ) .\nProof . 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 . \n\nDefinition invpair ( X : monoid ) ( x : X ) := total2 ( fun x' : X => dirprod ( paths ( x' * x ) 1 ) ( paths ( x * x' ) 1 ) ) .\nDefinition pr1invpair ( X : monoid ) ( x : X ) : invpair X x -> X := @pr1 _ _ .\nDefinition invtolinv ( X : monoid ) ( x : X ) ( x' : invpair X x ) : linvpair X x := tpair _ ( pr1 x' ) ( pr1 ( pr2 x' ) ) .\nDefinition invtorinv ( X : monoid ) ( x : X ) ( x' : invpair X x ) : rinvpair X x := tpair _ ( pr1 x' ) ( pr2 ( pr2 x' ) ) . \n\nLemma isapropinvpair ( X : monoid ) ( x : X ) : isaprop ( invpair X x ) .\nProof . 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. \n\nDefinition invpairxy ( X : monoid ) ( x y : X ) ( x' : invpair X x ) ( y' : invpair X y ) : invpair X ( x * y ) .\nProof . 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 . \n\n\n(** To groups *)\n\nLemma grfrompathsxy ( X : gr ) { a b : X } ( e : paths a b ) : paths ( op a ( grinv X b ) ) ( unel X ) .\nProof . intros .   assert  ( e' := maponpaths ( fun x : X => op x  ( grinv X b ) ) e ) . simpl in e' .  rewrite ( grrinvax X _ ) in e' .  apply e' . Defined .\n\nLemma grtopathsxy ( X : gr ) { a b : X } ( e : paths ( op a ( grinv X b ) ) ( unel X )  ) : paths a b  .\nProof . 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 .    \n\n\n\n(** To rigs *)\n\nDefinition multlinvpair ( X : rig ) ( x : X ) := linvpair ( rigmultmonoid X ) x .\n\nDefinition multrinvpair ( X : rig ) ( x : X ) := rinvpair ( rigmultmonoid X ) x .\n \nDefinition multinvpair ( X : rig ) ( x : X ) := invpair ( rigmultmonoid X ) x .\n\nDefinition rigneq0andmultlinv ( X : rig ) ( n m : X ) ( isnm : neg ( paths ( n * m ) 0 )%rig ) : neg ( paths n 0 )%rig .\nProof . intros . intro e .  rewrite e in isnm .  rewrite ( rigmult0x X ) in isnm .  destruct ( isnm ( idpath _ ) ) .  Defined . \n\nDefinition rigneq0andmultrinv ( X : rig ) ( n m : X ) ( isnm : neg ( paths ( n * m ) 0 )%rig ) : neg ( paths m 0 )%rig .\nProof . intros . intro e .  rewrite e in isnm .  rewrite ( rigmultx0 _ ) in isnm .  destruct ( isnm ( idpath _ ) ) .  Defined . \n\n\n\n(** To rings *)\n\nLocal Open Scope rng_scope.\n\nDefinition rngneq0andmultlinv ( X : rng ) ( n m : X ) ( isnm : neg ( paths ( n * m ) 0 ) ) : neg ( paths n 0 ) .\nProof . intros . intro e .  rewrite e in isnm .  rewrite ( rngmult0x X ) in isnm .  destruct ( isnm ( idpath _ ) ) .  Defined . \n\nDefinition rngneq0andmultrinv ( X : rng ) ( n m : X ) ( isnm : neg ( paths ( n * m ) 0 ) ) : neg ( paths m 0 ) .\nProof . intros . intro e .  rewrite e in isnm .  rewrite ( rngmultx0 _ ) in isnm .  destruct ( isnm ( idpath _ ) ) .  Defined . \n\n\nDefinition rngpossubmonoid ( X : rng ) { R : hrel X } ( is1 : isrngmultgt X R ) ( is2 : R 1 0 ) : @submonoids ( rngmultmonoid X ) .\nProof . intros . split with ( fun x => R x 0 ) . split .  intros x1 x2 . apply is1 . apply ( pr2 x1 ) .  apply ( pr2 x2 ) .  apply is2 . Defined . \n\nLemma isinvrngmultgtif ( X : rng ) { R : hrel X } ( is0 : @isbinophrel ( rngaddabgr X ) R ) ( is1 : isrngmultgt X R ) ( nc : neqchoice R ) ( isa : isasymm R ) : isinvrngmultgt X R .  \nProof . intros . split . \n\nintros 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' ) .  \n\nintros 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 .\n\n\n\n\n(** ** Standard Algebraic Structures (cont.) Integral domains and Fileds. \n\nSome 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.   *)\n\nLocal Open Scope rng_scope.\n\n\n(** *** Integral domains *)\n\n(** **** General definitions *)\n\nDefinition isnonzerorng ( X : rng ) := neg ( @paths X 1 0 ) .\n\nLemma isnonzerolinvel ( X : rng ) ( is : isnonzerorng X ) ( x : X ) ( x' : multlinvpair X x ) : neg ( paths ( pr1 x' ) 0 ) .\nProof . 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 .     \n\nLemma isnonzerorinvel ( X : rng ) ( is : isnonzerorng X ) ( x : X ) ( x' : multrinvpair X x ) : neg ( paths ( pr1 x' ) 0 ) .\nProof . 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 .  \n\nLemma isnonzerofromlinvel ( X : rng ) ( is : isnonzerorng X ) ( x : X ) ( x' : multlinvpair X x ) : neg ( paths x 0 ) .\nProof .  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 .\n\nLemma isnonzerofromrinvel ( X : rng ) ( is : isnonzerorng X ) ( x : X ) ( x' : multrinvpair X x ) : neg ( paths x 0 ) .\nProof .  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 .\n \nDefinition isintdom ( X : commrng ) := dirprod ( isnonzerorng X ) ( forall a1 a2 : X , paths ( a1 * a2 ) 0 -> hdisj ( eqset a1 0 ) ( eqset a2 0 ) ) .  \n\nDefinition intdom := total2 ( fun X : commrng => isintdom X ) .\nDefinition pr1intdom : intdom -> commrng := @pr1 _ _ .\nCoercion pr1intdom : intdom >-> commrng .\n\nDefinition nonzeroax ( X : intdom ) : neg ( @paths X 1 0 ) := pr1 ( pr2 X ) .   \nDefinition intdomax ( X : intdom ) : forall a1 a2 : X , paths ( a1 * a2 ) 0 -> hdisj ( eqset a1 0 ) ( eqset a2 0 )  := pr2 ( pr2 X ) . \n\n(** **** Computational lemmas for integral domains *)\n\nLemma intdomax2l ( X : intdom ) ( x y : X ) ( is : paths ( x * y ) 0 ) ( ne : neg ( paths x 0 ) ) : paths y 0 .\nProof . 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 .  \n\nLemma intdomax2r ( X : intdom ) ( x y : X ) ( is : paths ( x * y ) 0 ) ( ne : neg ( paths y 0 ) ) : paths x 0 .\nProof . 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 .  \n\n\nDefinition intdomneq0andmult ( X : intdom ) ( n m : X ) ( isn : neg ( paths n 0 ) ) ( ism : neg ( paths m 0 ) ) : neg ( paths ( n * m ) 0 ) .\nProof . intros . intro e . destruct ( ism ( intdomax2l X n m e isn  ) ) .  Defined . \n\n\n\n\n\n\nLemma intdomlcan ( X : intdom ) : forall a b c : X , neg ( paths c 0 ) -> paths ( c * a ) ( c * b ) -> paths a b .\nProof . 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 . \n\nOpaque intdomlcan .\n\nLemma intdomrcan ( X : intdom ) : forall a b c : X , neg ( paths c 0 ) -> paths ( a * c ) ( b * c ) -> paths a b .\nProof . 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 . \n\nOpaque intdomrcan .\n\n\nLemma intdomiscancelable ( X : intdom ) ( x : X ) ( is : neg ( paths x 0 ) ) : iscancelable ( @op2 X ) x . \nProof . intros . apply iscancelableif .  intros a b . apply ( intdomlcan X a b x is ) .  intros a b . apply ( intdomrcan X a b x is ) . Defined .  \n\n\n\n(** **** Multiplicative submonoid of non-zero elements *)\n\n\nDefinition intdomnonzerosubmonoid ( X : intdom ) : @subabmonoids ( rngmultabmonoid X ) .  \nProof . intros . split with ( fun x : X => hProppair _ ( isapropneg ( paths x 0 ) ) ) . split . \n\nintros 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 ) ) . \n\nsimpl .  apply ( nonzeroax X ) . Defined .\n\n\n\n\n(** **** Relations similar to \"greater\" on integral domains *)\n\n\nDefinition 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 .\nProof . 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 .\n\n\n\n\n\n(** *** Ring units ( i.e. multilicatively invertible elements ) *)\n\n\n\n\n\n\n\n(** *** Fields *)\n\n(** **** Main definitions *)\n\nDefinition isafield ( X : commrng ) := dirprod ( isnonzerorng X ) ( forall x : X , coprod ( multinvpair X x ) ( paths x 0 ) ) . \n\nDefinition fld := total2 ( fun X : commrng => isafield X ) .  \nDefinition fldpair ( X : commrng ) ( is : isafield X ) : fld := tpair _ X is . \nDefinition pr1fld : fld -> commrng := @pr1 _ _ .\n\nDefinition fldtointdom ( X : fld ) : intdom .\nProof . intro . split with ( pr1 X ) .  split with ( pr1 ( pr2 X ) ) . intros a1 a2 . destruct ( pr2 ( pr2 X ) a1 ) as [ a1' | e0 ] . \n\nintro e12 . rewrite ( pathsinv0 ( rngmultx0 ( pr1 X ) a1 ) ) in e12 . set ( e2 := lcanfromlinv _ _ _ _ ( invtolinv _ _ a1' ) e12 ) .  apply ( hinhpr _ ( ii2 e2 ) ) .      \n\nintro e12 . apply ( hinhpr _ ( ii1 e0 ) ) . Defined .  \n\nCoercion fldtointdom : fld >-> intdom . \n\nDefinition fldchoice { X : fld } ( x : X ) : coprod ( multinvpair X x ) ( paths x 0 ) := pr2 ( pr2 X ) x.\n\nDefinition fldmultinvpair ( X : fld ) ( x : X ) ( ne : neg ( paths x 0 ) ) : multinvpair X x .\nProof . intros . destruct ( fldchoice x ) as [ ne0 | e0 ] . apply ne0 . destruct ( ne e0 ) . Defined . \n\nDefinition fldmultinv { X : fld } ( x : X ) ( ne : neg ( paths x 0 ) ) : X := pr1 ( fldmultinvpair X x ne ) .  \n\n\n(** **** Field of fractions of an integral domain with decidable equality *)\n\nDefinition fldfracmultinvint ( X : intdom ) ( is : isdeceq X ) ( xa : dirprod X ( intdomnonzerosubmonoid X ) ) : dirprod X ( intdomnonzerosubmonoid X ) .\nProof .  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 . \n\n(** 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 *)\n\nLemma fldfracmultinvintcomp  ( X : intdom ) ( is : isdeceq X ) : iscomprelrelfun ( eqrelcommrngfrac X ( intdomnonzerosubmonoid X ) ) ( eqrelcommrngfrac X ( intdomnonzerosubmonoid X ) ) ( fldfracmultinvint X is ) .\nProof . 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 ] . \n\nsimpl .  split with ( tpair ( fun x => neg ( paths x 0 ) ) 1 ( nonzeroax X ) ) . apply idpath . \n\nsimpl . 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 ] .\n\nsimpl . 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'' ) .  \n\nsimpl .  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 . \n\nOpaque fldfracmultinvintcomp .\n\n \nDefinition fldfracmultinv0 ( X : intdom ) ( is : isdeceq X ) ( x : commrngfrac X ( intdomnonzerosubmonoid X ) ) : commrngfrac X ( intdomnonzerosubmonoid X ) := setquotfun _ _ _ ( fldfracmultinvintcomp X is ) x . \n\n\nLemma 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 ) . \nProof . 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 . \n\nOpaque nonzeroincommrngfrac .\n\nLemma 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 . \nProof . 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 .    \n\nOpaque zeroincommrngfrac . \n\n\nLemma isdeceqfldfrac  ( X : intdom ) ( is : isdeceq X ) : isdeceq ( commrngfrac X ( intdomnonzerosubmonoid X ) ) . \nProof . intros . apply isdeceqcommrngfrac .  intro a . apply isrcancelableif . intros b0 b1 e . apply ( intdomrcan X _ _ ( pr1 a ) ( pr2 a ) e ) .  apply is . Defined . \n\nLemma islinvinfldfrac ( X : intdom ) ( is : isdeceq X ) ( x : commrngfrac X ( intdomnonzerosubmonoid X ) ) ( ne : neg ( paths x 0 ) ) : paths ( ( fldfracmultinv0 X is x ) * x ) 1 .\nProof . 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' ] .\n\ndestruct ( nonzeroincommrngfrac X ( intdomnonzerosubmonoid X ) xa ne e0 ) .\n\napply 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 .  \n\nOpaque islinvinfldfrac . \n\nLemma isrinvinfldfrac ( X : intdom ) ( is : isdeceq X ) ( x : commrngfrac X ( intdomnonzerosubmonoid X ) ) ( ne : neg ( paths x 0 ) ) : paths ( x * ( fldfracmultinv0 X is x ) ) 1 .\nProof . intros. rewrite ( rngcomm2 _ _ _ ) . apply islinvinfldfrac . apply ne . Defined .   \n\n\nDefinition fldfrac ( X : intdom ) ( is : isdeceq X ) : fld .\nProof . intros . split with ( commrngfrac X ( intdomnonzerosubmonoid X ) ) . split .    \n\nintro e . assert ( e' := zeroincommrngfrac X ( intdomnonzerosubmonoid X ) ( fun a : ( intdomnonzerosubmonoid X ) => pr2 a ) 1 ( unel ( intdomnonzerosubmonoid X ) ) e ) . apply ( nonzeroax X e' ) . \n\nintro x .  destruct ( isdeceqfldfrac X is x 0 ) as [ e | ne ] .\n\napply ( ii2 e ) .\n\napply ii1 . split with ( fldfracmultinv0 X is x ) . split . apply ( islinvinfldfrac X is x ne )  .   apply ( isrinvinfldfrac X is x ne ) .  Defined .\n\n\n\n(** **** Canonical homomorphism to the field of fractions *)\n\nDefinition tofldfrac ( X : intdom ) ( is : isdeceq X ) ( x : X ) : fldfrac X is := setquotpr _ ( dirprodpair x ( tpair ( fun x => neg ( paths x 0 ) ) 1 ( nonzeroax X ) ) ) .\n\nDefinition isbinop1funtofldfrac ( X : intdom ) ( is : isdeceq X ) : @isbinopfun ( rngaddabgr X ) ( rngaddabgr ( fldfrac X is ) ) ( tofldfrac X is ) :=  isbinop1funtocommrngfrac X _ .   \n\nLemma isunital1funtofldfrac ( X : intdom ) ( is : isdeceq X ) : paths ( tofldfrac X is 0 ) 0 .\nProof . intros. apply idpath . Defined .\n\nDefinition isaddmonoidfuntofldfrac ( X : intdom ) ( is : isdeceq X ) : @ismonoidfun  ( rngaddabgr X ) ( rngaddabgr ( fldfrac X is ) ) ( tofldfrac X is ) := dirprodpair ( isbinop1funtofldfrac X is ) ( isunital1funtofldfrac X is ) . \n\nDefinition tofldfracandminus0 ( X : intdom ) ( is : isdeceq X ) ( x : X ) : paths ( tofldfrac X is ( - x ) ) ( - tofldfrac X is x ) := tocommrngfracandminus0 _ _ x  . \n\nDefinition 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 . \n\nDefinition isbinop2funtofldfrac  ( X : intdom ) ( is : isdeceq X ) : @isbinopfun ( rngmultmonoid X ) ( rngmultmonoid ( fldfrac X is ) ) ( tofldfrac X is ) := isbinopfuntoabmonoidfrac ( rngmultabmonoid X ) ( intdomnonzerosubmonoid X ) . \n\nOpaque isbinop2funtofldfrac .\n\nLemma isunital2funtofldfrac  ( X : intdom ) ( is : isdeceq X ) : paths ( tofldfrac X is 1 ) 1 .\nProof . intros. apply idpath . Defined .\n\nOpaque isunital2funtofldfrac .   \n\nDefinition ismultmonoidfuntofldfrac  ( X : intdom ) ( is : isdeceq X ) : @ismonoidfun  ( rngmultmonoid X ) ( rngmultmonoid ( fldfrac X is ) ) ( tofldfrac X is ) := dirprodpair ( isbinop2funtofldfrac X is ) ( isunital2funtofldfrac X is ) . \n\nDefinition isrngfuntofldfrac ( X : intdom ) ( is : isdeceq X ) : @isrngfun X ( fldfrac X is ) ( tofldfrac X is ) := dirprodpair ( isaddmonoidfuntofldfrac X is ) ( ismultmonoidfuntofldfrac X is ) .\n\nDefinition isincltofldfrac ( X : intdom ) ( is : isdeceq X ) : isincl ( tofldfrac X is ) := isincltocommrngfrac X ( intdomnonzerosubmonoid X ) ( fun x : _ =>  pr2 ( intdomiscancelable X ( pr1 x ) ( pr2 x ) ) ) .\n\n\n\n\n \n\n\n\n\n(** *** Relations similar to \"greater\" on fields of fractions \n\nOur 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.  *)\n\n\n\n\n\n\n(** **** Description of the field of fractions as the ring of fractions with respect to the submonoid of \"positive\" elements *)\n\n\nDefinition 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 ) .\nProof . 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 . \n\n\nLemma 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 ) . \nProof . 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 ] . \n\nsimpl .  rewrite ( rngrunax2 X _ ) . rewrite ( rngrunax2 X _ ) . apply ( intdomrcan X _ _ _ ( pr2 aa0 ) e ) . \n\nsimpl .   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 ] .\n\nsimpl .   rewrite ( rngrunax2 X _ ) . rewrite ( rngrunax2 X _ ) . rewrite (rngrmultminus X _ _ ) . rewrite ( rnglmultminus X _ _ ) . apply ( maponpaths ( fun x : X => - x ) ) .  apply ( intdomrcan X _ _ _ ( pr2 aa0 ) e ) .\n\nsimpl .    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 .  \n\nOpaque weqfldfracgtintcomp_f . \n\nDefinition 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 ) .   \n\nDefinition 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 ) ) ) ) . \n\n\nLemma 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 ) .\nProof . intros . intros xa1 xa2 . simpl .  apply hinhfun .  intro t2 . split with ( tpair _ ( pr1 ( pr1 t2 ) ) ( rtoneq ir ( pr2 ( pr1 t2 ) ) ) ) .   apply ( pr2 t2 ) .  Defined . \n\n\nDefinition 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 ) .\n\n\nDefinition 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 ) ) .\nProof . intros . set ( f := weqfldfracgt_f X is is0 is1 is2 nc ) . set ( g := weqfldfracgt_b X is is1 is2 ir ) .  split with f . \n\nassert ( 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' ] . \n\nsimpl . apply idpath .\n\nsimpl .  rewrite (rngrmultminus X _ _ ) . rewrite ( rnglmultminus X _ _ ) . apply idpath .   \n\nassert ( efg : forall a , paths ( f ( g a ) ) a ) .  unfold fldfrac. simpl . apply ( setquotunivprop _ ( fun a => hProppair _ ( isasetsetquot _ ( f ( g a ) ) a  ) ) ) . intro xa .  simpl .\nchange ( 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' ] . \n\nsimpl . apply idpath . \n\nsimpl .   rewrite (rngrmultminus X _ _ ) . rewrite ( rnglmultminus X _ _ ) . apply idpath .\n\napply ( gradth _ _ egf efg ) . Defined .\n\n\nLemma 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 ) .\nProof . intros . set ( g :=  weqfldfracgt_b X is is1 is2 ir ) . set ( g0 := weqfldfracgtint_b X is1 is2 ir ) . split . \n\nsplit .   \n\nunfold 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\n        (fun x : pr1 X =>\n         hProppair (paths x 0 -> empty) (isapropneg (paths x 0))) \n        (a1 * a2)\n        (fun e : paths (a1 * a2) 0 =>\n         toneghdisj (dirprodpair (rtoneq ir ia1) (rtoneq ir ia2))\n           (intdomax X a1 a2 e))) ( idpath _ ) ) .\n\nchange ( 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 .\n\nsplit .  \n\nunfold 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\n        (fun x : pr1 X =>\n         hProppair (paths x 0 -> empty) (isapropneg (paths x 0))) \n        (a1 * a2)\n        (fun e : paths (a1 * a2) 0 =>\n         toneghdisj (dirprodpair (rtoneq ir ia1) (rtoneq ir ia2))\n           (intdomax X a1 a2 e))) ( idpath _ ) ) .\n\nchange ( 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 . \n\nOpaque isrngfunweqfldfracgt_b .\n\n  \nLemma 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 ) .\nProof . 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 . \n\nOpaque isrngfunweqfldfracgt_f . \n\n\n\n\n\n\n\n\n(** **** Definition and properties of \"greater\" on the field of fractions *)\n\nDefinition 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 ) .  \n\nLemma 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 ) .\nProof . intros . apply ( rngmultgtandfun ( rngfunconstr  ( isrngfunweqfldfracgt_f X is is0 is1 is2 nc ir ) ) ) .  apply isrngmultcommrngfracgt . Defined .  \n\nOpaque isrngmultfldfracgt .\n\nLemma 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 ) .\nProof . intros . apply ( rngaddhrelandfun ( rngfunconstr  ( isrngfunweqfldfracgt_f X is is0 is1 is2 nc ir ) ) ) .  apply isrngaddcommrngfracgt . Defined . \n\nOpaque isrngaddfldfracgt . \n\nLemma 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 ) .\nProof . intros . intros a b c . unfold fldfracgt .  apply istransabmonoidfracrel .  apply isr . Defined . \n\nOpaque istransfldfracgt . \n\nLemma 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 ) .\nProof . intros .   intros a .  unfold fldfracgt  . apply isirreflabmonoidfracrel . apply isr .  Defined .\n\nOpaque isirreflfldfracgt .\n\nLemma 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 ) .\nProof . intros .  intros a b .  unfold fldfracgt  . apply isasymmabmonoidfracrel . apply isr . Defined .\n\nOpaque  isasymmfldfracgt .\n\nLemma 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 ) .\nProof . intros . intros a b c .  unfold fldfracgt  . apply iscotransabmonoidfracrel . apply isr . Defined .\n\nOpaque iscotransfldfracgt . \n\nLemma 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 ) .\nProof . 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)\n        (ispartbinopcommrngfracgt X (rngpossubmonoid X is1 is2) is0 is1\n           (fun (c : X) (r : (rngpossubmonoid X is1 is2) c) => r))). apply isr . \n\nintros a b n1 n2 . set ( e := int _ _ n1 n2 ) .  apply ( invmaponpathsweq ( weqfldfracgt X is is0 is1 is2 nc ir )  _ _ e ) . Defined .\n\nOpaque isantisymmnegfldfracgt . \n\n\nDefinition 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 ) .  \nProof . 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 . \n\n\n\n\n\n(** **** Relations and the canonical homomorphism to the field of fractions *)\n\n\nDefinition 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 ) .\nProof . 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 ] . \n\napply pathsdirprod .  apply idpath .  apply ( invmaponpathsincl _ ( isinclpr1 _ ( fun a => ( pr2 ( L a 0 ) ) ) ) ) . apply idpath .  \n\ndestruct ( isa _ _ is2 nl ) . \n\nassert  ( int' := int x1 x2 ) .   rewrite ( ee x1 ) in int' .   rewrite ( ee x2 ) in int' . apply int' .  apply l . Defined .\n\nOpaque iscomptofldfrac . \n \n\n\n\n\n\n(* End of the file algebra1d.v *)\n"
  },
  {
    "path": "hlevel2/finitesets.v",
    "content": "(** * Finite sets. Vladimir Voevodsky . Apr. - Sep. 2011.\n\nThis 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. \n\n*)\n\n\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *)\n\n\n\n(** Imports. *)\n\nAdd LoadPath \"../..\" .\n\nRequire Export Foundations.hlevel2.stnfsets .\n\n\n\n\n(** ** Sets with a given number of elements. *)\n\n(** *** Structure of a set with [ n ] elements on [ X ] defined as a term in [ weq ( stn n ) X ]  *)\n\nDefinition nelstruct ( n : nat ) ( X : UU ) := weq ( stn n ) X . \n\nDefinition nelstructonstn ( n : nat ) : nelstruct n ( stn n ) := idweq _ . \n\nDefinition nelstructweqf { X Y : UU } { n : nat } ( w : weq X Y ) ( sx : nelstruct n X ) : nelstruct n Y := weqcomp sx w .\n\nDefinition nelstructweqb { X Y : UU } { n : nat } ( w : weq X Y ) ( sy : nelstruct n Y ) : nelstruct n X := weqcomp sy ( invweq w ) . \n\nDefinition nelstructonempty : nelstruct 0 empty := weqstn0toempty . \n\nDefinition nelstructonempty2 { X : UU } ( is : neg X ) : nelstruct 0 X :=  weqcomp weqstn0toempty ( invweq ( weqtoempty is ) ) . \n\nDefinition nelstructonunit : nelstruct 1 unit := weqstn1tounit .\n\nDefinition nelstructoncontr { X : UU } ( is : iscontr X ) : nelstruct 1 X := weqcomp weqstn1tounit ( invweq ( weqcontrtounit is ) ) .\n\nDefinition nelstructonbool : nelstruct 2 bool := weqstn2tobool .\n\nDefinition 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 ) ) .\n\nDefinition 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 ) ) . \n\nDefinition 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 ) .\n\nDefinition 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 )  .  \n\nDefinition 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 ) .\n\n(** For a generalization of [ weqfromdecsubsetofstn ] see below *) \n\nDefinition 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 ) )  .\n\nDefinition 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 ) ) ) )  . \n\nDefinition 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 ) ) .\n\n\n\n(** *** The property of [ X ] to have [ n ] elements *) \n\nDefinition isofnel ( n : nat ) ( X : UU ) : hProp := ishinh ( weq ( stn n ) X ) . \n\nLemma isofneluniv { n : nat} { X : UU }  ( P : hProp ) : ( ( nelstruct n X ) -> P ) -> ( isofnel n X -> P ) .\nProof. intros.  apply @hinhuniv with ( weq ( stn n ) X ) . assumption. assumption. Defined. \n\nDefinition isofnelstn ( n : nat ) : isofnel n ( stn n ) := hinhpr _ ( nelstructonstn n ) . \n\nDefinition isofnelweqf { X Y : UU } { n : nat } ( w : weq X Y ) ( sx : isofnel n X ) : isofnel n Y := hinhfun ( fun sx0 : _ =>  nelstructweqf w sx0 ) sx . \n\nDefinition isofnelweqb { X Y : UU } { n : nat } ( w : weq X Y ) ( sy : isofnel n Y ) : isofnel n X :=  hinhfun ( fun sy0 : _ => nelstructweqb w sy0 ) sy . \n\nDefinition isofnelempty : isofnel 0 empty := hinhpr _ nelstructonempty . \n\nDefinition isofnelempty2 { X : UU } ( is : neg X ) : isofnel 0 X :=  hinhpr _ ( nelstructonempty2 is ) . \n\nDefinition isofnelunit : isofnel 1 unit := hinhpr _ nelstructonunit  .\n\nDefinition isofnelcontr { X : UU } ( is : iscontr X ) : isofnel 1 X := hinhpr _ ( nelstructoncontr is ) .\n\nDefinition isofnelbool : isofnel 2 bool := hinhpr _ nelstructonbool .\n\nDefinition isofnelcoprodwithunit { X : UU } { n : nat } ( sx : isofnel n X ) : isofnel ( S n ) ( coprod X unit ) :=   hinhfun ( fun sx0 : _ =>  nelstructoncoprodwithunit sx0 ) sx . \n\nDefinition isofnelcompl { X : UU } { n : nat } ( x : X ) ( sx : isofnel ( S n ) X ) : isofnel n ( compl X x ) := hinhfun ( fun sx0 : _ =>  nelstructoncompl x sx0 ) sx . \n\nDefinition 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 . \n\n(** For a result corresponding to [ nelstructontotal2 ] see below . *)\n\nDefinition 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 . \n\nDefinition 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 . \n\n(** For a result corresponding to [ nelstructonforall ] see below . *)\n\nDefinition isofnelonweq { X : UU } { n : nat } ( sx : isofnel n X ) : isofnel ( factorial n ) ( weq X X ) := hinhfun ( fun sx0 : _ =>  nelstructonweq sx0 ) sx . \n\n\n\n\n(** ** General finite sets. *)\n\n(** *** Finite structure on a type [ X ] defined as a pair [ ( n , w ) ] where [ n : nat ] and [ w : weq ( stn n ) X ] *)\n\n\nDefinition finstruct  ( X : UU ) := total2 ( fun n : nat => nelstruct n X ) .\nDefinition fintructpair  ( X : UU )  := tpair ( fun n : nat => nelstruct n X ) .\n\nDefinition finstructonstn ( n : nat ) : finstruct ( stn n ) := tpair _ n ( nelstructonstn n ) . \n\nDefinition finstructweqf { X Y : UU } ( w : weq X Y ) ( sx : finstruct X ) : finstruct Y := tpair _ ( pr1 sx ) ( nelstructweqf w ( pr2 sx ) ) .\n\nDefinition finstructweqb { X Y : UU } ( w : weq X Y ) ( sy : finstruct Y ) : finstruct X :=  tpair _ ( pr1 sy ) ( nelstructweqb w ( pr2 sy ) ) .\n\nDefinition finstructonempty : finstruct empty := tpair _ 0 nelstructonempty .\n\nDefinition finstructonempty2 { X : UU } ( is : neg X ) : finstruct X :=  tpair _ 0 ( nelstructonempty2 is ) . \n\nDefinition finstructonunit : finstruct unit := tpair _ 1 nelstructonunit .\n\nDefinition finstructoncontr { X : UU } ( is : iscontr X ) : finstruct X := tpair _ 1 ( nelstructoncontr is ) .\n\n(** 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 . *)   \n\nDefinition finstructonbool : finstruct bool := tpair _ 2 nelstructonbool .\n\nDefinition finstructoncoprodwithunit { X : UU }  ( sx : finstruct X ) : finstruct ( coprod X unit ) :=  tpair _ ( S ( pr1 sx ) ) ( nelstructoncoprodwithunit ( pr2 sx ) ) .\n\nDefinition finstructoncompl { X : UU } ( x : X ) ( sx : finstruct X ) : finstruct ( compl X x ) .\nProof . 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 . \n\nDefinition finstructoncoprod { X  Y : UU } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( coprod X Y ) := tpair _ ( ( pr1 sx ) + ( pr1 sy ) ) ( nelstructoncoprod ( pr2 sx ) ( pr2 sy ) ) . \n\nDefinition 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 ) ) ) . \n\nDefinition finstructondirprod { X Y : UU } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( dirprod X Y ) := tpair _ ( ( pr1 sx ) * ( pr1 sy ) ) ( nelstructondirprod ( pr2 sx ) ( pr2 sy ) ) .\n\nDefinition 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 ) ) . \n\n\nDefinition finstructonfun { X Y : UU } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( X -> Y ) := tpair _ ( natpower ( pr1 sy ) ( pr1 sx ) ) ( nelstructonfun ( pr2 sx ) ( pr2 sy ) ) .\n\nDefinition 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 ) ) ) . \n\nDefinition finstructonweq { X : UU }  ( sx : finstruct X ) : finstruct ( weq X X ) := tpair _ ( factorial ( pr1 sx ) ) ( nelstructonweq ( pr2 sx ) ) .\n\n\n\n\n(** *** The property of being finite *)\n\nDefinition isfinite  ( X : UU ) := ishinh ( finstruct X ) .\n\nDefinition fincard { X : UU } ( is : isfinite X ) : nat .\nProof . 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 . \n\nTheorem ischoicebasefiniteset { X : UU } ( is : isfinite X ) : ischoicebase X . \nProof . intros . apply ( @hinhuniv ( finstruct X ) ( ischoicebase X ) ) .  intro nw . destruct nw as [ n w ] .   apply ( ischoicebaseweqf w ( ischoicebasestn n ) ) .  apply is .  Defined . \n\n\nDefinition isfinitestn ( n : nat ) : isfinite ( stn n ) := hinhpr _ ( finstructonstn n ) . \n\nDefinition isfiniteweqf { X Y : UU } ( w : weq X Y ) ( sx : isfinite X ) : isfinite Y :=  hinhfun ( fun sx0 : _ =>  finstructweqf w sx0 ) sx .\n\nDefinition isfiniteweqb { X Y : UU } ( w : weq X Y ) ( sy : isfinite Y ) : isfinite X :=   hinhfun ( fun sy0 : _ =>  finstructweqb w sy0 ) sy .\n\nDefinition isfiniteempty : isfinite empty := hinhpr _ finstructonempty .\n\nDefinition isfiniteempty2 { X : UU } ( is : neg X ) : isfinite X :=  hinhpr _ ( finstructonempty2 is ) . \n\nDefinition isfiniteunit : isfinite unit := hinhpr _ finstructonunit .\n\nDefinition isfinitecontr { X : UU } ( is : iscontr X ) : isfinite X := hinhpr _ ( finstructoncontr is ) .\n\nDefinition isfinitebool : isfinite bool := hinhpr _ finstructonbool .\n\nDefinition isfinitecoprodwithunit { X : UU } ( sx : isfinite X ) : isfinite ( coprod X unit ) :=  hinhfun ( fun sx0 : _ => finstructoncoprodwithunit sx0 ) sx .\n\nDefinition isfinitecompl { X : UU } ( x : X ) ( sx : isfinite X ) : isfinite ( compl X x ) := hinhfun ( fun sx0 : _ => finstructoncompl x sx0 ) sx .\n\nDefinition isfinitecoprod { X  Y : UU } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( coprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructoncoprod sx0 sy0 ) sx sy . \n\nDefinition isfinitetotal2 { X : UU } ( P : X -> UU ) ( sx : isfinite X ) ( fs : forall x : X , isfinite ( P x ) ) : isfinite ( total2 P ) .\nProof . 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 . \n\nDefinition isfinitedirprod { X Y : UU } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( dirprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructondirprod sx0 sy0 ) sx sy . \n\nDefinition isfinitedecsubset { X : UU } ( f : X -> bool ) ( sx : isfinite X ) : isfinite ( hfiber f true ) := hinhfun ( fun sx0 : _ =>  finstructondecsubset f sx0 ) sx .\n\nDefinition isfinitefun { X Y : UU } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( X -> Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructonfun sx0 sy0 ) sx sy . \n\nDefinition isfiniteforall { X : UU } ( P : X -> UU ) ( sx : isfinite X ) ( fs : forall x : X , isfinite ( P x ) ) : isfinite ( forall x : X , P x ) .\nProof . 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 . \n\nDefinition isfiniteweq { X : UU } ( sx : isfinite X ) : isfinite ( weq X X ) := hinhfun ( fun sx0 : _ =>  finstructonweq sx0 ) sx .\n\n\n\n\n\n\n\n\n\n\n\n(*\n\n(* The cardinality of finite sets using double negation and decidability of equality in nat. *)\n\nDefinition carddneg  ( X : UU ) (is: isfinite X): nat:= pr1 (isfiniteimplisfinite0 X is).\n\nDefinition preweq  ( X : UU ) (is: isfinite X): isofnel (carddneg X is) X.\nProof. 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. \n\nassert (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 ]. \nassert (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)). \nassert (e:paths t c). apply (stnsdnegweqtoeq _ _  dw). clear dnw. destruct e. assumption. unfold isofnel. \napply (hinhfun _ _ f (hinhand (finitestruct X) _ is (hinhpr _ dnw))). Defined. \n\n*)\n\n(* to be completed \n\nTheorem carddnegweqf (X Y:UU)(f: X -> Y)(isw:isweq f)(isx: isfinite X): paths  (carddneg _ isx) (carddneg _ (isfiniteweqf _ _ _ isw isx)).\nProof. intros. *) \n\n(* The cardinality of finite sets defined using the \"impredicative\" ishinh *)\n\n\n\n(** ** Test computations. *)\n\n\n\n(*Eval compute in carddneg _  (isfinitedirprod _ _ (isfinitestn (S (S (S (S O)))))  (isfinitestn (S (S (S O))))).*)\n\nEval compute in fincard (isfiniteempty).\n\nEval compute in fincard (isfiniteunit).\n\nEval compute in fincard (isfinitebool).\n\n\n\n\n(*Eval lazy in   (pr1 (finitestructcomplement _ (dirprodpair _ _ tt tt) (finitestructdirprod _ _ (finitestructunit) (finitestructunit)))).*)\n \n\n\n\nEval compute in fincard (isfinitecompl  true isfinitebool).\n\nEval compute in fincard (isfinitedirprod  isfinitebool isfinitebool).\n\nEval compute in fincard (isfinitedirprod  isfinitebool (isfinitedirprod  isfinitebool isfinitebool)).\n\nEval lazy in fincard (isfinitecompl (ii1 tt) (isfinitecoprod  (isfiniteunit) (isfinitebool))).\n\nEval lazy in  fincard (isfinitecompl (ii1 tt) (isfinitecoprod (isfiniteunit) (isfinitebool))). \n\nEval lazy in fincard (isfinitecompl (dirprodpair tt tt) (isfinitedirprod  isfiniteunit isfiniteunit)).\n \nEval lazy in fincard (isfinitecompl (dirprodpair  true (dirprodpair  true false)) (isfinitedirprod  (isfinitebool) (isfinitedirprod  (isfinitebool) (isfinitebool)))).\n\nEval lazy in fincard ( isfiniteweq ( isfinitedirprod ( isfinitedirprod isfinitebool isfinitebool ) isfinitebool ) ) . \n\n\n\n\n\n\n\n(* End of the file finitesets.v *)\n"
  },
  {
    "path": "hlevel2/hSet.v",
    "content": "(** * Generalities on [ hSet ] .  Vladimir Voevodsky. Feb. - Sep. 2011 \n\nIn 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. \n\nWhile 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.\n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)\n\n\n(** Imports *)\n\nAdd LoadPath \"../../\" .\n\nRequire Export Foundations.hlevel1.hProp .\n\n\n\n\n(** ** The type of sets i.e. of types of h-level 2 in [ UU ] *) \n\nDefinition hSet:= total2 (fun X : UU => isaset X) .\nDefinition hSetpair := tpair (fun X : UU => isaset X).\nDefinition pr1hSet:= @pr1 UU (fun X : UU => isaset X) : hSet -> Type.\nCoercion pr1hSet: hSet >-> Sortclass.\n\nDefinition eqset { X : hSet } ( x x' : X ) : hProp := hProppair _ ( pr2 X x x' ) . \n\nDefinition setproperty ( X : hSet ) := pr2 X . \n\nDefinition setdirprod ( X Y : hSet ) : hSet .\nProof . intros . split with ( dirprod X Y ) . apply ( isofhleveldirprod 2 ) .  apply ( pr2 X ) . apply ( pr2 Y ) . Defined . \n\n(** [ hProp ] as a set *)\n\nDefinition hPropset : hSet := tpair _ hProp isasethProp .  \n(* Canonical Structure hPropset. *)\n\n\n(** Booleans as a set *)\n\nDefinition boolset : hSet := hSetpair bool isasetbool .\n(* Canonical Structure boolset .  *)\n\n\n(** ** Types [ X ] which satisfy \" weak \" axiom of choice for all families [ P : X -> UU ] \n\nWeak 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 . \n\nIntuition 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 . \n\n\n*)\n\nDefinition ischoicebase_uu1 ( X : UU ) := forall P : X -> UU , ( forall x : X , ishinh ( P x ) ) -> ishinh ( forall x : X , P x ) .\n\nLemma isapropischoicebase ( X : UU ) : isaprop ( ischoicebase_uu1 X ) .  (** Uses RR1 *)\nProof .  intro . apply impred . intro P .  apply impred . intro fs . apply ( pr2 ( ishinh _ ) ) .  Defined . \n\nDefinition ischoicebase ( X : UU ) : hProp := hProppair _ ( isapropischoicebase X ) . \n\n\nLemma ischoicebaseweqf { X Y : UU } ( w : weq X Y ) ( is : ischoicebase X ) : ischoicebase Y .\nProof . intros . unfold ischoicebase . intros Q fs . apply ( hinhfun ( invweq ( weqonsecbase Q w ) ) ) .   apply ( is ( funcomp w Q ) ( fun x : X => fs ( w x ) ) ) .  Defined . \n\nLemma ischoicebaseweqb { X Y : UU } ( w : weq X Y ) ( is : ischoicebase Y ) : ischoicebase X .\nProof . intros . apply ( ischoicebaseweqf ( invweq w ) is ) . Defined . \n\nLemma ischoicebaseunit : ischoicebase unit .\nProof . unfold ischoicebase . intros P fs .  apply ( hinhfun ( tosecoverunit P ) ) .  apply ( fs tt ) .  Defined .\n\nLemma ischoicebasecontr { X : UU } ( is : iscontr X ) : ischoicebase X .\nProof . intros . apply ( ischoicebaseweqb ( weqcontrtounit is )  ischoicebaseunit ) . Defined . \n\nLemma ischoicebaseempty : ischoicebase empty .\nProof . unfold ischoicebase . intros P fs .  apply ( hinhpr _ ( fun x : empty => fromempty x ) ) .  Defined .\n\nLemma ischoicebaseempty2 { X : UU } ( is : neg X ) : ischoicebase X .\nProof . intros . apply ( ischoicebaseweqb ( weqtoempty is ) ischoicebaseempty ) . Defined .\n\nLemma ischoicebasecoprod { X Y : UU } ( isx : ischoicebase X ) ( isy : ischoicebase Y ) :  ischoicebase ( coprod X Y ) .\nProof . 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 . \n\n\n\n\n\n\n\n\n(** ** The type of monic subtypes of a type (subsets of the set of connected components) *)\n\n\n(** *** Genneral definitions *)\n\nDefinition hsubtypes ( X : UU ) :=  X -> hProp .\nIdentity Coercion id_hsubtypes :  hsubtypes >-> Funclass . \nDefinition carrier { X : UU } ( A : hsubtypes X ) := total2 A.\nCoercion carrier : hsubtypes >-> Sortclass. \nDefinition carrierpair { X : UU } ( A : hsubtypes X ) := tpair A.\nDefinition pr1carrier { X:UU } ( A : hsubtypes X ) := @pr1 _ _  : carrier A -> X .\n\nLemma isinclpr1carrier { X : UU } ( A : hsubtypes X ) : isincl ( @pr1carrier X A ) .\nProof . intros . apply ( isinclpr1 A ( fun x : _ => pr2 ( A x ) ) ) . Defined . \n\nLemma isasethsubtypes (X:UU): isaset (hsubtypes X).\nProof. intro . change ( isofhlevel 2 ( hsubtypes X ) ) .  apply impred . intro. apply isasethProp. Defined.\n\nDefinition totalsubtype ( X : UU ) : hsubtypes X := fun x => htrue .\n\nDefinition weqtotalsubtype ( X : UU ) : weq ( totalsubtype X ) X .\nProof . intro . apply weqpr1 .   intro . apply iscontrunit .  Defined . \n\n\n(** *** Direct product of two subtypes *)\n\nDefinition subtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : hsubtypes ( dirprod X Y ) := fun xy : _ => hconj ( A ( pr1 xy ) ) ( B ( pr2 xy ) ) .\n\nDefinition fromdsubtypesdirprodcarrier { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( xyis : subtypesdirprod A B ) : dirprod A B .\nProof . 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 .\n\nDefinition tosubtypesdirprodcarrier { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( xisyis : dirprod A B ) : subtypesdirprod A B . \nProof . 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 .  \n\nLemma weqsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : weq ( subtypesdirprod A B ) ( dirprod A B ) .\nProof . intros .  set ( f := fromdsubtypesdirprodcarrier A B ) . set ( g :=  tosubtypesdirprodcarrier A B ) . split with f .\nassert ( 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 . \nassert ( 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 .\napply ( gradth _ _ egf efg ) . Defined .  \n\nLemma ishinhsubtypesdirprod  { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( isa : ishinh A ) ( isb : ishinh B ) : ishinh ( subtypesdirprod A B ) .  \nProof . intros . apply ( hinhfun ( invweq ( weqsubtypesdirprod A B ) ) ) .  apply hinhand .  apply isa . apply isb . Defined . \n\n\n\n(** *** A a subtype of with a paths between any every two elements is an h-prop. *)\n\n\nLemma isapropsubtype { X : UU } ( A : hsubtypes X ) ( is : forall ( x1 x2 : X ) , A x1 -> A x2 -> paths x1 x2 ) : isaprop ( carrier A ) . \nProof. intros.  apply invproofirrelevance. intros x x' .  \nassert ( isincl ( @pr1 _ A )).  apply isinclpr1. intro x0. apply ( pr2 ( A x0 )).  \napply ( invmaponpathsincl ( @pr1 _ A ) X0 ). destruct x as [ x0 is0 ]. destruct x' as [ x0' is0' ] . simpl. apply is. assumption. assumption. Defined. \n\n\n(* End of \" the type of monic subtypes of a type \" . *)\n\n\n\n\n\n\n\n(** ** Relations on types ( or equivalently relations on the sets of connected components) *)\n\n\n(** *** Relations and boolean relations *)\n\nDefinition hrel ( X : UU ) := X -> X -> hProp.\nIdentity Coercion idhrel : hrel >-> Funclass .  \n\nDefinition brel ( X : UU ) := X -> X -> bool .\nIdentity Coercion idbrel : brel >-> Funclass . \n\n(** *** Standard properties of relations *)\n\n\n\nDefinition istrans { X : UU } ( R : hrel X ) := forall ( x1 x2 x3 : X ) ( r12 : R x1 x2 ) ( r23 : R x2 x3 ) , R x1 x3.\n\nDefinition isrefl { X : UU } ( R : hrel X ) := forall x : X , R x x.\n\nDefinition issymm { X : UU } ( R : hrel X ) := forall ( x1 x2 : X ) ( r12 : R x1 x2 ) , R x2 x1 .\n\nDefinition ispo { X : UU } ( R : hrel X ) := dirprod ( istrans R ) ( isrefl R ) .\n\nDefinition iseqrel { X : UU } ( R : hrel X ) := dirprod ( ispo R ) ( issymm R ) .\nDefinition iseqrelconstr { X : UU } { R : hrel X } ( trans0 : istrans R ) ( refl0 : isrefl R ) ( symm0 : issymm R ) : iseqrel R := dirprodpair ( dirprodpair trans0 refl0 ) symm0 .\n\nDefinition isirrefl { X : UU } ( R : hrel X ) := forall  x : X , neg ( R x x ) . \n\nDefinition isasymm { X : UU } ( R : hrel X ) := forall ( x1 x2 : X ) ( r12 : R x1 x2 ) ( r21 : R x2 x1 ) , empty . \n\nDefinition iscoasymm { X : UU } ( R : hrel X ) := forall x1 x2 , neg ( R x1 x2 ) -> R x2 x1 .\n\nDefinition istotal { X : UU } ( R : hrel X ) := forall x1 x2 , hdisj ( R x1 x2 ) ( R x2 x1 ) .\n\nDefinition iscotrans { X : UU } ( R : hrel X ) := forall x1 x2 x3 , R x1 x3 -> hdisj ( R x1 x2 ) ( R x2 x3 ) .\n\nDefinition isdecrel { X : UU } ( R : hrel X ) := forall x1 x2 , coprod ( R x1 x2 ) ( neg ( R x1 x2 ) ) .\n\nDefinition isnegrel { X : UU } ( R : hrel X ) := forall x1 x2 , neg ( neg ( R x1 x2 ) ) -> R x1 x2 .\n\n(** 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 . *) \n\nDefinition isantisymm { X : UU } ( R : hrel X ) := forall ( x1 x2 : X ) ( r12 : R x1 x2 ) ( r21 : R x2 x1 ) , paths x1 x2 .\n\nDefinition isantisymmneg { X : UU } ( R : hrel X ) := forall ( x1 x2 : X ) ( nr12 : neg ( R x1 x2 ) ) ( nr21 : neg ( R x2 x1 ) ) , paths x1 x2 .\n\nDefinition iscoantisymm { X : UU } ( R : hrel X ) := forall x1 x2 , neg ( R x1 x2 ) -> coprod ( R x2 x1 ) ( paths x1 x2 ) .\n\n(** 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. *)\n\nDefinition neqchoice { X : UU } ( R : hrel X ) := forall x1 x2 , neg ( paths x1 x2 ) -> coprod ( R x1 x2 ) ( R x2 x1 ) .\n\n\n\n(** *** Elementary implications between properties of relations *)\n\nLemma istransandirrefltoasymm { X : UU } { R : hrel X } ( is1 : istrans R ) ( is2 : isirrefl R ) : isasymm R .\nProof . intros .  intros a b rab rba . apply ( is2 _ ( is1 _ _ _ rab rba ) ) .  Defined . \n\nLemma istotaltoiscoasymm { X : UU } { R : hrel X } ( is : istotal R ) : iscoasymm R .\nProof . intros .  intros x1 x2 . apply ( hdisjtoimpl ( is _ _ ) ) . Defined . \n\nLemma isdecreltoisnegrel { X : UU } { R : hrel X } ( is : isdecrel R ) : isnegrel R .\nProof . intros .  intros x1 x2 .  destruct ( is x1 x2 ) as [ r | nr ] . intro . apply r . intro nnr . destruct ( nnr nr ) .  Defined . \n\nLemma isantisymmnegtoiscoantisymm { X : UU } { R : hrel X } ( isdr : isdecrel R ) ( isr : isantisymmneg R ) : iscoantisymm R . \nProof . intros . intros x1 x2 nrx12 . destruct ( isdr x2 x1 ) as [ r | nr ] . apply ( ii1 r ) .  apply ii2 . apply ( isr _ _ nrx12 nr ) .  Defined . \n\nLemma rtoneq { X : UU } { R : hrel X } ( is : isirrefl R ) { a b : X } ( r : R a b ) : neg ( paths a b ) .\nProof . intros . intro e . rewrite e in r . apply ( is b r ) . Defined .  \n\n\n(** *** Standard properties of relations and logical equivalences *)\n\nDefinition hrellogeq { X : UU } ( L R : hrel X ) := forall x1 x2 , ( L x1 x2 <-> R x1 x2 ) .\n\nDefinition istranslogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : istrans L ) : istrans R .\nProof . intros . intros x1 x2 x3 r12 r23 .   apply ( ( pr1 ( lg _ _ ) ) ( isl _ _ _ ( ( pr2 ( lg _ _ ) ) r12 ) ( ( pr2 ( lg _ _ ) ) r23 ) ) ) . Defined . \n\nDefinition isrefllogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isrefl L ) : isrefl R . \nProof . intros . intro x . apply ( pr1 ( lg _ _ ) ( isl x ) ) .  Defined . \n\nDefinition issymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : issymm L ) : issymm R . \nProof . intros . intros x1 x2 r12 . apply ( pr1 ( lg _ _ ) ( isl _ _ ( pr2 ( lg _ _ ) r12 ) ) ) . Defined .  \n\nDefinition ispologeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : ispo L ) : ispo R . \nProof . intros . apply ( dirprodpair ( istranslogeqf lg ( pr1 isl ) ) ( isrefllogeqf lg ( pr2 isl ) ) ) . Defined . \n\nDefinition iseqrellogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : iseqrel L ) : iseqrel R . \nProof . intros . apply ( dirprodpair ( ispologeqf lg ( pr1 isl ) ) ( issymmlogeqf lg ( pr2 isl ) ) ) . Defined . \n\nDefinition isirrefllogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isirrefl L ) : isirrefl R .\nProof . intros . intros x r . apply ( isl _ ( pr2 ( lg x x ) r ) ) . Defined .   \n\nDefinition isasymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isasymm L ) : isasymm R . \nProof . intros . intros x1 x2 r12 r21 . apply ( isl _ _ ( pr2 ( lg _ _ ) r12 ) ( pr2 ( lg _ _ ) r21 ) )   . Defined . \n\nDefinition iscoasymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : iscoasymm L ) : iscoasymm R . \nProof . intros . intros x1 x2 r12 . apply ( ( pr1 ( lg _ _ ) ) ( isl _ _ ( negf ( pr1 ( lg _ _ ) ) r12 ) ) ) . Defined . \n\nDefinition istotallogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : istotal L ) : istotal R . \nProof . 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 . \n\nDefinition iscotranslogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : iscotrans L ) : iscotrans R . \nProof . 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 .\n\nDefinition isdecrellogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isdecrel L ) : isdecrel R . \nProof . intros . intros x1 x2 . destruct ( isl x1 x2 ) as [ l | nl ] . apply ( ii1 ( pr1 ( lg _ _ ) l ) ) . apply ( ii2 ( negf ( pr2 ( lg _ _ ) ) nl ) ) . Defined . \n\nDefinition isnegrellogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isnegrel L ) : isnegrel R . \nProof . intros . intros x1 x2 nnr . apply ( ( pr1 ( lg _ _ ) ) ( isl _ _ ( negf ( negf ( pr2 ( lg _ _ ) ) ) nnr ) ) ) . Defined . \n\nDefinition isantisymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isantisymm L ) : isantisymm R .\nProof . intros . intros x1 x2 r12 r21 . apply ( isl _ _ ( pr2 ( lg _ _ ) r12 ) ( pr2 ( lg _ _ ) r21 ) )   . Defined .  \n\nDefinition isantisymmneglogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : isantisymmneg L ) : isantisymmneg R .\nProof . intros . intros x1 x2 nr12 nr21 . apply ( isl _ _ ( negf ( pr1 ( lg _ _ ) ) nr12 ) ( negf ( pr1 ( lg _ _ ) ) nr21 ) )   . Defined .  \n\nDefinition iscoantisymmlogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : iscoantisymm L ) : iscoantisymm R .\nProof . intros . intros x1 x2 r12 . set ( int := isl _ _ ( negf ( pr1 ( lg _ _ ) ) r12 ) ) . generalize int .  clear int .  simpl . apply ( coprodf ( pr1 ( lg _ _ ) ) ( idfun _ ) ) . Defined . \n\nDefinition neqchoicelogeqf { X : UU } { L R : hrel X } ( lg : forall x1 x2 , L x1 x2 <-> R x1 x2 ) ( isl : neqchoice L ) : neqchoice R .\nProof . intros . intros x1 x2  ne .  apply ( coprodf ( pr1 ( lg x1 x2 ) ) ( pr1 ( lg x2 x1 ) ) ( isl _ _ ne ) ) . Defined . \n\n\n\n(** *** Preorderings and associated types . *)\n\nDefinition po ( X : UU ) := total2 ( fun R : hrel X => ispo R ) .\nDefinition popair { X : UU } ( R : hrel X ) ( is : ispo R ) : po X := tpair ( fun R : hrel X => ispo R ) R is .\nDefinition carrierofpo ( X : UU ) :  po X  -> ( X -> X -> hProp ) :=  @pr1 _ ( fun R : hrel X => ispo R ) .\nCoercion carrierofpo : po >-> Funclass  . \n\nDefinition Poset := total2 ( fun X : hSet => po X ) .\nDefinition Posetpair ( X : hSet ) ( R : po X ) : Poset := tpair ( fun X : hSet => po X ) X R .\nDefinition carrierofposet : Poset -> hSet := @pr1 _ _ .\nCoercion carrierofposet : Poset >-> hSet . \n\nDefinition isaposetmorphism { X Y : Poset } ( f : X -> Y ) := forall x x' : X , ( pr1 ( pr2 X ) x x' ) -> ( pr1 ( pr2 Y ) ( f x ) ( f x' ) ) .\nDefinition posetmorphism ( X Y : Poset ) := total2 ( fun f : X -> Y => isaposetmorphism f ) .\nDefinition posetmorphismpair ( X Y : Poset ) := tpair ( fun f : X -> Y => isaposetmorphism f ) .\nDefinition carrierofposetmorphism ( X Y : Poset ) : posetmorphism X Y -> ( X -> Y ) := @pr1 _ _ .\nCoercion  carrierofposetmorphism : posetmorphism >-> Funclass . \n\n\n(** *** Eqivalence relations and associated types . *)\n\nDefinition eqrel ( X : UU ) := total2 ( fun R : hrel X => iseqrel R ) .\nDefinition eqrelpair { X : UU } ( R : hrel X ) ( is : iseqrel R ) : eqrel X := tpair ( fun R : hrel X => iseqrel R ) R is .\nDefinition eqrelconstr { X : UU } ( R : hrel X ) ( is1 : istrans R ) ( is2 : isrefl R ) ( is3 : issymm R ) : eqrel X := eqrelpair R ( dirprodpair ( dirprodpair is1 is2 ) is3 ) .  \nDefinition pr1eqrel ( X : UU ) : eqrel X -> ( X -> ( X -> hProp ) ) := @pr1 _ _ .\nCoercion pr1eqrel : eqrel >-> Funclass . \n\nDefinition eqreltrans { X : UU } ( R : eqrel X ) : istrans R := pr1 ( pr1 ( pr2 R ) ) . \nDefinition eqrelrefl { X : UU } ( R : eqrel X ) : isrefl R := pr2 ( pr1 ( pr2 R ) ) . \nDefinition eqrelsymm { X : UU } ( R : eqrel X ) : issymm R := pr2 ( pr2 R )  . \n\n\n\n(** *** Direct product of two relations *)\n\nDefinition 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' ) ) .\n\nDefinition 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 ) ) . \n\nDefinition 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 _ ) .\n\nDefinition   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 ) ) . \n\nDefinition 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 ) ) .\n\n\n(** *** Negation of a relation and its properties *)\n\nDefinition negrel { X : UU } ( R : hrel X ) : hrel X := fun x x' => hProppair _ ( isapropneg ( R x x' ) ) .\n\nLemma istransnegrel { X : UU } ( R : hrel X  ) ( isr : iscotrans R ) : istrans ( negrel R ) .  \nProof . intros . intros x1 x2 x3 r12 r23 .  apply ( negf ( isr x1 x2 x3 ) ) .  apply ( toneghdisj ( dirprodpair r12 r23 ) ) . Defined . \n\nLemma isasymmnegrel { X : UU } ( R : hrel X  ) ( isr : iscoasymm R ) : isasymm ( negrel R ) .  \nProof . intros . intros x1 x2 r12 r21 . apply ( r21 ( isr _ _ r12 ) ) .   Defined . \n\nLemma iscoasymmgenrel { X : UU } ( R : hrel X  ) ( isr : isasymm R ) : iscoasymm ( negrel R ) .  \nProof . intros . intros x1 x2 nr12 . apply ( negf ( isr _ _ ) nr12 ) .  Defined . \n\nLemma isdecnegrel { X : UU } ( R : hrel X  ) ( isr : isdecrel R ) : isdecrel ( negrel R ) .\nProof . intros . intros x1 x2 . destruct ( isr x1 x2 ) as [ r | nr ] . apply ii2 .   apply ( todneg _ r ) .  apply ( ii1 nr ) . Defined . \n\nLemma isnegnegrel { X : UU } ( R : hrel X ) : isnegrel ( negrel R ) .\nProof . intros .   intros x1 x2 .  apply ( negf ( todneg ( R x1 x2 ) ) ) . Defined . \n\nLemma isantisymmnegrel { X : UU } ( R : hrel X  ) ( isr : isantisymmneg R ) : isantisymm ( negrel R ) . \nProof . intros . apply isr .  Defined . \n\n(** *** Boolean representation of decidable equality *)\n\nDefinition eqh { X : UU } ( is : isdeceq X ) : hrel X := fun x x' => hProppair ( paths ( booleq is x x' ) true ) ( isasetbool ( booleq is x x' ) true ) .\n\nDefinition neqh { X : UU } ( is : isdeceq X ) : hrel X := fun x x' =>  hProppair ( paths ( booleq is x x' ) false ) ( isasetbool ( booleq is x x' ) false ) . \n\nLemma isrefleqh { X : UU } ( is : isdeceq X ) : isrefl ( eqh is ) . \nProof . intros .  unfold eqh .  unfold booleq . intro x .  destruct ( is x x ) as [ e | ne ] . simpl .  apply idpath .  destruct ( ne ( idpath x ) ) .  Defined . \n\nDefinition weqeqh { X : UU } ( is : isdeceq X ) ( x x' : X ) : weq ( paths x x' ) ( eqh is x x' ) .\nProof . 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 . \n\nDefinition weqneqh { X : UU } ( is : isdeceq X ) ( x x' : X ) : weq ( neg ( paths x x' ) ) ( neqh is x x' ) .\nProof . 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 .\n\n\n \n\n(** *** Boolean representation of decidable relations *)\n\n\nDefinition decrel ( X : UU ) := total2 ( fun R : hrel X => isdecrel R ) .\nDefinition pr1decrel ( X : UU ) : decrel X -> hrel X := @pr1 _ _ .  \nDefinition decrelpair { X : UU } { R : hrel X } ( is : isdecrel R ) : decrel X := tpair _ R is .  \nCoercion pr1decrel : decrel >-> hrel . \n\nDefinition decreltobrel { X : UU } ( R : decrel X ) : brel X .\nProof . intros . intros x x' . destruct ( ( pr2 R ) x x' ) . apply true . apply false . Defined .\n\nDefinition breltodecrel { X : UU } ( B : brel X ) : decrel X := @decrelpair _ ( fun x x' => hProppair ( paths ( B x x' ) true ) ( isasetbool _ _ ) ) ( fun x x' => ( isdeceqbool _ _ ) ) .  \n \nDefinition pathstor { X : UU } ( R : decrel X ) ( x x' : X ) ( e : paths ( decreltobrel R x x' ) true ) : R x x' .\nProof . unfold decreltobrel . intros .  destruct ( pr2 R x x' ) as [ e' | ne ]  .  apply e' . destruct ( nopathsfalsetotrue e ) . Defined .  \n\nDefinition rtopaths  { X : UU } ( R : decrel X ) ( x x' : X ) ( r : R x x' ) : paths ( decreltobrel R x x' ) true  .\nProof . unfold decreltobrel .  intros . destruct ( ( pr2 R ) x x' ) as [ r' | nr ] . apply idpath .  destruct ( nr r ) . Defined .   \n\nDefinition pathstonegr { X : UU } ( R : decrel X ) ( x x' : X ) ( e : paths ( decreltobrel R x x' ) false ) : neg ( R x x' ) .\nProof . unfold decreltobrel . intros .  destruct ( pr2 R x x' ) as [ e' | ne ] .  destruct ( nopathstruetofalse e ) . apply ne .  Defined . \n\nDefinition negrtopaths { X : UU } ( R : decrel X ) ( x x' : X ) ( nr : neg ( R x x' ) ) : paths ( decreltobrel R x x' ) false .\nProof . unfold decreltobrel . intros .   destruct ( pr2 R x x' ) as [ r | nr' ] . destruct ( nr r ) . apply idpath. Defined .   \n\n\n(** 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 ] .  \n\nDefinition pathstor_comp { X : UU } ( R : decrel X ) ( x x' : X ) ( e : paths ( decreltobrel R x x' ) true ) : R x x' .\nProof . unfold decreltobrel . intros .  destruct ( pr2 R x x' ) as [ e' | ne ]  .  apply e' . destruct ( nopathsfalsetotrue e ) . Defined .  \n\nNotation \" 'ct' ( R , x , y ) \" := ( ( pathstor_comp _ x y ( idpath true ) ) : R x y ) (at level 70 ) . \n\n*)\n\nDefinition ctlong { X : UU } ( R : hrel X ) ( is : isdecrel R ) ( x x' : X ) ( e : paths ( decreltobrel (decrelpair is ) x x' ) true ) : R x x' .\nProof . unfold decreltobrel . intros .  simpl in e .  destruct ( is x x' ) as [ e' | ne ]  .  apply e' . destruct ( nopathsfalsetotrue e ) . Defined .  \n\nNotation \" 'ct' ( R , is , x , y ) \" := ( ctlong R is x y ( idpath true ) ) ( at level 70 ) .  \n\n(** **** Restriction of a relation to a subtype *)\n\nDefinition resrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) : hrel P := fun p1 p2 => L ( pr1 p1 ) ( pr1 p2 ) .\n\nDefinition istransresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : istrans L ) : istrans ( resrel L P ) .\nProof . intros . intros x1 x2 x3 r12 r23 . apply ( isl _ ( pr1 x2 ) _ r12 r23 ) . Defined . \n\nDefinition isreflresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X )  ( isl : isrefl L ) : isrefl ( resrel L P ) . \nProof . intros . intro x . apply isl . Defined . \n\nDefinition issymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : issymm L ) : issymm ( resrel L P ) . \nProof . intros . intros x1 x2 r12 . apply isl . apply r12 .  Defined .  \n\nDefinition isporesrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : ispo L ) : ispo ( resrel L P ) . \nProof . intros . apply ( dirprodpair ( istransresrel L P ( pr1 isl ) ) ( isreflresrel L P ( pr2 isl ) ) ) . Defined . \n\nDefinition iseqrelresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : iseqrel L ) : iseqrel ( resrel L P ) . \nProof . intros . apply ( dirprodpair ( isporesrel L P ( pr1 isl ) ) ( issymmresrel L P ( pr2 isl ) ) ) . Defined . \n\nDefinition isirreflresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isirrefl L ) : isirrefl ( resrel L P ) .\nProof . intros . intros x r . apply ( isl _ r ) . Defined .   \n\nDefinition isasymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isasymm L ) : isasymm ( resrel L P ) . \nProof . intros . intros x1 x2 r12 r21 . apply ( isl _ _ r12 r21 ) .  Defined . \n\nDefinition iscoasymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : iscoasymm L ) : iscoasymm ( resrel L P ) . \nProof . intros . intros x1 x2 r12 . apply ( isl _ _ r12 ) . Defined . \n\nDefinition istotalresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : istotal L ) : istotal ( resrel L P ) . \nProof . intros . intros x1 x2 . apply isl . Defined . \n\nDefinition iscotransresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : iscotrans L ) : iscotrans ( resrel L P ) . \nProof . intros . intros x1 x2 x3 r13 . apply ( isl _ _ _ r13 ) .  Defined .\n\nDefinition isdecrelresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isdecrel L ) : isdecrel ( resrel L P ) . \nProof . intros . intros x1 x2 . apply isl . Defined . \n\nDefinition isnegrelresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isnegrel L ) : isnegrel ( resrel L P ) . \nProof . intros . intros x1 x2 nnr . apply ( isl _ _ nnr ) . Defined . \n\nDefinition isantisymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isantisymm L ) : isantisymm ( resrel L P ) .\nProof . intros . intros x1 x2 r12 r21 . apply ( invmaponpathsincl _ ( isinclpr1carrier _ ) _ _ ( isl _ _ r12 r21  ) ) . Defined .  \n\nDefinition isantisymmnegresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : isantisymmneg L ) : isantisymmneg ( resrel L P ) .\nProof . intros . intros x1 x2 nr12 nr21 . apply (  invmaponpathsincl _ ( isinclpr1carrier _ ) _ _ ( isl _ _ nr12 nr21 ) ) . Defined .  \n\nDefinition iscoantisymmresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : iscoantisymm L ) : iscoantisymm ( resrel L P ) .\nProof . intros . intros x1 x2 r12 . destruct ( isl _ _ r12 ) as [ l | e ] . apply ( ii1 l ) .  apply ii2 .  apply (  invmaponpathsincl _ ( isinclpr1carrier _ ) _ _ e ) . Defined . \n\nDefinition  neqchoiceresrel { X : UU } ( L : hrel X ) ( P : hsubtypes X ) ( isl : neqchoice L ) : neqchoice ( resrel L P ) .\nProof . intros . intros x1 x2 ne .  set ( int := negf ( invmaponpathsincl _ ( isinclpr1carrier P ) _ _ ) ne ) . apply ( isl _ _ int ) . Defined . \n\n\n\n(** *** Equivalence classes with respect to a given relation *)\n\n\n\nDefinition 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 ) ).\nDefinition 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 ) . \n\nDefinition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X }  : iseqclass R A -> ishinh ( carrier A ) := fun is : iseqclass R A =>  pr1 is .\nDefinition 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) .\nDefinition 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) .\n\nLemma isapropiseqclass  { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : isaprop ( iseqclass R A ) .\nProof. intros. unfold iseqclass. apply isofhleveldirprod. apply (isapropishinh (carrier A)). apply isofhleveldirprod. apply impredtwice. intros t t' . apply impred. intro. apply impred.  intro.  \napply (pr2 (A t')).  apply impredtwice. intros. apply impred. intro. apply impred.  intro.  apply (pr2 (R t t')).  Defined. \n\n\n(** *** Direct product of equivalence classes *)\n\nLemma 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 ) .\nProof . intros . set ( XY := dirprod X Y ) . set ( AB := subtypesdirprod A B ) . set ( RQ := hreldirprod R Q ) . \nset ( ax0 := ishinhsubtypesdirprod  A B ( eqax0 isa ) ( eqax0 isb ) ) .\nassert ( 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 ) ) ) .    \nassert ( 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 ) ) ) .\napply ( iseqclassconstr _ ax0 ax1 ax2 ) . Defined .     \n\n\n\n\n\n\n\n(** ** Images and surjectivity for functions between types (both depend only on the behavior of the corresponding function between the sets of connected components) **)\n\nDefinition image { X Y : UU } ( f : X -> Y ) := total2 ( fun y : Y => ishinh ( hfiber f y ) ) .\nDefinition imagepair { X Y : UU } (f: X -> Y) := tpair ( fun y : Y => ishinh ( hfiber f y ) ) .\nDefinition pr1image { X Y : UU } ( f : X -> Y ) := @pr1 _  ( fun y : Y => ishinh ( hfiber f y ) ) .\n\n\nDefinition prtoimage { X Y : UU } (f : X -> Y) : X -> image f.\nProof. intros X Y f X0. apply (imagepair _ (f X0) (hinhpr _ (hfiberpair f X0 (idpath _ )))). Defined. \n\nDefinition issurjective { X Y : UU } (f : X -> Y ) := forall y:Y, ishinh (hfiber f y). \n\nLemma isapropissurjective { X Y : UU } ( f : X -> Y) : isaprop (issurjective f).\nProof. intros.  apply impred. intro t. apply  (pr2 (ishinh (hfiber f t))). Defined. \n\nLemma isinclpr1image { X Y : UU } (f:X -> Y): isincl (pr1image f).\nProof. intros. apply isofhlevelfpr1. intro. apply ( pr2 ( ishinh ( hfiber f x ) ) ) . Defined.\n\nLemma issurjprtoimage { X Y : UU } ( f : X -> Y) : issurjective (prtoimage f ).\nProof. intros. intro z.  set (f' := prtoimage f ). set (g:= pr1image f ). set (gf':= fun x:_ => g ( f' x )).\nassert (e: paths f gf'). apply etacorrection .  \nassert (ff: hfiber gf' (pr1 z) -> hfiber f' z).   apply ( invweq ( samehfibers _ _ ( isinclpr1image f ) z ) ) .  \nassert (is2: ishinh (hfiber gf' (pr1 z))). destruct e.  apply (pr2 z). \napply (hinhfun ff is2). Defined. \n\n\n(** *** Surjections to sets are epimorphisms  *)\n\nTheorem 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 ) .\nProof. intros . set (P1:= hProppair (paths (g1 y) (g2 y)) (is2 (g1 y) (g2 y))). unfold issurjective in is1. \nassert (s1: (hfiber f y)-> paths (g1 y) (g2 y)). intro X1. destruct X1 as [t x ]. induction x. apply (isf t). \nassert (s2: ishinh (paths (g1 y) (g2 y))). apply (hinhfun s1 (is1 y)).  \nset (is3:= is2 (g1 y) (g2 y)). simpl in is3. apply (@hinhuniv (paths (g1 y) (g2 y)) (hProppair _ is3)). intro X1.  assumption. assumption. Defined. \n\n(** *** The two-out-of-three properties of surjections *)\n\nLemma issurjcomp { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isf : issurjective f ) ( isg : issurjective g ) : issurjective ( funcomp f g ) .\nProof . intros . unfold issurjective .  intro z . apply ( fun ff => hinhuniv ff ( isg z ) ) . intro ye .  apply ( hinhfun ( hfibersftogf f g z ye ) ) .  apply ( isf ) .   Defined . \n\nNotation issurjtwooutof3c := issurjcomp . \n\nLemma issurjtwooutof3b { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isgf : issurjective ( funcomp f g ) ) : issurjective g .  \nProof . intros . unfold issurjective .  intro z .  apply ( hinhfun ( hfibersgftog f g z ) ( isgf z ) ) .  Defined . \n\n(** *** A function between hsets which is an inclusion and a surjection is a weak equivalence *)\n\nLemma isweqinclandsurj { X Y : hSet } ( f : X -> Y ) ( is1 : isincl f ) ( is1 : issurjective f ) : isweq f .\nProof . intros . unfold isweq . intro y . \n\nassert ( isp : isaprop ( hfiber f y ) ) . apply ( is1 y ) .\napply iscontraprop1 . apply isp . apply ( @hinhuniv _ ( hProppair _ isp ) ( idfun _ ) ( is0 y ) ) .  Defined .\n\n\n \n\n\n\n\n(** ** Set quotients of types. \n\nIn 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. \n\nOur 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.  \n\n\n*)\n\n\n\n(** ** Setquotient defined in terms of equivalence classes *)\n\n\nDefinition setquot { X : UU } ( R : hrel X ) := total2 ( fun A : _ => iseqclass R A ) .\nDefinition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) := tpair _ A is .\nDefinition pr1setquot { X : UU } ( R : hrel X ) : setquot R -> ( hsubtypes X ) := @pr1 _ ( fun A : _ => iseqclass R A ) .\nCoercion pr1setquot : setquot >-> hsubtypes . \n\nLemma isinclpr1setquot { X : UU } ( R : hrel X ) : isincl ( pr1setquot R ) .\nProof . intros . apply isinclpr1.  intro x0. apply isapropiseqclass. Defined .  \n\nDefinition setquottouu0 { X : UU } ( R : hrel X ) ( a : setquot R )  := carrier ( pr1 a ).\nCoercion setquottouu0 : setquot >-> Sortclass.\n\n\nTheorem isasetsetquot { X : UU } ( R : hrel X ) : isaset ( setquot R ) .\nProof. intros.  apply ( isasetsubset ( @pr1 _ _ )  ( isasethsubtypes X )  ) . apply isinclpr1.  intro.  apply isapropiseqclass.  Defined. \n\nDefinition setquotinset { X : UU } ( R : hrel X ) : hSet := hSetpair _ ( isasetsetquot R ) . \n\nTheorem setquotpr { X : UU } ( R : eqrel X ) : X -> setquot R.\nProof. 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))).  \nassert (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.\nassert (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). \nassumption. Defined. \n\nLemma setquotl0 { X : UU } ( R : eqrel X ) ( c : setquot R ) ( x : c ) : paths ( setquotpr R ( pr1 x ) ) c .\nProof . 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 . \n\n\n\nTheorem issurjsetquotpr { X : UU } ( R : eqrel X)  : issurjective (setquotpr R ).\nProof. intros. unfold issurjective. intro c.   apply ( @hinhuniv ( carrier ( pr1 c ) ) ) .  intro x . apply hinhpr .  split with ( pr1 x ) . apply setquotl0 .  apply ( eqax0 ( pr2 c ) ) .  \nDefined . \n\nLemma iscompsetquotpr { X : UU } ( R : eqrel X ) ( x x' : X ) ( a : R x x' ) : paths ( setquotpr R x ) ( setquotpr R x' ) .\nProof. 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 .  \n\n\n\n\n\n(** *** Universal property of [ seqtquot R ] for functions to sets satisfying compatibility condition [ iscomprelfun ] *)\n\n\nDefinition iscomprelfun { X Y : UU } ( R : hrel X ) ( f : X -> Y ) := forall x x' : X , R x x' -> paths ( f x ) ( f x' ) .\n\nLemma iscomprelfunlogeqf { X Y : UU } { R L : hrel X } ( lg : hrellogeq L R ) ( f : X -> Y ) ( is : iscomprelfun L f ) : iscomprelfun R f .\nProof . intros . intros x x' r . apply ( is _ _ ( pr2 ( lg  _ _ ) r ) ) . Defined . \n\nLemma 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 ) ) ) .\nProof. 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 .  \n\n\nTheorem setquotuniv  { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( is : iscomprelfun R f ) ( c : setquot R ) : Y .\nProof. 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 . \n\n\n(** 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. *)\n\n\nTheorem 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 ) .\nProof. intros. unfold setquotuniv . unfold setquotpr .  simpl .  apply idpath .  Defined.\n\n\nTheorem weqpathsinsetquot { X : UU } ( R : eqrel X ) ( x x' : X ) : weq ( R x x' ) ( paths ( setquotpr R x ) ( setquotpr R x' ) ) .\nProof .  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 .\n\n\n\n(** *** Functoriality of [ setquot ] for functions mapping one relation to another *)\n\n\nDefinition 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' ) .\n\nLemma 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 .\nProof . intros . intros x x' r . apply ( is _ _ ( pr2 ( lg  _ _ ) r ) ) . Defined . \n\nLemma 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 .\nProof . intros . intros x x' r . apply ( ( pr1 ( lg _ _ ) ) ( is _ _ r ) ) . Defined . \n\nDefinition  setquotfun  { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> Y ) ( is : iscomprelrelfun RX RY f ) ( cx : setquot RX ) : setquot RY .\nProof . 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 . \n\nDefinition 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 ) ) .\nProof . intros . simpl . apply idpath .  Defined . \n\n\n\n(** *** Universal property of [ setquot ] for predicates of one and several variables *)\n\n\nTheorem setquotunivprop { X : UU } ( R : eqrel X ) ( P : setquot R -> hProp ) ( is : forall x : X , P ( setquotpr R x ) ) : forall c : setquot R ,  P c .\nProof . 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 . \n\n\nTheorem 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' .\nProof . 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 . \n\nTheorem 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''  .\nProof . 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 . \n\nTheorem 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''' .\nProof . 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 . \n\n\n\n\n(** 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 . *)\n\n\n\n\n(** *** The case when the function between quotients defined by [ setquotfun ] is a surjection , inclusion or a weak equivalence  *)\n\nLemma 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 ) .\nProof . intros . apply ( issurjtwooutof3b ( setquotpr RX ) ) . apply ( issurjcomp f ( setquotpr RY ) is ( issurjsetquotpr RY ) ) .   Defined . \n\n\nLemma 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 ) .\nProof . intros . apply isinclbetweensets . apply isasetsetquot .   apply isasetsetquot .\nassert ( 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 .  \napply ( 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 .\n\nDefinition 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 ) . \n\nDefinition  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 )  .\nProof . intros . set ( ff := setquotfun RX RY f is1 ) . split with ff .\nassert ( 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' ) .\n\nassert ( 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 ) ) . \n\nassert ( 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 ) ) .\n\napply ( gradth _ _ egf efg ) . Defined .\n\nDefinition 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 )  .\nProof . 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 . \n\n\n\n(** *** [ setquot ] with respect to the product of two relations *)\n\n\n\nDefinition setquottodirprod { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) ( cc : setquot ( eqreldirprod RX RY ) ) : dirprod ( setquot RX ) ( setquot RY ) .\nProof . 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 .   \n\nDefinition 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 ) ) ) . \n\n\nTheorem weqsetquottodirprod { X Y : UU } ( RX : eqrel X ) ( RY : eqrel Y ) : weq ( setquot ( eqreldirprod RX RY ) ) ( dirprod ( setquot RX ) ( setquot RY ) ) .\nProof . intros . set ( f := setquottodirprod  RX RY ) . set ( g := dirprodtosetquot RX RY ) . split with f .\n\nassert ( 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 .\n\nassert ( 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 . \n\napply ( gradth _ _ egf efg ) . Defined .  \n\n\n\n(** *** Universal property of [ setquot ] for functions of two variables *) \n\nDefinition 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' ) .\n\nLemma 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 .\nProof . 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 . \n\nLemma iscomprelfun2logeqf { X Y : UU } { L R : hrel X } ( lg : hrellogeq L R ) ( f : X -> X -> Y ) ( is : iscomprelfun2 L f ) : iscomprelfun2 R f .\nProof . intros . intros x x' x0 x0' r r0 . apply ( is _ _ _ _ ( ( pr2 ( lg _ _ ) ) r )  ( ( pr2 ( lg _ _ ) ) r0 ) ) . Defined .     \n\nDefinition setquotuniv2  { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) : Y .\nProof. intros .  set ( ff := fun xy : dirprod X X => f ( pr1 xy ) ( pr2 xy ) ) . set ( RR := hreldirprod R R ) . \nassert ( 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 .   \n\nTheorem 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' ) .\nProof. intros.   apply idpath .  Defined.\n\n\n\n(** *** Functoriality of [ setquot ] for functions of two variables mapping one relation to another *)\n\n\nDefinition 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' ) .\n\nLemma 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 .\nProof . 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 . \n\nLemma 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 .\nProof . intros . intros x x' x0 x0' r r0 . apply ( is _ _ _ _ ( ( pr2 ( lg _ _ ) ) r )  ( ( pr2 ( lg _ _ ) ) r0 ) ) . Defined .\n\nLemma 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 .\nProof . intros . intros x x' x0 x0' r r0 . apply ( ( pr1 ( lg _ _ ) ) ( is _ _ _ _ r r0 ) ) .  Defined .\n\nDefinition  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 .\nProof . 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 . \n\nTheorem 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' ) ) .\nProof. intros.   apply idpath .  Defined.\n\n\n\n(** *** Set quotients with respect to decidable equivalence relations have decidable equality *)\n\n\nTheorem isdeceqsetquot_non_constr { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) : isdeceq ( setquot R ) . \nProof . 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 . \n\nDefinition setquotbooleqint { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) ( x x' : X ) : bool .\nProof . intros . destruct ( pr1 ( is x x' ) ) . apply true . apply false . Defined .\n\nLemma  setquotbooleqintcomp { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) : iscomprelfun2 R ( setquotbooleqint R is ) .\nProof . 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 . \n\n\nDefinition 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 ) .\n\nLemma 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' . \nProof . 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 .  \n\nLemma 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 .\nProof . 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 . \n\nDefinition  isdeceqsetquot { X : UU } ( R : eqrel X ) ( is : forall x x' : X , isdecprop ( R x x' ) ) : isdeceq ( setquot R ) .\nProof . 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 . \n\n\n\n(** *** Relations on quotient sets \n\nNote 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 .  *)\n\nDefinition iscomprelrel { X : UU } ( R : hrel X ) ( L : hrel X ) := iscomprelfun2 R L .\n\nLemma 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 .\nProof . 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 . \n\nLemma iscomprelrellogeqf1 { X : UU } { R R' : hrel X } ( L : hrel X ) ( lg : hrellogeq R R' ) ( is : iscomprelrel R L ) : iscomprelrel R' L .\nProof . intros . apply ( iscomprelfun2logeqf lg L is ) .  Defined .\n\nLemma iscomprelrellogeqf2 { X : UU } ( R : hrel X ) { L L' : hrel X } ( lg : hrellogeq L L' ) ( is : iscomprelrel R L ) : iscomprelrel R L' .\nProof . 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 . \n\nDefinition quotrel  { X : UU } { R L : hrel X } ( is : iscomprelrel R L ) : hrel ( setquot R ) := setquotuniv2 R hPropset L is .\n\nLemma istransquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : istrans L ) : istrans ( quotrel is ) .\nProof . 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 .   \n\nLemma issymmquotrel  { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : issymm L ) : issymm ( quotrel is ) .\nProof . 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 .\n\nLemma isreflquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isrefl L ) : isrefl ( quotrel is ) .  \nProof . intros . unfold isrefl .  apply ( setquotunivprop R ) .   intro x .  apply ( isl x ) . Defined . \n\nLemma ispoquotrel  { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : ispo L ) : ispo ( quotrel is ) .\nProof . intros . split with ( istransquotrel is ( pr1 isl ) ) .  apply ( isreflquotrel is ( pr2 isl ) ) .  Defined . \n\nLemma iseqrelquotrel  { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : iseqrel L ) : iseqrel ( quotrel is ) .\nProof . intros . split with ( ispoquotrel is ( pr1 isl ) ) .  apply ( issymmquotrel is ( pr2 isl ) ) .  Defined . \n\nLemma isirreflquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isirrefl L ) : isirrefl ( quotrel is ) .  \nProof . intros . unfold isirrefl .  apply ( setquotunivprop R ( fun x => hProppair _ ( isapropneg (quotrel is x x) ) ) ) .   intro x .  apply ( isl x ) . Defined .   \n\nLemma isasymmquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isasymm L ) : isasymm ( quotrel is ) .\nProof . 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 .\n\nLemma iscoasymmquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : iscoasymm L ) : iscoasymm ( quotrel is ) .\nProof . 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 .\n\nLemma istotalquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : istotal L ) : istotal ( quotrel is ) .\nProof . intros .  unfold istotal . apply ( setquotuniv2prop R ( fun x1 x2 => hdisj _ _ ) ) .  intros x x' . intros r r' . apply ( isl x x' r r' ) . Defined .\n\nLemma iscotransquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : iscotrans L ) : iscotrans ( quotrel is ) .\nProof . 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 .\n\nLemma isantisymmquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isantisymm L ) : isantisymm ( quotrel is ) .\nProof . 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 .\n \nLemma isantisymmnegquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isantisymmneg L ) : isantisymmneg ( quotrel is ) .\nProof . 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 .\n\n(** 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.*)\n\n\nLemma 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'  .\nProof . 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 . \n\nLemma 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' ) .\nProof . 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 . \n\n\n(** Constructive proof of decidability of the quotient relation *)\n\n\nDefinition quotdecrelint { X : UU } { R : hrel X } ( L : decrel X ) ( is : iscomprelrel R ( pr1 L ) )  : brel ( setquot R ) .\nProof .    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 .\n\nDefinition 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' .\nProof . 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 .\n\nLemma isdecquotrel { X : UU } { R : eqrel X } { L : hrel X } ( is : iscomprelrel R L ) ( isl : isdecrel L ) : isdecrel ( quotrel is ) .\nProof . intros . apply ( isdecrellogeqf ( quotdecrelintlogeq ( decrelpair isl ) is ) ( pr2 ( breltodecrel ( quotdecrelint ( decrelpair isl ) is ) ) ) ) .  Defined .   \n\nDefinition decquotrel  { X : UU } { R : eqrel X } ( L : decrel X ) ( is : iscomprelrel R L ) : decrel ( setquot R ) := decrelpair ( isdecquotrel is ( pr2 L ) ) . \n\n\n\n(** *** Subtypes of quotients and quotients of subtypes *)\n\n\nDefinition reseqrel { X : UU } ( R : eqrel X ) ( P : hsubtypes X ) : eqrel P := eqrelpair _ ( iseqrelresrel R P ( pr2 R ) ) . \n\nLemma 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 ) ) .\nProof . intros . split .\n\nset ( 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 . \n\nintros p1 p2 r12 q1 . apply ( ( pr1 ( pr2 is ) ) _ _ r12 q1 ) . \n\nintros p1 p2 q1 q2 . apply ( ( pr2 ( pr2 is ) ) _ _ q1 q2 ) . Defined . \n\nDefinition fromsubquot { X : UU } ( R : eqrel X ) ( P : hsubtypes ( setquot R ) ) ( p : P )  : setquot ( resrel R ( funcomp ( setquotpr R ) P ) ) .\nProof . 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 .  \n\nDefinition tosubquot { X : UU } ( R : eqrel X ) ( P : hsubtypes ( setquot R ) ) : setquot ( resrel R ( funcomp ( setquotpr R ) P ) ) -> P .\nProof . 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 .  \n\nDefinition weqsubquot { X : UU } ( R : eqrel X ) ( P : hsubtypes ( setquot R ) ) : weq P ( setquot ( resrel R ( funcomp ( setquotpr R ) P ) ) ) .\nProof . 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 .\n\nassert ( 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 . \n\nassert ( 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 . \n\n(* Compilations hangs here if the next command is \"simpl.\" in 8.4-8.5-trunk *)\n\n  apply ( invmaponpathsincl _ ( isinclpr1 _ ( fun a => isapropiseqclass _ a ) ) ) .  apply idpath .  \n\napply ( gradth _ _ egf efg ) . Defined .\n\n(** Comment: unfortunetely [ weqsubquot ] is not as useful as it should be at moment due to the failure of the following code to work: \n\n[ 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 ) ) .  \nProof . intros . apply idpath . Defined . ]\n\nAs one of the consequences we are forced to use a \"hack\" in the definition of multiplicative inverses for rationals in [ hqmultinv ] .\n\nThe 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 ]. \n\nIt can and probably should be fixed by the addition of a new componenet to CIC in the form of a term constructor:\n\ntfc ( X : Type ) ( E : X -> Type ) ( is : forall x , iscontr ( E x ) ) ( x0 : X ) ( e0 : E x0 ) : forall x : X , E x . \n\nand a computation rule\n\ntfc_comp ( tfc X E is x0 e0 x0 ) == e0 \n\n(with both tfc and tfc_comp definable in an arbitrary context)\n\nSuch 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 ) ] ) :\n\nLemma proofirrelevance { X : UU } ( is : isaprop X ) : forall x1 x2 , paths x1 x2 .\nProof . intros X is x1 . apply ( tfc X ( fun x2 => paths x1 x2 ) is x1 ( idpath x1 ) ) . Defined . \n\nDefined 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 ) ]. *)\n\n\n\n\n(** *** The set of connected components of type. *)\n\n\n\nDefinition pathshrel ( X : UU ) := fun x x' : X  =>  ishinh ( paths x x' )  .\nDefinition 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 .\nDefinition isreflpathshrel ( X : UU ) : isrefl ( pathshrel X ) := fun x : _ =>  hinhpr _ ( idpath x ) .\nDefinition issymmpathshrel ( X : UU ) : issymm ( pathshrel X ) := fun x x': _ => fun a : _ => hinhfun ( fun e : paths x x' => pathsinv0 e ) a . \n\nDefinition pathseqrel ( X : UU ) := eqrelconstr ( pathshrel X ) ( istranspathshrel X ) ( isreflpathshrel X ) ( issymmpathshrel X ) . \n\nDefinition pi0 ( X : UU ) := setquot ( pathshrel X ) . \nDefinition pi0pr ( X : UU ) := setquotpr ( pathseqrel X ) .\n\n\n\n\n\n\n\n\n\n(** **  Set quotients. Construction 2. \n\n\n****************** THIS SECTION IS UNFINISHED ******************\n\n\nAnother 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.\n\n\nWe 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). *)\n\n\n\n\n(** *** Functions compatible with a relation *)\n\n\n\n\nDefinition compfun { X : UU }  ( R : hrel X ) ( S : UU ) : UU := total2  (fun F: X -> S => iscomprelfun R F ) . \nDefinition compfunpair { X : UU }  ( R : hrel X ) { S : UU } ( f : X -> S ) ( is : iscomprelfun R f ) : compfun R S := tpair _ f is .\nDefinition pr1compfun ( X : UU )  ( R : hrel X ) ( S : UU ) : @compfun X R S -> ( X -> S ) := @pr1 _ _ .\nCoercion pr1compfun : compfun >-> Funclass .   \n\nDefinition 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.\n\nDefinition compfuncomp { X : UU }  ( R : hrel X ) { S S' : UU } ( f : compfun R S ) ( g : S -> S' ) : compfun R S' .\nProof . intros . split with ( funcomp f g ) . intros x x' r .  apply ( maponpaths g ( pr2 f x x' r ) ) . Defined . \n\n\n(** Tests \n\nDefinition F ( X Y : UU ) ( R : hrel X ) := ( compfun R Y ) -> Y .\n\nDefinition Fi ( X Y : UU ) ( R : hrel X ) : X -> F X Y R := fun x => fun f => f x .\n\nLemma iscompFi { X Y : UU } ( R : hrel X ) : iscomprelfun R ( Fi X Y R ) .\nProof . intros . intros x x' r . unfold Fi . apply funextfun .  intro f . apply ( pr2 f x x' r ) .  Defined . \n\nDefinition Fv { X Y : UU } ( R : hrel X ) ( f : compfun R Y ) ( phi : F X Y R ) : Y := phi f . \n\nDefinition 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 ) ) .  \n\nLemma 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 ) ) ) .\nProof . intros . apply isinclpr1 .  intro phi .  apply impred . intro psi .  apply ( pr2 Y ) . Defined.  \n\nDefinition toqeq { X Y : UU } ( R : hrel X ) ( x : X ) : @qeq X Y R .\nProof . intros . split with ( Fi X Y R x ) . intro psi. apply idpath . Defined . \n\nLemma iscomptoqeq  { X : UU } ( Y : hSet ) ( R : hrel X ) : iscomprelfun R ( @toqeq X Y R ) .\nProof . intros . intros x x' r . unfold toqeq . apply ( invmaponpathsincl _ ( isinclpr1qeq R Y ) ) . apply (  @iscompFi X Y R x x' r ) . Defined . \n\nDefinition qequniv { X : UU } ( Y : hSet ) ( R : hrel X ) ( f : compfun R Y ) ( phi : @qeq X Y R ) : Y .\nProof . intros . apply ( Fv R f ( pr1 phi ) ) . Defined.\n\nLemma qequnivandpr { X : UU } ( Y : hSet ) ( R : hrel X ) ( f : compfun R Y ) ( x : X ) : paths ( qequniv Y R f ( toqeq R x ) ) ( f x ) .\nProof . intros . apply idpath . Defined .  \n\nLemma 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 ) .  \nProof .  intros . apply ( pr2 phi psi ) .  \n\n\n\n\nDefinition Fd1 { X Y : UU } : F X Y R -> ( F ( F X Y ) Y ) := Fi ( F X Y ) Y . \n\nDefinition 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 ) . \n\nDefinition Ffunct { X1 X2 : UU } ( f : X1 -> X2 ) ( Y : UU ) : F X1 Y -> F X2 Y := fun phi => fun g => phi ( funcomp f g ) . \n\n\n\nLemma testd1 { X Y : UU } ( psi : F X Y -> Y ) ( phi : F X Y ) : paths ( psi phi ) ( Fd1 phi psi )  .  \nProof . intros . apply idpath . Defined . \n\nLemma testd2 { X Y : UU } ( psi : F X Y -> Y ) ( phi : F X Y ) : paths ( Fv ( funcomp ( Fi X Y ) psi ) phi ) ( Fd2 phi psi )  .\nProof . intros . apply idpath . Defined .  \n\nDefinition F ( X Y : UU ) := ( X -> Y ) -> Y .\n\nDefinition Ffunct { X1 X2 : UU } ( f : X1 -> X2 ) ( Y : UU ) : F X1 Y -> F X2 Y := fun phi => fun g => phi ( funcomp f g ) . \n\nDefinition Fi ( X Y : UU ) : X -> F X Y := fun x => fun f => f x .\n\nDefinition Fd1 { X Y : UU } : F X Y -> ( F ( F X Y ) Y ) := Fi ( F X Y ) Y . \n\nDefinition Fd2 { X Y : UU } : F X Y -> ( F ( F X Y ) Y ) := Ffunct ( Fi X Y ) Y .\n\nDefinition Fv { X Y : UU } ( f : X -> Y ) ( phi : F X Y ) : Y := phi f .  \n\nLemma testd1 { X Y : UU } ( psi : F X Y -> Y ) ( phi : F X Y ) : paths ( psi phi ) ( Fd1 phi psi )  .  \nProof . intros . apply idpath . Defined . \n\nLemma testd2 { X Y : UU } ( psi : F X Y -> Y ) ( phi : F X Y ) : paths ( Fv ( funcomp ( Fi X Y ) psi ) phi ) ( Fd2 phi psi )  .\nProof . intros . apply idpath . Defined .  \n\n\n\n\n\nLemma Xineq ( X Y : UU ) ( x : X ) : paths ( Fd1 ( Fi X Y x ) ) ( Fd2 ( Fi X Y x ) ) .\nProof . intros . apply idpath . Defined .   \n\nLemma 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 ) ) .\nProof . intros . unfold Fd1 . unfold Fd2. unfold Fi . unfold Ffunct . unfold funcomp .    simpl .  apply ( maponpaths phi ) .  apply etacorrection . Defined . \n\nInductive 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' .\n\nDefinition 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 .\nProof . intros . destruct  X . apply idpath . Defined . \n\nDefinition try0map2  ( T : Type ) ( t : T ) ( t1 t2 : T ) ( e1 : paths t t1 ) ( e2 : paths t t2 ) : try0 T t t1 t2 e1 e2 .\nProof .     \n\n\nLemma test ( X : UU ) ( t : X ) : paths ( pr2 ( iscontrcoconustot X t ) (  pr1 ( iscontrcoconustot X t ) ) ) ( idpath _ ) .\nProof . intros . apply idpath . \n\n\nLemma test { X : UU } ( is : iscontr X ) : paths ( pr2 ( iscontrcor is ) ( pr1 ( iscontrcor is ) ) ) ( idpath _ ) . \nProof . intros . apply idpath . \n\n\n\n\nLemma 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 ) ) ) .   \nProof . intros . apply funextfun .  intro c . simpl . destruct c as [ A iseq ] .  simpl .  *)\n\n\n\n\n\n\n(** *** The quotient set of a type by a relation. *)\n\nDefinition setquot2 { X : UU } ( R : hrel X ) : UU := image  ( compevmapset R ) . \n\nTheorem isasetsetquot2 { X : UU } ( R : hrel X ) : isaset ( setquot2 R ) .\nProof. intros. \nassert (is1: isofhlevel 2 ( forall S: hSet, (compfun R S) -> S )).  apply impred.  intro.  apply impred.  intro X0.  apply (pr2 t).\napply (isasetsubset _ is1 (isinclpr1image _ )).  Defined.\n\nDefinition setquot2inset { X : UU } ( R : hrel X ) : hSet := hSetpair _ ( isasetsetquot2 R ) .  \n\n(** 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 . *)  \n\nDefinition setquot2pr { X : UU }  ( R : hrel X ) : X -> setquot2 R := fun x : X => imagepair ( compevmapset R ) _ ( hinhpr _ ( hfiberpair ( compevmapset R ) x ( idpath _ ) ) ) .\n\nLemma issurjsetquot2pr { X : UU } ( R : hrel X ) : issurjective ( setquot2pr R ) .\nProof. intros. apply issurjprtoimage. Defined.    \n\nLemma iscompsetquot2pr { X : UU } ( R : hrel X ) : iscomprelfun R ( setquot2pr R ) . \nProof. intros.  intros x x' r . \nassert (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 ) . \napply ( invmaponpathsincl _ ( isinclpr1image ( compevmapset R ) ) ( setquot2pr R x ) ( setquot2pr R x' ) e1 ) . Defined . \n\n\n(** *** Universal property of [ seqtquot2 R ] for functions to sets satisfying compatibility condition [ iscomprelfun ] *)\n\nDefinition 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 ) .  \n\nTheorem 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) .  \nProof. intros. apply idpath. Defined.\n\n(** *** Weak equivalence from [ R x x' ] to [ paths ( setquot2pr R x ) ( setquot2pr R x' ) ] *) \n\nLemma weqpathssetquot2l1 { X : UU } ( R : eqrel X ) ( x : X ) : iscomprelfun R ( fun x' => R x x' ) . \nProof . 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 . \n\nTheorem weqpathsinsetquot2 { X : UU } ( R : eqrel X ) ( x x' : X ) : weq ( R x x' ) ( paths ( setquot2pr R x ) ( setquot2pr R x' ) ) .\nProof .  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 . \n\n\n\n\n\n\n\n\n(* *** Comparison of setquot2 and setquot.  *)\n\n\n\nDefinition setquottosetquot2 (X: UU) (R: hrel X) (is: iseqrel R) : setquot R -> setquot2 R.\nProof. intros X R is X0. apply (setquotuniv R (hSetpair _ (isasetsetquot2 R)) (setquot2pr R) (iscompsetquot2pr R) X0).  Defined.\n\n\n\n\n\n\n\n\n\n\n(* End of the file hSet.v *)\n"
  },
  {
    "path": "hlevel2/hnat.v",
    "content": "(** * Natural numbers and their properties. Vladimir Voevodsky . Apr. - Sep. 2011  \n\nThis file contains the formulations and proofs of general properties of natural numbers from the univalent perspecive. *)\n\n\n\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *)\n\n\n\n(** Imports. *)\n\nAdd LoadPath \"../..\" .\n\nRequire Export Foundations.hlevel2.algebra1d . \n\n(** To up-stream files  *)\n\n\n\n(** ** Equality on [ nat ] *)\n\n\n(** *** Basic properties of [ paths ] on [ nat ] and the proofs of [ isdeceq ] and [ isaset ] for [ nat ] .  *) \n   \n\nLemma negpaths0sx ( x : nat ) : neg ( paths O (S x) ) .\nProof. intro. set (f:= fun n : nat => match n with O => true | S m => false end ) . apply ( negf ( @maponpaths _ _ f 0 ( S x ) ) nopathstruetofalse ) . Defined. \n\nLemma negpathssx0 ( x : nat ) : neg ( paths (S x) O ) .\nProof. intros x X. apply (negpaths0sx x (pathsinv0  X)). Defined. \n\nLemma invmaponpathsS ( n m : nat ) : paths ( S n ) ( S m ) -> paths n m .\nProof. 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.  \n\nLemma noeqinjS ( x x' : nat ) : neg ( paths x x' ) -> neg ( paths (S x) (S x') ) .\nProof. intros x x'. apply ( negf ( invmaponpathsS x x' ) ) .  Defined. \n \nDefinition isdeceqnat: isdeceq nat.\nProof. 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 . \n\nDefinition isisolatedn ( n : nat ) : isisolated _ n .\nProof. intro. unfold isisolated . intro x' . apply isdeceqnat . Defined. \n\nTheorem isasetnat: isaset nat.\nProof.  apply (isasetifdeceq _ isdeceqnat). Defined. \n\nDefinition natset : hSet := hSetpair _ isasetnat . \n(* Canonical Structure natset . *) \n\nDefinition nateq ( x y : nat ) : hProp := hProppair ( paths x y ) ( isasetnat _ _  )  .\nDefinition isdecrelnateq : isdecrel nateq  := fun a b => isdeceqnat a b .\nDefinition natdeceq : decrel nat := decrelpair isdecrelnateq . \n(* Canonical Structure natdeceq. *)\n\nDefinition natbooleq := decreltobrel natdeceq .  \n\nDefinition natneq ( x y : nat ) : hProp := hProppair ( neg ( paths x y ) ) ( isapropneg _  )  .\nDefinition isdecrelnatneq : isdecrel natneq  := isdecnegrel _ isdecrelnateq . \nDefinition natdecneq : decrel nat := decrelpair isdecrelnatneq . \n\n(* Canonical Structure natdecneq. *) \n\nDefinition natboolneq := decreltobrel natdecneq .  \n\n(** *** [ S : nat -> nat ] is a decidable inclusion . *)\n\nTheorem isinclS : isincl S .\nProof. apply ( isinclbetweensets S isasetnat isasetnat invmaponpathsS ) .  Defined .\n\nTheorem isdecinclS : isdecincl S .\nProof. 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 . \n\n\n(** ** Inequalities on [ nat ] . *)\n\n\n(** *** Boolean \"less or equal\" and \"greater or equal\" on [ nat ] . *)\n\nFixpoint natgtb (n m : nat) : bool :=\nmatch n , m with\n | S n , S m => natgtb n m\n | O, _ => false\n | _, _ => true\nend.\n\n\n\n(** *** Semi-boolean \"greater\" on [ nat ] or [ natgth ]  \n\n1. 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.\n2. 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\".   *) \n\n\nDefinition natgth ( n m : nat ) := hProppair ( paths ( natgtb n m ) true ) ( isasetbool _ _ ) . \n\nLemma negnatgth0n ( n : nat ) : neg ( natgth 0 n ) .\nProof. intro n . simpl . intro np . apply ( nopathsfalsetotrue np ) .  Defined . \n\nLemma natgthsnn ( n : nat ) : natgth ( S n ) n .\nProof . intro . induction n as [ | n IHn ] . simpl . apply idpath .   apply IHn . Defined .\n\nLemma natgthsn0 ( n : nat ) : natgth ( S n ) 0 .\nProof . intro . simpl . apply idpath .  Defined . \n\nLemma negnatgth0tois0 ( n : nat ) ( ng : neg ( natgth n 0 ) ) : paths n 0 .\nProof . intro. destruct n as [ | n ] . intro.   apply idpath.  intro ng .  destruct ( ng ( natgthsn0 _ ) ) . Defined . \n\nLemma natneq0togth0 ( n : nat ) ( ne : neg ( paths n 0 ) ) : natgth n 0 .\nProof . intros . destruct n as [ | n ] . destruct ( ne ( idpath _ ) ) .  apply natgthsn0 .  Defined . \n\nLemma nat1gthtois0 ( n : nat ) ( g : natgth 1 n ) : paths n 0 .\nProof . intro . destruct n as [ | n ] . intro . apply idpath . intro x .  destruct ( negnatgth0n n x ) .  Defined .\n\nLemma istransnatgth ( n m k : nat ) : natgth n m -> natgth m k -> natgth n k .\nProof. 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. \n\nLemma isirreflnatgth ( n : nat ) : neg ( natgth n n ) .\nProof. intro . induction n as [ | n IHn ] . apply ( negnatgth0n 0 ) .  apply IHn .  Defined . \n\nNotation negnatlthnn := isirreflnatgth . \n\nLemma natgthtoneq ( n m : nat ) ( g : natgth n m ) : neg ( paths n m ) .\nProof . intros . intro e . rewrite e in g . apply ( isirreflnatgth _ g ) . Defined .  \n\nLemma isasymmnatgth ( n m : nat ) : natgth n m -> natgth m n -> empty .\nProof. intros n m is is' . apply ( isirreflnatgth n ( istransnatgth _ _ _ is is' ) ) . Defined .  \n\nLemma isantisymmnegnatgth ( n m : nat ) : neg ( natgth n m ) -> neg ( natgth m n ) -> paths n m .\nProof . 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 .     \n\nLemma isdecrelnatgth : isdecrel natgth .\nProof. intros n m . apply ( isdeceqbool ( natgtb n m ) true ) .  Defined .\n\nDefinition natgthdec := decrelpair isdecrelnatgth .\n\n(* Canonical Structure natgthdec . *)\n\nLemma isnegrelnatgth : isnegrel natgth .\nProof . apply isdecreltoisnegrel . apply isdecrelnatgth . Defined . \n\nLemma iscoantisymmnatgth ( n m : nat ) : neg ( natgth n m ) -> coprod ( natgth m n ) ( paths n m ) .\nProof . apply isantisymmnegtoiscoantisymm . apply isdecrelnatgth .  intros n m . apply isantisymmnegnatgth . Defined .  \n\nLemma iscotransnatgth ( n m k : nat ) : natgth n k -> hdisj ( natgth n m ) ( natgth m k ) .\nProof . 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 .   \n\n\n\n\n(** *** Semi-boolean \"less\" on [ nat ] or [ natlth ] *)\n\nDefinition natlth ( n m : nat ) := natgth m n .\n\nDefinition negnatlthn0 ( n : nat ) : neg ( natlth n 0 ) := negnatgth0n n .\n\nDefinition natlthnsn ( n : nat ) : natlth n ( S n ) := natgthsnn n . \n\nDefinition negnat0lthtois0 ( n : nat ) ( nl : neg ( natlth 0 n ) ) : paths n 0 := negnatgth0tois0 n nl .\n\nDefinition natneq0to0lth ( n : nat ) ( ne : neg ( paths n 0 ) ) : natlth 0 n := natneq0togth0 n ne .\n\nDefinition natlth1tois0 ( n : nat ) ( l : natlth n 1 ) : paths n 0 := nat1gthtois0 _ l . \n\nDefinition istransnatlth ( n m k  : nat ) : natlth n m -> natlth m k -> natlth n k := fun lnm lmk => istransnatgth _ _ _ lmk lnm . \n\nDefinition isirreflnatlth ( n : nat ) : neg ( natlth n n ) := isirreflnatgth n . \n\nNotation negnatgthnn := isirreflnatlth . \n\nLemma natlthtoneq ( n m : nat ) ( g : natlth n m ) : neg ( paths n m ) .\nProof . intros . intro e . rewrite e in g . apply ( isirreflnatlth _ g ) . Defined .   \n\nDefinition isasymmnatlth ( n m : nat ) : natlth n m -> natlth m n -> empty := fun lnm lmn => isasymmnatgth _ _ lmn lnm .\n\nDefinition isantisymmnegnattth  ( n m : nat ) : neg ( natlth n m ) -> neg ( natlth m n ) -> paths n m := fun nlnm nlmn => isantisymmnegnatgth _ _ nlmn nlnm .\n\nDefinition isdecrelnatlth  : isdecrel natlth  := fun n m => isdecrelnatgth m n . \n\nDefinition natlthdec := decrelpair isdecrelnatlth .\n\n(* Canonical Structure natlthdec . *)\n\nDefinition isnegrelnatlth : isnegrel natlth := fun n m => isnegrelnatgth m n .\n\nDefinition iscoantisymmnatlth ( n m : nat ) : neg ( natlth n m ) -> coprod ( natlth m n ) ( paths n m ) .\nProof . intros n m nlnm . destruct ( iscoantisymmnatgth m n nlnm ) as [ l | e ] . apply ( ii1 l ) . apply ( ii2 ( pathsinv0 e ) ) . Defined . \n\nDefinition iscotransnatlth ( n m k : nat ) : natlth n k -> hdisj ( natlth n m ) ( natlth m k ) . \nProof . intros n m k lnk . apply ( ( pr1 islogeqcommhdisj ) ( iscotransnatgth _ _ _ lnk ) )  .  Defined .      \n\n\n\n(** *** Semi-boolean \"less or equal \" on [ nat ] or [ natleh ] *)\n\nDefinition natleh ( n m : nat ) := hProppair ( neg ( natgth n m ) ) ( isapropneg _ )  .\n\nDefinition natleh0tois0 ( n : nat ) ( l : natleh n 0 ) : paths n 0 := negnatgth0tois0 _ l .\n\nDefinition natleh0n ( n : nat ) : natleh 0 n := negnatgth0n _ .\n\nDefinition negnatlehsn0 ( n : nat ) : neg ( natleh ( S n ) 0 ) := todneg _ ( natgthsn0 n ) . \n\nDefinition negnatlehsnn ( n : nat ) : neg ( natleh ( S n ) n ) := todneg _ ( natgthsnn _ ) . \n\nDefinition  istransnatleh ( n m k : nat ) : natleh n m -> natleh m k -> natleh n k .\nProof. apply istransnegrel . unfold iscotrans. apply iscotransnatgth .  Defined.   \n\nDefinition isreflnatleh ( n : nat ) : natleh n n := isirreflnatgth n .  \n\nDefinition isantisymmnatleh ( n m : nat ) : natleh n m -> natleh m n -> paths n m := isantisymmnegnatgth n m .   \n\nDefinition isdecrelnatleh : isdecrel natleh := isdecnegrel _ isdecrelnatgth . \n\nDefinition natlehdec := decrelpair isdecrelnatleh .\n\n(* Canonical Structure natlehdec . *)\n\nDefinition isnegrelnatleh : isnegrel natleh .\nProof . apply isdecreltoisnegrel . apply isdecrelnatleh . Defined . \n\nDefinition iscoasymmnatleh ( n m : nat ) ( nl : neg ( natleh n m ) ) : natleh m n := negf ( isasymmnatgth _ _ ) nl . \n\nDefinition istotalnatleh : istotal natleh . \nProof . intros x y . destruct ( isdecrelnatleh x y ) as [ lxy | lyx ] . apply ( hinhpr _ ( ii1 lxy ) ) . apply hinhpr .   apply ii2 . apply ( iscoasymmnatleh _ _ lyx ) .   Defined . \n\n\n\n(** *** Semi-boolean \"greater or equal\" on [ nat ] or [ natgeh ] . *)\n\n\nDefinition natgeh ( n m : nat ) : hProp := hProppair ( neg ( natgth m n ) ) ( isapropneg _ ) .  \n\nDefinition nat0gehtois0 ( n : nat ) ( g : natgeh 0 n ) : paths n 0 := natleh0tois0 _ g . \n\nDefinition natgehn0 ( n : nat ) : natgeh n 0 := natleh0n n .  \n\nDefinition negnatgeh0sn ( n : nat ) : neg ( natgeh 0 ( S n ) ) := negnatlehsn0 n . \n\nDefinition negnatgehnsn ( n : nat ) : neg ( natgeh n ( S n ) ) := negnatlehsnn n . \n\nDefinition istransnatgeh ( n m k : nat ) : natgeh n m -> natgeh m k -> natgeh n k := fun gnm gmk => istransnatleh _ _ _ gmk gnm . \n\nDefinition isreflnatgeh ( n : nat ) : natgeh n n := isreflnatleh _ . \n\nDefinition isantisymmnatgeh ( n m : nat ) : natgeh n m -> natgeh m n -> paths n m := fun gnm gmn => isantisymmnatleh _ _ gmn gnm . \n\nDefinition isdecrelnatgeh : isdecrel natgeh := fun n m => isdecrelnatleh m n .\n\nDefinition natgehdec := decrelpair isdecrelnatgeh .\n\n(* Canonical Structure natgehdec . *)\n\nDefinition isnegrelnatgeh : isnegrel natgeh := fun n m => isnegrelnatleh m n . \n\nDefinition iscoasymmnatgeh ( n m : nat ) ( nl : neg ( natgeh n m ) ) : natgeh m n := iscoasymmnatleh _ _ nl . \n\nDefinition istotalnatgeh : istotal natgeh := fun n m => istotalnatleh m n .\n\n\n\n\n(** *** Simple implications between comparisons *)\n\nDefinition natgthtogeh ( n m : nat ) : natgth n m -> natgeh n m .\nProof. intros n m g . apply iscoasymmnatgeh . apply ( todneg _ g ) . Defined .\n\nDefinition natlthtoleh ( n m : nat ) : natlth n m -> natleh n m := natgthtogeh _ _ . \n\nDefinition natlehtonegnatgth ( n m : nat ) : natleh n m -> neg ( natgth n m )  .\nProof. intros n m is is' . apply ( is is' ) .  Defined . \n\nDefinition  natgthtonegnatleh ( n m : nat ) : natgth n m -> neg ( natleh n m ) := fun g l  => natlehtonegnatgth _ _ l g .   \n\nDefinition natgehtonegnatlth ( n m : nat ) : natgeh n m -> neg ( natlth n m ) := fun gnm lnm => natlehtonegnatgth _ _ gnm lnm . \n\nDefinition natlthtonegnatgeh ( n m : nat ) : natlth n m -> neg ( natgeh n m ) := fun gnm lnm => natlehtonegnatgth _ _ lnm gnm .  \n\nDefinition negnatlehtogth ( n m : nat ) : neg ( natleh n m ) -> natgth n m := isnegrelnatgth n m .   \n\nDefinition negnatgehtolth ( n m : nat ) : neg ( natgeh n m ) -> natlth n m := isnegrelnatlth n m .\n\nDefinition negnatgthtoleh ( n m : nat ) : neg ( natgth n m ) -> natleh n m .\nProof . intros n m ng . destruct ( isdecrelnatleh n m ) as [ l | nl ] . apply l . destruct ( nl ng ) .  Defined . \n\nDefinition negnatlthtogeh ( n m : nat ) : neg ( natlth n m ) -> natgeh n m := fun nl => negnatgthtoleh _ _ nl . \n\n\n(* *** Simple corollaries of implications *** *)\n\nDefinition natlehnsn ( n : nat ) : natleh n ( S n ) := natlthtoleh _ _ ( natgthsnn n ) .  \n\nDefinition natgehsnn ( n : nat ) : natgeh ( S n ) n := natlehnsn n  .\n\n\n(** *** Comparison alternatives *)\n\n\nDefinition natgthorleh ( n m : nat ) : coprod ( natgth n m ) ( natleh n m ) .\nProof . intros . apply ( isdecrelnatgth n m ) .  Defined . \n\nDefinition natlthorgeh ( n m : nat ) : coprod ( natlth n m ) ( natgeh n m ) := natgthorleh _ _ .\n\nDefinition natneqchoice ( n m : nat ) ( ne : neg ( paths n m ) ) : coprod ( natgth n m ) ( natlth n m ) .\nProof . 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 . \n\nDefinition natlehchoice ( n m : nat ) ( l : natleh n m ) : coprod ( natlth n m ) ( paths n m ) .\nProof .  intros . destruct ( natlthorgeh n m ) as [ l' | g ] .  apply ( ii1 l' ) . apply ( ii2 ( isantisymmnatleh _ _ l g ) ) . Defined . \n\nDefinition natgehchoice ( n m : nat ) ( g : natgeh n m ) : coprod ( natgth n m ) ( paths n m ) .\nProof .  intros . destruct ( natgthorleh n m ) as [ g' | l ] .  apply ( ii1 g' ) . apply ( ii2 ( isantisymmnatleh _ _ l g ) ) .  Defined . \n\n\n\n\n(** *** Mixed transitivities *)\n\n\n\nLemma natgthgehtrans ( n m k : nat ) : natgth n m -> natgeh m k -> natgth n k .\nProof. 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. \n\nLemma natgehgthtrans ( n m k : nat ) : natgeh n m -> natgth m k -> natgth n k .\nProof. intros n m k gnm gmk . destruct ( natgehchoice n m gnm ) as [ g' | e ] . apply ( istransnatgth _ _ _ g' gmk ) .  rewrite e .  apply gmk . Defined. \n\nLemma natlthlehtrans ( n m k : nat ) : natlth n m -> natleh m k -> natlth n k .\nProof . intros n m k l1 l2 . apply ( natgehgthtrans k m n l2 l1 ) . Defined . \n\nLemma natlehlthtrans ( n m k : nat ) : natleh n m -> natlth m k -> natlth n k .\nProof . intros n m k l1 l2 . apply ( natgthgehtrans k m n l2 l1 ) . Defined . \n\n\n\n(** *** Two comparisons and [ S ] *)\n\nLemma natgthtogehsn ( n m : nat ) : natgth n m -> natgeh n ( S m ) .\nProof. 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 . \n\nLemma natgthsntogeh ( n m : nat ) : natgth ( S n ) m -> natgeh n m .\nProof. intros n m a . apply ( natgthtogehsn ( S n ) m a ) . Defined. (* PeWa *) \n\nLemma natgehtogthsn ( n m : nat ) : natgeh n m -> natgth ( S n ) m .\nProof . intros n m X . apply ( natgthgehtrans _ n _ ) .  apply natgthsnn . apply X . Defined.  (* New *)\n\nLemma natgehsntogth ( n m : nat ) : natgeh n ( S m ) -> natgth n m .\nProof. intros n m X . apply ( natgehgthtrans _ ( S m ) _ X ) .  apply natgthsnn . Defined .  (* New *)\n\nLemma natlthtolehsn ( n m : nat ) : natlth n m -> natleh ( S n ) m .\nProof. intros n m X . apply ( natgthtogehsn m n X ) . Defined .\n\nLemma natlehsntolth ( n m : nat ) : natleh ( S n ) m -> natlth n m .\nProof.  intros n m X . apply ( natgehsntogth m n X ) .   Defined . \n\nLemma natlehtolthsn ( n m : nat ) : natleh n m -> natlth n ( S m ) . \nProof. intros n m X . apply ( natgehtogthsn m n X ) .  Defined.\n\nLemma natlthsntoleh ( n m : nat ) : natlth n ( S m ) -> natleh n m .\nProof. intros n m a . apply ( natlthtolehsn n ( S m ) a ) . Defined. (* PeWa *) \n\n\n\n(** *** Comparsion alternatives and [ S ] *)\n\n\nLemma natlehchoice2 ( n m : nat ) : natleh n m -> coprod ( natleh ( S n ) m ) ( paths n m ) .\nProof . intros n m l . destruct ( natlehchoice n m l ) as [ l' | e ] .   apply ( ii1 ( natlthtolehsn _ _ l' ) ) . apply ( ii2 e ) .  Defined . \n\n\nLemma natgehchoice2 ( n m : nat ) : natgeh n m -> coprod ( natgeh n ( S m ) ) ( paths n m ) .\nProof . intros n m g . destruct ( natgehchoice n m g ) as [ g' | e ] .   apply ( ii1 ( natgthtogehsn _ _ g' ) ) . apply ( ii2 e ) . Defined . \n\n\nLemma natgthchoice2 ( n m : nat ) : natgth n m -> coprod ( natgth n ( S m ) ) ( paths n ( S m ) ) .\nProof.  intros n m g . destruct ( natgehchoice _ _ ( natgthtogehsn _ _ g ) ) as [ g' | e ] . apply ( ii1 g' ) .  apply ( ii2 e ) .  Defined . \n\n\nLemma natlthchoice2 ( n m : nat ) : natlth n m -> coprod ( natlth ( S n ) m ) ( paths ( S n ) m ) .\nProof.  intros n m l . destruct ( natlehchoice _ _ ( natlthtolehsn _ _ l ) ) as [ l' | e ] . apply ( ii1 l' ) .  apply ( ii2 e ) .   Defined . \n   \n\n\n\n\n\n(** ** Some properties of [ plus ] on [ nat ] *)\n\n(* Addition is defined in Init/Peano.v by the following code \n\nFixpoint plus (n m:nat) : nat :=\n  match n with\n  | O => m\n  | S p => S (p + m)\n  end\n\nwhere \"n + m\" := (plus n m) : nat_scope.\n*)\n\n\n(** *** The structure of the additive ablelian monoid on [ nat ] *) \n\n\nLemma natplusl0 ( n : nat ) : paths ( 0 + n ) n .\nProof . intros . apply idpath . Defined .  \n\nLemma natplusr0 ( n : nat ) : paths ( n + 0 ) n .\nProof . intro . induction n as [ | n IH n ] . apply idpath .  simpl . apply ( maponpaths S IH ) . Defined .\nHint Resolve natplusr0: natarith .\n\nLemma natplusnsm ( n m : nat ) : paths ( n + S m ) ( S n + m ) .\nProof. intro . simpl . induction n as [ | n IHn ] .  auto with natarith . simpl . intro . apply ( maponpaths S ( IHn m ) ) .  Defined . \nHint Resolve natplusnsm : natarith .\n\nLemma natpluscomm ( n m : nat ) : paths ( n + m ) ( m + n ) .\nProof. 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 . \nHint Resolve natpluscomm : natarith . \n\nLemma natplusassoc ( n m k : nat ) : paths ( ( n + m ) + k ) ( n + ( m + k ) ) .\nProof . intro . induction n as [ | n IHn ] . auto with natarith . intros . simpl .  apply ( maponpaths S ( IHn m k ) ) . Defined. \nHint Resolve natplusassoc : natarith .\n\nDefinition nataddabmonoid : abmonoid := abmonoidpair ( setwithbinoppair natset ( fun n m : nat => n + m ) ) ( dirprodpair ( dirprodpair natplusassoc ( @isunitalpair natset _ 0 ( dirprodpair natplusl0 natplusr0 ) ) ) natpluscomm ) .    \n\n\n\n\n(** *** Addition and comparisons  *)\n\n\n\n(** [ natgth ] *)\n\n\n\nDefinition natgthtogths ( n m : nat ) : natgth n m -> natgth ( S n ) m  .\nProof. intros n m is . apply ( istransnatgth _ _ _ ( natgthsnn n ) is ) . Defined .\n\nDefinition negnatgthmplusnm ( n m : nat ) : neg ( natgth m ( n + m ) ) .\nProof. intros . induction n as [ | n IHn ] .  apply isirreflnatgth . apply ( istransnatleh _ _ _ IHn ( ( natlthtoleh _ _ ( natlthnsn _ ) ) ) ) .  Defined . \n\nDefinition negnatgthnplusnm ( n m : nat ) : neg ( natgth n ( n + m ) ) .\nProof. intros . rewrite ( natpluscomm n m ) .  apply ( negnatgthmplusnm m n ) .  Defined . \n\nDefinition natgthandplusl ( n m k : nat ) : natgth n m -> natgth ( k + n ) ( k + m ) .\nProof. intros n m k l . induction k as [ | k IHk ] . assumption .  assumption .  Defined . \n\nDefinition natgthandplusr ( n m k : nat ) : natgth n m -> natgth ( n + k ) ( m + k ) .\nProof. intros . rewrite ( natpluscomm n k ) . rewrite ( natpluscomm m k ) . apply natgthandplusl . assumption . Defined . \n\nDefinition natgthandpluslinv  ( n m k : nat ) : natgth ( k + n ) ( k + m ) -> natgth n m  .\nProof. intros n m k l . induction k as [ | k IHk ] . assumption .  apply ( IHk l ) . Defined .\n\nDefinition natgthandplusrinv ( n m k : nat ) :  natgth ( n + k ) ( m + k ) -> natgth n m  . \nProof. intros n m k l . rewrite ( natpluscomm n k ) in l . rewrite ( natpluscomm m k ) in l . apply ( natgthandpluslinv _ _ _ l )  . Defined . \n \n\n(** [ natlth ] *)\n\n\nDefinition natlthtolths ( n m : nat ) : natlth n m -> natlth n ( S m ) := natgthtogths _ _ . \n\nDefinition negnatlthplusnmm ( n m : nat ) : neg ( natlth ( n + m ) m )  := negnatgthmplusnm _ _ .\n\nDefinition negnatlthplusnmn ( n m : nat ) : neg ( natlth ( n + m ) n )  := negnatgthnplusnm _ _ .\n\nDefinition natlthandplusl ( n m k : nat ) : natlth n m -> natlth ( k + n ) ( k + m )  := natgthandplusl _ _ _ . \n\nDefinition natlthandplusr ( n m k : nat ) : natlth n m -> natlth ( n + k ) ( m + k ) := natgthandplusr _ _ _ .\n\nDefinition natlthandpluslinv  ( n m k : nat ) : natlth ( k + n ) ( k + m ) -> natlth n m := natgthandpluslinv _ _ _ .\n\nDefinition natlthandplusrinv ( n m k : nat ) :  natlth ( n + k ) ( m + k ) -> natlth n m := natgthandplusrinv _ _ _ . \n\n\n\n(** [ natleh ] *)\n\n\nDefinition natlehtolehs ( n m : nat ) : natleh n m -> natleh n ( S m ) .  \nProof . intros n m is . apply ( istransnatleh _ _ _ is ( natlthtoleh _ _ ( natlthnsn _ ) ) ) . Defined .\n\nDefinition natlehmplusnm ( n m : nat ) : natleh m ( n + m )  := negnatlthplusnmm _ _  .\n\nDefinition natlehnplusnm ( n m : nat ) : natleh n ( n + m ) := negnatlthplusnmn _ _  .\n\nDefinition natlehandplusl ( n m k : nat ) : natleh n m -> natleh ( k + n ) ( k + m ) := negf ( natgthandpluslinv n m k )  . \n\nDefinition natlehandplusr ( n m k : nat ) : natleh n m -> natleh ( n + k ) ( m + k ) := negf ( natgthandplusrinv n m k )  . \n\nDefinition natlehandpluslinv  ( n m k : nat ) : natleh ( k + n ) ( k + m ) -> natleh n m := negf ( natgthandplusl n m k )  .  \n\nDefinition natlehandplusrinv ( n m k : nat ) :  natleh ( n + k ) ( m + k ) -> natleh n m :=  negf ( natgthandplusr n m k ) . \n\n\n\n\n(** [ natgeh ] *)\n\n\nDefinition natgehtogehs ( n m : nat ) : natgeh n m -> natgeh ( S n ) m := natlehtolehs _ _  .\n \nDefinition natgehplusnmm ( n m : nat ) : natgeh ( n + m ) m := negnatgthmplusnm _ _ .\n\nDefinition natgehplusnmn ( n m : nat ) : natgeh ( n + m ) n := negnatgthnplusnm _ _  . \n\nDefinition natgehandplusl ( n m k : nat ) : natgeh n m -> natgeh ( k + n ) ( k + m ) := negf ( natgthandpluslinv m n k ) .  \n\nDefinition natgehandplusr ( n m k : nat ) : natgeh n m -> natgeh ( n + k ) ( m + k ) := negf ( natgthandplusrinv m n k )  . \n\nDefinition natgehandpluslinv  ( n m k : nat ) : natgeh ( k + n ) ( k + m ) -> natgeh n m := negf ( natgthandplusl m n k )  . \n\nDefinition natgehandplusrinv ( n m k : nat ) :  natgeh ( n + k ) ( m + k ) -> natgeh n m :=  negf ( natgthandplusr m n k ) . \n\n\n\n(* The following are included mainly for direct compatibility with the library hz.v *)\n\n\n\n(** *** Comparisons and [ n -> n + 1 ] *)\n\nDefinition natgthtogthp1 ( n m : nat ) : natgth n m -> natgth ( n + 1 ) m  .\nProof. intros n m is . destruct (natpluscomm 1 n) . apply (natgthtogths n m is). Defined. \n \nDefinition natlthtolthp1 ( n m : nat ) : natlth n m -> natlth n ( m + 1 ) := natgthtogthp1 _ _ . \n\nDefinition natlehtolehp1 ( n m : nat ) : natleh n m -> natleh n ( m + 1 ) .  \nProof . intros n m is . destruct (natpluscomm 1 m) . apply (natlehtolehs n m is). Defined. \n\nDefinition natgehtogehp1 ( n m : nat ) : natgeh n m -> natgeh ( n + 1 ) m := natlehtolehp1 _ _  .\n \n\n\n(** *** Two comparisons and [ n -> n + 1 ] *)\n\nLemma natgthtogehp1 ( n m : nat ) : natgth n m -> natgeh n ( m + 1 ) .\nProof. intros n m is . destruct (natpluscomm 1 m) . apply (natgthtogehsn n m is). Defined . \n\n\nLemma natgthp1togeh ( n m : nat ) : natgth ( n + 1 ) m -> natgeh n m .\nProof.   intros n m is . destruct (natpluscomm 1 n) . apply ( natgthsntogeh n m is). Defined. (* PeWa *) \n\nLemma natlehp1tolth ( n m : nat ) : natleh ( n + 1 )  m -> natlth n m .\nProof.  intros n m is . destruct (natpluscomm 1 n) . apply (natlehsntolth n m is).  Defined . \n\nLemma natlthtolehp1 ( n m : nat ) : natlth n m -> natleh ( n + 1 )  m .\nProof. intros n m is . destruct (natpluscomm 1 n) . apply (natlthtolehsn n m is). Defined .\n\nLemma natlthp1toleh ( n m : nat ) : natlth n ( m + 1 ) -> natleh n m .\nProof. intros n m is . destruct (natpluscomm 1 m) . apply (natlthsntoleh n m is). Defined. (* PeWa *) \n\nLemma natgehp1togth ( n m : nat ) : natgeh n ( m + 1 ) -> natgth n m .\nProof. intros n m is . destruct (natpluscomm 1 m) . apply (natgehsntogth n m is). Defined .  \n\n\n(** *** Comparsion alternatives and [ n -> n + 1 ] *)\n\n\nLemma natlehchoice3 ( n m : nat ) : natleh n m -> coprod ( natleh ( n + 1 )  m ) ( paths n m ) .\nProof . intros n m l . destruct ( natlehchoice n m l ) as [ l' | e ] .   apply ( ii1 ( natlthtolehp1 _ _ l' ) ) . apply ( ii2 e ) .  Defined . \n\n\nLemma natgehchoice3 ( n m : nat ) : natgeh n m -> coprod ( natgeh n ( m + 1 ) ) ( paths n m ) .\nProof . intros n m g . destruct ( natgehchoice n m g ) as [ g' | e ] .   apply ( ii1 ( natgthtogehp1 _ _ g' ) ) . apply ( ii2 e ) . Defined . \n\n\nLemma natgthchoice3 ( n m : nat ) : natgth n m -> coprod ( natgth n ( m + 1 ) ) ( paths n ( m + 1 ) ) .\nProof.  intros n m g . destruct ( natgehchoice _ _ ( natgthtogehp1 _ _ g ) ) as [ g' | e ] . apply ( ii1 g' ) .  apply ( ii2 e ) .  Defined . \n\n\nLemma natlthchoice3 ( n m : nat ) : natlth n m -> coprod ( natlth ( n + 1 )  m ) ( paths ( n + 1 )  m ) .\nProof.  intros n m l . destruct ( natlehchoice _ _ ( natlthtolehp1 _ _ l ) ) as [ l' | e ] . apply ( ii1 l' ) .  apply ( ii2 e ) .   Defined . \n   \n\n\n\n\n\n\n\n(** *** Cancellation properties of [ plus ] on [ nat ] *)\n\nLemma pathsitertoplus ( n m : nat ) : paths ( iteration S n m ) ( n + m ) .\nProof. intros .  induction n as [ | n IHn ] . apply idpath . simpl .  apply ( maponpaths S IHn ) .  Defined .\n\nLemma isinclnatplusr ( n : nat ) : isincl ( fun m : nat => m + n ) .\nProof. 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. \n\nLemma isinclnatplusl ( n : nat ) : isincl ( fun m : nat => n + m ) .\nProof. intro .  apply ( isofhlevelfhomot 1 _ _ ( fun m : nat => natpluscomm m n ) ( isinclnatplusr n ) ) . Defined . \n\nLemma natplusrcan ( a b c : nat ) ( is : paths ( a + c ) ( b + c ) ) : paths a b .\nProof . intros . apply ( invmaponpathsincl _ ( isinclnatplusr c ) a b ) . apply is . Defined .  \n\nLemma natpluslcan ( a b c : nat ) ( is : paths ( c + a ) ( c + b ) ) : paths a b .\nProof . intros . rewrite ( natpluscomm _ _ ) in is . rewrite ( natpluscomm c b ) in is . apply ( natplusrcan a b c  is ) .  Defined .   \n\n\nLemma iscontrhfibernatplusr ( n m : nat ) ( is : natgeh m n ) : iscontr ( hfiber ( fun i : nat => i + n ) m ) .\nProof. 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 . \n\nLemma neghfibernatplusr ( n m : nat ) ( is : natlth m n ) : neg ( hfiber  ( fun i : nat => i + n ) m ) .\nProof. intros. intro h . destruct h as [ i e ] . rewrite ( pathsinv0 e )  in is . destruct ( natlehtonegnatgth _ _ ( natlehmplusnm i n ) is ) .  Defined .    \n\nLemma isdecinclnatplusr ( n : nat ) : isdecincl ( fun i : nat => i + n ) .\nProof. 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 .  \n\n\n\n\n(** *** Some properties of [ minus ] on [ nat ] \n\nNote : minus is defined in Init/Peano.v by the following code:\n\nFixpoint minus (n m:nat) : nat :=\n  match n, m with\n  | O, _ => n\n  | S k, O => n\n  | S k, S l => k - l\n  end\n\nwhere \"n - m\" := (minus n m) : nat_scope.\n\n*)\n\n\nDefinition minuseq0 ( n m : nat ) ( is : natleh n m ) : paths ( n - m )%nat  0 .\nProof. 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. \n\nDefinition minusgeh0 ( n m : nat ) ( is : natgeh n m ) : natgeh ( n - m ) 0%nat.\nProof. intro . induction n as [ | n IHn ] . intros.  apply isreflnatgeh. intros .  apply natgehn0 . Defined. \n\nDefinition minusgth0 ( n m : nat ) ( is : natgth n m ) : natgth ( n - m ) 0%nat .\nProof . 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. \n\nDefinition minusgth0inv ( n m : nat ) ( is : natgth ( n - m ) 0%nat ) : natgth n m .\nProof . intro . induction n as [ | n IHn ] . intros .  destruct ( negnatgth0n _ is ) . intro . destruct m as [ | m ]. intros . apply natgthsn0.  intro . apply ( IHn m is ) . Defined. \n\n\n\nDefinition natminuseqn ( n : nat ) : paths ( n - 0 )%nat n .\nProof . intro. destruct n . apply idpath . apply idpath. Defined. \n\nDefinition natminuslehn ( n m : nat ) : natleh ( n - m ) n .\nProof . 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. \n\nDefinition natminuslthn ( n m : nat ) ( is : natgth n 0 ) ( is' : natgth m 0 ) : natlth ( n - m ) n .\nProof . 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. \n\nDefinition natminuslthninv (n m : nat ) ( is : natlth ( n - m ) n ) : natgth m 0 .\nProof. 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. \n\n\n\nDefinition minusplusnmm ( n m : nat ) ( is : natgeh n m ) : paths ( ( n - m ) + m ) n .\nProof . 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 . \n\nDefinition minusplusnmmineq ( n m : nat ) : natgeh ( ( n - m ) + m ) n .\nProof. intros. destruct ( natlthorgeh n m ) as [ lt | ge ] .  rewrite ( minuseq0 _ _ ( natlthtoleh _ _ lt ) ). apply ( natgthtogeh _ _ lt ) . rewrite ( minusplusnmm _ _ ge ) . apply isreflnatgeh . Defined. \n\nDefinition plusminusnmm ( n m : nat ) : paths ( ( n + m ) - m )%nat n .\nProof. intros . set ( int1 := natgehplusnmm n m ) . apply ( natplusrcan _ _ m ) .  rewrite ( minusplusnmm _ _ int1 ) .  apply idpath. Defined. \n\n\n(* *** Two-sided minus and comparisons *)\n\nDefinition natgehandminusr ( n m k : nat ) ( is : natgeh  n m ) : natgeh ( n - k ) ( m - k ) .\nProof. 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. \n\nDefinition natgehandminusl ( n m k : nat ) ( is : natgeh n m ) : natgeh ( n - k ) ( m - k ) .\nProof .  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. \n\nDefinition natgehandminusrinv ( n m k : nat ) ( is' : natgeh n k ) ( is : natgeh  ( n - k ) ( m - k ) ) : natgeh n m  .\nProof. 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. \n\n(*\n\nDefinition natgehandminuslinv ( n m k : nat ) ( is' : natgeh k n ) ( is : natleh  ( k - n ) ( k - m ) ) : natgeh n m  .\nProof. 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. \n\n\n\n\n\ninduction 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. \n\n\n\nDefinition natgthandminusinvr ( n m k : nat ) ( is : natgth n m ) ( is' : natgth n k ) : natgth ( n - k ) ( m - k ) .\nProof . 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. \n\n\n\nDefinition natlehandminusl ( n m k : nat ) ( is : natgeh n m ) : natleh ( k - n ) ( k - m ) .\nProof. 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. \n\nDefinition natlehandminusr \n\nDefinition natlthandminusl ( n m k : nat ) ( is : natgth n m ) ( is' : natgeh k n ) : natlth ( k - n ) ( k - m ) .\nProof. 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. \n\nDefinition natlehandminusl ( n m k : nat ) ( is : natgeh n m ) : natleh ( k - n ) ( k - m ) .\nProof. 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. \n\n\nDefinition natlehandminusl ( n m k : nat ) : ( natleh n m ) -> natgeh ( k - n ) ( k - m ) := natlehandminusl m n k . \n\nDefinition natlehandminusr ( n m k : nat ) : ( natleh n m ) -> natleh ( n - k ) ( m - k ) := natgehandminusr m n k .\n\n\n \n\n(* *** One sided minus and comparisons *)\n\n\n(* *** Greater or equal and minus *)\n\n\nDefinition natgehrightminus ( n m k : nat ) ( is : natgeh ( n + m ) k ) : natgeh n ( k - m ) .\nProof. intros . \n\nDefinition natgehrightplus ( n m k : nat ) ( is : natgeh ( n - m ) k ) : natgeh n ( k + m ) .\n\nDefinition natgehleftminus ( n m k : nat ) ( is : natgeh n ( m + k ) ) : natgeh ( n - k ) m .\n\nDefinition natgehleftplus ( n m k : nat ) ( is : natgeh n ( m - k ) ) : natgeh ( n + k ) m .\n\n\n(* **** Greater and minus *)\n\n\nDefinition natgthrightminus ( n m k : nat ) ( is : natgth ( n + m ) k ) : natgth n ( k - m ) .\nProof . intros. \n\nDefinition natgthrightplus ( n m k : nat ) ( is : natgth ( n - m ) k ) : natgth n ( k + m ) .\n\nDefinition natgthleftminus ( n m k : nat ) ( is : natgth n ( m + k ) ) : natgth ( n - k ) m .\n\nDefinition natgthleftplus ( n m k : nat ) ( is : natgth n ( m - k ) ) : natgth ( n + k ) m .\\\n\n\n(* **** Less and minus *)\n\n\nDefinition natlthrightminus ( n m k : nat ) ( is : natlth ( n + m ) k ) : natlth n ( k - m ) .\n\nDefinition natlthrightplus ( n m k : nat ) ( is : natlth ( n - m ) k ) : natlth n ( k + m ) .\n\nDefinition natlthleftminus ( n m k : nat ) ( is : natlth n ( m + k ) ) : natlth ( n - k ) m .\n\nDefinition natlthleftplus ( n m k : nat ) ( is : natlth n ( m - k ) ) : natlth ( n + k ) m .\n\n\n(* **** Less or equal and minus *)\n\n\nDefinition natlehrightminus ( n m k : nat ) ( is : natleh ( n + m ) k ) : natleh n ( k - m ) .\n\nDefinition natlehrightplus ( n m k : nat ) ( is : natleh ( n - m ) k ) : natleh n ( k + m ) .\n\nDefinition natlehleftminus ( n m k : nat ) ( is : natleh n ( m + k ) ) : natleh ( n - k ) m .\n\nDefinition natlehleftplus ( n m k : nat ) ( is : natleh n ( m - k ) ) : natleh ( n + k ) m .\n\n\n\n\n\n\n\n\n\n\n(* *** Mixed plus/minus associativities. \n\nThere 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. *)\n\nNotation natassocppeq := natplusassoc .\n\nDefinition natassocpmeq ( n m k : nat ) ( is : natgeh m k ) : paths (( n + m ) - k )%nat (n + ( m - k )).\nProof. 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. \n\nDefinition natassocpmineq ( n m k : nat ) : natleh (( n + m ) - k ) ( n + ( m - k )) .\nProof. intros n m k . destruct (natgthorleh k m) as [g | le]. \n\nset ( 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 .\n\nrewrite ( natassocpmeq _ _ _ le ) .  apply isreflnatleh . Defined.\n\n\nDefinition natassocmpeq ( n m k : nat ) ( isnm : natgeh n m ) ( ismk : natgeh m k ) : paths (( n - m ) + k )%nat (n - ( m - k ))%nat.\nProof. intros.  apply ( natplusrcan _ _ ( m - k ) ) . \n\nassert ( 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. \n\n\nDefinition natassocmpineq ( n m k : nat ) : natgeh (( n - m ) + k ) ( n - ( m - k )) .\nProof. intros n m k . destruct (natgthorleh k m) as [g | le]. \n\nset ( 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 ) .  \n\ndestruct ( 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 ) .  \n\ndestruct ( natgthorleh ( m - k ) n ) as [ g'' | le'' ] . rewrite ( minuseq0 n ( m - k ) ( natgthtogeh _ _ g'' ) ) .   apply ( natminuslehn  m k ) . rewrite ( minusplusnmm _ _ le'' ) .  apply ( natgthtogeh _ _ g' ) .  \n\nrewrite ( natassocmpeq _ _ _ le' le ) . apply isreflnatgeh .  Defined. \n\n\nDefinition natassocmmeq ( n m k : nat ) : paths (( n  - m ) - k )%nat (n - ( m + k ))%nat.\nProof. intros.  destruct ( natgthorleh ( m + k ) n ) as [ g | le ] . \n\nrewrite ( 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 \n\n\n\n\n\n\n\n\napply ( natplusrcan _ _ k ) . rewrite ( natplusassoc n _ k ) .  rewrite ( minusplusnmm _ k is ) .  set ( is' := istransnatgeh _ _ _ ( natgehplusnmm n m ) is ) . rewrite ( minusplusnmm _ k is' ) .apply idpath. Defined. \n\nDefinition natassocpmineq ( n m k : nat ) : natleh (( n + m ) - k ) ( n + ( m - k )) .\nProof. intros n m k . destruct (natgthorleh k m) as [g | le]. \n\nset ( 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 .\n\nrewrite ( natassocpmeq _ _ _ le ) .  apply isreflnatleh . Defined.\n\n \n\n\n\n*)\n\n\n\n\n\n\n(** ** Some properties of [ mult ] on [ nat ] \n\nNote : multiplication is defined in Init/Peano.v by the following code:\n\nFixpoint mult (n m:nat) : nat :=\n  match n with\n  | O => 0\n  | S p => m + p * m\n  end\n\nwhere \"n * m\" := (mult n m) : nat_scope.\n\n*)\n\n(** *** Basic algebraic properties of [ mult ] on [ nat ] *)\n\nLemma natmult0n ( n : nat ) : paths ( 0 * n ) 0 .\nProof. intro n . apply idpath . Defined . \nHint Resolve natmult0n : natarith .\n\nLemma natmultn0 ( n : nat ) : paths ( n * 0 ) 0 .\nProof. intro n . induction n as [ | n IHn ] . apply idpath . simpl .   assumption .  Defined . \nHint Resolve natmultn0 : natarith .\n\nLemma multsnm ( n m : nat ) : paths ( ( S n ) * m ) ( m + n * m ) .\nProof. intros . apply idpath . Defined .\nHint Resolve multsnm : natarith .\n\nLemma multnsm ( n m : nat ) : paths ( n * ( S m ) ) ( n + n * m ) .\nProof. 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 . \nHint Resolve multnsm : natarith .\n\nLemma natmultcomm ( n m : nat ) : paths ( n * m ) ( m * n ) .\nProof. 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 .\n\nLemma natrdistr ( n m k : nat ) : paths ( ( n + m ) * k ) ( n * k + m * k ) .\nProof . 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 . \n  \nLemma natldistr ( m k n : nat ) : paths ( n * ( m + k ) ) ( n * m + n * k ) .\nProof . 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 .\n\nLemma natmultassoc ( n m k : nat ) : paths ( ( n * m ) * k ) ( n * ( m * k ) ) .\nProof. 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 . \n\nLemma natmultl1 ( n : nat ) : paths ( 1 * n ) n .\nProof. simpl .  auto with natarith . Defined . \nHint Resolve natmultl1 : natarith .\n\nLemma natmultr1 ( n : nat ) : paths ( n * 1 ) n .\nProof. intro n . rewrite ( natmultcomm n 1 ) . auto with natarith . Defined . \nHint Resolve natmultr1 : natarith .\n\nDefinition natmultabmonoid : abmonoid :=  abmonoidpair ( setwithbinoppair natset ( fun n m : nat => n * m ) ) ( dirprodpair ( dirprodpair natmultassoc ( @isunitalpair natset _ 1 ( dirprodpair natmultl1 natmultr1 ) ) ) natmultcomm ) . \n\n    \n\n\n(** *** [ nat ] as a commutative rig *)\n\nDefinition natcommrig : commrig .\nProof . 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 .\n\n\n(** *** Cancellation properties of [ mult ] on [ nat ] *)\n\nDefinition natneq0andmult ( n m : nat ) ( isn : natneq n 0 ) ( ism : natneq m 0 ) : natneq ( n * m ) 0 .\nProof . intros . destruct n as [ | n ] . destruct ( isn ( idpath _ ) ) .  destruct m as [ | m ] .  destruct ( ism ( idpath _ ) ) . simpl . apply ( negpathssx0 ) .  Defined . \n\nDefinition natneq0andmultlinv ( n m : nat ) ( isnm : natneq ( n * m ) 0 ) : natneq n 0 := rigneq0andmultlinv natcommrig n m isnm . \n\nDefinition natneq0andmultrinv ( n m : nat ) ( isnm : natneq ( n * m ) 0 ) : natneq m 0 := rigneq0andmultrinv natcommrig n m isnm .\n\n\n\n(** *** Multiplication and comparisons  *)\n\n\n(** [ natgth ] *)\n\n\nDefinition natgthandmultl ( n m k : nat ) ( is : natneq k 0 ) : natgth n m -> natgth ( k * n ) ( k * m ) .\nProof. 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 .  \n\nDefinition natgthandmultr ( n m k : nat ) ( is : natneq k 0 ) : natgth n m -> natgth ( n * k ) ( m * k )  .\nProof . intros n m k l . rewrite ( natmultcomm n k ) . rewrite ( natmultcomm m k ) . apply ( natgthandmultl n m k l ) . Defined .\n\nDefinition natgthandmultlinv ( n m k : nat ) : natgth ( k * n ) ( k * m ) -> natgth n m .\nProof . 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 . \n\nDefinition natgthandmultrinv ( n m k : nat ) : natgth ( n * k ) ( m * k ) -> natgth n m .\nProof.  intros n m k g . rewrite ( natmultcomm n k ) in g . rewrite ( natmultcomm m k ) in g . apply ( natgthandmultlinv n m k g ) . Defined .\n\n\n\n(** [ natlth ] *)\n\n\nDefinition natlthandmultl ( n m k : nat ) ( is : natneq k 0 ) : natlth n m -> natlth ( k * n ) ( k * m )  := natgthandmultl _ _ _ is .\n\nDefinition natlthandmultr ( n m k : nat ) ( is : natneq k 0 ) : natlth n m -> natlth ( n * k ) ( m * k ) := natgthandmultr _ _ _ is .\n\nDefinition natlthandmultlinv ( n m k : nat ) : natlth ( k * n ) ( k * m ) -> natlth n m := natgthandmultlinv _ _ _  .\n\nDefinition natlthandmultrinv ( n m k : nat ) : natlth ( n * k ) ( m * k ) -> natlth n m := natgthandmultrinv _ _ _ .\n\n\n(** [ natleh ] *)\n\n\nDefinition natlehandmultl ( n m k : nat ) : natleh n m -> natleh ( k * n ) ( k * m ) := negf ( natgthandmultlinv _ _ _ ) .\n\nDefinition natlehandmultr ( n m k : nat ) : natleh n m -> natleh ( n * k ) ( m * k ) := negf ( natgthandmultrinv _ _ _ ) .\n\nDefinition natlehandmultlinv ( n m k : nat ) ( is : natneq k 0 ) : natleh ( k * n ) ( k * m ) -> natleh n m := negf ( natgthandmultl _ _ _ is )  .\n\nDefinition natlehandmultrinv ( n m k : nat ) ( is : natneq k 0 ) : natleh ( n * k ) ( m * k ) -> natleh n m := negf ( natgthandmultr _ _ _ is ) .\n\n\n(** [ natgeh ] *)\n\n\nDefinition natgehandmultl ( n m k : nat ) : natgeh n m -> natgeh ( k * n ) ( k * m ) := negf ( natgthandmultlinv _ _ _ ) .\n\nDefinition natgehandmultr ( n m k : nat ) : natgeh n m -> natgeh ( n * k ) ( m * k )  := negf ( natgthandmultrinv _ _ _ ) .\n\nDefinition natgehandmultlinv ( n m k : nat ) ( is : natneq k 0 ) : natgeh ( k * n ) ( k * m ) -> natgeh n m := negf ( natgthandmultl _ _ _ is )   .\n\nDefinition natgehandmultrinv ( n m k : nat ) ( is : natneq k 0 ) : natgeh ( n * k ) ( m * k ) -> natgeh n m := negf ( natgthandmultr _ _ _ is )  .\n\n\n\n\n\n\n(** *** Properties of comparisons in the terminology of  algebra1.v *)\n\nOpen Scope rig_scope.\n\n(** [ natgth ] *)\n\nLemma isplushrelnatgth : @isbinophrel nataddabmonoid natgth . \nProof . split . apply  natgthandplusl .  apply natgthandplusr .  Defined . \n\nLemma isinvplushrelnatgth : @isinvbinophrel nataddabmonoid natgth . \nProof . split . apply  natgthandpluslinv .  apply natgthandplusrinv .  Defined . \n\nLemma isinvmulthrelnatgth : @isinvbinophrel natmultabmonoid natgth . \nProof . split .  intros a b c r . apply ( natlthandmultlinv _ _ _ r ) .   intros a b c r .  apply ( natlthandmultrinv _ _ _ r ) .  Defined . \n\nLemma isrigmultgtnatgth : isrigmultgt natcommrig natgth .\nProof . 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 ) . \n\nintro 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 . \n\nLemma isinvrigmultgtnatgth : isinvrigmultgt natcommrig natgth .\nProof . 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 ] .  \n\nintros 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 .   \n\nintros 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 .  \n\n\n\n\n\n(** [ natlth ] *)\n\nLemma isplushrelnatlth : @isbinophrel nataddabmonoid natlth . \nProof . split . intros a b c . apply  ( natgthandplusl b a c ) . intros a b c . apply ( natgthandplusr b a c )  .  Defined . \n\nLemma isinvplushrelnatlth : @isinvbinophrel nataddabmonoid natlth . \nProof . split . intros a b c . apply  ( natgthandpluslinv b a c ) .  intros a b c . apply ( natgthandplusrinv b a c ) .  Defined . \n\nLemma isinvmulthrelnatlth : @isinvbinophrel natmultabmonoid natlth . \nProof . split . intros a b c r .  apply ( natlthandmultlinv  _ _ _ r ) .   intros a b c r .  apply ( natlthandmultrinv _ _ _ r ) .  Defined . \n\n(** [ natleh ] *)\n\nLemma isplushrelnatleh : @isbinophrel nataddabmonoid natleh . \nProof . split . apply natlehandplusl .  apply natlehandplusr . Defined . \n\nLemma isinvplushrelnatleh : @isinvbinophrel nataddabmonoid natleh . \nProof . split . apply natlehandpluslinv .  apply natlehandplusrinv . Defined . \n\nLemma ispartinvmulthrelnatleh : @ispartinvbinophrel natmultabmonoid ( fun x => natneq x 0 ) natleh . \nProof . split . intros a b c s r . apply ( natlehandmultlinv _ _ _ s r ) .   intros a b c s r .  apply ( natlehandmultrinv _ _ _ s r ) .  Defined . \n\n\n(** [ natgeh ] *)\n\nLemma isplushrelnatgeh : @isbinophrel nataddabmonoid natgeh . \nProof . split . intros a b c . apply ( natlehandplusl b a c ) .   intros a b c . apply ( natlehandplusr b a c ) . Defined . \n\nLemma isinvplushrelnatgeh : @isinvbinophrel nataddabmonoid natgeh . \nProof . split . intros a b c . apply ( natlehandpluslinv b a c ) .   intros a b c . apply ( natlehandplusrinv b a c ) . Defined . \n\nLemma ispartinvmulthrelnatgeh : @ispartinvbinophrel natmultabmonoid ( fun x => natneq x 0 ) natgeh . \nProof . split .  intros a b c s r . apply ( natlehandmultlinv _ _ _ s r ) .   intros a b c s r .  apply ( natlehandmultrinv _ _ _ s r ) .  Defined . \n\n\nClose Scope rig_scope . \n\n\n\n(** *** Submonoid of non-zero elements in [ nat ] *)\n\nDefinition natnonzero : @subabmonoids natmultabmonoid . \nProof . 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 . \n\nLemma natnonzerocomm ( a b : natnonzero ) : paths ( @op natnonzero a b ) ( @op natnonzero b a ) . \nProof . intros . apply ( invmaponpathsincl _ ( isinclpr1carrier _ ) ( @op natnonzero a b ) ( @op natnonzero b a ) ) .  simpl . apply natmultcomm . Defined . \n\n\n\n(** *** Division with a remainder on [ nat ] \n\nFor technical reasons it is more convenient to introduce divison with remainder for all pairs (n,m) including pairs of the form (n,0). *)\n\n\nDefinition natdivrem ( n m : nat ) : dirprod nat nat .\nProof. 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 . \n\nDefinition natdiv ( n m : nat )  := pr1 ( natdivrem n m ) .\nDefinition natrem ( n m : nat )  := pr2 ( natdivrem n m ) .\n\nLemma lthnatrem ( n m : nat ) ( is : natneq m 0 ) : natlth ( natrem n m ) m .\nProof. 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 . \n\n\nTheorem natdivremrule ( n m : nat ) ( is : natneq m 0 ) : paths n ( ( natrem n m ) + ( natdiv n m ) * m ) .\nProof. 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 ] . \n\nsimpl .  apply ( maponpaths S ( IHn m is ) ) .\n\nsimpl . 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'' . \nDefined . \n\nOpaque natdivremrule . \n\n\nLemma natlehmultnatdiv ( n m : nat ) ( is : natneq m 0 ) :  natleh ( mult ( natdiv n m ) m ) n .\nProof . intros . set ( e := natdivremrule n m ) . set ( int := ( natdiv n m ) * m ) . rewrite e . unfold int  .   apply ( natlehmplusnm _ _ ) .  apply is . Defined . \n\n\nTheorem 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' ) .\nProof. intros m i . induction i as [ | i IHi ] .\n\nintros 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 ) .\n\nintros 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' ) .  \n\nsimpl 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 . \n\nOpaque natdivremunique .\n\nLemma 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 ) ) ) . \nProof . 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 ) . \n\nsplit with ( pr1 int ) . \n\nrewrite ( natmultcomm k b ) . apply ( pr2 int ) .  Defined . \n\nOpaque natdivremandmultl .\n\n\nDefinition 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 ) .\n\n  \nDefinition 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 ) .\n\n\nLemma 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  ) ) . \nProof . intros . rewrite ( natmultcomm m k ) .   rewrite ( natmultcomm m k ) in ismk .  rewrite ( natmultcomm n k ) . rewrite ( natmultcomm ( natrem _ _ ) k ) .  apply ( natdivremandmultl _ _ _ ism ismk ) . Defined . \n\n\nOpaque natdivremandmultr .\n\n\nDefinition 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 ) .\n \n\nDefinition 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 ) .\n\n\n\n\n\n(** *** Exponentiation [ natpower n m ] ( \" n to the power m \" ) on [ nat ] *)\n\nFixpoint natpower ( n m : nat ) := match m with\nO => 1 |\nS m' => n * ( natpower n m' ) end .\n\n\n(** *** Factorial on [ nat ] *)\n\nFixpoint factorial ( n : nat ) := match n with\n0 => 1 |\nS n' => ( S n' ) * ( factorial n' ) end .  \n\n\n\n\n\n(** ** The order-preserving functions [ di i : nat -> nat ] whose image is the complement to one element [ i ] . *)\n\n\n\n\nDefinition di ( i : nat ) ( x : nat ) : nat :=\nmatch natlthorgeh x i with \nii1 _ => x |\nii2 _ => S x \nend .\n\n\nLemma natlehdinsn ( i n : nat ) : natleh ( di i n ) ( S n ) .\nProof . intros . unfold di . destruct ( natlthorgeh n i ) . apply natlthtoleh . apply natlthnsn . apply isreflnatleh .  Defined . \n\nLemma natgehdinn ( i n : nat ) : natgeh ( di i n ) n .\nProof. intros . unfold di . destruct ( natlthorgeh n i ) .  apply isreflnatleh .  apply natlthtoleh . apply natlthnsn .   Defined . \n\n\nLemma isincldi ( i : nat ) : isincl ( di i ) .\nProof. 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 . \n\n\nLemma neghfiberdi ( i : nat ) : neg ( hfiber ( di i ) i ) .\nProof. 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. \n\nLemma iscontrhfiberdi ( i j : nat ) ( ne : neg ( paths i j ) ) : iscontr ( hfiber ( di i ) j ) .\nProof. 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 . \n \n\nLemma isdecincldi ( i : nat ) : isdecincl ( di i ) .\nProof. 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 .\n\n\n\n\n\n\n(** ** Inductive types [ le ] with values in [ Type ] . \n\nThis part is included for illustration purposes only . In practice it is easier to work with [ natleh ] than with [ le ] . \n\n*)\n\n(** *** A generalization of [ le ] and its properties . *)\n\nInductive 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' ) .\n\nLemma leFiter { T : UU } ( F : T -> T ) ( t : T ) ( n : nat ) : leF F t ( iteration F n t ) .\nProof. intros .   induction n as [ | n IHn ] . apply leF_O . simpl . unfold funcomp . apply leF_S .  assumption .  Defined . \n\nLemma leFtototal2withnat { T : UU } ( F : T -> T ) ( t t' : T ) ( a : leF F t t' ) : total2 ( fun n : nat => paths ( iteration F n t ) t' ) .\nProof. 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. \nLemma total2withnattoleF { T : UU } ( F : T -> T ) ( t t' : T ) ( a : total2 ( fun n : nat => paths ( iteration F n t ) t' ) ) : leF F t t' .\nProof. intros .  destruct a as [ n e ] .  destruct e .  apply leFiter.  Defined . \n\n\nLemma 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) ) ) . \nProof . intros . induction n as [ | n IHn ] .   apply idpath . simpl .  \nset ( 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. \n\n\nLemma isweqleFtototal2withnat { T : UU } ( F : T -> T ) ( t t' : T ) : isweq ( leFtototal2withnat F t t' ) .\nProof . intros .  set ( f := leFtototal2withnat F t t' ) . set ( g :=  total2withnattoleF  F t t' ) . \nassert ( 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 ) .\nassert ( efg : forall x : _ , paths ( f ( g x ) ) x ) . intro x .  destruct x as [ n e ] .  destruct e . simpl .  apply  leFtototal2withnat_l0 . \napply ( gradth _ _ egf efg ) . Defined.\n\nDefinition 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' ) .\n\n\n(** *** Inductive types [ le ] with values in [ Type ] are in [ hProp ] *)\n\nDefinition le ( n : nat ) : nat -> Type := leF S n .\nDefinition le_n := leF_O S .\nDefinition le_S := leF_S S . \n\n\n\nTheorem isaprople ( n m : nat ) : isaprop ( le n m ) .\nProof. 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 . \n\n(** *** Comparison between [ le ] with values in [ Type ] and [ natleh ] . *)\n\n\nLemma letoleh ( n m : nat ) : le n m -> natleh n m .\nProof .  intros n m H . induction H as [ | m H0 IHH0 ] . apply isreflnatleh .  apply natlehtolehs .  assumption .  Defined . \n\nLemma natlehtole ( n m : nat ) : natleh n m ->  le n m .\nProof. intros n m H .  induction m .  assert ( int := natleh0tois0 n H ) .   clear H . destruct int . apply le_n . \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 .\n\nLemma isweqletoleh ( n m : nat ) : isweq ( letoleh n m ) .\nProof. intros . set ( is1 := isaprople n m ) . set ( is2 := pr2 ( natleh n m )  ) . apply ( isweqimplimpl ( letoleh n m ) ( natlehtole n m ) is1 is2 ) .  Defined . \n\nDefinition weqletoleh ( n m : nat ) := weqpair _ ( isweqletoleh n m ) .\n\n\n\n\n(* End of the file hnat.v *)\n"
  },
  {
    "path": "hlevel2/hq.v",
    "content": "(** * Generalities on the type of rationals and rational arithmetic. Vladimir Voevodsky . Aug. - Sep. 2011.\n\nIn 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 . \n\n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)\n\n\n(** Imports *)\n\nAdd LoadPath \"../..\" .\nAdd LoadPath \"../Generalities\".\n\nRequire Export Foundations.hlevel2.hz .\n\nOpaque hz . \n\n(** Upstream *)\n\n\n\n\n(** ** The commutative ring [ hq ] of integres *)\n\n(** *** General definitions *)\n\n\nDefinition hq : fld := fldfrac hzintdom isdeceqhz .\nDefinition hqaddabgr : abgr := rngaddabgr hq . \nDefinition hqmultabmonoid : abmonoid := rngmultabmonoid hq .\nDefinition hqtype : UU := hq . \n\nDefinition hzhztohq : hz -> ( intdomnonzerosubmonoid hzintdom ) -> hq := fun x a => setquotpr _ ( dirprodpair x a ) . \n\nDefinition hqplus : hq -> hq -> hq := @op1 hq.\nDefinition hqsign : hq -> hq := grinv hqaddabgr .\nDefinition hqminus : hq -> hq -> hq := fun x y => hqplus x ( hqsign y ) .\nDefinition hqzero : hq := unel hqaddabgr .\n\nDefinition hqmult : hq -> hq -> hq := @op2 hq .\nDefinition hqone : hq := unel hqmultabmonoid .\n\nBind Scope hq_scope with hq . \nNotation \" x + y \" := ( hqplus x y ) : hq_scope .\nNotation \" 0 \" := hqzero : hq_scope .\nNotation \" 1 \" := hqone : hq_scope . \nNotation \" - x \" := ( hqsign x ) : hq_scope . \nNotation \" x - y \" := ( hqminus x y ) : hq_scope .\nNotation \" x * y \" := ( hqmult x y ) : hq_scope .  \n\nDelimit Scope hq_scope with hq .    \n\n\n(** *** Properties of equlaity on [ hq ] *)\n\nDefinition isdeceqhq : isdeceq hq := isdeceqfldfrac hzintdom isdeceqhz . \n\nDefinition isasethq := setproperty hq .\n\nDefinition hqeq ( x y : hq ) : hProp := hProppair ( paths x y ) ( isasethq _ _  )  .\nDefinition isdecrelhqeq : isdecrel hqeq  := fun a b => isdeceqhq a b .\nDefinition hqdeceq : decrel hq := decrelpair isdecrelhqeq . \n\n(* Canonical Structure hqdeceq. *) \n\nDefinition hqbooleq := decreltobrel hqdeceq .  \n\nDefinition hqneq ( x y : hq ) : hProp := hProppair ( neg ( paths x y ) ) ( isapropneg _  )  .\nDefinition isdecrelhqneq : isdecrel hqneq  := isdecnegrel _ isdecrelhqeq . \nDefinition hqdecneq : decrel hq := decrelpair isdecrelhqneq . \n\n(* Canonical Structure hqdecneq. *) \n\nDefinition hqboolneq := decreltobrel hqdecneq .  \n\n(** Computation test *)\n\nOpen Local Scope hz_scope .\n\nTransparent hz .\n\nEval 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 ) ) ) ) ) . \n\nOpaque hz . \n\n(** *)\n\n\n\n(** *** Properties of addition and subtraction on [ hq ] *) \n\nOpen Local Scope hq_scope .\n\nLemma hqplusr0 ( x : hq ) : paths ( x + 0 ) x .\nProof . intro . apply ( rngrunax1 _ x ) .  Defined . \n\nLemma hqplusl0 ( x : hq ) : paths ( 0 + x ) x .\nProof . intro . apply ( rnglunax1 _ x ) . Defined . \n\nLemma hqplusassoc ( x y z : hq ) : paths ( ( x + y ) + z ) ( x + ( y + z ) ) .\nProof . intros . apply ( rngassoc1 hq x y z ) . Defined .   \n\nLemma hqpluscomm ( x y : hq ) : paths ( x + y ) ( y + x ) .\nProof . intros .  apply ( rngcomm1 hq x y ) . Defined .\n\nLemma hqlminus ( x : hq ) : paths ( -x + x ) 0 .\nProof . intro. apply ( rnglinvax1 hq x ) . Defined .\n\nLemma hqrminus  ( x : hq ) : paths ( x - x ) 0 .\nProof . intro. apply ( rngrinvax1 hq x ) . Defined .\n\nLemma isinclhqplusr ( n : hq ) : isincl ( fun m : hq => m + n ) .\nProof. intro . apply ( pr2 ( weqtoincl _ _ ( weqrmultingr hqaddabgr n ) ) ) . Defined. \n\nLemma isinclhqplusl ( n : hq ) : isincl ( fun m : hq => n + m ) .\nProof.  intro.  apply ( pr2 ( weqtoincl _ _ ( weqlmultingr hqaddabgr n ) ) ) . Defined . \n\n\nLemma hqpluslcan ( a b c : hq ) ( is : paths ( c + a ) ( c + b ) ) : paths a b .\nProof . intros . apply ( @grlcan hqaddabgr a b c is ) .  Defined . \n\nLemma hqplusrcan ( a b c : hq ) ( is : paths ( a + c ) ( b + c ) ) : paths a b .\nProof . intros . apply ( @grrcan hqaddabgr a b c is ) .  Defined . \n\nDefinition hqinvmaponpathsminus { a b : hq } ( e :  paths ( - a ) ( - b ) ) : paths a b := grinvmaponpathsinv hqaddabgr e . \n\n\n\n(** *** Proparties of multiplication on [ hq ] *)\n\n\nLemma hqmultr1 ( x : hq ) : paths ( x * 1 ) x .\nProof . intro . apply ( rngrunax2 _ x ) .  Defined . \n\nLemma hqmultl1 ( x : hq ) : paths ( 1 * x ) x .\nProof . intro . apply ( rnglunax2 _ x ) . Defined . \n\nLemma hqmult0x ( x : hq ) : paths ( 0 * x ) 0 .\nProof . intro . apply ( rngmult0x _ x ) .  Defined . \n\nLemma hqmultx0 ( x : hq ) : paths ( x * 0 ) 0 .\nProof . intro . apply ( rngmultx0 _ x ) . Defined . \n\nLemma hqmultassoc ( x y z : hq ) : paths ( ( x * y ) * z ) ( x * ( y * z ) ) .\nProof . intros . apply ( rngassoc2 hq x y z ) . Defined .   \n\nLemma hqmultcomm ( x y : hq ) : paths ( x * y ) ( y * x ) .\nProof . intros .  apply ( rngcomm2 hq  x y ) . Defined .\n\n\n(** *** Multiplicative inverse and division on [ hq ] \n\nNote : in our definition it is possible to divide by 0 . The result in this case is 0 . *)\n\nDefinition hqmultinv : hq -> hq := fun x => fldfracmultinv0 hzintdom isdeceqhz x . \n\nLemma hqislinvmultinv ( x : hq ) ( ne : hqneq x 0 ) : paths ( ( hqmultinv x ) * x ) 1 .\nProof. intros .  apply ( islinvinfldfrac hzintdom isdeceqhz x ne ) . Defined .  \n\nLemma hqisrinvmultinv ( x : hq ) ( ne : hqneq x 0 ) : paths (  x * ( hqmultinv x ) ) 1 .\nProof. intros .  apply ( isrinvinfldfrac hzintdom isdeceqhz x ne ) . Defined .  \n\nDefinition hqdiv ( x y : hq ) : hq := hqmult x ( hqmultinv y ) . \n\n\n\n\n(** ** Definition and properties of \"greater\", \"less\", \"greater or equal\" and \"less or equal\" on [ hq ] . *)\n\n\n(** *** Definitions and notations *)\n\n\nDefinition hqgth : hrel hq := fldfracgt hzintdom isdeceqhz isplushrelhzgth isrngmulthzgth ( ct ( hzgth , isdecrelhzgth,  1%hz , 0%hz ) ) hzneqchoice .\n\nDefinition hqlth : hrel hq := fun a b => hqgth b a .\n\nDefinition hqleh : hrel hq := fun a b => hProppair ( neg ( hqgth a b ) ) ( isapropneg _ )  . \n\nDefinition hqgeh : hrel hq := fun a b => hProppair ( neg ( hqgth b a ) ) ( isapropneg _ )  .\n\n\n \n\n(** *** Decidability *)\n\n\nLemma isdecrelhqgth : isdecrel hqgth .\nProof . apply isdecfldfracgt . exact isasymmhzgth .   apply isdecrelhzgth . Defined .\n\nDefinition hqgthdec := decrelpair isdecrelhqgth .\n\n(* Canonical Structure hqgthdec . *)\n\nDefinition isdecrelhqlth : isdecrel hqlth := fun x x' => isdecrelhqgth x' x . \n\nDefinition hqlthdec := decrelpair isdecrelhqlth .\n\n(* Canonical Structure hqlthdec . *)\n\nDefinition isdecrelhqleh : isdecrel hqleh := isdecnegrel _ isdecrelhqgth .\n\nDefinition hqlehdec := decrelpair isdecrelhqleh .\n\n(* Canonical Structure hqlehdec . *)\n\nDefinition isdecrelhqgeh : isdecrel hqgeh := fun x x' => isdecrelhqleh x' x .\n\nDefinition hqgehdec := decrelpair isdecrelhqgeh .\n\n(* Canonical Structure hqgehdec . *)\n\n(** Computation test *)\n\nTransparent hz .\n\nEval 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 ) ) ) ) ) . \n\nOpaque hz . \n\n\n(** *** Properties of individual relations *)\n\n(** [ hqgth ] *)\n\n\n\nLemma istranshqgth ( n m k : hq ) : hqgth n m -> hqgth m k -> hqgth n k .\nProof. apply istransfldfracgt . exact istranshzgth .  Defined . \n\nLemma isirreflhqgth ( n : hq ) : neg ( hqgth n n ) .\nProof. apply isirreflfldfracgt . exact isirreflhzgth .   Defined . \n\nLemma isasymmhqgth ( n m : hq ) : hqgth n m -> hqgth m n -> empty .\nProof. apply isasymmfldfracgt .  exact isasymmhzgth .  Defined .  \n\nLemma isantisymmneghqgth ( n m : hq ) : neg ( hqgth n m ) -> neg ( hqgth m n ) -> paths n m .\nProof . apply isantisymmnegfldfracgt . exact isirreflhzgth . exact isantisymmneghzgth .   Defined .     \n\nLemma isnegrelhqgth : isnegrel hqgth .\nProof . apply isdecreltoisnegrel . apply isdecrelhqgth . Defined . \n\nLemma iscoantisymmhqgth ( n m : hq ) : neg ( hqgth n m ) -> coprod ( hqgth m n ) ( paths n m ) .\nProof . apply isantisymmnegtoiscoantisymm . apply isdecrelhqgth .  intros n m . apply isantisymmneghqgth . Defined .  \n\nLemma iscotranshqgth ( n m k : hq ) : hqgth n k -> hdisj ( hqgth n m ) ( hqgth m k ) .\nProof . 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 .   \n\n\n\n\n(** [ hqlth ] *)\n\n\nDefinition istranshqlth ( n m k  : hq ) : hqlth n m -> hqlth m k -> hqlth n k := fun lnm lmk => istranshqgth _ _ _ lmk lnm . \n\nDefinition isirreflhqlth ( n : hq ) : neg ( hqlth n n ) := isirreflhqgth n .  \n\nDefinition isasymmhqlth ( n m : hq ) : hqlth n m -> hqlth m n -> empty := fun lnm lmn => isasymmhqgth _ _ lmn lnm .\n\nDefinition isantisymmneghqtth  ( n m : hq ) : neg ( hqlth n m ) -> neg ( hqlth m n ) -> paths n m := fun nlnm nlmn => isantisymmneghqgth _ _ nlmn nlnm .\n\nDefinition isnegrelhqlth : isnegrel hqlth := fun n m => isnegrelhqgth m n .\n\nDefinition iscoantisymmhqlth ( n m : hq ) : neg ( hqlth n m ) -> coprod ( hqlth m n ) ( paths n m ) .\nProof . intros n m nlnm . destruct ( iscoantisymmhqgth m n nlnm ) as [ l | e ] . apply ( ii1 l ) . apply ( ii2 ( pathsinv0 e ) ) . Defined . \n\nDefinition iscotranshqlth ( n m k : hq ) : hqlth n k -> hdisj ( hqlth n m ) ( hqlth m k ) . \nProof . intros n m k lnk . apply ( ( pr1 islogeqcommhdisj ) ( iscotranshqgth _ _ _ lnk ) )  .  Defined .      \n\n\n\n(**  [ hqleh ] *)\n\n\nDefinition  istranshqleh ( n m k : hq ) : hqleh n m -> hqleh m k -> hqleh n k .\nProof. apply istransnegrel . unfold iscotrans. apply iscotranshqgth .  Defined.   \n\nDefinition isreflhqleh ( n : hq ) : hqleh n n := isirreflhqgth n .  \n\nDefinition isantisymmhqleh ( n m : hq ) : hqleh n m -> hqleh m n -> paths n m := isantisymmneghqgth n m .   \n\nDefinition isnegrelhqleh : isnegrel hqleh .\nProof . apply isdecreltoisnegrel . apply isdecrelhqleh . Defined . \n\nDefinition iscoasymmhqleh ( n m : hq ) ( nl : neg ( hqleh n m ) ) : hqleh m n := negf ( isasymmhqgth _ _ ) nl . \n\nDefinition istotalhqleh : istotal hqleh . \nProof . intros x y . destruct ( isdecrelhqleh x y ) as [ lxy | lyx ] . apply ( hinhpr _ ( ii1 lxy ) ) . apply hinhpr .   apply ii2 . apply ( iscoasymmhqleh _ _ lyx ) .   Defined . \n\n\n\n(**  [ hqgeh ] . *)\n\n\nDefinition istranshqgeh ( n m k : hq ) : hqgeh n m -> hqgeh m k -> hqgeh n k := fun gnm gmk => istranshqleh _ _ _ gmk gnm . \n\nDefinition isreflhqgeh ( n : hq ) : hqgeh n n := isreflhqleh _ . \n\nDefinition isantisymmhqgeh ( n m : hq ) : hqgeh n m -> hqgeh m n -> paths n m := fun gnm gmn => isantisymmhqleh _ _ gmn gnm . \n\nDefinition isnegrelhqgeh : isnegrel hqgeh := fun n m => isnegrelhqleh m n . \n\nDefinition iscoasymmhqgeh ( n m : hq ) ( nl : neg ( hqgeh n m ) ) : hqgeh m n := iscoasymmhqleh _ _ nl . \n\nDefinition istotalhqgeh : istotal hqgeh := fun n m => istotalhqleh m n .\n\n\n\n\n(** *** Simple implications between comparisons *)\n\nDefinition hqgthtogeh ( n m : hq ) : hqgth n m -> hqgeh n m .\nProof. intros n m g . apply iscoasymmhqgeh . apply ( todneg _ g ) . Defined .\n\nDefinition hqlthtoleh ( n m : hq ) : hqlth n m -> hqleh n m := hqgthtogeh _ _ . \n\nDefinition hqlehtoneghqgth ( n m : hq ) : hqleh n m -> neg ( hqgth n m )  .\nProof. intros n m is is' . apply ( is is' ) .  Defined . \n\nDefinition  hqgthtoneghqleh ( n m : hq ) : hqgth n m -> neg ( hqleh n m ) := fun g l  => hqlehtoneghqgth _ _ l g .   \n\nDefinition hqgehtoneghqlth ( n m : hq ) : hqgeh n m -> neg ( hqlth n m ) := fun gnm lnm => hqlehtoneghqgth _ _ gnm lnm . \n\nDefinition hqlthtoneghqgeh ( n m : hq ) : hqlth n m -> neg ( hqgeh n m ) := fun gnm lnm => hqlehtoneghqgth _ _ lnm gnm .  \n\nDefinition neghqlehtogth ( n m : hq ) : neg ( hqleh n m ) -> hqgth n m := isnegrelhqgth n m .   \n\nDefinition neghqgehtolth ( n m : hq ) : neg ( hqgeh n m ) -> hqlth n m := isnegrelhqlth n m .\n\nDefinition neghqgthtoleh ( n m : hq ) : neg ( hqgth n m ) -> hqleh n m .\nProof . intros n m ng . destruct ( isdecrelhqleh n m ) as [ l | nl ] . apply l . destruct ( nl ng ) .  Defined . \n\nDefinition neghqlthtogeh ( n m : hq ) : neg ( hqlth n m ) -> hqgeh n m := fun nl => neghqgthtoleh _ _ nl . \n\n\n\n(** *** Comparison alternatives *)\n\n\nDefinition hqgthorleh ( n m : hq ) : coprod ( hqgth n m ) ( hqleh n m ) .\nProof . intros . apply ( isdecrelhqgth n m ) .  Defined . \n\nDefinition hqlthorgeh ( n m : hq ) : coprod ( hqlth n m ) ( hqgeh n m ) := hqgthorleh _ _ .\n\nDefinition hqneqchoice ( n m : hq ) ( ne : neg ( paths n m ) ) : coprod ( hqgth n m ) ( hqlth n m ) .\nProof . 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 . \n\nDefinition hqlehchoice ( n m : hq ) ( l : hqleh n m ) : coprod ( hqlth n m ) ( paths n m ) .\nProof .  intros . destruct ( hqlthorgeh n m ) as [ l' | g ] .   apply ( ii1 l' ) . apply ( ii2 ( isantisymmhqleh _ _ l g ) ) . Defined . \n\nDefinition hqgehchoice ( n m : hq ) ( g : hqgeh n m ) : coprod ( hqgth n m ) ( paths n m ) .\nProof .  intros . destruct ( hqgthorleh n m ) as [ g' | l ] .  apply ( ii1 g' ) .  apply ( ii2 ( isantisymmhqleh _ _ l g ) ) .  Defined . \n\n\n\n\n\n(** *** Mixed transitivities *)\n\n\n\nLemma hqgthgehtrans ( n m k : hq ) : hqgth n m -> hqgeh m k -> hqgth n k .\nProof. 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. \n\nLemma hqgehgthtrans ( n m k : hq ) : hqgeh n m -> hqgth m k -> hqgth n k .\nProof. intros n m k gnm gmk . destruct ( hqgehchoice n m gnm ) as [ g' | e ] . apply ( istranshqgth _ _ _ g' gmk ) .  rewrite e .  apply gmk . Defined. \n\nLemma hqlthlehtrans ( n m k : hq ) : hqlth n m -> hqleh m k -> hqlth n k .\nProof . intros n m k l1 l2 . apply ( hqgehgthtrans k m n l2 l1 ) . Defined . \n\nLemma hqlehlthtrans ( n m k : hq ) : hqleh n m -> hqlth m k -> hqlth n k .\nProof . intros n m k l1 l2 . apply ( hqgthgehtrans k m n l2 l1 ) . Defined .\n\n\n\n\n(** *** Addition and comparisons  *)\n\n\n\n(** [ gth ] *)\n\nDefinition isrngaddhzgth : @isbinophrel hqaddabgr hqgth .\nProof . apply isrngaddfldfracgt . exact isirreflhzgth . Defined . \n\n\nDefinition hqgthandplusl ( n m k : hq ) : hqgth n m -> hqgth ( k + n ) ( k + m ) := fun g => ( pr1 isrngaddhzgth ) n m k g . \n\nDefinition hqgthandplusr ( n m k : hq ) : hqgth n m -> hqgth ( n + k ) ( m + k ) := fun g => ( pr2 isrngaddhzgth ) n m k g .\n\nDefinition hqgthandpluslinv  ( n m k : hq ) : hqgth ( k + n ) ( k + m ) -> hqgth n m  .\nProof. 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 .\n\nDefinition hqgthandplusrinv ( n m k : hq ) :  hqgth ( n + k ) ( m + k ) -> hqgth n m  . \nProof. intros n m k l . rewrite ( hqpluscomm n k ) in l . rewrite ( hqpluscomm m k ) in l . apply ( hqgthandpluslinv _ _ _ l )  . Defined . \n\nLemma hqgthsnn ( n : hq ) : hqgth ( n + 1 ) n . \nProof . intro . set ( int := hqgthandplusl _ _ n ( ct ( hqgth , isdecrelhqgth , 1 , 0 ) ) ) . clearbody int . rewrite ( hqplusr0 n ) in int .   apply int . Defined . \n\n\n(** [ lth ] *)\n\n\nDefinition hqlthandplusl ( n m k : hq ) : hqlth n m -> hqlth ( k + n ) ( k + m )  := hqgthandplusl _ _ _ . \n\nDefinition hqlthandplusr ( n m k : hq ) : hqlth n m -> hqlth ( n + k ) ( m + k ) := hqgthandplusr _ _ _ .\n\nDefinition hqlthandpluslinv  ( n m k : hq ) : hqlth ( k + n ) ( k + m ) -> hqlth n m := hqgthandpluslinv _ _ _ .\n\nDefinition hqlthandplusrinv ( n m k : hq ) :  hqlth ( n + k ) ( m + k ) -> hqlth n m := hqgthandplusrinv _ _ _ .\n\nDefinition hqlthnsn ( n : hq ) : hqlth n ( n + 1 ) := hqgthsnn n . \n\n\n\n(** [ leh ] *)\n\n\nDefinition hqlehandplusl ( n m k : hq ) : hqleh n m -> hqleh ( k + n ) ( k + m ) := negf ( hqgthandpluslinv n m k )  . \n\nDefinition hqlehandplusr ( n m k : hq ) : hqleh n m -> hqleh ( n + k ) ( m + k ) := negf ( hqgthandplusrinv n m k )  . \n\nDefinition hqlehandpluslinv  ( n m k : hq ) : hqleh ( k + n ) ( k + m ) -> hqleh n m := negf ( hqgthandplusl n m k )  .  \n\nDefinition hqlehandplusrinv ( n m k : hq ) :  hqleh ( n + k ) ( m + k ) -> hqleh n m :=  negf ( hqgthandplusr n m k ) . \n\n\n\n(** [ geh ] *)\n\n\nDefinition hqgehandplusl ( n m k : hq ) : hqgeh n m -> hqgeh ( k + n ) ( k + m ) := negf ( hqgthandpluslinv m n k ) .  \n\nDefinition hqgehandplusr ( n m k : hq ) : hqgeh n m -> hqgeh ( n + k ) ( m + k ) := negf ( hqgthandplusrinv m n k )  . \n\nDefinition hqgehandpluslinv  ( n m k : hq ) : hqgeh ( k + n ) ( k + m ) -> hqgeh n m := negf ( hqgthandplusl m n k )  . \n\nDefinition hqgehandplusrinv ( n m k : hq ) :  hqgeh ( n + k ) ( m + k ) -> hqgeh n m :=  negf ( hqgthandplusr m n k ) . \n\n\n\n(** *** Properties of [ hqgth ] in the terminology of  algebra1.v *)\n\n\nDefinition isplushrelhqgth : @isbinophrel hqaddabgr hqgth := isrngaddhzgth . \n\nLemma isinvplushrelhqgth : @isinvbinophrel hqaddabgr hqgth . \nProof . split . apply  hqgthandpluslinv .  apply hqgthandplusrinv .  Defined . \n\nLemma isrngmulthqgth : isrngmultgt _ hqgth .\nProof . apply  isrngmultfldfracgt .  exact isirreflhzgth .  Defined .  \n\nLemma  isinvrngmulthqgth : isinvrngmultgt _ hqgth .\nProof . apply isinvrngmultgtif .  apply isplushrelhqgth .  apply isrngmulthqgth . exact hqneqchoice . exact isasymmhqgth . Defined . \n\n\n\n(** *** Negation and comparisons *)\n\n(** [ hqgth ] *)\n\nLemma hqgth0andminus { n : hq } ( is : hqgth n 0 ) : hqlth ( - n ) 0 .\nProof . intros . unfold hqlth . apply ( rngfromgt0 hq isplushrelhqgth is ) .  Defined . \n\nLemma hqminusandgth0 { n : hq } ( is : hqgth ( - n ) 0 ) : hqlth n 0 .\nProof . intros . unfold hqlth . apply ( rngtolt0 hq isplushrelhqgth is ) .  Defined . \n\n\n(** [ hqlth ] *)\n\nLemma hqlth0andminus { n : hq } ( is : hqlth n 0 ) : hqgth ( - n ) 0 .\nProof . intros .  unfold hqlth . apply ( rngfromlt0 hq isplushrelhqgth is ) .  Defined . \n\nLemma hqminusandlth0 { n : hq } ( is : hqlth ( - n ) 0 ) : hqgth n 0 .\nProof . intros . unfold hqlth . apply ( rngtogt0 hq isplushrelhqgth is ) .  Defined .\n \n(* ??? Coq slows down for no good reason at Defined in the previous four lemmas. *)\n\n(** [ hqleh ] *)\n\nLemma hqleh0andminus { n : hq } ( is : hqleh n 0 ) : hqgeh ( - n ) 0 .\nProof . intro n . apply ( negf ( @hqminusandlth0 n ) ) . Defined .  \n\nLemma hqminusandleh0 { n : hq } ( is : hqleh ( - n ) 0 ) : hqgeh n 0 .\nProof . intro n . apply ( negf ( @hqlth0andminus n ) ) . Defined .  \n\n\n\n(** [ hqgeh ] *)\n\nLemma hqgeh0andminus { n : hq } ( is : hqgeh n 0 ) : hqleh ( - n ) 0 .\nProof . intro n . apply ( negf ( @hqminusandgth0 n ) ) . Defined .  \n\nLemma hqminusandgeh0 { n : hq } ( is : hqgeh ( - n ) 0 ) : hqleh n 0 .\nProof . intro n . apply ( negf ( @hqgth0andminus n ) ) . Defined .  \n\n\n(** *** Multiplication and comparisons  *)\n\n\n(** [ gth ] *)\n \n\nDefinition hqgthandmultl ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth n m -> hqgth ( k * n ) ( k * m ) .\nProof. apply ( isrngmultgttoislrngmultgt _ isplushrelhqgth isrngmulthqgth ) .   Defined . \n\nDefinition hqgthandmultr ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth n m -> hqgth ( n * k ) ( m * k )  .\nProof . apply ( isrngmultgttoisrrngmultgt _ isplushrelhqgth isrngmulthqgth ) . Defined .\n\nDefinition  hqgthandmultlinv ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth ( k * n ) ( k * m ) -> hqgth n m .\nProof . intros n m k is is' .  apply ( isinvrngmultgttoislinvrngmultgt hq isplushrelhqgth isinvrngmulthqgth n m k is is' ) .  Defined . \n\nDefinition hqgthandmultrinv ( n m k : hq ) ( is : hqgth k hqzero ) : hqgth ( n * k ) ( m * k ) -> hqgth n m .\nProof.   intros n m k is is' .  apply ( isinvrngmultgttoisrinvrngmultgt hq isplushrelhqgth isinvrngmulthqgth n m k is is' ) .  Defined . \n\n\n\n(** [ lth ] *)\n\n\nDefinition hqlthandmultl ( n m k : hq ) ( is : hqgth k 0 ) : hqlth n m -> hqlth ( k * n ) ( k * m )  := hqgthandmultl _ _ _ is .\n\nDefinition hqlthandmultr ( n m k : hq ) ( is : hqgth k 0 ) : hqlth n m -> hqlth ( n * k ) ( m * k ) := hqgthandmultr _ _ _ is .\n\nDefinition hqlthandmultlinv ( n m k : hq ) ( is : hqgth k 0 ) : hqlth ( k * n ) ( k * m ) -> hqlth n m := hqgthandmultlinv _ _ _ is .\n\nDefinition hqlthandmultrinv ( n m k : hq ) ( is : hqgth k 0 ) : hqlth ( n * k ) ( m * k ) -> hqlth n m := hqgthandmultrinv _ _ _ is .\n\n\n(** [ leh ] *)\n\n\nDefinition hqlehandmultl ( n m k : hq ) ( is : hqgth k 0 ) : hqleh n m -> hqleh ( k * n ) ( k * m ) := negf ( hqgthandmultlinv _ _ _ is ) .\n\nDefinition hqlehandmultr ( n m k : hq ) ( is : hqgth k 0 ) : hqleh n m -> hqleh ( n * k ) ( m * k ) := negf ( hqgthandmultrinv _ _ _ is ) .\n\nDefinition hqlehandmultlinv ( n m k : hq ) ( is : hqgth k 0 ) : hqleh ( k * n ) ( k * m ) -> hqleh n m := negf ( hqgthandmultl _ _ _ is )  .\n\nDefinition hqlehandmultrinv ( n m k : hq ) ( is : hqgth k 0 ) : hqleh ( n * k ) ( m * k ) -> hqleh n m := negf ( hqgthandmultr _ _ _ is ) .\n\n\n(** [ geh ] *)\n\n\nDefinition hqgehandmultl ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh n m -> hqgeh ( k * n ) ( k * m ) := negf ( hqgthandmultlinv _ _ _ is ) .\n\nDefinition hqgehandmultr ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh n m -> hqgeh ( n * k ) ( m * k )  := negf ( hqgthandmultrinv _ _ _ is ) .\n\nDefinition hqgehandmultlinv ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh ( k * n ) ( k * m ) -> hqgeh n m := negf ( hqgthandmultl _ _ _ is )   .\n\nDefinition hqgehandmultrinv ( n m k : hq ) ( is : hqgth k 0 ) : hqgeh ( n * k ) ( m * k ) -> hqgeh n m := negf ( hqgthandmultr _ _ _ is )  .\n\n\n\n\n\n\n\n\n(** Multiplication of positive with negative, negative with positive and two negatives. *)\n\n\nLemma hqmultgth0gth0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqgth n 0 ) : hqgth ( m * n ) 0 .\nProof . intros . apply isrngmulthqgth . apply ism . apply isn . Defined .  \n\nLemma hqmultgth0geh0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqgeh n 0 ) : hqgeh ( m * n ) 0 .\nProof . intros .  destruct ( hqgehchoice _ _ isn ) as [ gn | en ] . \n\napply ( hqgthtogeh _ _ ( hqmultgth0gth0  ism gn ) ) . \n\nrewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined .\n\n\nLemma hqmultgeh0gth0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqgth n 0 ) : hqgeh ( m * n ) 0 .\nProof .  intros .  destruct ( hqgehchoice _ _ ism ) as [ gm | em ] . \n\napply ( hqgthtogeh _ _ ( hqmultgth0gth0 gm isn ) ) . \n\nrewrite em .  rewrite ( hqmult0x _ ) . apply isreflhqgeh . Defined .\n \n\nLemma hqmultgeh0geh0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqgeh n 0 ) : hqgeh ( m * n ) 0 .\nProof . intros .   destruct ( hqgehchoice _ _ isn ) as [ gn | en ] . \n\napply ( hqmultgeh0gth0 ism gn ) . \n\nrewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined .\n\n\nLemma hqmultgth0lth0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqlth n 0 ) : hqlth ( m * n ) 0 .\nProof . intros . apply ( rngmultgt0lt0 hq isplushrelhqgth isrngmulthqgth ) . apply ism . apply isn . Defined .  \n\nLemma hqmultgth0leh0 { m n : hq } ( ism : hqgth m 0 ) ( isn : hqleh n 0 ) : hqleh ( m * n ) 0 .\nProof . intros .  destruct ( hqlehchoice _ _ isn ) as [ ln | en ] . \n\napply ( hqlthtoleh _ _ ( hqmultgth0lth0  ism ln ) ) . \n\nrewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqleh . Defined .\n\nLemma hqmultgeh0lth0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqlth n 0 ) : hqleh ( m * n ) 0 .\nProof .  intros .  destruct ( hqlehchoice _ _ ism ) as [ lm | em ] . \n\napply ( hqlthtoleh _ _ ( hqmultgth0lth0 lm isn ) ) . \n\ndestruct em .  rewrite ( hqmult0x _ ) . apply isreflhqleh . Defined .\n\nLemma hqmultgeh0leh0 { m n : hq } ( ism : hqgeh m 0 ) ( isn : hqleh n 0 ) : hqleh ( m * n ) 0 .\nProof . intros .   destruct ( hqlehchoice _ _ isn ) as [ ln | en ] . \n\napply ( hqmultgeh0lth0 ism ln ) . \n\nrewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqleh . Defined .\n\n\n\nLemma hqmultlth0gth0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqgth n 0 ) : hqlth ( m * n ) 0 .\nProof . intros . rewrite ( hqmultcomm ) .  apply hqmultgth0lth0 . apply isn . apply ism .  Defined .  \n\nLemma hqmultlth0geh0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqgeh n 0 ) : hqleh ( m * n ) 0 .\nProof . intros . rewrite ( hqmultcomm ) .  apply hqmultgeh0lth0 . apply isn . apply ism .  Defined .  \n\n\nLemma hqmultleh0gth0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqgth n 0 ) : hqleh ( m * n ) 0 .\nProof . intros . rewrite ( hqmultcomm ) .  apply hqmultgth0leh0 . apply isn . apply ism .  Defined .  \n\n\nLemma hqmultleh0geh0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqgeh n 0 ) : hqleh ( m * n ) 0 .\nProof . intros . rewrite ( hqmultcomm ) .  apply hqmultgeh0leh0 . apply isn . apply ism .  Defined .  \n\n\nLemma hqmultlth0lth0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqlth n 0 ) : hqgth ( m * n ) 0 .\nProof . intros . assert ( ism' := hqlth0andminus ism ) .  assert ( isn' := hqlth0andminus isn ) . assert ( int := isrngmulthqgth _ _ ism' isn' ) . rewrite ( rngmultminusminus hq ) in int .  apply int . Defined . \n\nLemma hqmultlth0leh0 { m n : hq } ( ism : hqlth m 0 ) ( isn : hqleh n 0 ) : hqgeh ( m * n ) 0 .\nProof . intros . intros .  destruct ( hqlehchoice _ _ isn ) as [ ln | en ] . \n\napply ( hqgthtogeh _ _ ( hqmultlth0lth0  ism ln ) ) . \n\nrewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqgeh . Defined .\n\nLemma hqmultleh0lth0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqlth n 0 ) : hqgeh ( m * n ) 0 .\nProof . intros . destruct ( hqlehchoice _ _ ism ) as [ lm | em ] . \n\napply ( hqgthtogeh _ _ ( hqmultlth0lth0 lm isn ) ) . \n\nrewrite em .  rewrite ( hqmult0x _ ) . apply isreflhqgeh .  Defined .\n \nLemma hqmultleh0leh0 { m n : hq } ( ism : hqleh m 0 ) ( isn : hqleh n 0 ) : hqgeh ( m * n ) 0 .\nProof . intros .  destruct ( hqlehchoice _ _ isn ) as [ ln | en ] . \n\napply ( hqmultleh0lth0 ism ln ) . \n\nrewrite en .  rewrite ( hqmultx0 m ) . apply isreflhqgeh .   Defined .\n\n\n\n(** *** Cancellation properties of multiplication on [ hq ] *)\n\nLemma hqmultlcan ( a b c : hq ) ( ne : neg ( paths c 0 ) ) ( e : paths ( c * a ) ( c * b ) ) : paths a b .\nProof . intros . apply ( intdomlcan hq _ _ _ ne e ) . Defined .\n\nLemma hqmultrcan ( a b c : hq ) ( ne : neg ( paths c 0 ) ) ( e : paths ( a * c ) ( b * c ) ) : paths a b .\nProof . intros . apply ( intdomrcan hq _ _ _ ne e ) . Defined .\n\n \n\n\n(** *** Positive rationals *)\n\nDefinition hqpos : @subabmonoids hqmultabmonoid . \nProof . 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 . \n\n\n(** *** Canonical ring homomorphism from [ hz ] to [ hq ] *)\n\nDefinition hztohq : hz -> hq := tofldfrac hzintdom isdeceqhz.\n\nDefinition isinclhztohq : isincl hztohq := isincltofldfrac hzintdom isdeceqhz . \n\nDefinition hztohqandneq ( n m : hz ) ( is : hzneq n m ) : hqneq ( hztohq n ) ( hztohq m ) := negf ( invmaponpathsincl _ isinclhztohq n m ) is . \n\nDefinition hztohqand0 : paths ( hztohq 0%hz ) 0 := idpath _ . \n\nDefinition hztohqand1 : paths ( hztohq 1%hz ) 1 := idpath _ . \n\nDefinition hztohqandplus ( n m : hz ) : paths ( hztohq ( n + m )%hz ) ( hztohq n + hztohq m ) := isbinop1funtofldfrac hzintdom isdeceqhz n m .\n\nDefinition hztohqandminus ( n m : hz ) : paths ( hztohq ( n - m )%hz ) ( hztohq n - hztohq m ) := tofldfracandminus hzintdom isdeceqhz n m . \n\nDefinition hztohqandmult ( n m : hz ) : paths ( hztohq ( n * m )%hz ) ( hztohq n * hztohq m ) := isbinop2funtofldfrac hzintdom isdeceqhz n m . \n\nDefinition 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 . \n\nDefinition hztohqandlth ( n m : hz ) ( is : hzlth n m ) : hqlth ( hztohq n ) ( hztohq m ) := hztohqandgth m n is . \n\nDefinition hztohqandleh ( n m : hz ) ( is : hzleh n m ) : hqleh ( hztohq n ) ( hztohq m ) .\nProof . intros . destruct ( hzlehchoice _ _ is ) as [ l | e ] .   apply ( hqlthtoleh _ _ ( hztohqandlth _ _ l ) ) .  rewrite e .  apply ( isreflhqleh ) .  Defined . \n\nDefinition hztohqandgeh ( n m : hz ) ( is : hzgeh n m ) : hqgeh ( hztohq n ) ( hztohq m ) := hztohqandleh _ _ is . \n\n\n\n\n(** *** Integral part of a rational *)\n\nDefinition intpartint0 ( xa : dirprod hz ( intdomnonzerosubmonoid hzintdom ) ) : nat := natdiv ( hzabsval (pr1 xa ) ) ( hzabsval ( pr1 ( pr2 xa ) ) )  .\n\nLemma iscompintpartint0 : iscomprelfun ( eqrelabmonoidfrac hzmultabmonoid ( intdomnonzerosubmonoid hzintdom ) ) intpartint0 .\nProof . 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 ) . \n\nsimpl 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' .\n\nunfold 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 .  \n\nOpaque iscompintpartint0 .\n\nDefinition intpart0 : hq -> nat := setquotuniv ( eqrelabmonoidfrac hzmultabmonoid (intdomnonzerosubmonoid hzintdom) ) natset _ \n     ( iscompintpartint0 ) .   \n\nDefinition intpart ( x : hq ) : hz .\nProof . intro . destruct ( hqlthorgeh x 0 ) as [ l | ge ] .  destruct ( isdeceqhq ( x + ( hztohq ( nattohz ( intpart0 x ) ) ) ) 0 ) as [ e | ne ] . \n\napply ( - (nattohz (intpart0 x)))%hz . \n\napply ( - ( 1 + (nattohz (intpart0 x)) ) )%hz .\n\napply (nattohz (intpart0 x)) . Defined .\n\n\n(** Computation test *)\n\nTransparent hz .\n\nEval lazy in ( hzabsval ( intpart ( hqdiv ( hztohq ( nattohz ( 10 ) ) )  ( - ( 1 + 1 + 1 ) ) ) ) ) . \n\n\nOpaque hz . \n\n\n\n\n\n\n\n   \n\n\n\n(* End of the file hq.v *)\n\n\n\n  \n"
  },
  {
    "path": "hlevel2/hz.v",
    "content": "(** * Generalities on the type of integers and integer arithmetic. Vladimir Voevodsky . Aug. - Sep. 2011.\n\nIn 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 . \n\n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)\n\n\n(** Imports *)\n\nAdd LoadPath \"../..\" .\n \nRequire Export Foundations.hlevel2.hnat .\n\n\n\n(** Upstream *)\n\n\n\n\n(** ** The commutative ring [ hz ] of integres *)\n\n(** *** General definitions *)\n\n\nDefinition hz : commrng := commrigtocommrng natcommrig .\nDefinition hzaddabgr : abgr := rngaddabgr hz . \nDefinition hzmultabmonoid : abmonoid := rngmultabmonoid hz .\n\nDefinition natnattohz : nat -> nat -> hz := fun n m => setquotpr _ ( dirprodpair n m ) . \n\nDefinition hzplus : hz -> hz -> hz := @op1 hz.\nDefinition hzsign : hz -> hz := grinv hzaddabgr .\nDefinition hzminus : hz -> hz -> hz := fun x y => hzplus x ( hzsign y ) .\nDefinition hzzero : hz := unel hzaddabgr .\n\nDefinition hzmult : hz -> hz -> hz := @op2 hz .\nDefinition hzone : hz := unel hzmultabmonoid .\n\nBind Scope hz_scope with hz . \nNotation \" x + y \" := ( hzplus x y ) : hz_scope .\nNotation \" 0 \" := hzzero : hz_scope .\nNotation \" 1 \" := hzone : hz_scope . \nNotation \" - x \" := ( hzsign x ) : hz_scope . \nNotation \" x - y \" := ( hzminus x y ) : hz_scope .\nNotation \" x * y \" := ( hzmult x y ) : hz_scope .\n\nDelimit Scope hz_scope with hz .     \n\n\n(** *** Properties of equlaity on [ hz ] *)\n\nTheorem isdeceqhz : isdeceq hz .\nProof . change ( isdeceq ( abgrfrac ( rigaddabmonoid natcommrig ) ) ) . apply isdeceqabgrfrac . apply isinclnatplusr .  apply isdeceqnat .  Defined . \n\nLemma isasethz : isaset hz .\nProof . apply ( setproperty hzaddabgr ) . Defined . \n\nDefinition hzeq ( x y : hz ) : hProp := hProppair ( paths x y ) ( isasethz _ _  )  .\nDefinition isdecrelhzeq : isdecrel hzeq  := fun a b => isdeceqhz a b .\nDefinition hzdeceq : decrel hz := decrelpair isdecrelhzeq . \n\n(* Canonical Structure hzdeceq. *) \n\nDefinition hzbooleq := decreltobrel hzdeceq .  \n\nDefinition hzneq ( x y : hz ) : hProp := hProppair ( neg ( paths x y ) ) ( isapropneg _  )  .\nDefinition isdecrelhzneq : isdecrel hzneq  := isdecnegrel _ isdecrelhzeq . \nDefinition hzdecneq : decrel hz := decrelpair isdecrelhzneq . \n\n(* Canonical Structure hzdecneq. *)  \n\nDefinition hzboolneq := decreltobrel hzdecneq .  \n\n\nOpen Local Scope hz_scope . \n\n\n(** *** [ hz ] is a non-zero ring *)\n\nLemma isnonzerornghz : isnonzerorng hz .\nProof . apply  ( ct ( hzneq , isdecrelhzneq, 1 , 0 ) ) . Defined . \n\n\n(** *** Properties of addition and subtraction on [ hz ] *) \n\nDefinition hzminuszero : paths ( - 0 ) 0 := rnginvunel1 hz . \n\nLemma hzplusr0 ( x : hz ) : paths ( x + 0 ) x .\nProof . intro . apply ( rngrunax1 _ x ) .  Defined . \n\nLemma hzplusl0 ( x : hz ) : paths ( 0 + x ) x .\nProof . intro . apply ( rnglunax1 _ x ) . Defined . \n\nLemma hzplusassoc ( x y z : hz ) : paths ( ( x + y ) + z ) ( x + ( y + z ) ) .\nProof . intros . apply ( rngassoc1 hz x y z ) . Defined .   \n\nLemma hzpluscomm ( x y : hz ) : paths ( x + y ) ( y + x ) .\nProof . intros .  apply ( rngcomm1 hz x y ) . Defined .\n\nLemma hzlminus ( x : hz ) : paths ( -x + x ) 0 .\nProof . intro. apply ( rnglinvax1 hz x ) . Defined .\n\nLemma hzrminus  ( x : hz ) : paths ( x - x ) 0 .\nProof . intro. apply ( rngrinvax1 hz x ) . Defined .\n\nLemma isinclhzplusr ( n : hz ) : isincl ( fun m : hz => m + n ) .\nProof. intro . apply ( pr2 ( weqtoincl _ _ ( weqrmultingr hzaddabgr n ) ) ) . Defined. \n\nLemma isinclhzplusl ( n : hz ) : isincl ( fun m : hz => n + m ) .\nProof.  intro.  apply ( pr2 ( weqtoincl _ _ ( weqlmultingr hzaddabgr n ) ) ) . Defined . \n\nLemma hzpluslcan ( a b c : hz ) ( is : paths ( c + a ) ( c + b ) ) : paths a b .\nProof . intros . apply ( @grlcan hzaddabgr a b c is ) .  Defined . \n\nLemma hzplusrcan ( a b c : hz ) ( is : paths ( a + c ) ( b + c ) ) : paths a b .\nProof . intros . apply ( @grrcan hzaddabgr a b c is ) .  Defined . \n\nDefinition hzinvmaponpathsminus { a b : hz } ( e :  paths ( - a ) ( - b ) ) : paths a b := grinvmaponpathsinv hzaddabgr e . \n\n\n(** *** Properties of multiplication on [ hz ] *)\n\n\nLemma hzmultr1 ( x : hz ) : paths ( x * 1 ) x .\nProof . intro . apply ( rngrunax2 _ x ) .  Defined . \n\nLemma hzmultl1 ( x : hz ) : paths ( 1 * x ) x .\nProof . intro . apply ( rnglunax2 _ x ) . Defined . \n\nLemma hzmult0x ( x : hz ) : paths ( 0 * x ) 0 .\nProof . intro . apply ( rngmult0x _ x ) .  Defined . \n\nLemma hzmultx0 ( x : hz ) : paths ( x * 0 ) 0 .\nProof . intro . apply ( rngmultx0 _ x ) . Defined . \n\nLemma hzmultassoc ( x y z : hz ) : paths ( ( x * y ) * z ) ( x * ( y * z ) ) .\nProof . intros . apply ( rngassoc2 hz x y z ) . Defined .   \n\nLemma hzmultcomm ( x y : hz ) : paths ( x * y ) ( y * x ) .\nProof . intros .  apply ( rngcomm2 hz  x y ) . Defined .\n\nDefinition hzneq0andmultlinv ( n m : hz ) ( isnm : hzneq ( n * m ) 0 ) : hzneq n 0 := rngneq0andmultlinv hz n m isnm . \n\nDefinition hzneq0andmultrinv ( n m : hz ) ( isnm : hzneq ( n * m ) 0 ) : hzneq m 0 := rngneq0andmultrinv hz n m isnm . \n\n\n\n(** ** Definition and properties of \"greater\", \"less\", \"greater or equal\" and \"less or equal\" on [ hz ] . *)\n\n\n(** *** Definitions and notations *)\n\nDefinition hzgth : hrel hz := rigtorngrel natcommrig isplushrelnatgth .\n\nDefinition hzlth : hrel hz := fun a b => hzgth b a .\n\nDefinition hzleh : hrel hz := fun a b => hProppair ( neg ( hzgth a b ) ) ( isapropneg _ )  . \n\nDefinition hzgeh : hrel hz := fun a b => hProppair ( neg ( hzgth b a ) ) ( isapropneg _ )  .\n\n\n \n\n(** *** Decidability *)\n\n\nLemma isdecrelhzgth : isdecrel hzgth .\nProof . apply ( isdecrigtorngrel natcommrig isplushrelnatgth  ) .  apply isinvplushrelnatgth . apply isdecrelnatgth . Defined . \n\nDefinition hzgthdec := decrelpair isdecrelhzgth .\n\n(* Canonical Structure hzgthdec . *)\n\nDefinition isdecrelhzlth : isdecrel hzlth := fun x x' => isdecrelhzgth x' x . \n\nDefinition hzlthdec := decrelpair isdecrelhzlth .\n\n(* Canonical Structure hzlthdec . *)\n\nDefinition isdecrelhzleh : isdecrel hzleh := isdecnegrel _ isdecrelhzgth .\n\nDefinition hzlehdec := decrelpair isdecrelhzleh .\n\n(* Canonical Structure hzlehdec . *)\n\nDefinition isdecrelhzgeh : isdecrel hzgeh := fun x x' => isdecrelhzleh x' x .\n\nDefinition hzgehdec := decrelpair isdecrelhzgeh .\n\n(* Canonical Structure hzgehdec . *)\n\n\n(** *** Properties of individual relations *)\n\n(** [ hzgth ] *)\n\n\n\nLemma istranshzgth ( n m k : hz ) : hzgth n m -> hzgth m k -> hzgth n k .\nProof. apply ( istransabgrfracrel nataddabmonoid isplushrelnatgth )  .  unfold istrans .  apply istransnatgth .  Defined. \n\nLemma isirreflhzgth ( n : hz ) : neg ( hzgth n n ) .\nProof. apply ( isirreflabgrfracrel nataddabmonoid isplushrelnatgth )  . unfold isirrefl .  apply isirreflnatgth .   Defined . \n\nLemma hzgthtoneq ( n m : hz ) ( g : hzgth n m ) : neg ( paths n m ) .\nProof . intros . intro e . rewrite e in g . apply ( isirreflhzgth _ g ) . Defined .  \n\nLemma isasymmhzgth ( n m : hz ) : hzgth n m -> hzgth m n -> empty .\nProof. apply ( isasymmabgrfracrel nataddabmonoid isplushrelnatgth )  . unfold isasymm .  apply isasymmnatgth .  Defined .  \n\nLemma isantisymmneghzgth ( n m : hz ) : neg ( hzgth n m ) -> neg ( hzgth m n ) -> paths n m .\nProof . apply ( isantisymmnegabgrfracrel nataddabmonoid isplushrelnatgth )  . unfold isantisymmneg .  apply isantisymmnegnatgth .   Defined .     \n\nLemma isnegrelhzgth : isnegrel hzgth .\nProof . apply isdecreltoisnegrel . apply isdecrelhzgth . Defined . \n\nLemma iscoantisymmhzgth ( n m : hz ) : neg ( hzgth n m ) -> coprod ( hzgth m n ) ( paths n m ) .\nProof . apply isantisymmnegtoiscoantisymm . apply isdecrelhzgth .  intros n m . apply isantisymmneghzgth . Defined .  \n\nLemma iscotranshzgth ( n m k : hz ) : hzgth n k -> hdisj ( hzgth n m ) ( hzgth m k ) .\nProof . 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 .   \n\n\n\n\n(** [ hzlth ] *)\n\n\nDefinition istranshzlth ( n m k  : hz ) : hzlth n m -> hzlth m k -> hzlth n k := fun lnm lmk => istranshzgth _ _ _ lmk lnm . \n\nDefinition isirreflhzlth ( n : hz ) : neg ( hzlth n n ) := isirreflhzgth n .  \n\nLemma hzlthtoneq ( n m : hz ) ( g : hzlth n m ) : neg ( paths n m ) .\nProof . intros . intro e . rewrite e in g . apply ( isirreflhzlth _ g ) . Defined .  \n\nDefinition isasymmhzlth ( n m : hz ) : hzlth n m -> hzlth m n -> empty := fun lnm lmn => isasymmhzgth _ _ lmn lnm .\n\nDefinition isantisymmneghztth  ( n m : hz ) : neg ( hzlth n m ) -> neg ( hzlth m n ) -> paths n m := fun nlnm nlmn => isantisymmneghzgth _ _ nlmn nlnm .\n\nDefinition isnegrelhzlth : isnegrel hzlth := fun n m => isnegrelhzgth m n .\n\nDefinition iscoantisymmhzlth ( n m : hz ) : neg ( hzlth n m ) -> coprod ( hzlth m n ) ( paths n m ) .\nProof . intros n m nlnm . destruct ( iscoantisymmhzgth m n nlnm ) as [ l | e ] . apply ( ii1 l ) . apply ( ii2 ( pathsinv0 e ) ) . Defined . \n\nDefinition iscotranshzlth ( n m k : hz ) : hzlth n k -> hdisj ( hzlth n m ) ( hzlth m k ) . \nProof . intros n m k lnk . apply ( ( pr1 islogeqcommhdisj ) ( iscotranshzgth _ _ _ lnk ) )  .  Defined .      \n\n\n\n(**  [ hzleh ] *)\n\n\nDefinition  istranshzleh ( n m k : hz ) : hzleh n m -> hzleh m k -> hzleh n k .\nProof. apply istransnegrel . unfold iscotrans. apply iscotranshzgth .  Defined.   \n\nDefinition isreflhzleh ( n : hz ) : hzleh n n := isirreflhzgth n .  \n\nDefinition isantisymmhzleh ( n m : hz ) : hzleh n m -> hzleh m n -> paths n m := isantisymmneghzgth n m .   \n\nDefinition isnegrelhzleh : isnegrel hzleh .\nProof . apply isdecreltoisnegrel . apply isdecrelhzleh . Defined . \n\nDefinition iscoasymmhzleh ( n m : hz ) ( nl : neg ( hzleh n m ) ) : hzleh m n := negf ( isasymmhzgth _ _ ) nl . \n\nDefinition istotalhzleh : istotal hzleh . \nProof . intros x y . destruct ( isdecrelhzleh x y ) as [ lxy | lyx ] . apply ( hinhpr _ ( ii1 lxy ) ) . apply hinhpr .   apply ii2 . apply ( iscoasymmhzleh _ _ lyx ) .   Defined . \n\n\n\n(**  [ hzgeh ] . *)\n\n\nDefinition istranshzgeh ( n m k : hz ) : hzgeh n m -> hzgeh m k -> hzgeh n k := fun gnm gmk => istranshzleh _ _ _ gmk gnm . \n\nDefinition isreflhzgeh ( n : hz ) : hzgeh n n := isreflhzleh _ . \n\nDefinition isantisymmhzgeh ( n m : hz ) : hzgeh n m -> hzgeh m n -> paths n m := fun gnm gmn => isantisymmhzleh _ _ gmn gnm . \n\nDefinition isnegrelhzgeh : isnegrel hzgeh := fun n m => isnegrelhzleh m n . \n\nDefinition iscoasymmhzgeh ( n m : hz ) ( nl : neg ( hzgeh n m ) ) : hzgeh m n := iscoasymmhzleh _ _ nl . \n\nDefinition istotalhzgeh : istotal hzgeh := fun n m => istotalhzleh m n .\n\n\n\n\n(** *** Simple implications between comparisons *)\n\nDefinition hzgthtogeh ( n m : hz ) : hzgth n m -> hzgeh n m .\nProof. intros n m g . apply iscoasymmhzgeh . apply ( todneg _ g ) . Defined .\n\nDefinition hzlthtoleh ( n m : hz ) : hzlth n m -> hzleh n m := hzgthtogeh _ _ . \n\nDefinition hzlehtoneghzgth ( n m : hz ) : hzleh n m -> neg ( hzgth n m )  .\nProof. intros n m is is' . apply ( is is' ) .  Defined . \n\nDefinition  hzgthtoneghzleh ( n m : hz ) : hzgth n m -> neg ( hzleh n m ) := fun g l  => hzlehtoneghzgth _ _ l g .   \n\nDefinition hzgehtoneghzlth ( n m : hz ) : hzgeh n m -> neg ( hzlth n m ) := fun gnm lnm => hzlehtoneghzgth _ _ gnm lnm . \n\nDefinition hzlthtoneghzgeh ( n m : hz ) : hzlth n m -> neg ( hzgeh n m ) := fun gnm lnm => hzlehtoneghzgth _ _ lnm gnm .  \n\nDefinition neghzlehtogth ( n m : hz ) : neg ( hzleh n m ) -> hzgth n m := isnegrelhzgth n m .   \n\nDefinition neghzgehtolth ( n m : hz ) : neg ( hzgeh n m ) -> hzlth n m := isnegrelhzlth n m .\n\nDefinition neghzgthtoleh ( n m : hz ) : neg ( hzgth n m ) -> hzleh n m .\nProof . intros n m ng . destruct ( isdecrelhzleh n m ) as [ l | nl ] . apply l . destruct ( nl ng ) .  Defined . \n\nDefinition neghzlthtogeh ( n m : hz ) : neg ( hzlth n m ) -> hzgeh n m := fun nl => neghzgthtoleh _ _ nl . \n\n\n\n(** *** Comparison alternatives *)\n\n\nDefinition hzgthorleh ( n m : hz ) : coprod ( hzgth n m ) ( hzleh n m ) .\nProof . intros . apply ( isdecrelhzgth n m ) .  Defined . \n\nDefinition hzlthorgeh ( n m : hz ) : coprod ( hzlth n m ) ( hzgeh n m ) := hzgthorleh _ _ .\n\nDefinition hzneqchoice ( n m : hz ) ( ne : neg ( paths n m ) ) : coprod ( hzgth n m ) ( hzlth n m ) .\nProof . 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 . \n\nDefinition hzlehchoice ( n m : hz ) ( l : hzleh n m ) : coprod ( hzlth n m ) ( paths n m ) .\nProof .  intros . destruct ( hzlthorgeh n m ) as [ l' | g ] .   apply ( ii1 l' ) . apply ( ii2 ( isantisymmhzleh _ _ l g ) ) . Defined . \n\nDefinition hzgehchoice ( n m : hz ) ( g : hzgeh n m ) : coprod ( hzgth n m ) ( paths n m ) .\nProof .  intros . destruct ( hzgthorleh n m ) as [ g' | l ] .  apply ( ii1 g' ) .  apply ( ii2 ( isantisymmhzleh _ _ l g ) ) .  Defined . \n\n\n\n\n(** *** Mixed transitivities *)\n\n\n\nLemma hzgthgehtrans ( n m k : hz ) : hzgth n m -> hzgeh m k -> hzgth n k .\nProof. 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. \n\nLemma hzgehgthtrans ( n m k : hz ) : hzgeh n m -> hzgth m k -> hzgth n k .\nProof. intros n m k gnm gmk . destruct ( hzgehchoice n m gnm ) as [ g' | e ] . apply ( istranshzgth _ _ _ g' gmk ) .  rewrite e .  apply gmk . Defined. \n\nLemma hzlthlehtrans ( n m k : hz ) : hzlth n m -> hzleh m k -> hzlth n k .\nProof . intros n m k l1 l2 . apply ( hzgehgthtrans k m n l2 l1 ) . Defined . \n\nLemma hzlehlthtrans ( n m k : hz ) : hzleh n m -> hzlth m k -> hzlth n k .\nProof . intros n m k l1 l2 . apply ( hzgthgehtrans k m n l2 l1 ) . Defined .\n\n\n\n\n(** *** Addition and comparisons  *)\n\n\n\n(** [ hzgth ] *)\n\n\nDefinition hzgthandplusl ( n m k : hz ) : hzgth n m -> hzgth ( k + n ) ( k + m ) .\nProof. apply ( pr1 ( isbinopabgrfracrel nataddabmonoid isplushrelnatgth ) ) .   Defined . \n\nDefinition hzgthandplusr ( n m k : hz ) : hzgth n m -> hzgth ( n + k ) ( m + k ) .\nProof. apply ( pr2 ( isbinopabgrfracrel nataddabmonoid isplushrelnatgth ) ) .  Defined . \n\nDefinition hzgthandpluslinv  ( n m k : hz ) : hzgth ( k + n ) ( k + m ) -> hzgth n m  .\nProof. 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 .\n\nDefinition hzgthandplusrinv ( n m k : hz ) :  hzgth ( n + k ) ( m + k ) -> hzgth n m  . \nProof. intros n m k l . rewrite ( hzpluscomm n k ) in l . rewrite ( hzpluscomm m k ) in l . apply ( hzgthandpluslinv _ _ _ l )  . Defined . \n\nLemma hzgthsnn ( n : hz ) : hzgth ( n + 1 ) n . \nProof . intro . set ( int := hzgthandplusl _ _ n ( ct ( hzgth , isdecrelhzgth, 1 , 0 ) ) ) . clearbody int . rewrite ( hzplusr0 _ ) in int .   apply int . Defined . \n\n\n(** [ hzlth ] *)\n\n\nDefinition hzlthandplusl ( n m k : hz ) : hzlth n m -> hzlth ( k + n ) ( k + m )  := hzgthandplusl _ _ _ . \n\nDefinition hzlthandplusr ( n m k : hz ) : hzlth n m -> hzlth ( n + k ) ( m + k ) := hzgthandplusr _ _ _ .\n\nDefinition hzlthandpluslinv  ( n m k : hz ) : hzlth ( k + n ) ( k + m ) -> hzlth n m := hzgthandpluslinv _ _ _ .\n\nDefinition hzlthandplusrinv ( n m k : hz ) :  hzlth ( n + k ) ( m + k ) -> hzlth n m := hzgthandplusrinv _ _ _ .\n\nDefinition hzlthnsn ( n : hz ) : hzlth n ( n + 1 ) := hzgthsnn n . \n\n\n\n(** [ hzleh ] *)\n\n\nDefinition hzlehandplusl ( n m k : hz ) : hzleh n m -> hzleh ( k + n ) ( k + m ) := negf ( hzgthandpluslinv n m k )  . \n\nDefinition hzlehandplusr ( n m k : hz ) : hzleh n m -> hzleh ( n + k ) ( m + k ) := negf ( hzgthandplusrinv n m k )  . \n\nDefinition hzlehandpluslinv  ( n m k : hz ) : hzleh ( k + n ) ( k + m ) -> hzleh n m := negf ( hzgthandplusl n m k )  .  \n\nDefinition hzlehandplusrinv ( n m k : hz ) :  hzleh ( n + k ) ( m + k ) -> hzleh n m :=  negf ( hzgthandplusr n m k ) . \n\n\n\n(** [ hzgeh ] *)\n\n\nDefinition hzgehandplusl ( n m k : hz ) : hzgeh n m -> hzgeh ( k + n ) ( k + m ) := negf ( hzgthandpluslinv m n k ) .  \n\nDefinition hzgehandplusr ( n m k : hz ) : hzgeh n m -> hzgeh ( n + k ) ( m + k ) := negf ( hzgthandplusrinv m n k )  . \n\nDefinition hzgehandpluslinv  ( n m k : hz ) : hzgeh ( k + n ) ( k + m ) -> hzgeh n m := negf ( hzgthandplusl m n k )  . \n\nDefinition hzgehandplusrinv ( n m k : hz ) :  hzgeh ( n + k ) ( m + k ) -> hzgeh n m :=  negf ( hzgthandplusr m n k ) . \n\n\n\n\n(** *** Properties of [ hzgth ] in the terminology of  algebra1.v (continued below)\n\nNote: 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 ] . *)\n\nLemma isplushrelhzgth : @isbinophrel hzaddabgr hzgth . \nProof . split . apply  hzgthandplusl .  apply hzgthandplusr .  Defined . \n\nLemma isinvplushrelhzgth : @isinvbinophrel hzaddabgr hzgth . \nProof . split . apply  hzgthandpluslinv .  apply hzgthandplusrinv .  Defined . \n\nLemma isrngmulthzgth : isrngmultgt _ hzgth .\nProof . apply ( isrngrigtorngmultgt natcommrig isplushrelnatgth isrigmultgtnatgth )  . Defined . \n\nLemma  isinvrngmulthzgth : isinvrngmultgt _ hzgth .\nProof . apply ( isinvrngrigtorngmultgt natcommrig isplushrelnatgth isinvplushrelnatgth isinvrigmultgtnatgth ) . Defined . \n\n\n\n(** *** Negation and comparisons *)\n\n(** [ hzgth ] *)\n\nLemma hzgth0andminus  { n : hz } ( is : hzgth n 0 ) : hzlth ( - n ) 0 .\nProof . intros . apply ( rngfromgt0 hz isplushrelhzgth ) . apply is . Defined . \n\nLemma hzminusandgth0  { n : hz } ( is : hzgth ( - n ) 0 ) : hzlth n 0 .\nProof . intros . apply ( rngtolt0 hz isplushrelhzgth ) . apply is . Defined . \n\n\n(** [ hzlth ] *)\n\nLemma hzlth0andminus  { n : hz } ( is : hzlth n 0 ) : hzgth ( - n ) 0 .\nProof . intros . apply ( rngfromlt0 hz isplushrelhzgth ) . apply is . Defined . \n\nLemma hzminusandlth0  { n : hz } ( is : hzlth ( - n ) 0 ) : hzgth n 0 .\nProof . intros .  apply ( rngtogt0 hz isplushrelhzgth ) . apply is . Defined .\n\n(* ??? Coq slows down on the proofs of these two lemmas for no good reason. *) \n\n\n(** [ hzleh ] *)\n\nLemma hzleh0andminus  { n : hz } ( is : hzleh n 0 ) : hzgeh ( - n ) 0 .\nProof . intro n . apply ( negf ( @hzminusandlth0 n ) ) . Defined .  \n\nLemma hzminusandleh0  { n : hz } ( is : hzleh ( - n ) 0 ) : hzgeh n 0 .\nProof . intro n . apply ( negf ( @hzlth0andminus n ) ) . Defined .  \n\n\n\n(** [ hzgeh ] *)\n\nLemma hzgeh0andminus  { n : hz } ( is : hzgeh n 0 ) : hzleh ( - n ) 0 .\nProof . intro n . apply ( negf ( @hzminusandgth0 n ) ) . Defined .  \n\nLemma hzminusandgeh0  { n : hz } ( is : hzgeh ( - n ) 0 ) : hzleh n 0 .\nProof . intro n . apply ( negf ( @hzgth0andminus n ) ) . Defined .  \n\n\n\n(** *** Multiplication and comparisons  *)\n\n\n(** [ hzgth ] *)\n \n\nDefinition hzgthandmultl ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth n m -> hzgth ( k * n ) ( k * m ) .\nProof. apply ( isrngmultgttoislrngmultgt _ isplushrelhzgth isrngmulthzgth ) .   Defined . \n\nDefinition hzgthandmultr ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth n m -> hzgth ( n * k ) ( m * k )  .\nProof . apply ( isrngmultgttoisrrngmultgt _ isplushrelhzgth isrngmulthzgth ) . Defined .\n\nDefinition  hzgthandmultlinv ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth ( k * n ) ( k * m ) -> hzgth n m .\nProof . intros n m k is is' .  apply ( isinvrngmultgttoislinvrngmultgt hz isplushrelhzgth isinvrngmulthzgth n m k is is' ) .  Defined . \n\nDefinition hzgthandmultrinv ( n m k : hz ) ( is : hzgth k hzzero ) : hzgth ( n * k ) ( m * k ) -> hzgth n m .\nProof.   intros n m k is is' .  apply ( isinvrngmultgttoisrinvrngmultgt hz isplushrelhzgth isinvrngmulthzgth n m k is is' ) .  Defined . \n\n\n\n(** [ hzlth ] *)\n\n\nDefinition hzlthandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzlth n m -> hzlth ( k * n ) ( k * m )  := hzgthandmultl _ _ _ is .\n\nDefinition hzlthandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzlth n m -> hzlth ( n * k ) ( m * k ) := hzgthandmultr _ _ _ is .\n\nDefinition hzlthandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzlth ( k * n ) ( k * m ) -> hzlth n m := hzgthandmultlinv _ _ _ is .\n\nDefinition hzlthandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzlth ( n * k ) ( m * k ) -> hzlth n m := hzgthandmultrinv _ _ _ is .\n\n\n(** [ hzleh ] *)\n\n\nDefinition hzlehandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzleh n m -> hzleh ( k * n ) ( k * m ) := negf ( hzgthandmultlinv _ _ _ is ) .\n\nDefinition hzlehandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzleh n m -> hzleh ( n * k ) ( m * k ) := negf ( hzgthandmultrinv _ _ _ is ) .\n\nDefinition hzlehandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzleh ( k * n ) ( k * m ) -> hzleh n m := negf ( hzgthandmultl _ _ _ is )  .\n\nDefinition hzlehandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzleh ( n * k ) ( m * k ) -> hzleh n m := negf ( hzgthandmultr _ _ _ is ) .\n\n\n(** [ hzgeh ] *)\n\n\nDefinition hzgehandmultl ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh n m -> hzgeh ( k * n ) ( k * m ) := negf ( hzgthandmultlinv _ _ _ is ) .\n\nDefinition hzgehandmultr ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh n m -> hzgeh ( n * k ) ( m * k )  := negf ( hzgthandmultrinv _ _ _ is ) .\n\nDefinition hzgehandmultlinv ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh ( k * n ) ( k * m ) -> hzgeh n m := negf ( hzgthandmultl _ _ _ is )   .\n\nDefinition hzgehandmultrinv ( n m k : hz ) ( is : hzgth k 0 ) : hzgeh ( n * k ) ( m * k ) -> hzgeh n m := negf ( hzgthandmultr _ _ _ is )  .\n\n\n\n(** Multiplication of positive with positive, positive with negative, negative with positive, two negatives etc. *)\n\nLemma hzmultgth0gth0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzgth n 0 ) : hzgth ( m * n ) 0 .\nProof . intros . apply isrngmulthzgth . apply ism . apply isn . Defined .  \n\nLemma hzmultgth0geh0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzgeh n 0 ) : hzgeh ( m * n ) 0 .\nProof . intros .  destruct ( hzgehchoice _ _ isn ) as [ gn | en ] . \n\napply ( hzgthtogeh _ _ ( hzmultgth0gth0  ism gn ) ) . \n\nrewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined .\n\n\nLemma hzmultgeh0gth0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzgth n 0 ) : hzgeh ( m * n ) 0 .\nProof .  intros .  destruct ( hzgehchoice _ _ ism ) as [ gm | em ] . \n\napply ( hzgthtogeh _ _ ( hzmultgth0gth0 gm isn ) ) . \n\nrewrite em .  rewrite ( hzmult0x _ ) . apply isreflhzgeh . Defined .\n \n\nLemma hzmultgeh0geh0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzgeh n 0 ) : hzgeh ( m * n ) 0 .\nProof . intros .   destruct ( hzgehchoice _ _ isn ) as [ gn | en ] . \n\napply ( hzmultgeh0gth0 ism gn ) . \n\nrewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined .\n\n\nLemma hzmultgth0lth0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzlth n 0 ) : hzlth ( m * n ) 0 .\nProof . intros . apply ( rngmultgt0lt0 hz isplushrelhzgth isrngmulthzgth ) . apply ism . apply isn . Defined .  \n\nLemma hzmultgth0leh0 { m n : hz } ( ism : hzgth m 0 ) ( isn : hzleh n 0 ) : hzleh ( m * n ) 0 .\nProof . intros .  destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . \n\napply ( hzlthtoleh _ _ ( hzmultgth0lth0  ism ln ) ) . \n\nrewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzleh . Defined .\n\nLemma hzmultgeh0lth0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzlth n 0 ) : hzleh ( m * n ) 0 .\nProof .  intros .  destruct ( hzlehchoice _ _ ism ) as [ lm | em ] . \n\napply ( hzlthtoleh _ _ ( hzmultgth0lth0 lm isn ) ) . \n\ndestruct em .  rewrite ( hzmult0x _ ) . apply isreflhzleh . Defined .\n\nLemma hzmultgeh0leh0 { m n : hz } ( ism : hzgeh m 0 ) ( isn : hzleh n 0 ) : hzleh ( m * n ) 0 .\nProof . intros .   destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . \n\napply ( hzmultgeh0lth0 ism ln ) . \n\nrewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzleh . Defined .\n\n\n\nLemma hzmultlth0gth0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzgth n 0 ) : hzlth ( m * n ) 0 .\nProof . intros . rewrite ( hzmultcomm ) .  apply hzmultgth0lth0 . apply isn . apply ism .  Defined .  \n\nLemma hzmultlth0geh0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzgeh n 0 ) : hzleh ( m * n ) 0 .\nProof . intros . rewrite ( hzmultcomm ) .  apply hzmultgeh0lth0 . apply isn . apply ism .  Defined .  \n\n\nLemma hzmultleh0gth0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzgth n 0 ) : hzleh ( m * n ) 0 .\nProof . intros . rewrite ( hzmultcomm ) .  apply hzmultgth0leh0 . apply isn . apply ism .  Defined .  \n\n\nLemma hzmultleh0geh0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzgeh n 0 ) : hzleh ( m * n ) 0 .\nProof . intros . rewrite ( hzmultcomm ) .  apply hzmultgeh0leh0 . apply isn . apply ism .  Defined .  \n\n\nLemma hzmultlth0lth0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzlth n 0 ) : hzgth ( m * n ) 0 .\nProof . intros . assert ( ism' := hzlth0andminus ism ) .  assert ( isn' := hzlth0andminus isn ) . assert ( int := isrngmulthzgth _ _ ism' isn' ) . rewrite ( rngmultminusminus hz ) in int .  apply int . Defined . \n\nLemma hzmultlth0leh0 { m n : hz } ( ism : hzlth m 0 ) ( isn : hzleh n 0 ) : hzgeh ( m * n ) 0 .\nProof . intros . intros .  destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . \n\napply ( hzgthtogeh _ _ ( hzmultlth0lth0  ism ln ) ) . \n\nrewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzgeh . Defined .\n\nLemma hzmultleh0lth0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzlth n 0 ) : hzgeh ( m * n ) 0 .\nProof . intros . destruct ( hzlehchoice _ _ ism ) as [ lm | em ] . \n\napply ( hzgthtogeh _ _ ( hzmultlth0lth0 lm isn ) ) . \n\nrewrite em .  rewrite ( hzmult0x _ ) . apply isreflhzgeh .  Defined .\n \nLemma hzmultleh0leh0 { m n : hz } ( ism : hzleh m 0 ) ( isn : hzleh n 0 ) : hzgeh ( m * n ) 0 .\nProof . intros .  destruct ( hzlehchoice _ _ isn ) as [ ln | en ] . \n\napply ( hzmultleh0lth0 ism ln ) . \n\nrewrite en .  rewrite ( hzmultx0 m ) . apply isreflhzgeh .   Defined .\n\n\n\n\n(** *** [ hz ] as an integral domain *)\n\n\nLemma isintdomhz : isintdom hz .\nProof . 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 . \n\n\nDefinition hzintdom : intdom := tpair _ _ isintdomhz .  \n\nDefinition hzneq0andmult ( n m : hz ) ( isn : hzneq n 0 ) ( ism : hzneq m 0 ) : hzneq ( n * m ) 0 := intdomneq0andmult hzintdom n m isn ism . \n\nLemma hzmultlcan ( a b c : hz ) ( ne : neg ( paths c 0 ) ) ( e : paths ( c * a ) ( c * b ) ) : paths a b .\nProof . intros . apply ( intdomlcan hzintdom _ _ _ ne e ) . Defined .\n\nLemma hzmultrcan ( a b c : hz ) ( ne : neg ( paths c 0 ) ) ( e : paths ( a * c ) ( b * c ) ) : paths a b .\nProof . intros . apply ( intdomrcan hzintdom _ _ _ ne e ) . Defined .\n\nLemma isinclhzmultl ( n : hz )( ne : neg ( paths n 0 ) ) : isincl ( fun m : hz => n * m ) .\nProof.  intros .  apply ( pr1 ( intdomiscancelable hzintdom n ne ) ) . Defined .\n\nLemma isinclhzmultr ( n : hz )( ne : neg ( paths n 0 ) ) : isincl ( fun m : hz => m * n ) .\nProof. intros . apply ( pr2 ( intdomiscancelable hzintdom n ne ) ) . Defined. \n \n\n\n\n\n\n(** *** Comparisons and [ n -> n + 1 ] *)\n\nDefinition hzgthtogths ( n m : hz ) : hzgth n m -> hzgth ( n + 1 ) m  .\nProof. intros n m is . apply ( istranshzgth _ _ _ ( hzgthsnn n ) is ) . Defined .\n \nDefinition hzlthtolths ( n m : hz ) : hzlth n m -> hzlth n ( m + 1 ) := hzgthtogths _ _ . \n\nDefinition hzlehtolehs ( n m : hz ) : hzleh n m -> hzleh n ( m + 1 ) .  \nProof . intros n m is . apply ( istranshzleh _ _ _ is ( hzlthtoleh _ _ ( hzlthnsn _ ) ) ) . Defined .\n\nDefinition hzgehtogehs ( n m : hz ) : hzgeh n m -> hzgeh ( n + 1 ) m := hzlehtolehs _ _  .\n \n\n\n(** *** Two comparisons and [ n -> n + 1 ] *)\n\nLemma hzgthtogehsn ( n m : hz ) : hzgth n m -> hzgeh n ( m + 1 ) .\nProof. 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 . \n\nLemma hzgthsntogeh ( n m : hz ) : hzgth ( n + 1 ) m -> hzgeh n m .\nProof. intros n m a . apply (hzgehandplusrinv n m 1) . apply ( hzgthtogehsn ( n + 1 ) m a ) . Defined. (* PeWa *) \n\nLemma hzlehsntolth ( n m : hz ) : hzleh ( n + 1 )  m -> hzlth n m .\nProof.  intros n m X . apply ( hzlthlehtrans _ _ _ ( hzlthnsn n ) X ) .  Defined . \n\nLemma hzlthtolehsn ( n m : hz ) : hzlth n m -> hzleh ( n + 1 )  m .\nProof. intros n m X . apply ( hzgthtogehsn m n X ) . Defined .\n\nLemma hzlthsntoleh ( n m : hz ) : hzlth n ( m + 1 ) -> hzleh n m .\nProof. intros n m a . apply (hzlehandplusrinv n m 1) . apply ( hzlthtolehsn n ( m + 1 ) a ) . Defined. (* PeWa *) \n\nLemma hzgehsntogth ( n m : hz ) : hzgeh n ( m + 1 ) -> hzgth n m .\nProof. intros n m X . apply ( hzlehsntolth m n X ) .  Defined .  \n\n\n(** *** Comparsion alternatives and [ n -> n + 1 ] *)\n\n\nLemma hzlehchoice2 ( n m : hz ) : hzleh n m -> coprod ( hzleh ( n + 1 )  m ) ( paths n m ) .\nProof . intros n m l . destruct ( hzlehchoice n m l ) as [ l' | e ] .   apply ( ii1 ( hzlthtolehsn _ _ l' ) ) . apply ( ii2 e ) .  Defined . \n\n\nLemma hzgehchoice2 ( n m : hz ) : hzgeh n m -> coprod ( hzgeh n ( m + 1 ) ) ( paths n m ) .\nProof . intros n m g . destruct ( hzgehchoice n m g ) as [ g' | e ] .   apply ( ii1 ( hzgthtogehsn _ _ g' ) ) . apply ( ii2 e ) . Defined . \n\n\nLemma hzgthchoice2 ( n m : hz ) : hzgth n m -> coprod ( hzgth n ( m + 1 ) ) ( paths n ( m + 1 ) ) .\nProof.  intros n m g . destruct ( hzgehchoice _ _ ( hzgthtogehsn _ _ g ) ) as [ g' | e ] . apply ( ii1 g' ) .  apply ( ii2 e ) .  Defined . \n\n\nLemma hzlthchoice2 ( n m : hz ) : hzlth n m -> coprod ( hzlth ( n + 1 )  m ) ( paths ( n + 1 )  m ) .\nProof.  intros n m l . destruct ( hzlehchoice _ _ ( hzlthtolehsn _ _ l ) ) as [ l' | e ] . apply ( ii1 l' ) .  apply ( ii2 e ) .   Defined . \n   \n\n\n(** *** Operations and comparisons on [ hz ] and [ natnattohz ] *)\n\nLemma natnattohzandgth ( xa1 xa2 : dirprod nat nat ) ( is : hzgth ( setquotpr _ xa1 ) ( setquotpr _ xa2 ) ) : natgth ( ( pr1 xa1 ) + ( pr2 xa2 ) ) ( ( pr1 xa2 ) + ( pr2 xa1 ) ) .  \nProof . 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 . \n\nLemma natnattohzandlth ( xa1 xa2 : dirprod nat nat ) ( is : hzlth ( setquotpr _ xa1 ) ( setquotpr _ xa2 ) ) : natlth ( ( pr1 xa1 ) + ( pr2 xa2 ) ) ( ( pr1 xa2 ) + ( pr2 xa1 ) ) . \nProof . intros . apply ( natnattohzandgth xa2 xa1 is ) .  Defined .  \n\n\n\n(** *** Canonical rig homomorphism from [ nat ] to [ hz ] *)\n\nDefinition nattohz : nat -> hz := fun n => setquotpr _ ( dirprodpair n 0%nat ) .\n\nDefinition isinclnattohz : isincl nattohz := isincltorngdiff natcommrig ( fun n => isinclnatplusr n ) . \n\nDefinition nattohzandneq ( n m : nat ) ( is : natneq n m ) : hzneq ( nattohz n ) ( nattohz m ) := negf ( invmaponpathsincl _ isinclnattohz n m ) is . \n\nDefinition nattohzand0 : paths ( nattohz 0%nat ) 0 := idpath _ . \n\nDefinition nattohzandS ( n : nat ) : paths ( nattohz ( S n ) ) ( 1 + nattohz n ) := isbinop1funtorngdiff natcommrig 1%nat n .  \n\nDefinition nattohzand1 : paths ( nattohz 1%nat ) 1 := idpath _ . \n\nDefinition nattohzandplus ( n m : nat ) : paths ( nattohz ( n + m )%nat ) ( nattohz n + nattohz m ) := isbinop1funtorngdiff natcommrig n m .\n\nDefinition nattohzandminus ( n m : nat ) ( is : natgeh n m ) : paths ( nattohz ( n - m )%nat ) ( nattohz n - nattohz m ) .\nProof . 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 . \n\nOpaque nattohzandminus . \n\nDefinition nattohzandmult ( n m : nat ) : paths ( nattohz ( n * m )%nat ) ( nattohz n * nattohz m ) .\nProof . intros . simpl . change nattohz with ( torngdiff natcommrig ) . apply ( isbinop2funtorngdiff natcommrig n m ) . Defined . \n\nDefinition nattohzandgth ( n m : nat ) ( is : natgth n m ) : hzgth ( nattohz n ) ( nattohz m ) := iscomptorngdiff natcommrig isplushrelnatgth n m is . \n\nDefinition nattohzandlth ( n m : nat ) ( is : natlth n m ) : hzlth ( nattohz n ) ( nattohz m ) := nattohzandgth m n is . \n\nDefinition nattohzandleh ( n m : nat ) ( is : natleh n m ) : hzleh ( nattohz n ) ( nattohz m ) .\nProof . intros . destruct ( natlehchoice _ _ is ) as [ l | e ] .   apply ( hzlthtoleh _ _ ( nattohzandlth _ _ l ) ) .  rewrite e .  apply ( isreflhzleh ) .  Defined . \n\nDefinition nattohzandgeh ( n m : nat ) ( is : natgeh n m ) : hzgeh ( nattohz n ) ( nattohz m ) := nattohzandleh _ _ is . \n\n\n\n(** *** Addition and subtraction on [ nat ] and [ hz ] *)\n\n\n\n(** *** Absolute value on [ hz ] *)\n\nDefinition hzabsvalint : ( dirprod nat nat ) -> nat .\nProof . intro nm . destruct ( natgthorleh ( pr1 nm ) ( pr2  nm ) ) .  apply ( minus ( pr1 nm ) ( pr2 nm ) ) . apply ( minus ( pr2 nm ) ( pr1 nm ) ) . Defined .\n       \nLemma hzabsvalintcomp : @iscomprelfun ( dirprod nat nat ) nat ( hrelabgrfrac nataddabmonoid )  hzabsvalint .\nProof . 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 ) . \n\ndestruct int as [isgt | isle ] . destruct int' as [ isgt' | isle' ] .\n\napply ( 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' . \n\nassert ( 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'''' ) .  \n\ndestruct int' as [ isgt' | isle' ] . \n\ndestruct ( 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'''' ) .  \n\napply ( 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' ) . \nDefined . \n\nDefinition hzabsval : hz -> nat := setquotuniv _ natset hzabsvalint hzabsvalintcomp . \n\nLemma hzabsval0 : paths ( hzabsval 0 ) 0%nat .\nProof .  apply idpath .  Defined . \n\nLemma hzabsvalgth0 { x : hz } ( is : hzgth x 0 ) : paths ( nattohz ( hzabsval x ) ) x .\nProof . 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 ] .  \n\nrewrite ( minusplusnmm _ _ ( natlthtoleh _ _ g'' ) ) . apply idpath . \n\ndestruct ( l g' ) .  Defined .  \n\nOpaque hzabsvalgth0 .\n\nLemma hzabsvalgeh0 { x : hz } ( is : hzgeh x 0 ) : paths ( nattohz ( hzabsval x ) ) x .\nProof .  intros . destruct ( hzgehchoice _ _ is ) as [ g | e ] .  apply ( hzabsvalgth0 g ) . rewrite e .  apply idpath .  Defined . \n\nLemma hzabsvallth0 { x : hz } ( is : hzlth x 0 ) : paths ( nattohz ( hzabsval x ) ) ( - x ) .\nProof . 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'' ] .  \n\ndestruct ( isasymmnatgth _ _ g l' ) .\n\nrewrite ( minusplusnmm _ _ l'' ) . apply idpath . Defined .\n\nOpaque hzabsvallth0 .\n\nLemma hzabsvalleh0 { x : hz } ( is : hzleh x 0 ) : paths ( nattohz ( hzabsval x ) ) ( - x ) .\nProof .  intros . destruct ( hzlehchoice _ _ is ) as [ l | e ] .  apply ( hzabsvallth0 l ) . rewrite e .  apply idpath .  Defined . \n\n \nLemma hzabsvaleq0 { x : hz } ( e :  paths ( hzabsval x ) 0%nat ) : paths x 0  .\nProof .  intros . destruct ( isdeceqhz x 0 ) as [ e0 | ne0 ] . apply e0 .  destruct ( hzneqchoice _ _ ne0 ) as [ g | l ] .  \n\nassert ( e' := hzabsvalgth0 g ) . rewrite e in e' . change ( paths 0 x ) in e' .  apply ( pathsinv0 e' ) .\n\nassert ( 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 .  \n \nDefinition hzabsvalneq0 { x : hz } := negf ( @hzabsvaleq0 x ) . \n\nLemma hzabsvalandmult ( a b : hz ) : paths ( ( hzabsval a ) * ( hzabsval b ) )%nat ( hzabsval ( a * b ) ) . \nProof . intros . apply ( invmaponpathsincl _ isinclnattohz ) . rewrite ( nattohzandmult _ _ ) .  destruct ( hzgthorleh a 0 ) as [ ga | lea ] . destruct ( hzgthorleh b 0 ) as [ gb | leb ] . \n\nrewrite ( hzabsvalgth0 ga ) .  rewrite ( hzabsvalgth0 gb ) .  rewrite ( hzabsvalgth0 ( hzmultgth0gth0 ga gb ) ) . apply idpath . \n\nrewrite ( hzabsvalgth0 ga ) .  rewrite ( hzabsvalleh0 leb ) . rewrite ( hzabsvalleh0 ( hzmultgth0leh0 ga leb ) ) .    apply ( rngrmultminus hz ) .  destruct ( hzgthorleh b 0 ) as [ gb | leb ] . \n \nrewrite ( hzabsvalgth0 gb ) .  rewrite ( hzabsvalleh0 lea ) . rewrite ( hzabsvalleh0 ( hzmultleh0gth0 lea gb ) ) . apply ( rnglmultminus hz ) . \n\nrewrite ( hzabsvalleh0 lea ) . rewrite ( hzabsvalleh0 leb ) . rewrite ( hzabsvalgeh0 ( hzmultleh0leh0 lea leb ) ) .  apply (rngmultminusminus hz ) . Defined . \n\n\n\n\n   \n\n\nEval lazy in ( hzbooleq ( natnattohz 3 4 ) ( natnattohz 17 18 ) ) . \nEval lazy in ( hzbooleq ( natnattohz 3 4 ) ( natnattohz 17 19 ) ) . \n\nEval lazy in ( hzabsval ( natnattohz 58 332 ) ) .  \nEval lazy in ( hzabsval ( hzplus ( natnattohz 2 3 ) ( natnattohz 3 2 ) ) ) . \nEval lazy in ( hzabsval ( hzminus ( natnattohz 2 3 ) ( natnattohz 3 2 ) ) ) .\n\nEval lazy in  ( hzabsval ( hzmult ( natnattohz 20 50 ) ( natnattohz 30 20 ) ) ) .\n\n\n\n\n\n\n(* End of the file hz.v *)\n"
  },
  {
    "path": "hlevel2/stnfsets.v",
    "content": "(** * Standard finite sets . Vladimir Voevodsky . Apr. - Sep. 2011 .\n\nThis file contains main constructions related to the standard finite sets defined as the initial intervals of [ nat ] and their properties . *)\n\n\n\n\n(** ** Preambule *)\n\n(** Settings *)\n\nUnset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *)\n\n\n\n(** Imports. *)\n\nAdd LoadPath \"../../\" .\n\nRequire Export Foundations.hlevel2.hnat .\n\n\n(* To up-stream files *)\n\n\n\n\n\n\n\n(** ** Standard finite sets [ stn ] . *)\n\n\n\nDefinition stn ( n : nat ) := total2 ( fun m : nat => natlth m n ) .\nDefinition stnpair ( n : nat ) := tpair ( fun m : nat => natlth m n ) .\nDefinition stntonat ( n : nat ) : stn n -> nat := @pr1 _ _ .\nCoercion stntonat : stn >-> nat .\n\nNotation \" 'stnel' ( i , j ) \" := ( stnpair _ _  ( ctlong natlth isdecrelnatlth j i ( idpath true ) ) ) ( at level 70 ) .\n\nLemma isinclstntonat ( n : nat ) : isincl ( stntonat n ) .\nProof. intro .  apply isinclpr1 .  intro x .  apply ( pr2 ( natlth x n ) ) .  Defined.\n\nLemma isdecinclstntonat ( n : nat ) : isdecincl ( stntonat n ) .\nProof. intro . apply isdecinclpr1 .  intro x . apply isdecpropif . apply ( pr2 _ ) .   apply isdecrelnatgth .  Defined . \n\nLemma neghfiberstntonat ( n m : nat ) ( is : natgeh m n ) : neg ( hfiber ( stntonat n ) m ) .\nProof. 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 .\n\nLemma iscontrhfiberstntonat ( n m : nat ) ( is : natlth m n ) : iscontr ( hfiber ( stntonat n ) m ) .\nProof. intros .  apply ( iscontrhfiberofincl ( stntonat n ) ( isinclstntonat n ) ( stnpair n m is ) ) .  Defined . \n\nLemma isisolatedinstn { n : nat } ( x : stn n ) : isisolated _ x.\nProof. intros . apply ( isisolatedinclb ( stntonat n ) ( isinclstntonat n ) x ( isisolatedn x ) ) .  Defined. \n\nCorollary isdeceqstn ( n : nat ) : isdeceq (stn n).\nProof. intro.  unfold isdeceq. intros x x' . apply (isisolatedinstn x x' ). Defined.\n\nDefinition weqisolatedstntostn ( n : nat ) : weq ( isolated ( stn n ) ) ( stn n ) .\nProof . intro . apply weqpr1 . intro x .   apply iscontraprop1 .  apply ( isapropisisolated ) . set ( int := isdeceqstn n x  ) . assumption .  Defined . \n\n\nCorollary isasetstn ( n : nat ) : isaset ( stn n ) .\nProof. intro . apply ( isasetifdeceq _ ( isdeceqstn n ) ) . Defined . \n\nDefinition stnposet ( i : nat ) : Poset .\nProof. 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. \n\n\nDefinition lastelement ( n : nat ) : stn ( S n ) .\nProof. intro .   split with n .  apply ( natgthsnn ( S n ) ) .  Defined . \n\nDefinition 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 .  \n\n\n\n\n(** ** \"Boundary\" maps [ dni : stn n -> stn ( S n ) ] and their properties . *) \n\n\n\nDefinition dni ( n : nat ) ( i : stn ( S n ) ) : stn n -> stn ( S n ) .\nProof. 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.  \n\nLemma dnicommsq ( n : nat ) ( i : stn ( S n ) ) : commsqstr( dni n i )  ( stntonat ( S n ) ) ( stntonat n ) ( di i )  .\nProof. intros . intro x . unfold dni . unfold di . destruct ( natlthorgeh x i ) .  simpl .  apply idpath . simpl .  apply idpath . Defined . \n\nTheorem dnihfsq ( n : nat ) ( i : stn ( S n ) ) : hfsqstr ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni n i ) .\nProof. intros . apply ( ishfsqweqhfibersgtof' ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni n i ) ( dnicommsq _ _  ) ) . intro x . destruct ( natlthorgeh x n ) as [ g | l ] . \n\nassert ( is1 : iscontr ( hfiber ( stntonat n ) x ) ) . apply iscontrhfiberstntonat . assumption .\nassert ( is2 : iscontr ( hfiber ( stntonat ( S n ) ) ( di i x )  ) ) .    apply iscontrhfiberstntonat . apply ( natlehlthtrans _ ( S x ) ( S n ) ( natlehdinsn i x ) g ) .  \napply isweqcontrcontr . assumption . assumption . \n\nassert ( 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 ) .\nDefined . \n\n\n\nLemma weqhfiberdnihfiberdi ( n : nat ) ( i j : stn ( S n ) ) : weq ( hfiber ( dni n i ) j ) ( hfiber ( di i ) j ) .\nProof.  intros . apply ( weqhfibersg'tof _ _ _ _ ( dnihfsq n i ) j ) . Defined .\n\nLemma neghfiberdni ( n : nat ) ( i : stn ( S n ) ) : neg ( hfiber ( dni n i ) i ) . \nProof. intros . apply ( negf ( weqhfiberdnihfiberdi n i i ) ( neghfiberdi i ) ) . Defined .  \n\nLemma iscontrhfiberdni ( n : nat ) ( i j : stn ( S n ) ) ( ne : neg ( paths i j ) ) : iscontr ( hfiber ( dni n i ) j ) .\nProof . intros . set ( ne' := negf ( invmaponpathsincl _ ( isinclstntonat ( S n ) ) _ _ ) ne ) .  apply ( iscontrweqb ( weqhfiberdnihfiberdi n i j ) ( iscontrhfiberdi i j ne' ) ) .  Defined . \n\nLemma isdecincldni ( n : nat ) ( i : stn ( S n ) ) : isdecincl ( dni n i ) .\nProof.  intros . intro j . destruct ( isdeceqstn _ i j ) . rewrite i0 .  apply ( isdecpropfromneg ( neghfiberdni n j ) ) . apply ( isdecpropfromiscontr ( iscontrhfiberdni _ _ _ e ) ) .  Defined . \n \nLemma isincldni ( n : nat ) ( i : stn ( S n ) ) : isincl ( dni n i ) .\nProof. intros . apply ( isdecincltoisincl _  ( isdecincldni n i ) ) .  Defined . \n\n\n\n\n\n\n(** ** Weak equivalences between standard finite sets and constructions on these sets *)\n\n\n\n(** *** The weak equivalence from [ stn n ] to the compl of a point [ j ] in [ stn ( S n ) ] defined by [ dni n j ] *)\n\n\nDefinition dnitocompl ( n : nat ) ( i : stn ( S n ) ) ( j : stn n ) : compl ( stn ( S n ) ) i .\nProof. intros . split with ( dni n i j ) .  intro e .  apply ( neghfiberdni n i ( hfiberpair _ j ( pathsinv0 e ) ) ) .  Defined .\n\nLemma isweqdnitocompl  ( n : nat ) ( i : stn ( S n ) ) : isweq ( dnitocompl n i ) .\nProof. 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 . \n\n\nDefinition weqdnicompl ( n : nat ) ( i : stn ( S n ) ) := weqpair _ ( isweqdnitocompl n i ) . \n\n\n\n\n(** *** Weak equivalence from [ coprod ( stn n ) unit ] to [ stn ( S n ) ] defined by [ dni n i ] *)\n\n\nDefinition weqdnicoprod  ( n : nat ) ( j : stn ( S n ) ) : weq ( coprod ( stn n ) unit ) ( stn ( S n ) ) .\nProof . intros . apply ( weqcomp ( weqcoprodf ( weqdnicompl n j ) ( idweq unit ) ) ( weqrecompl ( stn ( S n ) ) j ( isdeceqstn ( S n ) j ) ) ) .  Defined . \n\n\n\n\n(** *** Weak equivalences from [ stn n ] for [ n = 0 , 1 , 2 ] to [ empty ] , [ unit ] and [ bool ] ( see also the section on [ nelstruct ] in finitesets.v ) . *)\n\nDefinition negstn0 : neg ( stn 0 ) .\nProof . intro x .  destruct x as [ a b ] .  apply ( negnatlthn0 _ b ) . Defined . \n\nDefinition weqstn0toempty : weq ( stn 0 ) empty .\nProof .  apply weqtoempty . apply negstn0 . Defined .  \n\nDefinition weqstn1tounit : weq ( stn 1 ) unit .\nProof. 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 .\n\nCorollary iscontrstn1 : iscontr ( stn 1 ) .\nProof. apply iscontrifweqtounit . apply weqstn1tounit . Defined . \n\nLemma isinclfromstn1 { X : UU } ( f : stn 1 -> X ) ( is : isaset X ) : isincl f .\nProof. intros . apply ( isinclbetweensets f ( isasetstn 1 ) is ) . intros x x' e . apply ( invmaponpathsweq weqstn1tounit x x' ( idpath tt ) )  .  Defined .    \n\nDefinition weqstn2tobool : weq ( stn 2 ) bool .\nProof. 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 . \nassert ( 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 ) ) .  \nassert ( efg : forall b : _ , paths ( f ( g b ) ) b ) . intro b .  unfold g .  destruct b . apply idpath . apply idpath. \napply ( gradth _ _ egf efg ) . Defined . \n\n\n\n\n\n\n(** ***  Weak equivalence between the coproduct of [ stn n ] and [ stn m ] and [ stn ( n + m ) ] *)\n\nTheorem weqfromcoprodofstn ( n m : nat ) : weq ( coprod ( stn n ) ( stn m ) ) ( stn ( n + m ) ) .\nProof. intros . \n\nassert ( i1 : forall i : nat , natlth i n -> natlth i ( n + m ) ) . intros i1 l . apply ( natlthlehtrans _ _ _ l ( natlehnplusnm n m ) ) .    \nassert ( i2 : forall i : nat , natlth i m -> natlth ( i + n ) ( n + m ) ) .  intros i2 l .  rewrite ( natpluscomm i2  n ) .  apply natgthandplusl . assumption . \nset ( 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 ) . \nsplit with f . \n\nassert ( 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 ] .\n\ndestruct 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 ) .  \n\ndestruct 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 ) ) .  \n\nintro jl . apply iscontraprop1 .  apply ( is jl ) .   destruct jl as [ j l ] . destruct ( natgthorleh n j ) as [ i | ni ] .\n \nsplit with ( ii1 ( stnpair _ j i ) ) . simpl .   apply ( invmaponpathsincl _ ( isinclstntonat ( n + m ) )  (stnpair (n + m) j (i1 j i)) ( stnpair _ j l )  ( idpath j ) ) .\n\nset ( 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 .\n\n\n\n(** *** Weak equivalence from the total space of a family [ stn ( f x ) ]  over [ stn n ] to [ stn ( stnsum n f ) ] *)\n\nDefinition stnsum { n : nat } ( f : stn n -> nat ) : nat .\nProof. 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 . \n\nTheorem 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 ) ) .\nProof . 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 . \n\n\nCorollary 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 ) ) .\nProof. 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 . \n\n\n\n(** *** Weak equivalence between the direct product of [ stn n ] and [ stn m ] and [ stn n * m ] *)\n\nTheorem weqfromprodofstn ( n m : nat ) : weq ( dirprod ( stn n ) ( stn m ) ) ( stn ( n * m ) ) .\nProof .  intros . destruct ( natgthorleh m 0 ) as [ is | i ] . \n\nassert ( 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 ) ) ) .     \n\nset ( 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 . \n\nassert ( 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' .\nassert ( eei : paths i i' ) . apply ( pr1 ( natdivremunique m i j i' j' lj lj' ( maponpaths ( stntonat _ ) e ) ) ) .    \nset ( eeis := invmaponpathsincl _ ( isinclstntonat _ ) ( stnpair _ i li ) ( stnpair _ i' li' ) eei ) .\nassert ( eej : paths j j' ) . apply ( pr2 ( natdivremunique m i j i' j' lj lj' ( maponpaths ( stntonat _ ) e ) ) ) . \nset ( eejs := invmaponpathsincl _ ( isinclstntonat _ ) ( stnpair _ j lj ) ( stnpair _ j' lj' ) eej ) . apply ( pathsdirprod eeis eejs ) . \n\nintro 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 .\n\nset ( e := natleh0tois0 _ i ) .  rewrite e .  rewrite ( natmultn0 n ) . split with ( @pr2 _ _ ) .   apply ( isweqtoempty2 _ ( weqstn0toempty ) ) . Defined . \n\n\n(** *** Weak equivalences between decidable subsets of [ stn n ] and [ stn x ] *)\n\nTheorem weqfromdecsubsetofstn { n : nat } ( f : stn n -> bool ) : total2 ( fun x : nat => weq ( hfiber f true ) ( stn x ) ) .\nProof . 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 . \n\nset ( 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 ) ) ) .  \n\nset ( x0 := pr1 ( IHn fh ) ) . set ( w0 := pr2 ( IHn fh ) ) . simpl in w0 . destruct ( boolchoice ( fl ( lastelement 0 ) ) ) as [ i | ni ] .  \n\nsplit 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 _ ) ) . \n\nsplit 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 . \n\n(** *** Weak equivalences between hfibers of functions from [ stn n ] over isolated points and [ stn x ] *)\n\nTheorem 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 ) ) .\nProof . 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 . \n\n\n\n\n\n(** *** Weak equivalence between [ stn n -> stn m ] and [ stn ( natpower m n ) ] ( uses functional extensionality ) *) \n\n\nTheorem weqfromfunstntostn ( n m : nat ) : weq ( stn n -> stn m ) ( stn ( natpower m n ) ) .\nProof. intro n . induction n as [ | n IHn ] . intro m .  apply weqcontrcontr . apply ( iscontrfunfromempty2 _ weqstn0toempty ) .  apply iscontrstn1 .\nintro 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 . \n\n\n\n\n\n(** *** Weak equivalence from the space of functions of a family [ stn ( f x ) ]  over [ stn n ] to [ stn ( stnprod n f ) ] ( uses functional extensionality ) *)\n\nDefinition stnprod { n : nat } ( f : stn n -> nat ) : nat .\nProof. 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 . \n\nTheorem 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 ) ) .\nProof . 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 . \n\n\n\n\n(** *** Weak equivalence between [ weq ( stn n ) ( stn n ) ] and [ stn ( factorial n ) ] ( uses functional extensionality ) *)\n\nTheorem  weqweqstnsn ( n : nat ) : weq ( weq ( stn ( S n ) ) ( stn ( S n ) ) ) ( dirprod ( stn ( S n ) ) ( weq ( stn n ) ( stn n ) ) ) .\nProof . 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 .   \n\n\nTheorem weqfromweqstntostn ( n : nat ) : weq ( weq ( stn n ) ( stn n ) ) ( stn ( factorial n ) ) . \nProof . 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 . \n\n\n(* End of \" weak equivalences between standard finite sets and constructions on these sets \" . *)\n\n\n\n\n\n\n\n(** ** Standard finite sets satisfy weak axiom of choice *)\n\nTheorem ischoicebasestn ( n : nat ) : ischoicebase ( stn n ) .\nProof . intro . induction n as [ | n IHn ] .  apply ( ischoicebaseempty2 negstn0 ) .  apply ( ischoicebaseweqf ( weqdnicoprod n ( lastelement n ) ) ( ischoicebasecoprod IHn ischoicebaseunit ) ) .  Defined . \n\n\n\n\n\n\n\n(** ** Weak equivalence class of [ stn n ] determines [ n ] . *)\n\n\nLemma negweqstnsn0 (n:nat): neg (weq (stn (S n)) (stn O)).\nProof. unfold neg. intro. assert (lp: stn (S n)). apply lastelement.  intro X.  apply weqstn0toempty .  apply (pr1 X lp). Defined.\n\nLemma negweqstn0sn (n:nat): neg (weq (stn O) (stn (S n))).\nProof.  unfold neg. intro. assert (lp: stn (S n)). apply lastelement.  intro X.  apply weqstn0toempty .  apply (pr1 ( invweq X ) lp). Defined.\n\nLemma weqcutforstn ( n n' : nat ) ( w : weq (stn (S n)) (stn (S n')) ) : weq (stn n) (stn n').\nProof. 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 .   \n\n\nTheorem weqtoeqstn ( n n' : nat ) ( w : weq (stn n) (stn n') ) : paths n n'.\nProof. intro. induction n as [ | n IHn ] . intro. destruct n' as [ | n' ] .  intros. apply idpath. intro X. apply (fromempty (negweqstn0sn  n' X)).  \n 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. \nset (e:= IHn n' ( weqcutforstn _ _ X)). apply (maponpaths S e). Defined. \n\nCorollary stnsdnegweqtoeq ( n n' : nat ) ( dw : dneg (weq (stn n) (stn n')) ) : paths n n'.\nProof. intros n n' X. apply (eqfromdnegeq nat isdeceqnat _ _  (dnegf (@weqtoeqstn n n') X)). Defined. \n\n\n\n\n(** ** Some results on bounded quantification *)\n\n\nLemma weqforallnatlehn0 ( F : nat -> hProp ) : weq ( forall n : nat , natleh n 0 -> F n ) ( F 0 ) .\nProof . 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 . \n\nLemma 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' ) ) ) . \nProof . 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 .\n\nLemma weqexistsnatlehn0 ( P : nat -> hProp  ) : weq ( hexists ( fun n : nat => dirprod ( natleh n 0 ) ( P n ) ) ) ( P 0 ) .\nProof . 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 .\n\nLemma 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' ) ) ) .\nProof . 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 .  \n\n\nLemma isdecbexists ( n : nat ) ( P : nat -> UU ) ( is : forall n' , isdecprop ( P n' ) ) : isdecprop ( hexists ( fun n' => dirprod ( natleh n' n ) ( P n' ) ) ) .\nProof . 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 .   \n\nLemma isdecbforall ( n : nat ) ( P : nat -> UU ) ( is : forall n' , isdecprop ( P n' ) ) : isdecprop ( forall n' , natleh n' n -> P n' )  .\nProof . 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 .   \n\n \n\n(** 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. *)\n\nLemma 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' ) ) ) .\nProof . 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 . \n\n\n(** ** Accesibility - the least element of an inhabited decidable subset of [nat] *)\n\nDefinition 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' ) ) .\n\nLemma isapropnatdecleast ( F : nat -> UU ) ( is : forall n , isdecprop ( F n ) ) : isaprop ( natdecleast F is ) .\nProof . 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 .\n\nTheorem accth ( F : nat -> UU ) ( is : forall n , isdecprop ( F n ) )  ( is' : hexists F ) : natdecleast F is .\nProof . intros F is . simpl . apply (@hinhuniv _ ( hProppair _ ( isapropnatdecleast F is ) ) ) . intro t2. destruct t2 as [ n l ] . simpl .\n\nset ( 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'' . \n\nassert ( 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' . \n\napply ( X n ( hinhpr _ ( tpair _ n ( dirprodpair ( isreflnatleh n ) l ) ) ) ) .  Defined . \n\n\n  \n\n\n\n\n\n\n\n\n\n(* End of the file stnfsets.v *)\n\n\n"
  }
]