Showing preview only (897K chars total). Download the full file or copy to clipboard to get everything.
Repository: vladimirias/Foundations
Branch: master
Commit: df19211f602a
Files: 28
Total size: 871.6 KB
Directory structure:
gitextract_d3i8cydv/
├── .gitignore
├── Coq_patches/
│ ├── README
│ ├── fix-hanging-at-end-of-proof.patch
│ ├── grayson-closedir-after-opendir.patch
│ ├── grayson-fix-infinite-loop.patch
│ ├── grayson-improved-abstraction-version2-8.3pl2.patch
│ ├── inductive-indice-levels-matter-8.3.patch
│ └── patch.type-in-type
├── Current_work/
│ ├── 2013_from_poset.v
│ ├── bsystem.v
│ ├── semisimplicial.v
│ └── semisimplicial2.v
├── Generalities/
│ ├── uu0.v
│ └── uuu.v
├── Makefile
├── Proof_of_Extensionality/
│ └── funextfun.v
├── README
├── hlevel1/
│ └── hProp.v
└── hlevel2/
├── algebra1a.v
├── algebra1b.v
├── algebra1c.v
├── algebra1d.v
├── finitesets.v
├── hSet.v
├── hnat.v
├── hq.v
├── hz.v
└── stnfsets.v
================================================
FILE CONTENTS
================================================
================================================
FILE: .gitignore
================================================
.#*
*.html
*.css
*.vo
*.glob
*.v.d
TAGS
.#*
html
================================================
FILE: Coq_patches/README
================================================
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/ .
Hugo's patches "inductive-indice-levels-matter-8.3.patch" and "patch.type-in-type" are intended only as a temporary solution for the universe management issues in Coq which arise in connection with the univalent approach.
The first of these patches changes the way the universe level of inductive types is computed for those definitions which do not specify [ Set ] or [ Prop ] as the target of the inductive construction 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:
[ Inductive Ind ( a1 : A1 ) : forall a2 : A2 , Type := ... ]
The 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.
The second patch switches off the universe consistency checking in Coq which is a temporary measure which allows us to formalize interesting constructions such as [ ishinh ] and [ setquot ] without having the resizing rules.
Dan's patches have the following functions (see also comments in the individual patches):
1. "grayson-closedir-after-opendir.patch" imporoves the management of file openings/closing and eliminates in most cases the complaint that there arev too many open files.
2. "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.
3. "grayson-improved-abstraction-version2-8.3pl2.patch" this patch dramatically improves the behavior of the [destruct] tactic making it applicable in many the cases when dependencies are present. It is not creating any complicated proof terms but simply uses the eliminator for inductive definitions in a more intelligent way than the standard [ destruct ] .
4. "grayson-fix-infinite-loop.patch" fixes another hanging situation.
The 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):
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ ./configure --prefix /opt/local
You have GNU Make >= 3.81. Good!
You have Objective-Caml 3.11.2. Good!
LablGtk2 not found: CoqIde will not be available.
pngtopnm was not found; documentation will not be available
Coq top directory : /Applications/coq-8.3pl2_two_patches_and_Dan_3
Architecture : i386
Coq VM bytecode link flags : -custom
Coq tools bytecode link flags : -custom
OS dependent libraries : -cclib -lunix
Objective-Caml/Camlp4 version : 3.11.2
Objective-Caml/Camlp4 binaries in : /opt/local/bin
Objective-Caml library in : /opt/local/lib/ocaml
Camlp4 library in : +camlp5
Native dynamic link support : true
Documentation : None
CoqIde : no
Web browser : firefox -remote "OpenURL(%s,new-tab)" || firefox %s &
Coq web site : http://coq.inria.fr/
Paths for true installation:
binaries will be copied in /opt/local/bin
library will be copied in /opt/local/lib/coq
man pages will be copied in /opt/local/man
documentation will be copied in /opt/local/share/doc/coq
emacs mode will be copied in /opt/local/share/emacs/site-lisp
If anything in the above is wrong, please restart './configure'.
*Warning* To compile the system for a new architecture
don't forget to do a 'make archclean' before './configure'.
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p1 < inductive-indice-levels-matter-8.3.patch
patching file kernel/indtypes.ml
patching file kernel/inductive.ml
patching file kernel/inductive.mli
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p3 < patch.type-in-type
patching file kernel/reduction.ml
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < fix-hanging-at-end-of-proof.patch
patching file kernel/closure.ml
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < grayson-fix-infinite-loop.patch
patching file ./tactics/tactics.ml
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < grayson-improved-abstraction-version2-8.3pl2.patch
patching file ./configure
patching file ./pretyping/evd.ml
patching file ./pretyping/evd.mli
patching file ./pretyping/pretype_errors.ml
patching file ./pretyping/pretype_errors.mli
patching file ./pretyping/unification.ml
patching file ./pretyping/unification.mli
patching file ./proofs/logic.ml
patching file ./tactics/tactics.ml
patching file ./test-suite/success/unification.v
patching file ./test-suite/success/unification2.v
patching file ./toplevel/himsg.ml
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < grayson-closedir-after-opendir.patch
patching file ./lib/system.ml
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ sudo make GOTO_STAGE=2 coqbinaries states
....
fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ sudo make install .
(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. )
================================================
FILE: Coq_patches/fix-hanging-at-end-of-proof.patch
================================================
diff -ub coq-8.3pl2-clean/kernel/closure.ml coq-8.3pl2-no-universe-constraints--index-levels-matter/kernel/closure.ml
--- kernel/closure.ml 2010-07-28 07:22:04.000000000 -0500
+++ kernel/closure.ml 2011-10-03 14:48:17.000000000 -0500
@@ -17,7 +17,7 @@
open Esubst
let stats = ref false
-let share = ref true
+let share = ref false
(* Profiling *)
let beta = ref 0
================================================
FILE: Coq_patches/grayson-closedir-after-opendir.patch
================================================
This patch will leave many few file descriptors unclosed.
Dan Grayson
diff -ur ../coq-8.3pl2-clean/lib/system.ml ./lib/system.ml
--- ../coq-8.3pl2-clean/lib/system.ml 2010-12-24 03:55:54.000000000 -0600
+++ ./lib/system.ml 2011-10-14 12:49:30.000000000 -0500
@@ -103,7 +103,7 @@
(* All subdirectories, recursively *)
let exists_dir dir =
- try let _ = opendir dir in true with Unix_error _ -> false
+ try let _ = closedir (opendir dir) in true with Unix_error _ -> false
let skipped_dirnames = ref ["CVS"; "_darcs"]
================================================
FILE: Coq_patches/grayson-fix-infinite-loop.patch
================================================
This "fixes" a seemingly infinite loop by abandoning the routine after ten repetitions.
A better fix would involve understanding what the code was supposed to do.
Dan Grayson
diff -ubr ../coq-8.3pl2-clean/tactics/tactics.ml ./tactics/tactics.ml
--- ../coq-8.3pl2-clean/tactics/tactics.ml 2011-04-08 11:59:26.000000000 -0500
+++ ./tactics/tactics.ml 2011-10-07 09:55:24.000000000 -0500
@@ -522,7 +522,10 @@
let pf_lookup_hypothesis_as_renamed_gen red h gl =
let env = pf_env gl in
+ let infinite_loop_detector = ref 0 in
let rec aux ccl =
+ incr infinite_loop_detector;
+ if !infinite_loop_detector > 10 then raise Redelimination;
match pf_lookup_hypothesis_as_renamed env ccl h with
| None when red ->
aux
================================================
FILE: Coq_patches/grayson-improved-abstraction-version2-8.3pl2.patch
================================================
diff -ur ../coq-8.3pl2-patched/configure ./configure
--- ../coq-8.3pl2-patched/configure 2011-04-19 02:19:00.000000000 -0500
+++ ./configure 2011-09-12 18:25:27.000000000 -0500
@@ -6,7 +6,7 @@
#
##################################
-VERSION=8.3pl2
+VERSION=8.3pl2+improved-abstraction
VOMAGIC=08300
STATEMAGIC=58300
DATE=`LANG=C date +"%B %Y"`
@@ -323,8 +323,8 @@
if [ "$MAKE" != "" ]; then
MAKEVERSION=`$MAKE -v | head -1`
case $MAKEVERSION in
- "GNU Make 3.8"[12])
- echo "You have GNU Make >= 3.81. Good!";;
+ "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].* )
+ echo "You have GNU Make $MAKEVERSION >= 3.81. Good!";;
*)
OK="no"
if [ -x ./make ]; then
diff -ur ../coq-8.3pl2-patched/pretyping/evd.ml ./pretyping/evd.ml
--- ../coq-8.3pl2-patched/pretyping/evd.ml 2011-03-10 09:50:24.000000000 -0600
+++ ./pretyping/evd.ml 2011-09-11 06:30:25.000000000 -0500
@@ -675,6 +675,11 @@
metas = Metamap.add mv (Clval(na,(mk_freelisted v,pb),ty)) evd.metas }
| _ -> anomaly "meta_reassign: not yet defined"
+let meta_unassign mv evd =
+ match Metamap.find mv evd.metas with
+ | Clval(na,_,ty) -> { evd with metas = Metamap.add mv (Cltyp(na,ty)) evd.metas }
+ | _ -> anomaly "meta_unassign: not yet defined"
+
(* If the meta is defined then forget its name *)
let meta_name evd mv =
try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous
diff -ur ../coq-8.3pl2-patched/pretyping/evd.mli ./pretyping/evd.mli
--- ../coq-8.3pl2-patched/pretyping/evd.mli 2011-03-10 09:50:24.000000000 -0600
+++ ./pretyping/evd.mli 2011-09-11 06:30:39.000000000 -0500
@@ -224,6 +224,7 @@
metavariable -> types -> ?name:name -> evar_map -> evar_map
val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map
val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map
+val meta_unassign : metavariable -> evar_map -> evar_map
(* [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
val meta_merge : evar_map -> evar_map -> evar_map
diff -ur ../coq-8.3pl2-patched/pretyping/pretype_errors.ml ./pretyping/pretype_errors.ml
--- ../coq-8.3pl2-patched/pretyping/pretype_errors.ml 2010-07-24 10:57:30.000000000 -0500
+++ ./pretyping/pretype_errors.ml 2011-09-13 16:23:06.000000000 -0500
@@ -34,6 +34,7 @@
| CannotGeneralize of constr
| NoOccurrenceFound of constr * identifier option
| CannotFindWellTypedAbstraction of constr * constr list
+ | CannotFindAbstraction of Evd.evar_map * constr * constr list * string
| AbstractionOverMeta of name * name
| NonLinearUnification of name * constr
(* Pretyping *)
@@ -178,6 +179,9 @@
let error_cannot_find_well_typed_abstraction env sigma p l =
raise (PretypeError (env_ise sigma env,CannotFindWellTypedAbstraction (p,l)))
+let error_cannot_find_abstraction env sigma c l msg =
+ raise (PretypeError (env_ise sigma env,CannotFindAbstraction (sigma,c,l,msg)))
+
let error_abstraction_over_meta env sigma hdmeta metaarg =
let m = Evd.meta_name sigma hdmeta and n = Evd.meta_name sigma metaarg in
raise (PretypeError (env_ise sigma env,AbstractionOverMeta (m,n)))
diff -ur ../coq-8.3pl2-patched/pretyping/pretype_errors.mli ./pretyping/pretype_errors.mli
--- ../coq-8.3pl2-patched/pretyping/pretype_errors.mli 2010-07-24 10:57:30.000000000 -0500
+++ ./pretyping/pretype_errors.mli 2011-09-13 16:22:42.000000000 -0500
@@ -35,6 +35,7 @@
| CannotGeneralize of constr
| NoOccurrenceFound of constr * identifier option
| CannotFindWellTypedAbstraction of constr * constr list
+ | CannotFindAbstraction of Evd.evar_map * constr * constr list * string
| AbstractionOverMeta of name * name
| NonLinearUnification of name * constr
(* Pretyping *)
@@ -107,6 +108,9 @@
val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map ->
constr -> constr list -> 'b
+val error_cannot_find_abstraction : env -> Evd.evar_map ->
+ constr -> constr list -> string -> 'b
+
val error_abstraction_over_meta : env -> Evd.evar_map ->
metavariable -> metavariable -> 'b
diff -ur ../coq-8.3pl2-patched/pretyping/unification.ml ./pretyping/unification.ml
--- ../coq-8.3pl2-patched/pretyping/unification.ml 2010-07-26 17:12:43.000000000 -0500
+++ ./pretyping/unification.ml 2011-09-13 17:03:34.000000000 -0500
@@ -28,6 +28,109 @@
open Coercion.Default
open Recordops
+let rec take n x =
+ if n = 0 then [] else
+ match x with
+ [] -> raise Not_found
+ | e::x -> e::(take (n-1) x)
+
+let rec last x = match x with
+ | [] -> error "internal error: empty list"
+ | [e] -> e
+ | _::x -> last x
+
+let all_but_last x = List.rev (List.tl (List.rev x))
+
+let is_well_typed env evd t = try ignore(Typing.type_of env evd t); true with Type_errors.TypeError _ -> false
+
+let meta_name evd mv =
+ match find_meta evd mv with
+ | Cltyp(na,_) -> na
+ | Clval(na,_,_) -> na
+
+let abstract_metas evd mvs t = List.fold_right
+ (fun mv t ->
+ mkLambda( meta_name evd mv, Typing.meta_type evd mv, replace_term (mkMeta mv) (mkRel 1) t))
+ mvs t
+
+let occurrence_count term subterm =
+ let n = ref 0 in
+ let rec f c = if eq_constr subterm c then incr n else iter_constr f c in
+ iter_constr f term;
+ !n
+
+let subsets n =
+ assert (n >= 0);
+ let rec subsets n =
+ if n = 0 then [[]]
+ else
+ let m = n-1 in
+ let s = subsets m in
+ List.append s (List.map (fun t -> m :: t) s) in
+ List.map List.rev (subsets n)
+let cartprod2 x y = List.flatten (List.map (fun t -> List.map (fun u -> t::u) y) x)
+let cartprod z = List.fold_right cartprod2 z [[]]
+let subsetsn l = cartprod (List.map subsets l)
+
+let replace_term_occ occs c by_c in_t =
+ let ctr = ref 0 in
+ let rec f x = (
+ if eq_constr c x
+ then (
+ let x' = if List.mem !ctr occs then by_c else x in
+ incr ctr;
+ x'
+ )
+ else map_constr f x
+ ) in
+ f in_t
+
+let select f x =
+ let rec select f = function
+ | [] -> []
+ | a::x -> if f a then a :: select f x else select f x in
+ select f x
+
+let abstract_list_search_warning = ref (function (env:env) -> function (evd:evar_map) -> function (survivors:constr list) -> assert false)
+
+let always_search = true (* true for development, false for production *)
+
+let abstract_list_search env evd2 typ c l =
+ let c_orig = c in
+ let l_orig = l in
+ let elimA = List.rev (take (List.length l) (List.map fst (meta_list evd2))) in
+ let k = last l in
+ let l = all_but_last l in
+ let psvar = all_but_last elimA in
+ let evd = List.fold_right meta_unassign psvar evd2 in
+ let psvalpairs = List.map (fun mv -> (mv,meta_value evd2 mv)) psvar in
+ let ispsval t =
+ let rec f = function [] -> None | (mv,v)::rest -> if eq_constr t v then Some mv else f rest in
+ f psvalpairs in
+ let c = replace_term k (mkMeta (last elimA)) c in
+ let c =
+ let rec f t = match ispsval t with Some mv -> mkMeta mv | None -> map_constr f t in
+ map_constr f c in
+ let psvargoalcount = List.map (occurrence_count c) (List.map mkMeta psvar) in
+ let totcount = List.fold_right (+) psvargoalcount 0 in
+ if totcount > 16 then error_cannot_find_abstraction env evd2 c_orig l_orig "attempted, more than 16 replacement spots";
+ let psvaroccs = subsetsn psvargoalcount in
+ let possibilities = List.map
+ (fun occlist -> List.fold_right2 (fun occ (mv,vl) goal -> replace_term_occ occ (mkMeta mv) vl goal) occlist psvalpairs c)
+ psvaroccs in
+ let survivors = select (is_well_typed env evd) possibilities in
+ let survivors = List.map (abstract_metas evd elimA) survivors in
+ begin
+ match List.length survivors with
+ 0 -> error_cannot_find_abstraction env evd2 c_orig l_orig "possible"
+ | 1 -> ()
+ | _ -> !abstract_list_search_warning env evd2 survivors
+ end;
+ let p = List.hd survivors in
+ if is_conv_leq env evd2 (Typing.type_of env evd2 p) typ
+ then p
+ else error "internal error: abstraction not convertible?"
+
let occur_meta_or_undefined_evar evd c =
let rec occrec c = match kind_of_term c with
| Meta _ -> raise Occur
@@ -930,7 +1033,8 @@
let (evd',cllist) =
w_unify_to_subterm_list env flags allow_K p oplist typ evd in
let typp = Typing.meta_type evd' p in
- let pred = abstract_list_all env evd' typp typ cllist in
+ let pred = try abstract_list_all env evd' typp typ cllist
+ with PretypeError _ -> abstract_list_search env evd' typp typ cllist in
w_merge env false flags (evd',[p,pred,(ConvUpToEta 0,TypeProcessed)],[])
let w_unify2 env flags allow_K cv_pb ty1 ty2 evd =
diff -ur ../coq-8.3pl2-patched/pretyping/unification.mli ./pretyping/unification.mli
--- ../coq-8.3pl2-patched/pretyping/unification.mli 2010-07-24 10:57:30.000000000 -0500
+++ ./pretyping/unification.mli 2011-09-12 12:27:16.000000000 -0500
@@ -52,3 +52,6 @@
(* (exported for inv.ml) *)
val abstract_list_all :
env -> evar_map -> constr -> constr -> constr list -> constr
+
+
+val abstract_list_search_warning : (env -> evar_map -> Term.constr list -> unit) ref
diff -ur ../coq-8.3pl2-patched/proofs/logic.ml ./proofs/logic.ml
--- ../coq-8.3pl2-patched/proofs/logic.ml 2010-07-26 17:12:43.000000000 -0500
+++ ./proofs/logic.ml 2011-09-12 11:47:14.000000000 -0500
@@ -58,7 +58,7 @@
(* unification errors *)
| PretypeError(_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _
|NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _
- |CannotFindWellTypedAbstraction _|OccurCheck _
+ |CannotFindAbstraction _|CannotFindWellTypedAbstraction _|OccurCheck _
|UnsolvableImplicit _)) -> true
| Typeclasses_errors.TypeClassError
(_, Typeclasses_errors.UnsatisfiableConstraints _) -> true
diff -ur ../coq-8.3pl2-patched/tactics/tactics.ml ./tactics/tactics.ml
--- ../coq-8.3pl2-patched/tactics/tactics.ml 2011-10-11 07:28:57.000000000 -0500
+++ ./tactics/tactics.ml 2011-10-10 16:38:28.000000000 -0500
@@ -134,7 +134,9 @@
errorlabstrm "" (pr_id id ++ str " is used in conclusion.")
| Evarutil.OccurHypInSimpleClause (Some id') ->
errorlabstrm ""
- (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".")
+ (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str"." ++ fnl() ++ fnl()
+ ++ str "The context:" ++ fnl() ++ str " " ++ Printer.pr_context_of env
+ )
| Evarutil.EvarTypingBreak ev ->
errorlabstrm ""
(str "Cannot remove " ++ pr_id id ++
@@ -1912,13 +1914,8 @@
let argl = snd (decompose_app indtyp) in
let c = List.nth argl (i-1) in
match kind_of_term c with
- | Var id when not (List.exists (occur_var (pf_env gl) id) avoid) ->
- atomize_one (i-1) ((mkVar id)::avoid) gl
| Var id ->
- let x = fresh_id [] id gl in
- tclTHEN
- (letin_tac None (Name x) (mkVar id) None allHypsAndConcl)
- (atomize_one (i-1) ((mkVar x)::avoid)) gl
+ atomize_one (i-1) ((mkVar id)::avoid) gl
| _ ->
let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
Anonymous in
diff -ur ../coq-8.3pl2-patched/test-suite/success/unification.v ./test-suite/success/unification.v
--- ../coq-8.3pl2-patched/test-suite/success/unification.v 2010-04-07 17:01:23.000000000 -0500
+++ ./test-suite/success/unification.v 2011-09-12 17:55:41.000000000 -0500
@@ -136,3 +136,4 @@
Proof.
intros.
rewrite H.
+Abort.
diff -ur ../coq-8.3pl2-patched/test-suite/success/unification2.v ./test-suite/success/unification2.v
--- ../coq-8.3pl2-patched/test-suite/success/unification2.v 2011-10-11 07:31:05.000000000 -0500
+++ ./test-suite/success/unification2.v 2011-09-12 18:11:59.000000000 -0500
@@ -0,0 +1,35 @@
+(* tests to go with Grayson's patch to "destruct" for handling Univalent Foundations *)
+
+Unset Automatic Introduction.
+
+(* Voevodsky's original example: *)
+
+Definition test ( X : Type ) ( x : X ) ( fxe : forall x1 : X , identity x1 x1 ) : identity ( fxe x ) ( fxe x ).
+Proof. intros. destruct ( fxe x ). apply identity_refl. Defined.
+
+(* a harder example *)
+
+Definition UU := Type .
+Inductive paths {T:Type}(t:T): T -> UU := idpath: paths t t.
+Inductive foo (X0:UU) (x0:X0) : forall (X:UU)(x:X) , UU := newfoo : foo X0 x0 X0 x0.
+Definition idonfoo {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo X0 x0 X1 x1 -> foo X0 x0 X1 x1.
+Proof. intros * t. exact t. Defined.
+
+Lemma hA (T:UU) (t:T) (k : foo T t T t) : paths k (idonfoo k).
+Proof. intros.
+ destruct k.
+ unfold idonfoo.
+ apply idpath.
+Defined.
+
+(* an example with two constructors *)
+
+Inductive foo' (X0:UU) (x0:X0) : forall (X:UU)(x:X) , UU := newfoo1 : foo' X0 x0 X0 x0 | newfoo2 : foo' X0 x0 X0 x0 .
+Definition idonfoo' {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo' X0 x0 X1 x1 -> foo' X0 x0 X1 x1.
+Proof. intros * t. exact t. Defined.
+Lemma tryb2 (T:UU) (t:T) (k : foo' T t T t) : paths k (idonfoo' k).
+Proof. intros.
+ destruct k.
+ unfold idonfoo'. apply idpath.
+ unfold idonfoo'. apply idpath.
+Defined.
diff -ur ../coq-8.3pl2-patched/toplevel/himsg.ml ./toplevel/himsg.ml
--- ../coq-8.3pl2-patched/toplevel/himsg.ml 2010-09-24 17:23:07.000000000 -0500
+++ ./toplevel/himsg.ml 2011-09-13 17:07:40.000000000 -0500
@@ -439,6 +439,16 @@
str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++
str "which is ill-typed."
+let explain_cannot_find_abstraction env evd c l msg =
+ str "Abstraction over the " ++
+ str (plural (List.length l) "term") ++ spc () ++
+ hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++
+ str "not" ++ spc() ++ str msg ++ str "." ++
+ fnl() ++ fnl() ++ str "The context:" ++ fnl() ++
+ str " " ++ pr_context_of env ++
+ fnl() ++ fnl() ++ str "The term to be abstracted: " ++ fnl() ++ fnl() ++
+ str " " ++ pr_constr c
+
let explain_abstraction_over_meta _ m n =
strbrk "Too complex unification problem: cannot find a solution for both " ++
pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "."
@@ -502,6 +512,8 @@
| CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n
| CannotFindWellTypedAbstraction (p,l) ->
explain_cannot_find_well_typed_abstraction env p l
+ | CannotFindAbstraction (evd,c,l,msg) ->
+ explain_cannot_find_abstraction env evd c l msg
| AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n
| NonLinearUnification (m,c) -> explain_non_linear_unification env m c
@@ -850,3 +862,8 @@
pr_enum pr_call calls ++ strbrk kind_of_last_call)
else
mt ()
+
+let _ =
+ Unification.abstract_list_search_warning :=
+ function env -> function evd -> function l ->
+ msgnl(str "warning: multiple well-typed abstractions found:" ++ (fnl()) ++ prlist_with_sep fnl pr_constr l)
================================================
FILE: Coq_patches/inductive-indice-levels-matter-8.3.patch
================================================
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index df3670d..3e33ffb 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -161,11 +161,14 @@ let extract_level (_,_,_,lc,lev) =
if Array.length lc >= 2 then sup type0_univ lev else lev
let inductive_levels arities inds =
- let levels = Array.map pi3 arities in
- let cstrs_levels = Array.map extract_level inds in
+ let levels = Array.map (fun (_,_,_,lev) -> lev) arities in
+ let arsign_levels = Array.map (fun (_,_,arlev,_) -> arlev) arities in
+ let inds_levels = Array.map extract_level inds in
+ (* Add the constraints coming from the real arguments *)
+ let inds_levels = array_map2 sup arsign_levels inds_levels in
(* Take the transitive closure of the system of constructors *)
(* level constraints and remove the recursive dependencies *)
- solve_constraints_system levels cstrs_levels
+ solve_constraints_system levels inds_levels
(* This (re)computes informations relevant to extraction and the sort of an
arity or type constructor; we do not to recompute universes constraints *)
@@ -184,9 +187,14 @@ let infer_constructor_packet env_ar_par params lc =
let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in
(* compute *)
let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in
-
(info,lc'',level,cst)
+let rel_context_level env sign =
+ fst (List.fold_right
+ (fun (_,_,t as d) (lev,env) ->
+ sup (univ_of_sort (fst (infer_type env t)).utj_type) lev, push_rel d env)
+ sign (type0m_univ,env))
+
(* Type-check an inductive definition. Does not check positivity
conditions. *)
let typecheck_inductive env mie =
@@ -216,10 +224,12 @@ let typecheck_inductive env mie =
let lev =
(* Decide that if the conclusion is not explicitly Type *)
(* then the inductive type is not polymorphic *)
- match kind_of_term ((strip_prod_assum arity.utj_val)) with
+ match kind_of_term (strip_prod_assum arity.utj_val) with
| Sort (Type u) -> Some u
| _ -> None in
- (cst,env_ar',(id,full_arity,lev)::l))
+ let arsign, _ = dest_arity env_params arity.utj_val in
+ let arsign_lev = rel_context_level env_params arsign in
+ (cst,env_ar',(id,full_arity,arsign_lev,lev)::l))
(cst1,env,[])
mie.mind_entry_inds in
@@ -255,15 +265,15 @@ let typecheck_inductive env mie =
(* Compute/check the sorts of the inductive types *)
let ind_min_levels = inductive_levels arities inds in
let inds, cst =
- array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst ->
+ array_fold_map2' (fun ((id,full_arity,arsign_level,ind_level),cn,info,lc,_) lev cst ->
let sign, s = dest_arity env full_arity in
let status,cst = match s with
- | Type u when ar_level <> None (* Explicitly polymorphic *)
+ | Type u when ind_level <> None (* Explicitly polymorphic *)
&& no_upper_constraints u cst ->
(* The polymorphic level is a function of the level of the *)
(* conclusions of the parameters *)
(* We enforce [u >= lev] in case [lev] has a strict upper *)
- (* constraints over [u] *)
+ (* constraint over [u] *)
Inr (param_ccls, lev), enforce_geq u lev cst
| Type u (* Not an explicit occurrence of Type *) ->
Inl (info,full_arity,s), enforce_geq u lev cst
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 24b0751..a81531e 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -202,13 +202,13 @@ let type_of_inductive env (_,mip) =
(* The max of an array of universes *)
-let cumulate_constructor_univ u = function
- | Prop Null -> u
- | Prop Pos -> sup type0_univ u
- | Type u' -> sup u u'
+let univ_of_sort = function
+ | Prop Pos -> type0m_univ
+ | Prop Null -> type0_univ
+ | Type u -> u
let max_inductive_sort =
- Array.fold_left cumulate_constructor_univ type0m_univ
+ Array.fold_left (fun u s -> sup u (univ_of_sort s)) type0m_univ
(************************************************************************)
(* Type of a constructor *)
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index a0fba8e..188a1cb 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -88,6 +88,8 @@ val check_cofix : env -> cofixpoint -> unit
val type_of_inductive_knowing_parameters :
env -> one_inductive_body -> types array -> types
+val univ_of_sort : sorts -> universe
+
val max_inductive_sort : sorts array -> universe
val instantiate_universes : env -> rel_context ->
================================================
FILE: Coq_patches/patch.type-in-type
================================================
diff --git a/branches/v8.3/kernel/reduction.ml b/branches/v8.3/kernel/reduction.ml
index aa50f78..77e6072 100644
--- a/branches/v8.3/kernel/reduction.ml
+++ b/branches/v8.3/kernel/reduction.ml
@@ -183,10 +183,13 @@ let sort_cmp pb s0 s1 cuniv =
if c1 = c2 then cuniv else raise NotConvertible
| (Prop c1, Type u) when pb = CUMUL -> assert (is_univ_variable u); cuniv
| (Type u1, Type u2) ->
+ cuniv
+(*
assert (is_univ_variable u2);
(match pb with
| CONV -> enforce_eq u1 u2 cuniv
| CUMUL -> enforce_geq u2 u1 cuniv)
+*)
| (_, _) -> raise NotConvertible
================================================
FILE: Current_work/2013_from_poset.v
================================================
Unset Automatic Introduction.
Add LoadPath ".." .
Require Export Foundations.hlevel2.finitesets.
(* Standard finite posets and order preserving functions between them. *)
Notation " 'stnel' ( i , j ) " := ( stnpair _ _ ( ctlong natlth isdecrelnatlth j i ( idpath true ) ) ) ( at level 70 ) .
Definition stnposet ( i : nat ) : Poset .
Proof. intro. unfold Poset . split with ( hSetpair ( stn i ) ( isasetstn i ) ) . unfold po. split with ( fun j1 j2 : stn i => natleh j1 j2 ) . split with ( fun j1 j2 j3 : stn i => istransnatleh j1 j2 j3 ) . exact ( fun j : stn i => isreflnatleh j ) . Defined.
Definition issmaller { X : Poset } ( x1 x2 : X ) := dirprod ( pr2 X x1 x2 ) ( neg ( paths x1 x2 ) ) .
Definition 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 ) ) .
Definition ndchainstosequences ( i : nat ) ( X : Poset ) : ndchains i X -> ( stn i ) -> X := fun xstar => fun k => ( pr1 xstar ) k .
Coercion ndchainstosequences : ndchains >-> Funclass .
Lemma natlthinndchainstn { i j : nat } ( ch : ndchains j ( stnposet i ) ) { j1 j2 : stn j } ( is : natlth j1 j2 ) : natlth ( stntonat _ ( ch j1 ) ) ( stntonat _ ( ch j2 ) ) .
Proof . intros .
assert ( is10 : natleh ( stntonat _ ( ch j1 ) ) ( stntonat _ ( ch j2 ) ) ) . apply ( pr1 ( pr2 ch j1 j2 is ) ) .
assert ( is110 : neg ( paths ( ch j1 ) ( ch j2 ) ) ) . apply ( pr2 ( pr2 ch j1 j2 is ) ) .
assert ( is11 : natneq ( stntonat _ ( ch j1 ) ) ( stntonat _ ( ch j2 ) ) ) . apply ( negf ( invmaponpathsincl ( stntonat _ ) ( isinclstntonat _ ) (ch j1 ) ( ch j2 ) ) is110 ) .
destruct ( natlehchoice _ _ is10 ) as [ l | e ]. apply l . destruct ( is11 e ) . Defined.
Definition ndchainsrestr { i j : nat } { X : Poset } ( chs : ndchains j ( stnposet i ) ) ( chX : ndchains i X ) : ndchains j X .
Proof . intros . split with ( fun k : stn j => chX ( chs k ) ) . intros j1 j2 . intro is . apply ( pr2 chX _ _ ( natlthinndchainstn chs is ) ) . Defined.
Definition Ind_tuple ( i : nat ) : total2 ( fun
FSkXtoUUcat : forall ( X : Poset ) , UU (* FSkXtoUUcat X := sk_i(N(X)) -> N(UU_cat) *)
=> total2 ( fun XtoT : total2 ( fun
FSkXtoT : forall ( X : Poset ) ( T : UU ) , UU (* FSkXtoT X T := sk_i(N(X)) -> N(T) *)
=>
forall ( X : Poset ) ( T : UU ) ( F : T -> UU ) , FSkXtoT X T -> FSkXtoUUcat X
)
=> dirprod
( 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) *)
( total2 ( fun
Phi :forall ( j : nat ) ( is : natgeh j i ) ( X : Poset ) ( xstar : ndchains ( S j ) X ) ( d : FSkXtoUUcat X ) , FSkXtoUUcat ( stnposet ( S j ) )
=>
forall ( 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 )
)))) .
Proof. intros . induction i as [ | i IHi].
(* i=0 *)
split with ( fun X : Poset => ( X -> UU ) ) .
split .
split with ( fun X => fun T => ( X -> T ) ) .
exact ( fun X => fun T => fun F => ( fun d => fun x => F ( d x ) ) ) .
split with ( fun f : stnposet 2 -> UU => ( f ( stnel(2,0) ) -> f ( stnel(2,1) ) ) ) .
split with ( fun j => fun is => fun X => fun xstar => fun d => fun k => d ( xstar k ) ) .
intros . apply idpath.
(* i+1 *)
set ( 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 .
(*
FSkXtoUUcat X = Hom ( sk_i(N(X)) , N(UU_cat) )
FSkXtoT X T := Hom ( sk_i(N(X)) , N(T) )
FSkXtoTcomp X T F := fun d : sk_i(N(X)) -> N(T) => F \circ d
FDT d = the type of extensions of d : sk_i(Delta^{i+1}) -> N(UU_cat) to functions Delta^{i+1} -> N(UU_cat)
Phi 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)
*)
(* First split with Hom ( sk_{i+1}(N(X)), N(UU_cat) ) *)
split with ( fun X => total2 ( fun d : FSkXtoUUcat X => forall xstar : ndchains ( S ( S i ) ) X , FDT ( Phi ( S i ) ( natgehsnn i ) X xstar d ) ) ) .
split.
(* 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. *)
split 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 ) ) ) ) .
(* now we need the composition map d : sk_i(N(X)) -> N(T) => F \circ d where F : T -> UU *)
intros X T F dsi . destruct dsi as [ d dall ] . split with ( FSkXtoTcomp X T F d ) . apply ( dall F ) .
split.
(* 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) *)
intro dsi . destruct dsi as [ d dfill ] .
admit.
assert ( Phi0 : forall j : nat,
natgeh j (S i) ->
forall X : Poset,
ndchains (S j) X ->
total2
(fun d : FSkXtoUUcat X =>
forall xstar0 : ndchains (S (S i)) X,
FDT (Phi (S i) (natgehsnn i) X xstar0 d)) ->
total2
(fun d0 : FSkXtoUUcat (stnposet (S j)) =>
forall xstar0 : ndchains (S (S i)) (stnposet (S j)),
FDT (Phi (S i) (natgehsnn i) (stnposet (S j)) xstar0 d0)) ).
intros j is X xstar.
(* 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
xstar : Delta^j -> N(X) *)
intro d . destruct d as [ di dfdt ] . split with ( Phi j (istransnatgeh _ _ _ is (natgehsnn i)) X xstar di ) .
intro xstar0.
set ( xstar1 := ndchainsrestr xstar0 xstar ) .
(* 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
sk_i(Delta^{i+1}->Delta^j->N(X)) -> N(UU_cat) for which we have an extesnion dfdt xstar1 *)
simpl in h . rewrite h . apply ( dfdt xstar1 ) .
split with Phi0 .
intros .
================================================
FILE: Current_work/bsystem.v
================================================
Require Export Foundations.Generalities.uu0.
Unset Automatic Introduction.
(** ** To ustream files of the library *)
Notation hfppru := hfpg' .
Notation hfpprl := hfpg .
Notation fromunit := termfun .
(** To hfiber. *)
Definition tohfiber { X Y : UU } ( f : X -> Y ) ( x : X ) : hfiber f ( f x ) := hfiberpair f x ( idpath _ ) .
(** To hfp *)
Definition 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 .
(** Functoriality of hfp. *)
Lemma hfplhomot { X Y Z : UU } { fl1 fl2 : X -> Y } ( h : homot fl1 fl2 ) ( gr : Z -> Y ) : weq ( hfp fl1 gr ) ( hfp fl2 gr ) .
Proof . intros . refine ( weqgradth _ _ _ _ ) .
{ intro xze . destruct xze as [ xz e ] . split with xz . exact (pathscomp0 e (h (pr1 xz))) . }
{ intro xze . destruct xze as [ xz e ] . split with xz . exact (pathscomp0 e ( pathsinv0 (h (pr1 xz)))) . }
{ intro xze . destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) . destruct ( h ( pr1 xz ) ) . destruct e . apply idpath . }
{ intro xze . destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) . destruct (h (pr1 xz)) . destruct e . apply idpath . }
Defined .
Lemma hfprhomot { X Y Z : UU } ( fl : X -> Y ) { gr1 gr2 : Z -> Y } ( h : homot gr1 gr2 ) : weq ( hfp fl gr1 ) ( hfp fl gr2 ) .
Proof . intros . refine ( weqgradth _ _ _ _ ) .
{ intro xze . destruct xze as [ xz e ] . split with xz . exact (pathscomp0 ( pathsinv0 (h (pr2 xz))) e) . }
{ intro xze . destruct xze as [ xz e ] . split with xz . exact (pathscomp0 (h (pr2 xz)) e) . }
{ intro xze . destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) . destruct ( h ( pr2 xz ) ) . destruct e . apply idpath . }
{ intro xze . destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) . destruct (h (pr2 xz)) . destruct e . apply idpath . }
Defined .
Lemma 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' .
Proof . intros . split with ( dirprodpair ( gt' ( pr1 ( pr1 x ) ) ) ( g' ( pr2 ( pr1 x ) ) ) ) . destruct x as [ x e ] . simpl . destruct x as [ zt z ] .
simpl . simpl in e . destruct ( pathsinv0 ( h_front z ) ) . destruct ( pathsinv0 ( h_down zt ) ) . exact ( maponpaths f e ) . Defined.
Lemma 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' .
Proof. intros . intro z . apply idpath . Defined.
Lemma 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' .
Proof. intros . intro z . apply idpath . Defined.
(** Double pull-backs ( cf. two_pullbacks_isequiv in hott-limits ) . *)
Definition 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 .
Proof. 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.
Definition 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 ) .
Proof. 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.
Definition 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 ) ).
Proof. 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 .
Lemma 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 .
Proof . intros . destruct z as [ [ [ x y ] h ] h0 ] . exact ( tohfiber ( hfpprl fl gr ) ( hfptriple fl gr x0 y ( pathscomp0 h ( maponpaths fl h0 ) ) ) ) . Defined.
Lemma doublehfp_from_to_l2 { Tll Tlr Tur } ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) ( x0 : Tll ) : homot ( doublehfp_from_to_l1 fl gr x0 ) ( idfun _ ) .
Proof. 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 .
Definition 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 ) ) ).
Proof. 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 .
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.
Lemma isweq_doublehfp_from { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) : isweq ( doublehfp_from f'l fl gr ) .
Proof . 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.
(** Note: change these in uu0.v *)
Definition 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 ) .
Proof. intros . split with ( g' ( pr1 ze ) ) . apply ( pathscomp0 ( h ( pr1 ze ) ) ( maponpaths f ( pr2 ze ) ) ) . Defined .
Definition 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' ) .
Proof. intros . split with ( g ( pr1 ze ) ) . apply ( pathscomp0 ( pathsinv0 ( h ( pr1 ze ) ) ) ( maponpaths f' ( pr2 ze ) ) ) . Defined .
(** ** Pre-towers and towers of types
A 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.
We call such infinite sequences of functions pre-towers and coinductive opbjects towers.
In 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.
*)
(** *** Pre-towers of types - the sequence of functions definition. *)
Definition pretower := total2 ( fun T : nat -> Type => forall n : nat , T ( S n ) -> T n ) .
Definition 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 .
Definition preTn ( pT : pretower ) ( n : nat ) : Type := pr1 pT n .
Coercion preTn : pretower >-> Funclass .
Definition pretowerpn ( pT : pretower ) ( n : nat ) : pT ( S n ) -> pT n := pr2 pT n .
(** Pre-tower functions. *)
Definition 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 ) ) ) .
Definition 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 .
Definition prefn { pT pT' : pretower } ( f : pretowerfun pT pT' ) ( n : nat ) : pT n -> pT' n := pr1 f n .
Coercion prefn : pretowerfun >-> Funclass .
Definition 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 .
Definition pretowerweq ( pT pT' : pretower ) : Type := total2 ( fun f : pretowerfun pT pT' => forall n : nat , isweq ( prefn f n ) ) .
Definition pretoweridfun ( T : pretower ) : pretowerfun T T := pretowerfunconstr T T ( fun n => idfun _ ) ( fun n => fun z => idpath _ ) .
Definition 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 ) ) ) .
(** Pre-tower shifts *)
Definition pretoweroneshift ( pT : pretower ) : pretower := pretowerpair ( fun n => pT ( S n ) ) ( fun n => pretowerpn pT ( S n ) ) .
Definition 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 ) ) .
(** Pre-tower pull-backs *)
Definition pretowerpb_a ( pT : pretower ) { X : Type } ( f : X -> pT 0 ) ( n : nat ) : total2 ( fun pretowerpbsn : Type => pretowerpbsn -> pT n ) .
Proof . intros . induction n .
split with X . exact f .
split with ( hfp ( pr2 IHn ) ( pretowerpn pT n ) ) . exact ( hfppru ( pr2 IHn ) ( pretowerpn pT n ) ) . Defined.
Definition 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 ) ) .
Definition 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 ) ) .
Definition 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 ) ) .
Proof. intros. induction n as [ | n IHn ] .
refine ( tpair _ _ _ ) . { exact g . } { exact h . }
destruct IHn as [ fto hn ] . refine ( tpair _ _ _ ) .
{ 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 ) . }
{ exact ( fun z => idpath _ ) . } Defined.
Definition 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 ) .
Proof. 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 ) .
Definition 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 ) ) ) .
Proof. intros . induction n as [ | n IHn ] .
{ split with ( fun x => x ) . intro . apply idpath . }
{ 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 _ _ _ ) .
{ 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 .
apply ( hfppru fto ( hfpprl ( funcomp gn fn ) pn ) ) . apply doublehfp_to . apply xze' . }
{ intro xze . destruct xze as [ [ x z ] e ] . apply idpath . }}
Defined .
Definition 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 ) .
Proof. intros . refine ( pretowerfunconstr _ _ _ _ ) .
{ intro n . exact ( pr1 ( pretowerpb_trans_a pT g f n ) ) . }
{ intro n . intro xze . destruct xze as [ [ x z ] e ] . simpl . destruct ( pretowerpb_trans_a pT g f n ) . apply idpath . }
Defined.
(** Pre-tower fibers *)
Definition pretfib { pT : pretower } ( t : pT 0 ) : pretower := pretoweroneshift ( pretowerpb pT ( fromunit t ) ) .
Definition pretfibj { pT : pretower } ( t : pT 0 ) : pretowerfun ( pretfib t ) ( pretoweroneshift pT ) := pretowerfunoneshift ( pretowerpbpr pT ( fromunit t ) ) .
(* To be removed:
Definition pretfib_Tn_jn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : total2 ( fun pretfibn : Type => pretfibn -> pT ( S n ) ) .
Proof . intros . induction n .
split with (hfiber ( pretowerpn pT O ) t ) . exact pr1 .
split with ( hfp ( pr2 IHn ) ( pretowerpn pT ( S n ) ) ) . exact ( hfppru ( pr2 IHn ) ( pretowerpn pT ( S n ) ) ) . Defined.
Definition pretfib_Tn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : Type := pr1 ( pretfib_Tn_jn pT t n ) .
Definition pretfib_jn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : pretfib_Tn pT t n -> pT ( S n ) := pr2 ( pretfib_Tn_jn pT t n ) .
Definition pretfib_pn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : pretfib_Tn pT t ( S n ) -> pretfib_Tn pT t n .
Proof. intros pT t n . exact ( hfpprl ( pr2 ( pretfib_Tn_jn pT t n ) ) ( pretowerpn pT ( S n ) ) ) . Defined.
Definition pretfib { pT : pretower } ( t : pT 0 ) : pretower := pretowerpair ( pretfib_Tn pT t ) ( pretfib_pn pT t ) .
Lemma pr0pretfib ( pT : pretower ) ( t : pT 0 ) : paths ( pretfib t 0 ) ( hfiber ( pretowerpn pT O ) t ) .
Proof. intros. apply idpath . Defined.
Definition 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 ) .
Proof. intros pT pT' f t n . induction n as [ | n IHn ] .
split with ( hfibersgtof' ( f 0 ) ( pretowerpn pT' 0 ) ( pretowerpn pT 0 ) ( f 1 ) ( prehn f 0 ) t ) . intro . About commsqstr . apply idpath . ???
split 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.
*)
Definition pretowerfuntfib { pT pT' : pretower } ( f : pretowerfun pT pT' ) ( t : pT 0 ) : pretowerfun ( pretfib t ) ( pretfib ( f 0 t ) ) .
Proof. intros. apply pretowerfunoneshift. apply ( pretowerpb_trans pT ( fromunit t ) ???? .
Definition 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 ) ) .
Definition 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 .
Proof. intros . induction n . ???
Definition pretfibofpretoweroneshift ( pT : pretower ) ( t1 : pT 1 ) : pretowerfun ( @pretfib ( pretoweroneshift pT ) t1 ) ( @pretfib ( @pretfib pT ( pretowerpn pT 0 t1 ) ) ( tohfiber ( pretowerpn pT 0 ) t1 ) ) .
Proof. intros . ???
Definition prenshift ( n : nat ) ( pT : pretower ) : pretower .
Proof. intros . induction n as [| n IHn] . exact pT . exact ( pretoweroneshift IHn ). Defined.
(** *** Towers of types - the coinductive definition. *)
CoInductive tower := towerconstr : forall T0 : Type, ( T0 -> tower ) -> tower .
Definition pr0 ( T : tower ) : Type .
Proof. intro . destruct T as [ T' S' ] . exact T' . Defined.
Definition tfib { T : tower } ( t : pr0 T ) : tower .
Proof. intro. destruct T as [ T' S' ] . exact S' . Defined.
Definition oneshift ( T : tower ) : tower := towerconstr ( total2 ( fun t : pr0 T => pr0 ( tfib t ) ) ) ( fun tf => tfib ( pr2 tf ) ) .
Definition nshift ( n : nat ) ( T : tower ) : tower .
Proof. intros . induction n as [| n IHn] . exact T . exact (oneshift IHn). Defined.
CoInductive 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' .
Definition towerfunpr0 { T T' : tower } ( f : towerfun T T' ) : pr0 T -> pr0 T' .
Proof. intros T1 T2 f G . destruct f as [ T T' f0 ff ] . exact ( f0 G ) . Defined.
Definition towerfuntfib { T T' : tower } ( f : towerfun T T' ) ( t : pr0 T ) : towerfun ( tfib t ) ( tfib ( towerfunpr0 f t ) ) .
Proof. intros. destruct f as [ T T' f0 ff ] . exact ( ff t ). Defined.
CoFixpoint toweridfun ( T : tower ) : towerfun T T := towerfunconstr T T ( fun x => x ) ( fun t0 => toweridfun ( tfib t0 ) ) .
CoFixpoint 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 ) ) ) .
(** *** Equivalence between towers and pre-towers *)
(** Towers from pre-towers *)
CoFixpoint towerfrompretower ( pT : pretower ) : tower := towerconstr ( prepr0 pT ) ( fun t => towerfrompretower ( @pretfib pT t ) ) .
CoFixpoint 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 ) ) .
Definition tfib_t_from_pt ( pT: pretower ) ( t : pT O ) : paths ( towerfrompretower ( @pretfib pT t ) ) ( @tfib ( towerfrompretower pT ) t ) .
Proof. intros . apply idpath . Defined .
Lemma oneshift_t_from_pt_to ( pT : pretower ) : towerfun ( towerfrompretower ( pretoweroneshift pT ) ) ( oneshift ( towerfrompretower pT ) ) .
Proof. intro . cofix. split with ( tococonusf ( pretowerpn pT O ) ) . intro t1 .
set (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 ) .
apply ( fun f => @towerfuntfib ( towerfrompretower ( pretoweroneshift pT ) ) ( towerfrompretower ( @pretfib pT ( pretowerpn pT 0 t1 ) ) ) f t1 ) . . simpl .
Defined.
(** Pre-towers from towers *)
Definition Tn ( T : tower ) ( n : nat ) : Type := pr0 (nshift n T).
Coercion Tn : tower >-> Funclass .
Lemma TSn ( T :tower ) ( n : nat ) : paths ( T ( S n ) ) ( total2 ( fun t : T n => pr0 ( tfib t ) ) ) .
Proof. intros . apply idpath . Defined.
Definition pn ( T : tower ) ( n : nat ) : T ( S n ) -> T n := @pr1 _ ( fun t : pr0 ( nshift n T ) => pr0 ( tfib t ) ) .
Definition pretowerfromtower ( T : tower ) : pretower := pretowerpair ( fun n => T n ) ( fun n => pn T n ) .
(** Pre-towers from towers from pre-towers *)
Definition TnpretopreTn ( pT : pretower ) ( n : nat ) : Tn ( towerfrompretower pT ) n -> preTn pT n .
Proof. intros pT n . induction n .
intro x . exact x .
intro x . unfold towerfrompretower in x . unfold Tn in x . simpl in x .
Definition weqTnpre ( pT : pretower ) ( n : nat ) : weq ( towerfrompretower pT n ) ( preTn pT n ) .
Proof. intros .
assert
Lemma pttpt_to_id_fun ( pT : pretower ) : pretowerfun ( pretowerfromtower ( towerfrompretower pT ) ) pT .
Proof. intro.
Definition fiberfloor { n : nat } { T : tower } ( tn : T n ) := pr0 ( tfib tn ) .
(* Useful formulas:
towerfloor (1+n) T := total2 ( fun G : towerfoloor n T => fiberfloor G )
@tfib (1+n) T ( tpair _ G G' ) := @tfib (tfib G) G'
*)
Definition fiberfloortotowerfloor { n : nat } { T : tower } ( tn : T n ) ( t' : fiberfloor tn ) : T ( S n ) := tpair _ tn t' .
(** *** The type of functions berween towers *)
Definition towerfunfiberfloor { T T' : tower } ( f : towerfun T T' ) { G : pr0 T } : @fiberfloor 0 _ G -> @fiberfloor 0 _ ( towerfunpr0 f G ) := towerfunpr0 ( towerfuntfib f G ) .
Definition towerfunnshift { T T' : tower } ( n : nat ) ( f : towerfun T T' ) : towerfun ( nshift n T ) ( nshift n T' ) .
Proof. 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.
Definition towerfunonfloors { n : nat } { T T' : tower } ( f : towerfun T T' ) : T n -> T' n := towerfunpr0 ( towerfunnshift n f ) .
Definition 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 .
(** An example of a function between towers *)
CoFixpoint towerstrmap ( T : tower ) ( t0 : pr0 T ) : towerfun ( tfib t0 ) T := towerfunconstr _ _ ( fun x => t0 ) ( fun t1 => towerstrmap ( tfib t0 ) t1 ) .
(** *** The type of homotopies between functions of towers *)
(* Some constructions related to tower shifts *)
Definition mnshiftfun ( m n : nat ) ( T : tower ) : towerfun ( nshift m ( nshift n T ) ) ( nshift ( m + n ) T ) .
Proof. intros . induction m .
apply toweridfun .
set ( onfloors := ( fun G' => tpair _ (towerfunpr0 IHm (pr1 G')) (towerfunfiberfloor IHm (pr2 G' ) ) ) : (nshift n T) (S m) -> T (S (m + n))) .
split with onfloors . intro G . apply ( towerfuntfib ( towerfuntfib IHm (pr1 G) ) (pr2 G) ) . Defined.
Definition mnfloorfun { m n : nat } { T : tower } ( G : ( nshift n T ) m ) : T ( m + n ) := towerfunpr0 ( mnshiftfun m n T ) G .
Definition tfibtotop { n : nat } { T : tower } ( G : T n ) : towerfun ( tfib G ) ( nshift ( S n ) T ).
Proof. intros.
split with ( fun G' : pr0 ( tfib G ) => tpair ( fun G : T n => pr0 ( tfib G ) ) G G' ) .
intro G' . apply toweridfun . Defined.
Definition fiberfloortofloor { n m : nat } { T : tower } ( G : T n ) ( G' : ( tfib G ) m ) : T ( m + ( S n ) ) .
Proof. intros. apply ( mnfloorfun ( towerfunonfloors ( tfibtotop G ) G' ) ) . Defined.
(* Extending a tower with a unit type *)
Definition towerunitext ( T : tower ) : tower := towerconstr unit ( fun x : unit => T ) .
(* Extended tower over a node G : T n *)
Definition tfibplus { n : nat } { T : tower } ( G : T n ) := towerconstr unit ( fun x => tfib G ) .
Definition fromtfibplus { n : nat } { T : tower } ( G : T n ) : towerfun ( tfibplus G ) ( nshift n T ) .
Proof . intros . split with ( fun x => G ) . intro . apply ( toweridfun (tfib G) ) . Defined.
(* The type of carriers of B-systems - towers together with a one step ramification at each floor except for the ground floor. *)
Definition bsyscar := total2 ( fun T : tower => forall ( n : nat ) ( GT : T ( S n ) ) , Type ) .
Definition bsyscarpair ( T : tower ) ( btilde : forall ( n : nat ) ( GT : T ( S n ) ) , Type ) : bsyscar := tpair _ T btilde .
Definition bsyscartotower ( B : bsyscar ) := pr1 B .
Coercion bsyscartotower : bsyscar >-> tower.
Definition Btilde { n : nat } { B : bsyscar } ( GT : B ( S n ) ) : Type := pr2 B n GT .
Definition 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 ) ) ) .
(* The type of functions between bsystemcarrier's *)
Definition 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 ) ) .
Definition bsyscarfuntotowerfun ( B B' : bsyscar ) : bsyscarfun B B' -> towerfun B B' := pr1 .
Coercion bsyscarfuntotowerfun : bsyscarfun >-> towerfun .
Definition Bnfun { n : nat } { B B' : bsyscar } ( f : bsyscarfun B B' ) ( G : B n ) : B' n := @towerfunonfloors n _ _ f G .
Definition 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 .
(* Structures on bsystemcarriers which together form the data of a B-system. *)
(* Operation Tops : ( Gamma, x:T |- ) => ( Gamma , Delta |- ) => ( Gamma, x:T, Delta |- ) *)
Definition Tops ( B : bsyscar ) := forall ( n : nat ) ( G : B n ) ( GT : pr0 ( tfib G ) ) , towerfun ( tfib G ) ( tfib GT ) .
(* Operation Ttildeops : ( Gamma, x:T |- ) => ( Gamma , Delta |- s : S ) => ( Gamma, x:T, Delta |- s : S ) *)
Definition 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 ) ) .
(* note - B for bsyscar, G : towerfloor n B , T : tfib G *)
(* Operation Sops : ( Gamma |- s : S ) => ( Gamma , x:S, Delta |- ) => ( Gamma, Delta[s/x] |- ) *)
Definition 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 ) ) .
(* Operation Stildeops : ( Gamma |- s : S ) => ( Gamma , x:S, Delta |- r : R ) => ( Gamma, Delta[s/x] |- r[s/x]:R[s/x]) *)
Definition 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 ) ) .
(* Operation deltaops : ( Gamma, x:T |- ) => ( Gamma, x : T |- x : T ) *)
Definition deltaops ( B : bsyscar ) ( Top : Tops B ) := forall ( n : nat ) ( GT : towerfloor ( S n ) B ) , BT ( fiberfloortotowerfloor GT ( towerfunpr0 ( Top n GT ) ( pr2 GT ) ) ) .
(* End of the file bsystems.v *)
================================================
FILE: Current_work/semisimplicial.v
================================================
Add Rec LoadPath "..".
Require Export Foundations.hlevel2.finitesets .
Unset Automatic Introduction.
Variable 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. *)
Variable 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. *)
Variable 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. *)
Definition Intrec1 ( n : nat ) := total2 ( fun
SS : UU => total2 ( fun
mapsfromsks : forall ( X : SS ) ( m : nat ) ( c : natleh m n ) (i : nat ) , UU =>
(* 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 ) ) .
Definition SS ( n : nat ) ( XX : Intrec1 n ) := pr1 XX .
Definition mapsfromsks ( n : nat ) ( XX : Intrec1 n ) := pr1 (pr2 XX ) .
Definition restr ( n : nat ) ( XX : Intrec1 n ) := pr2 ( pr2 XX ) .
(* We are now going to attempt to construct for each n : nat an object SEMISIPL n of Intrec1 n such that:
SS n ( SEMISIMPL n ) - is the type of semi-simplicial types of dimension n.
mapsfromsks 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.
restr 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.
We 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
SSSn n : Intrec1 n -> UU
then a function
mapsfromsksSn n : forall IHn : Intrec1 n , ( forall ( X : SSSn n IHn ) ( m : nat ) ( c : natleh m ( S n ) ) (i : nat ) , UU )
and then restrSn n.
*)
Definition 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 ) .
Definition mapsfromsksSn ( n : nat ) ( IHn : Intrec1 n ) : forall ( X : SSSn n IHn ) ( m : nat ) ( c : natleh m ( S n ) ) ( i : nat ) , UU .
Proof. intros . set ( cc := natlehchoice2 _ _ c ) . destruct cc .
simpl in h . change (pr1 (natleh m n ) ) in h . exact ( mapsfromsks n IHn ( pr1 X ) m h i ) .
exact ( 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.
Definition SEMISIMPL ( n : nat ) : Intrec1 n .
Proof . induction n as [ | n IHn ] .
(* 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 => Sn *) set ( SSn := SS n IHn ) . set (mapsfromsksn := mapsfromsks n IHn ) . set (restrn := restr n IHn ) .
set ( SSSn := total2 ( fun Xn : SSn => forall f : mapsfromsksn Xn n (isreflnatleh n) ( S n ) , UU ) ) . split with SSSn .
split with (fun X => fun i => fun c => fun j => mapsfromsksSn n IHn X i c j ) .
intros X i c j k . unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc as [ isle | iseq ] . apply restrn .
intros 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 ).
intros . set ( s1 := gamma ( S n ) j k s0 s ) . set ( ffint := ff s1 ) .
set ( 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)).
simpl in fs1 . simpl in fs0s.
assert ( 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 )) ).
(* 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 .
apply ( transportf ( fun z : _ => pr2 X z ) e ) . apply ffint . Defined.
Definition SEMISIMPL0 : Intrec1 0.
Proof . 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.
Definition SEMISIMPL1 : Intrec1 1.
Proof. set ( IHn := SEMISIMPL0 ) . set ( SSn := SS 0 IHn ) . set (mapsfromsksn := mapsfromsks 0 IHn ) . set (restrn := restr 0 IHn ) .
set ( SSSn := total2 ( fun Xn : SSn => forall f : mapsfromsksn Xn 0 (isreflnatleh 0) ( S 0 ) , UU ) ) . split with SSSn .
split with (fun X => fun i => fun c => fun j => mapsfromsksSn 0 IHn X i c j ) .
intros X i c j k. unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc . apply restrn .
intros. 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).
intros . set ( s1 := gamma ( S 0 ) j k s0 s ) . set ( ffint := ff s1 ) .
set ( 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 )).
simpl in fs1 . simpl in fs0s.
assert ( 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 ) ) ).
simpl. unfold IHn. unfold restrn. unfold restr. unfold IHn . unfold SEMISIMPL0. simpl . apply funextfun . intro . apply ( maponpaths fn ) .
Check (restrn (pr1 X) 0 (isreflnatleh 0) (S 0) k s1 fn).
(* End of the file semisimplicial.v *)
================================================
FILE: Current_work/semisimplicial2.v
================================================
Add Rec LoadPath "../Foundations/Generalities".
Add Rec LoadPath "../Foundations/hlevel1".
Add Rec LoadPath "../Foundations/hlevel2".
Require Export "../Foundations/hlevel2/finitesets" .
Unset Automatic Introduction.
Print identity_rect.
Variable 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. *)
Variable 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. *)
Variable 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. *)
Definition Intrec1 ( n : nat ) := total2 ( fun
SS : UU => total2 ( fun
mapsfromsks : forall ( X : SS ) ( m : nat ) ( c : natleh m n ) (i : nat ) , UU => total2 ( fun
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 =>
(* 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 ) ) ) ) ) .
Definition SS ( n : nat ) ( XX : Intrec1 n ) := pr1 XX .
Definition mapsfromsks ( n : nat ) ( XX : Intrec1 n ) := pr1 (pr2 XX ) .
Definition restr ( n : nat ) ( XX : Intrec1 n ) := pr1 ( pr2 ( pr2 XX ) ).
Definition pbn ( n : nat ) ( XX : Intrec1 n ) := pr2 ( pr2 ( pr2 XX ) ) .
(* We are now going to construct for each n : nat an object SEMISIPL n of Intrec1 n such that:
SS n ( SEMISIMPL n ) - is the type of semi-simplicial types of dimension n.
mapsfromsks 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.
restr 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.
pbn 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 ) )
We 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
SSSn n : Intrec1 n -> UU
then a function
mapsfromsksSn n : forall IHn : Intrec1 n , ( forall ( X : SSSn n IHn ) ( m : nat ) ( c : natleh m ( S n ) ) (i : nat ) , UU )
and then restrSn n and pbnSn n .
*)
Definition 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 ) .
Definition mapsfromsksSn ( n : nat ) ( IHn : Intrec1 n ) : forall ( X : SSSn n IHn ) ( m : nat ) ( c : natleh m ( S n ) ) ( i : nat ) , UU .
Proof. intros . set ( cc := natlehchoice2 _ _ c ) . destruct cc .
simpl in h . change (pr1 (natleh m n ) ) in h . exact ( mapsfromsks n IHn ( pr1 X ) m h i ) .
exact ( 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.
Definition 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.
Proof . intros n IHn.
intros X m c i j. unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc . apply ( restr n IHn ).
intros. destruct f as [fn ff]. split with (restr n IHn (pr1 X) n (isreflnatleh n) i j s fn ).
intros . set ( s1 := gamma ( S n ) i j s0 s ) . set ( ffint := ff s1 ) .
set ( 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)).
simpl in fs1 . simpl in fs0s.
assert ( 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 ) .
change (restr n IHn (pr1 X) n (isreflnatleh n) (S n) i s0
(restr n IHn (pr1 X) n (isreflnatleh n) i j s fn)) with fs0s in e . apply (transportf _ e ffint ) . Defined.
(*
Definition 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 ) ) .
Proof . intros n IHn X m c i j k s1 s2 . unfold mapsfromsksSn . unfold restrSn. set ( cc := natlehchoice2 _ _ c ) . destruct cc .
apply ( pbn n IHn ) .
intro f . destruct f as [ f sf ] .
assert ( 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 =>
transportf (pr2 X)
(pbn n IHn (pr1 X) n (isreflnatleh n)
(S n) i k s0 (gamma i j k s1 s2) f)
(sf (gamma (S n) i k s0 (gamma i j k s1 s2))) ) )
(tpair _ (restr n IHn (pr1 X) n (isreflnatleh n) i j s1
(restr n IHn (pr1 X) n (isreflnatleh n) j k s2 f)) ( fun s0 : Delta ( S n ) i =>
transportf (pr2 X)
(pbn n IHn (pr1 X) n (isreflnatleh n)
(S n) i k s0 (gamma i j k s1 s2) f)
transportf (pr2 X)
(pbn n IHn (pr1 X) n (isreflnatleh n)
(S n) i k s0 (gamma i j k s1 s2) f)
(sf (gamma (S n) i k s0 (gamma i j k s1 s2)))
set ( P := fun g : mapsfromsks n IHn ( pr1 X ) n ( isreflnatleh n ) i => forall s0 : Delta ( S n ) i , pr2 X
( restr n IHn (pr1 X) n (isreflnatleh n) (S n) i s0 g) ) .
(restr n IHn (pr1 X) n (isreflnatleh n) i k
(gamma i j k s1 s2) f)
set ( 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
(restr n IHn (pr1 X) n (isreflnatleh n) j k s2 f) ) ) . rewrite e .
*)
Definition SEMISIMPL ( n : nat ) : Intrec1 n .
Proof . induction 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 => Sn *) set ( SSn := SS n IHn ) . set (mapsfromsksn := mapsfromsks n IHn ) . set (restrn := restr n IHn ) .
set ( SSSn := total2 ( fun Xn : SSn => forall f : mapsfromsksn Xn n (isreflnatleh n) ( S n ) , UU ) ) . split with SSSn .
split with (fun X => fun i => fun c => fun j => mapsfromsksSn n IHn X i c j ) .
intro. intro. intro. intro. intro. unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc . apply restrn .
intros. 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 ).
intros . set ( s1 := gamma ( S n ) j k s0 s ) . set ( ffint := ff s1 ) .
set ( 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)).
simpl in fs1 . simpl in fs0s.
assert ( 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 )) ).
(* At this point the remaining goal is to prove a certain equality. This equlity will hold definitionally in TS (if I am not mistaken). *)
Check (restrn (pr1 X) n (isreflnatleh n) (S n) k s1 fn).
Admitted.
Definition SEMISIMPL0 : Intrec1 0.
Proof . 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.
Definition SEMISIMPL1 : Intrec1 1.
Proof. set ( IHn := SEMISIMPL0 ) . set ( SSn := SS 0 IHn ) . set (mapsfromsksn := mapsfromsks 0 IHn ) . set (restrn := restr 0 IHn ) .
set ( SSSn := total2 ( fun Xn : SSn => forall f : mapsfromsksn Xn 0 (isreflnatleh 0) ( S 0 ) , UU ) ) . split with SSSn .
split with (fun X => fun i => fun c => fun j => mapsfromsksSn 0 IHn X i c j ) .
intro. intro. intro. intro. intro. unfold mapsfromsksSn . set ( cc := natlehchoice2 _ _ c ) . destruct cc . apply restrn .
intros. 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).
intros . set ( s1 := gamma ( S 0 ) j k s0 s ) . set ( ffint := ff s1 ) .
set ( 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 )).
simpl in fs1 . simpl in fs0s.
assert ( 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 ) ) ).
simpl. unfold IHn. unfold restrn. unfold restr. unfold IHn . unfold SEMISIMPL0. simpl . apply funextfun . intro . apply ( maponpaths fn ) .
Check (restrn (pr1 X) 0 (isreflnatleh 0) (S 0) k s1 fn).
(* End of the file semisimplicial.v *)
(*
*** Local Variables: ***
*** coq-prog-name: "/opt/local/bin/coqtop" ***
*** coq-prog-args: ("-emacs-U") ***
*** End: ***
*)
================================================
FILE: Generalities/uu0.v
================================================
(** * Univalent Basics. Vladimir Voevodsky. Feb. 2010 - Sep. 2011. Port to coq trunk (8.4-8.5) in March 2014.
This file contains results which form a basis of the univalent approach and which do not require the use of universes as types. Fixpoints with values in a universe are used only once in the definition [ isofhlevel ]. Many results in this file do not require any axioms. The first axiom we use is [ funextempty ] which is the functional extensionality axiom for functions with values in the empty type. Closer to the end of the file we use general functional extensionality [ funextfunax ] asserting that two homotopic functions are equal. Since [ funextfunax ] itself is not an "axiom" in our sense i.e. its type is not of h-level 1 we show that it is logically equivalent to a real axiom [ funcontr ] which asserts that the space of sections of a family with contractible fibers is contractible.
*)
(** ** Preambule *)
(** Settings *)
Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *)
(** Imports *)
Add LoadPath "../../".
Require Export Foundations.Generalities.uuu.
(** Universe structure *)
Definition UU := Type .
(* end of "Preambule". *)
(** ** Some standard constructions not using identity types (paths) *)
(** *** Canonical functions from [ empty ] and to [ unit ] *)
Definition fromempty { X : UU } : empty -> X.
Proof. intros X H. destruct H. Defined.
Definition tounit { X : UU } : X -> unit := fun x : X => tt .
(** *** Functions from [ unit ] corresponding to terms *)
Definition termfun { X : UU } ( x : X ) : unit -> X := fun t : unit => x .
(** *** Identity functions and function composition *)
Definition idfun ( T : UU ) := fun t : T => t .
Definition funcomp { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) := fun x : X => g ( f x ) .
(** *** Iteration of an endomorphism *)
Fixpoint iteration { T : UU } ( f : T -> T ) ( n : nat ) : T -> T := match n with
O => idfun T |
S m => funcomp ( iteration f m ) f
end .
(** *** Basic constructions related to the adjoint evaluation function [ X -> ( ( X -> Y ) -> Y ) ] *)
Definition adjev { X Y : UU } ( x : X ) ( f : X -> Y ) : Y := f x.
Definition adjev2 { X Y : UU } ( phi : ( ( X -> Y ) -> Y ) -> Y ) : X -> Y := (fun x : X => phi ( fun f : X -> Y => f x ) ) .
(** *** Pairwise direct products *)
Definition dirprod ( X Y : UU ) := total2 ( fun x : X => Y ) .
Definition dirprodpair { X Y : UU } := tpair ( fun x : X => Y ) .
Definition dirprodadj { X Y Z : UU } ( f : dirprod X Y -> Z ) : X -> Y -> Z := fun x : X => fun y : Y => f ( dirprodpair x y ) .
Definition dirprodf { X Y X' Y' : UU } ( f : X -> Y ) ( f' : X' -> Y' ) ( xx' : dirprod X X' ) : dirprod Y Y' := dirprodpair ( f ( pr1 xx') ) ( f' ( pr2 xx' ) ) .
Definition ddualand { X Y P : UU } (xp : ( X -> P ) -> P ) ( yp : ( Y -> P ) -> P ) : ( dirprod X Y -> P ) -> P.
Proof. intros X Y P xp yp X0 . set ( int1 := fun ypp : ( ( Y -> P ) -> P ) => fun x : X => yp ( fun y : Y => X0 ( dirprodpair x y) ) ) . apply ( xp ( int1 yp ) ) . Defined .
(** *** Negation and double negation *)
Definition neg ( X : UU ) : UU := X -> empty.
Definition negf { X Y : UU } ( f : X -> Y ) : neg Y -> neg X := fun phi : Y -> empty => fun x : X => phi ( f x ) .
Definition dneg ( X : UU ) : UU := ( X -> empty ) -> empty .
Definition dnegf { X Y : UU } ( f : X -> Y ) : dneg X -> dneg Y := negf ( negf f ) .
Definition todneg ( X : UU ) : X -> dneg X := adjev .
Definition dnegnegtoneg { X : UU } : dneg ( neg X ) -> neg X := adjev2 .
Lemma dneganddnegl1 { X Y : UU } ( dnx : dneg X ) ( dny : dneg Y ) : neg ( X -> neg Y ) .
Proof. intros. intro X2. assert ( X3 : dneg X -> neg Y ) . apply ( fun xx : dneg X => dnegnegtoneg ( dnegf X2 xx ) ) . apply ( dny ( X3 dnx ) ) . Defined.
Definition dneganddnegimpldneg { X Y : UU } ( dnx : dneg X ) ( dny : dneg Y ) : dneg ( dirprod X Y ) := ddualand dnx dny.
(** *** Logical equivalence *)
Definition logeq ( X Y : UU ) := dirprod ( X -> Y ) ( Y -> X ) .
Notation " X <-> Y " := ( logeq X Y ) : type_scope .
Definition logeqnegs { X Y : UU } ( l : X <-> Y ) : ( neg X ) <-> ( neg Y ) := dirprodpair ( negf ( pr2 l ) ) ( negf ( pr1 l ) ) .
(* end of "Some standard constructions not using idenity types (paths)". *)
(** ** Operations on [ paths ] *)
(** *** Composition of paths and inverse paths *)
Definition pathscomp0 { X : UU } { a b c : X } ( e1 : paths a b ) ( e2 : paths b c ) : paths a c .
Proof. intros. destruct e1. apply e2 . Defined.
Hint Resolve @pathscomp0 : pathshints .
Definition pathscomp0rid { X : UU } { a b : X } ( e1 : paths a b ) : paths ( pathscomp0 e1 ( idpath b ) ) e1 .
Proof. intros. destruct e1. simpl. apply idpath. Defined.
(** Note that we do no need [ pathscomp0lid ] since the corresponding two terms are convertible to each other due to our definition of [ pathscomp0 ] . If we defined it by destructing [ e2 ] and applying [ e1 ] then [ pathsinv0rid ] would be trivial but [ pathsinv0lid ] would require a proof. Similarly we do not need a lemma to connect [ pathsinv0 ( idpath _ ) ] to [ idpath ] *)
Definition pathsinv0 { X : UU } { a b : X } ( e : paths a b ) : paths b a .
Proof. intros. destruct e. apply idpath. Defined.
Hint Resolve @pathsinv0 : pathshints .
Definition pathsinv0l { X : UU } { a b : X } ( e : paths a b ) : paths ( pathscomp0 ( pathsinv0 e ) e ) ( idpath _ ) .
Proof. intros. destruct e. apply idpath. Defined.
Definition pathsinv0r { X : UU } { a b : X } ( e : paths a b ) : paths ( pathscomp0 e ( pathsinv0 e ) ) ( idpath _ ) .
Proof. intros. destruct e. apply idpath. Defined.
Definition pathsinv0inv0 { X : UU } { x x' : X } ( e : paths x x' ) : paths ( pathsinv0 ( pathsinv0 e ) ) e .
Proof. intros. destruct e. apply idpath. Defined.
(** *** Direct product of paths *)
Definition pathsdirprod { X Y : UU } { x1 x2 : X } { y1 y2 : Y } ( ex : paths x1 x2 ) ( ey : paths y1 y2 ) : paths ( dirprodpair x1 y1 ) ( dirprodpair x2 y2 ) .
Proof . intros . destruct ex . destruct ey . apply idpath . Defined .
(** *** The function [ maponpaths ] between paths types defined by a function between abmbient types and its behavior relative to [ pathscomp0 ] and [ pathsinv0 ] *)
Definition maponpaths { T1 T2 : UU } ( f : T1 -> T2 ) { t1 t2 : T1 } ( e: paths t1 t2 ) : paths ( f t1 ) ( f t2 ) .
Proof. intros . destruct e . apply idpath. Defined.
Definition maponpathscomp0 { X Y : UU } { x1 x2 x3 : X } ( f : X -> Y ) ( e1 : paths x1 x2 ) ( e2 : paths x2 x3 ) : paths ( maponpaths f ( pathscomp0 e1 e2 ) ) ( pathscomp0 ( maponpaths f e1 ) ( maponpaths f e2 ) ) .
Proof. intros. destruct e1. destruct e2. simpl. apply idpath. Defined.
Definition maponpathsinv0 { X Y : UU } ( f : X -> Y ) { x1 x2 : X } ( e : paths x1 x2 ) : paths ( maponpaths f ( pathsinv0 e ) ) ( pathsinv0 ( maponpaths f e ) ) .
Proof. intros . destruct e . apply idpath . Defined .
(** *** [ maponpaths ] for the identity functions and compositions of functions *)
Lemma maponpathsidfun { X : UU } { x x' : X } ( e : paths x x' ) : paths ( maponpaths ( idfun X ) e ) e .
Proof. intros. destruct e. apply idpath . Defined.
Lemma maponpathscomp { X Y Z : UU } { x x' : X } ( f : X -> Y ) ( g : Y -> Z ) ( e : paths x x' ) : paths ( maponpaths g ( maponpaths f e ) ) ( maponpaths ( funcomp f g ) e) .
Proof. intros. destruct e. apply idpath. Defined.
(** The following four statements show that [ maponpaths ] defined by a function f which is homotopic to the identity is "surjective". It is later used to show that the maponpaths defined by a function which is a weak equivalence is itself a weak equivalence. *)
Definition maponpathshomidinv { X : UU } (f:X -> X) ( h: forall x:X, paths (f x) x) ( x x' : X ) : paths (f x) (f x') -> paths x x' := (fun e: paths (f x) (f x') => pathscomp0 (pathsinv0 (h x)) (pathscomp0 e (h x'))).
Lemma maponpathshomid1 { X : UU } (f:X -> X) (h: forall x:X, paths (f x) x) { x x' : X } (e:paths x x'): paths (maponpaths f e) (pathscomp0 (h x) (pathscomp0 e (pathsinv0 (h x')))).
Proof. intros. destruct e. change (pathscomp0 (idpath x) (pathsinv0 (h x))) with (pathsinv0 (h x)). assert (ee: paths (maponpaths f (idpath x)) (idpath (f x))). apply idpath .
assert (eee: paths (idpath (f x)) (pathscomp0 (h x) (pathsinv0 (h x)))). apply (pathsinv0 (pathsinv0r (h x))). apply (pathscomp0 ee eee). Defined.
Lemma maponpathshomid12 { X : UU } { x x' fx fx' : X } (e:paths fx fx') (hx:paths fx x) (hx':paths fx' x') : paths (pathscomp0 hx (pathscomp0 (pathscomp0 (pathsinv0 hx) (pathscomp0 e hx')) (pathsinv0 hx'))) e.
Proof. intros. destruct hx. destruct hx'. destruct e. simpl. apply idpath. Defined.
Lemma maponpathshomid2 { X : UU } (f:X->X) (h: forall x:X, paths (f x) x) ( x x' : X ) (e:paths (f x) (f x')) : paths (maponpaths f (maponpathshomidinv f h _ _ e)) e.
Proof. intros. assert (ee: paths (pathscomp0 (h x) (pathscomp0 (pathscomp0 (pathsinv0 (h x)) (pathscomp0 e (h x'))) (pathsinv0 (h x')))) e). apply (maponpathshomid12 e (h x) (h x')). assert (eee: paths (maponpaths f (pathscomp0 (pathsinv0 (h x)) (pathscomp0 e (h x')))) (pathscomp0 (h x) (pathscomp0 (pathscomp0 (pathsinv0 (h x)) (pathscomp0 e (h x'))) (pathsinv0 (h x'))))). apply maponpathshomid1. apply (pathscomp0 eee ee). Defined.
(** Here we consider the behavior of maponpaths in the case of a projection [ p ] with a section [ s ]. *)
Definition pathssec1 { X Y : UU } ( s : X -> Y ) ( p : Y -> X ) ( eps : forall x:X , paths ( p ( s x ) ) x ) ( x : X ) ( y : Y ) ( e : paths (s x) y ) : paths x (p y) := pathscomp0 ( pathsinv0 ( eps x ) ) ( maponpaths p e ) .
Definition pathssec2 { X Y : UU } ( s : X -> Y ) ( p : Y -> X ) ( eps : forall x : X , paths ( p ( s x ) ) x ) ( x x' : X ) ( e : paths ( s x ) ( s x' ) ) : paths x x'.
Proof. intros . set ( e' := pathssec1 s p eps _ _ e ) . apply ( pathscomp0 e' ( eps x' ) ) . Defined .
Definition pathssec2id { X Y : UU } ( s : X -> Y ) ( p : Y -> X ) ( eps : forall x : X , paths ( p ( s x ) ) x ) ( x : X ) : paths ( pathssec2 s p eps _ _ ( idpath ( s x ) ) ) ( idpath x ) .
Proof. intros. unfold pathssec2. unfold pathssec1. simpl. assert (e: paths (pathscomp0 (pathsinv0 (eps x)) (idpath (p (s x)))) (pathsinv0 (eps x))). apply pathscomp0rid. assert (ee: paths
(pathscomp0 (pathscomp0 (pathsinv0 (eps x)) (idpath (p (s x)))) (eps x))
(pathscomp0 (pathsinv0 (eps x)) (eps x))).
apply (maponpaths (fun e0: _ => pathscomp0 e0 (eps x)) e). assert (eee: paths (pathscomp0 (pathsinv0 (eps x)) (eps x)) (idpath x)). apply (pathsinv0l (eps x)). apply (pathscomp0 ee eee). Defined.
Definition pathssec3 { X Y : UU } (s:X-> Y) (p:Y->X) (eps: forall x:X, paths (p (s x)) x) { x x' : X } ( e : paths x x' ) : paths (pathssec2 s p eps _ _ (maponpaths s e)) e.
Proof. intros. destruct e. simpl. unfold pathssec2. unfold pathssec1. simpl. apply pathssec2id. Defined.
(* end of "Operations on [ paths ]". *)
(** ** Fibrations and paths *)
Definition tppr { T : UU } { P : T -> UU } ( x : total2 P ) : paths x ( tpair _ (pr1 x) (pr2 x) ) .
Proof. intros. destruct x. apply idpath. Defined.
Definition constr1 { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : total2 (fun f: P x -> P x' => ( total2 ( fun ee : forall p : P x, paths (tpair _ x p) (tpair _ x' ( f p ) ) => forall pp : P x, paths (maponpaths ( @pr1 _ _ ) ( ee pp ) ) e ) ) ) .
Proof. intros. destruct e. split with ( idfun ( P x ) ). simpl. split with (fun p : P x => idpath _ ) . unfold maponpaths. simpl. apply (fun pp : P x => idpath _ ) . Defined.
Definition transportf { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : P x -> P x' := pr1 ( constr1 P e ) .
Definition transportb { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : P x' -> P x := transportf P ( pathsinv0 e ) .
Lemma functtransportf { X Y : UU } ( f : X -> Y ) ( P : Y -> UU ) { x x' : X } ( e : paths x x' ) ( p : P ( f x ) ) : paths ( transportf ( fun x => P ( f x ) ) e p ) ( transportf P ( maponpaths f e ) p ) .
Proof. intros. destruct e. apply idpath. Defined.
(** ** First homotopy notions *)
(** *** Homotopy between functions *)
Definition homot { X Y : UU } ( f g : X -> Y ) := forall x : X , paths ( f x ) ( g x ) .
(** *** Contractibility, homotopy fibers etc. *)
(** Contractible types. *)
Definition iscontr (T:UU) : UU := total2 (fun cntr:T => forall t:T, paths t cntr).
Definition iscontrpair { T : UU } := tpair (fun cntr:T => forall t:T, paths t cntr).
Definition iscontrpr1 { T : UU } := @pr1 T ( fun cntr:T => forall t:T, paths t cntr ) .
Lemma iscontrretract { X Y : UU } ( p : X -> Y ) ( s : Y -> X ) ( eps : forall y : Y, paths ( p ( s y ) ) y ) ( is : iscontr X ) : iscontr Y.
Proof . intros . destruct is as [ x fe ] . set ( y := p x ) . split with y . intro y' . apply ( pathscomp0 ( pathsinv0 ( eps y' ) ) ( maponpaths p ( fe ( s y' ) ) ) ) . Defined .
Lemma proofirrelevancecontr { X : UU }(is: iscontr X) ( x x' : X ): paths x x'.
Proof. intros. unfold iscontr in is. destruct is as [ t x0 ]. set (e:= x0 x). set (e':= pathsinv0 (x0 x')). apply (pathscomp0 e e'). Defined.
(** Coconuses - spaces of paths which begin or end at a given point. *)
Definition coconustot ( T : UU ) ( t : T ) := total2 (fun t':T => paths t' t).
Definition coconustotpair ( T : UU ) { t t' : T } (e: paths t' t) : coconustot T t := tpair (fun t':T => paths t' t) t' e.
Definition coconustotpr1 ( T : UU ) ( t : T ) := @pr1 _ (fun t':T => paths t' t) .
Lemma connectedcoconustot { T : UU } { t : T } ( c1 c2 : coconustot T t ) : paths c1 c2.
Proof. intros. destruct c1 as [ x0 x ]. destruct x. destruct c2 as [ x1 x ]. destruct x. apply idpath. Defined.
Lemma iscontrcoconustot ( T : UU ) (t:T) : iscontr (coconustot T t).
Proof. intros. unfold iscontr. set (t0:= tpair (fun t':T => paths t' t) t (idpath t)). split with t0. intros. apply connectedcoconustot. Defined.
Definition coconusfromt ( T : UU ) (t:T) := total2 (fun t':T => paths t t').
Definition coconusfromtpair ( T : UU ) { t t' : T } (e: paths t t') : coconusfromt T t := tpair (fun t':T => paths t t') t' e.
Definition coconusfromtpr1 ( T : UU ) ( t : T ) := @pr1 _ (fun t':T => paths t t') .
Lemma connectedcoconusfromt { T : UU } { t : T } ( e1 e2 : coconusfromt T t ) : paths e1 e2.
Proof. intros. destruct e1 as [x0 x]. destruct x. destruct e2 as [ x1 x ]. destruct x. apply idpath. Defined.
Lemma iscontrcoconusfromt ( T : UU ) (t:T) : iscontr (coconusfromt T t).
Proof. intros. unfold iscontr. set (t0:= tpair (fun t':T => paths t t') t (idpath t)). split with t0. intros. apply connectedcoconusfromt. Defined.
(** Pathsspace of a type. *)
Definition pathsspace (T:UU) := total2 (fun t:T => coconusfromt T t).
Definition pathsspacetriple ( T : UU ) { t1 t2 : T } (e: paths t1 t2): pathsspace T := tpair _ t1 (coconusfromtpair T e).
Definition deltap ( T : UU ) : T -> pathsspace T := (fun t:T => pathsspacetriple T (idpath t)).
Definition pathsspace' ( T : UU ) := total2 (fun xy : dirprod T T => (match xy with tpair _ x y => paths x y end)).
(** Homotopy fibers. *)
Definition hfiber { X Y : UU } (f:X -> Y) (y:Y) : UU := total2 (fun pointover:X => paths (f pointover) y).
Definition hfiberpair { X Y : UU } (f:X -> Y) { y : Y } ( x : X ) ( e : paths ( f x ) y ) := tpair (fun pointover:X => paths (f pointover) y) x e .
Definition hfiberpr1 { X Y : UU } ( f : X -> Y ) ( y : Y ) := @pr1 _ (fun pointover:X => paths (f pointover) y) .
(** Paths in homotopy fibers. *)
Lemma hfibertriangle1 { X Y : UU } (f:X -> Y) { y : Y } { xe1 xe2: hfiber f y } (e: paths xe1 xe2): paths (pr2 xe1) (pathscomp0 (maponpaths f (maponpaths ( @pr1 _ _ ) e)) (pr2 xe2)).
Proof. intros. destruct e. simpl. apply idpath. Defined.
Lemma hfibertriangle1inv0 { X Y : UU } (f:X -> Y) { y : Y } { xe1 xe2: hfiber f y } (e: paths xe1 xe2) : paths ( pathscomp0 ( maponpaths f ( pathsinv0 ( maponpaths ( @pr1 _ _ ) e ) ) ) ( pr2 xe1 ) ) ( pr2 xe2 ) .
Proof . intros . destruct e . apply idpath . Defined .
Lemma hfibertriangle2 { X Y : UU } (f:X -> Y) { y : Y } (xe1 xe2: hfiber f y) (ee: paths (pr1 xe1) (pr1 xe2))(eee: paths (pr2 xe1) (pathscomp0 (maponpaths f ee) (pr2 xe2))): paths xe1 xe2.
Proof. intros. destruct xe1 as [ t e1 ]. destruct xe2. simpl in eee. simpl in ee. destruct ee. simpl in eee. apply (maponpaths (fun e: paths (f t) y => hfiberpair f t e) eee). Defined.
(** Coconus of a function - the total space of the family of h-fibers. *)
Definition coconusf { X Y : UU } (f: X -> Y):= total2 (fun y:_ => hfiber f y).
Definition fromcoconusf { X Y : UU } (f: X -> Y) : coconusf f -> X := fun yxe:_ => pr1 (pr2 yxe).
Definition tococonusf { X Y:UU } (f: X -> Y) : X -> coconusf f := fun x:_ => tpair _ (f x) (hfiberpair f x (idpath _ ) ).
(** Total spaces of families and homotopies *)
Definition famhomotfun { X : UU } { P Q : X -> UU } ( h : homot P Q ) ( xp : total2 P ) : total2 Q .
Proof . intros. destruct xp as [ x p ] . split with x . destruct ( h x ) . apply p . Defined.
Definition famhomothomothomot { X : UU } { P Q : X -> UU } ( h1 h2 : homot P Q ) ( H : forall x : X , paths ( h1 x ) ( h2 x ) ) : homot ( famhomotfun h1 ) ( famhomotfun h2 ) .
Proof . intros . intro xp . destruct xp as [x p] . simpl . apply ( maponpaths ( fun q => tpair Q x q ) ) . destruct ( H x ) . apply idpath . Defined.
(** ** Weak equivalences *)
(** *** Basics *)
Definition isweq { X Y : UU } ( f : X -> Y) : UU := forall y:Y, iscontr (hfiber f y) .
Lemma idisweq (T:UU) : isweq (fun t:T => t).
Proof. intros.
unfold isweq.
intro y .
assert (y0: hfiber (fun t : T => t) y). apply (tpair (fun pointover:T => paths ((fun t:T => t) pointover) y) y (idpath y)).
split with y0. intro t.
destruct y0 as [x0 e0]. destruct t as [x1 e1]. destruct e0. destruct e1. apply idpath. Defined.
Definition weq ( X Y : UU ) : UU := total2 (fun f:X->Y => isweq f) .
Definition pr1weq ( X Y : UU):= @pr1 _ _ : weq X Y -> (X -> Y).
Coercion pr1weq : weq >-> Funclass.
Definition weqpair { X Y : UU } (f:X-> Y) (is: isweq f) : weq X Y := tpair (fun f:X->Y => isweq f) f is.
Definition idweq (X:UU) : weq X X := tpair (fun f:X->X => isweq f) (fun x:X => x) ( idisweq X ) .
Definition isweqtoempty { X : UU } (f : X -> empty ) : isweq f.
Proof. intros. intro y. apply (fromempty y). Defined.
Definition weqtoempty { X : UU } ( f : X -> empty ) := weqpair _ ( isweqtoempty f ) .
Lemma isweqtoempty2 { X Y : UU } ( f : X -> Y ) ( is : neg Y ) : isweq f .
Proof. intros . intro y . destruct ( is y ) . Defined .
Definition weqtoempty2 { X Y : UU } ( f : X -> Y ) ( is : neg Y ) := weqpair _ ( isweqtoempty2 f is ) .
Definition invmap { X Y : UU } ( w : weq X Y ) : Y -> X .
Proof. intros X Y w y . apply (pr1 (pr1 ( pr2 w y ))). Defined.
(** We now define different homotopies and maps between the paths spaces corresponding to a weak equivalence. What may look like unnecessary complexity in the definition of [ weqgf ] is due to the fact that the "naive" definition, that of [ weqgf00 ], needs to be corrected in order for lemma [ weqfgf ] to hold. *)
Definition homotweqinvweq { T1 T2 : UU } ( w : weq T1 T2 ) : forall t2:T2, paths ( w ( invmap w t2 ) ) t2.
Proof. intros. unfold invmap. simpl. apply (pr2 (pr1 ( pr2 w t2 ) ) ) . Defined.
Definition homotinvweqweq0 { X Y : UU } ( w : weq X Y ) ( x : X ) : paths x ( invmap w ( w x ) ) .
Proof. intros. set (isfx:= ( pr2 w ( w x ) ) ). set (pr1fx:= @pr1 X (fun x':X => paths ( w x' ) ( w x ))).
set (xe1:= (hfiberpair w x (idpath ( w x)))). apply (maponpaths pr1fx (pr2 isfx xe1)). Defined.
Definition homotinvweqweq { X Y : UU } ( w : weq X Y ) ( x : X ) : paths (invmap w ( w x ) ) x := pathsinv0 (homotinvweqweq0 w x).
Lemma diaglemma2 { X Y : UU } (f:X -> Y) { x x':X } (e1: paths x x')(e2: paths (f x') (f x)) (ee: paths (idpath (f x)) (pathscomp0 (maponpaths f e1) e2)): paths (maponpaths f (pathsinv0 e1)) e2.
Proof. intros. destruct e1. simpl. simpl in ee. assumption. Defined.
Definition homotweqinvweqweq { X Y : UU } ( w : weq X Y ) ( x : X ) : paths (maponpaths w (homotinvweqweq w x)) (homotweqinvweq w ( w x)).
Proof. intros. set (xe1:= hfiberpair w x (idpath (w x))). set (isfx:= ( pr2 w ) (w x)). set (xe2:= pr1 isfx). set (e:= pr2 isfx xe1). set (ee:=hfibertriangle1 w e). simpl in ee.
apply (diaglemma2 w (homotinvweqweq0 w x) ( homotweqinvweq w ( w x ) ) ee ). Defined.
Definition invmaponpathsweq { X Y : UU } ( w : weq X Y ) ( x x' : X ) : paths (w x) (w x') -> paths x x':= pathssec2 w (invmap w ) (homotinvweqweq w ) _ _ .
Definition invmaponpathsweqid { X Y : UU } ( w : weq X Y ) ( x : X ) : paths (invmaponpathsweq w _ _ (idpath (w x))) (idpath x):= pathssec2id w (invmap w ) (homotinvweqweq w ) x.
Definition pathsweq1 { X Y : UU } ( w : weq X Y ) ( x : X ) ( y : Y ) : paths (w x) y -> paths x (invmap w y) := pathssec1 w (invmap w ) (homotinvweqweq w ) _ _ .
Definition pathsweq1' { X Y : UU } ( w : weq X Y ) ( x : X ) ( y : Y ) : paths x (invmap w y) -> paths ( w x ) y := fun e:_ => pathscomp0 (maponpaths w e) (homotweqinvweq w y).
Definition pathsweq3 { X Y : UU } ( w : weq X Y ) { x x' : X } ( e : paths x x' ) : paths (invmaponpathsweq w x x' (maponpaths w e)) e:= pathssec3 w (invmap w ) (homotinvweqweq w ) _ .
Definition pathsweq4 { X Y : UU } ( w : weq X Y ) ( x x' : X ) ( e : paths ( w x ) ( w x' )) : paths (maponpaths w (invmaponpathsweq w x x' e)) e.
Proof. intros. destruct w as [ f is1 ] . set ( w := weqpair f is1 ) . set (g:=invmap w ). set (gf:= fun x:X => (g (f x))). set (ee:= maponpaths g e). set (eee:= maponpathshomidinv gf (homotinvweqweq w ) x x' ee ).
assert (e1: paths (maponpaths f eee) e).
assert (e2: paths (maponpaths g (maponpaths f eee)) (maponpaths g e)).
assert (e3: paths (maponpaths g (maponpaths f eee)) (maponpaths gf eee)). apply maponpathscomp.
assert (e4: paths (maponpaths gf eee) ee). apply maponpathshomid2. apply (pathscomp0 e3 e4).
set (s:= @maponpaths _ _ g (f x) (f x')). set (p:= @pathssec2 _ _ g f (homotweqinvweq w ) (f x) (f x')). set (eps:= @pathssec3 _ _ g f (homotweqinvweq w ) (f x) (f x')). apply (pathssec2 s p eps _ _ e2 ).
assert (e5: paths (maponpaths f (invmaponpathsweq w x x' e)) (maponpaths f (invmaponpathsweq w x x' (maponpaths f eee)))). apply (pathsinv0 (maponpaths (fun e0: paths (f x) (f x') => (maponpaths f (invmaponpathsweq w x x' e0))) e1)).
assert (X0: paths (invmaponpathsweq w x x' (maponpaths f eee)) eee). apply (pathsweq3 w ).
assert (e6: paths (maponpaths f (invmaponpathsweq w x x' (maponpaths f eee))) (maponpaths f eee)). apply (maponpaths (fun eee0: paths x x' => maponpaths f eee0) X0). set (e7:= pathscomp0 e5 e6). set (pathscomp0 e7 e1).
assumption. Defined.
(** *** Weak equivalences between contractible types (other implications are proved below) *)
Lemma iscontrweqb { X Y : UU } ( w : weq X Y ) ( is : iscontr Y ) : iscontr X.
Proof. intros . apply ( iscontrretract (invmap w ) w (homotinvweqweq w ) is ). Defined.
(** *** Functions between fibers defined by a path on the base are weak equivalences *)
Lemma isweqtransportf { X : UU } (P:X -> UU) { x x' : X } (e:paths x x'): isweq (transportf P e).
Proof. intros. destruct e. apply idisweq. Defined.
Lemma isweqtransportb { X : UU } (P:X -> UU) { x x' : X } (e:paths x x'): isweq (transportb P e).
Proof. intros. apply (isweqtransportf _ (pathsinv0 e)). Defined.
(** *** [ unit ] and contractibility *)
(** [ unit ] is contractible (recall that [ tt ] is the name of the canonical term of the type [ unit ]). *)
Lemma unitl0: paths tt tt -> coconustot _ tt.
Proof. intros X. apply (coconustotpair _ X). Defined.
Lemma unitl1: coconustot _ tt -> paths tt tt.
Proof. intro X. destruct X as [ x t ]. destruct x. assumption. Defined.
Lemma unitl2: forall e: paths tt tt, paths (unitl1 (unitl0 e)) e.
Proof. intros. unfold unitl0. simpl. apply idpath. Defined.
Lemma unitl3: forall e:paths tt tt, paths e (idpath tt).
Proof. intros.
assert (e0: paths (unitl0 (idpath tt)) (unitl0 e)). eapply connectedcoconustot.
assert (e1:paths (unitl1 (unitl0 (idpath tt))) (unitl1 (unitl0 e))). apply (maponpaths unitl1 e0).
assert (e2: paths (unitl1 (unitl0 e)) e). eapply unitl2.
assert (e3: paths (unitl1 (unitl0 (idpath tt))) (idpath tt)). eapply unitl2.
destruct e1. clear e0. destruct e2. assumption. Defined.
Theorem iscontrunit: iscontr (unit).
Proof. assert (pp:forall x:unit, paths x tt). intros. destruct x. apply (idpath _).
apply (tpair (fun cntr:unit => forall t:unit, paths t cntr) tt pp). Defined.
(** [ paths ] in [ unit ] are contractible. *)
Theorem iscontrpathsinunit ( x x' : unit ) : iscontr ( paths x x' ) .
Proof. intros . assert (c:paths x x'). destruct x. destruct x'. apply idpath.
assert (X: forall g:paths x x', paths g c). intro. assert (e:paths c c). apply idpath. destruct c. destruct x. apply unitl3. apply (iscontrpair c X). Defined.
(** A type [ T : UU ] is contractible if and only if [ T -> unit ] is a weak equivalence. *)
Lemma ifcontrthenunitl0 ( e1 e2 : paths tt tt ) : paths e1 e2.
Proof. intros. assert (e3: paths e1 (idpath tt) ). apply unitl3.
assert (e4: paths e2 (idpath tt)). apply unitl3. destruct e3. destruct e4. apply idpath. Defined.
Lemma isweqcontrtounit { T : UU } (is : iscontr T) : (isweq (fun t:T => tt)).
Proof. intros T X. unfold isweq. intro y. destruct y.
assert (c: hfiber (fun x:T => tt) tt). destruct X as [ t x0 ]. eapply (hfiberpair _ t (idpath tt)).
assert (e: forall d: (hfiber (fun x:T => tt) tt), paths d c). intros. destruct c as [ t x] . destruct d as [ t0 x0 ].
assert (e': paths x x0). apply ifcontrthenunitl0 .
assert (e'': paths t t0). destruct X as [t1 x1 ].
assert (e''': paths t t1). apply x1.
assert (e'''': paths t0 t1). apply x1.
destruct e''''. assumption.
destruct e''. destruct e'. apply idpath. apply (iscontrpair c e). Defined.
Definition weqcontrtounit { T : UU } ( is : iscontr T ) := weqpair _ ( isweqcontrtounit is ) .
Theorem iscontrifweqtounit { X : UU } ( w : weq X unit ) : iscontr X.
Proof. intros X X0. apply (iscontrweqb X0 ). apply iscontrunit. Defined.
(** *** A homotopy equivalence is a weak equivalence *)
Definition hfibersgftog { X Y Z : UU } (f:X -> Y) (g: Y -> Z) (z:Z) ( xe : hfiber (fun x:X => g(f x)) z ) : hfiber g z := hfiberpair g ( f ( pr1 xe ) ) ( pr2 xe ) .
Lemma constr2 { X Y : UU } (f:X -> Y)(g: Y-> X) (efg: forall y:Y, paths (f(g y)) y) ( x0 : X) ( z0 : hfiber g x0 ) : total2 (fun z': hfiber (fun x:X => g (f x)) x0 => paths z0 (hfibersgftog f g x0 z')).
Proof. intros. destruct z0 as [ y e ].
assert (eint: paths y (f x0 )). assert (e0: paths (f(g y)) y). apply efg. assert (e1: paths (f(g y)) (f x0 )). apply (maponpaths f e). destruct e1. apply pathsinv0. assumption.
set (int1:=constr1 (fun y:Y => paths (g y) x0 ) eint). destruct int1 as [ t x ].
set (int2:=hfiberpair (fun x0 : X => g (f x0)) x0 (t e)). split with int2. apply x. Defined.
Lemma iscontrhfiberl1 { X Y : UU } (f:X -> Y) (g: Y-> X) (efg: forall y:Y, paths (f(g y)) y) (x0 : X): iscontr (hfiber (fun x:X => g (f x)) x0 ) ->iscontr (hfiber g x0).
Proof. intros X Y f g efg x0 X0. set (X1:= hfiber (fun x:X => g(f x)) x0 ). set (Y1:= hfiber g x0 ). set (f1:= hfibersgftog f g x0 ). set (g1:= fun z0:_ => pr1 (constr2 f g efg x0 z0)).
set (efg1:= (fun y1:Y1 => pathsinv0 ( pr2 (constr2 f g efg x0 y1 ) ) ) ) . simpl in efg1. apply ( iscontrretract f1 g1 efg1). assumption. Defined.
Lemma iscontrhfiberl2 { X Y : UU } ( f1 f2 : X-> Y) (h: forall x:X, paths (f2 x) (f1 x)) (y:Y): iscontr (hfiber f2 y) -> iscontr (hfiber f1 y).
Proof. intros X Y f1 f2 h y X0.
set (f:= (fun z:(hfiber f1 y) =>
match z with
(tpair _ x e) => hfiberpair f2 x (pathscomp0 (h x) e)
end)).
set (g:= (fun z:(hfiber f2 y) =>
match z with
(tpair _ x e) => hfiberpair f1 x (pathscomp0 (pathsinv0 (h x)) e)
end)).
assert (egf: forall z:(hfiber f1 y), paths (g (f z)) z). intros. destruct z as [ x e ]. simpl . apply ( hfibertriangle2 _ (hfiberpair f1 x (pathscomp0 (pathsinv0 (h x)) (pathscomp0 (h x) e))) ( hfiberpair f1 x e ) ( idpath x ) ) . simpl . destruct e . destruct ( h x ) . apply idpath .
apply ( iscontrretract g f egf X0). Defined.
Corollary isweqhomot { X Y : UU } ( f1 f2 : X-> Y ) (h: forall x:X, paths (f1 x) (f2 x)): isweq f1 -> isweq f2.
Proof. intros X Y f1 f2 h X0. unfold isweq. intro y. set (Y0:= X0 y). apply (iscontrhfiberl2 f2 f1 h). assumption. Defined.
Theorem gradth { X Y : UU } (f:X->Y) (g:Y->X) (egf: forall x:X, paths (g (f x)) x) (efg: forall y:Y, paths (f (g y)) y ): isweq f.
Proof. intros. unfold isweq. intro z.
assert (iscontr (hfiber (fun y:Y => (f (g y))) z)).
assert (efg': forall y:Y, paths y (f (g y))). intros. set (e1:= efg y). apply pathsinv0. assumption.
apply (iscontrhfiberl2 (fun y:Y => (f (g y))) (fun y:Y => y) efg' z (idisweq Y z)).
apply (iscontrhfiberl1 g f egf z). assumption.
Defined.
Definition weqgradth { X Y : UU } (f:X->Y) (g:Y->X) (egf: forall x:X, paths (g (f x)) x) (efg: forall y:Y, paths (f (g y)) y ) : weq X Y := weqpair _ ( gradth _ _ egf efg ) .
(** *** Some basic weak equivalences *)
Corollary isweqinvmap { X Y : UU } ( w : weq X Y ) : isweq (invmap w ).
Proof. intros. set (invf:= invmap w ). assert (efinvf: forall y:Y, paths ( w (invf y)) y). apply homotweqinvweq.
assert (einvff: forall x:X, paths (invf ( w x)) x). apply homotinvweqweq. apply ( gradth _ _ efinvf einvff ) . Defined.
Definition invweq { X Y : UU } ( w : weq X Y ) : weq Y X := weqpair (invmap w ) (isweqinvmap w ).
Corollary invinv { X Y :UU } ( w : weq X Y ) ( x : X ) : paths ( invweq ( invweq w ) x) (w x).
Proof. intros. unfold invweq . unfold invmap . simpl . apply idpath . Defined .
Corollary iscontrweqf { X Y : UU } ( w : weq X Y ) : iscontr X -> iscontr Y.
Proof. intros X Y w X0 . apply (iscontrweqb ( invweq w ) ). assumption. Defined.
(** The standard weak equivalence from [ unit ] to a contractible type *)
Definition wequnittocontr { X : UU } ( is : iscontr X ) : weq unit X .
Proof . intros . set ( f := fun t : unit => pr1 is ) . set ( g := fun x : X => tt ) . split with f .
assert ( egf : forall a : _ , paths ( g ( f a )) a ) . intro . destruct a . apply idpath .
assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro . simpl . apply ( pathsinv0 ( pr2 is a ) ) .
apply ( gradth _ _ egf efg ) . Defined .
(** A weak equivalence bwteen types defines weak equivalences on the corresponding [ paths ] types. *)
Corollary isweqmaponpaths { X Y : UU } ( w : weq X Y ) ( x x' : X ) : isweq (@maponpaths _ _ w x x').
Proof. intros. apply (gradth (@maponpaths _ _ w x x') (@invmaponpathsweq _ _ w x x') (@pathsweq3 _ _ w x x') (@pathsweq4 _ _ w x x')). Defined.
Definition weqonpaths { X Y : UU } ( w : weq X Y ) ( x x' : X ) := weqpair _ ( isweqmaponpaths w x x' ) .
Corollary isweqpathsinv0 { X : UU } (x x':X): isweq (@pathsinv0 _ x x').
Proof. intros. apply (gradth (@pathsinv0 _ x x') (@pathsinv0 _ x' x) (@pathsinv0inv0 _ _ _ ) (@pathsinv0inv0 _ _ _ )). Defined.
Definition weqpathsinv0 { X : UU } ( x x' : X ) := weqpair _ ( isweqpathsinv0 x x' ) .
Corollary isweqpathscomp0r { X : UU } (x : X ) { x' x'' : X } (e': paths x' x''): isweq (fun e:paths x x' => pathscomp0 e e').
Proof. intros. set (f:= fun e:paths x x' => pathscomp0 e e'). set (g:= fun e'': paths x x'' => pathscomp0 e'' (pathsinv0 e')).
assert (egf: forall e:_ , paths (g (f e)) e). intro. destruct e. simpl. destruct e'. simpl. apply idpath.
assert (efg: forall e'':_, paths (f (g e'')) e''). intro. destruct e''. simpl. destruct e'. simpl. apply idpath.
apply (gradth f g egf efg). Defined.
Corollary isweqtococonusf { X Y : UU } (f:X-> Y): isweq ( tococonusf f) .
Proof . intros. set (ff:= fromcoconusf f). set (gg:= tococonusf f).
assert (egf: forall yxe:_, paths (gg (ff yxe)) yxe). intro. destruct yxe as [t x]. destruct x as [ x e ]. unfold gg. unfold tococonusf. unfold ff. unfold fromcoconusf. simpl. destruct e. apply idpath.
assert (efg: forall x:_, paths (ff (gg x)) x). intro. apply idpath.
apply (gradth _ _ efg egf ). Defined.
Definition weqtococonusf { X Y : UU } ( f : X -> Y ) : weq X ( coconusf f ) := weqpair _ ( isweqtococonusf f ) .
Corollary isweqfromcoconusf { X Y : UU } (f:X-> Y): isweq (fromcoconusf f).
Proof. intros. set (ff:= fromcoconusf f). set (gg:= tococonusf f).
assert (egf: forall yxe:_, paths (gg (ff yxe)) yxe). intro. destruct yxe as [t x]. destruct x as [ x e ]. unfold gg. unfold tococonusf. unfold ff. unfold fromcoconusf. simpl. destruct e. apply idpath.
assert (efg: forall x:_, paths (ff (gg x)) x). intro. apply idpath.
apply (gradth _ _ egf efg). Defined.
Definition weqfromcoconusf { X Y : UU } ( f : X -> Y ) : weq ( coconusf f ) X := weqpair _ ( isweqfromcoconusf f ) .
Corollary isweqdeltap (T:UU) : isweq (deltap T).
Proof. intros. set (ff:=deltap T). set (gg:= fun z:pathsspace T => pr1 z).
assert (egf: forall t:T, paths (gg (ff t)) t). intro. apply idpath.
assert (efg: forall tte: pathsspace T, paths (ff (gg tte)) tte). intro. destruct tte as [ t x ]. destruct x as [ x0 e ]. destruct e. apply idpath.
apply (gradth _ _ egf efg). Defined.
Corollary isweqpr1pr1 (T:UU) : isweq (fun a: pathsspace' T => (pr1 (pr1 a))).
Proof. intros. set (f:= (fun a:_ => (pr1 (pr1 a))): pathsspace' T -> T). set (g:= (fun t:T => tpair _ (dirprodpair t t) (idpath t)): T -> pathsspace' T).
assert (efg: forall t:T, paths (f (g t)) t). intro. apply idpath.
assert (egf: forall a: pathsspace' T, paths (g (f a)) a). intro. destruct a as [ t x ]. destruct t. destruct x. simpl. apply idpath.
apply (gradth _ _ egf efg). Defined.
Lemma hfibershomotftog { X Y : UU } ( f g : X -> Y ) ( h : forall x : X , paths ( f x ) ( g x ) ) ( y : Y ) : hfiber f y -> hfiber g y .
Proof. intros X Y f g h y xe . destruct xe as [ x e ] . split with x . apply ( pathscomp0 ( pathsinv0 ( h x ) ) e ) . Defined .
Lemma hfibershomotgtof { X Y : UU } ( f g : X -> Y ) ( h : forall x : X , paths ( f x ) ( g x ) ) ( y : Y ) : hfiber g y -> hfiber f y .
Proof. intros X Y f g h y xe . destruct xe as [ x e ] . split with x . apply ( pathscomp0 ( h x ) e ) . Defined .
Theorem weqhfibershomot { X Y : UU } ( f g : X -> Y ) ( h : forall x : X , paths ( f x ) ( g x ) ) ( y : Y ) : weq ( hfiber f y ) ( hfiber g y ) .
Proof . intros . set ( ff := hfibershomotftog f g h y ) . set ( gg := hfibershomotgtof f g h y ) . split with ff .
assert ( effgg : forall xe : _ , paths ( ff ( gg xe ) ) xe ) . intro . destruct xe as [ x e ] . simpl .
assert ( eee: paths ( pathscomp0 (pathsinv0 (h x)) (pathscomp0 (h x) e) ) (pathscomp0 (maponpaths g ( idpath x ) ) e ) ) . simpl . destruct e . destruct ( h x ) . simpl . apply idpath .
set ( xe1 := hfiberpair g x ( pathscomp0 (pathsinv0 (h x)) (pathscomp0 (h x) e) ) ) . set ( xe2 := hfiberpair g x e ) . apply ( hfibertriangle2 g xe1 xe2 ( idpath x ) eee ) .
assert ( eggff : forall xe : _ , paths ( gg ( ff xe ) ) xe ) . intro . destruct xe as [ x e ] . simpl .
assert ( eee: paths ( pathscomp0 (h x) (pathscomp0 (pathsinv0 (h x)) e) ) (pathscomp0 (maponpaths f ( idpath x ) ) e ) ) . simpl . destruct e . destruct ( h x ) . simpl . apply idpath .
set ( xe1 := hfiberpair f x ( pathscomp0 (h x) (pathscomp0 (pathsinv0 (h x)) e) ) ) . set ( xe2 := hfiberpair f x e ) . apply ( hfibertriangle2 f xe1 xe2 ( idpath x ) eee ) .
apply ( gradth _ _ eggff effgg ) . Defined .
(** *** The 2-out-of-3 property of weak equivalences.
Theorems showing that if any two of three functions f, g, gf are weak equivalences then so is the third - the 2-out-of-3 property. *)
Theorem twooutof3a { X Y Z : UU } (f:X->Y) (g:Y->Z) (isgf: isweq (fun x:X => g (f x))) (isg: isweq g) : isweq f.
Proof. intros. set ( gw := weqpair g isg ) . set ( gfw := weqpair _ isgf ) . set (invg:= invmap gw ). set (invgf:= invmap gfw ). set (invf := (fun y:Y => invgf (g y))).
assert (efinvf: forall y:Y, paths (f (invf y)) y). intro. assert (int1: paths (g (f (invf y))) (g y)). unfold invf. apply (homotweqinvweq gfw ( g y ) ). apply (invmaponpathsweq gw _ _ int1).
assert (einvff: forall x: X, paths (invf (f x)) x). intro. unfold invf. apply (homotinvweqweq gfw x).
apply (gradth f invf einvff efinvf). Defined.
Corollary isweqcontrcontr { X Y : UU } (f:X -> Y) (isx: iscontr X) (isy: iscontr Y): isweq f.
Proof. intros. set (py:= (fun y:Y => tt)). apply (twooutof3a f py (isweqcontrtounit isx) (isweqcontrtounit isy)). Defined.
Definition weqcontrcontr { X Y : UU } ( isx : iscontr X) (isy: iscontr Y) := weqpair _ ( isweqcontrcontr ( fun x : X => pr1 isy ) isx isy ) .
Theorem twooutof3b { X Y Z : UU } (f:X->Y) (g:Y->Z) (isf: isweq f) (isgf: isweq (fun x:X => g(f x))) : isweq g.
Proof. intros. set ( wf := weqpair f isf ) . set ( wgf := weqpair _ isgf ) . set (invf:= invmap wf ). set (invgf:= invmap wgf ). set (invg := (fun z:Z => f ( invgf z))). set (gf:= fun x:X => (g (f x))).
assert (eginvg: forall z:Z, paths (g (invg z)) z). intro. apply (homotweqinvweq wgf z).
assert (einvgg: forall y:Y, paths (invg (g y)) y). intro. assert (isinvf: isweq invf). apply isweqinvmap. assert (isinvgf: isweq invgf). apply isweqinvmap. assert (int1: paths (g y) (gf (invf y))). apply (maponpaths g (pathsinv0 (homotweqinvweq wf y))). assert (int2: paths (gf (invgf (g y))) (gf (invf y))). assert (int3: paths (gf (invgf (g y))) (g y)). apply (homotweqinvweq wgf ). destruct int1. assumption. assert (int4: paths (invgf (g y)) (invf y)). apply (invmaponpathsweq wgf ). assumption. assert (int5:paths (invf (f (invgf (g y)))) (invgf (g y))). apply (homotinvweqweq wf ). assert (int6: paths (invf (f (invgf (g (y))))) (invf y)). destruct int4. assumption. apply (invmaponpathsweq ( weqpair invf isinvf ) ). assumption. apply (gradth g invg einvgg eginvg). Defined.
Lemma isweql3 { X Y : UU } (f:X-> Y) (g:Y->X) (egf: forall x:X, paths (g (f x)) x): isweq f -> isweq g.
Proof. intros X Y f g egf X0. set (gf:= fun x:X => g (f x)). assert (int1: isweq gf). apply (isweqhomot (fun x:X => x) gf (fun x:X => (pathsinv0 (egf x)))). apply idisweq. apply (twooutof3b f g X0 int1). Defined.
Theorem twooutof3c { X Y Z : UU } (f:X->Y) (g:Y->Z) (isf: isweq f) (isg: isweq g) : isweq (fun x:X => g(f x)).
Proof. intros. set ( wf := weqpair f isf ) . set ( wg := weqpair _ isg ) . set (gf:= fun x:X => g (f x)). set (invf:= invmap wf ). set (invg:= invmap wg ). set (invgf:= fun z:Z => invf (invg z)). assert (egfinvgf: forall x:X, paths (invgf (gf x)) x). unfold gf. unfold invgf. intro x. assert (int1: paths (invf (invg (g (f x)))) (invf (f x))). apply (maponpaths invf (homotinvweqweq wg (f x))). assert (int2: paths (invf (f x)) x). apply homotinvweqweq. destruct int1. assumption.
assert (einvgfgf: forall z:Z, paths (gf (invgf z)) z). unfold gf. unfold invgf. intro z. assert (int1: paths (g (f (invf (invg z)))) (g (invg z))). apply (maponpaths g (homotweqinvweq wf (invg z))). assert (int2: paths (g (invg z)) z). apply (homotweqinvweq wg z). destruct int1. assumption. apply (gradth gf invgf egfinvgf einvgfgf). Defined.
Definition weqcomp { X Y Z : UU } (w1 : weq X Y) (w2 : weq Y Z) : (weq X Z) := weqpair (fun x:X => (pr1 w2 (pr1 w1 x))) (twooutof3c _ _ (pr2 w1) (pr2 w2)).
(** *** Associativity of [ total2 ] *)
Lemma total2asstor { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) : total2 Q -> total2 ( fun x : X => total2 ( fun p : P x => Q ( tpair P x p ) ) ) .
Proof. intros X P Q xpq . destruct xpq as [ xp q ] . destruct xp as [ x p ] . split with x . split with p . assumption . Defined .
Lemma total2asstol { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) : total2 ( fun x : X => total2 ( fun p : P x => Q ( tpair P x p ) ) ) -> total2 Q .
Proof. intros X P Q xpq . destruct xpq as [ x pq ] . destruct pq as [ p q ] . split with ( tpair P x p ) . assumption . Defined .
Theorem weqtotal2asstor { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) : weq ( total2 Q ) ( total2 ( fun x : X => total2 ( fun p : P x => Q ( tpair P x p ) ) ) ).
Proof. intros . set ( f := total2asstor P Q ) . set ( g:= total2asstol P Q ) . split with f .
assert ( egf : forall xpq : _ , paths ( g ( f xpq ) ) xpq ) . intro . destruct xpq as [ xp q ] . destruct xp as [ x p ] . apply idpath .
assert ( efg : forall xpq : _ , paths ( f ( g xpq ) ) xpq ) . intro . destruct xpq as [ x pq ] . destruct pq as [ p q ] . apply idpath .
apply ( gradth _ _ egf efg ) . Defined.
Definition weqtotal2asstol { X : UU } ( P : X -> UU ) ( Q : total2 P -> UU ) : weq ( total2 ( fun x : X => total2 ( fun p : P x => Q ( tpair P x p ) ) ) ) ( total2 Q ) := invweq ( weqtotal2asstor P Q ) .
(** *** Associativity and commutativity of [ dirprod ] *)
Definition weqdirprodasstor ( X Y Z : UU ) : weq ( dirprod ( dirprod X Y ) Z ) ( dirprod X ( dirprod Y Z ) ) .
Proof . intros . apply weqtotal2asstor . Defined .
Definition weqdirprodasstol ( X Y Z : UU ) : weq ( dirprod X ( dirprod Y Z ) ) ( dirprod ( dirprod X Y ) Z ) := invweq ( weqdirprodasstor X Y Z ) .
Definition weqdirprodcomm ( X Y : UU ) : weq ( dirprod X Y ) ( dirprod Y X ) .
Proof. intros . set ( f := fun xy : dirprod X Y => dirprodpair ( pr2 xy ) ( pr1 xy ) ) . set ( g := fun yx : dirprod Y X => dirprodpair ( pr2 yx ) ( pr1 yx ) ) .
assert ( egf : forall xy : _ , paths ( g ( f xy ) ) xy ) . intro . destruct xy . apply idpath .
assert ( efg : forall yx : _ , paths ( f ( g yx ) ) yx ) . intro . destruct yx . apply idpath .
split with f . apply ( gradth _ _ egf efg ) . Defined .
(** *** Coproducts and direct products *)
Definition rdistrtocoprod ( X Y Z : UU ): dirprod X (coprod Y Z) -> coprod (dirprod X Y) (dirprod X Z).
Proof. intros X Y Z X0. destruct X0 as [ t x ]. destruct x as [ y | z ] . apply (ii1 (dirprodpair t y)). apply (ii2 (dirprodpair t z)). Defined.
Definition rdistrtoprod (X Y Z:UU): coprod (dirprod X Y) (dirprod X Z) -> dirprod X (coprod Y Z).
Proof. intros X Y Z X0. destruct X0 as [ d | d ]. destruct d as [ t x ]. apply (dirprodpair t (ii1 x)). destruct d as [ t x ]. apply (dirprodpair t (ii2 x)). Defined.
Theorem isweqrdistrtoprod (X Y Z:UU): isweq (rdistrtoprod X Y Z).
Proof. intros. set (f:= rdistrtoprod X Y Z). set (g:= rdistrtocoprod X Y Z).
assert (egf: forall a:_, paths (g (f a)) a). intro. destruct a as [ d | d ] . destruct d. apply idpath. destruct d. apply idpath.
assert (efg: forall a:_, paths (f (g a)) a). intro. destruct a as [ t x ]. destruct x. apply idpath. apply idpath.
apply (gradth f g egf efg). Defined.
Definition weqrdistrtoprod (X Y Z: UU):= weqpair _ (isweqrdistrtoprod X Y Z).
Corollary isweqrdistrtocoprod (X Y Z:UU): isweq (rdistrtocoprod X Y Z).
Proof. intros. apply (isweqinvmap ( weqrdistrtoprod X Y Z ) ) . Defined.
Definition weqrdistrtocoprod (X Y Z: UU):= weqpair _ (isweqrdistrtocoprod X Y Z).
(** *** Total space of a family over a coproduct *)
Definition fromtotal2overcoprod { X Y : UU } ( P : coprod X Y -> UU ) ( xyp : total2 P ) : coprod ( total2 ( fun x : X => P ( ii1 x ) ) ) ( total2 ( fun y : Y => P ( ii2 y ) ) ) .
Proof. intros . set ( PX := fun x : X => P ( ii1 x ) ) . set ( PY := fun y : Y => P ( ii2 y ) ) . destruct xyp as [ xy p ] . destruct xy as [ x | y ] . apply ( ii1 ( tpair PX x p ) ) . apply ( ii2 ( tpair PY y p ) ) . Defined .
Definition tototal2overcoprod { X Y : UU } ( P : coprod X Y -> UU ) ( xpyp : coprod ( total2 ( fun x : X => P ( ii1 x ) ) ) ( total2 ( fun y : Y => P ( ii2 y ) ) ) ) : total2 P .
Proof . intros . destruct xpyp as [ xp | yp ] . destruct xp as [ x p ] . apply ( tpair P ( ii1 x ) p ) . destruct yp as [ y p ] . apply ( tpair P ( ii2 y ) p ) . Defined .
Theorem weqtotal2overcoprod { X Y : UU } ( P : coprod X Y -> UU ) : weq ( total2 P ) ( coprod ( total2 ( fun x : X => P ( ii1 x ) ) ) ( total2 ( fun y : Y => P ( ii2 y ) ) ) ) .
Proof. intros . set ( f := fromtotal2overcoprod P ) . set ( g := tototal2overcoprod P ) . split with f .
assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . destruct a as [ xy p ] . destruct xy as [ x | y ] . simpl . apply idpath . simpl . apply idpath .
assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . destruct a as [ xp | yp ] . destruct xp as [ x p ] . simpl . apply idpath . destruct yp as [ y p ] . apply idpath .
apply ( gradth _ _ egf efg ) . Defined .
(** *** Weak equivalences and pairwise direct products *)
Theorem isweqdirprodf { X Y X' Y' : UU } ( w : weq X Y )( w' : weq X' Y' ) : isweq (dirprodf w w' ).
Proof. intros. set ( f := dirprodf w w' ) . set ( g := dirprodf ( invweq w ) ( invweq w' ) ) .
assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . destruct a as [ x x' ] . simpl . apply pathsdirprod . apply ( homotinvweqweq w x ) . apply ( homotinvweqweq w' x' ) .
assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . destruct a as [ x x' ] . simpl . apply pathsdirprod . apply ( homotweqinvweq w x ) . apply ( homotweqinvweq w' x' ) .
apply ( gradth _ _ egf efg ) . Defined .
Definition weqdirprodf { X Y X' Y' : UU } ( w : weq X Y ) ( w' : weq X' Y' ) := weqpair _ ( isweqdirprodf w w' ) .
Definition weqtodirprodwithunit (X:UU): weq X (dirprod X unit).
Proof. intros. set (f:=fun x:X => dirprodpair x tt). split with f. set (g:= fun xu:dirprod X unit => pr1 xu).
assert (egf: forall x:X, paths (g (f x)) x). intro. apply idpath.
assert (efg: forall xu:_, paths (f (g xu)) xu). intro. destruct xu as [ t x ]. destruct x. apply idpath.
apply (gradth f g egf efg). Defined.
(** *** Basics on pairwise coproducts (disjoint unions) *)
(** In the current version [ coprod ] is a notation, introduced in uuu.v for [ sum ] of types which is defined in Coq.Init *)
Definition sumofmaps {X Y Z:UU}(fx: X -> Z)(fy: Y -> Z): (coprod X Y) -> Z := fun xy:_ => match xy with ii1 x => fx x | ii2 y => fy y end.
Definition boolascoprod: weq (coprod unit unit) bool.
Proof. set (f:= fun xx: coprod unit unit => match xx with ii1 t => true | ii2 t => false end). split with f.
set (g:= fun t:bool => match t with true => ii1 tt | false => ii2 tt end).
assert (egf: forall xx:_, paths (g (f xx)) xx). intro xx . destruct xx as [ u | u ] . destruct u. apply idpath. destruct u. apply idpath.
assert (efg: forall t:_, paths (f (g t)) t). destruct t. apply idpath. apply idpath.
apply (gradth f g egf efg). Defined.
Definition coprodasstor (X Y Z:UU): coprod (coprod X Y) Z -> coprod X (coprod Y Z).
Proof. intros X Y Z X0. destruct X0 as [ c | z ] . destruct c as [ x | y ] . apply (ii1 x). apply (ii2 (ii1 y)). apply (ii2 (ii2 z)). Defined.
Definition coprodasstol (X Y Z: UU): coprod X (coprod Y Z) -> coprod (coprod X Y) Z.
Proof. intros X Y Z X0. destruct X0 as [ x | c ] . apply (ii1 (ii1 x)). destruct c as [ y | z ] . apply (ii1 (ii2 y)). apply (ii2 z). Defined.
Theorem isweqcoprodasstor (X Y Z:UU): isweq (coprodasstor X Y Z).
Proof. intros. set (f:= coprodasstor X Y Z). set (g:= coprodasstol X Y Z).
assert (egf: forall xyz:_, paths (g (f xyz)) xyz). intro xyz. destruct xyz as [ c | z ] . destruct c. apply idpath. apply idpath. apply idpath.
assert (efg: forall xyz:_, paths (f (g xyz)) xyz). intro xyz. destruct xyz as [ x | c ] . apply idpath. destruct c. apply idpath. apply idpath.
apply (gradth f g egf efg). Defined.
Definition weqcoprodasstor ( X Y Z : UU ) := weqpair _ ( isweqcoprodasstor X Y Z ) .
Corollary isweqcoprodasstol (X Y Z:UU): isweq (coprodasstol X Y Z).
Proof. intros. apply (isweqinvmap ( weqcoprodasstor X Y Z) ). Defined.
Definition weqcoprodasstol (X Y Z:UU):= weqpair _ (isweqcoprodasstol X Y Z).
Definition coprodcomm (X Y:UU): coprod X Y -> coprod Y X := fun xy:_ => match xy with ii1 x => ii2 x | ii2 y => ii1 y end.
Theorem isweqcoprodcomm (X Y:UU): isweq (coprodcomm X Y).
Proof. intros. set (f:= coprodcomm X Y). set (g:= coprodcomm Y X).
assert (egf: forall xy:_, paths (g (f xy)) xy). intro. destruct xy. apply idpath. apply idpath.
assert (efg: forall yx:_, paths (f (g yx)) yx). intro. destruct yx. apply idpath. apply idpath.
apply (gradth f g egf efg). Defined.
Definition weqcoprodcomm (X Y:UU):= weqpair _ (isweqcoprodcomm X Y).
Theorem isweqii1withneg (X : UU) { Y : UU } (nf:Y -> empty): isweq (@ii1 X Y).
Proof. intros. set (f:= @ii1 X Y). set (g:= fun xy:coprod X Y => match xy with ii1 x => x | ii2 y => fromempty (nf y) end).
assert (egf: forall x:X, paths (g (f x)) x). intro. apply idpath.
assert (efg: forall xy: coprod X Y, paths (f (g xy)) xy). intro. destruct xy as [ x | y ] . apply idpath. apply (fromempty (nf y)).
apply (gradth f g egf efg). Defined.
Definition weqii1withneg ( X : UU ) { Y : UU } ( nf : neg Y ) := weqpair _ ( isweqii1withneg X nf ) .
Theorem isweqii2withneg { X : UU } ( Y : UU ) (nf : X -> empty): isweq (@ii2 X Y).
Proof. intros. set (f:= @ii2 X Y). set (g:= fun xy:coprod X Y => match xy with ii1 x => fromempty (nf x) | ii2 y => y end).
assert (egf: forall y : Y, paths (g (f y)) y). intro. apply idpath.
assert (efg: forall xy: coprod X Y, paths (f (g xy)) xy). intro. destruct xy as [ x | y ] . apply (fromempty (nf x)). apply idpath.
apply (gradth f g egf efg). Defined.
Definition weqii2withneg { X : UU } ( Y : UU ) ( nf : neg X ) := weqpair _ ( isweqii2withneg Y nf ) .
Definition coprodf { X Y X' Y' : UU } (f: X -> X')(g: Y-> Y'): coprod X Y -> coprod X' Y' := fun xy: coprod X Y =>
match xy with
ii1 x => ii1 (f x)|
ii2 y => ii2 (g y)
end.
Definition homotcoprodfcomp { X X' Y Y' Z Z' : UU } ( f : X -> Y ) ( f' : X' -> Y' ) ( g : Y -> Z ) ( g' : Y' -> Z' ) : homot ( funcomp ( coprodf f f' ) ( coprodf g g' ) ) ( coprodf ( funcomp f g ) ( funcomp f' g' ) ) .
Proof. intros . intro xx' . destruct xx' as [ x | x' ] . apply idpath . apply idpath . Defined .
Definition homotcoprodfhomot { X X' Y Y' } ( f g : X -> Y ) ( f' g' : X' -> Y' ) ( h : homot f g ) ( h' : homot f' g' ) : homot ( coprodf f f') ( coprodf g g') := fun xx' : _ => match xx' with ( ii1 x ) => maponpaths ( @ii1 _ _ ) ( h x ) | ( ii2 x' ) => maponpaths ( @ii2 _ _ ) ( h' x' ) end .
Theorem isweqcoprodf { X Y X' Y' : UU } ( w : weq X X' )( w' : weq Y Y' ) : isweq (coprodf w w' ).
Proof. intros. set (finv:= invmap w ). set (ginv:= invmap w' ). set (ff:=coprodf w w' ). set (gg:=coprodf finv ginv).
assert (egf: forall xy: coprod X Y, paths (gg (ff xy)) xy). intro. destruct xy as [ x | y ] . simpl. apply (maponpaths (@ii1 X Y) (homotinvweqweq w x)). apply (maponpaths (@ii2 X Y) (homotinvweqweq w' y)).
assert (efg: forall xy': coprod X' Y', paths (ff (gg xy')) xy'). intro. destruct xy' as [ x | y ] . simpl. apply (maponpaths (@ii1 X' Y') (homotweqinvweq w x)). apply (maponpaths (@ii2 X' Y') (homotweqinvweq w' y)).
apply (gradth ff gg egf efg). Defined.
Definition weqcoprodf { X Y X' Y' : UU } (w1: weq X Y)(w2: weq X' Y') : weq (coprod X X') (coprod Y Y') := weqpair _ ( isweqcoprodf w1 w2 ) .
Lemma negpathsii1ii2 { X Y : UU } (x:X)(y:Y): neg (paths (ii1 x) (ii2 y)).
Proof. intros. unfold neg. intro X0. set (dist:= fun xy: coprod X Y => match xy with ii1 x => unit | ii2 y => empty end). apply (transportf dist X0 tt). Defined.
Lemma negpathsii2ii1 { X Y : UU } (x:X)(y:Y): neg (paths (ii2 y) (ii1 x)).
Proof. intros. unfold neg. intro X0. set (dist:= fun xy: coprod X Y => match xy with ii1 x => empty | ii2 y => unit end). apply (transportf dist X0 tt). Defined.
(** *** Fibrations with only one non-empty fiber.
Theorem saying that if a fibration has only one non-empty fiber then the total space is weakly equivalent to this fiber. *)
Theorem onefiber { X : UU } (P:X -> UU)(x:X)(c: forall x':X, coprod (paths x x') (P x' -> empty)) : isweq (fun p: P x => tpair P x p).
Proof. intros.
set (f:= fun p: P x => tpair _ x p).
set (cx := c x).
set (cnew:= fun x':X =>
match cx with
ii1 x0 =>
match c x' with
ii1 ee => ii1 (pathscomp0 (pathsinv0 x0) ee)|
ii2 phi => ii2 phi
end |
ii2 phi => c x'
end).
set (g:= fun pp: total2 P =>
match (cnew (pr1 pp)) with
ii1 e => transportb P e (pr2 pp) |
ii2 phi => fromempty (phi (pr2 pp))
end).
assert (efg: forall pp: total2 P, paths (f (g pp)) pp). intro. destruct pp as [ t x0 ]. set (cnewt:= cnew t). unfold g. unfold f. simpl. change (cnew t) with cnewt. destruct cnewt as [ x1 | y ]. apply (pathsinv0 (pr1 (pr2 (constr1 P (pathsinv0 x1))) x0)). destruct (y x0).
set (cnewx:= cnew x).
assert (e1: paths (cnew x) cnewx). apply idpath.
unfold cnew in cnewx. change (c x) with cx in cnewx.
destruct cx as [ x0 | e0 ].
assert (e: paths (cnewx) (ii1 (idpath x))). apply (maponpaths (@ii1 (paths x x) (P x -> empty)) (pathsinv0l x0)).
assert (egf: forall p: P x, paths (g (f p)) p). intro. simpl in g. unfold g. unfold f. simpl.
set (ff:= fun cc:coprod (paths x x) (P x -> empty) =>
match cc with
| ii1 e0 => transportb P e0 p
| ii2 phi => fromempty (phi p)
end).
assert (ee: paths (ff (cnewx)) (ff (@ii1 (paths x x) (P x -> empty) (idpath x)))). apply (maponpaths ff e).
assert (eee: paths (ff (@ii1 (paths x x) (P x -> empty) (idpath x))) p). apply idpath. fold (ff (cnew x)).
assert (e2: paths (ff (cnew x)) (ff cnewx)). apply (maponpaths ff e1).
apply (pathscomp0 (pathscomp0 e2 ee) eee).
apply (gradth f g egf efg).
unfold isweq. intro y0. destruct (e0 (g y0)). Defined.
(** *** Pairwise coproducts as dependent sums of families over [ bool ] *)
Fixpoint coprodtobool { X Y : UU } ( xy : coprod X Y ) : bool :=
match xy with
ii1 x => true|
ii2 y => false
end.
Definition boolsumfun (X Y:UU) : bool -> UU := fun t:_ =>
match t with
true => X|
false => Y
end.
Definition coprodtoboolsum ( X Y : UU ) : coprod X Y -> total2 (boolsumfun X Y) := fun xy : _ =>
match xy with
ii1 x => tpair (boolsumfun X Y) true x|
ii2 y => tpair (boolsumfun X Y) false y
end .
Definition boolsumtocoprod (X Y:UU): (total2 (boolsumfun X Y)) -> coprod X Y := (fun xy:_ =>
match xy with
tpair _ true x => ii1 x|
tpair _ false y => ii2 y
end).
Theorem isweqcoprodtoboolsum (X Y:UU): isweq (coprodtoboolsum X Y).
Proof. intros. set (f:= coprodtoboolsum X Y). set (g:= boolsumtocoprod X Y).
assert (egf: forall xy: coprod X Y , paths (g (f xy)) xy). destruct xy. apply idpath. apply idpath.
assert (efg: forall xy: total2 (boolsumfun X Y), paths (f (g xy)) xy). intro. destruct xy as [ t x ]. destruct t. apply idpath. apply idpath. apply (gradth f g egf efg). Defined.
Definition weqcoprodtoboolsum ( X Y : UU ) := weqpair _ ( isweqcoprodtoboolsum X Y ) .
Corollary isweqboolsumtocoprod (X Y:UU): isweq (boolsumtocoprod X Y ).
Proof. intros. apply (isweqinvmap ( weqcoprodtoboolsum X Y ) ) . Defined.
Definition weqboolsumtocoprod ( X Y : UU ) := weqpair _ ( isweqboolsumtocoprod X Y ) .
(** *** Splitting of [ X ] into a coproduct defined by a function [ X -> coprod Y Z ] *)
Definition weqcoprodsplit { X Y Z : UU } ( f : X -> coprod Y Z ) : weq X ( coprod ( total2 ( fun y : Y => hfiber f ( ii1 y ) ) ) ( total2 ( fun z : Z => hfiber f ( ii2 z ) ) ) ) .
Proof . intros . set ( w1 := weqtococonusf f ) . set ( w2 := weqtotal2overcoprod ( fun yz : coprod Y Z => hfiber f yz ) ) . apply ( weqcomp w1 w2 ) . Defined .
(** *** Some properties of [ bool ] *)
Definition boolchoice ( x : bool ) : coprod ( paths x true ) ( paths x false ) .
Proof. intro . destruct x . apply ( ii1 ( idpath _ ) ) . apply ( ii2 ( idpath _ ) ) . Defined .
Definition curry : bool -> UU := fun x : bool =>
match x with
false => empty|
true => unit
end.
Theorem nopathstruetofalse: paths true false -> empty.
Proof. intro X. apply (transportf curry X tt). Defined.
Corollary nopathsfalsetotrue: paths false true -> empty.
Proof. intro X. apply (transportb curry X tt). Defined.
Definition truetonegfalse ( x : bool ) : paths x true -> neg ( paths x false ) .
Proof . intros x e . rewrite e . unfold neg . apply nopathstruetofalse . Defined .
Definition falsetonegtrue ( x : bool ) : paths x false -> neg ( paths x true ) .
Proof . intros x e . rewrite e . unfold neg . apply nopathsfalsetotrue . Defined .
Definition negtruetofalse (x : bool ) : neg ( paths x true ) -> paths x false .
Proof. intros x ne. destruct (boolchoice x) as [t | f]. destruct (ne t). apply f. Defined.
Definition negfalsetotrue ( x : bool ) : neg ( paths x false ) -> paths x true .
Proof. intros x ne . destruct (boolchoice x) as [t | f]. apply t . destruct (ne f) . Defined.
(** ** Basics about fibration sequences. *)
(** *** Fibrations sequences and their first "left shifts".
The group of constructions related to fibration sequences forms one of the most important computational toolboxes of homotopy theory .
Given a pair of functions [ ( f : X -> Y ) ( g : Y -> Z ) ] and a point [ z : Z ] , a structure of the complex on such a triple is a homotopy from the composition [ funcomp f g ] to the constant function [ X -> Z ] corresponding to [ z ] i.e. a term [ ez : forall x:X, paths ( g ( f x ) ) z ]. Specifing such a structure is essentially equivalent to specifing a structure of the form [ ezmap : X -> hfiber g z ]. The mapping in one direction is given in the definition of [ ezmap ] below. The mapping in another is given by [ f := fun x : X => pr1 ( ezmap x ) ] and [ ez := fun x : X => pr2 ( ezmap x ) ].
A complex is called a fibration sequence if [ ezmap ] is a weak equivalence. Correspondingly, the structure of a fibration sequence on [ f g z ] is a pair [ ( ez , is ) ] where [ is : isweq ( ezmap f g z ez ) ]. For a fibration sequence [ f g z fs ] where [ fs : fibseqstr f g z ] and any [ y : Y ] there is defined a function [ diff1 : paths ( g y ) z -> X ] and a structure of the fibration sequence [ fibseqdiff1 ] on the triple [ diff1 g y ]. This new fibration sequence is called the derived fibration sequence of the original one.
The first function of the second derived of [ f g z fs ] corresponding to [ ( y : Y ) ( x : X ) ] is of the form [ paths ( f x ) y -> paths ( g y ) z ] and it is homotopic to the function defined by [ e => pathscomp0 ( maponpaths g ( pathsinv0 e) ) ( ez x ) ]. The first function of the third derived of [ f g z fs ] corresponding to [ ( y : Y ) ( x : X ) ( e : paths ( g y ) z ) ] is of the form [ paths ( diff1 e ) x -> paths ( f x ) y ]. Therefore, the third derived of a sequence based on [ X Y Z ] is based entirely on paths types of [ X ], [ Y ] and [ Z ]. When this construction is applied to types of finite h-level (see below) and combined with the fact that the h-level of a path type is strictly lower than the h-level of the ambient type it leads to the possibility of building proofs about types by induction on h-level.
There are three important special cases in which fibration sequences arise:
( pr1 - case ) The fibration sequence [ fibseqpr1 P z ] defined by family [ P : Z -> UU ] and a term [ z : Z ]. It is based on the sequence of functions [ ( tpair P z : P z -> total2 P ) ( pr1 : total2 P -> Z ) ]. The corresponding [ ezmap ] is defined by an obvious rule and the fact that it is a weak equivalence is proved in [ isweqfibertohfiber ].
( g - case ) The fibration sequence [ fibseqg g z ] defined by a function [ g : Y -> Z ] and a term [ z : Z ]. It is based on the sequence of functions [ ( hfiberpr1 : hfiber g z -> Y ) ( g : Y -> Z ) ] and the corresponding [ ezmap ] is the function which takes a term [ ye : hfiber ] to [ hfiberpair g ( pr1 ye ) ( pr2 ye ) ]. If we had eta-concersion for the depndent sums it would be the identiry function. Since we do not have this conversion in Coq this function is only homotopic to the identity function by [ tppr ] which is sufficient to ensure that it is a weak equivalence. The first derived of [ fibseqg g z ] corresponding to [ y : Y ] coincides with [ fibseqpr1 ( fun y' : Y => paths ( g y' ) z ) y ].
( hf -case ) The fibration sequence of homotopy fibers defined for any pair of functions [ ( f : X -> Y ) ( g : Y -> Z ) ] and any terms [ ( z : Z ) ( ye : hfiber g z ) ]. It is based on functions [ hfiberftogf : hfiber f ( pr1 ye ) -> hfiber ( funcomp f g ) z ] and [ hfibergftog : hfiber ( funcomp f g ) z -> hfiber g z ] which are defined below.
*)
(** The structure of a complex structure on a composable pair of functions [ ( f : X -> Y ) ( g : Y -> Z ) ] relative to a term [ z : Z ]. *)
Definition complxstr { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) := forall x:X, paths (g (f x)) z .
(** The structure of a fibration sequence on a complex. *)
Definition ezmap { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) (ez : complxstr f g z ) : X -> hfiber g z := fun x:X => hfiberpair g (f x) (ez x).
Definition isfibseq { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) (ez : complxstr f g z ) := isweq (ezmap f g z ez).
Definition fibseqstr { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) := total2 ( fun ez : complxstr f g z => isfibseq f g z ez ) .
Definition fibseqstrpair { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) := tpair ( fun ez : complxstr f g z => isfibseq f g z ez ) .
Definition fibseqstrtocomplxstr { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) : fibseqstr f g z -> complxstr f g z := @pr1 _ ( fun ez : complxstr f g z => isfibseq f g z ez ) .
Coercion fibseqstrtocomplxstr : fibseqstr >-> complxstr .
Definition ezweq { X Y Z : UU } (f:X -> Y) (g:Y->Z) ( z : Z ) ( fs : fibseqstr f g z ) : weq X ( hfiber g z ) := weqpair _ ( pr2 fs ) .
(** Construction of the derived fibration sequence. *)
Definition d1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( y : Y ) : paths ( g y ) z -> X := fun e : _ => invmap ( ezweq f g z fs ) ( hfiberpair g y e ) .
Definition ezmap1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( y : Y ) ( e : paths ( g y ) z ) : hfiber f y .
Proof . intros . split with ( d1 f g z fs y e ) . unfold d1 . change ( f ( invmap (ezweq f g z fs) (hfiberpair g y e) ) ) with ( hfiberpr1 _ _ ( ezweq f g z fs ( invmap (ezweq f g z fs) (hfiberpair g y e) ) ) ) . apply ( maponpaths ( hfiberpr1 g z ) ( homotweqinvweq ( ezweq f g z fs ) (hfiberpair g y e) ) ) . Defined .
Definition invezmap1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ez : complxstr f g z ) ( y : Y ) : hfiber f y -> paths (g y) z :=
fun xe: hfiber f y =>
match xe with
tpair _ x e => pathscomp0 (maponpaths g ( pathsinv0 e ) ) ( ez x )
end.
Theorem isweqezmap1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( y : Y ) : isweq ( ezmap1 f g z fs y ) .
Proof . intros . set ( ff := ezmap1 f g z fs y ) . set ( gg := invezmap1 f g z ( pr1 fs ) y ) .
assert ( egf : forall e : _ , paths ( gg ( ff e ) ) e ) . intro . simpl . apply ( hfibertriangle1inv0 g (homotweqinvweq (ezweq f g z fs) (hfiberpair g y e)) ) .
assert ( efg : forall xe : _ , paths ( ff ( gg xe ) ) xe ) . intro . destruct xe as [ x e ] . destruct e . simpl . unfold ff . unfold ezmap1 . unfold d1 . change (hfiberpair g (f x) ( pr1 fs x) ) with ( ezmap f g z fs x ) . apply ( hfibertriangle2 f ( hfiberpair f ( invmap (ezweq f g z fs) (ezmap f g z fs x) ) _ ) ( hfiberpair f x ( idpath _ ) ) ( homotinvweqweq ( ezweq f g z fs ) x ) ) . simpl . set ( e1 := pathsinv0 ( pathscomp0rid (maponpaths f (homotinvweqweq (ezweq f g z fs) x) ) ) ) . assert ( e2 : paths (maponpaths (hfiberpr1 g z) (homotweqinvweq (ezweq f g z fs) ( ( ezmap f g z fs ) x))) (maponpaths f (homotinvweqweq (ezweq f g z fs) x)) ) . set ( e3 := maponpaths ( fun e : _ => maponpaths ( hfiberpr1 g z ) e ) ( pathsinv0 ( homotweqinvweqweq ( ezweq f g z fs ) x ) ) ) . simpl in e3 . set ( e4 := maponpathscomp (ezmap f g z (pr1 fs)) (hfiberpr1 g z) (homotinvweqweq (ezweq f g z fs) x) ) . simpl in e4 . apply ( pathscomp0 e3 e4 ) . apply ( pathscomp0 e2 e1 ) .
apply ( gradth _ _ egf efg ) . Defined .
Definition ezweq1 { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( y : Y ) := weqpair _ ( isweqezmap1 f g z fs y ) .
Definition fibseq1 { X Y Z : UU } (f:X -> Y) (g:Y->Z) (z:Z) ( fs : fibseqstr f g z )(y:Y) : fibseqstr ( d1 f g z fs y) f y := fibseqstrpair _ _ _ _ ( isweqezmap1 f g z fs y ) .
(** Explitcit description of the first map in the second derived sequence. *)
Definition d2 { X Y Z : UU } (f:X -> Y) (g:Y->Z) (z:Z) ( fs : fibseqstr f g z ) (y:Y) (x:X) ( e : paths (f x) y ) : paths (g y) z := pathscomp0 ( maponpaths g ( pathsinv0 e ) ) ( ( pr1 fs ) x ) .
Definition ezweq2 { X Y Z : UU } (f:X -> Y) (g:Y->Z) (z:Z) ( fs : fibseqstr f g z ) (y:Y) (x:X) : weq ( paths (f x) y ) ( hfiber (d1 f g z fs y) x ) := ezweq1 (d1 f g z fs y) f y ( fibseq1 f g z fs y ) x.
Definition fibseq2 { X Y Z : UU } (f:X -> Y) (g:Y->Z) (z:Z) ( fs : fibseqstr f g z ) (y:Y) (x:X) : fibseqstr ( d2 f g z fs y x ) ( d1 f g z fs y ) x := fibseqstrpair _ _ _ _ ( isweqezmap1 (d1 f g z fs y) f y ( fibseq1 f g z fs y ) x ) .
(** *** Fibration sequences based on [ ( tpair P z : P z -> total2 P ) ( pr1 : total2 P -> Z ) ] ( the "pr1-case" ) *)
(** Construction of the fibration sequence. *)
Definition ezmappr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : P z -> hfiber ( @pr1 Z P ) z := fun p : P z => tpair _ ( tpair _ z p ) ( idpath z ).
Definition invezmappr1 { Z : UU } ( P : Z -> UU) ( z : Z ) : hfiber ( @pr1 Z P ) z -> P z := fun te : hfiber ( @pr1 Z P ) z =>
match te with
tpair _ t e => transportf P e ( pr2 t )
end.
Definition isweqezmappr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : isweq ( ezmappr1 P z ).
Proof. intros.
assert ( egf : forall x: P z , paths (invezmappr1 _ z ((ezmappr1 P z ) x)) x). intro. unfold ezmappr1. unfold invezmappr1. simpl. apply idpath.
assert ( efg : forall x: hfiber (@pr1 Z P) z , paths (ezmappr1 _ z (invezmappr1 P z x)) x). intros. destruct x as [ x t0 ]. destruct t0. simpl in x. simpl. destruct x. simpl. unfold transportf. unfold ezmappr1. apply idpath.
apply (gradth _ _ egf efg ). Defined.
Definition ezweqpr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) := weqpair _ ( isweqezmappr1 P z ) .
Lemma isfibseqpr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : isfibseq (fun p : P z => tpair _ z p) ( @pr1 Z P ) z (fun p: P z => idpath z ).
Proof. intros. unfold isfibseq. unfold ezmap. apply isweqezmappr1. Defined.
Definition fibseqpr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) : fibseqstr (fun p : P z => tpair _ z p) ( @pr1 Z P ) z := fibseqstrpair _ _ _ _ ( isfibseqpr1 P z ) .
(** The main weak equivalence defined by the first derived of [ fibseqpr1 ]. *)
Definition ezweq1pr1 { Z : UU } ( P : Z -> UU ) ( z : Z ) ( zp : total2 P ) : weq ( paths ( pr1 zp) z ) ( hfiber ( tpair P z ) zp ) := ezweq1 _ _ z ( fibseqpr1 P z ) zp .
(** *** Fibration sequences based on [ ( hfiberpr1 : hfiber g z -> Y ) ( g : Y -> Z ) ] (the "g-case") *)
Theorem isfibseqg { Y Z : UU } (g:Y -> Z) (z:Z) : isfibseq (hfiberpr1 g z) g z (fun ye: _ => pr2 ye).
Proof. intros. assert (Y0:forall ye': hfiber g z, paths ye' (ezmap (hfiberpr1 g z) g z (fun ye: _ => pr2 ye) ye')). intro. apply tppr. apply (isweqhomot _ _ Y0 (idisweq _ )). Defined.
Definition ezweqg { Y Z : UU } (g:Y -> Z) (z:Z) := weqpair _ ( isfibseqg g z ) .
Definition fibseqg { Y Z : UU } (g:Y -> Z) (z:Z) : fibseqstr (hfiberpr1 g z) g z := fibseqstrpair _ _ _ _ ( isfibseqg g z ) .
(** The first derived of [ fibseqg ]. *)
Definition d1g { Y Z : UU} ( g : Y -> Z ) ( z : Z ) ( y : Y ) : paths ( g y ) z -> hfiber g z := hfiberpair g y .
(** note that [ d1g ] coincides with [ d1 _ _ _ ( fibseqg g z ) ] which makes the following two definitions possible. *)
Definition ezweq1g { Y Z : UU } (g:Y -> Z) (z:Z) (y:Y) : weq (paths (g y) z) (hfiber (hfiberpr1 g z) y) := weqpair _ (isweqezmap1 (hfiberpr1 g z) g z ( fibseqg g z ) y) .
Definition fibseq1g { Y Z : UU } (g:Y -> Z) (z:Z) ( y : Y) : fibseqstr (d1g g z y ) ( hfiberpr1 g z ) y := fibseqstrpair _ _ _ _ (isweqezmap1 (hfiberpr1 g z) g z ( fibseqg g z ) y) .
(** The second derived of [ fibseqg ]. *)
Definition d2g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e: paths (pr1 ye') y ) : paths (g y) z := pathscomp0 ( maponpaths g ( pathsinv0 e ) ) ( pr2 ye' ) .
(** note that [ d2g ] coincides with [ d2 _ _ _ ( fibseqg g z ) ] which makes the following two definitions possible. *)
Definition ezweq2g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) : weq (paths (pr1 ye') y) (hfiber ( hfiberpair g y ) ye') := ezweq2 _ _ _ ( fibseqg g z ) _ _ .
Definition fibseq2g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) : fibseqstr ( d2g g y ye' ) ( hfiberpair g y ) ye' := fibseq2 _ _ _ ( fibseqg g z ) _ _ .
(** The third derived of [ fibseqg ] and an explicit description of the corresponding first map. *)
Definition d3g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e : paths ( g y ) z ) : paths ( hfiberpair g y e ) ye' -> paths ( pr1 ye' ) y := d2 (d1g g z y) (hfiberpr1 g z) y ( fibseq1g g z y ) ye' e .
Lemma homotd3g { Y Z : UU } ( g : Y -> Z ) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e : paths ( g y ) z ) ( ee : paths ( hfiberpair g y e) ye' ) : paths (d3g g y ye' e ee) ( maponpaths ( @pr1 _ _ ) ( pathsinv0 ee ) ) .
Proof. intros. unfold d3g . unfold d2 . simpl . apply pathscomp0rid. Defined .
Definition ezweq3g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e : paths ( g y ) z ) := ezweq2 (d1g g z y) (hfiberpr1 g z) y ( fibseq1g g z y ) ye' e .
Definition fibseq3g { Y Z : UU } (g:Y -> Z) { z : Z } ( y : Y ) ( ye' : hfiber g z ) ( e : paths ( g y ) z ) := fibseq2 (d1g g z y) (hfiberpr1 g z) y ( fibseq1g g z y ) ye' e .
(** *** Fibration sequence of h-fibers defined by a composable pair of functions (the "hf-case")
We construct a fibration sequence based on [ ( hfibersftogf f g z ye : hfiber f ( pr1 ye ) -> hfiber gf z ) ( hfibersgftog f g z : hfiber gf z -> hfiber g z ) ]. *)
Definition hfibersftogf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xe : hfiber f ( pr1 ye ) ) : hfiber ( funcomp f g ) z .
Proof . intros . split with ( pr1 xe ) . apply ( pathscomp0 ( maponpaths g ( pr2 xe ) ) ( pr2 ye ) ) . Defined .
Definition ezmaphf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xe : hfiber f ( pr1 ye ) ) : hfiber ( hfibersgftog f g z ) ye .
Proof . intros . split with ( hfibersftogf f g z ye xe ) . simpl . apply ( hfibertriangle2 g (hfiberpair g (f (pr1 xe)) (pathscomp0 (maponpaths g (pr2 xe)) ( pr2 ye ) )) ye ( pr2 xe ) ) . simpl . apply idpath . Defined .
Definition invezmaphf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xee' : hfiber ( hfibersgftog f g z ) ye ) : hfiber f ( pr1 ye ) .
Proof . intros . split with ( pr1 ( pr1 xee' ) ) . apply ( maponpaths ( hfiberpr1 _ _ ) ( pr2 xee' ) ) . Defined .
Definition ffgg { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xee' : hfiber ( hfibersgftog f g z ) ye ) : hfiber ( hfibersgftog f g z ) ye .
Proof . intros . destruct ye as [ y e ] . destruct e . unfold hfibersgftog . unfold hfibersgftog in xee' . destruct xee' as [ xe e' ] . destruct xe as [ x e ] . simpl in e' . split with ( hfiberpair ( funcomp f g ) x ( pathscomp0 ( maponpaths g (maponpaths (hfiberpr1 g (g y)) e') ) ( idpath (g y ))) ) . simpl . apply ( hfibertriangle2 _ (hfiberpair g (f x) (( pathscomp0 ( maponpaths g (maponpaths (hfiberpr1 g (g y)) e') ) ( idpath (g y ))))) ( hfiberpair g y ( idpath _ ) ) ( maponpaths ( hfiberpr1 _ _ ) e' ) ( idpath _ ) ) . Defined .
Definition homotffggid { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) ( xee' : hfiber ( hfibersgftog f g z ) ye ) : paths ( ffgg f g z ye xee' ) xee' .
Proof . intros . destruct ye as [ y e ] . destruct e . destruct xee' as [ xe e' ] . destruct e' . destruct xe as [ x e ] . destruct e . simpl . apply idpath . Defined .
Theorem isweqezmaphf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) : isweq ( ezmaphf f g z ye ) .
Proof . intros . set ( ff := ezmaphf f g z ye ) . set ( gg := invezmaphf f g z ye ) .
assert ( egf : forall xe : _ , paths ( gg ( ff xe ) ) xe ) . destruct ye as [ y e ] . destruct e . intro xe . apply ( hfibertriangle2 f ( gg ( ff xe ) ) xe ( idpath ( pr1 xe ) ) ) . destruct xe as [ x ex ] . simpl in ex . destruct ( ex ) . simpl . apply idpath .
assert ( efg : forall xee' : _ , paths ( ff ( gg xee' ) ) xee' ) . destruct ye as [ y e ] . destruct e . intro xee' .
assert ( hint : paths ( ff ( gg xee' ) ) ( ffgg f g ( g y ) ( hfiberpair g y ( idpath _ ) ) xee' ) ) . destruct xee' as [ xe e' ] . destruct xe as [ x e ] . apply idpath .
apply ( pathscomp0 hint ( homotffggid _ _ _ _ xee' ) ) .
apply ( gradth _ _ egf efg ) . Defined .
Definition ezweqhf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) : weq ( hfiber f ( pr1 ye ) ) ( hfiber ( hfibersgftog f g z ) ye ) := weqpair _ ( isweqezmaphf f g z ye ) .
Definition fibseqhf { X Y Z : UU } (f:X -> Y)(g: Y -> Z)(z:Z)(ye: hfiber g z) : fibseqstr (hfibersftogf f g z ye) (hfibersgftog f g z) ye := fibseqstrpair _ _ _ _ ( isweqezmaphf f g z ye ) .
Definition isweqinvezmaphf { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( ye : hfiber g z ) : isweq ( invezmaphf f g z ye ) := pr2 ( invweq ( ezweqhf f g z ye ) ) .
Corollary weqhfibersgwtog { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( z : Z ) : weq ( hfiber ( funcomp w g ) z ) ( hfiber g z ) .
Proof. intros . split with ( hfibersgftog w g z ) . intro ye . apply ( iscontrweqf ( ezweqhf w g z ye ) ( ( pr2 w ) ( pr1 ye ) ) ) . Defined .
(** ** Fiber-wise weak equivalences.
Theorems saying that a fiber-wise morphism between total spaces is a weak equivalence if and only if all the morphisms between the fibers are weak equivalences. *)
Definition totalfun { X : UU } ( P Q : X -> UU ) (f: forall x:X, P x -> Q x) := (fun z: total2 P => tpair Q (pr1 z) (f (pr1 z) (pr2 z))).
Theorem isweqtotaltofib { X : UU } ( P Q : X -> UU) (f: forall x:X, P x -> Q x):
isweq (totalfun _ _ f) -> forall x:X, isweq (f x).
Proof. intros X P Q f X0 x. set (totp:= total2 P). set (totq := total2 Q). set (totf:= (totalfun _ _ f)). set (pip:= fun z: totp => pr1 z). set (piq:= fun z: totq => pr1 z).
set (hfx:= hfibersgftog totf piq x). simpl in hfx.
assert (H: isweq hfx). unfold isweq. intro y.
set (int:= invezmaphf totf piq x y).
assert (X1:isweq int). apply (isweqinvezmaphf totf piq x y). destruct y as [ t e ].
assert (is1: iscontr (hfiber totf t)). apply (X0 t). apply (iscontrweqb ( weqpair int X1 ) is1).
set (ip:= ezmappr1 P x). set (iq:= ezmappr1 Q x). set (h:= fun p: P x => hfx (ip p)).
assert (is2: isweq h). apply (twooutof3c ip hfx (isweqezmappr1 P x) H). set (h':= fun p: P x => iq ((f x) p)).
assert (ee: forall p:P x, paths (h p) (h' p)). intro. apply idpath.
assert (X2:isweq h'). apply (isweqhomot h h' ee is2).
apply (twooutof3a (f x) iq X2).
apply (isweqezmappr1 Q x). Defined.
Definition weqtotaltofib { X : UU } ( P Q : X -> UU ) ( f : forall x : X , P x -> Q x ) ( is : isweq ( totalfun _ _ f ) ) ( x : X ) : weq ( P x ) ( Q x ) := weqpair _ ( isweqtotaltofib P Q f is x ) .
Theorem isweqfibtototal { X : UU } ( P Q : X -> UU) (f: forall x:X, weq ( P x ) ( Q x ) ) : isweq (totalfun _ _ f).
Proof. intros X P Q f . set (fpq:= totalfun P Q f). set (pr1p:= fun z: total2 P => pr1 z). set (pr1q:= fun z: total2 Q => pr1 z). unfold isweq. intro xq. set (x:= pr1q xq). set (xqe:= hfiberpair pr1q xq (idpath _)). set (hfpqx:= hfibersgftog fpq pr1q x).
assert (isint: iscontr (hfiber hfpqx xqe)).
assert (isint1: isweq hfpqx). set (ipx:= ezmappr1 P x). set (iqx:= ezmappr1 Q x). set (diag:= fun p:P x => (iqx ((f x) p))).
assert (is2: isweq diag). apply (twooutof3c (f x) iqx (pr2 ( f x) ) (isweqezmappr1 Q x)). apply (twooutof3b ipx hfpqx (isweqezmappr1 P x) is2). unfold isweq in isint1. apply (isint1 xqe).
set (intmap:= invezmaphf fpq pr1q x xqe). apply (iscontrweqf ( weqpair intmap (isweqinvezmaphf fpq pr1q x xqe) ) isint).
Defined.
Definition weqfibtototal { X : UU } ( P Q : X -> UU) (f: forall x:X, weq ( P x ) ( Q x ) ) := weqpair _ ( isweqfibtototal P Q f ) .
(** ** Homotopy fibers of the function [fpmap: total2 X (P f) -> total2 Y P].
Given [ X Y ] in [ UU ], [ P:Y -> UU ] and [ f: X -> Y ] we get a function [ fpmap: total2 X (P f) -> total2 Y P ]. The main theorem of this section asserts that the homotopy fiber of fpmap over [ yp:total Y P ] is naturally weakly equivalent to the homotopy fiber of [ f ] over [ pr1 yp ]. In particular, if [ f ] is a weak equivalence then so is [ fpmap ]. *)
Definition fpmap { X Y : UU } (f: X -> Y) ( P:Y-> UU) : total2 ( fun x => P ( f x ) ) -> total2 P :=
(fun z:total2 (fun x:X => P (f x)) => tpair P (f (pr1 z)) (pr2 z)).
Definition hffpmap2 { X Y : UU } (f: X -> Y) (P:Y-> UU): total2 ( fun x => P ( f x ) ) -> total2 (fun u:total2 P => hfiber f (pr1 u)).
Proof. intros X Y f P X0. set (u:= fpmap f P X0). split with u. set (x:= pr1 X0). split with x. simpl. apply idpath. Defined.
Definition hfiberfpmap { X Y : UU } (f:X -> Y)(P:Y-> UU)(yp: total2 P): hfiber (fpmap f P) yp -> hfiber f (pr1 yp).
Proof. intros X Y f P yp X0. set (int1:= hfibersgftog (hffpmap2 f P) (fun u: (total2 (fun u:total2 P => hfiber f (pr1 u))) => (pr1 u)) yp). set (phi:= invezmappr1 (fun u:total2 P => hfiber f (pr1 u)) yp). apply (phi (int1 X0)). Defined.
Lemma centralfiber { X : UU } (P:X -> UU)(x:X): isweq (fun p: P x => tpair (fun u: coconusfromt X x => P ( pr1 u)) (coconusfromtpair X (idpath x)) p).
Proof. intros. set (f:= fun p: P x => tpair (fun u: coconusfromt X x => P(pr1 u)) (coconusfromtpair X (idpath x)) p). set (g:= fun z: total2 (fun u: coconusfromt X x => P ( pr1 u)) => transportf P (pathsinv0 (pr2 (pr1 z))) (pr2 z)).
assert (efg: forall z: total2 (fun u: coconusfromt X x => P ( pr1 u)), paths (f (g z)) z). intro. destruct z as [ t x0 ]. destruct t as [t x1 ]. simpl. destruct x1. simpl. apply idpath.
assert (egf: forall p: P x , paths (g (f p)) p). intro. apply idpath.
apply (gradth f g egf efg). Defined.
Lemma isweqhff { X Y : UU } (f: X -> Y)(P:Y-> UU): isweq (hffpmap2 f P).
Proof. intros. set (int:= total2 (fun x:X => total2 (fun u: coconusfromt Y (f x) => P (pr1 u)))). set (intpair:= tpair (fun x:X => total2 (fun u: coconusfromt Y (f x) => P (pr1 u)))). set (toint:= fun z: (total2 (fun u : total2 P => hfiber f (pr1 u))) => intpair (pr1 (pr2 z)) (tpair (fun u: coconusfromt Y (f (pr1 (pr2 z))) => P (pr1 u)) (coconusfromtpair _ (pr2 (pr2 z))) (pr2 (pr1 z)))). set (fromint:= fun z: int => tpair (fun u:total2 P => hfiber f (pr1 u)) (tpair P (pr1 (pr1 (pr2 z))) (pr2 (pr2 z))) (hfiberpair f (pr1 z) (pr2 (pr1 (pr2 z))))). assert (fromto: forall u:(total2 (fun u : total2 P => hfiber f (pr1 u))), paths (fromint (toint u)) u). simpl in toint. simpl in fromint. simpl. intro u. destruct u as [ t x ]. destruct x. destruct t as [ p0 p1 ] . simpl. unfold toint. unfold fromint. simpl. apply idpath. assert (tofrom: forall u:int, paths (toint (fromint u)) u). intro. destruct u as [ t x ]. destruct x as [ t0 x ]. destruct t0. simpl in x. simpl. unfold fromint. unfold toint. simpl. apply idpath. assert (is: isweq toint). apply (gradth toint fromint fromto tofrom). clear tofrom. clear fromto. clear fromint.
set (h:= fun u: total2 (fun x:X => P (f x)) => toint ((hffpmap2 f P) u)). simpl in h.
assert (l1: forall x:X, isweq (fun p: P (f x) => tpair (fun u: coconusfromt _ (f x) => P (pr1 u)) (coconusfromtpair _ (idpath (f x))) p)). intro. apply (centralfiber P (f x)).
assert (X0:isweq h). apply (isweqfibtototal (fun x:X => P (f x)) (fun x:X => total2 (fun u: coconusfromt _ (f x) => P (pr1 u))) (fun x:X => weqpair _ ( l1 x ) ) ).
apply (twooutof3a (hffpmap2 f P) toint X0 is). Defined.
Theorem isweqhfiberfp { X Y : UU } (f:X -> Y)(P:Y-> UU)(yp: total2 P): isweq (hfiberfpmap f P yp).
Proof. intros. set (int1:= hfibersgftog (hffpmap2 f P) (fun u: (total2 (fun u:total2 P => hfiber f (pr1 u))) => (pr1 u)) yp). assert (is1: isweq int1). simpl in int1 . apply ( pr2 ( weqhfibersgwtog ( weqpair _ ( isweqhff f P ) ) (fun u : total2 (fun u : total2 P => hfiber f (pr1 u)) => pr1 u) yp ) ) . set (phi:= invezmappr1 (fun u:total2 P => hfiber f (pr1 u)) yp). assert (is2: isweq phi). apply ( pr2 ( invweq ( ezweqpr1 (fun u:total2 P => hfiber f (pr1 u)) yp ) ) ) . apply (twooutof3c int1 phi is1 is2). Defined.
Corollary isweqfpmap { X Y : UU } ( w : weq X Y )(P:Y-> UU) : isweq (fpmap w P).
Proof. intros. unfold isweq. intro y. set (h:=hfiberfpmap w P y).
assert (X1:isweq h). apply isweqhfiberfp.
assert (is: iscontr (hfiber w (pr1 y))). apply ( pr2 w ). apply (iscontrweqb ( weqpair h X1 ) is). Defined.
Definition weqfp { X Y : UU } ( w : weq X Y )(P:Y-> UU) := weqpair _ ( isweqfpmap w P ) .
(** *** Total spaces of families over a contractible base *)
Definition fromtotal2overunit ( P : unit -> UU ) ( tp : total2 P ) : P tt .
Proof . intros . destruct tp as [ t p ] . destruct t . apply p . Defined .
Definition tototal2overunit ( P : unit -> UU ) ( p : P tt ) : total2 P := tpair P tt p .
Theorem weqtotal2overunit ( P : unit -> UU ) : weq ( total2 P ) ( P tt ) .
Proof. intro . set ( f := fromtotal2overunit P ) . set ( g := tototal2overunit P ) . split with f .
assert ( egf : forall a : _ , paths ( g ( f a ) ) a ) . intro a . destruct a as [ t p ] . destruct t . apply idpath .
assert ( efg : forall a : _ , paths ( f ( g a ) ) a ) . intro a . apply idpath .
apply ( gradth _ _ egf efg ) . Defined .
(** ** The maps between total spaces of families given by a map between the bases of the families and maps between the corresponding members of the families *)
Definition bandfmap { X Y : UU }(f: X -> Y) ( P : X -> UU)(Q: Y -> UU)(fm: forall x:X, P x -> (Q (f x))): total2 P -> total2 Q:= fun xp:_ =>
match xp with
tpair _ x p => tpair Q (f x) (fm x p)
end.
Theorem isweqbandfmap { X Y : UU } (w : weq X Y ) (P:X -> UU)(Q: Y -> UU)( fw : forall x:X, weq ( P x) (Q (w x))) : isweq (bandfmap _ P Q fw).
Proof. intros. set (f1:= totalfun P _ fw). set (is1:= isweqfibtototal P (fun x:X => Q (w x)) fw ). set (f2:= fpmap w Q). set (is2:= isweqfpmap w Q ).
assert (h: forall xp: total2 P, paths (f2 (f1 xp)) (bandfmap w P Q fw xp)). intro. destruct xp. apply idpath. apply (isweqhomot _ _ h (twooutof3c f1 f2 is1 is2)). Defined.
Definition weqbandf { X Y : UU } (w : weq X Y ) (P:X -> UU)(Q: Y -> UU)( fw : forall x:X, weq ( P x) (Q (w x))) := weqpair _ ( isweqbandfmap w P Q fw ) .
(** ** Homotopy fiber squares *)
(** *** Homotopy commutative squares *)
Definition commsqstr { X X' Y Z : UU } ( g' : Z -> X' ) ( f' : X' -> Y ) ( g : Z -> X ) ( f : X -> Y ) := forall ( z : Z ) , paths ( f' ( g' z ) ) ( f ( g z ) ) .
Definition hfibersgtof' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( x : X ) ( ze : hfiber g x ) : hfiber f' ( f x ) .
Proof. intros . destruct ze as [ z e ] . split with ( g' z ) . apply ( pathscomp0 ( h z ) ( maponpaths f e ) ) . Defined .
Definition hfibersg'tof { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( x' : X' ) ( ze : hfiber g' x' ) : hfiber f ( f' x' ) .
Proof. intros . destruct ze as [ z e ] . split with ( g z ) . apply ( pathscomp0 ( pathsinv0 ( h z ) ) ( maponpaths f' e ) ) . Defined .
Definition transposcommsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) : commsqstr g' f' g f -> commsqstr g f g' f' := fun h : _ => fun z : Z => ( pathsinv0 ( h z ) ) .
(** *** Short complexes and homotopy commutative squares *)
Lemma complxstrtocommsqstr { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( h : complxstr f g z ) : commsqstr f g ( fun x : X => tt ) ( fun t : unit => z ) .
Proof. intros . assumption . Defined .
Lemma 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 .
Proof. intros . assumption . Defined .
(** *** Homotopy fiber products *)
Definition hfp {X X' Y:UU} (f:X -> Y) (f':X' -> Y):= total2 (fun xx' : dirprod X X' => paths ( f' ( pr2 xx' ) ) ( f ( pr1 xx' ) ) ) .
Definition hfpg {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : hfp f f' -> X := fun xx'e => ( pr1 ( pr1 xx'e ) ) .
Definition hfpg' {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : hfp f f' -> X' := fun xx'e => ( pr2 ( pr1 xx'e ) ) .
Definition commsqZtohfp { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) : Z -> hfp f f' := fun z : _ => tpair _ ( dirprodpair ( g z ) ( g' z ) ) ( h z ) .
Definition commsqZtohfphomot { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) : forall z : Z , paths ( hfpg _ _ ( commsqZtohfp _ _ _ _ h z ) ) ( g z ) := fun z : _ => idpath _ .
Definition commsqZtohfphomot' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) : forall z : Z , paths ( hfpg' _ _ ( commsqZtohfp _ _ _ _ h z ) ) ( g' z ) := fun z : _ => idpath _ .
Definition hfpoverX {X X' Y:UU} (f:X -> Y) (f':X' -> Y) := total2 (fun x : X => hfiber f' ( f x ) ) .
Definition hfpoverX' {X X' Y:UU} (f:X -> Y) (f':X' -> Y) := total2 (fun x' : X' => hfiber f (f' x' ) ) .
Definition weqhfptohfpoverX {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : weq ( hfp f f' ) ( hfpoverX f f' ) .
Proof. intros . apply ( weqtotal2asstor ( fun x : X => X' ) ( fun xx' : dirprod X X' => paths ( f' ( pr2 xx' ) ) ( f ( pr1 xx' ) ) ) ) . Defined .
Definition weqhfptohfpoverX' {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : weq ( hfp f f' ) ( hfpoverX' f f' ) .
Proof. intros . set ( w1 := weqfp ( weqdirprodcomm X X' ) ( fun xx' : dirprod X' X => paths ( f' ( pr1 xx' ) ) ( f ( pr2 xx' ) ) ) ) . simpl in w1 .
set ( w2 := weqfibtototal ( fun x'x : dirprod X' X => paths ( f' ( pr1 x'x ) ) ( f ( pr2 x'x ) ) ) ( fun x'x : dirprod X' X => paths ( f ( pr2 x'x ) ) ( f' ( pr1 x'x ) ) ) ( fun x'x : _ => weqpathsinv0 ( f' ( pr1 x'x ) ) ( f ( pr2 x'x ) ) ) ) . set ( w3 := weqtotal2asstor ( fun x' : X' => X ) ( fun x'x : dirprod X' X => paths ( f ( pr2 x'x ) ) ( f' ( pr1 x'x ) ) ) ) . simpl in w3 . apply ( weqcomp ( weqcomp w1 w2 ) w3 ) . Defined .
Lemma weqhfpcomm { X X' Y : UU } ( f : X -> Y ) ( f' : X' -> Y ) : weq ( hfp f f' ) ( hfp f' f ) .
Proof . intros . set ( w1 := weqfp ( weqdirprodcomm X X' ) ( fun xx' : dirprod X' X => paths ( f' ( pr1 xx' ) ) ( f ( pr2 xx' ) ) ) ) . simpl in w1 . set ( w2 := weqfibtototal ( fun x'x : dirprod X' X => paths ( f' ( pr1 x'x ) ) ( f ( pr2 x'x ) ) ) ( fun x'x : dirprod X' X => paths ( f ( pr2 x'x ) ) ( f' ( pr1 x'x ) ) ) ( fun x'x : _ => weqpathsinv0 ( f' ( pr1 x'x ) ) ( f ( pr2 x'x ) ) ) ) . apply ( weqcomp w1 w2 ) . Defined .
Definition commhfp {X X' Y:UU} (f:X -> Y) (f':X' -> Y) : commsqstr ( hfpg' f f' ) f' ( hfpg f f' ) f := fun xx'e : hfp f f' => pr2 xx'e .
(** *** Homotopy fiber products and homotopy fibers *)
Definition hfibertohfp { X Y : UU } ( f : X -> Y ) ( y : Y ) ( xe : hfiber f y ) : hfp ( fun t : unit => y ) f := tpair ( fun tx : dirprod unit X => paths ( f ( pr2 tx ) ) y ) ( dirprodpair tt ( pr1 xe ) ) ( pr2 xe ) .
Definition hfptohfiber { X Y : UU } ( f : X -> Y ) ( y : Y ) ( hf : hfp ( fun t : unit => y ) f ) : hfiber f y := hfiberpair f ( pr2 ( pr1 hf ) ) ( pr2 hf ) .
Lemma weqhfibertohfp { X Y : UU } ( f : X -> Y ) ( y : Y ) : weq ( hfiber f y ) ( hfp ( fun t : unit => y ) f ) .
Proof . intros . set ( ff := hfibertohfp f y ) . set ( gg := hfptohfiber f y ) . split with ff .
assert ( egf : forall xe : _ , paths ( gg ( ff xe ) ) xe ) . intro . destruct xe . apply idpath .
assert ( efg : forall hf : _ , paths ( ff ( gg hf ) ) hf ) . intro . destruct hf as [ tx e ] . destruct tx as [ t x ] . destruct t . apply idpath .
apply ( gradth _ _ egf efg ) . Defined .
(** *** Homotopy fiber squares *)
Definition ishfsq { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) := isweq ( commsqZtohfp f f' g g' h ) .
Definition hfsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) := total2 ( fun h : commsqstr g' f' g f => isweq ( commsqZtohfp f f' g g' h ) ) .
Definition hfsqstrpair { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) := tpair ( fun h : commsqstr g' f' g f => isweq ( commsqZtohfp f f' g g' h ) ) .
Definition hfsqstrtocommsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) : hfsqstr f f' g g' -> commsqstr g' f' g f := @pr1 _ ( fun h : commsqstr g' f' g f => isweq ( commsqZtohfp f f' g g' h ) ) .
Coercion hfsqstrtocommsqstr : hfsqstr >-> commsqstr .
Definition weqZtohfp { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) : weq Z ( hfp f f' ) := weqpair _ ( pr2 hf ) .
Lemma isweqhfibersgtof' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) ( x : X ) : isweq ( hfibersgtof' f f' g g' hf x ) .
Proof. intros . set ( is := pr2 hf ) . set ( h := pr1 hf ) .
set ( a := weqtococonusf g ) . set ( c := weqpair _ is ) . set ( d := weqhfptohfpoverX f f' ) . set ( b0 := totalfun _ _ ( hfibersgtof' f f' g g' h ) ) .
assert ( h1 : forall z : Z , paths ( d ( c z ) ) ( b0 ( a z ) ) ) . intro . simpl . unfold b0 . unfold a . unfold weqtococonusf . unfold tococonusf . simpl . unfold totalfun . simpl . assert ( e : paths ( h z ) ( pathscomp0 (h z) (idpath (f (g z))) ) ) . apply ( pathsinv0 ( pathscomp0rid _ ) ) . destruct e . apply idpath .
assert ( is1 : isweq ( fun z : _ => b0 ( a z ) ) ) . apply ( isweqhomot _ _ h1 ) . apply ( twooutof3c _ _ ( pr2 c ) ( pr2 d ) ) .
assert ( is2 : isweq b0 ) . apply ( twooutof3b _ _ ( pr2 a ) is1 ) . apply ( isweqtotaltofib _ _ _ is2 x ) . Defined .
Definition weqhfibersgtof' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) ( x : X ) := weqpair _ ( isweqhfibersgtof' _ _ _ _ hf x ) .
Lemma ishfsqweqhfibersgtof' { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( is : forall x : X , isweq ( hfibersgtof' f f' g g' h x ) ) : hfsqstr f f' g g' .
Proof . intros . split with h .
set ( a := weqtococonusf g ) . set ( c0 := commsqZtohfp f f' g g' h ) . set ( d := weqhfptohfpoverX f f' ) . set ( b := weqfibtototal _ _ ( fun x : X => weqpair _ ( is x ) ) ) .
assert ( h1 : forall z : Z , paths ( d ( c0 z ) ) ( b ( a z ) ) ) . intro . simpl . unfold b . unfold a . unfold weqtococonusf . unfold tococonusf . simpl . unfold totalfun . simpl . assert ( e : paths ( h z ) ( pathscomp0 (h z) (idpath (f (g z))) ) ) . apply ( pathsinv0 ( pathscomp0rid _ ) ) . destruct e . apply idpath .
assert ( is1 : isweq ( fun z : _ => d ( c0 z ) ) ) . apply ( isweqhomot _ _ ( fun z : Z => ( pathsinv0 ( h1 z ) ) ) ) . apply ( twooutof3c _ _ ( pr2 a ) ( pr2 b ) ) .
apply ( twooutof3a _ _ is1 ( pr2 d ) ) . Defined .
Lemma isweqhfibersg'tof { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) ( x' : X' ) : isweq ( hfibersg'tof f f' g g' hf x' ) .
Proof. intros . set ( is := pr2 hf ) . set ( h := pr1 hf ) .
set ( a' := weqtococonusf g' ) . set ( c' := weqpair _ is ) . set ( d' := weqhfptohfpoverX' f f' ) . set ( b0' := totalfun _ _ ( hfibersg'tof f f' g g' h ) ) .
assert ( h1 : forall z : Z , paths ( d' ( c' z ) ) ( b0' ( a' z ) ) ) . intro . unfold b0' . unfold a' . unfold weqtococonusf . unfold tococonusf . unfold totalfun . simpl . assert ( e : paths ( pathsinv0 ( h z ) ) ( pathscomp0 ( pathsinv0 (h z) ) (idpath (f' (g' z))) ) ) . apply ( pathsinv0 ( pathscomp0rid _ ) ) . destruct e . apply idpath .
assert ( is1 : isweq ( fun z : _ => b0' ( a' z ) ) ) . apply ( isweqhomot _ _ h1 ) . apply ( twooutof3c _ _ ( pr2 c' ) ( pr2 d' ) ) .
assert ( is2 : isweq b0' ) . apply ( twooutof3b _ _ ( pr2 a' ) is1 ) . apply ( isweqtotaltofib _ _ _ is2 x' ) . Defined .
Definition weqhfibersg'tof { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) ( x' : X' ) := weqpair _ ( isweqhfibersg'tof _ _ _ _ hf x' ) .
Lemma ishfsqweqhfibersg'tof { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( is : forall x' : X' , isweq ( hfibersg'tof f f' g g' h x' ) ) : hfsqstr f f' g g' .
Proof . intros . split with h .
set ( a' := weqtococonusf g' ) . set ( c0' := commsqZtohfp f f' g g' h ) . set ( d' := weqhfptohfpoverX' f f' ) . set ( b' := weqfibtototal _ _ ( fun x' : X' => weqpair _ ( is x' ) ) ) .
assert ( h1 : forall z : Z , paths ( d' ( c0' z ) ) ( b' ( a' z ) ) ) . intro . simpl . unfold b' . unfold a' . unfold weqtococonusf . unfold tococonusf . unfold totalfun . simpl . assert ( e : paths ( pathsinv0 ( h z ) ) ( pathscomp0 ( pathsinv0 (h z) ) (idpath (f' (g' z))) ) ) . apply ( pathsinv0 ( pathscomp0rid _ ) ) . destruct e . apply idpath .
assert ( is1 : isweq ( fun z : _ => d' ( c0' z ) ) ) . apply ( isweqhomot _ _ ( fun z : Z => ( pathsinv0 ( h1 z ) ) ) ) . apply ( twooutof3c _ _ ( pr2 a' ) ( pr2 b' ) ) .
apply ( twooutof3a _ _ is1 ( pr2 d' ) ) . Defined .
Theorem transposhfpsqstr { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( hf : hfsqstr f f' g g' ) : hfsqstr f' f g' g .
Proof . intros . set ( is := pr2 hf ) . set ( h := pr1 hf ) . set ( th := transposcommsqstr f f' g g' h ) . split with th .
set ( w1 := weqhfpcomm f f' ) . assert ( h1 : forall z : Z , paths ( w1 ( commsqZtohfp f f' g g' h z ) ) ( commsqZtohfp f' f g' g th z ) ) . intro . unfold commsqZtohfp . simpl . unfold fpmap . unfold totalfun . simpl . apply idpath . apply ( isweqhomot _ _ h1 ) . apply ( twooutof3c _ _ is ( pr2 w1 ) ) . Defined .
(** *** Fiber sequences and homotopy fiber squares *)
Theorem fibseqstrtohfsqstr { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( hf : fibseqstr f g z ) : hfsqstr ( fun t : unit => z ) g ( fun x : X => tt ) f .
Proof . intros . split with ( pr1 hf ) . set ( ff := ezweq f g z hf ) . set ( ggff := commsqZtohfp ( fun t : unit => z ) g ( fun x : X => tt ) f ( pr1 hf ) ) . set ( gg := weqhfibertohfp g z ) .
apply ( pr2 ( weqcomp ff gg ) ) . Defined .
Theorem hfsqstrtofibseqstr { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( hf : hfsqstr ( fun t : unit => z ) g ( fun x : X => tt ) f ) : fibseqstr f g z .
Proof . intros . split with ( pr1 hf ) . set ( ff := ezmap f g z ( pr1 hf ) ) . set ( ggff := weqZtohfp ( fun t : unit => z ) g ( fun x : X => tt ) f hf ) . set ( gg := weqhfibertohfp g z ) .
apply ( twooutof3a ff gg ( pr2 ggff ) ( pr2 gg ) ) . Defined .
(** ** Basics about h-levels *)
(** *** h-levels of types *)
Fixpoint isofhlevel (n:nat) (X:UU): UU:=
match n with
O => iscontr X |
S m => forall x:X, forall x':X, (isofhlevel m (paths x x'))
end.
Theorem hlevelretract (n:nat) { X Y : UU } ( p : X -> Y ) ( s : Y -> X ) ( eps : forall y : Y , paths ( p ( s y ) ) y ) : isofhlevel n X -> isofhlevel n Y .
Proof. intro. induction n as [ | n IHn ]. intros X Y p s eps X0. unfold isofhlevel. apply ( iscontrretract p s eps X0).
unfold isofhlevel. intros X Y p s eps X0 x x'. unfold isofhlevel in X0. assert (is: isofhlevel n (paths (s x) (s x'))). apply X0. set (s':= @maponpaths _ _ s x x'). set (p':= pathssec2 s p eps x x'). set (eps':= @pathssec3 _ _ s p eps x x' ). simpl. apply (IHn _ _ p' s' eps' is). Defined.
Corollary isofhlevelweqf (n:nat) { X Y : UU } ( f : weq X Y ) : isofhlevel n X -> isofhlevel n Y .
Proof. intros n X Y f X0. apply (hlevelretract n f (invmap f ) (homotweqinvweq f )). assumption. Defined.
Corollary isofhlevelweqb (n:nat) { X Y : UU } ( f : weq X Y ) : isofhlevel n Y -> isofhlevel n X .
Proof. intros n X Y f X0 . apply (hlevelretract n (invmap f ) f (homotinvweqweq f )). assumption. Defined.
Lemma isofhlevelsn ( n : nat ) { X : UU } ( f : X -> isofhlevel ( S n ) X ) : isofhlevel ( S n ) X.
Proof. intros . simpl . intros x x' . apply ( f x x x'). Defined.
Lemma isofhlevelssn (n:nat) { X : UU } ( is : forall x:X, isofhlevel (S n) (paths x x)) : isofhlevel (S (S n)) X.
Proof. intros . simpl. intros x x'. change ( forall ( x0 x'0 : paths x x' ), isofhlevel n ( paths x0 x'0 ) ) with ( isofhlevel (S n) (paths x x') ).
assert ( X1 : paths x x' -> isofhlevel (S n) (paths x x') ) . intro X2. destruct X2. apply ( is x ). apply ( isofhlevelsn n X1 ). Defined.
(** *** h-levels of functions *)
Definition isofhlevelf ( n : nat ) { X Y : UU } ( f : X -> Y ) : UU := forall y:Y, isofhlevel n (hfiber f y).
Theorem isofhlevelfhomot ( n : nat ) { X Y : UU }(f f':X -> Y)(h: forall x:X, paths (f x) (f' x)): isofhlevelf n f -> isofhlevelf n f'.
Proof. intros n X Y f f' h X0. unfold isofhlevelf. intro y . apply ( isofhlevelweqf n ( weqhfibershomot f f' h y ) ( X0 y )) . Defined .
Theorem isofhlevelfpmap ( n : nat ) { X Y : UU } ( f : X -> Y ) ( Q : Y -> UU ) : isofhlevelf n f -> isofhlevelf n ( fpmap f Q ) .
Proof. intros n X Y f Q X0. unfold isofhlevelf. unfold isofhlevelf in X0. intro y . set (yy:= pr1 y). set ( g := hfiberfpmap f Q y). set (is:= isweqhfiberfp f Q y). set (isy:= X0 yy). apply (isofhlevelweqb n ( weqpair g is ) isy). Defined.
Theorem isofhlevelfffromZ ( n : nat ) { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( isz : isofhlevel ( S n ) Z ) : isofhlevelf n f .
Proof. intros . intro y . assert ( w : weq ( hfiber f y ) ( paths ( g y ) z ) ) . apply ( invweq ( ezweq1 f g z fs y ) ) . apply ( isofhlevelweqb n w ( isz (g y ) z ) ) . Defined.
Theorem isofhlevelXfromg ( n : nat ) { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) : isofhlevelf n g -> isofhlevel n X .
Proof. intros n X Y Z f g z fs isf . assert ( w : weq X ( hfiber g z ) ) . apply ( weqpair _ ( pr2 fs ) ) . apply ( isofhlevelweqb n w ( isf z ) ) . Defined .
Theorem isofhlevelffromXY ( n : nat ) { X Y : UU } ( f : X -> Y ) : isofhlevel n X -> isofhlevel (S n) Y -> isofhlevelf n f.
Proof. intro. induction n as [ | n IHn ] . intros X Y f X0 X1.
assert (is1: isofhlevel O Y). split with ( f ( pr1 X0 ) ) . intro t . unfold isofhlevel in X1 . set ( is := X1 t ( f ( pr1 X0 ) ) ) . apply ( pr1 is ).
apply (isweqcontrcontr f X0 is1).
intros X Y f X0 X1. unfold isofhlevelf. simpl.
assert (is1: forall x' x:X, isofhlevel n (paths x' x)). simpl in X0. assumption.
assert (is2: forall y' y:Y, isofhlevel (S n) (paths y' y)). simpl in X1. simpl. assumption.
assert (is3: forall (y:Y)(x:X)(xe': hfiber f y), isofhlevelf n (d2g f x xe')). intros. apply (IHn _ _ (d2g f x xe') (is1 (pr1 xe') x) (is2 (f x) y)).
assert (is4: forall (y:Y)(x:X)(xe': hfiber f y)(e: paths (f x) y), isofhlevel n (paths (hfiberpair f x e) xe')). intros.
apply (isofhlevelweqb n ( ezweq3g f x xe' e) (is3 y x xe' e)).
intros y xe xe' . destruct xe as [ t x ]. apply (is4 y t xe' x). Defined.
Theorem isofhlevelXfromfY ( n : nat ) { X Y : UU } ( f : X -> Y ) : isofhlevelf n f -> isofhlevel n Y -> isofhlevel n X.
Proof. intro. induction n as [ | n IHn ] . intros X Y f X0 X1. apply (iscontrweqb ( weqpair f X0 ) X1). intros X Y f X0 X1. simpl.
assert (is1: forall (y:Y)(xe xe': hfiber f y), isofhlevel n (paths xe xe')). intros. apply (X0 y).
assert (is2: forall (y:Y)(x:X)(xe': hfiber f y), isofhlevelf n (d2g f x xe')). intros. unfold isofhlevel. intro y0.
apply (isofhlevelweqf n ( ezweq3g f x xe' y0 ) (is1 y (hfiberpair f x y0) xe')).
assert (is3: forall (y' y : Y), isofhlevel n (paths y' y)). simpl in X1. assumption.
intros x' x .
set (y:= f x'). set (e':= idpath y). set (xe':= hfiberpair f x' e').
apply (IHn _ _ (d2g f x xe') (is2 y x xe') (is3 (f x) y)). Defined.
Theorem isofhlevelffib ( n : nat ) { X : UU } ( P : X -> UU ) ( x : X ) ( is : forall x':X, isofhlevel n (paths x' x) ) : isofhlevelf n ( tpair P x ) .
Proof . intros . unfold isofhlevelf . intro xp . apply (isofhlevelweqf n ( ezweq1pr1 P x xp) ( is ( pr1 xp ) ) ) . Defined .
Theorem isofhlevelfhfiberpr1y ( n : nat ) { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : forall y':Y, isofhlevel n (paths y' y) ) : isofhlevelf n ( hfiberpr1 f y).
Proof. intros . unfold isofhlevelf. intro x. apply (isofhlevelweqf n ( ezweq1g f y x ) ( is ( f x ) ) ) . Defined.
Theorem isofhlevelfsnfib (n:nat) { X : UU } (P:X -> UU)(x:X) ( is : isofhlevel (S n) (paths x x) ) : isofhlevelf (S n) ( tpair P x ).
Proof. intros . unfold isofhlevelf. intro xp. apply (isofhlevelweqf (S n) ( ezweq1pr1 P x xp ) ). apply isofhlevelsn . intro X1 . destruct X1 . assumption . Defined .
Theorem isofhlevelfsnhfiberpr1 ( n : nat ) { X Y : UU } (f : X -> Y ) ( y : Y ) ( is : isofhlevel (S n) (paths y y) ) : isofhlevelf (S n) (hfiberpr1 f y).
Proof. intros . unfold isofhlevelf. intro x. apply (isofhlevelweqf (S n) ( ezweq1g f y x ) ). apply isofhlevelsn. intro X1. destruct X1. assumption. Defined .
Corollary isofhlevelfhfiberpr1 ( n : nat ) { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : isofhlevel (S n) Y ) : isofhlevelf n ( hfiberpr1 f y ) .
Proof. intros. apply isofhlevelfhfiberpr1y. intro y' . apply (is y' y). Defined.
Theorem isofhlevelff ( n : nat ) { X Y Z : UU } (f : X -> Y ) ( g : Y -> Z ) : isofhlevelf n (fun x : X => g ( f x) ) -> isofhlevelf (S n) g -> isofhlevelf n f.
Proof. intros n X Y Z f g X0 X1. unfold isofhlevelf. intro y . set (ye:= hfiberpair g y (idpath (g y))).
apply (isofhlevelweqb n ( ezweqhf f g (g y) ye ) (isofhlevelffromXY n _ (X0 (g y)) (X1 (g y)) ye)). Defined.
Theorem isofhlevelfgf ( n : nat ) { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) : isofhlevelf n f -> isofhlevelf n g -> isofhlevelf n (fun x:X => g(f x)).
Proof. intros n X Y Z f g X0 X1. unfold isofhlevelf. intro z.
assert (is1: isofhlevelf n (hfibersgftog f g z)). unfold isofhlevelf. intro ye. apply (isofhlevelweqf n ( ezweqhf f g z ye ) (X0 (pr1 ye))).
assert (is2: isofhlevel n (hfiber g z)). apply (X1 z).
apply (isofhlevelXfromfY n _ is1 is2). Defined.
Theorem isofhlevelfgwtog (n:nat ) { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( is : isofhlevelf n (fun x : X => g ( w x ) ) ) : isofhlevelf n g .
Proof. intros . intro z . assert ( is' : isweq ( hfibersgftog w g z ) ) . intro ye . apply ( iscontrweqf ( ezweqhf w g z ye ) ( pr2 w ( pr1 ye ) ) ) . apply ( isofhlevelweqf _ ( weqpair _ is' ) ( is _ ) ) . Defined .
Theorem isofhlevelfgtogw (n:nat ) { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( is : isofhlevelf n g ) : isofhlevelf n (fun x : X => g ( w x ) ) .
Proof. intros . intro z . assert ( is' : isweq ( hfibersgftog w g z ) ) . intro ye . apply ( iscontrweqf ( ezweqhf w g z ye ) ( pr2 w ( pr1 ye ) ) ) . apply ( isofhlevelweqb _ ( weqpair _ is' ) ( is _ ) ) . Defined .
Corollary isofhlevelfhomot2 (n:nat) { X X' Y : UU } (f:X -> Y)(f':X' -> Y)(w : weq X X' )(h:forall x:X, paths (f x) (f' (w x))) : isofhlevelf n f -> isofhlevelf n f'.
Proof. intros n X X' Y f f' w h X0. assert (X1: isofhlevelf n (fun x:X => f' (w x))). apply (isofhlevelfhomot n _ _ h X0).
apply (isofhlevelfgwtog n w f' X1). Defined.
Theorem isofhlevelfonpaths (n:nat) { X Y : UU }(f:X -> Y)(x x':X): isofhlevelf (S n) f -> isofhlevelf n (@maponpaths _ _ f x x').
Proof. intros n X Y f x x' X0.
set (y:= f x'). set (xe':= hfiberpair f x' (idpath _ )).
assert (is1: isofhlevelf n (d2g f x xe')). unfold isofhlevelf. intro y0 . apply (isofhlevelweqf n ( ezweq3g f x xe' y0 ) (X0 y (hfiberpair f x y0) xe')).
assert (h: forall ee:paths x' x, paths (d2g f x xe' ee) (maponpaths f (pathsinv0 ee))). intro.
assert (e0: paths (pathscomp0 (maponpaths f (pathsinv0 ee)) (idpath _ )) (maponpaths f (pathsinv0 ee)) ). destruct ee. simpl. apply idpath. apply (e0). apply (isofhlevelfhomot2 n _ _ ( weqpair (@pathsinv0 _ x' x ) (isweqpathsinv0 _ _ ) ) h is1) . Defined.
Theorem isofhlevelfsn (n:nat) { X Y : UU } (f:X -> Y): (forall x x':X, isofhlevelf n (@maponpaths _ _ f x x')) -> isofhlevelf (S n) f.
Proof. intros n X Y f X0. unfold isofhlevelf. intro y . simpl. intros x x' . destruct x as [ x e ]. destruct x' as [ x' e' ]. destruct e' . set (xe':= hfiberpair f x' ( idpath _ ) ). set (xe:= hfiberpair f x e). set (d3:= d2g f x xe'). simpl in d3.
assert (is1: isofhlevelf n (d2g f x xe')).
assert (h: forall ee: paths x' x, paths (maponpaths f (pathsinv0 ee)) (d2g f x xe' ee)). intro. unfold d2g. simpl . apply ( pathsinv0 ( pathscomp0rid _ ) ) .
assert (is2: isofhlevelf n (fun ee: paths x' x => maponpaths f (pathsinv0 ee))). apply (isofhlevelfgtogw n ( weqpair _ (isweqpathsinv0 _ _ ) ) (@maponpaths _ _ f x x') (X0 x x')).
apply (isofhlevelfhomot n _ _ h is2).
apply (isofhlevelweqb n ( ezweq3g f x xe' e ) (is1 e)). Defined.
Theorem isofhlevelfssn (n:nat) { X Y : UU } (f:X -> Y): (forall x:X, isofhlevelf (S n) (@maponpaths _ _ f x x)) -> isofhlevelf (S (S n)) f.
Proof. intros n X Y f X0. unfold isofhlevelf. intro y .
assert (forall xe0: hfiber f y, isofhlevel (S n) (paths xe0 xe0)). intro. destruct xe0 as [ x e ]. destruct e . set (e':= idpath ( f x ) ). set (xe':= hfiberpair f x e'). set (xe:= hfiberpair f x e' ). set (d3:= d2g f x xe'). simpl in d3.
assert (is1: isofhlevelf (S n) (d2g f x xe')).
assert (h: forall ee: paths x x, paths (maponpaths f (pathsinv0 ee)) (d2g f x xe' ee)). intro. unfold d2g . simpl . apply ( pathsinv0 ( pathscomp0rid _ ) ) .
assert (is2: isofhlevelf (S n) (fun ee: paths x x => maponpaths f (pathsinv0 ee))). apply (isofhlevelfgtogw ( S n ) ( weqpair _ (isweqpathsinv0 _ _ ) ) (@maponpaths _ _ f x x) ( X0 x )) .
apply (isofhlevelfhomot (S n) _ _ h is2).
apply (isofhlevelweqb (S n) ( ezweq3g f x xe' e' ) (is1 e')).
apply (isofhlevelssn). assumption. Defined.
(** ** h -levels of [ pr1 ], fiber inclusions, fibers, total spaces and bases of fibrations *)
(** *** h-levelf of [ pr1 ] *)
Theorem isofhlevelfpr1 (n:nat) { X : UU } (P:X -> UU)(is: forall x:X, isofhlevel n (P x)) : isofhlevelf n (@pr1 X P).
Proof. intros. unfold isofhlevelf. intro x . apply (isofhlevelweqf n ( ezweqpr1 _ x) (is x)). Defined.
Lemma isweqpr1 { Z : UU } ( P : Z -> UU ) ( is1 : forall z : Z, iscontr ( P z ) ) : isweq ( @pr1 Z P ) .
Proof. intros. unfold isweq. intro y. set (isy:= is1 y). apply (iscontrweqf ( ezweqpr1 P y)) . assumption. Defined.
Definition weqpr1 { Z : UU } ( P : Z -> UU ) ( is : forall z : Z , iscontr ( P z ) ) : weq ( total2 P ) Z := weqpair _ ( isweqpr1 P is ) .
(** *** h-level of the total space [ total2 ] *)
Theorem isofhleveltotal2 ( n : nat ) { X : UU } ( P : X -> UU ) ( is1 : isofhlevel n X )( is2 : forall x:X, isofhlevel n (P x) ) : isofhlevel n (total2 P).
Proof. intros. apply (isofhlevelXfromfY n (@pr1 _ _ )). apply isofhlevelfpr1. assumption. assumption. Defined.
Corollary isofhleveldirprod ( n : nat ) ( X Y : UU ) ( is1 : isofhlevel n X ) ( is2 : isofhlevel n Y ) : isofhlevel n (dirprod X Y).
Proof. intros. apply isofhleveltotal2. assumption. intro. assumption. Defined.
(** ** Propositions, inclusions and sets *)
(** *** Basics about types of h-level 1 - "propositions" *)
Definition isaprop := isofhlevel (S O) .
Notation isapropunit := iscontrpathsinunit .
Notation isapropdirprod := ( isofhleveldirprod 1 ) .
Lemma isapropifcontr { X : UU } ( is : iscontr X ) : isaprop X .
Proof. intros . set (f:= fun x:X => tt). assert (isw : isweq f). apply isweqcontrtounit. assumption. apply (isofhlevelweqb (S O) ( weqpair f isw ) ). intros x x' . apply iscontrpathsinunit. Defined.
Coercion isapropifcontr : iscontr >-> isaprop .
Theorem hlevelntosn ( n : nat ) ( T : UU ) ( is : isofhlevel n T ) : isofhlevel (S n) T.
Proof. intro. induction n as [ | n IHn ] . intro. apply isapropifcontr. intro. intro X. change (forall t1 t2:T, isofhlevel (S n) (paths t1 t2)). intros t1 t2 . change (forall t1 t2 : T, isofhlevel n (paths t1 t2)) in X. set (XX := X t1 t2). apply (IHn _ XX). Defined.
Corollary isofhlevelcontr (n:nat) { X : UU } ( is : iscontr X ) : isofhlevel n X.
Proof. intro. induction n as [ | n IHn ] . intros X X0 . assumption.
intros X X0. simpl. intros x x' . assert (is: iscontr (paths x x')). apply (isapropifcontr X0 x x'). apply (IHn _ is). Defined.
Lemma isofhlevelfweq ( n : nat ) { X Y : UU } ( f : weq X Y ) : isofhlevelf n f .
Proof. intros n X Y f . unfold isofhlevelf. intro y . apply ( isofhlevelcontr n ). apply ( pr2 f ). Defined.
Corollary isweqfinfibseq { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( z : Z ) ( fs : fibseqstr f g z ) ( isz : iscontr Z ) : isweq f .
Proof. intros . apply ( isofhlevelfffromZ 0 f g z fs ( isapropifcontr isz ) ) . Defined .
Corollary weqhfibertocontr { X Y : UU } ( f : X -> Y ) ( y : Y ) ( is : iscontr Y ) : weq ( hfiber f y ) X .
Proof. intros . split with ( hfiberpr1 f y ) . apply ( isofhlevelfhfiberpr1 0 f y ( hlevelntosn 0 _ is ) ) . Defined.
Corollary weqhfibertounit ( X : UU ) : weq ( hfiber ( fun x : X => tt ) tt ) X .
Proof. intro . apply ( weqhfibertocontr _ tt iscontrunit ) . Defined.
Corollary isofhleveltofun ( n : nat ) ( X : UU ) : isofhlevel n X -> isofhlevelf n ( fun x : X => tt ) .
Proof. intros n X is . intro t . destruct t . apply ( isofhlevelweqb n ( weqhfibertounit X ) is ) . Defined .
Corollary isofhlevelfromfun ( n : nat ) ( X : UU ) : isofhlevelf n ( fun x : X => tt ) -> isofhlevel n X .
Proof. intros n X is . apply ( isofhlevelweqf n ( weqhfibertounit X ) ( is tt ) ) . Defined .
Lemma isofhlevelsnprop (n:nat) { X : UU } ( is : isaprop X ) : isofhlevel (S n) X.
Proof. intros n X X0. simpl. unfold isaprop in X0. simpl in X0. intros x x' . apply isofhlevelcontr. apply (X0 x x'). Defined.
Lemma iscontraprop1 { X : UU } ( is : isaprop X ) ( x : X ) : iscontr X .
Proof. intros . unfold iscontr. split with x . intro t . unfold isofhlevel in is . set (is' := is t x ). apply ( pr1 is' ).
Defined.
Lemma iscontraprop1inv { X : UU } ( f : X -> iscontr X ) : isaprop X .
Proof. intros X X0. assert ( H : X -> isofhlevel (S O) X). intro X1. apply (hlevelntosn O _ ( X0 X1 ) ) . apply ( isofhlevelsn O H ) . Defined.
Lemma proofirrelevance ( X : UU ) ( is : isaprop X ) : forall x x' : X , paths x x' .
Proof. intros . unfold isaprop in is . unfold isofhlevel in is . apply ( pr1 ( is x x' ) ). Defined.
Lemma invproofirrelevance ( X : UU ) ( ee : forall x x' : X , paths x x' ) : isaprop X.
Proof. intros . unfold isaprop. unfold isofhlevel . intro x .
assert ( is1 : iscontr X ). split with x. intro t . apply ( ee t x). assert ( is2 : isaprop X). apply isapropifcontr. assumption.
unfold isaprop in is2. unfold isofhlevel in is2. apply (is2 x). Defined.
Lemma isweqimplimpl { X Y : UU } ( f : X -> Y ) ( g : Y -> X ) ( isx : isaprop X ) ( isy : isaprop Y ) : isweq f.
Proof. intros.
assert (isx0: forall x:X, paths (g (f x)) x). intro. apply proofirrelevance . apply isx .
assert (isy0 : forall y : Y, paths (f (g y)) y). intro. apply proofirrelevance . apply isy .
apply (gradth f g isx0 isy0). Defined.
Definition weqimplimpl { X Y : UU } ( f : X -> Y ) ( g : Y -> X ) ( isx : isaprop X ) ( isy : isaprop Y ) := weqpair _ ( isweqimplimpl f g isx isy ) .
Theorem isapropempty: isaprop empty.
Proof. unfold isaprop. unfold isofhlevel. intros x x' . destruct x. Defined.
Theorem isapropifnegtrue { X : UU } ( a : X -> empty ) : isaprop X .
Proof . intros . set ( w := weqpair _ ( isweqtoempty a ) ) . apply ( isofhlevelweqb 1 w isapropempty ) . Defined .
(** *** Functional extensionality for functions to the empty type *)
Axiom funextempty : forall ( X : UU ) ( f g : X -> empty ) , paths f g .
(** *** More results on propositions *)
Theorem isapropneg (X:UU): isaprop (X -> empty).
Proof. intro. apply invproofirrelevance . intros x x' . apply ( funextempty X x x' ) . Defined .
(** See also [ isapropneg2 ] *)
Corollary isapropdneg (X:UU): isaprop (dneg X).
Proof. intro. apply (isapropneg (neg X)). Defined.
Definition isaninvprop (X:UU) := isweq (todneg X).
Definition invimpl (X:UU) (is: isaninvprop X) : (dneg X) -> X:= invmap ( weqpair (todneg X) is ) .
Lemma isapropaninvprop (X:UU): isaninvprop X -> isaprop X.
Proof. intros X X0.
apply (isofhlevelweqb (S O) ( weqpair (todneg X) X0 ) (isapropdneg X)). Defined.
Theorem isaninvpropneg (X:UU): isaninvprop (neg X).
Proof. intros.
set (f:= todneg (neg X)). set (g:= negf (todneg X)). set (is1:= isapropneg X). set (is2:= isapropneg (dneg X)). apply (isweqimplimpl f g is1 is2). Defined.
Theorem isapropdec (X:UU): (isaprop X) -> (isaprop (coprod X (X-> empty))).
Proof. intros X X0.
assert (X1: forall (x x': X), paths x x'). apply (proofirrelevance _ X0).
assert (X2: forall (x x': coprod X (X -> empty)), paths x x'). intros.
destruct x as [ x0 | y0 ]. destruct x' as [ x | y ]. apply (maponpaths (fun x:X => ii1 x) (X1 x0 x)).
apply (fromempty (y x0)).
destruct x' as [ x | y ]. apply (fromempty (y0 x)).
assert (e: paths y0 y). apply (proofirrelevance _ (isapropneg X) y0 y). apply (maponpaths (fun f: X -> empty => ii2 f) e).
apply (invproofirrelevance _ X2). Defined.
(** *** Inclusions - functions of h-level 1 *)
Definition isincl { X Y : UU } (f : X -> Y ) := isofhlevelf 1 f .
Definition incl ( X Y : UU ) := total2 ( fun f : X -> Y => isincl f ) .
Definition inclpair { X Y : UU } ( f : X -> Y ) ( is : isincl f ) : incl X Y := tpair _ f is .
Definition pr1incl ( X Y : UU ) : incl X Y -> ( X -> Y ) := @pr1 _ _ .
Coercion pr1incl : incl >-> Funclass .
Lemma isinclweq ( X Y : UU ) ( f : X -> Y ) : isweq f -> isincl f .
Proof . intros X Y f is . apply ( isofhlevelfweq 1 ( weqpair _ is ) ) . Defined .
Coercion isinclweq : isweq >-> isincl .
Lemma isofhlevelfsnincl (n:nat) { X Y : UU } (f:X -> Y)(is: isincl f): isofhlevelf (S n) f.
Proof. intros. unfold isofhlevelf. intro y . apply isofhlevelsnprop. apply (is y). Defined.
Definition weqtoincl ( X Y : UU ) : weq X Y -> incl X Y := fun w => inclpair ( pr1 w ) ( pr2 w ) .
Coercion weqtoincl : weq >-> incl .
Lemma isinclcomp { X Y Z : UU } ( f : incl X Y ) ( g : incl Y Z ) : isincl ( funcomp ( pr1 f ) ( pr1 g ) ) .
Proof . intros . apply ( isofhlevelfgf 1 f g ( pr2 f ) ( pr2 g ) ) . Defined .
Definition inclcomp { X Y Z : UU } ( f : incl X Y ) ( g : incl Y Z ) : incl X Z := inclpair ( funcomp ( pr1 f ) ( pr1 g ) ) ( isinclcomp f g ) .
Lemma isincltwooutof3a { X Y Z : UU } ( f : X -> Y ) ( g : Y -> Z ) ( isg : isincl g ) ( isgf : isincl ( funcomp f g ) ) : isincl f .
Proof . intros . apply ( isofhlevelff 1 f g isgf ) . apply ( isofhlevelfsnincl 1 g isg ) . Defined .
Lemma isinclgwtog { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( is : isincl ( funcomp w g ) ) : isincl g .
Proof . intros . apply ( isofhlevelfgwtog 1 w g is ) . Defined .
Lemma isinclgtogw { X Y Z : UU } ( w : weq X Y ) ( g : Y -> Z ) ( is : isincl g ) : isincl ( funcomp w g ) .
Proof . intros . apply ( isofhlevelfgtogw 1 w g is ) . Defined .
Lemma isinclhomot { X Y : UU } ( f g : X -> Y ) ( h : homot f g ) ( isf : isincl f ) : isincl g .
Proof . intros . apply ( isofhlevelfhomot ( S O ) f g h isf ) . Defined .
Definition isofhlevelsninclb (n:nat) { X Y : UU } (f:X -> Y)(is: isincl f) : isofhlevel (S n) Y -> isofhlevel (S n) X:= isofhlevelXfromfY (S n) f (isofhlevelfsnincl n f is).
Definition isapropinclb { X Y : UU } ( f : X -> Y ) ( isf : isincl f ) : isaprop Y -> isaprop X := isofhlevelXfromfY 1 _ isf .
Lemma iscontrhfiberofincl { X Y : UU } (f:X -> Y): isincl f -> (forall x:X, iscontr (hfiber f (f x))).
Proof. intros X Y f X0 x. unfold isofhlevelf in X0. set (isy:= X0 (f x)). apply (iscontraprop1 isy (hfiberpair f _ (idpath (f x)))). Defined.
Lemma isweqonpathsincl { X Y : UU } (f:X -> Y) (is: isincl f)(x x':X): isweq (@maponpaths _ _ f x x').
Proof. intros. apply (isofhlevelfonpaths O f x x' is). Defined.
Definition weqonpathsincl { X Y : UU } (f:X -> Y) (is: isincl f)(x x':X) := weqpair _ ( isweqonpathsincl f is x x' ) .
Definition invmaponpathsincl { X Y : UU } (f:X -> Y) (is: isincl f)(x x':X): paths (f x) (f x') -> paths x x':= invmap ( weqonpathsincl f is x x') .
Lemma isinclweqonpaths { X Y : UU } (f:X -> Y): (forall x x':X, isweq (@maponpaths _ _ f x x')) -> isincl f.
Proof. intros X Y f X0. apply (isofhlevelfsn O f X0). Defined.
Definition isinclpr1 { X : UU } (P:X -> UU)(is: forall x:X, isaprop (P x)): isincl (@pr1 X P):= isofhlevelfpr1 (S O) P is.
Theorem samehfibers { X Y Z : UU } (f: X -> Y) (g: Y -> Z) (is1: isincl g) ( y: Y): weq ( hfiber f y ) ( hfiber ( fun x => g ( f x ) ) ( g y ) ) .
Proof. intros. split with (@hfibersftogf _ _ _ f g (g y) (hfiberpair g y (idpath _ ))) .
set (z:= g y). set (ye:= hfiberpair g y (idpath _ )). unfold isweq. intro xe.
set (is3:= isweqezmap1 _ _ _ ( fibseqhf f g z ye ) xe).
assert (w1: weq (paths (hfibersgftog f g z xe) ye) (hfiber (hfibersftogf f g z ye) xe)). split with (ezmap (d1 (hfibersftogf f g z ye) (hfibersgftog f g z) ye ( fibseqhf f g z ye ) xe) (hfibersftogf f g z ye) xe ( fibseq1 (hfibersftogf f g z ye) (hfibersgftog f g z) ye ( fibseqhf f g z ye ) xe) ). apply is3. apply (iscontrweqf w1 ).
assert (is4: iscontr (hfiber g z)). apply iscontrhfiberofincl. assumption.
apply ( isapropifcontr is4 ). Defined.
(** *** Basics about types of h-level 2 - "sets" *)
Definition isaset ( X : UU ) : UU := forall x x' : X , isaprop ( paths x x' ) .
(* Definition isaset := isofhlevel 2 . *)
Notation isasetdirprod := ( isofhleveldirprod 2 ) .
Lemma isasetunit : isaset unit .
Proof . apply ( isofhlevelcontr 2 iscontrunit ) . Defined .
Lemma isasetempty : isaset empty .
Proof. apply ( isofhlevelsnprop 1 isapropempty ) . Defined .
Lemma isasetifcontr { X : UU } ( is : iscontr X ) : isaset X .
Proof . intros . apply ( isofhlevelcontr 2 is ) . Defined .
Lemma isasetaprop { X : UU } ( is : isaprop X ) : isaset X .
Proof . intros . apply ( isofhlevelsnprop 1 is ) . Defined .
(** The following lemma assert "uniqueness of identity proofs" (uip) for sets. *)
Lemma uip { X : UU } ( is : isaset X ) { x x' : X } ( e e' : paths x x' ) : paths e e' .
Proof. intros . apply ( proofirrelevance _ ( is x x' ) e e' ) . Defined .
(** For the theorem about the coproduct of two sets see [ isasetcoprod ] below. *)
Lemma isofhlevelssnset (n:nat) ( X : UU ) ( is : isaset X ) : isofhlevel ( S (S n) ) X.
gitextract_d3i8cydv/
├── .gitignore
├── Coq_patches/
│ ├── README
│ ├── fix-hanging-at-end-of-proof.patch
│ ├── grayson-closedir-after-opendir.patch
│ ├── grayson-fix-infinite-loop.patch
│ ├── grayson-improved-abstraction-version2-8.3pl2.patch
│ ├── inductive-indice-levels-matter-8.3.patch
│ └── patch.type-in-type
├── Current_work/
│ ├── 2013_from_poset.v
│ ├── bsystem.v
│ ├── semisimplicial.v
│ └── semisimplicial2.v
├── Generalities/
│ ├── uu0.v
│ └── uuu.v
├── Makefile
├── Proof_of_Extensionality/
│ └── funextfun.v
├── README
├── hlevel1/
│ └── hProp.v
└── hlevel2/
├── algebra1a.v
├── algebra1b.v
├── algebra1c.v
├── algebra1d.v
├── finitesets.v
├── hSet.v
├── hnat.v
├── hq.v
├── hz.v
└── stnfsets.v
Condensed preview — 28 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (909K chars).
[
{
"path": ".gitignore",
"chars": 49,
"preview": ".#*\n*.html\n*.css\n*.vo\n*.glob\n*.v.d\nTAGS\n.#*\nhtml\n"
},
{
"path": "Coq_patches/README",
"chars": 6785,
"preview": "This directory contains patches for Coq-8.3pl2 written by Hugo Hereblin and Dan Grayson which are needed for proper comp"
},
{
"path": "Coq_patches/fix-hanging-at-end-of-proof.patch",
"chars": 372,
"preview": "diff -ub coq-8.3pl2-clean/kernel/closure.ml coq-8.3pl2-no-universe-constraints--index-levels-matter/kernel/closure.ml\n--"
},
{
"path": "Coq_patches/grayson-closedir-after-opendir.patch",
"chars": 534,
"preview": "This patch will leave many few file descriptors unclosed.\n\n Dan Grayson\n\ndiff -ur ../coq-8.3pl2-clean/lib/system.ml "
},
{
"path": "Coq_patches/grayson-fix-infinite-loop.patch",
"chars": 751,
"preview": "This \"fixes\" a seemingly infinite loop by abandoning the routine after ten repetitions.\nA better fix would involve under"
},
{
"path": "Coq_patches/grayson-improved-abstraction-version2-8.3pl2.patch",
"chars": 14772,
"preview": "diff -ur ../coq-8.3pl2-patched/configure ./configure\n--- ../coq-8.3pl2-patched/configure\t2011-04-19 02:19:00.000000000 -"
},
{
"path": "Coq_patches/inductive-indice-levels-matter-8.3.patch",
"chars": 4535,
"preview": "diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml\nindex df3670d..3e33ffb 100644\n--- a/kernel/indtypes.ml\n+++ b/kernel"
},
{
"path": "Coq_patches/patch.type-in-type",
"chars": 610,
"preview": "diff --git a/branches/v8.3/kernel/reduction.ml b/branches/v8.3/kernel/reduction.ml\nindex aa50f78..77e6072 100644\n--- a/b"
},
{
"path": "Current_work/2013_from_poset.v",
"chars": 6677,
"preview": "Unset Automatic Introduction.\n\nAdd LoadPath \"..\" .\n\nRequire Export Foundations.hlevel2.finitesets.\n\n(* Standard finite p"
},
{
"path": "Current_work/bsystem.v",
"chars": 27596,
"preview": "Require Export Foundations.Generalities.uu0.\n\nUnset Automatic Introduction.\n\n\n(** ** To ustream files of the library *)\n"
},
{
"path": "Current_work/semisimplicial.v",
"chars": 6216,
"preview": "Add Rec LoadPath \"..\".\n\nRequire Export Foundations.hlevel2.finitesets .\n\nUnset Automatic Introduction.\n\n\nVariable Delta "
},
{
"path": "Current_work/semisimplicial2.v",
"chars": 9724,
"preview": "Add Rec LoadPath \"../Foundations/Generalities\".\nAdd Rec LoadPath \"../Foundations/hlevel1\".\nAdd Rec LoadPath \"../Foundati"
},
{
"path": "Generalities/uu0.v",
"chars": 217147,
"preview": "(** * Univalent Basics. Vladimir Voevodsky. Feb. 2010 - Sep. 2011. Port to coq trunk (8.4-8.5) in March 2014. \n\nThis fi"
},
{
"path": "Generalities/uuu.v",
"chars": 2544,
"preview": "(** * Introduction. Vladimir Voevodsky . Feb. 2010 - Sep. 2011 \n\nThis is the first in the group of files which contain t"
},
{
"path": "Makefile",
"chars": 2738,
"preview": "all : hlevel2/hq.vo hlevel2/finitesets.vo Proof_of_Extensionality/funextfun.vo\n\nhlevel2/hq.vo : hlevel2/hq.v hlevel2/hz"
},
{
"path": "Proof_of_Extensionality/funextfun.v",
"chars": 7271,
"preview": "(** * Univalence axiom and functional extensionality. Vladimir Voevodsky. Feb. 2010 - Sep. 2011 \n\nThis file contains th"
},
{
"path": "README",
"chars": 5101,
"preview": "This library is now a part of the UniMath repository, available at\nhttps://github.com/UniMath/UniMath . The recommended "
},
{
"path": "hlevel1/hProp.v",
"chars": 17029,
"preview": "(** * Generalities on hProp. Vladimir Voevodsky . May - Sep. 2011 . \n\nIn this file we introduce the hProp - an analog o"
},
{
"path": "hlevel2/algebra1a.v",
"chars": 71622,
"preview": "(** * Algebra 1 . Part A . Generalities. Vladimir Voevodsky. Aug. 2011 - . \n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)"
},
{
"path": "hlevel2/algebra1b.v",
"chars": 79527,
"preview": "(** * Algebra I. Part B. Monoids, abelian monoids groups, abelian groups. Vladimir Voevodsky. Aug. 2011 - . \n\n*)\n\n\n\n(**"
},
{
"path": "hlevel2/algebra1c.v",
"chars": 93683,
"preview": "(** * Algebra I. Part C. Rigs and rings. Vladimir Voevodsky. Aug. 2011 - . \n\n*)\n\n\n\n(** ** Preambule *)\n\n(** Settings *)"
},
{
"path": "hlevel2/algebra1d.v",
"chars": 42938,
"preview": "(** * Algebra I. Part D. Integral domains and fileds. Vladimir Voevodsky. Aug. 2011 - . \n\n*)\n\n\n\n(** ** Preambule *)\n\n(*"
},
{
"path": "hlevel2/finitesets.v",
"chars": 16043,
"preview": "(** * Finite sets. Vladimir Voevodsky . Apr. - Sep. 2011.\n\nThis file contains the definition and main properties of fini"
},
{
"path": "hlevel2/hSet.v",
"chars": 86896,
"preview": "(** * Generalities on [ hSet ] . Vladimir Voevodsky. Feb. - Sep. 2011 \n\nIn this file we introduce the type [ hSet ] of "
},
{
"path": "hlevel2/hnat.v",
"chars": 67453,
"preview": "(** * Natural numbers and their properties. Vladimir Voevodsky . Apr. - Sep. 2011 \n\nThis file contains the formulations"
},
{
"path": "hlevel2/hq.v",
"chars": 30755,
"preview": "(** * Generalities on the type of rationals and rational arithmetic. Vladimir Voevodsky . Aug. - Sep. 2011.\n\nIn this fil"
},
{
"path": "hlevel2/hz.v",
"chars": 41545,
"preview": "(** * Generalities on the type of integers and integer arithmetic. Vladimir Voevodsky . Aug. - Sep. 2011.\n\nIn this file "
},
{
"path": "hlevel2/stnfsets.v",
"chars": 31647,
"preview": "(** * Standard finite sets . Vladimir Voevodsky . Apr. - Sep. 2011 .\n\nThis file contains main constructions related to t"
}
]
About this extraction
This page contains the full source code of the vladimirias/Foundations GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 28 files (871.6 KB), approximately 328.0k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.