├── .DS_Store ├── .gitignore ├── LICS2012 ├── Makefile ├── README.md ├── identity │ └── identity.v ├── inductive_types │ ├── list.v │ ├── nat.v │ ├── one.v │ ├── sum.v │ ├── three.v │ ├── two.v │ ├── w.v │ └── zero.v ├── nat_as_w_type │ ├── nat_as_w_type.v │ └── o2_as_w_type.v ├── two_is_hinitial │ ├── dep_implies_simp.v │ ├── hinitial_implies_simp.v │ ├── simp_implies_dep.v │ ├── simp_implies_hinitial.v │ ├── two_algebras.v │ └── two_simp.v ├── univalent_foundations │ ├── 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 │ ├── Generalities │ │ ├── uu0.v │ │ └── uuu.v │ ├── Proof_of_Extensionality │ │ └── funextfun.v │ ├── README │ ├── forcoqdoc │ ├── hlevel1 │ │ └── hProp.v │ └── hlevel2 │ │ ├── algebra1a.v │ │ ├── algebra1b.v │ │ ├── algebra1c.v │ │ ├── algebra1d.v │ │ ├── finitesets.v │ │ ├── hSet.v │ │ ├── hnat.v │ │ ├── hq.v │ │ ├── hz.v │ │ └── stnfsets.v └── w_is_hinitial │ ├── hinitial_implies_w.v │ ├── polynomial_functors.v │ └── w_implies_hinitial.v └── README.md /.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HoTT/Archive/394a22ed27d255d65ef2f9493e96897eced8f177/.DS_Store -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | -------------------------------------------------------------------------------- /LICS2012/Makefile: -------------------------------------------------------------------------------- 1 | # Edit the following parameter(s) if "make" fails to find the executables 2 | 3 | # The directory which contains the Coq executables (leave it empty if 4 | # coqc is in the PATH), for example on my Mac I would set 5 | # COQBIN=/Applications/CoqIdE_8.3.app/Contents/Resources/bin/ 6 | # (note the trailing slash). 7 | # 8 | # alternatively you can pass these as arguments on the command line, e.g. 9 | # make COQBIN=~/w/htt/coq-8.3pl2-vv/bin/ COQC=coqc.opt 10 | # 11 | COQBIN= 12 | 13 | # Edit below at your own risk 14 | 15 | COQC:=coqc 16 | COQDEP:=coqdep 17 | 18 | # instead of Add LoadPath we pass them to coqc/coqide/coqtop 19 | COQINCLUDES:=-R "univalent_foundations/Generalities" "Foundations" \ 20 | -R "univalent_foundations/hlevel1" "Foundations" \ 21 | -R "univalent_foundations/hlevel2" "Foundations" \ 22 | -R "identity/" "IT" \ 23 | -R "inductive_types/" "IT" \ 24 | -R "nat_as_w_type/" "IT" \ 25 | -R "two_is_hinitial/" "IT" \ 26 | -R "w_is_hinitial/" "IT" 27 | 28 | # recursively find all .v files and compile them 29 | VFILES:=$(shell find . -name '*.v') 30 | VOFILES:=$(VFILES:.v=.vo) 31 | GLOBFILES:=$(VFILES:.v=.glob) 32 | 33 | .PHONY: all .depend clean 34 | 35 | all: .depend coqidescript .dirlocals $(VOFILES) 36 | 37 | .depend: 38 | @$(COQBIN)$(COQDEP) $(COQINCLUDES) -I . $(VFILES) > .depend 39 | 40 | %.vo %.glob: %.v 41 | @echo Compiling $< 42 | $(COQBIN)$(COQC) $(COQINCLUDES) $< 43 | 44 | clean: 45 | @rm -f coqidescript 46 | @rm -f $(VOFILES) 47 | @rm -f $(GLOBFILES) 48 | 49 | # script to start coq ide with proper arguments (-R ...) 50 | coqidescript: 51 | @echo "#!/bin/sh" > $@ 52 | @echo 'exec $(COQBIN)coqide $(COQINCLUDES) $$@' >> $@ 53 | @chmod +x $@ 54 | 55 | # similar script, but for proof general 56 | .dirlocals: 57 | @echo ';; local settings for proof general' > $@ 58 | @echo '((coq-mode . (' >> $@ 59 | @echo ' (coq-prog-args . ("-emacs-U" $(COQINCLUDES)))' >> $@ 60 | @echo ' (coq-prog-name . "$(COQBIN)coqtop")' >> $@ 61 | @echo ')))' >> $@ 62 | @# we need to quote -R in elisp 63 | @sed -e 's/-R/"-R"/g' --in-place $@ 64 | 65 | -include .depend 66 | -------------------------------------------------------------------------------- /LICS2012/README.md: -------------------------------------------------------------------------------- 1 | Inductive types in Homotopy Type Theory: Coq proofs 2 | =================================================== 3 | 4 | This directory LICS2012 contains Coq proofs formalizing the development of 5 | inductive types in the setting of Homotopy Type Theory, to accompany the 6 | paper "Inductive Types in Homotopy Type Theory", by S. Awodey, N. Gambino 7 | and K. Sojakova. 8 | 9 | The files in the folder `univalent_foundations` are by V. Voevodsky. 10 | All other files were created and are maintained by S. Awodey, N. Gambino, 11 | and K. Sojakova (awodey@cmu.edu, ngambino@math.unipa.it, kristinas@cmu.edu). 12 | 13 | The Coq version used is 8.3pl3. 14 | 15 | The main results formalized in the repository are the proofs of the following 16 | statements: 17 | 18 | * weak 2-types arise as h-initial algebras 19 | * weak W-types arise as h-initial algebras 20 | * weak natural numbers reduce to weak W-types 21 | * second number class reduces to weak W-types 22 | 23 | ## Organization 24 | 25 | The organization is as follows: 26 | 27 | 1. The subdirectory `univalent_foundations` contains the present 28 | development of Voevodsky's Univalent Foundations program, 29 | which aims to provide computational foundations for mathematics 30 | based on homotopically-motivated type theories. For our purposes 31 | only the following files are needed: 32 | 33 | * `Generalities/uuu.v` 34 | * `Generalities/uu0.v` 35 | 36 | The above files introduce the identity types, Sigma types, and the 37 | (simple) function extensionality axiom. Dependent function extensionality 38 | is derived as a consequence and a homotopy equivalence is established 39 | between the types of pointwise vs global function equalities. 40 | 41 | 2. The file `identity.` in the folder `identity` introduces various lemmas 42 | concerning the basic homotopical properties of propositional equalities 43 | and the interaction of identity types with other type constructors. 44 | 45 | 3. The folder `inductive_types` contains the definitions of various 46 | weak inductive types, namely the types `Zero`, `One`, `Two`, 47 | `Three` with `0`, `1`, `2`,`3` constructors respectively; the type 48 | `Sum` of weak sums; weak natural numbers and lists; and weak 49 | W-types. The types are presented in the standard form by giving the 50 | formation, introduction, elimination, and computation rules (here 51 | called beta). The corresponding eta rules are derived. 52 | 53 | 4. The folder `two_is_hinitial` contains the proof that the type `Two` 54 | arises as an h-initial algebra. The proof is structured as follows: 55 | 56 | 1. First the analogous simple rules for Two are formulated; the corresponding 57 | eta rules are no longer derivable and are stated as axioms. This is done 58 | in the file `two_simp.v`. 59 | 60 | 2. We show that the dependent rules for Two imply the simple ones and 61 | vice versa. This is done in the files `simp_implies_dep.v` and 62 | `dep_implies_simp.v`. 63 | 64 | 3. The notions of algebra homomorphisms, algebra 2-cells, and homotopy-initial 65 | algebras are formulated for Two. It is furthermore shown that two algebra 66 | homomorphisms are propositionally equal if and only if there exists an 67 | algebra 2-cell between them. This is done in the file `two_algebras.v`. 68 | 69 | 4. We show that the simple rules for Two are equivalent to the assertion 70 | that there exists a homotopy-initial 2-algebra. This is done in the files 71 | `simp_implies_hinitial.v` and `hinitial_implies_simp.v`. 72 | 73 | 5. The folder `w_is_hinitial` contains the proof that weak W-types arise as h-initial 74 | algebras for polynomial functors. The proof is structured as follows: 75 | 76 | 1. First we introduce the notion of polynomial functors and prove a number 77 | of useful lemmas. This is done in the file `polynomial_functors.v`. 78 | 79 | 2. We show the main result, i.e. that the dependent rules for W are 80 | equivalent to the assertion that there exists a homotopy-initial algebra 81 | for the associated polynomial functor. This is done in the files 82 | `w_implies_hinitial.v` and `hinitial_implies_w.v`. 83 | 84 | 6. The file `nat_as_w_type.v` in the folder `nat_as_w_type` formalizes the proof that 85 | weak natural numbers are encodable as weak W-types in the presence of the types 86 | Zero, One, and (a type-level version of) Two. 87 | 88 | 7. The file `o2_as_w_type.v` in the folder `nat_as_w_type` formalizes the proof that the 89 | second number class is encodable as a weak W-type in the presence of the types 90 | Zero, One, Two, and (a type-level version of) Three. 91 | 92 | ## How to compile 93 | 94 | The order of compilation is as follows (although after you compiled 95 | `uuu.v` and `uu0.v` you can just run `make` in the IT subdirectory): 96 | 97 | 1. in the `univalent_foundations` directory: 98 | * `Generalities/uuu.v` 99 | * `Generalities/uu0.v` 100 | 2. `identity/identity.v` 101 | 3. `inductive_types/*.v` 102 | 4. `two_is_hinitial`: 103 | * `two_simp.v`, `two_algebras.v` 104 | * `dep_implies_simp.v`, `simp_implies_dep.v`, `simp_implies_hinitial.v`, `hinitial_implies_simp.v` 105 | 5. `w_is_hinitial`: 106 | * `polynomial_functors.v` 107 | * `hinitial_implies_w.v`, `w_implies_hinitial.v` 108 | 6. `nat_as_w_type`: 109 | * `nat_as_w_type.v` 110 | * `o2_as_w_type.v` 111 | 112 | Repository last updated : 24 Apr 2012. -------------------------------------------------------------------------------- /LICS2012/inductive_types/list.v: -------------------------------------------------------------------------------- 1 | (** Rules for the inductive type List A, the weak version of lists of type A. **) 2 | 3 | Add Rec LoadPath "../univalent_foundations/Generalities". 4 | Add Rec LoadPath "../identity". 5 | 6 | Require Export identity. 7 | 8 | (* Formation rule. *) 9 | Axiom List : U -> U. 10 | 11 | (* Introduction rules. *) 12 | Axiom nil : forall (A : U), List A. 13 | Axiom cons : forall (A : U), A -> List A -> List A. 14 | 15 | (* Elimination rule. *) 16 | Axiom list_rec : forall (A : U) (E : List A -> U) (e_n : E (nil A)) (e_c : forall a l, E l -> E (cons A a l)) 17 | (x : List A), E x. 18 | 19 | (* Beta rules. *) 20 | Axiom list_beta_n : forall (A : U) (E : List A -> U) (e_n : E (nil A)) (e_c : forall a l, E l -> E (cons A a l)), 21 | Id (list_rec A E e_n e_c (nil A)) e_n. 22 | 23 | Axiom list_beta_c : forall (A : U) (E : List A -> U) (e_n : E (nil A)) (e_c : forall a l, E l -> E (cons A a l)) 24 | (a : A) (l : List A), 25 | Id (list_rec A E e_n e_c (cons A a l)) (e_c a l (list_rec A E e_n e_c l)). 26 | 27 | (***********************************************************************) 28 | (***********************************************************************) 29 | 30 | (* Derived rules. *) 31 | 32 | (* First-order eta rule. *) 33 | Definition list_eta_1 (A : U) (E : List A -> U) (e_n : E (nil A)) (e_c : forall a l, E l -> E (cons A a l)) (h : forall x, E x) (p_n : Id (h (nil A)) e_n) (p_c : forall a l, Id (h (cons A a l)) (e_c a l (h l))) : 34 | forall (x : List A), Id (h x) (list_rec A E e_n e_c x) 35 | := list_rec A (fun x => Id (h x) (list_rec A E e_n e_c x)) 36 | (p_n @ (list_beta_n A E e_n e_c)!) 37 | (fun a l hyp => p_c a l @ mapid (e_c a l) hyp @ (list_beta_c A E e_n e_c a l)!). 38 | 39 | (* Second-order eta rules. *) 40 | Definition list_eta_2_n (A : U) (E : List A -> U) (e_n : E (nil A)) (e_c : forall a l, E l -> E (cons A a l)) (h : forall x, E x) (p_n : Id (h (nil A)) e_n) (p_c : forall a l, Id (h (cons A a l)) (e_c a l (h l))) : 41 | Id (list_eta_1 A E e_n e_c h p_n p_c (nil A) @ list_beta_n A E e_n e_c) p_n. 42 | Proof. 43 | intros. 44 | apply cancel_right_inv. 45 | apply list_beta_n with (E := fun x => Id (h x) (list_rec A E e_n e_c x)). 46 | Defined. 47 | 48 | Definition list_eta_2_c (A : U) (E : List A -> U) (e_n : E (nil A)) (e_c : forall a l, E l -> E (cons A a l)) (h : forall x, E x) (p_n : Id (h (nil A)) e_n) (p_c : forall a l, Id (h (cons A a l)) (e_c a l (h l))) : 49 | forall (a : A) (l : List A), 50 | Id (list_eta_1 A E e_n e_c h p_n p_c (cons A a l) @ list_beta_c A E e_n e_c a l) 51 | (p_c a l @ mapid (e_c a l) (list_eta_1 A E e_n e_c h p_n p_c l)). 52 | Proof. 53 | intros. 54 | apply cancel_right_inv. 55 | apply list_beta_c with (E := fun x => Id (h x) (list_rec A E e_n e_c x)). 56 | Defined. 57 | -------------------------------------------------------------------------------- /LICS2012/inductive_types/nat.v: -------------------------------------------------------------------------------- 1 | (** Rules for the inductive type Nat, the weak version of natural numbers. **) 2 | 3 | Add Rec LoadPath "../univalent_foundations/Generalities". 4 | Add Rec LoadPath "../identity". 5 | 6 | Require Export identity. 7 | 8 | (* Formation rule. *) 9 | Axiom Nat : U. 10 | 11 | (* Introduction rules. *) 12 | Axiom zero : Nat. 13 | Axiom suc : Nat -> Nat. 14 | 15 | (* Elimination rule. *) 16 | Axiom nat_rec : forall (E : Nat -> U) (e_z : E zero) (e_s : forall n, E n -> E (suc n)) 17 | (x : Nat), E x. 18 | 19 | (* Beta rules. *) 20 | Axiom nat_beta_z : forall (E : Nat -> U) (e_z : E zero) (e_s : forall n, E n -> E (suc n)), 21 | Id (nat_rec E e_z e_s zero) e_z. 22 | 23 | Axiom nat_beta_s : forall (E : Nat -> U) (e_z : E zero) (e_s : forall n, E n -> E (suc n)) 24 | (n : Nat), Id (nat_rec E e_z e_s (suc n)) (e_s n (nat_rec E e_z e_s n)). 25 | 26 | (***********************************************************************) 27 | (***********************************************************************) 28 | 29 | (* Derived rules. *) 30 | 31 | (* First-order eta rule. *) 32 | Definition nat_eta_1 (E : Nat -> U) (e_z : E zero) (e_s : forall n, E n -> E (suc n)) (h : forall x, E x) (p_z : Id (h zero) e_z) (p_s : forall n, Id (h (suc n)) (e_s n (h n))) : 33 | forall (x : Nat), Id (h x) (nat_rec E e_z e_s x) 34 | := nat_rec (fun x => Id (h x) (nat_rec E e_z e_s x)) 35 | (p_z @ (nat_beta_z E e_z e_s)!) 36 | (fun n hyp => p_s n @ mapid (e_s n) hyp @ (nat_beta_s E e_z e_s n)!). 37 | 38 | (* Second-order eta rules. *) 39 | Definition nat_eta_2_z (E : Nat -> U) (e_z : E zero) (e_s : forall n, E n -> E (suc n)) (h : forall x, E x) (p_z : Id (h zero) e_z) (p_s : forall n, Id (h (suc n)) (e_s n (h n))) : 40 | Id (nat_eta_1 E e_z e_s h p_z p_s zero @ nat_beta_z E e_z e_s) p_z. 41 | Proof. 42 | intros. 43 | apply cancel_right_inv. 44 | apply nat_beta_z with (E := fun x => Id (h x) (nat_rec E e_z e_s x)). 45 | Defined. 46 | 47 | Definition nat_eta_2_s (E : Nat -> U) (e_z : E zero) (e_s : forall n, E n -> E (suc n)) (h : forall x, E x) (p_z : Id (h zero) e_z) (p_s : forall n, Id (h (suc n)) (e_s n (h n))) : 48 | forall (n : Nat), 49 | Id (nat_eta_1 E e_z e_s h p_z p_s (suc n) @ nat_beta_s E e_z e_s n) 50 | (p_s n @ mapid (e_s n) (nat_eta_1 E e_z e_s h p_z p_s n)). 51 | Proof. 52 | intros. 53 | apply cancel_right_inv. 54 | apply nat_beta_s with (E := fun x => Id (h x) (nat_rec E e_z e_s x)). 55 | Defined. 56 | -------------------------------------------------------------------------------- /LICS2012/inductive_types/one.v: -------------------------------------------------------------------------------- 1 | (** Rules for the weak inductive type One with one constructor and propositional 2 | beta rule. **) 3 | 4 | Add Rec LoadPath "../univalent_foundations/Generalities". 5 | Add Rec LoadPath "../identity". 6 | 7 | Require Export identity. 8 | 9 | (* Formation rule. *) 10 | Axiom One : U. 11 | 12 | (* Introduction rule. *) 13 | Axiom unit : One. 14 | 15 | (* Elimination rule. *) 16 | Axiom one_rec : forall (E : One -> U) (e_u : E unit) (x : One), E x. 17 | 18 | (* Beta rule. *) 19 | Axiom one_beta : forall (E : One -> U) (e_u : E unit), 20 | Id (one_rec E e_u unit) e_u. 21 | 22 | (***********************************************************************) 23 | (***********************************************************************) 24 | 25 | (* Derived rules. *) 26 | 27 | (* First-order eta rule. *) 28 | Definition one_eta_1 (E : One -> U) (e_u : E unit) (h : forall x, E x) (p : Id (h unit) e_u) : 29 | forall (x : One), Id (h x) (one_rec E e_u x) 30 | := one_rec (fun x => Id (h x) (one_rec E e_u x)) (p @ (one_beta E e_u)!). 31 | 32 | (* Second-order eta rule. *) 33 | Definition one_eta_2 (E : One -> U) (e_u : E unit) (h : forall x, E x) (p : Id (h unit) e_u) : 34 | Id (one_eta_1 E e_u h p unit @ one_beta E e_u) p. 35 | Proof. 36 | apply cancel_right_inv. 37 | apply one_beta with (E := fun x => Id (h x) (one_rec E e_u x)). 38 | Defined. 39 | -------------------------------------------------------------------------------- /LICS2012/inductive_types/sum.v: -------------------------------------------------------------------------------- 1 | (** Rules for the inductive type Sum A B, the weak version of A + B. **) 2 | 3 | Add Rec LoadPath "../univalent_foundations/Generalities". 4 | Add Rec LoadPath "../identity". 5 | 6 | Require Export identity. 7 | 8 | (* Formation rule. *) 9 | Axiom Sum : U -> U -> U. 10 | 11 | (* Introduction rules. *) 12 | Axiom inl : forall (A B : U), A -> Sum A B. 13 | Axiom inr : forall (A B : U), B -> Sum A B. 14 | 15 | (* Elimination rule. *) 16 | Axiom sum_rec : forall (A B : U) (E : Sum A B -> U) (e_l : forall a, E (inl A B a)) (e_r : forall b, E (inr A B b)) 17 | (x : Sum A B), E x. 18 | 19 | (* Beta rules. *) 20 | Axiom sum_beta_l : forall (A B : U) (E : Sum A B -> U) (e_l : forall a, E (inl A B a)) (e_r : forall b, E (inr A B b)) 21 | (a : A), Id (sum_rec A B E e_l e_r (inl A B a)) (e_l a). 22 | 23 | Axiom sum_beta_r : forall (A B : U) (E : Sum A B -> U) (e_l : forall a, E (inl A B a)) (e_r : forall b, E (inr A B b)) 24 | (b : B), Id (sum_rec A B E e_l e_r (inr A B b)) (e_r b). 25 | 26 | (***********************************************************************) 27 | (***********************************************************************) 28 | 29 | (* Derived rules. *) 30 | 31 | (* First-order eta rule. *) 32 | Definition sum_eta_1 (A B : U) (E : Sum A B -> U) (e_l : forall a, E (inl A B a)) (e_r : forall b, E (inr A B b)) (h : forall x, E x) (p_l : forall a, Id (h (inl A B a)) (e_l a)) (p_r : forall b, Id (h (inr A B b)) (e_r b)) : 33 | forall (x : Sum A B), Id (h x) (sum_rec A B E e_l e_r x) 34 | := sum_rec A B (fun x => Id (h x) (sum_rec A B E e_l e_r x)) 35 | (fun a => p_l a @ (sum_beta_l A B E e_l e_r a)!) 36 | (fun b => p_r b @ (sum_beta_r A B E e_l e_r b)!). 37 | 38 | (* Second-order eta rules. *) 39 | Definition sum_eta_2_l (A B : U) (E : Sum A B -> U) (e_l : forall a, E (inl A B a)) (e_r : forall b, E (inr A B b)) (h : forall x, E x) (p_l : forall a, Id (h (inl A B a)) (e_l a)) (p_r : forall b, Id (h (inr A B b)) (e_r b)) : 40 | forall (a : A), 41 | Id (sum_eta_1 A B E e_l e_r h p_l p_r (inl A B a) @ sum_beta_l A B E e_l e_r a) 42 | (p_l a). 43 | Proof. 44 | intros. 45 | apply cancel_right_inv. 46 | apply sum_beta_l with (E := fun x => Id (h x) (sum_rec A B E e_l e_r x)) (a := a). 47 | Defined. 48 | 49 | Definition sum_eta_2_r (A B : U) (E : Sum A B -> U) (e_l : forall a, E (inl A B a)) (e_r : forall b, E (inr A B b)) (h : forall x, E x) (p_l : forall a, Id (h (inl A B a)) (e_l a)) (p_r : forall b, Id (h (inr A B b)) (e_r b)) : 50 | forall (b : B), 51 | Id (sum_eta_1 A B E e_l e_r h p_l p_r (inr A B b) @ sum_beta_r A B E e_l e_r b) 52 | (p_r b). 53 | Proof. 54 | intros. 55 | apply cancel_right_inv. 56 | apply sum_beta_r with (E := fun x => Id (h x) (sum_rec A B E e_l e_r x)) (b := b). 57 | Defined. 58 | -------------------------------------------------------------------------------- /LICS2012/inductive_types/three.v: -------------------------------------------------------------------------------- 1 | (** Rules for the weak inductive type Three with three constructors and 2 | propositional beta rules. **) 3 | 4 | Add Rec LoadPath "../univalent_foundations/Generalities". 5 | Add Rec LoadPath "../identity". 6 | 7 | Require Export identity. 8 | 9 | (* Formation rule. *) 10 | Axiom Three : U. 11 | 12 | (* Introduction rules. *) 13 | Axiom left : Three. 14 | Axiom center : Three. 15 | Axiom right : Three. 16 | 17 | (* Elimination rule. *) 18 | Axiom three_rec : forall (E : Three -> U) (e_l : E left) (e_c : E center) (e_r : E right) (x : Three), E x. 19 | 20 | (* Beta rules. *) 21 | Axiom three_beta_l : forall (E : Three -> U) (e_l : E left) (e_c : E center) (e_r : E right), 22 | Id (three_rec E e_l e_c e_r left) e_l. 23 | 24 | Axiom three_beta_c : forall (E : Three -> U) (e_l : E left) (e_c : E center) (e_r : E right), 25 | Id (three_rec E e_l e_c e_r center) e_c. 26 | 27 | Axiom three_beta_r : forall (E : Three -> U) (e_l : E left) (e_c : E center) (e_r : E right), 28 | Id (three_rec E e_l e_c e_r right) e_r. 29 | 30 | (***********************************************************************) 31 | (***********************************************************************) 32 | 33 | (* Derived rules. *) 34 | 35 | (* First-order eta rule. *) 36 | Definition three_eta_1 (E : Three -> U) (e_l : E left) (e_c : E center) (e_r : E right) (h : forall x, E x) (p_l : Id (h left) e_l) (p_c : Id (h center) e_c) (p_r : Id (h right) e_r) : 37 | forall (x : Three), Id (h x) (three_rec E e_l e_c e_r x) 38 | := three_rec (fun x => Id (h x) (three_rec E e_l e_c e_r x)) 39 | (p_l @ (three_beta_l E e_l e_c e_r)!) 40 | (p_c @ (three_beta_c E e_l e_c e_r)!) 41 | (p_r @ (three_beta_r E e_l e_c e_r)!). 42 | 43 | (* Second-order eta rules. *) 44 | Definition three_eta_2_l (E : Three -> U) (e_l : E left) (e_c : E center) (e_r : E right) (h : forall x, E x) (p_l : Id (h left) e_l) (p_c : Id (h center) e_c) (p_r : Id (h right) e_r) : 45 | Id (three_eta_1 E e_l e_c e_r h p_l p_c p_r left @ three_beta_l E e_l e_c e_r) 46 | p_l. 47 | Proof. 48 | apply cancel_right_inv. 49 | apply three_beta_l with (E := fun x => Id (h x) (three_rec E e_l e_c e_r x)). 50 | Defined. 51 | 52 | Definition three_eta_2_c (E : Three -> U) (e_l : E left) (e_c : E center) (e_r : E right) (h : forall x, E x) (p_l : Id (h left) e_l) (p_c : Id (h center) e_c) (p_r : Id (h right) e_r) : 53 | Id (three_eta_1 E e_l e_c e_r h p_l p_c p_r center @ three_beta_c E e_l e_c e_r) 54 | p_c. 55 | Proof. 56 | apply cancel_right_inv. 57 | apply three_beta_c with (E := fun x => Id (h x) (three_rec E e_l e_c e_r x)). 58 | Defined. 59 | 60 | Definition three_eta_2_r (E : Three -> U) (e_l : E left) (e_c : E center) (e_r : E right) (h : forall x, E x) (p_l : Id (h left) e_l) (p_c : Id (h center) e_c) (p_r : Id (h right) e_r) : 61 | Id (three_eta_1 E e_l e_c e_r h p_l p_c p_r right @ three_beta_r E e_l e_c e_r) 62 | p_r. 63 | Proof. 64 | apply cancel_right_inv. 65 | apply three_beta_r with (E := fun x => Id (h x) (three_rec E e_l e_c e_r x)). 66 | Defined. 67 | -------------------------------------------------------------------------------- /LICS2012/inductive_types/two.v: -------------------------------------------------------------------------------- 1 | (** Rules for the weak inductive type Two with two constructors and propositional 2 | beta rules. **) 3 | 4 | Add Rec LoadPath "../univalent_foundations/Generalities". 5 | Add Rec LoadPath "../identity". 6 | 7 | Require Export identity. 8 | 9 | (* Formation rule. *) 10 | Axiom Two : U. 11 | 12 | (* Introduction rules. *) 13 | Axiom false : Two. 14 | Axiom true : Two. 15 | 16 | (* Elimination rule. *) 17 | Axiom two_rec : forall (E : Two -> U) (e_f : E false) (e_t : E true) (x : Two), E x. 18 | 19 | (* Beta rules. *) 20 | Axiom two_beta_f : forall (E : Two -> U) (e_f : E false) (e_t : E true), 21 | Id (two_rec E e_f e_t false) e_f. 22 | 23 | Axiom two_beta_t : forall (E : Two -> U) (e_f : E false) (e_t : E true), 24 | Id (two_rec E e_f e_t true) e_t. 25 | 26 | (***********************************************************************) 27 | (***********************************************************************) 28 | 29 | (* Derived rules. *) 30 | 31 | (* First-order eta rule. *) 32 | Definition two_eta_1 (E : Two -> U) (e_f : E false) (e_t : E true) (h : forall x, E x) (p_f : Id (h false) e_f) (p_t : Id (h true) e_t) : 33 | forall (x : Two), Id (h x) (two_rec E e_f e_t x) 34 | := two_rec (fun x => Id (h x) (two_rec E e_f e_t x)) 35 | (p_f @ (two_beta_f E e_f e_t)!) 36 | (p_t @ (two_beta_t E e_f e_t)!). 37 | 38 | (* Second-order eta rules. *) 39 | Definition two_eta_2_l (E : Two -> U) (e_f : E false) (e_t : E true) (h : forall x, E x) (p_f : Id (h false) e_f) (p_t : Id (h true) e_t) : 40 | Id (two_eta_1 E e_f e_t h p_f p_t false @ two_beta_f E e_f e_t) p_f. 41 | Proof. 42 | apply cancel_right_inv. 43 | apply two_beta_f with (E := fun x => Id (h x) (two_rec E e_f e_t x)). 44 | Defined. 45 | 46 | Definition two_eta_2_r (E : Two -> U) (e_f : E false) (e_t : E true) (h : forall x, E x) (p_f : Id (h false) e_f) (p_t : Id (h true) e_t) : 47 | Id (two_eta_1 E e_f e_t h p_f p_t true @ two_beta_t E e_f e_t) p_t. 48 | Proof. 49 | apply cancel_right_inv. 50 | apply two_beta_t with (E := fun x => Id (h x) (two_rec E e_f e_t x)). 51 | Defined. 52 | -------------------------------------------------------------------------------- /LICS2012/inductive_types/w.v: -------------------------------------------------------------------------------- 1 | (** Rules for the inductive type W A B, the weak version of W-types over A and B. **) 2 | 3 | Add Rec LoadPath "../univalent_foundations/Generalities". 4 | Add Rec LoadPath "../identity". 5 | 6 | Require Export identity. 7 | 8 | (* Formation rule. *) 9 | Axiom W : forall (A : U) (B : A -> U), U. 10 | 11 | (* Introduction rule. *) 12 | Axiom sup : forall (A : U) (B : A -> U) (x : A) (f : B x -> W A B), W A B. 13 | 14 | (* Elimination rule. *) 15 | Axiom w_rec : forall (A : U) (B : A -> U) (E : W A B -> U) (e_s : forall x f, (forall b, E (f b)) -> E (sup A B x f)) 16 | (w : W A B), E w. 17 | 18 | (* Beta rule. *) 19 | Axiom w_beta : forall (A : U) (B : A -> U) (E : W A B -> U) (e_s : forall x f, (forall b, E (f b)) -> E (sup A B x f)) 20 | (x : A) (f : B x -> W A B), 21 | Id (w_rec A B E e_s (sup A B x f)) (e_s x f (fun b => w_rec A B E e_s (f b))). 22 | 23 | (***********************************************************************) 24 | (***********************************************************************) 25 | 26 | (* Derived rules. *) 27 | 28 | (* First-order eta rule. *) 29 | Definition w_eta_1 (A : U) (B : A -> U) (E : W A B -> U) (e_s : forall x f, (forall b, E (f b)) -> E (sup A B x f)) (h : forall x, E x) (p_s : forall x f, Id (h (sup A B x f)) (e_s x f (fun b => h (f b)))) : 30 | forall (w : W A B), Id (h w) (w_rec A B E e_s w) 31 | := w_rec A B (fun w => Id (h w) (w_rec A B E e_s w)) 32 | (fun x f hyp => p_s x f @ mapid (e_s x f) (dfunext _ _ _ hyp) @ (w_beta A B E e_s x f)!). 33 | 34 | (* Second-order eta rule. *) 35 | Definition w_eta_2 (A : U) (B : A -> U) (E : W A B -> U) (e_s : forall x f, (forall b, E (f b)) -> E (sup A B x f)) (h : forall x, E x) (p_s : forall x f, Id (h (sup A B x f)) (e_s x f (fun b => h (f b)))) : 36 | forall (x : A) (f : B x -> W A B), 37 | Id (w_eta_1 A B E e_s h p_s (sup A B x f) @ w_beta A B E e_s x f) 38 | (p_s x f @ mapid (e_s x f) (dfunext _ _ _ (fun b => w_eta_1 A B E e_s h p_s (f b)))). 39 | Proof. 40 | intros. 41 | apply cancel_right_inv. 42 | apply w_beta with (E := fun w => Id (h w) (w_rec A B E e_s w)). 43 | Defined. 44 | -------------------------------------------------------------------------------- /LICS2012/inductive_types/zero.v: -------------------------------------------------------------------------------- 1 | (** Rules for the inductive type Zero with no constructors. **) 2 | 3 | Add Rec LoadPath "../univalent_foundations/Generalities". 4 | Add Rec LoadPath "../identity". 5 | 6 | Require Export identity. 7 | 8 | (* Formation rule. *) 9 | Axiom Zero : U. 10 | 11 | (* No introduction rule. *) 12 | 13 | (* Elimination rule. *) 14 | Axiom zero_rec : forall (E : Zero -> U) (x : Zero), E x. 15 | 16 | (* No beta rule. *) 17 | 18 | (***********************************************************************) 19 | (***********************************************************************) 20 | 21 | (* Derived rules. *) 22 | 23 | (* First-order eta rule. *) 24 | Definition zero_eta_1 (E : Zero -> U) (h : forall x, E x) : 25 | forall (x : Zero), Id (h x) (zero_rec E x) 26 | := zero_rec (fun x => Id (h x) (zero_rec E x)). -------------------------------------------------------------------------------- /LICS2012/nat_as_w_type/nat_as_w_type.v: -------------------------------------------------------------------------------- 1 | (** We show that in the presence of the types 2 | 3 | - Zero, One, Two with propositional computation rules 4 | - W-types with propositional computation rules 5 | - propositional function extensionality 6 | 7 | we get 8 | 9 | - Nat with propositional computation rules. 10 | 11 | *) 12 | 13 | 14 | Add Rec LoadPath "../univalent_foundations/Generalities". 15 | Add Rec LoadPath "../identity". 16 | Add Rec LoadPath "../inductive_types". 17 | 18 | Unset Automatic Introduction. 19 | Require Export uu0. 20 | Require Export identity. 21 | Require Export zero. 22 | Require Export one. 23 | Require Export w. 24 | 25 | (** * H-terminal types *) 26 | 27 | Section H_terminal_type. 28 | 29 | (** We show that if a type X satisfies the rules for the h-initial type, then for every 30 | type Y there is an adjoint homotopy equivalence between (X -> Y) and Y *) 31 | 32 | (** Axioms for a h-terminal type *) 33 | 34 | Variable X : U. 35 | Variable x_0 : X. 36 | Variable rec : forall (E : X -> U)(e : E x_0)(x : X), E x. 37 | Variable comp : forall (E : X -> U)(e : E x_0), Id (rec E e x_0) e. 38 | 39 | (** We show that for any type Y, there is an adjoint homotopy equivalence between X -> Y and Y *) 40 | 41 | Variable Y : U. 42 | 43 | Definition f_terminal : (X -> Y) -> Y := 44 | fun (u : X -> Y) => u x_0. 45 | 46 | (** Like any function between types, the map f extends in a canonical way to paths. Below, we give an 47 | explicit expression for it *) 48 | 49 | Definition f_terminal_on_paths {u u' : X -> Y} : 50 | Id u u' -> Id (f_terminal u) (f_terminal u'). 51 | Proof. 52 | intros u u' e. 53 | unfold f_terminal. 54 | apply (toforallpaths _ _ _ e x_0). 55 | Defined. 56 | 57 | Definition f_terminal_on_paths_vs_map_on_paths {u u' : X -> Y} : 58 | forall (e : Id u u'), Id (f_terminal_on_paths e) (maponpaths f_terminal e). 59 | Proof. 60 | intros. 61 | destruct e. 62 | simpl. 63 | unfold f_terminal. 64 | apply refl. 65 | Defined. 66 | 67 | Definition g_terminal : Y -> (X -> Y) := 68 | fun (y : Y) => rec (fun _ : X => Y) y. 69 | 70 | (** Again, we need an expression for the canonical action of g on paths. We give 71 | first a definition from paths to homotopies *) 72 | 73 | Definition g_terminal_from_paths_to_hom {y y' : Y} : Id y y' -> Hom (g_terminal y) (g_terminal y'). 74 | Proof. 75 | intros y y' e. 76 | unfold g_terminal. 77 | intro x. 78 | apply (rec (fun z => Id (rec (fun _ : X => Y) y z) (rec (fun _ : X => Y) y' z))). 79 | apply (pathscomp0 (pathscomp0 (comp (fun _ : X => Y) y) e) (pathsinv0 (comp (fun _ : X => Y) y'))). 80 | Defined. 81 | 82 | Definition g_terminal_from_paths_to_hom_vs_map_on_paths {y y' : Y} : 83 | forall (e : Id y y'), Id ( g_terminal_from_paths_to_hom e) (fun x : X => maponpaths (fun z => (g_terminal z x)) e). 84 | Proof. 85 | intros. 86 | destruct e. 87 | simpl. 88 | apply funextsec. 89 | intro x. 90 | apply (rec (fun z => Id (g_terminal_from_paths_to_hom (refl y) z) (refl (g_terminal y z)))). 91 | unfold g_terminal_from_paths_to_hom. 92 | apply 93 | (transportb (fun z => Id z (refl (g_terminal y x_0))) (comp (fun z : X => Id (rec (fun _ : X => Y) y z) (rec (fun _ : X => Y) y z)) 94 | (pathscomp0 (pathscomp0 (comp (fun _ : X => Y) y) (refl y)) 95 | (pathsinv0 (comp (fun _ : X => Y) y))))). 96 | unfold g_terminal. 97 | set (u_y := (rec (fun _ : X => Y) y x_0)). 98 | set (E := (fun _ : X => Y)). 99 | set (s := (comp E y)). 100 | simpl. 101 | apply (transportb (fun z => Id (pathscomp0 z (pathsinv0 s)) (refl u_y)) (pathscomp0rid s)). 102 | apply (transportb (fun z => Id z _) (pathsinv0r s)). 103 | apply refl. 104 | Defined. 105 | 106 | Definition g_terminal_on_paths {y y' : Y} : 107 | Id y y' -> Id (g_terminal y) (g_terminal y'). 108 | Proof. 109 | intros y y' e. 110 | unfold g_terminal. 111 | apply funextfun. 112 | apply (g_terminal_from_paths_to_hom e). 113 | Defined. 114 | 115 | Definition g_terminal_on_paths_vs_map_on_paths {y y' : Y} : 116 | forall (e : Id y y'), Id (g_terminal_on_paths e) (maponpaths g_terminal e). 117 | Proof. 118 | intros. 119 | destruct e. 120 | simpl. 121 | unfold g_terminal_on_paths. 122 | apply (transportb (fun z => Id (funextfun (rec (fun _ : X => Y) y) (rec (fun _ : X => Y) y) z) (refl (g_terminal y))) 123 | (g_terminal_from_paths_to_hom_vs_map_on_paths (refl y))). 124 | unfold maponpaths. 125 | change (fun x : X => refl (g_terminal y x)) with (toforallpaths _ _ _ (refl (g_terminal y))). 126 | apply (homotinvweqweq (weqtoforallpaths _ _ _) (refl (g_terminal y))). 127 | Defined. 128 | 129 | (** The counit e_fg_terminal : FG ==> 1 *) 130 | 131 | Definition e_fg_terminal : forall (y : Y), Id (f_terminal (g_terminal y)) y. 132 | Proof. 133 | intros. 134 | unfold g_terminal. 135 | unfold f_terminal. 136 | apply (comp (fun _ : X => Y) y). 137 | Defined. 138 | 139 | (** The unit e_gf_terminal : GF ==> 1 *) 140 | 141 | Definition hom_e_gf_terminal : 142 | forall (u : X -> Y)(x : X), Id ((g_terminal (f_terminal u)) x) (u x). 143 | Proof. 144 | intros u x. 145 | apply (rec (fun z => Id (g_terminal (f_terminal u) z) (u z))). 146 | unfold f_terminal. 147 | unfold g_terminal. 148 | apply (e_fg_terminal (u x_0)). 149 | Defined. 150 | 151 | Definition e_gf_terminal : 152 | forall (u : X -> Y), Id (g_terminal (f_terminal u)) u. 153 | Proof. 154 | intros. 155 | apply (funextfun _ _ (hom_e_gf_terminal u)). 156 | Defined. 157 | 158 | (** From the homotopy equivalence, we get a weak equivalence *) 159 | 160 | Definition weq_terminal : 161 | weq (X -> Y) Y. 162 | Proof. 163 | intros. 164 | apply (weqgradth f_terminal g_terminal e_gf_terminal e_fg_terminal). 165 | Defined. 166 | 167 | (** The first triangular law *) 168 | 169 | Definition towards_first_triangular_law_terminal : 170 | forall (u : X -> Y), Id (f_terminal_on_paths (e_gf_terminal u)) (e_fg_terminal (f_terminal u)). 171 | Proof. 172 | intros. 173 | unfold e_gf_terminal. 174 | unfold f_terminal_on_paths. 175 | assert (p : Id (toforallpaths _ _ _ (funextfun _ _ (hom_e_gf_terminal u))) (hom_e_gf_terminal u)). 176 | apply (homotweqinvweq (weqtoforallpaths _ _ _) (hom_e_gf_terminal u)). 177 | apply (transportb (fun x => Id (x x_0) _) p). 178 | unfold f_terminal. 179 | unfold hom_e_gf_terminal. 180 | set (E := (fun x : X => Id (g_terminal (f_terminal u) x) (u x))). 181 | set (e := (comp (fun _ : X => Y) (u x_0))). 182 | apply (comp E e). 183 | Defined. 184 | 185 | Definition first_triangular_law_terminal : 186 | forall (u : X -> Y), Id ((maponpaths f_terminal) (e_gf_terminal u)) (e_fg_terminal (f_terminal u)). 187 | Proof. 188 | intros. 189 | set (p := (f_terminal_on_paths_vs_map_on_paths (e_gf_terminal u))). 190 | apply (transportf (fun z => Id z (e_fg_terminal (f_terminal u))) p). 191 | apply (towards_first_triangular_law_terminal u). 192 | Defined. 193 | 194 | Definition towards_second_triangular_law_terminal : 195 | forall (y : Y), Id (e_gf_terminal (g_terminal y)) (g_terminal_on_paths (e_fg_terminal y)). 196 | Proof. 197 | intros. 198 | unfold e_gf_terminal. 199 | unfold g_terminal_on_paths. 200 | apply maponpaths. 201 | apply funextsec. 202 | set (u_y := g_terminal y). 203 | intro x. 204 | apply (rec (fun z => Id (hom_e_gf_terminal u_y z) (g_terminal_from_paths_to_hom (e_fg_terminal y) z))). 205 | assert (p_1 : Id (hom_e_gf_terminal u_y x_0) (e_fg_terminal (u_y x_0))). 206 | apply (comp (fun z => Id (g_terminal (f_terminal u_y) z) (u_y z)) (e_fg_terminal (u_y x_0))). 207 | apply (transportb (fun x => Id x _) p_1). 208 | unfold g_terminal_from_paths_to_hom. 209 | set (E_1 := (fun _ : X => Y)). 210 | set (E_2 := (fun z : X => Id (rec E_1 (f_terminal (g_terminal y)) z) (rec E_1 y z))). 211 | change (Id (e_fg_terminal (u_y x_0)) 212 | (rec E_2 (pathscomp0 (pathscomp0 (comp E_1 (f_terminal (g_terminal y))) (e_fg_terminal y)) (pathsinv0 (comp E_1 y))) x_0)). 213 | assert (p_2 : 214 | Id (rec E_2 (pathscomp0 (pathscomp0 (comp E_1 (f_terminal (g_terminal y))) (e_fg_terminal y)) (pathsinv0 (comp E_1 y))) x_0) 215 | (pathscomp0 (pathscomp0 (comp E_1 (f_terminal (g_terminal y))) (e_fg_terminal y)) (pathsinv0 (comp E_1 y)))). 216 | apply (comp E_2 _). 217 | apply (transportb (fun z => Id _ z) p_2). 218 | change (g_terminal y) with (u_y). 219 | unfold e_fg_terminal. 220 | change (fun _ : X => Y) with E_1. 221 | unfold f_terminal. 222 | set (s := (comp E_1 (u_y x_0))). 223 | set (t := (comp E_1 y)). 224 | apply (transportb (fun z => Id _ z) (pathsinv0 (pathscomp0assoc s t (pathsinv0 t)))). 225 | apply (transportb (fun z => Id _ (pathscomp0 s z)) (pathsinv0r t)). 226 | apply (transportb (fun z => Id _ z) (pathscomp0rid s)). 227 | apply refl. 228 | Defined. 229 | 230 | Definition second_triangular_law_terminal : 231 | forall (y : Y), Id (e_gf_terminal (g_terminal y)) ((maponpaths g_terminal) (e_fg_terminal y)). 232 | Proof. 233 | intros. 234 | set (p := (g_terminal_on_paths_vs_map_on_paths (e_fg_terminal y))). 235 | apply (transportf (fun z => Id (e_gf_terminal (g_terminal y)) z) p). 236 | apply (towards_second_triangular_law_terminal y). 237 | Defined. 238 | 239 | End H_terminal_type. 240 | 241 | (* If we have a type X and a proof of Id(One, X), then X satisfies the axioms for a h-terminal type. 242 | This implies that for every type Y there is an adjoint homotopy equivalence between (X -> Y) and Y *) 243 | 244 | Definition transport_unit : 245 | forall (X : U)(e : Id One X), X. 246 | Proof. 247 | intros. 248 | destruct e. 249 | apply unit. 250 | Defined. 251 | 252 | Definition transport_one_rec : 253 | forall (X : U)(e : Id One X), forall (E : X -> U)(y : E (transport_unit X e))(x : X), E x. 254 | Proof. 255 | intros. 256 | destruct e. 257 | apply (one_rec E y x). 258 | Defined. 259 | 260 | Definition transport_one_beta : 261 | forall (X : U)(e : Id One X), forall (E : X -> U)(y : E (transport_unit X e)), Id (transport_one_rec X e E y (transport_unit X e)) y. 262 | Proof. 263 | intros. 264 | destruct e. 265 | apply (one_beta E y). 266 | Defined. 267 | 268 | (** We now consider a type X that satisfies the axioms for a h-initial type and show that for 269 | every type Y there is is an adjoint homotopy equivalence between (X -> Y) and One *) 270 | 271 | Section Universal_property_of_h_initial. 272 | 273 | Variable X : U. 274 | Variable X_rec : forall (E : X -> U)(x : X), E x. 275 | 276 | Variable Y : U. 277 | 278 | Definition f_initial : (X -> Y) -> One := 279 | fun _ : X -> Y => unit. 280 | 281 | Definition f_initial_on_paths {u u' : X -> Y} : Id u u' -> Id (f_initial u) (f_initial u'). 282 | Proof. 283 | intros u u' e. 284 | apply (refl unit). 285 | Defined. 286 | 287 | Definition f_initial_on_paths_vs_maponpaths {u u' : X -> Y} : forall e : Id u u', Id (f_initial_on_paths e)(maponpaths f_initial e). 288 | Proof. 289 | intros. 290 | destruct e. 291 | apply refl. 292 | Defined. 293 | 294 | Definition g_initial : One -> (X -> Y) := 295 | fun _ : One => (fun x : X => X_rec (fun _ : X => Y) x). 296 | 297 | Definition g_initial_on_paths {x x' : One} : Id x x' -> Id (g_initial x) (g_initial x'). 298 | Proof. 299 | intros x x' e. 300 | unfold g_initial. 301 | apply refl. 302 | Defined. 303 | 304 | Definition g_initial_on_paths_vs_maponpaths {x x' : One} : forall e : Id x x', Id (g_initial_on_paths e) (maponpaths g_initial e). 305 | Proof. 306 | intros. 307 | destruct e. 308 | apply refl. 309 | Defined. 310 | 311 | Definition e_gf_initial : forall u : X -> Y, Id (g_initial ( f_initial u)) u. 312 | Proof. 313 | intros. 314 | apply funextfun. 315 | intro x. 316 | apply (X_rec (fun z => Id (g_initial (f_initial u) z) (u z)) x). 317 | Defined. 318 | 319 | Definition e_fg_initial : forall x : One, Id (f_initial (g_initial x)) x. 320 | Proof. 321 | intros. 322 | unfold f_initial. 323 | apply (one_rec (fun z => Id unit z) (refl unit)). 324 | Defined. 325 | 326 | Definition towards_first_triangular_law_initial : forall u : X -> Y, Id (f_initial_on_paths (e_gf_initial u)) (e_fg_initial (f_initial u)). 327 | Proof. 328 | intro u. 329 | unfold f_initial. 330 | unfold e_fg_initial. 331 | apply (transportb (fun zz => Id (f_initial_on_paths (e_gf_initial u)) zz) (one_beta (fun z : One => Id unit z) (refl unit))). 332 | unfold f_initial_on_paths. 333 | apply refl. 334 | Defined. 335 | 336 | Definition first_triangular_law_initial : forall u : X -> Y, Id (maponpaths f_initial (e_gf_initial u)) (e_fg_initial (f_initial u)). 337 | Proof. 338 | intros. 339 | rewrite (pathsinv0 (f_initial_on_paths_vs_maponpaths (e_gf_initial u))). 340 | apply (towards_first_triangular_law_initial u). 341 | Defined. 342 | 343 | Definition towards_second_triangular_law_initial : forall x : One, Id (e_gf_initial (g_initial x)) (g_initial_on_paths (e_fg_initial x)). 344 | Proof. 345 | intros. 346 | apply pathsinv0. 347 | apply (one_rec (fun z => Id (g_initial_on_paths (e_fg_initial z)) (e_gf_initial (g_initial z)))). 348 | apply (transportb (fun z => Id (g_initial_on_paths z) (e_gf_initial (g_initial unit))) (one_beta (fun z => Id unit z) (refl unit))). 349 | unfold g_initial_on_paths. 350 | unfold g_initial. 351 | set (u := (fun x0 : X => X_rec (fun _ : X => Y) x0)). 352 | unfold e_gf_initial. 353 | assert (p : Id (refl u) (funextfun (g_initial (f_initial u)) u (toforallpaths _ _ _ (refl u) ))). 354 | apply (pathsinv0 (homotinvweqweq (weqtoforallpaths _ (g_initial (f_initial u)) u) (refl u))). 355 | rewrite p. 356 | apply maponpaths. 357 | apply funextsec. 358 | intro xx. 359 | apply (X_rec (fun zz => Id (toforallpaths (fun _ : X => Y) u u (refl u) zz) 360 | (X_rec (fun z : X => Id (g_initial (f_initial u) z) (u z)) zz)) xx). 361 | Defined. 362 | 363 | Definition second_triangular_law_initial : forall x : One, Id (e_gf_initial (g_initial x)) (maponpaths g_initial ( e_fg_initial x)). 364 | Proof. 365 | intros. 366 | apply (transportf (fun z => Id (e_gf_initial (g_initial x)) z) (g_initial_on_paths_vs_maponpaths (e_fg_initial x))). 367 | apply (towards_second_triangular_law_initial x). 368 | Defined. 369 | 370 | End Universal_property_of_h_initial. 371 | 372 | Definition f_zero := f_initial. 373 | Definition g_zero := (g_initial Zero zero_rec). 374 | Definition e_fg_zero := (e_fg_initial Zero zero_rec). 375 | Definition e_gf_zero := (e_gf_initial Zero zero_rec). 376 | Definition first_triangular_law_zero := (first_triangular_law_initial Zero zero_rec). 377 | Definition second_triangular_law_zero := (second_triangular_law_initial Zero zero_rec). 378 | 379 | (** We can transfer the structure to any type propositionally equal to Zero *) 380 | 381 | Definition zero_rec_transfer (X : U)(e : Id Zero X)(E : X -> U)(x : X) : E x. 382 | Proof. 383 | intros. 384 | destruct e. 385 | apply (zero_rec E x). 386 | Defined. 387 | 388 | (* The type-level type Two. *) 389 | 390 | Axiom Two : U. 391 | Axiom false : Two. 392 | Axiom true : Two. 393 | Axiom two_rec : forall (E : Two -> Type)(e_f : E false)(e_t : E true)(x : Two), E x. 394 | Axiom two_beta_f : forall (E : Two -> Type)(e_f : E false)(e_t : E true), Id (two_rec E e_f e_t false) e_f. 395 | Axiom two_beta_t : forall (E : Two -> Type)(e_f : E false)(e_t : E true), Id (two_rec E e_f e_t true) e_t. 396 | 397 | (** Definition of Nat as a W-type *) 398 | 399 | Definition A := Two. 400 | 401 | Definition B : A -> U := 402 | fun x : A => two_rec (fun _ : A => U) Zero One x. 403 | 404 | Definition Nat := W A B. 405 | 406 | (** The propositional computation rules for Two give us proofs that 407 | Zero is propositionally equal to (B l) and One is propositionally 408 | equal to (B r). We will use these paths to transport the structure 409 | of h-initial and h-terminal *) 410 | 411 | Definition e_f : Id Zero (B false). 412 | Proof. 413 | unfold B. 414 | apply (pathsinv0 (two_beta_f (fun _ : A => U) Zero One)). 415 | Defined. 416 | 417 | Definition e_t : Id One (B true). 418 | Proof. 419 | unfold B. 420 | apply (pathsinv0 (two_beta_t (fun _ : A => U) Zero One)). 421 | Defined. 422 | 423 | (** Some notation *) 424 | 425 | Definition B_f := B false. 426 | Definition B_f_rec := (zero_rec_transfer B_f (e_f)). 427 | 428 | Definition B_t := B true. 429 | Definition unit_B_t := transport_unit B_t e_t. 430 | Definition B_t_rec := transport_one_rec B_t e_t. 431 | Definition B_t_comp := transport_one_beta B_t e_t. 432 | 433 | (** We consider the adjoint homotopy equivalence between (B r) -> Nat and Nat *) 434 | 435 | Definition f_B_t := (f_terminal B_t unit_B_t Nat). 436 | Definition g_B_t := (g_terminal B_t unit_B_t B_t_rec Nat). 437 | Definition e_gf_B_t := (e_gf_terminal B_t unit_B_t B_t_rec B_t_comp Nat). 438 | Definition e_fg_B_t := (e_fg_terminal B_t unit_B_t B_t_rec B_t_comp Nat). 439 | Definition first_triangular_law_B_t := (first_triangular_law_terminal B_t unit_B_t B_t_rec B_t_comp Nat). 440 | Definition second_triangular_law_B_t := (second_triangular_law_terminal B_t unit_B_t B_t_rec B_t_comp Nat). 441 | 442 | (** We consider the adjoint homotopy equivalence between (B l) -> Nat and One *) 443 | 444 | Definition f_B_f := ((f_initial B_f Nat) : (B_f -> Nat) -> One). 445 | Definition g_B_f := ((g_initial B_f B_f_rec Nat) : One -> (B_f -> Nat)). 446 | Definition e_gf_B_f := (e_gf_initial B_f B_f_rec Nat). 447 | Definition e_fg_B_f := (e_fg_initial B_f B_f_rec Nat). 448 | Definition first_triangular_law_B_f := (first_triangular_law_initial B_f B_f_rec Nat). 449 | Definition second_triangular_law_B_f := (second_triangular_law_initial B_f B_f_rec Nat). 450 | 451 | Definition zero : Nat := 452 | (sup A B false (g_B_f unit)). 453 | 454 | Definition suc : Nat -> Nat := 455 | fun w : Nat => (sup A B true (g_B_t w)). 456 | 457 | (** To derive the elimination rule, we assume its premisses *) 458 | 459 | Section nat_elim. 460 | 461 | Variable E : Nat -> U. 462 | Variable c : E zero. 463 | Variable d : forall (u : Nat)(y : E u), E (suc u). 464 | 465 | (** We now derive the premisses of the W-elimination rule *) 466 | 467 | Definition e_zero : 468 | forall (u : B_f -> Nat)(v : forall y : B_f, E (u y)), E (sup A B false u). 469 | Proof. 470 | intros. 471 | set (p_u := e_gf_B_f u). 472 | apply (transportf (fun z => E (sup A B false z)) p_u c). 473 | Defined. 474 | 475 | Definition e_suc : 476 | forall (u : B_t -> Nat)(v : forall y : B_t, E (u y)), E (sup A B true u). 477 | Proof. 478 | intros. 479 | set (p_u := e_gf_B_t u). 480 | apply (transportf (fun z => E (sup A B true z)) p_u (d (u unit_B_t) (v unit_B_t))). 481 | Defined. 482 | 483 | Definition e_zero_suc : 484 | forall (x : A)(u : B x -> Nat)(v : forall y : B x, E (u y)), E (sup A B x u). 485 | Proof. 486 | intros. 487 | set (E' := fun x : Two => forall (u : B x -> Nat)(v : forall y : B x, E (u y)), E (sup A B x u)). 488 | apply (two_rec E' (fun u v => (e_zero u v)) (fun u v => (e_suc u v))). 489 | apply v. 490 | Defined. 491 | 492 | (** The elimination rule *) 493 | 494 | Definition nat_rec : forall w : Nat, E w := 495 | fun w : Nat => (w_rec A B E e_zero_suc w). 496 | 497 | (** Derivation of the first computation rules *) 498 | 499 | Definition nat_beta_z : 500 | Id (nat_rec zero) c. 501 | Proof. 502 | intros. 503 | unfold nat_rec. 504 | unfold zero. 505 | set (u := (g_B_f unit)). 506 | apply (transportb (fun z => Id z c) (w_beta A B E e_zero_suc false u)). 507 | set (v := (fun y : B false => w_rec A B E e_zero_suc (u y))). 508 | assert (p : Id (e_zero_suc false u v) (e_zero u v)). 509 | set (E' := fun x : Two => forall (u : B x -> Nat)(v : forall y : B x, E (u y)), E (sup A B x u)). 510 | set (p_1 := ((two_beta_f E' (fun u v => (e_zero u v)) (fun u v => (e_suc u v))))). 511 | set (phi_1 := (toforallpaths _ _ _ p_1)). 512 | set (p_2 := phi_1 u). 513 | set (phi_2 := toforallpaths _ _ _ p_2). 514 | apply (phi_2 v). 515 | apply (transportb (fun z => Id z c) p). 516 | unfold e_zero. 517 | unfold u. 518 | apply (transportb (fun e => Id 519 | (transportf (fun z : B false -> W A B => E (sup A B false z)) e c) c) (second_triangular_law_B_f unit)). 520 | change (W A B) with Nat. 521 | change (B false) with B_f. 522 | change (g_initial B_f B_f_rec Nat) with (g_B_f). 523 | change (e_fg_initial B_f B_f_rec Nat) with (e_fg_B_f). 524 | assert (q : Id (e_fg_B_f unit) (refl unit)). 525 | unfold e_fg_B_t. 526 | unfold e_fg_B_f. 527 | apply (one_beta (fun z : One => Id unit z) (refl unit)). 528 | rewrite q. 529 | unfold maponpaths. 530 | unfold transportf. 531 | simpl. 532 | apply refl. 533 | Defined. 534 | 535 | (** An auxiliary definition *) 536 | 537 | Definition EE := (fun z : (B_t -> Nat) => E (sup A B true z)). 538 | 539 | Definition w_rec_nat := w_rec A B E e_zero_suc. 540 | Definition w_beta_nat := w_beta A B E e_zero_suc. 541 | 542 | (** Two lemmas useful to derive the second computation rule *) 543 | 544 | Definition first_lemma_for_nat_beta : 545 | forall (w w' : Nat)(e : Id w w')(x : E w), 546 | Id (transportf EE (maponpaths g_B_t e) (d w x)) (d w' (transportf E e x)). 547 | Proof. 548 | intros. 549 | destruct e. 550 | apply refl. 551 | Defined. 552 | 553 | Definition second_lemma_for_nat_beta : 554 | forall (w w' : Nat)(e : Id w w'), 555 | Id (d w' (transportf E e (w_rec_nat w))) (d w' (w_rec_nat w')). 556 | Proof. 557 | intros. 558 | destruct e. 559 | apply refl. 560 | Defined. 561 | 562 | (** The second computation rule *) 563 | Definition nat_beta_s : 564 | forall w : Nat, Id (nat_rec (suc w)) (d w (nat_rec w)). 565 | Proof. 566 | intros. 567 | unfold suc. 568 | unfold nat_rec. 569 | apply (transportb (fun z => Id z _) (w_beta_nat true (g_B_t w))). 570 | set (u_w := (g_B_t w)). 571 | set (v_w := (fun y : B true => w_rec_nat (u_w y))). 572 | assert (p : Id (e_zero_suc true u_w v_w) (e_suc u_w v_w)). 573 | set (E' := fun x : Two => forall (u : B x -> Nat)(v : forall y : B x, E (u y)), E (sup A B x u)). 574 | set (p_1 := ((two_beta_t E' (fun u v => (e_zero u v)) (fun u v => (e_suc u v))))). 575 | set (phi_1 := (toforallpaths _ _ _ p_1)). 576 | set (p_2 := phi_1 u_w). 577 | set (phi_2 := toforallpaths _ _ _ p_2). 578 | apply (phi_2 v_w). 579 | change (w_rec A B E e_zero_suc) with w_rec_nat. 580 | apply (transportb (fun z => Id z _) p). 581 | unfold e_suc. 582 | change (fun z : B true -> W A B => E (sup A B true z)) with EE. 583 | change (v_w unit_B_t) with (w_rec_nat (f_B_t (g_B_t w))). 584 | change (u_w unit_B_t) with (f_B_t (g_B_t w)). 585 | unfold u_w. 586 | apply (transportb (fun z => (Id (transportf EE z _) _)) (second_triangular_law_B_t w)). 587 | change (g_terminal B_t unit_B_t B_t_rec Nat) with g_B_t. 588 | change (e_fg_terminal B_t unit_B_t B_t_rec B_t_comp Nat) with (e_fg_B_t). 589 | assert (q_1 : 590 | Id (transportf EE (maponpaths g_B_t (e_fg_B_t w)) (d (f_B_t (g_B_t w)) (w_rec_nat (f_B_t (g_B_t w))))) 591 | (d w (transportf E (e_fg_B_t w) (w_rec_nat (f_B_t (g_B_t w)))))). 592 | apply (first_lemma_for_nat_beta (f_B_t (g_B_t w)) w (e_fg_B_t w) (w_rec_nat (f_B_t (g_B_t w)))). 593 | assert (q_2 : Id 594 | (d w (transportf E (e_fg_B_t w) (w_rec_nat (f_B_t (g_B_t w))))) 595 | (d w (w_rec_nat w))). 596 | apply (second_lemma_for_nat_beta (f_B_t (g_B_t w)) w (e_fg_B_t w)). 597 | apply (pathscomp0 q_1 q_2). 598 | Defined. 599 | 600 | End nat_elim. -------------------------------------------------------------------------------- /LICS2012/nat_as_w_type/o2_as_w_type.v: -------------------------------------------------------------------------------- 1 | (* We show that in the presence of function extensionality, W-types *) 2 | (* allow us to define a type of natural numbers that satisfies the *) 3 | (* usual introduction and elimination rules and a variant of the *) 4 | (* computation rules in which definition equalities are replaced by *) 5 | (* propositional ones *) 6 | 7 | (* The key step is to define propositional equalities expressing the *) 8 | (* eta rule for maps out of the empty and unit type which reduce to *) 9 | (* reflexivity terms when applied to functions that are already in *) 10 | (* eta-expanded form *) 11 | 12 | Add Rec LoadPath "../univalent_foundations/Generalities". 13 | Add Rec LoadPath "../identity". 14 | Add Rec LoadPath "../inductive_types". 15 | Add Rec LoadPath "../nat_as_w_type". 16 | 17 | Unset Automatic Introduction. 18 | 19 | Require Export nat_as_w_type. 20 | Require Export uu0. 21 | Require Export identity. 22 | Require Export zero. 23 | Require Export one. 24 | Require Export two. 25 | Require Export w. 26 | Require Export nat_as_w_type. 27 | 28 | Axiom Three : U. 29 | Axiom left : Three. 30 | Axiom center : Three. 31 | Axiom right : Three. 32 | Axiom three_rec : forall (E : Three -> Type)(e_l : E left)(e_c : E center)(e_r : E right)(x : Three), E x. 33 | Axiom three_beta_l : forall (E : Three -> Type)(e_l : E left)(e_c : E center)(e_r : E right), 34 | Id (three_rec E e_l e_c e_r left)(e_l). 35 | Axiom three_beta_c : forall (E : Three -> Type)(e_l : E left)(e_c : E center)(e_r : E right), 36 | Id (three_rec E e_l e_c e_r center) e_c. 37 | Axiom three_beta_r : forall (E : Three -> Type)(e_l : E left)(e_c : E center)(e_r : E right), 38 | Id (three_rec E e_l e_c e_r right) e_r. 39 | 40 | Definition transport_zero (X : U)(e : Id Nat X) : X. 41 | Proof. 42 | intros. 43 | destruct e. 44 | apply zero. 45 | Defined. 46 | 47 | Definition transport_suc (X : U)(e : Id Nat X) : X -> X. 48 | Proof. 49 | intros X e. 50 | destruct e. 51 | apply suc. 52 | Defined. 53 | 54 | Definition transport_rec (X : U)(e : Id Nat X)(E : X -> U)(c : E (transport_zero X e))(d : forall x : X, E x -> E (transport_suc X e x)) : 55 | forall x : X, E x. 56 | Proof. 57 | intros X e E c d. 58 | destruct e. 59 | apply (nat_rec E c d). 60 | Defined. 61 | 62 | Definition transport_beta_z (X : U)(e : Id Nat X)(E : X -> U)(c : E (transport_zero X e))(d : forall x : X, E x -> E (transport_suc X e x)) : 63 | Id (transport_rec X e E c d (transport_zero X e)) c. 64 | Proof. 65 | intros X e E c d. 66 | destruct e. 67 | apply (nat_beta_z E c d). 68 | Defined. 69 | 70 | Definition transport_beta_s (X : U)(e : Id Nat X)(E : X -> U)(c : E (transport_zero X e))(d : forall x : X, E x -> E (transport_suc X e x)) : 71 | forall x : X, Id (transport_rec X e E c d (transport_suc X e x)) (d x (transport_rec X e E c d x)). 72 | Proof. 73 | intros X e E c d x. 74 | destruct e. 75 | apply (nat_beta_s E c d x). 76 | Defined. 77 | 78 | (* Second number class as a W-type *) 79 | 80 | Definition AA := Three. 81 | 82 | Definition BB : AA -> U := 83 | fun x : AA => (three_rec (fun _ : AA => U) Zero One Nat x). 84 | 85 | Definition o2 := W AA BB. 86 | 87 | (** The propositional computation rules for Bool give us proofs that 88 | Empty is propositionally equal to (B false) and Unit is propositionally 89 | equal to (B true). We will use these paths to transport the structure 90 | of h-initial and h-terminal *) 91 | 92 | Definition e_l : Id Zero (BB left). 93 | Proof. 94 | unfold BB. 95 | apply (pathsinv0 (three_beta_l (fun _ : AA => U) Zero One Nat)). 96 | Defined. 97 | 98 | Definition e_c : Id One (BB center). 99 | Proof. 100 | unfold BB. 101 | apply (pathsinv0 (three_beta_c (fun _ : AA => U) Zero One Nat)). 102 | Defined. 103 | 104 | Definition e_r : Id Nat (BB right). 105 | Proof. 106 | unfold BB. 107 | apply (pathsinv0 (three_beta_r (fun _ : AA => U) Zero One Nat)). 108 | Defined. 109 | 110 | (** Some notation *) 111 | 112 | Definition BB_l := BB left. 113 | Definition BB_c := BB center. 114 | Definition BB_r := BB right. 115 | 116 | (** We transport the structure from Zero to BB_l. *) 117 | 118 | Definition BB_l_rec := (zero_rec_transfer BB_l (e_l)). 119 | 120 | (* The adjoint homotopy equivalence between (BB_l -> o2) and One *) 121 | 122 | Definition f_BB_l := f_initial BB_l o2. 123 | Definition g_BB_l := g_initial BB_l BB_l_rec o2. 124 | Definition e_gf_BB_l := e_gf_initial BB_l BB_l_rec o2. 125 | Definition e_fg_BB_l := e_fg_initial B_f B_f_rec o2. 126 | Definition first_triangular_law_BB_l := first_triangular_law_initial BB_l BB_l_rec o2. 127 | Definition second_triangular_law_BB_l := second_triangular_law_initial BB_l BB_l_rec o2. 128 | 129 | (* We transport the structure from One to BB_c *) 130 | 131 | Definition unit_BB_c := transport_unit BB_c e_c. 132 | Definition BB_c_rec := transport_one_rec BB_c e_c. 133 | Definition BB_c_beta := transport_one_beta BB_c e_c. 134 | 135 | (* The adjoint homotopy equivalence between (BB_c -> o2) and o2 *) 136 | 137 | Definition f_BB_c := (f_terminal BB_c unit_BB_c o2). 138 | Definition g_BB_c := (g_terminal BB_c unit_BB_c BB_c_rec o2). 139 | Definition e_gf_BB_c := (e_gf_terminal BB_c unit_BB_c BB_c_rec BB_c_beta o2). 140 | Definition e_fg_BB_c := (e_fg_terminal BB_c unit_BB_c BB_c_rec BB_c_beta o2). 141 | Definition first_triangular_law_BB_c := (first_triangular_law_terminal BB_c unit_BB_c BB_c_rec BB_c_beta o2). 142 | Definition second_triangular_law_BB_c := (second_triangular_law_terminal BB_c unit_BB_c BB_c_rec BB_c_beta o2). 143 | 144 | (** We transport the structure from Nat to BB_right *) 145 | 146 | Definition zero_BB_r := transport_zero BB_r e_r. 147 | Definition suc_BB_r := transport_suc BB_r e_r. 148 | Definition rec_BB_r := transport_rec BB_r e_r. 149 | Definition BB_r_z := transport_beta_z BB_r e_r. 150 | Definition BB_r_s := transport_beta_s BB_r e_r. 151 | 152 | Definition zero_o2 := 153 | sup _ _ left (g_BB_l unit). 154 | 155 | Definition succ_o2 : o2 -> o2 := 156 | fun w : o2 => (sup AA BB center (g_BB_c w)). 157 | 158 | Definition sup_o2 : (BB_r -> o2) -> o2 := 159 | fun u : (BB_r -> o2) => sup AA BB right u. 160 | 161 | (** Derivation of the elimination and computation rules *) 162 | 163 | Section Elimination_and_computation_rules_for_o2. 164 | 165 | Variable E : o2 -> U. 166 | Variable c : E zero_o2. 167 | Variable d : forall x : o2, E x -> E (succ_o2 x). 168 | Variable e : forall (u : BB_r -> o2)(v : forall y : BB_r, E (u y)), E (sup_o2 u). 169 | 170 | (** We now derive the premisses of the W-elimination rule *) 171 | 172 | Definition e_zero_o2 : 173 | forall (u : BB_l -> o2)(v : forall y : BB_l, E (u y)), E (sup AA BB left u). 174 | Proof. 175 | intros. 176 | set (p_u := e_gf_BB_l u). 177 | apply (transportf (fun z => E (sup AA BB left z)) p_u c). 178 | Defined. 179 | 180 | Definition e_suc_o2 : 181 | forall (u : BB_c -> o2)(v : forall y : BB_c, E (u y)), E (sup AA BB center u). 182 | Proof. 183 | intros. 184 | set (p_u := e_gf_BB_c u). 185 | apply (transportf (fun z => E (sup AA BB center z)) p_u (d (u unit_BB_c) (v unit_BB_c))). 186 | Defined. 187 | 188 | Definition e_sup_o2 : 189 | forall (u : BB_r -> o2)(v : forall y : BB_r, E (u y)), E (sup AA BB right u). 190 | Proof. 191 | intros. 192 | apply (e u v). 193 | Defined. 194 | 195 | Definition e_zero_suc_sup_o2 : 196 | forall (x : AA)(u : BB x -> o2)(v : forall y : BB x, E (u y)), E (sup AA BB x u). 197 | Proof. 198 | intros. 199 | set (E' := fun x : Three => forall (u : BB x -> o2)(v : forall y : BB x, E (u y)), E (sup AA BB x u)). 200 | apply (three_rec E' (fun u v => (e_zero_o2 u v)) (fun u v => (e_suc_o2 u v)) (fun u v => (e_sup_o2 u v))). 201 | apply v. 202 | Defined. 203 | 204 | (** The elimination rule *) 205 | 206 | Definition o2_rec : forall w : o2, E w := 207 | fun w : o2 => (w_rec AA BB E e_zero_suc_sup_o2 w). 208 | 209 | (** Derivation of the first computation rules *) 210 | 211 | Definition first_o2_comp : 212 | Id (o2_rec zero_o2) c. 213 | Proof. 214 | intros. 215 | unfold o2_rec. 216 | unfold zero_o2. 217 | set (u := (g_BB_l unit)). 218 | apply (transportb (fun z => Id z c) (w_beta AA BB E e_zero_suc_sup_o2 left u)). 219 | set (v := (fun y : BB_l => w_rec AA BB E e_zero_suc_sup_o2 (u y))). 220 | assert (p : Id (e_zero_suc_sup_o2 left u v) (e_zero_o2 u v)). 221 | set (E' := fun x : Three => forall (u : BB x -> o2)(v : forall y : BB x, E (u y)), E (sup AA BB x u)). 222 | set (p_1 := ((three_beta_l E' (fun u v => (e_zero_o2 u v)) (fun u v => (e_suc_o2 u v)) (fun u v => (e_sup_o2 u v))))). 223 | set (phi_1 := (toforallpaths _ _ _ p_1)). 224 | set (p_2 := phi_1 u). 225 | set (phi_2 := toforallpaths _ _ _ p_2). 226 | apply (phi_2 v). 227 | apply (transportb (fun z => Id z c) p). 228 | unfold e_zero_o2. 229 | unfold u. 230 | apply (transportb (fun e => Id 231 | (transportf (fun z : BB_l -> W AA BB => E (sup AA BB left z)) e c) c) (second_triangular_law_BB_l unit)). 232 | change (W AA BB) with o2. 233 | change (BB left) with BB_l. 234 | change (g_initial BB_l BB_l_rec o2) with (g_BB_l). 235 | change (e_fg_initial BB_l BB_l_rec o2) with (e_fg_BB_l). 236 | assert (q : Id (e_fg_BB_l unit) (refl unit)). 237 | unfold e_fg_BB_l. 238 | unfold e_fg_BB_l. 239 | apply (one_beta (fun z : One => Id unit z) (refl unit)). 240 | rewrite q. 241 | unfold maponpaths. 242 | unfold transportf. 243 | simpl. 244 | apply refl. 245 | Defined. 246 | 247 | 248 | (* An auxiliary definition *) 249 | 250 | Definition EEE := (fun z : (BB_c -> o2) => E (sup AA BB center z)). 251 | 252 | Definition w_rec_o2 := w_rec AA BB E e_zero_suc_sup_o2. 253 | Definition w_comp_o2 := w_beta AA BB E e_zero_suc_sup_o2. 254 | 255 | (** Two lemmas useful to derive the second computation rule *) 256 | 257 | Definition first_lemma_for_o2_beta : 258 | forall (w w' : o2)(p : Id w w')(x : E w), 259 | Id (transportf EEE (maponpaths g_BB_c p) (d w x)) (d w' (transportf E p x)). 260 | Proof. 261 | intros. 262 | destruct p. 263 | apply refl. 264 | Defined. 265 | 266 | Definition second_lemma_for_o2_beta : 267 | forall (w w' : o2)(p : Id w w'), 268 | Id (d w' (transportf E p (w_rec_o2 w))) (d w' (w_rec_o2 w')). 269 | Proof. 270 | intros. 271 | destruct p. 272 | apply refl. 273 | Defined. 274 | 275 | (** The second computation rule *) 276 | 277 | Definition second_o2_comp : 278 | forall w : o2, Id (o2_rec (succ_o2 w)) (d w (o2_rec w)). 279 | Proof. 280 | intros. 281 | unfold succ_o2. 282 | unfold o2_rec. 283 | apply (transportb (fun z => Id z _) (w_comp_o2 center (g_BB_c w))). 284 | set (u_w := (g_BB_c w)). 285 | set (v_w := (fun y : BB_c => w_rec_o2 (u_w y))). 286 | assert (p : Id (e_zero_suc_sup_o2 center u_w v_w) (e_suc_o2 u_w v_w)). 287 | set (E' := fun x : Three => forall (u : BB x -> o2)(v : forall y : BB x, E (u y)), E (sup AA BB x u)). 288 | set (p_1 := ((three_beta_c E' (fun u v => (e_zero_o2 u v)) (fun u v => (e_suc_o2 u v)) (fun u v => (e_sup_o2 u v))))). 289 | set (phi_1 := (toforallpaths _ _ _ p_1)). 290 | set (p_2 := phi_1 u_w). 291 | set (phi_2 := toforallpaths _ _ _ p_2). 292 | apply (phi_2 v_w). 293 | change (w_rec AA BB E e_zero_suc_sup_o2) with w_rec_o2. 294 | apply (transportb (fun z => Id z _) p). 295 | unfold e_suc_o2. 296 | change (fun z : BB_c -> W AA BB => E (sup AA BB center z)) with EEE. 297 | change (v_w unit_BB_c) with (w_rec_o2 (f_BB_c (g_BB_c w))). 298 | change (u_w unit_BB_c) with (f_BB_c (g_BB_c w)). 299 | unfold u_w. 300 | apply (transportb (fun z => (Id (transportf EEE z _) _)) (second_triangular_law_BB_c w)). 301 | change (g_terminal BB_c unit_BB_c BB_c_rec o2) with g_BB_c. 302 | change (e_fg_terminal BB_c unit_BB_c BB_c_rec BB_c_beta o2) with (e_fg_BB_c). 303 | set (q_1 := (first_lemma_for_o2_beta (f_BB_c (g_BB_c w)) w (e_fg_BB_c w) (w_rec_o2 (f_BB_c (g_BB_c w))))). 304 | set (q_2 := (second_lemma_for_o2_beta (f_BB_c (g_BB_c w)) w (e_fg_BB_c w))). 305 | apply (pathscomp0 q_1 q_2). 306 | Defined. 307 | 308 | Definition third_o2_comp : 309 | forall u : BB_r -> o2, Id (o2_rec (sup_o2 u)) (e u (fun y : BB_r => o2_rec (u y))). 310 | Proof. 311 | intros. 312 | unfold o2_rec. 313 | apply (transportb (fun z => Id z _) (w_beta AA BB E _ right _)). 314 | set (E' := fun x : Three => forall (u : BB x -> o2)(v : forall y : BB x, E (u y)), E (sup AA BB x u)). 315 | set (p_1 := ((three_beta_r E' (fun u v => (e_zero_o2 u v)) (fun u v => (e_suc_o2 u v)) (fun u v => (e_sup_o2 u v))))). 316 | set (phi_1 := (toforallpaths _ _ _ p_1)). 317 | set (p_2 := phi_1 u). 318 | set (phi_2 := toforallpaths _ _ _ p_2). 319 | set (v := (fun y : BB_r => w_rec AA BB E e_zero_suc_sup_o2 (u y))). 320 | apply (phi_2 v). 321 | Defined. 322 | 323 | End Elimination_and_computation_rules_for_o2. -------------------------------------------------------------------------------- /LICS2012/two_is_hinitial/dep_implies_simp.v: -------------------------------------------------------------------------------- 1 | (** Dependent elim + beta for Two 2 | =====> 3 | Simple elim + beta + eta_1 + eta_2 for Two 4 | **) 5 | 6 | Add Rec LoadPath "../univalent_foundations/Generalities". 7 | Add Rec LoadPath "../identity". 8 | Add Rec LoadPath "../inductive_types". 9 | 10 | Require Export identity. 11 | 12 | (* We assume the dependent rules for Two. *) 13 | Require Export two. 14 | 15 | (* The simple rules are just special cases of the dependent ones. *) 16 | Definition two_rec_simp (C : U) (c_f c_t : C) : forall (x : Two), C 17 | := two_rec (fun _ => C) c_f c_t. 18 | 19 | Definition two_beta_simp_f (C : U) (c_f c_t : C) : Id (two_rec_simp C c_f c_t false) c_f 20 | := two_beta_f (fun _ => C) c_f c_t. 21 | 22 | Definition two_beta_simp_t (C : U) (c_f c_t : C) : Id (two_rec_simp C c_f c_t true) c_t 23 | := two_beta_t (fun _ => C) c_f c_t. 24 | 25 | Definition two_eta_simp_1 (C : U) (c_f c_t : C) (h : Two -> C) (p_f : Id (h false) c_f) (p_t : Id (h true) c_t) : 26 | forall (x : Two), Id (h x) (two_rec_simp C c_f c_t x) 27 | := two_eta_1 (fun _ => C) c_f c_t h p_f p_t. 28 | 29 | Definition two_eta_simp_2_l (C : U) (c_f c_t : C) (h : Two -> C) (p_f : Id (h false) c_f) (p_t : Id (h true) c_t) : 30 | Id (two_eta_simp_1 C c_f c_t h p_f p_t false @ two_beta_simp_f C c_f c_t) p_f 31 | := two_eta_2_l (fun _ => C) c_f c_t h p_f p_t. 32 | 33 | Definition two_eta_simp_2_r (C : U) (c_f c_t : C) (h : Two -> C) (p_f : Id (h false) c_f) (p_t : Id (h true) c_t) : 34 | Id (two_eta_simp_1 C c_f c_t h p_f p_t true @ two_beta_simp_t C c_f c_t) p_t 35 | := two_eta_2_r (fun _ => C) c_f c_t h p_f p_t. 36 | -------------------------------------------------------------------------------- /LICS2012/two_is_hinitial/hinitial_implies_simp.v: -------------------------------------------------------------------------------- 1 | (** Homotopy-initial two-algebra 2 | =====> 3 | Simple elim + beta + eta_1 + eta_2 for Two 4 | **) 5 | 6 | Add Rec LoadPath "../univalent_foundations/Generalities". 7 | Add Rec LoadPath "../identity". 8 | 9 | Require Export identity. 10 | Require Export two_algebras. 11 | 12 | (* We assume there exists an h-initial two-algebra. *) 13 | Hypothesis Two : U. 14 | Hypothesis false : Two. 15 | Hypothesis true : Two. 16 | 17 | Parameter two_is_hinitial : two_hinitial Two false true. 18 | 19 | (* We want to derive the simple rules for Two. *) 20 | Section Simp_rules. 21 | 22 | (***********************************************************************) 23 | (***********************************************************************) 24 | 25 | (* Simp elim + beta. *) 26 | 27 | (* Assume the premises of the simp elim and beta rules. *) 28 | Variable C : U. 29 | Variable c_f : C. 30 | Variable c_t : C. 31 | 32 | (* By h-initiality there exists a homomorphism from Two to C. *) 33 | Definition c : TwoHom Two false true C c_f c_t := p1 (two_is_hinitial C c_f c_t). 34 | 35 | Definition two_rec_simp : Two -> C := p1 c. 36 | Definition two_beta_simp_f : Id (two_rec_simp false) c_f := p1 (p2 c). 37 | Definition two_beta_simp_t : Id (two_rec_simp true) c_t := p2 (p2 c). 38 | 39 | (***********************************************************************) 40 | (***********************************************************************) 41 | 42 | (* First- and second-order eta. *) 43 | 44 | (* Assume the additional premises for the eta rules. *) 45 | Variable u : Two -> C. 46 | Variable p_f : Id (u false) c_f. 47 | Variable p_t : Id (u true) c_t. 48 | 49 | (* This gives us another homomorphism from Two to C. *) 50 | Definition h : TwoHom Two false true C c_f c_t 51 | := dpair (P Two false true C c_f c_t) u (pair p_f p_t). 52 | 53 | (* By h-initiality h is propositionally equal to c and hence we have 54 | a 2-cell from h to c. *) 55 | Definition cell : TwoCell h c. 56 | Proof. 57 | apply prop_eq_to_two_cell. 58 | apply (p2 (two_is_hinitial C c_f c_t) h). 59 | Defined. 60 | 61 | Definition two_eta_simp_1 : forall (x : Two), Id (u x) (two_rec_simp x) 62 | := p1 cell. 63 | 64 | Definition two_eta_simp_2_f : Id (two_eta_simp_1 false @ two_beta_simp_f) p_f 65 | := p1 (p2 cell). 66 | 67 | Definition two_eta_simp_2_t : Id (two_eta_simp_1 true @ two_beta_simp_t) p_t 68 | := p2 (p2 cell). 69 | 70 | End Simp_rules. -------------------------------------------------------------------------------- /LICS2012/two_is_hinitial/simp_implies_dep.v: -------------------------------------------------------------------------------- 1 | (** Simple elim + beta + eta_1 + eta_2 for Two 2 | =====> 3 | Dependent elim + beta for Two 4 | **) 5 | 6 | Add Rec LoadPath "../univalent_foundations/Generalities". 7 | Add Rec LoadPath "../identity". 8 | 9 | Require Export identity. 10 | 11 | (* We assume the simple rules for Two. *) 12 | Require Export two_simp. 13 | 14 | (* We derive the dep elim and beta rules. *) 15 | Section Dep_rules. 16 | 17 | (* We assume the premises of the dep elim and beta rules. *) 18 | Variable E : Two -> U. 19 | Variable e_f : E false. 20 | Variable e_t : E true. 21 | 22 | (***********************************************************************) 23 | (***********************************************************************) 24 | 25 | (* To obtain dep elim, we use simple elim with the type below. *) 26 | Definition C : U := Sigma E. 27 | 28 | (* For this we supply the terms below. *) 29 | Definition c_f : C := dpair E false e_f. 30 | Definition c_t : C := dpair E true e_t. 31 | 32 | (* This gives us the following terms. *) 33 | Definition u : Two -> C := two_rec_simp C c_f c_t. 34 | 35 | Definition u_1 (x : Two) : Two := p1 (u x). 36 | Definition u_2 (x : Two) : E (u_1 x) := p2 (u x). 37 | 38 | (* Using simple beta on the term u constructed above yields the following. *) 39 | Definition p_f : Id (u false) c_f := two_beta_simp_f C c_f c_t. 40 | Definition p_t : Id (u true) c_t := two_beta_simp_t C c_f c_t. 41 | 42 | (* Homotopy in a Sigma type is equivalent to a pair of homotopies in their 43 | respective component types: *) 44 | 45 | (* Homotopy of functions. *) 46 | Definition q_f_1 : Id (u_1 false) false := dp1id p_f. 47 | Definition q_t_1 : Id (u_1 true) true := dp1id p_t. 48 | 49 | (* Homotopy of proofs. *) 50 | Definition q_f_2 : Id (transport E q_f_1 (u_2 false)) e_f := dp2id p_f. 51 | Definition q_t_2 : Id (transport E q_t_1 (u_2 true)) e_t := dp2id p_t. 52 | 53 | (***********************************************************************) 54 | (***********************************************************************) 55 | 56 | (* We now want to show that the function u_1 defined above is 57 | propositionally equal to the identity function on Two. *) 58 | 59 | (* Using first-order simple eta twice gives us the terms below. *) 60 | Definition alpha_1 (x : Two) : Id (u_1 x) (two_rec_simp Two false true x) 61 | := two_eta_simp_1 Two false true u_1 q_f_1 q_t_1 x. 62 | 63 | Definition alpha_2 (x : Two) : Id x (two_rec_simp Two false true x) 64 | := two_eta_simp_1 Two false true (idfun Two) (refl false) (refl true) x. 65 | 66 | Definition alpha (x : Two) : Id (u_1 x) x := (alpha_1 x) @ (alpha_2 x)!. 67 | 68 | (* Using second-order simple eta on alpha_1 and alpha_2 gives us the following. *) 69 | Definition gamma_1_f : Id (alpha_1 false @ two_beta_simp_f Two false true) q_f_1 70 | := two_eta_simp_2_f Two false true u_1 q_f_1 q_t_1. 71 | 72 | Definition gamma_1_t : Id (alpha_1 true @ two_beta_simp_t Two false true) q_t_1 73 | := two_eta_simp_2_t Two false true u_1 q_f_1 q_t_1. 74 | 75 | Definition gamma_2_f : Id (alpha_2 false @ two_beta_simp_f Two false true) (refl false) 76 | := two_eta_simp_2_f Two false true (idfun Two) (refl false) (refl true). 77 | 78 | Definition gamma_2_t : Id (alpha_2 true @ two_beta_simp_t Two false true) (refl true) 79 | := two_eta_simp_2_t Two false true (idfun Two) (refl false) (refl true). 80 | 81 | Definition gamma_f : Id (alpha false) q_f_1. 82 | Proof. 83 | apply trans with (b := alpha_1 false @ two_beta_simp_f Two false true). 84 | apply concat_cong_left. 85 | apply cancel_left_from_id. 86 | apply gamma_2_f. 87 | apply gamma_1_f. 88 | Defined. 89 | 90 | Definition gamma_t : Id (alpha true) q_t_1. 91 | Proof. 92 | apply trans with (b := alpha_1 true @ two_beta_simp_t Two false true). 93 | apply concat_cong_left. 94 | apply cancel_left_from_id. 95 | apply gamma_2_t. 96 | apply gamma_1_t. 97 | Defined. 98 | 99 | (***********************************************************************) 100 | (***********************************************************************) 101 | 102 | (* Dep elim. *) 103 | Definition two_rec_dep (x : Two) : E x := transport E (alpha x) (u_2 x). 104 | 105 | (* Dep beta. *) 106 | Definition two_beta_dep_f : Id (two_rec_dep false) e_f. 107 | Proof. 108 | unfold two_rec_dep. 109 | apply trans with (b := transport E (q_f_1) (u_2 false)). 110 | apply appid. 111 | apply transport_cong. 112 | apply gamma_f. 113 | apply q_f_2. 114 | Defined. 115 | 116 | Definition beta_dep_t : Id (two_rec_dep true) e_t. 117 | Proof. 118 | unfold two_rec_dep. 119 | apply trans with (b := transport E (q_t_1) (u_2 true)). 120 | apply appid. 121 | apply transport_cong. 122 | apply gamma_t. 123 | apply q_t_2. 124 | Defined. 125 | 126 | End Dep_rules. -------------------------------------------------------------------------------- /LICS2012/two_is_hinitial/simp_implies_hinitial.v: -------------------------------------------------------------------------------- 1 | (** Simple elim + beta + eta_1 + eta_2 for Two 2 | =====> 3 | Homotopy-initial two-algebra. 4 | **) 5 | 6 | Add Rec LoadPath "../univalent_foundations/Generalities". 7 | Add Rec LoadPath "../identity". 8 | 9 | Require Export identity. 10 | Require Export two_algebras. 11 | 12 | (* We assume the simple rules for Two. *) 13 | Require Export two_simp. 14 | 15 | (* We want to show the two-algebra (Two,l,r) is h-initial. *) 16 | Section Two_is_h_initial. 17 | 18 | (* Take another two-algebra. *) 19 | Variable C : U. 20 | Variable c_f : C. 21 | Variable c_t : C. 22 | 23 | (***********************************************************************) 24 | (***********************************************************************) 25 | 26 | (* We want to show the type of homomorphisms from Two to C is contractible. *) 27 | 28 | (* Simp elim and beta determine the center of contraction. *) 29 | Definition u : Two -> C := two_rec_simp C c_f c_t. 30 | Definition p_f : Id (u false) c_f := two_beta_simp_f C c_f c_t. 31 | Definition p_t : Id (u true) c_t := two_beta_simp_t C c_f c_t. 32 | 33 | Definition c : TwoHom Two false true C c_f c_t 34 | := dpair (P Two false true C c_f c_t) u (pair p_f p_t). 35 | 36 | Section Contractibility. 37 | 38 | (* Take another homomorphism. *) 39 | Variable h : TwoHom Two false true C c_f c_t. 40 | 41 | (* First- and second order eta determine a 2-cell from h to c. *) 42 | Definition alpha : forall (x : Two), Id (p1 h x) (u x) 43 | := two_eta_simp_1 C c_f c_t (p1 h) (p1 (p2 h)) (p2 (p2 h)). 44 | 45 | Definition gamma_f : Id (alpha false @ p_f) (p1 (p2 h)) 46 | := two_eta_simp_2_f C c_f c_t (p1 h) (p1 (p2 h)) (p2 (p2 h)). 47 | 48 | Definition gamma_t : Id (alpha true @ p_t) (p2 (p2 h)) 49 | := two_eta_simp_2_t C c_f c_t (p1 h) (p1 (p2 h)) (p2 (p2 h)). 50 | 51 | End Contractibility. 52 | 53 | (***********************************************************************) 54 | (***********************************************************************) 55 | 56 | (* We thus have h-initiality as desired. *) 57 | Lemma two_is_hinitial : iscontr (TwoHom Two false true C c_f c_t). 58 | Proof. 59 | split with c. 60 | intro h. 61 | apply two_cell_to_prop_eq. 62 | split with (alpha h). 63 | split. 64 | apply (gamma_f h). 65 | apply (gamma_t h). 66 | Defined. 67 | 68 | End Two_is_h_initial. -------------------------------------------------------------------------------- /LICS2012/two_is_hinitial/two_algebras.v: -------------------------------------------------------------------------------- 1 | (** Homotopy-initial two-algebras. **) 2 | 3 | Add Rec LoadPath "../univalent_foundations/Generalities". 4 | Add Rec LoadPath "../identity". 5 | 6 | Require Export identity. 7 | 8 | (* A two-algebra consists of a type C and two terms (c_f c_t : C). *) 9 | 10 | (* The type of two-algebra homomorphisms. *) 11 | Definition TwoHom (C : U) (c_f c_t : C) (D : U) (d_f d_t : D) : U 12 | := Sigma (fun f : C -> D => Prod (Id (f c_f) d_f) (Id (f c_t) d_t)). 13 | 14 | (* The type of two-algebra 2-cells. *) 15 | Definition TwoCell {C : U} {c_f c_t : C} {D : U} {d_f d_t : D} (h_1 h_2 : TwoHom C c_f c_t D d_f d_t) : U 16 | := Sigma (fun p : forall (x : C), Id (p1 h_1 x) (p1 h_2 x) => 17 | Prod (Id ((p c_f) @ (p1 (p2 h_2))) (p1 (p2 h_1))) 18 | (Id ((p c_t) @ (p2 (p2 h_2))) (p2 (p2 h_1)))). 19 | 20 | (* Homotopy-initial two-algebras *) 21 | Definition two_hinitial (C : U) (c_f c_t : C) : Type 22 | := forall (D : U) (d_f d_t : D), iscontr (TwoHom C c_f c_t D d_f d_t). 23 | 24 | (***********************************************************************) 25 | (***********************************************************************) 26 | 27 | (** Given two-algebra homomorphisms h_1 h_2, they are propositionally equal 28 | iff there exists a 2-cell between them. **) 29 | 30 | Section TwoCells. 31 | 32 | (* Fix two-algebras C and D. *) 33 | Variable C : U. 34 | Variable c_f : C. 35 | Variable c_t : C. 36 | 37 | Variable D : U. 38 | Variable d_f : D. 39 | Variable d_t : D. 40 | 41 | (* Fix two-algebra homomorphisms h_1 and h_2. *) 42 | Variable h_1 h_2 : TwoHom C c_f c_t D d_f d_t. 43 | 44 | (***********************************************************************) 45 | (***********************************************************************) 46 | 47 | (* Some preliminary definitions and lemmas. *) 48 | Section Prelim. 49 | 50 | Definition F_f : (C -> D) -> D := fun f : C -> D => f c_f. 51 | Definition F_t : (C -> D) -> D := fun f : C -> D => f c_t. 52 | 53 | Definition G_f : (C -> D) -> D := fun _ : C -> D => d_f. 54 | Definition G_t : (C -> D) -> D := fun _ : C -> D => d_t. 55 | 56 | Definition Q_f := fun f => Id (f c_f) d_f. 57 | Definition Q_t := fun f => Id (f c_t) d_t. 58 | 59 | Definition P := fun f => Prod (Q_f f) (Q_t f). 60 | 61 | (***********************************************************************) 62 | (***********************************************************************) 63 | 64 | Lemma mapid_F_f (f g : C -> D) (p : Id f g) : 65 | Id (mapid F_f p) (appid p c_f). 66 | Proof. 67 | apply trans with (b := appid (mapid (@id (C -> D)) p) c_f). 68 | apply mapid_app_to_const with (N := c_f) (M := @id (C -> D)). 69 | apply @dappid with (g := appid p). 70 | apply appid_cong. 71 | apply mapid_id. 72 | Defined. 73 | 74 | Lemma mapid_F_t (f g : C -> D) (p : Id f g) : 75 | Id (mapid F_t p) (appid p c_t). 76 | Proof. 77 | apply trans with (b := appid (mapid (@id (C -> D)) p) c_t). 78 | apply mapid_app_to_const with (N := c_t) (M := @id (C -> D)). 79 | apply @dappid with (g := appid p). 80 | apply appid_cong. 81 | apply mapid_id. 82 | Defined. 83 | 84 | Lemma mapid_G_f (f g : C -> D) (p : Id f g) : 85 | Id (mapid G_f p) (refl d_f). 86 | Proof. 87 | apply mapid_const. 88 | Defined. 89 | 90 | Lemma mapid_G_t (f g : C -> D) (p : Id f g) : 91 | Id (mapid G_t p) (refl d_t). 92 | Proof. 93 | apply mapid_const. 94 | Defined. 95 | 96 | (***********************************************************************) 97 | (***********************************************************************) 98 | 99 | Lemma transport_P {f g : C -> D} (p : Id f g) : 100 | Id (transport P p) 101 | (fun q => pair ((appid p c_f)! @ p1 q) ((appid p c_t)! @ p2 q)). 102 | Proof. 103 | apply trans with (b := 104 | fun q : P f => pair (transport Q_f p (p1 q)) (transport Q_t p (p2 q))). 105 | apply transport_prod. 106 | apply funext. 107 | intro q. 108 | apply prodext. 109 | simpl. 110 | split. 111 | 112 | apply trans with (b := (mapid F_f p)! @ p1 q @ mapid G_f p). 113 | apply @appid with (g := 114 | fun q_f : Q_f f => (mapid F_f p)! @ q_f @ mapid G_f p). 115 | apply @transport_id with (f := F_f) (g := G_f). 116 | apply trans with (b := (mapid F_f p)! @ p1 q @ refl d_f). 117 | apply concat_cong_left. 118 | apply mapid_G_f. 119 | apply trans with (b := (mapid F_f p)! @ p1 q). 120 | apply refl_right_id. 121 | apply concat_cong_right. 122 | apply inv_cong. 123 | apply mapid_F_f. 124 | 125 | apply trans with (b := (mapid F_t p)! @ p2 q @ mapid G_t p). 126 | apply @appid with (g := 127 | fun q_t : Q_t f => (mapid F_t p)! @ q_t @ mapid G_t p). 128 | apply @transport_id with (f := F_t) (g := G_t). 129 | apply trans with (b := (mapid F_t p)! @ p2 q @ refl d_t). 130 | apply concat_cong_left. 131 | apply mapid_G_t. 132 | apply trans with (b := (mapid F_t p)! @ p2 q). 133 | apply refl_right_id. 134 | apply concat_cong_right. 135 | apply inv_cong. 136 | apply mapid_F_t. 137 | Defined. 138 | 139 | End Prelim. 140 | 141 | (***********************************************************************) 142 | (***********************************************************************) 143 | 144 | (* Prop equality between h_1 and h_2 ====> Two-algebra 2-cell from h_1 to h_2. *) 145 | Lemma prop_eq_to_two_cell : Id h_1 h_2 -> TwoCell h_1 h_2. 146 | Proof. 147 | intros e. 148 | destruct e. 149 | split with (fun x => refl (p1 h_1 x)). 150 | split. 151 | apply refl. 152 | apply refl. 153 | Defined. 154 | 155 | (* Two-algebra 2-cell from h_1 to h_2 ====> Prop equality between h_1 and h_2. *) 156 | Lemma two_cell_to_prop_eq : TwoCell h_1 h_2 -> Id h_1 h_2. 157 | Proof. 158 | intros e. 159 | destruct e as [p q]. 160 | set (p' := funext (p1 h_1) (p1 h_2) p). 161 | apply dprodext. 162 | split with p'. 163 | 164 | apply trans with (b := 165 | pair ((appid p' c_f)! @ p1 (p2 h_1)) ((appid p' c_t)! @ p2 (p2 h_1))). 166 | apply @appid with (g := fun q' : P (p1 h_1) => 167 | pair ((appid p' c_f)! @ p1 q') ((appid p' c_t)! @ p2 q')). 168 | apply transport_P. 169 | apply prodext. 170 | split. 171 | 172 | change (p1 (pair (appid p' c_f ! @ p1 (p2 h_1)) (appid p' c_t ! @ p2 (p2 h_1)))) with 173 | (appid p' c_f ! @ p1 (p2 h_1)). 174 | apply cancel_left. 175 | apply sym. 176 | apply trans with (b := p c_f @ p1 (p2 h_2)). 177 | apply concat_cong_right. 178 | apply dappid with (g := p). 179 | apply appid_funext. 180 | apply (p1 q). 181 | 182 | change (p2 (pair (appid p' c_f ! @ p1 (p2 h_1)) (appid p' c_t ! @ p2 (p2 h_1)))) with 183 | (appid p' c_t ! @ p2 (p2 h_1)). 184 | apply cancel_left. 185 | apply sym. 186 | apply trans with (b := p c_t @ p2 (p2 h_2)). 187 | apply concat_cong_right. 188 | apply dappid with (g := p). 189 | apply appid_funext. 190 | apply (p2 q). 191 | Defined. 192 | 193 | End TwoCells. -------------------------------------------------------------------------------- /LICS2012/two_is_hinitial/two_simp.v: -------------------------------------------------------------------------------- 1 | (** Simple (non-dependent) rules for the inductive type Two. Eta rules are no 2 | longer derivable and hence are included as axioms. **) 3 | 4 | Add Rec LoadPath "../univalent_foundations/Generalities". 5 | Add Rec LoadPath "../identity". 6 | 7 | Require Export identity. 8 | 9 | (* Formation rule. *) 10 | Axiom Two : U. 11 | 12 | (* Introduction rules. *) 13 | Axiom false : Two. 14 | Axiom true : Two. 15 | 16 | (* Elimination rule. *) 17 | Axiom two_rec_simp : forall (C : U) (c_f c_t : C) (x : Two), C. 18 | 19 | (* Beta rules. *) 20 | Axiom two_beta_simp_f : forall (C : U) (c_f c_t : C), 21 | Id (two_rec_simp C c_f c_t false) c_f. 22 | 23 | Axiom two_beta_simp_t : forall (C : U) (c_f c_t : C), 24 | Id (two_rec_simp C c_f c_t true) c_t. 25 | 26 | (* First-order eta-rule. *) 27 | Axiom two_eta_simp_1 : forall (C : U) (c_f c_t : C) (h : Two -> C) (p_f : Id (h false) c_f) (p_t : Id (h true) c_t) 28 | (x : Two), Id (h x) (two_rec_simp C c_f c_t x). 29 | 30 | (* Second-order eta-rules. *) 31 | Axiom two_eta_simp_2_f : forall (C : U) (c_f c_t : C) (h : Two -> C) (p_f : Id (h false) c_f) (p_t : Id (h true) c_t), 32 | Id (two_eta_simp_1 C c_f c_t h p_f p_t false @ two_beta_simp_f C c_f c_t) p_f. 33 | 34 | Axiom two_eta_simp_2_t : forall (C : U) (c_f c_t : C) (h : Two -> C) (p_f : Id (h false) c_f) (p_t : Id (h true) c_t), 35 | Id (two_eta_simp_1 C c_f c_t h p_f p_t true @ two_beta_simp_t C c_f c_t) p_t. 36 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/Coq_patches/README: -------------------------------------------------------------------------------- 1 | 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. 2 | 3 | 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. 4 | 5 | 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: 6 | 7 | [ Inductive Ind ( a1 : A1 ) : forall a2 : A2 , Type := ... ] 8 | 9 | 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. 10 | 11 | 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. 12 | 13 | Dan's patches have the following functions (see also comments in the individual patches): 14 | 15 | 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. 16 | 17 | 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 buf will be located and removed in the next update. 18 | 19 | 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 ] . 20 | 21 | 22 | 4. "grayson-fix-infinite-loop.patch" fixes another hanging situation. 23 | 24 | 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): 25 | 26 | 27 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ ./configure --prefix /opt/local 28 | You have GNU Make >= 3.81. Good! 29 | You have Objective-Caml 3.11.2. Good! 30 | LablGtk2 not found: CoqIde will not be available. 31 | pngtopnm was not found; documentation will not be available 32 | 33 | Coq top directory : /Applications/coq-8.3pl2_two_patches_and_Dan_3 34 | Architecture : i386 35 | Coq VM bytecode link flags : -custom 36 | Coq tools bytecode link flags : -custom 37 | OS dependent libraries : -cclib -lunix 38 | Objective-Caml/Camlp4 version : 3.11.2 39 | Objective-Caml/Camlp4 binaries in : /opt/local/bin 40 | Objective-Caml library in : /opt/local/lib/ocaml 41 | Camlp4 library in : +camlp5 42 | Native dynamic link support : true 43 | Documentation : None 44 | CoqIde : no 45 | Web browser : firefox -remote "OpenURL(%s,new-tab)" || firefox %s & 46 | Coq web site : http://coq.inria.fr/ 47 | 48 | Paths for true installation: 49 | binaries will be copied in /opt/local/bin 50 | library will be copied in /opt/local/lib/coq 51 | man pages will be copied in /opt/local/man 52 | documentation will be copied in /opt/local/share/doc/coq 53 | emacs mode will be copied in /opt/local/share/emacs/site-lisp 54 | 55 | If anything in the above is wrong, please restart './configure'. 56 | 57 | *Warning* To compile the system for a new architecture 58 | don't forget to do a 'make archclean' before './configure'. 59 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p1 < inductive-indice-levels-matter-8.3.patch 60 | patching file kernel/indtypes.ml 61 | patching file kernel/inductive.ml 62 | patching file kernel/inductive.mli 63 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p3 < patch.type-in-type 64 | patching file kernel/reduction.ml 65 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < fix-hanging-at-end-of-proof.patch 66 | patching file kernel/closure.ml 67 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < grayson-fix-infinite-loop.patch 68 | patching file ./tactics/tactics.ml 69 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < grayson-improved-abstraction-version2-8.3pl2.patch 70 | patching file ./configure 71 | patching file ./pretyping/evd.ml 72 | patching file ./pretyping/evd.mli 73 | patching file ./pretyping/pretype_errors.ml 74 | patching file ./pretyping/pretype_errors.mli 75 | patching file ./pretyping/unification.ml 76 | patching file ./pretyping/unification.mli 77 | patching file ./proofs/logic.ml 78 | patching file ./tactics/tactics.ml 79 | patching file ./test-suite/success/unification.v 80 | patching file ./test-suite/success/unification2.v 81 | patching file ./toplevel/himsg.ml 82 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ 83 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ patch -p0 < grayson-closedir-after-opendir.patch 84 | patching file ./lib/system.ml 85 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ sudo make GOTO_STAGE=2 coqbinaries states 86 | .... 87 | fuld-220:coq-8.3pl2_two_patches_and_Dan_3 vladimir$ sudo make install . 88 | 89 | 90 | (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. ) 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/Coq_patches/fix-hanging-at-end-of-proof.patch: -------------------------------------------------------------------------------- 1 | diff -ub coq-8.3pl2-clean/kernel/closure.ml coq-8.3pl2-no-universe-constraints--index-levels-matter/kernel/closure.ml 2 | --- kernel/closure.ml 2010-07-28 07:22:04.000000000 -0500 3 | +++ kernel/closure.ml 2011-10-03 14:48:17.000000000 -0500 4 | @@ -17,7 +17,7 @@ 5 | open Esubst 6 | 7 | let stats = ref false 8 | -let share = ref true 9 | +let share = ref false 10 | 11 | (* Profiling *) 12 | let beta = ref 0 13 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/Coq_patches/grayson-closedir-after-opendir.patch: -------------------------------------------------------------------------------- 1 | This patch will leave many few file descriptors unclosed. 2 | 3 | Dan Grayson 4 | 5 | diff -ur ../coq-8.3pl2-clean/lib/system.ml ./lib/system.ml 6 | --- ../coq-8.3pl2-clean/lib/system.ml 2010-12-24 03:55:54.000000000 -0600 7 | +++ ./lib/system.ml 2011-10-14 12:49:30.000000000 -0500 8 | @@ -103,7 +103,7 @@ 9 | (* All subdirectories, recursively *) 10 | 11 | let exists_dir dir = 12 | - try let _ = opendir dir in true with Unix_error _ -> false 13 | + try let _ = closedir (opendir dir) in true with Unix_error _ -> false 14 | 15 | let skipped_dirnames = ref ["CVS"; "_darcs"] 16 | 17 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/Coq_patches/grayson-fix-infinite-loop.patch: -------------------------------------------------------------------------------- 1 | This "fixes" a seemingly infinite loop by abandoning the routine after ten repetitions. 2 | A better fix would involve understanding what the code was supposed to do. 3 | 4 | Dan Grayson 5 | 6 | diff -ubr ../coq-8.3pl2-clean/tactics/tactics.ml ./tactics/tactics.ml 7 | --- ../coq-8.3pl2-clean/tactics/tactics.ml 2011-04-08 11:59:26.000000000 -0500 8 | +++ ./tactics/tactics.ml 2011-10-07 09:55:24.000000000 -0500 9 | @@ -522,7 +522,10 @@ 10 | 11 | let pf_lookup_hypothesis_as_renamed_gen red h gl = 12 | let env = pf_env gl in 13 | + let infinite_loop_detector = ref 0 in 14 | let rec aux ccl = 15 | + incr infinite_loop_detector; 16 | + if !infinite_loop_detector > 10 then raise Redelimination; 17 | match pf_lookup_hypothesis_as_renamed env ccl h with 18 | | None when red -> 19 | aux 20 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/Coq_patches/grayson-improved-abstraction-version2-8.3pl2.patch: -------------------------------------------------------------------------------- 1 | diff -ur ../coq-8.3pl2-patched/configure ./configure 2 | --- ../coq-8.3pl2-patched/configure 2011-04-19 02:19:00.000000000 -0500 3 | +++ ./configure 2011-09-12 18:25:27.000000000 -0500 4 | @@ -6,7 +6,7 @@ 5 | # 6 | ################################## 7 | 8 | -VERSION=8.3pl2 9 | +VERSION=8.3pl2+improved-abstraction 10 | VOMAGIC=08300 11 | STATEMAGIC=58300 12 | DATE=`LANG=C date +"%B %Y"` 13 | @@ -323,8 +323,8 @@ 14 | if [ "$MAKE" != "" ]; then 15 | MAKEVERSION=`$MAKE -v | head -1` 16 | case $MAKEVERSION in 17 | - "GNU Make 3.8"[12]) 18 | - echo "You have GNU Make >= 3.81. Good!";; 19 | + "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].* ) 20 | + echo "You have GNU Make $MAKEVERSION >= 3.81. Good!";; 21 | *) 22 | OK="no" 23 | if [ -x ./make ]; then 24 | diff -ur ../coq-8.3pl2-patched/pretyping/evd.ml ./pretyping/evd.ml 25 | --- ../coq-8.3pl2-patched/pretyping/evd.ml 2011-03-10 09:50:24.000000000 -0600 26 | +++ ./pretyping/evd.ml 2011-09-11 06:30:25.000000000 -0500 27 | @@ -675,6 +675,11 @@ 28 | metas = Metamap.add mv (Clval(na,(mk_freelisted v,pb),ty)) evd.metas } 29 | | _ -> anomaly "meta_reassign: not yet defined" 30 | 31 | +let meta_unassign mv evd = 32 | + match Metamap.find mv evd.metas with 33 | + | Clval(na,_,ty) -> { evd with metas = Metamap.add mv (Cltyp(na,ty)) evd.metas } 34 | + | _ -> anomaly "meta_unassign: not yet defined" 35 | + 36 | (* If the meta is defined then forget its name *) 37 | let meta_name evd mv = 38 | try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous 39 | diff -ur ../coq-8.3pl2-patched/pretyping/evd.mli ./pretyping/evd.mli 40 | --- ../coq-8.3pl2-patched/pretyping/evd.mli 2011-03-10 09:50:24.000000000 -0600 41 | +++ ./pretyping/evd.mli 2011-09-11 06:30:39.000000000 -0500 42 | @@ -224,6 +224,7 @@ 43 | metavariable -> types -> ?name:name -> evar_map -> evar_map 44 | val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map 45 | val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map 46 | +val meta_unassign : metavariable -> evar_map -> evar_map 47 | 48 | (* [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) 49 | val meta_merge : evar_map -> evar_map -> evar_map 50 | diff -ur ../coq-8.3pl2-patched/pretyping/pretype_errors.ml ./pretyping/pretype_errors.ml 51 | --- ../coq-8.3pl2-patched/pretyping/pretype_errors.ml 2010-07-24 10:57:30.000000000 -0500 52 | +++ ./pretyping/pretype_errors.ml 2011-09-13 16:23:06.000000000 -0500 53 | @@ -34,6 +34,7 @@ 54 | | CannotGeneralize of constr 55 | | NoOccurrenceFound of constr * identifier option 56 | | CannotFindWellTypedAbstraction of constr * constr list 57 | + | CannotFindAbstraction of Evd.evar_map * constr * constr list * string 58 | | AbstractionOverMeta of name * name 59 | | NonLinearUnification of name * constr 60 | (* Pretyping *) 61 | @@ -178,6 +179,9 @@ 62 | let error_cannot_find_well_typed_abstraction env sigma p l = 63 | raise (PretypeError (env_ise sigma env,CannotFindWellTypedAbstraction (p,l))) 64 | 65 | +let error_cannot_find_abstraction env sigma c l msg = 66 | + raise (PretypeError (env_ise sigma env,CannotFindAbstraction (sigma,c,l,msg))) 67 | + 68 | let error_abstraction_over_meta env sigma hdmeta metaarg = 69 | let m = Evd.meta_name sigma hdmeta and n = Evd.meta_name sigma metaarg in 70 | raise (PretypeError (env_ise sigma env,AbstractionOverMeta (m,n))) 71 | diff -ur ../coq-8.3pl2-patched/pretyping/pretype_errors.mli ./pretyping/pretype_errors.mli 72 | --- ../coq-8.3pl2-patched/pretyping/pretype_errors.mli 2010-07-24 10:57:30.000000000 -0500 73 | +++ ./pretyping/pretype_errors.mli 2011-09-13 16:22:42.000000000 -0500 74 | @@ -35,6 +35,7 @@ 75 | | CannotGeneralize of constr 76 | | NoOccurrenceFound of constr * identifier option 77 | | CannotFindWellTypedAbstraction of constr * constr list 78 | + | CannotFindAbstraction of Evd.evar_map * constr * constr list * string 79 | | AbstractionOverMeta of name * name 80 | | NonLinearUnification of name * constr 81 | (* Pretyping *) 82 | @@ -107,6 +108,9 @@ 83 | val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map -> 84 | constr -> constr list -> 'b 85 | 86 | +val error_cannot_find_abstraction : env -> Evd.evar_map -> 87 | + constr -> constr list -> string -> 'b 88 | + 89 | val error_abstraction_over_meta : env -> Evd.evar_map -> 90 | metavariable -> metavariable -> 'b 91 | 92 | diff -ur ../coq-8.3pl2-patched/pretyping/unification.ml ./pretyping/unification.ml 93 | --- ../coq-8.3pl2-patched/pretyping/unification.ml 2010-07-26 17:12:43.000000000 -0500 94 | +++ ./pretyping/unification.ml 2011-09-13 17:03:34.000000000 -0500 95 | @@ -28,6 +28,109 @@ 96 | open Coercion.Default 97 | open Recordops 98 | 99 | +let rec take n x = 100 | + if n = 0 then [] else 101 | + match x with 102 | + [] -> raise Not_found 103 | + | e::x -> e::(take (n-1) x) 104 | + 105 | +let rec last x = match x with 106 | + | [] -> error "internal error: empty list" 107 | + | [e] -> e 108 | + | _::x -> last x 109 | + 110 | +let all_but_last x = List.rev (List.tl (List.rev x)) 111 | + 112 | +let is_well_typed env evd t = try ignore(Typing.type_of env evd t); true with Type_errors.TypeError _ -> false 113 | + 114 | +let meta_name evd mv = 115 | + match find_meta evd mv with 116 | + | Cltyp(na,_) -> na 117 | + | Clval(na,_,_) -> na 118 | + 119 | +let abstract_metas evd mvs t = List.fold_right 120 | + (fun mv t -> 121 | + mkLambda( meta_name evd mv, Typing.meta_type evd mv, replace_term (mkMeta mv) (mkRel 1) t)) 122 | + mvs t 123 | + 124 | +let occurrence_count term subterm = 125 | + let n = ref 0 in 126 | + let rec f c = if eq_constr subterm c then incr n else iter_constr f c in 127 | + iter_constr f term; 128 | + !n 129 | + 130 | +let subsets n = 131 | + assert (n >= 0); 132 | + let rec subsets n = 133 | + if n = 0 then [[]] 134 | + else 135 | + let m = n-1 in 136 | + let s = subsets m in 137 | + List.append s (List.map (fun t -> m :: t) s) in 138 | + List.map List.rev (subsets n) 139 | +let cartprod2 x y = List.flatten (List.map (fun t -> List.map (fun u -> t::u) y) x) 140 | +let cartprod z = List.fold_right cartprod2 z [[]] 141 | +let subsetsn l = cartprod (List.map subsets l) 142 | + 143 | +let replace_term_occ occs c by_c in_t = 144 | + let ctr = ref 0 in 145 | + let rec f x = ( 146 | + if eq_constr c x 147 | + then ( 148 | + let x' = if List.mem !ctr occs then by_c else x in 149 | + incr ctr; 150 | + x' 151 | + ) 152 | + else map_constr f x 153 | + ) in 154 | + f in_t 155 | + 156 | +let select f x = 157 | + let rec select f = function 158 | + | [] -> [] 159 | + | a::x -> if f a then a :: select f x else select f x in 160 | + select f x 161 | + 162 | +let abstract_list_search_warning = ref (function (env:env) -> function (evd:evar_map) -> function (survivors:constr list) -> assert false) 163 | + 164 | +let always_search = true (* true for development, false for production *) 165 | + 166 | +let abstract_list_search env evd2 typ c l = 167 | + let c_orig = c in 168 | + let l_orig = l in 169 | + let elimA = List.rev (take (List.length l) (List.map fst (meta_list evd2))) in 170 | + let k = last l in 171 | + let l = all_but_last l in 172 | + let psvar = all_but_last elimA in 173 | + let evd = List.fold_right meta_unassign psvar evd2 in 174 | + let psvalpairs = List.map (fun mv -> (mv,meta_value evd2 mv)) psvar in 175 | + let ispsval t = 176 | + let rec f = function [] -> None | (mv,v)::rest -> if eq_constr t v then Some mv else f rest in 177 | + f psvalpairs in 178 | + let c = replace_term k (mkMeta (last elimA)) c in 179 | + let c = 180 | + let rec f t = match ispsval t with Some mv -> mkMeta mv | None -> map_constr f t in 181 | + map_constr f c in 182 | + let psvargoalcount = List.map (occurrence_count c) (List.map mkMeta psvar) in 183 | + let totcount = List.fold_right (+) psvargoalcount 0 in 184 | + if totcount > 16 then error_cannot_find_abstraction env evd2 c_orig l_orig "attempted, more than 16 replacement spots"; 185 | + let psvaroccs = subsetsn psvargoalcount in 186 | + let possibilities = List.map 187 | + (fun occlist -> List.fold_right2 (fun occ (mv,vl) goal -> replace_term_occ occ (mkMeta mv) vl goal) occlist psvalpairs c) 188 | + psvaroccs in 189 | + let survivors = select (is_well_typed env evd) possibilities in 190 | + let survivors = List.map (abstract_metas evd elimA) survivors in 191 | + begin 192 | + match List.length survivors with 193 | + 0 -> error_cannot_find_abstraction env evd2 c_orig l_orig "possible" 194 | + | 1 -> () 195 | + | _ -> !abstract_list_search_warning env evd2 survivors 196 | + end; 197 | + let p = List.hd survivors in 198 | + if is_conv_leq env evd2 (Typing.type_of env evd2 p) typ 199 | + then p 200 | + else error "internal error: abstraction not convertible?" 201 | + 202 | let occur_meta_or_undefined_evar evd c = 203 | let rec occrec c = match kind_of_term c with 204 | | Meta _ -> raise Occur 205 | @@ -930,7 +1033,8 @@ 206 | let (evd',cllist) = 207 | w_unify_to_subterm_list env flags allow_K p oplist typ evd in 208 | let typp = Typing.meta_type evd' p in 209 | - let pred = abstract_list_all env evd' typp typ cllist in 210 | + let pred = try abstract_list_all env evd' typp typ cllist 211 | + with PretypeError _ -> abstract_list_search env evd' typp typ cllist in 212 | w_merge env false flags (evd',[p,pred,(ConvUpToEta 0,TypeProcessed)],[]) 213 | 214 | let w_unify2 env flags allow_K cv_pb ty1 ty2 evd = 215 | diff -ur ../coq-8.3pl2-patched/pretyping/unification.mli ./pretyping/unification.mli 216 | --- ../coq-8.3pl2-patched/pretyping/unification.mli 2010-07-24 10:57:30.000000000 -0500 217 | +++ ./pretyping/unification.mli 2011-09-12 12:27:16.000000000 -0500 218 | @@ -52,3 +52,6 @@ 219 | (* (exported for inv.ml) *) 220 | val abstract_list_all : 221 | env -> evar_map -> constr -> constr -> constr list -> constr 222 | + 223 | + 224 | +val abstract_list_search_warning : (env -> evar_map -> Term.constr list -> unit) ref 225 | diff -ur ../coq-8.3pl2-patched/proofs/logic.ml ./proofs/logic.ml 226 | --- ../coq-8.3pl2-patched/proofs/logic.ml 2010-07-26 17:12:43.000000000 -0500 227 | +++ ./proofs/logic.ml 2011-09-12 11:47:14.000000000 -0500 228 | @@ -58,7 +58,7 @@ 229 | (* unification errors *) 230 | | PretypeError(_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _ 231 | |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _ 232 | - |CannotFindWellTypedAbstraction _|OccurCheck _ 233 | + |CannotFindAbstraction _|CannotFindWellTypedAbstraction _|OccurCheck _ 234 | |UnsolvableImplicit _)) -> true 235 | | Typeclasses_errors.TypeClassError 236 | (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true 237 | diff -ur ../coq-8.3pl2-patched/tactics/tactics.ml ./tactics/tactics.ml 238 | --- ../coq-8.3pl2-patched/tactics/tactics.ml 2011-10-11 07:28:57.000000000 -0500 239 | +++ ./tactics/tactics.ml 2011-10-10 16:38:28.000000000 -0500 240 | @@ -134,7 +134,9 @@ 241 | errorlabstrm "" (pr_id id ++ str " is used in conclusion.") 242 | | Evarutil.OccurHypInSimpleClause (Some id') -> 243 | errorlabstrm "" 244 | - (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".") 245 | + (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str"." ++ fnl() ++ fnl() 246 | + ++ str "The context:" ++ fnl() ++ str " " ++ Printer.pr_context_of env 247 | + ) 248 | | Evarutil.EvarTypingBreak ev -> 249 | errorlabstrm "" 250 | (str "Cannot remove " ++ pr_id id ++ 251 | @@ -1912,13 +1914,8 @@ 252 | let argl = snd (decompose_app indtyp) in 253 | let c = List.nth argl (i-1) in 254 | match kind_of_term c with 255 | - | Var id when not (List.exists (occur_var (pf_env gl) id) avoid) -> 256 | - atomize_one (i-1) ((mkVar id)::avoid) gl 257 | | Var id -> 258 | - let x = fresh_id [] id gl in 259 | - tclTHEN 260 | - (letin_tac None (Name x) (mkVar id) None allHypsAndConcl) 261 | - (atomize_one (i-1) ((mkVar x)::avoid)) gl 262 | + atomize_one (i-1) ((mkVar id)::avoid) gl 263 | | _ -> 264 | let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) 265 | Anonymous in 266 | diff -ur ../coq-8.3pl2-patched/test-suite/success/unification.v ./test-suite/success/unification.v 267 | --- ../coq-8.3pl2-patched/test-suite/success/unification.v 2010-04-07 17:01:23.000000000 -0500 268 | +++ ./test-suite/success/unification.v 2011-09-12 17:55:41.000000000 -0500 269 | @@ -136,3 +136,4 @@ 270 | Proof. 271 | intros. 272 | rewrite H. 273 | +Abort. 274 | diff -ur ../coq-8.3pl2-patched/test-suite/success/unification2.v ./test-suite/success/unification2.v 275 | --- ../coq-8.3pl2-patched/test-suite/success/unification2.v 2011-10-11 07:31:05.000000000 -0500 276 | +++ ./test-suite/success/unification2.v 2011-09-12 18:11:59.000000000 -0500 277 | @@ -0,0 +1,35 @@ 278 | +(* tests to go with Grayson's patch to "destruct" for handling Univalent Foundations *) 279 | + 280 | +Unset Automatic Introduction. 281 | + 282 | +(* Voevodsky's original example: *) 283 | + 284 | +Definition test ( X : Type ) ( x : X ) ( fxe : forall x1 : X , identity x1 x1 ) : identity ( fxe x ) ( fxe x ). 285 | +Proof. intros. destruct ( fxe x ). apply identity_refl. Defined. 286 | + 287 | +(* a harder example *) 288 | + 289 | +Definition UU := Type . 290 | +Inductive paths {T:Type}(t:T): T -> UU := idpath: paths t t. 291 | +Inductive foo (X0:UU) (x0:X0) : forall (X:UU)(x:X) , UU := newfoo : foo X0 x0 X0 x0. 292 | +Definition idonfoo {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo X0 x0 X1 x1 -> foo X0 x0 X1 x1. 293 | +Proof. intros * t. exact t. Defined. 294 | + 295 | +Lemma hA (T:UU) (t:T) (k : foo T t T t) : paths k (idonfoo k). 296 | +Proof. intros. 297 | + destruct k. 298 | + unfold idonfoo. 299 | + apply idpath. 300 | +Defined. 301 | + 302 | +(* an example with two constructors *) 303 | + 304 | +Inductive foo' (X0:UU) (x0:X0) : forall (X:UU)(x:X) , UU := newfoo1 : foo' X0 x0 X0 x0 | newfoo2 : foo' X0 x0 X0 x0 . 305 | +Definition idonfoo' {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo' X0 x0 X1 x1 -> foo' X0 x0 X1 x1. 306 | +Proof. intros * t. exact t. Defined. 307 | +Lemma tryb2 (T:UU) (t:T) (k : foo' T t T t) : paths k (idonfoo' k). 308 | +Proof. intros. 309 | + destruct k. 310 | + unfold idonfoo'. apply idpath. 311 | + unfold idonfoo'. apply idpath. 312 | +Defined. 313 | diff -ur ../coq-8.3pl2-patched/toplevel/himsg.ml ./toplevel/himsg.ml 314 | --- ../coq-8.3pl2-patched/toplevel/himsg.ml 2010-09-24 17:23:07.000000000 -0500 315 | +++ ./toplevel/himsg.ml 2011-09-13 17:07:40.000000000 -0500 316 | @@ -439,6 +439,16 @@ 317 | str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++ 318 | str "which is ill-typed." 319 | 320 | +let explain_cannot_find_abstraction env evd c l msg = 321 | + str "Abstraction over the " ++ 322 | + str (plural (List.length l) "term") ++ spc () ++ 323 | + hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++ 324 | + str "not" ++ spc() ++ str msg ++ str "." ++ 325 | + fnl() ++ fnl() ++ str "The context:" ++ fnl() ++ 326 | + str " " ++ pr_context_of env ++ 327 | + fnl() ++ fnl() ++ str "The term to be abstracted: " ++ fnl() ++ fnl() ++ 328 | + str " " ++ pr_constr c 329 | + 330 | let explain_abstraction_over_meta _ m n = 331 | strbrk "Too complex unification problem: cannot find a solution for both " ++ 332 | pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "." 333 | @@ -502,6 +512,8 @@ 334 | | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n 335 | | CannotFindWellTypedAbstraction (p,l) -> 336 | explain_cannot_find_well_typed_abstraction env p l 337 | + | CannotFindAbstraction (evd,c,l,msg) -> 338 | + explain_cannot_find_abstraction env evd c l msg 339 | | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n 340 | | NonLinearUnification (m,c) -> explain_non_linear_unification env m c 341 | 342 | @@ -850,3 +862,8 @@ 343 | pr_enum pr_call calls ++ strbrk kind_of_last_call) 344 | else 345 | mt () 346 | + 347 | +let _ = 348 | + Unification.abstract_list_search_warning := 349 | + function env -> function evd -> function l -> 350 | + msgnl(str "warning: multiple well-typed abstractions found:" ++ (fnl()) ++ prlist_with_sep fnl pr_constr l) 351 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/Coq_patches/inductive-indice-levels-matter-8.3.patch: -------------------------------------------------------------------------------- 1 | diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml 2 | index df3670d..3e33ffb 100644 3 | --- a/kernel/indtypes.ml 4 | +++ b/kernel/indtypes.ml 5 | @@ -161,11 +161,14 @@ let extract_level (_,_,_,lc,lev) = 6 | if Array.length lc >= 2 then sup type0_univ lev else lev 7 | 8 | let inductive_levels arities inds = 9 | - let levels = Array.map pi3 arities in 10 | - let cstrs_levels = Array.map extract_level inds in 11 | + let levels = Array.map (fun (_,_,_,lev) -> lev) arities in 12 | + let arsign_levels = Array.map (fun (_,_,arlev,_) -> arlev) arities in 13 | + let inds_levels = Array.map extract_level inds in 14 | + (* Add the constraints coming from the real arguments *) 15 | + let inds_levels = array_map2 sup arsign_levels inds_levels in 16 | (* Take the transitive closure of the system of constructors *) 17 | (* level constraints and remove the recursive dependencies *) 18 | - solve_constraints_system levels cstrs_levels 19 | + solve_constraints_system levels inds_levels 20 | 21 | (* This (re)computes informations relevant to extraction and the sort of an 22 | arity or type constructor; we do not to recompute universes constraints *) 23 | @@ -184,9 +187,14 @@ let infer_constructor_packet env_ar_par params lc = 24 | let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in 25 | (* compute *) 26 | let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in 27 | - 28 | (info,lc'',level,cst) 29 | 30 | +let rel_context_level env sign = 31 | + fst (List.fold_right 32 | + (fun (_,_,t as d) (lev,env) -> 33 | + sup (univ_of_sort (fst (infer_type env t)).utj_type) lev, push_rel d env) 34 | + sign (type0m_univ,env)) 35 | + 36 | (* Type-check an inductive definition. Does not check positivity 37 | conditions. *) 38 | let typecheck_inductive env mie = 39 | @@ -216,10 +224,12 @@ let typecheck_inductive env mie = 40 | let lev = 41 | (* Decide that if the conclusion is not explicitly Type *) 42 | (* then the inductive type is not polymorphic *) 43 | - match kind_of_term ((strip_prod_assum arity.utj_val)) with 44 | + match kind_of_term (strip_prod_assum arity.utj_val) with 45 | | Sort (Type u) -> Some u 46 | | _ -> None in 47 | - (cst,env_ar',(id,full_arity,lev)::l)) 48 | + let arsign, _ = dest_arity env_params arity.utj_val in 49 | + let arsign_lev = rel_context_level env_params arsign in 50 | + (cst,env_ar',(id,full_arity,arsign_lev,lev)::l)) 51 | (cst1,env,[]) 52 | mie.mind_entry_inds in 53 | 54 | @@ -255,15 +265,15 @@ let typecheck_inductive env mie = 55 | (* Compute/check the sorts of the inductive types *) 56 | let ind_min_levels = inductive_levels arities inds in 57 | let inds, cst = 58 | - array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst -> 59 | + array_fold_map2' (fun ((id,full_arity,arsign_level,ind_level),cn,info,lc,_) lev cst -> 60 | let sign, s = dest_arity env full_arity in 61 | let status,cst = match s with 62 | - | Type u when ar_level <> None (* Explicitly polymorphic *) 63 | + | Type u when ind_level <> None (* Explicitly polymorphic *) 64 | && no_upper_constraints u cst -> 65 | (* The polymorphic level is a function of the level of the *) 66 | (* conclusions of the parameters *) 67 | (* We enforce [u >= lev] in case [lev] has a strict upper *) 68 | - (* constraints over [u] *) 69 | + (* constraint over [u] *) 70 | Inr (param_ccls, lev), enforce_geq u lev cst 71 | | Type u (* Not an explicit occurrence of Type *) -> 72 | Inl (info,full_arity,s), enforce_geq u lev cst 73 | diff --git a/kernel/inductive.ml b/kernel/inductive.ml 74 | index 24b0751..a81531e 100644 75 | --- a/kernel/inductive.ml 76 | +++ b/kernel/inductive.ml 77 | @@ -202,13 +202,13 @@ let type_of_inductive env (_,mip) = 78 | 79 | (* The max of an array of universes *) 80 | 81 | -let cumulate_constructor_univ u = function 82 | - | Prop Null -> u 83 | - | Prop Pos -> sup type0_univ u 84 | - | Type u' -> sup u u' 85 | +let univ_of_sort = function 86 | + | Prop Pos -> type0m_univ 87 | + | Prop Null -> type0_univ 88 | + | Type u -> u 89 | 90 | let max_inductive_sort = 91 | - Array.fold_left cumulate_constructor_univ type0m_univ 92 | + Array.fold_left (fun u s -> sup u (univ_of_sort s)) type0m_univ 93 | 94 | (************************************************************************) 95 | (* Type of a constructor *) 96 | diff --git a/kernel/inductive.mli b/kernel/inductive.mli 97 | index a0fba8e..188a1cb 100644 98 | --- a/kernel/inductive.mli 99 | +++ b/kernel/inductive.mli 100 | @@ -88,6 +88,8 @@ val check_cofix : env -> cofixpoint -> unit 101 | val type_of_inductive_knowing_parameters : 102 | env -> one_inductive_body -> types array -> types 103 | 104 | +val univ_of_sort : sorts -> universe 105 | + 106 | val max_inductive_sort : sorts array -> universe 107 | 108 | val instantiate_universes : env -> rel_context -> 109 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/Coq_patches/patch.type-in-type: -------------------------------------------------------------------------------- 1 | diff --git a/branches/v8.3/kernel/reduction.ml b/branches/v8.3/kernel/reduction.ml 2 | index aa50f78..77e6072 100644 3 | --- a/branches/v8.3/kernel/reduction.ml 4 | +++ b/branches/v8.3/kernel/reduction.ml 5 | @@ -183,10 +183,13 @@ let sort_cmp pb s0 s1 cuniv = 6 | if c1 = c2 then cuniv else raise NotConvertible 7 | | (Prop c1, Type u) when pb = CUMUL -> assert (is_univ_variable u); cuniv 8 | | (Type u1, Type u2) -> 9 | + cuniv 10 | +(* 11 | assert (is_univ_variable u2); 12 | (match pb with 13 | | CONV -> enforce_eq u1 u2 cuniv 14 | | CUMUL -> enforce_geq u2 u1 cuniv) 15 | +*) 16 | | (_, _) -> raise NotConvertible 17 | 18 | 19 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/Generalities/uuu.v: -------------------------------------------------------------------------------- 1 | (** * Introduction. Vladimir Voevodsky . Feb. 2010 - Sep. 2011 2 | 3 | This is the first in the group of files which contain the (current state of) the mathematical library for theproof assistant Coq based on the Univalent Foundations. It contains some new notations for constructions defined in Coq.Init library as well as the definition of dependent sum as a record. 4 | 5 | 6 | *) 7 | 8 | 9 | 10 | 11 | (** Preambule. *) 12 | 13 | Unset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *) 14 | 15 | (** Universe structure *) 16 | 17 | Notation UUU := Set . 18 | 19 | (** Empty type. The empty type is introduced in Coq.Init.Datatypes by the line: 20 | 21 | [ Inductive Empty_set : Set := . ] 22 | 23 | *) 24 | 25 | Notation empty := Empty_set. 26 | 27 | (** Identity Types. Idenity types are introduced in Coq.Init.Datatypes by the lines : 28 | 29 | [ Inductive identity ( A : Type ) ( a : A ) : A -> Type := identity_refl : identity _ a a . 30 | Hint Resolve identity_refl : core . ] 31 | 32 | *) 33 | 34 | Notation paths := identity . 35 | Notation idpath := identity_refl . 36 | 37 | (** Dpendent sums. 38 | 39 | One can not use a new record each time one needs it because the general theorems about this construction would not apply to new instances of "Record" due to the "generativity" of inductive definitions in Coq. One could use "Inductive" instead of "Record" here but using "Record" which is equivalent to "Structure" allows us later to use the mechanism of canonical structures with total2. *) 40 | 41 | Record total2 { T: Type } ( P: T -> Type ) := tpair { pr1 : T ; pr2 : P pr1 }. 42 | 43 | (* Definition pr1 { T: Type } { P : T -> Type } ( tp : total2 P ) := match tp with tpair t p => t end . 44 | Definition pr2 { T: Type } { P : T -> Type } ( tp : total2 P ) := match tp as a return P ( pr1 a ) with tpair t p => p end . *) 45 | 46 | Implicit Arguments tpair [ T ] . 47 | Implicit Arguments pr1 [ T P ] . 48 | Implicit Arguments pr2 [ T P ] . 49 | 50 | (** Coproducts . 51 | 52 | The coproduct of two types is introduced in Coq.Init.Datatypes by the lines: 53 | 54 | [ Inductive sum (A B:Type) : Type := 55 | | inl : A -> sum A B 56 | | inr : B -> sum A B. ] 57 | *) 58 | 59 | Notation coprod := sum . 60 | 61 | Notation ii1fun := inl . 62 | Notation ii2fun := inr . 63 | 64 | Notation ii1 := inl . 65 | Notation ii2 := inr . 66 | Implicit Arguments ii1 [ A B ] . 67 | Implicit Arguments ii2 [ A B ] . 68 | 69 | 70 | (** The phantom type family ( following George Gonthier ) *) 71 | 72 | Inductive Phant ( T : Type ) := phant : Phant T . 73 | 74 | 75 | 76 | (** The following command checks wheather the patch which modifies the universe level assignement for inductive types have been installed. With the patch it returns [ paths 0 0 : UUU ] . Without the patch it returns [ paths 0 0 : Prop ]. *) 77 | 78 | Check (paths O O) . 79 | 80 | 81 | 82 | (* End of the file uuu.v *) 83 | 84 | 85 | 86 | 87 | 88 | 89 | (* 90 | *** Local Variables: *** 91 | *** coq-prog-name: "/opt/local/bin/coqtop" *** 92 | *** coq-prog-args: ("-emacs-U") *** 93 | *** End: *** 94 | *) 95 | 96 | 97 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/Proof_of_Extensionality/funextfun.v: -------------------------------------------------------------------------------- 1 | (** * Univalence axiom and functional extensionality. Vladimir Voevodsky. Feb. 2010 - Sep. 2011 2 | 3 | This file contains the formulation of the univalence axiom and the proof that it implies functional extensionality for functions - Theorem funextfun. 4 | 5 | *) 6 | 7 | 8 | (** *** Preamble. *) 9 | 10 | Add Rec LoadPath "../Generalities". 11 | 12 | (** *** Imports. *) 13 | 14 | Unset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *) 15 | 16 | Require Export uu0. 17 | 18 | 19 | (** ** Univalence axiom. *) 20 | 21 | 22 | Definition eqweqmap { T1 T2 : UU } ( e: paths T1 T2 ) : weq T1 T2 . 23 | Proof. intros. destruct e . apply idweq. Defined. 24 | 25 | Axiom univalenceaxiom : forall T1 T2 : UU , isweq ( @eqweqmap T1 T2 ). 26 | 27 | Definition weqtopaths { T1 T2 : UU } ( w : weq T1 T2 ) : paths T1 T2 := invmap ( weqpair _ ( univalenceaxiom T1 T2 ) ) w. 28 | 29 | 30 | Definition weqpathsweq { T1 T2 : UU } ( w : weq T1 T2 ) : paths ( eqweqmap ( weqtopaths w ) ) w := homotweqinvweq ( weqpair _ ( univalenceaxiom T1 T2 ) ) w. 31 | 32 | (** We show that [ univalenceaxiom ] is equivalent to the axioms [ weqtopaths0 ] and [ weqpathsweq0 ] stated below . *) 33 | 34 | 35 | Axiom weqtopaths0 : forall ( T1 T2 : UU ) ( w : weq T1 T2 ) , paths T1 T2. 36 | 37 | Axiom weqpathsweq0 : forall ( T1 T2 : UU ) ( w : weq T1 T2 ) , paths ( eqweqmap ( weqtopaths0 _ _ w ) ) w. 38 | 39 | Theorem univfromtwoaxioms ( T1 T2 : UU ) : isweq ( @eqweqmap T1 T2 ). 40 | Proof. intros. set ( P1 := fun XY : dirprod UU UU => ( match XY with tpair X Y => paths X Y end ) ) . set ( P2 := fun XY : dirprod UU UU => match XY with tpair X Y => weq X Y end ) . set ( Z1 := total2 P1 ). set ( Z2 := total2 P2 ). set ( f := totalfun _ _ ( fun XY : dirprod UU UU => match XY with tpair X Y => @eqweqmap X Y end ) : Z1 -> Z2 ) . set ( g := totalfun _ _ ( fun XY : dirprod UU UU => match XY with tpair X Y => weqtopaths0 X Y end ) : Z2 -> Z1 ) . set ( s1 := fun X Y : UU => fun w : weq X Y => tpair P2 ( dirprodpair X Y ) w ) . set ( efg := fun a => match a as a' return ( paths ( f ( g a' ) ) a' ) with tpair ( tpair X Y ) w => ( maponpaths ( s1 X Y ) ( weqpathsweq0 X Y w ) ) end ) . 41 | 42 | set ( h := fun a1 : Z1 => pr1 ( pr1 a1 ) ) . 43 | assert ( egf0 : forall a1 : Z1 , paths ( pr1 ( g ( f a1 ) ) ) ( pr1 a1 ) ). intro. apply idpath. 44 | assert ( egf1 : forall a1 a1' : Z1 , paths ( pr1 a1' ) ( pr1 a1 ) -> paths a1' a1 ). intros. set ( X' := maponpaths ( @pr1 _ _ ) X ). 45 | assert ( is : isweq h ). apply isweqpr1pr1 . apply ( invmaponpathsweq ( weqpair h is ) _ _ X' ). 46 | set ( egf := fun a1 => ( egf1 _ _ ( egf0 a1 ) ) ). 47 | set ( is2 := gradth _ _ egf efg ). 48 | apply ( isweqtotaltofib P1 P2 ( fun XY : dirprod UU UU => match XY with tpair X Y => @eqweqmap X Y end ) is2 ( dirprodpair T1 T2 ) ). Defined. 49 | 50 | 51 | (** Conjecture : the pair [weqtopaths0] and [weatopathsweq0] is well defined up to a canonical equality. **) 52 | 53 | 54 | 55 | 56 | 57 | 58 | (** ** Transport theorem. 59 | 60 | Theorem saying that any general scheme to "transport" a structure along a weak equivalence which does not change the structure in the case of the identity equivalence is equivalent to the transport along the path which corresponds to a weak equivalence by the univalenceaxiom. As a corollary we conclude that for any such transport scheme the corresponding maps on spaes of structures are weak equivalences. *) 61 | 62 | 63 | Lemma isweqtransportf10 { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : isweq ( transportf P e ). 64 | Proof. intros. destruct e. apply idisweq. Defined. 65 | 66 | Lemma isweqtransportb10 { X : UU } ( P : X -> UU ) { x x' : X } ( e : paths x x' ) : isweq ( transportb P e ). 67 | Proof. intros. apply ( isweqtransportf10 _ ( pathsinv0 e ) ). Defined. 68 | 69 | 70 | Lemma l1 { X0 X0' : UU } ( ee : paths X0 X0' ) ( P : UU -> UU ) ( pp' : P X0' ) ( R : forall X X' : UU , forall w : weq X X' , P X' -> P X ) ( r : forall X : UU , forall p : P X , paths ( R X X ( idweq X ) p ) p ) : paths ( R X0 X0' ( eqweqmap ee ) pp' ) ( transportb P ee pp' ). 71 | Proof. intro. intro. intro. intro. intro. destruct ee. simpl. intro. intro. apply r. Defined. 72 | 73 | 74 | Theorem weqtransportb ( P : UU -> UU ) ( R : forall ( X X' : UU ) ( w : weq X X' ) , P X' -> P X ) ( r : forall X : UU , forall p : P X , paths ( R X X ( idweq X ) p ) p ) : forall ( X X' : UU ) ( w : weq X X' ) ( p' : P X' ) , paths ( R X X' w p' ) ( transportb P ( weqtopaths w ) p' ). 75 | Proof. intros. set ( uv := weqtopaths w ). set ( v := eqweqmap uv ). 76 | 77 | assert ( e : paths v w ) . unfold weqtopaths in uv. apply ( homotweqinvweq ( weqpair _ ( univalenceaxiom X X' ) ) w ). 78 | 79 | assert ( ee : paths ( R X X' v p' ) ( R X X' w p' ) ) . set ( R' := fun vis : weq X X' => R X X' vis p' ). assert ( ee' : paths ( R' v ) ( R' w ) ). apply ( maponpaths R' e ). assumption. 80 | 81 | destruct ee. apply l1. assumption. Defined. 82 | 83 | 84 | 85 | Corollary isweqweqtransportb ( P : UU -> UU ) ( R : forall ( X X' : UU ) ( w : weq X X' ) , P X' -> P X ) ( r : forall X : UU , forall p : P X , paths ( R X X ( idweq X ) p ) p ) : forall ( X X' : UU ) ( w : weq X X' ) , isweq ( fun p' : P X' => R X X' w p' ). 86 | Proof. intros. assert ( e : forall p' : P X' , paths ( R X X' w p' ) ( transportb P ( weqtopaths w ) p' ) ). apply weqtransportb. assumption. assert ( ee : forall p' : P X' , paths ( transportb P ( weqtopaths w ) p' ) ( R X X' w p' ) ). intro. apply ( pathsinv0 ( e p' ) ). clear e. 87 | 88 | assert ( is1 : isweq ( transportb P ( weqtopaths w ) ) ). apply isweqtransportb10. 89 | apply ( isweqhomot ( transportb P ( weqtopaths w ) ) ( fun p' : P X' => R X X' w p' ) ee is1 ). Defined. 90 | 91 | 92 | 93 | 94 | 95 | (** Theorem saying that composition with a weak equivalence is a weak equivalence on function spaces. *) 96 | 97 | 98 | 99 | 100 | Theorem isweqcompwithweq { X X' : UU } ( w : weq X X' ) ( Y : UU ) : isweq ( fun f : X' -> Y => ( fun x : X => f ( w x ) ) ). 101 | Proof. intros. 102 | set ( P := fun X0 : UU => ( X0 -> Y ) ). 103 | set ( R := fun X0 : UU => ( fun X0' : UU => ( fun w1 : X0 -> X0' => ( fun f : P X0' => ( fun x : X0 => f ( w1 x ) ) ) ) ) ). 104 | set ( r := fun X0 : UU => ( fun f : X0 -> Y => pathsinv0 ( etacor f ) ) ). 105 | apply ( isweqweqtransportb P R r X X' w ). Defined. 106 | 107 | 108 | 109 | 110 | (** ** Proof of the functional extensionality for functions *) 111 | 112 | 113 | Lemma eqcor0 { X X' : UU } ( w : weq X X' ) ( Y : UU ) ( f1 f2 : X' -> Y ) : paths ( fun x : X => f1 ( w x ) ) ( fun x : X => f2 ( w x ) ) -> paths f1 f2. 114 | Proof. intros. apply ( invmaponpathsweq ( weqpair _ ( isweqcompwithweq w Y ) ) f1 f2 ). assumption. Defined. 115 | 116 | 117 | Lemma apathpr1topr ( T : UU ) : paths ( fun z : pathsspace T => pr1 z ) ( fun z : pathsspace T => pr1 ( pr2 z ) ). 118 | Proof. intro. apply ( eqcor0 ( weqpair _ ( isweqdeltap T ) ) _ ( fun z : pathsspace T => pr1 z ) ( fun z : pathsspace T => pr1 ( pr2 z ) ) ( idpath ( idfun T ) ) ) . Defined. 119 | 120 | 121 | Theorem funextfun { X Y : UU } ( f1 f2 : X -> Y ) ( e : forall x : X , paths ( f1 x ) ( f2 x ) ) : paths f1 f2. 122 | Proof. intros. set ( f := fun x : X => pathsspacetriple Y ( e x ) ) . set ( g1 := fun z : pathsspace Y => pr1 z ) . set ( g2 := fun z : pathsspace Y => pr1 ( pr2 z ) ). assert ( e' : paths g1 g2 ). apply ( apathpr1topr Y ). assert ( ee : paths ( fun x : X => f1 x ) ( fun x : X => f2 x ) ). change ( paths (fun x : X => g1 ( f x ) ) (fun x : X => g2 ( f x ) ) ) . destruct e' . apply idpath . apply etacoronpaths. apply ee . Defined. 123 | 124 | (* End of the file funextfun.v *) 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | (* 133 | *** Local Variables: *** 134 | *** coq-prog-name: "/opt/local/bin/coqtop" *** 135 | *** coq-prog-args: ("-emacs-U") *** 136 | *** End: *** 137 | *) 138 | 139 | 140 | 141 | 142 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/README: -------------------------------------------------------------------------------- 1 | By Vladimir Voevodsky Feb. 2010 - Nov. 2011 . 2 | 3 | This is the current version (as of Nov. 6 , 2011) of the mathematical library for the proof assistant Coq based on the univalent semantics for the calculus of inductive constructions. The best way to see in detail what the files in these subdirectories are about is to generate the corresponding tables of content with coqdoc . Here we give a brief outline of the library structure . 4 | 5 | Important : files in the library starting with hProp.v will not compile without a type_in_type patch which turns off the universe consistency checking . This is a temporary situation which will be corrected when better universe management is implememnted in Coq . We also use a patch which modifies the rule by which the universe level of inductive definitions is computed . If the later patch is applied correctly then the compilation of the first file uuu.v should produce a message of the form [ paths 0 0 : UUU ] . Without a patch the message will be [ paths 0 0 : Prop ] . 6 | 7 | The library contains subdirectories Generalities/ hlevel1/ hlevel2/ and /Proof_of_Extensionality . 8 | 9 | Directory Generalities/ contains files uuu.v and uu0.v . The file uuu.v contains some new notations for the constructions defined in Coq.Init library as well as the definition of "dependent sum" [ total2 ] . The file uu0.v contains the bulk of general results and definitions about types which are pertinent to the univalent approach . In this file we prove main results which apply to all types and which require only one universe level to be proved. Some of the results in uu0 use the extensionality axiom for functions (introduced in the same file). No other axioms or resizings rules (see below) are used and these files should compile with the standard version of Coq. 10 | 11 | Directory hlevel1/ contains one file hProp.v with results and constructions related to types of h-level 1 i.e. to types which correspond to "propositions" in our formalization. Some of the results here use " resizing rules " and therefore it will currently not compile without a type_in_type patch . Note that we continue to keep track of universe levels in these files "by hand" and use only those "universe re-assigment" or "resizing" rules which are semantically justified. Some of the results in this file also use the univalence axiom for hProp called [ uahp ] which is equivalent to the axiom asserting that if two propositions are logically equivalent then they are equal . 12 | 13 | Directory hlevel2/ contains files with constructions and results related to types of hlevel 2 i.e. to types corresponding to sets in our formalization . 14 | 15 | The first file is hSet.v . It contains most general definitions related to sets including the constructions related to set-quotients of types . 16 | 17 | The next group of files in the hierarchy are algebra1(a b c d).v which contains many definitions and constructions of general abstract algebra culminating at the moment in the construction of the field of fractions of an integral domain. The files also contain definitions and results about the relations on algebraic structures . 18 | 19 | The next file is hnat.v which contains many simple lemmas about arithmetic and comparisons on natural numbers . 20 | 21 | Then the hierarchy branches. 22 | 23 | On one branch there are files stnfsets.v and finitesets.v which introduce constructions related to standard and general finite sets respectively. 24 | 25 | On another branch there are files hz.v and hq.v which introduce the basic cosntructions related to the integer and rational arithmetic as particular cases of the general theorems of the algebra1 group of files. 26 | 27 | At the end of files finitesets.v, hz.v and hq.v there are sample computations which show that despite our use of stnadard extensionality axioms the relevant terms of types [ bool ] and [ nat ] fully normalize. The last computation example in hq.v which evaluates the integral part of 10/-3 takes relatively long time ( about 30 sec. on my computer, it should work much faster with the stnadard optimized version of the "call by need" normalization algorithm which is switched off by one of the patches which I use, see the explanation in the README file of the patches directory) and it might make sense to comment it out. 28 | 29 | Directory Proof_of_Extensionality/ contains the formulation of general Univalence Axiom and a proof that it implies functional extensionality . 30 | 31 | 32 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/forcoqdoc: -------------------------------------------------------------------------------- 1 | Generalities/uuu.v 2 | Generalities/uu0.v 3 | hlevel1/hProp.v 4 | hlevel2/hSet.v 5 | hlevel2/algebra1a.v 6 | hlevel2/algebra1b.v 7 | hlevel2/algebra1c.v 8 | hlevel2/algebra1d.v 9 | hlevel2/hnat.v 10 | hlevel2/stnfsets.v 11 | hlevel2/finitesets.v 12 | hlevel2/hz.v 13 | hlevel2/hq.v 14 | 15 | -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/hlevel1/hProp.v: -------------------------------------------------------------------------------- 1 | (** * Generalities on hProp. Vladimir Voevodsky . May - Sep. 2011 . 2 | 3 | In this file we introduce the hProp - an analog of Prop defined based on the univalent semantics. We further introduce the hProp version of the "inhabited" construction - i.e. for any [ T ] in [ UU0 ] we construct an object [ ishinh T ] and a function [ hinhpr : T -> ishinh T ] which plays the role of [ inhabits ] from the Coq standard library. The semantic meaning of [ hinhpr ] is that it is universal among functions from [ T ] to objects of hProp. Proving that [ ishinh T ] is in [ hProp ] requires a resizing rule which can be written in the putative notation for such rules as follows : 4 | 5 | Resizing Rule RR1 ( U1 U2 : Univ ) ( X : U1 ) ( is : isaprop X ) |- X : U2 . 6 | 7 | Further in the file we introduce the univalence axiom for hProp and a proof of the fact that it is equivalent to a simplier and better known axiom [ uahp ]. We prove that this axiom implies that [ hProp ] satisfies [ isaset ] i.e. it is a type of h-level 2 . This requires another resizing rule : 8 | 9 | Resizing Rule RR2 ( U1 U2 : Univ ) |- @hProp U1 : U2 . 10 | 11 | Since resizing rules are not currently implemented in Coq the file does not compile without a patch provided by Hugo Herbelin which turns off the universe consistency verification. We do however keep track of universes in our development "by hand" to ensure that when the resizing rules will become available the current proofs will verify correctly. To point out which results require resizing rules in a substantial way we mark the first few of such reults by (** RR1 *) or (** RR2 *) comment . 12 | 13 | One can achieve similar results with a combination of usual axioms which imitate the resizing rules. However unlike the usual axioms the resizing rules do not affect the computation/normalization abilities of Coq which makes them the prefrred choice in this situation. 14 | 15 | 16 | *) 17 | 18 | 19 | 20 | (** ** Preambule *) 21 | 22 | (** Settings *) 23 | 24 | Add Rec LoadPath "../Generalities". 25 | 26 | Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *) 27 | 28 | (** Imports *) 29 | 30 | 31 | Require Export uu0 . 32 | 33 | (** Universe structure *) 34 | 35 | Definition UU0 := UU . 36 | 37 | (* end of " Preambule " . *) 38 | 39 | 40 | (** ** To upstream files *) 41 | 42 | 43 | 44 | (** ** The type [ hProp ] of types of h-level 1 *) 45 | 46 | 47 | Definition hProp := total2 ( fun X : UU0 => isaprop X ) . 48 | Definition hProppair ( X : UU0 ) ( is : isaprop X ) : hProp := tpair (fun X : UU0 => isaprop X ) X is . 49 | Definition hProppr1 := @pr1 _ _ : hProp -> Type . 50 | Coercion hProppr1: hProp >-> Sortclass. 51 | 52 | (** ** The type [ tildehProp ] of pairs ( P , p : P ) where [ P : hProp ] *) 53 | 54 | Definition tildehProp := total2 ( fun P : hProp => P ) . 55 | Definition tildehProppair { P : hProp } ( p : P ) : tildehProp := tpair _ P p . 56 | 57 | 58 | (** The following re-definitions should make proofs easier in the future when the unification algorithms in Coq are improved . At the moment they create more complications than they eliminate ( e.g. try to prove [ isapropishinh ] with [ isaprop ] in [ hProp ] ) so for the time being they are commented out . 59 | 60 | 61 | (** *** Re-definitions of some of the standard constructions of uu0 which lift these contructions from UU0 to hProp . *) 62 | 63 | 64 | Definition iscontr ( X : UU0 ) : hProp := hProppair _ ( isapropiscontr X ) . 65 | 66 | Definition isweq { X Y : UU0 } ( f : X -> Y ) : hProp := hProppair _ ( isapropisweq f ) . 67 | 68 | Definition isofhlevel ( n : nat ) ( X : UU0 ) : hProp := hProppair _ ( isapropisofhlevel n X ) . 69 | 70 | Definition isaprop ( X : UU0 ) : hProp := hProppair ( isaprop X ) ( isapropisaprop X ) . 71 | 72 | Definition isaset ( X : UU0 ) : hProp := hProppair _ ( isapropisaset X ) . 73 | 74 | Definition isisolated ( X : UU0 ) ( x : X ) : hProp := hProppair _ ( isapropisisolated X x ) . 75 | 76 | Definition isdeceq ( X : UU0 ) : hProp := hProppair _ ( isapropisdeceq X ) . 77 | 78 | *) 79 | 80 | 81 | (** ** Intuitionistic logic on [ hProp ] *) 82 | 83 | 84 | (** *** The [ hProp ] version of the "inhabited" construction. *) 85 | 86 | 87 | 88 | Definition ishinh_UU ( X : UU0 ) := forall P: hProp, ( ( X -> P ) -> P ). 89 | 90 | Lemma isapropishinh ( X : UU0 ) : isaprop ( ishinh_UU X ). 91 | Proof. intro. apply impred . intro P . apply impred. intro. apply ( pr2 P ) . Defined . 92 | 93 | Definition ishinh ( X : UU0 ) : hProp := hProppair ( ishinh_UU X ) ( isapropishinh X ) . 94 | Canonical Structure ishinh . (** RR1 *) 95 | 96 | 97 | Definition hinhpr ( X : UU0 ) : X -> ishinh X := fun x : X => fun P : hProp => fun f : X -> P => f x . 98 | 99 | Definition hinhfun { X Y : UU0 } ( f : X -> Y ) : ishinh_UU X -> ishinh_UU Y := fun isx : ishinh X => fun P : _ => fun yp : Y -> P => isx P ( fun x : X => yp ( f x ) ) . 100 | 101 | Definition hinhuniv { X : UU0 } { P : hProp } ( f : X -> P ) ( wit : ishinh_UU X ) : P := wit P f . 102 | 103 | 104 | (** Note that the previous definitions do not require RR1 in an essential way ( except for the placing of [ ishinh ] in [ hProp UU0 ] - without RR1 it would be placed in [ hProp UU1 ] ) . The first place where RR1 is essentially required is in application of [ hinhuniv ] to a function [ X -> ishinh Y ] *) 105 | 106 | 107 | Definition hinhand { X Y : UU0 } ( inx1 : ishinh_UU X ) ( iny1 : ishinh_UU Y) : ishinh ( dirprod X Y ) := fun P:_ => ddualand (inx1 P) (iny1 P). 108 | 109 | Definition hinhuniv2 { X Y : UU0 } { P : hProp } ( f : X -> Y -> P ) ( isx : ishinh_UU X ) ( isy : ishinh_UU Y ) : P := hinhuniv ( fun xy : dirprod X Y => f ( pr1 xy ) ( pr2 xy ) ) ( hinhand isx isy ) . 110 | 111 | Definition hinhfun2 { X Y Z : UU0 } ( f : X -> Y -> Z ) ( isx : ishinh_UU X ) ( isy : ishinh_UU Y ) : ishinh Z := hinhfun ( fun xy: dirprod X Y => f ( pr1 xy ) ( pr2 xy ) ) ( hinhand isx isy ) . 112 | 113 | Definition hinhunivcor1 ( P : hProp ) : ishinh_UU P -> P := hinhuniv ( idfun P ). 114 | Notation hinhprinv := hinhunivcor1 . 115 | 116 | 117 | (** *** [ ishinh ] and negation [ neg ] *) 118 | 119 | 120 | Lemma weqishinhnegtoneg ( X : UU0 ) : weq ( ishinh ( neg X ) ) ( neg X ) . 121 | Proof . intro . assert ( lg : logeq ( ishinh ( neg X ) ) ( neg X ) ) . split . simpl . apply ( @hinhuniv _ ( hProppair _ ( isapropneg X ) ) ) . simpl . intro nx . apply nx . apply hinhpr . apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( pr2 ( ishinh _ ) ) ( isapropneg X ) ) . Defined . 122 | 123 | Lemma weqnegtonegishinh ( X : UU0 ) : weq ( neg X ) ( neg ( ishinh X ) ) . 124 | Proof . intro . assert ( lg : logeq ( neg ( ishinh X ) ) ( neg X ) ) . split . apply ( negf ( hinhpr X ) ) . intro nx . unfold neg . simpl . apply ( @hinhuniv _ ( hProppair _ isapropempty ) ) . apply nx . apply ( weqimplimpl ( pr2 lg ) ( pr1 lg ) ( isapropneg _ ) ( isapropneg _ ) ) . Defined . 125 | 126 | 127 | (** *** [ ishinh ] and [ coprod ] *) 128 | 129 | 130 | Lemma hinhcoprod ( X Y : UU0 ) ( is : ishinh ( coprod ( ishinh X ) ( ishinh Y ) ) ) : ishinh ( coprod X Y ) . 131 | Proof. intros . unfold ishinh. intro P . intro CP. set (CPX := fun x : X => CP ( ii1 x ) ) . set (CPY := fun y : Y => CP (ii2 y) ). set (is1P := is P). 132 | assert ( f : coprod ( ishinh X ) ( ishinh Y ) -> P ) . apply ( sumofmaps ( hinhuniv CPX ) ( hinhuniv CPY ) ). apply (is1P f ) . Defined. 133 | 134 | 135 | 136 | (** *** Intuitionistic logic on [ hProp ]. *) 137 | 138 | 139 | Definition htrue : hProp := hProppair unit isapropunit. 140 | 141 | Definition hfalse : hProp := hProppair empty isapropempty. 142 | 143 | Definition hconj ( P Q : hProp ) : hProp := hProppair ( dirprod P Q ) ( isapropdirprod _ _ ( pr2 P ) ( pr2 Q ) ). 144 | 145 | Definition hdisj ( P Q : UU0 ) : hProp := ishinh ( coprod P Q ) . 146 | 147 | Definition hneg ( P : UU0 ) : hProp := hProppair ( neg P ) ( isapropneg P ) . 148 | 149 | Definition himpl ( P : UU0 ) ( Q : hProp ) : hProp. 150 | Proof. intros. split with ( P -> Q ) . apply impred. intro. apply (pr2 Q). Defined. 151 | 152 | Definition hexists { X : UU0 } ( P : X -> UU0 ) := ishinh ( total2 P ) . 153 | 154 | Definition wittohexists { X : UU0 } ( P : X -> UU0 ) ( x : X ) ( is : P x ) : hexists P := hinhpr ( total2 P ) (tpair _ x is ) . 155 | 156 | Definition total2tohexists { X : UU0 } ( P : X -> UU0 ) : total2 P -> hexists P := hinhpr _ . 157 | 158 | Definition weqneghexistsnegtotal2 { X : UU0 } ( P : X -> UU0 ) : weq ( neg ( hexists P ) ) ( neg ( total2 P ) ) . 159 | Proof . intros . assert ( lg : ( neg ( hexists P ) ) <-> ( neg ( total2 P ) ) ) . split . apply ( negf ( total2tohexists P ) ) . intro nt2 . unfold neg . change ( ishinh_UU ( total2 P ) -> hfalse ) . apply ( hinhuniv ) . apply nt2 . apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( isapropneg _ ) ( isapropneg _ ) ) . Defined . 160 | 161 | 162 | (** *** Associativity and commutativity of [ hdisj ] and [ hconj ] up to logical equivalence *) 163 | 164 | Lemma islogeqcommhdisj { P Q : hProp } : hdisj P Q <-> hdisj Q P . 165 | Proof . intros . split . simpl . apply hinhfun . apply coprodcomm . simpl . apply hinhfun . apply coprodcomm . Defined . 166 | 167 | 168 | 169 | (** *** Proof of the only non-trivial axiom of intuitionistic logic for our constructions. For the full list of axioms see e.g. http://plato.stanford.edu/entries/logic-intuitionistic/ *) 170 | 171 | 172 | Lemma hconjtohdisj ( P Q : UU0 ) ( R : hProp ) : hconj ( himpl P R ) ( himpl Q R ) -> himpl ( hdisj P Q ) R . 173 | Proof. intros P Q R X0. 174 | assert (s1: hdisj P Q -> R) . intro X1. 175 | assert (s2: coprod P Q -> R ) . intro X2. destruct X2 as [ XP | XQ ]. apply X0. apply XP . apply ( pr2 X0 ). apply XQ . 176 | apply ( hinhuniv s2 ). apply X1 . unfold himpl. simpl . apply s1 . Defined. 177 | 178 | 179 | 180 | 181 | (** *** Negation and quantification. 182 | 183 | There are four standard implications in classical logic which can be summarized as ( neg ( forall P ) ) <-> ( exists ( neg P ) ) and ( neg ( exists P ) ) <-> ( forall ( neg P ) ) . Of these four implications three are provable in the intuitionistic logic. The remaining implication ( neg ( forall P ) ) -> ( exists ( neg P ) ) is not provable in general . For a proof in the case of bounded quantification of decidable predicates on natural numbers see hnat.v . For some other cases when these implications hold see ??? . *) 184 | 185 | Lemma hexistsnegtonegforall { X : UU0 } ( F : X -> UU0 ) : hexists ( fun x : X => neg ( F x ) ) -> neg ( forall x : X , F x ) . 186 | Proof . intros X F . simpl . apply ( @hinhuniv _ ( hProppair _ ( isapropneg (forall x : X , F x ) ) ) ) . simpl . intros t2 f2 . destruct t2 as [ x d2 ] . apply ( d2 ( f2 x ) ) . Defined . 187 | 188 | Lemma forallnegtoneghexists { X : UU0 } ( F : X -> UU0 ) : ( forall x : X , neg ( F x ) ) -> neg ( hexists F ) . 189 | Proof. intros X F nf . change ( ( ishinh_UU ( total2 F ) ) -> hfalse ) . apply hinhuniv . intro t2 . destruct t2 as [ x f ] . apply ( nf x f ) . Defined . 190 | 191 | Lemma neghexisttoforallneg { X : UU0 } ( F : X -> UU0 ) : neg ( hexists F ) -> forall x : X , neg ( F x ) . 192 | Proof . intros X F nhe x . intro fx . apply ( nhe ( hinhpr _ ( tpair F x fx ) ) ) . Defined . 193 | 194 | Definition weqforallnegtonegexists { X : UU0 } ( F : X -> UU0 ) : weq ( forall x : X , neg ( F x ) ) ( neg ( hexists F ) ) . 195 | Proof . intros . apply ( weqimplimpl ( forallnegtoneghexists F ) ( neghexisttoforallneg F ) ) . apply impred . intro x . apply isapropneg . apply isapropneg . Defined . 196 | 197 | 198 | 199 | (** *** Negation and conjunction ( "and" ) and disjunction ( "or" ) . 200 | 201 | There are four implications in classical logic ( ( neg X ) and ( neg Y ) ) <-> ( neg ( X or Y ) ) and ( ( neg X ) or ( neg Y ) ) <-> ( neg ( X and Y ) ) . Of these four, three are provable unconditionally in the intuitionistic logic and the remaining one ( neg ( X and Y ) ) -> ( ( neg X ) or ( neg Y ) ) is provable only if one of the propositions is deidable. These two cases are proved in uu0.v under the names [ fromneganddecx ] and [ fromneganddecy ] . *) 202 | 203 | Lemma tonegdirprod { X Y : UU0 } ( is : hdisj ( neg X ) ( neg Y ) ) : neg ( dirprod X Y ) . 204 | Proof. intros X Y . simpl . apply ( @hinhuniv _ ( hProppair _ ( isapropneg ( dirprod X Y ) ) ) ) . intro c . destruct c as [ nx | ny ] . simpl . intro xy . apply ( nx ( pr1 xy ) ) . simpl . intro xy . apply ( ny ( pr2 xy ) ) . Defined . 205 | 206 | Lemma tonegcoprod { X Y : UU } ( is : dirprod ( neg X ) ( neg Y ) ) : neg ( coprod X Y ) . 207 | Proof . intros. intro c . destruct c as [ x | y ] . apply ( pr1 is x ) . apply ( pr2 is y ) . Defined . 208 | 209 | Lemma toneghdisj { X Y : UU } ( is : dirprod ( neg X ) ( neg Y ) ) : neg ( hdisj X Y ) . 210 | Proof . intros . unfold hdisj. apply ( weqnegtonegishinh ) . apply tonegcoprod . apply is . Defined . 211 | 212 | Lemma fromnegcoprod { X Y : UU0 } ( is : neg ( coprod X Y ) ) : dirprod ( neg X ) ( neg Y ) . 213 | Proof . intros . split . exact ( fun x => is ( ii1 x ) ) . exact ( fun y => is ( ii2 y ) ) . Defined . 214 | 215 | Lemma hdisjtoimpl { P : UU0 } { Q : hProp } : hdisj P Q -> ( neg P -> Q ) . 216 | Proof . intros P Q . assert ( int : isaprop ( neg P -> Q ) ) . apply impred . intro . apply ( pr2 Q ) . simpl . apply ( @hinhuniv _ ( hProppair _ int ) ) . simpl . intro pq . destruct pq as [ p | q ] . intro np . destruct ( np p ) . intro np . apply q . Defined . 217 | 218 | 219 | 220 | (** *** Property of being deidable and [ hdisj ] ( "or" ) . 221 | 222 | For being deidable [ hconj ] see [ isdecpropdirprod ] in uu0.v *) 223 | 224 | Lemma isdecprophdisj { X Y : UU0 } ( isx : isdecprop X ) ( isy : isdecprop Y ) : isdecprop ( hdisj X Y ) . 225 | Proof . intros . apply isdecpropif . apply ( pr2 ( hdisj X Y ) ) . destruct ( pr1 isx ) as [ x | nx ] . apply ( ii1 ( hinhpr _ ( ii1 x ) ) ) . destruct ( pr1 isy ) as [ y | ny ] . apply ( ii1 ( hinhpr _ ( ii2 y ) ) ) . apply ( ii2 ( toneghdisj ( dirprodpair nx ny ) ) ) . Defined . 226 | 227 | 228 | 229 | 230 | 231 | (** *** The double negation version of [ hinhabited ] ( does not require RR1 ) . *) 232 | 233 | 234 | Definition isinhdneg ( X : UU0 ) : hProp := hProppair ( dneg X ) ( isapropdneg X ) . 235 | 236 | Definition inhdnegpr (X:UU0): X -> isinhdneg X := todneg X. 237 | 238 | Definition inhdnegfun { X Y : UU0 } (f:X -> Y): isinhdneg X -> isinhdneg Y := dnegf f. 239 | 240 | Definition inhdneguniv (X: UU0)(P:UU0)(is:isweq (todneg P)): (X -> P) -> ((isinhdneg X) -> P) := fun xp:_ => fun inx0:_ => (invmap ( weqpair _ is ) (dnegf xp inx0)). 241 | 242 | Definition inhdnegand (X Y:UU0)(inx0: isinhdneg X)(iny0: isinhdneg Y) : isinhdneg (dirprod X Y) := dneganddnegimpldneg inx0 iny0. 243 | 244 | Definition hinhimplinhdneg (X:UU0)(inx1: ishinh X): isinhdneg X := inx1 hfalse. 245 | 246 | 247 | (** ** Univalence axiom for hProp 248 | 249 | We introduce here the weakest form of the univalence axiom - the univalence axiom for hProp which is equivalent to the second part of the extensionality axiom in Church simple type theory. This axiom is easily shown to be equivalent to its version with [paths P P'] as a target and to [ weqtopathshProp ] (see below) as well as to the version of [ weqtopathshProp ] with [ paths P P'] as a target. 250 | 251 | The proof of theorem [ univfromtwoaxiomshProp ] is modeled on the proof of [ univfromtwoaxioms ] from univ01.v 252 | 253 | 254 | *) 255 | 256 | 257 | Axiom uahp : forall P P':hProp, (P -> P') -> (P' -> P) -> @paths hProp P P'. 258 | 259 | Definition eqweqmaphProp { P P': hProp } ( e: @paths hProp P P' ) : weq P P'. 260 | Proof. intros . destruct e . apply idweq. Defined. 261 | 262 | Definition weqtopathshProp { P P' : hProp } (w: weq P P' ): @paths hProp P P' := uahp P P' w ( invweq w ) . 263 | 264 | Definition weqpathsweqhProp { P P' : hProp } (w : weq P P'): paths (eqweqmaphProp (weqtopathshProp w)) w. 265 | Proof. intros. apply proofirrelevance . apply (isapropweqtoprop P P' (pr2 P')). Defined. 266 | 267 | 268 | Theorem univfromtwoaxiomshProp (P P':hProp): isweq (@eqweqmaphProp P P'). 269 | Proof. intros. 270 | 271 | set (P1:= fun XY: dirprod hProp hProp => (match XY with tpair X Y => paths X Y end)). set (P2:= fun XY: dirprod hProp hProp => match XY with tpair X Y => weq X Y end). set (Z1:= total2 P1). set (Z2:= total2 P2). set (f:= ( totalfun _ _ (fun XY: dirprod hProp hProp => (match XY with tpair X Y => @eqweqmaphProp X Y end))): Z1 -> Z2). set (g:= ( totalfun _ _ (fun XY: dirprod hProp hProp => (match XY with tpair X Y => @weqtopathshProp X Y end))): Z2 -> Z1). set (s1:= (fun X Y :hProp => fun w: weq X Y => tpair P2 ( dirprodpair X Y) w)). set (efg:= (fun a:_ => match a as a' return (paths (f (g a')) a') with tpair ( tpair X Y) w => ( maponpaths (s1 X Y) (@weqpathsweqhProp X Y w)) end)). 272 | 273 | set (h:= fun a1:Z1 => (pr1 ( pr1 a1))). 274 | assert (egf0: forall a1:Z1, paths ( pr1 (g (f a1))) ( pr1 a1)). intro. apply idpath. 275 | assert (egf1: forall a1 a1':Z1, paths ( pr1 a1') ( pr1 a1) -> paths a1' a1). intros ? ? X . set (X':= maponpaths ( @pr1 _ _ ) X). 276 | assert (is: isweq h). apply ( isweqpr1pr1 hProp ). apply ( invmaponpathsweq ( weqpair h is ) _ _ X'). 277 | set (egf:= fun a1:_ => (egf1 _ _ (egf0 a1))). 278 | set (is2:= gradth _ _ egf efg). 279 | apply ( isweqtotaltofib P1 P2 (fun XY: dirprod hProp hProp => (match XY with tpair X Y => @eqweqmaphProp X Y end)) is2 ( dirprodpair P P')). Defined. 280 | 281 | Definition weqeqweqhProp ( P P' : hProp ) := weqpair _ ( univfromtwoaxiomshProp P P' ) . 282 | 283 | Corollary isasethProp : isaset hProp. 284 | Proof. unfold isaset. simpl. intros x x'. apply (isofhlevelweqb (S O) ( weqeqweqhProp x x' ) (isapropweqtoprop x x' (pr2 x'))). Defined. 285 | 286 | 287 | Lemma iscontrtildehProp : iscontr tildehProp . 288 | Proof . split with ( tpair _ htrue tt ) . intro tP . destruct tP as [ P p ] . apply ( invmaponpathsincl _ ( isinclpr1 ( fun P : hProp => P ) ( fun P => pr2 P ) ) ) . simpl . apply uahp . apply ( fun x => tt ) . intro t. apply p . Defined . 289 | 290 | Lemma isaproptildehProp : isaprop tildehProp . 291 | Proof . apply ( isapropifcontr iscontrtildehProp ) . Defined . 292 | 293 | Lemma isasettildehProp : isaset tildehProp . 294 | Proof . apply ( isasetifcontr iscontrtildehProp ) . Defined . 295 | 296 | 297 | 298 | (* End of the file hProp.v *) 299 | 300 | 301 | 302 | 303 | (* 304 | *** Local Variables: *** 305 | *** coq-prog-name: "/opt/local/bin/coqtop" *** 306 | *** coq-prog-args: ("-emacs-U") *** 307 | *** End: *** 308 | *) -------------------------------------------------------------------------------- /LICS2012/univalent_foundations/hlevel2/finitesets.v: -------------------------------------------------------------------------------- 1 | (** * Finite sets. Vladimir Voevodsky . Apr. - Sep. 2011. 2 | 3 | This file contains the definition and main properties of finite sets. At the end of the file there are several elementary examples which are used as test cases to check that our constructions do not prevent Coq from normalizing terms of type nat to numerals. 4 | 5 | *) 6 | 7 | 8 | 9 | 10 | 11 | (** ** Preambule *) 12 | 13 | (** Settings *) 14 | 15 | Add Rec LoadPath "../Generalities". 16 | Add Rec LoadPath "../hlevel1". 17 | Add Rec LoadPath "../hlevel2". 18 | 19 | Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *) 20 | 21 | 22 | 23 | (** Imports. *) 24 | 25 | Require Export hProp . 26 | Require Export stnfsets . 27 | Require Export hSet . 28 | 29 | 30 | 31 | 32 | (** ** Sets with a given number of elements. *) 33 | 34 | (** *** Structure of a set with [ n ] elements on [ X ] defined as a term in [ weq ( stn n ) X ] *) 35 | 36 | Definition nelstruct ( n : nat ) ( X : UU0 ) := weq ( stn n ) X . 37 | 38 | Definition nelstructonstn ( n : nat ) : nelstruct n ( stn n ) := idweq _ . 39 | 40 | Definition nelstructweqf { X Y : UU0 } { n : nat } ( w : weq X Y ) ( sx : nelstruct n X ) : nelstruct n Y := weqcomp sx w . 41 | 42 | Definition nelstructweqb { X Y : UU0 } { n : nat } ( w : weq X Y ) ( sy : nelstruct n Y ) : nelstruct n X := weqcomp sy ( invweq w ) . 43 | 44 | Definition nelstructonempty : nelstruct 0 empty := weqstn0toempty . 45 | 46 | Definition nelstructonempty2 { X : UU0 } ( is : neg X ) : nelstruct 0 X := weqcomp weqstn0toempty ( invweq ( weqtoempty is ) ) . 47 | 48 | Definition nelstructonunit : nelstruct 1 unit := weqstn1tounit . 49 | 50 | Definition nelstructoncontr { X : UU0 } ( is : iscontr X ) : nelstruct 1 X := weqcomp weqstn1tounit ( invweq ( weqcontrtounit is ) ) . 51 | 52 | Definition nelstructonbool : nelstruct 2 bool := weqstn2tobool . 53 | 54 | Definition nelstructoncoprodwithunit { X : UU0 } { n : nat } ( sx : nelstruct n X ) : nelstruct ( S n ) ( coprod X unit ) := weqcomp ( invweq ( weqdnicoprod n ( lastelement n ) ) ) ( weqcoprodf sx ( idweq unit ) ) . 55 | 56 | Definition nelstructoncompl { X : UU0 } { n : nat } ( x : X ) ( sx : nelstruct ( S n ) X ) : nelstruct n ( compl X x ) := weqcomp ( weqdnicompl n ( invweq sx x ) ) ( invweq ( weqoncompl ( invweq sx ) x ) ) . 57 | 58 | Definition nelstructoncoprod { X Y : UU0 } { n m : nat } ( sx : nelstruct n X ) ( sy : nelstruct m Y ) : nelstruct ( n + m ) ( coprod X Y ) := weqcomp ( invweq ( weqfromcoprodofstn n m ) ) ( weqcoprodf sx sy ) . 59 | 60 | Definition nelstructontotal2 { X : UU0 } ( P : X -> UU0 ) ( f : X -> nat ) { n : nat } ( sx : nelstruct n X ) ( fs : forall x : X , nelstruct ( f x ) ( P x ) ) : nelstruct ( stnsum ( funcomp ( pr1 sx ) f ) ) ( total2 P ) := weqcomp ( invweq ( weqstnsum ( funcomp ( pr1 sx ) P ) ( funcomp ( pr1 sx ) f ) ( fun i : stn n => fs ( ( pr1 sx ) i ) ) ) ) ( weqfp sx P ) . 61 | 62 | Definition nelstructondirprod { X Y : UU0 } { n m : nat } ( sx : nelstruct n X ) ( sy : nelstruct m Y ) : nelstruct ( n * m ) ( dirprod X Y ) := weqcomp ( invweq ( weqfromprodofstn n m ) ) ( weqdirprodf sx sy ) . 63 | 64 | (** For a generalization of [ weqfromdecsubsetofstn ] see below *) 65 | 66 | Definition nelstructonfun { X Y : UU0 } { n m : nat } ( sx : nelstruct n X ) ( sy : nelstruct m Y ) : nelstruct ( natpower m n ) ( X -> Y ) := weqcomp ( invweq ( weqfromfunstntostn n m ) ) ( weqcomp ( weqbfun _ ( invweq sx ) ) ( weqffun _ sy ) ) . 67 | 68 | Definition nelstructonforall { X : UU0 } ( P : X -> UU0 ) ( f : X -> nat ) { n : nat } ( sx : nelstruct n X ) ( fs : forall x : X , nelstruct ( f x ) ( P x ) ) : nelstruct ( stnprod ( funcomp ( pr1 sx ) f ) ) ( forall x : X , P x ) := invweq ( weqcomp ( weqonsecbase P sx ) ( weqstnprod ( funcomp ( pr1 sx ) P ) ( funcomp ( pr1 sx ) f ) ( fun i : stn n => fs ( ( pr1 sx ) i ) ) ) ) . 69 | 70 | Definition nelstructonweq { X : UU0 } { n : nat } ( sx : nelstruct n X ) : nelstruct ( factorial n ) ( weq X X ) := weqcomp ( invweq ( weqfromweqstntostn n ) ) ( weqcomp ( weqbweq _ ( invweq sx ) ) ( weqfweq _ sx ) ) . 71 | 72 | 73 | 74 | (** *** The property of [ X ] to have [ n ] elements *) 75 | 76 | Definition isofnel ( n : nat ) ( X : UU0 ) : hProp := ishinh ( weq ( stn n ) X ) . 77 | 78 | Lemma isofneluniv { n : nat} { X : UU0 } ( P : hProp ) : ( ( nelstruct n X ) -> P ) -> ( isofnel n X -> P ) . 79 | Proof. intros. apply @hinhuniv with ( weq ( stn n ) X ) . assumption. assumption. Defined. 80 | 81 | Definition isofnelstn ( n : nat ) : isofnel n ( stn n ) := hinhpr _ ( nelstructonstn n ) . 82 | 83 | Definition isofnelweqf { X Y : UU0 } { n : nat } ( w : weq X Y ) ( sx : isofnel n X ) : isofnel n Y := hinhfun ( fun sx0 : _ => nelstructweqf w sx0 ) sx . 84 | 85 | Definition isofnelweqb { X Y : UU0 } { n : nat } ( w : weq X Y ) ( sy : isofnel n Y ) : isofnel n X := hinhfun ( fun sy0 : _ => nelstructweqb w sy0 ) sy . 86 | 87 | Definition isofnelempty : isofnel 0 empty := hinhpr _ nelstructonempty . 88 | 89 | Definition isofnelempty2 { X : UU0 } ( is : neg X ) : isofnel 0 X := hinhpr _ ( nelstructonempty2 is ) . 90 | 91 | Definition isofnelunit : isofnel 1 unit := hinhpr _ nelstructonunit . 92 | 93 | Definition isofnelcontr { X : UU0 } ( is : iscontr X ) : isofnel 1 X := hinhpr _ ( nelstructoncontr is ) . 94 | 95 | Definition isofnelbool : isofnel 2 bool := hinhpr _ nelstructonbool . 96 | 97 | Definition isofnelcoprodwithunit { X : UU0 } { n : nat } ( sx : isofnel n X ) : isofnel ( S n ) ( coprod X unit ) := hinhfun ( fun sx0 : _ => nelstructoncoprodwithunit sx0 ) sx . 98 | 99 | Definition isofnelcompl { X : UU0 } { n : nat } ( x : X ) ( sx : isofnel ( S n ) X ) : isofnel n ( compl X x ) := hinhfun ( fun sx0 : _ => nelstructoncompl x sx0 ) sx . 100 | 101 | Definition isofnelcoprod { X Y : UU0 } { n m : nat } ( sx : isofnel n X ) ( sy : isofnel m Y ) : isofnel ( n + m ) ( coprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => nelstructoncoprod sx0 sy0 ) sx sy . 102 | 103 | (** For a result corresponding to [ nelstructontotal2 ] see below . *) 104 | 105 | Definition isofnelondirprod { X Y : UU0 } { n m : nat } ( sx : isofnel n X ) ( sy : isofnel m Y ) : isofnel ( n * m ) ( dirprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => nelstructondirprod sx0 sy0 ) sx sy . 106 | 107 | Definition isofnelonfun { X Y : UU0 } { n m : nat } ( sx : isofnel n X ) ( sy : isofnel m Y ) : isofnel ( natpower m n ) ( X -> Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => nelstructonfun sx0 sy0 ) sx sy . 108 | 109 | (** For a result corresponding to [ nelstructonforall ] see below . *) 110 | 111 | Definition isofnelonweq { X : UU0 } { n : nat } ( sx : isofnel n X ) : isofnel ( factorial n ) ( weq X X ) := hinhfun ( fun sx0 : _ => nelstructonweq sx0 ) sx . 112 | 113 | 114 | 115 | 116 | (** ** General finite sets. *) 117 | 118 | (** *** Finite structure on a type [ X ] defined as a pair [ ( n , w ) ] where [ n : nat ] and [ w : weq ( stn n ) X ] *) 119 | 120 | 121 | Definition finstruct ( X : UU0 ) := total2 ( fun n : nat => nelstruct n X ) . 122 | Definition fintructpair ( X : UU0 ) := tpair ( fun n : nat => nelstruct n X ) . 123 | 124 | Definition finstructonstn ( n : nat ) : finstruct ( stn n ) := tpair _ n ( nelstructonstn n ) . 125 | 126 | Definition finstructweqf { X Y : UU0 } ( w : weq X Y ) ( sx : finstruct X ) : finstruct Y := tpair _ ( pr1 sx ) ( nelstructweqf w ( pr2 sx ) ) . 127 | 128 | Definition finstructweqb { X Y : UU0 } ( w : weq X Y ) ( sy : finstruct Y ) : finstruct X := tpair _ ( pr1 sy ) ( nelstructweqb w ( pr2 sy ) ) . 129 | 130 | Definition finstructonempty : finstruct empty := tpair _ 0 nelstructonempty . 131 | 132 | Definition finstructonempty2 { X : UU0 } ( is : neg X ) : finstruct X := tpair _ 0 ( nelstructonempty2 is ) . 133 | 134 | Definition finstructonunit : finstruct unit := tpair _ 1 nelstructonunit . 135 | 136 | Definition finstructoncontr { X : UU0 } ( is : iscontr X ) : finstruct X := tpair _ 1 ( nelstructoncontr is ) . 137 | 138 | (** It is not difficult to show that a direct summand of a finite set is a finite set . As a corrolary it follows that a proposition ( a type of h-level 1 ) is a finite set if and only if it is decidable . *) 139 | 140 | Definition finstructonbool : finstruct bool := tpair _ 2 nelstructonbool . 141 | 142 | Definition finstructoncoprodwithunit { X : UU0 } ( sx : finstruct X ) : finstruct ( coprod X unit ) := tpair _ ( S ( pr1 sx ) ) ( nelstructoncoprodwithunit ( pr2 sx ) ) . 143 | 144 | Definition finstructoncompl { X : UU0 } ( x : X ) ( sx : finstruct X ) : finstruct ( compl X x ) . 145 | Proof . intros . unfold finstruct . unfold finstruct in sx . destruct sx as [ n w ] . destruct n as [ | n ] . destruct ( negstn0 ( invweq w x ) ) . split with n . apply ( nelstructoncompl x w ) . Defined . 146 | 147 | Definition finstructoncoprod { X Y : UU0 } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( coprod X Y ) := tpair _ ( ( pr1 sx ) + ( pr1 sy ) ) ( nelstructoncoprod ( pr2 sx ) ( pr2 sy ) ) . 148 | 149 | Definition finstructontotal2 { X : UU0 } ( P : X -> UU0 ) ( sx : finstruct X ) ( fs : forall x : X , finstruct ( P x ) ) : finstruct ( total2 P ) := tpair _ ( stnsum ( funcomp ( pr1 ( pr2 sx ) ) ( fun x : X => pr1 ( fs x ) ) ) ) ( nelstructontotal2 P ( fun x : X => pr1 ( fs x ) ) ( pr2 sx ) ( fun x : X => pr2 ( fs x ) ) ) . 150 | 151 | Definition finstructondirprod { X Y : UU0 } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( dirprod X Y ) := tpair _ ( ( pr1 sx ) * ( pr1 sy ) ) ( nelstructondirprod ( pr2 sx ) ( pr2 sy ) ) . 152 | 153 | Definition finstructondecsubset { X : UU0 } ( f : X -> bool ) ( sx : finstruct X ) : finstruct ( hfiber f true ) := tpair _ ( pr1 ( weqfromdecsubsetofstn ( funcomp ( pr1 ( pr2 sx ) ) f ) ) ) ( weqcomp ( invweq ( pr2 ( weqfromdecsubsetofstn ( funcomp ( pr1 ( pr2 sx ) ) f ) ) ) ) ( weqhfibersgwtog ( pr2 sx ) f true ) ) . 154 | 155 | 156 | Definition finstructonfun { X Y : UU0 } ( sx : finstruct X ) ( sy : finstruct Y ) : finstruct ( X -> Y ) := tpair _ ( natpower ( pr1 sy ) ( pr1 sx ) ) ( nelstructonfun ( pr2 sx ) ( pr2 sy ) ) . 157 | 158 | Definition finstructonforall { X : UU0 } ( P : X -> UU0 ) ( sx : finstruct X ) ( fs : forall x : X , finstruct ( P x ) ) : finstruct ( forall x : X , P x ) := tpair _ ( stnprod ( funcomp ( pr1 ( pr2 sx ) ) ( fun x : X => pr1 ( fs x ) ) ) ) ( nelstructonforall P ( fun x : X => pr1 ( fs x ) ) ( pr2 sx ) ( fun x : X => pr2 ( fs x ) ) ) . 159 | 160 | Definition finstructonweq { X : UU0 } ( sx : finstruct X ) : finstruct ( weq X X ) := tpair _ ( factorial ( pr1 sx ) ) ( nelstructonweq ( pr2 sx ) ) . 161 | 162 | 163 | 164 | 165 | (** *** The property of being finite *) 166 | 167 | Definition isfinite ( X : UU0 ) := ishinh ( finstruct X ) . 168 | 169 | Definition fincard { X : UU0 } ( is : isfinite X ) : nat . 170 | Proof . intros . set ( int := carrier ( fun n : nat => isofnel n X ) ) . set ( f1 := ( fun nw : finstruct X => tpair ( fun n : nat => isofnel n X ) ( pr1 nw ) ( hinhpr _ ( pr2 nw ) ) ) : finstruct X -> int ) . assert ( isp : isaprop int ) . apply isapropsubtype . intros x1 x2 is1 is2 . apply ( @hinhuniv2 ( nelstruct x1 X ) ( nelstruct x2 X ) ( hProppair _ ( isasetnat x1 x2 ) ) ) . intros sx1 sx2 . apply ( weqtoeqstn x1 x2 ( weqcomp sx1 ( invweq sx2 ) ) ) . apply is1 . apply is2 . apply ( @hinhuniv _ ( hProppair _ isp ) f1 ) . apply is . Defined . 171 | 172 | Theorem ischoicebasefiniteset { X : UU0 } ( is : isfinite X ) : ischoicebase X . 173 | Proof . intros . apply ( @hinhuniv ( finstruct X ) ( ischoicebase X ) ) . intro nw . destruct nw as [ n w ] . apply ( ischoicebaseweqf w ( ischoicebasestn n ) ) . apply is . Defined . 174 | 175 | 176 | Definition isfinitestn ( n : nat ) : isfinite ( stn n ) := hinhpr _ ( finstructonstn n ) . 177 | 178 | Definition isfiniteweqf { X Y : UU0 } ( w : weq X Y ) ( sx : isfinite X ) : isfinite Y := hinhfun ( fun sx0 : _ => finstructweqf w sx0 ) sx . 179 | 180 | Definition isfiniteweqb { X Y : UU0 } ( w : weq X Y ) ( sy : isfinite Y ) : isfinite X := hinhfun ( fun sy0 : _ => finstructweqb w sy0 ) sy . 181 | 182 | Definition isfiniteempty : isfinite empty := hinhpr _ finstructonempty . 183 | 184 | Definition isfiniteempty2 { X : UU0 } ( is : neg X ) : isfinite X := hinhpr _ ( finstructonempty2 is ) . 185 | 186 | Definition isfiniteunit : isfinite unit := hinhpr _ finstructonunit . 187 | 188 | Definition isfinitecontr { X : UU0 } ( is : iscontr X ) : isfinite X := hinhpr _ ( finstructoncontr is ) . 189 | 190 | Definition isfinitebool : isfinite bool := hinhpr _ finstructonbool . 191 | 192 | Definition isfinitecoprodwithunit { X : UU0 } ( sx : isfinite X ) : isfinite ( coprod X unit ) := hinhfun ( fun sx0 : _ => finstructoncoprodwithunit sx0 ) sx . 193 | 194 | Definition isfinitecompl { X : UU0 } ( x : X ) ( sx : isfinite X ) : isfinite ( compl X x ) := hinhfun ( fun sx0 : _ => finstructoncompl x sx0 ) sx . 195 | 196 | Definition isfinitecoprod { X Y : UU0 } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( coprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructoncoprod sx0 sy0 ) sx sy . 197 | 198 | Definition isfinitetotal2 { X : UU0 } ( P : X -> UU0 ) ( sx : isfinite X ) ( fs : forall x : X , isfinite ( P x ) ) : isfinite ( total2 P ) . 199 | Proof . intros . set ( fs' := ischoicebasefiniteset sx _ fs ) . apply ( hinhfun2 ( fun fx0 : forall x : X , finstruct ( P x ) => fun sx0 : _ => finstructontotal2 P sx0 fx0 ) fs' sx ) . Defined . 200 | 201 | Definition isfinitedirprod { X Y : UU0 } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( dirprod X Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructondirprod sx0 sy0 ) sx sy . 202 | 203 | Definition isfinitedecsubset { X : UU0 } ( f : X -> bool ) ( sx : isfinite X ) : isfinite ( hfiber f true ) := hinhfun ( fun sx0 : _ => finstructondecsubset f sx0 ) sx . 204 | 205 | Definition isfinitefun { X Y : UU0 } ( sx : isfinite X ) ( sy : isfinite Y ) : isfinite ( X -> Y ) := hinhfun2 ( fun sx0 : _ => fun sy0 : _ => finstructonfun sx0 sy0 ) sx sy . 206 | 207 | Definition isfiniteforall { X : UU0 } ( P : X -> UU0 ) ( sx : isfinite X ) ( fs : forall x : X , isfinite ( P x ) ) : isfinite ( forall x : X , P x ) . 208 | Proof . intros . set ( fs' := ischoicebasefiniteset sx _ fs ) . apply ( hinhfun2 ( fun fx0 : forall x : X , finstruct ( P x ) => fun sx0 : _ => finstructonforall P sx0 fx0 ) fs' sx ) . Defined . 209 | 210 | Definition isfiniteweq { X : UU0 } ( sx : isfinite X ) : isfinite ( weq X X ) := hinhfun ( fun sx0 : _ => finstructonweq sx0 ) sx . 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | (* 223 | 224 | (* The cardinality of finite sets using double negation and decidability of equality in nat. *) 225 | 226 | Definition carddneg ( X : UU0 ) (is: isfinite X): nat:= pr1 (isfiniteimplisfinite0 X is). 227 | 228 | Definition preweq ( X : UU0 ) (is: isfinite X): isofnel (carddneg X is) X. 229 | Proof. intros X is X0. set (c:= carddneg X is). set (dnw:= pr2 (isfiniteimplisfinite0 X is)). simpl in dnw. change (pr1 nat (fun n : nat => isofnel0 n X) (isfiniteimplisfinite0 X is)) with c in dnw. 230 | 231 | assert (f: dirprod (finitestruct X) (dneg (weq (stn c) X)) -> weq (stn c) X). intro H. destruct H as [ t x ]. destruct t as [ t x0 ]. 232 | assert (dw: dneg (weq (stn t) (stn c))). set (ff:= fun ab:dirprod (weq (stn t) X)(weq (stn c) X) => weqcomp _ _ _ (pr1 ab) (invweq (pr2 ab))). apply (dnegf _ _ ff (inhdnegand _ _ (todneg _ x0) x)). 233 | assert (e:paths t c). apply (stnsdnegweqtoeq _ _ dw). clear dnw. destruct e. assumption. unfold isofnel. 234 | apply (hinhfun _ _ f (hinhand (finitestruct X) _ is (hinhpr _ dnw))). Defined. 235 | 236 | *) 237 | 238 | (* to be completed 239 | 240 | Theorem carddnegweqf (X Y:UU0)(f: X -> Y)(isw:isweq f)(isx: isfinite X): paths (carddneg _ isx) (carddneg _ (isfiniteweqf _ _ _ isw isx)). 241 | Proof. intros. *) 242 | 243 | (* The cardinality of finite sets defined using the "impredicative" ishinh *) 244 | 245 | 246 | 247 | (** ** Test computations. *) 248 | 249 | 250 | 251 | (*Eval compute in carddneg _ (isfinitedirprod _ _ (isfinitestn (S (S (S (S O))))) (isfinitestn (S (S (S O))))).*) 252 | 253 | Eval compute in fincard (isfiniteempty). 254 | 255 | Eval compute in fincard (isfiniteunit). 256 | 257 | Eval compute in fincard (isfinitebool). 258 | 259 | 260 | 261 | 262 | (*Eval lazy in (pr1 (finitestructcomplement _ (dirprodpair _ _ tt tt) (finitestructdirprod _ _ (finitestructunit) (finitestructunit)))).*) 263 | 264 | 265 | 266 | 267 | Eval lazy in fincard (isfinitecompl true isfinitebool). 268 | 269 | Eval compute in fincard (isfinitedirprod isfinitebool isfinitebool). 270 | 271 | Eval compute in fincard (isfinitedirprod isfinitebool (isfinitedirprod isfinitebool isfinitebool)). 272 | 273 | Eval lazy in fincard (isfinitecompl (ii1 tt) (isfinitecoprod (isfiniteunit) (isfinitebool))). 274 | 275 | Eval lazy in fincard (isfinitecompl (ii1 tt) (isfinitecoprod (isfiniteunit) (isfinitebool))). 276 | 277 | Eval lazy in fincard (isfinitecompl (dirprodpair tt tt) (isfinitedirprod isfiniteunit isfiniteunit)). 278 | 279 | Eval lazy in fincard (isfinitecompl (dirprodpair true (dirprodpair true false)) (isfinitedirprod (isfinitebool) (isfinitedirprod (isfinitebool) (isfinitebool)))). 280 | 281 | Eval lazy in fincard ( isfiniteweq ( isfinitedirprod ( isfinitedirprod isfinitebool isfinitebool ) isfinitebool ) ) . 282 | 283 | 284 | 285 | 286 | 287 | 288 | 289 | (* End of the file finitesets.v *) 290 | 291 | 292 | 293 | 294 | 295 | (* 296 | *** Local Variables: *** 297 | *** coq-prog-name: "/opt/local/bin/coqtop" *** 298 | *** coq-prog-args: ("-emacs-U") *** 299 | *** End: *** 300 | *) -------------------------------------------------------------------------------- /LICS2012/w_is_hinitial/hinitial_implies_w.v: -------------------------------------------------------------------------------- 1 | Add Rec LoadPath "../univalent_foundations/Generalities". 2 | Add Rec LoadPath "../identity". 3 | 4 | Unset Automatic Introduction. 5 | Require Export uu0. 6 | Require Export identity. 7 | Require Export polynomial_functors. 8 | 9 | (** * Preliminaries *) 10 | 11 | Section Preliminaries. 12 | 13 | Definition pullbackalongeval {X Y : U}(E : Y -> U) : 14 | forall (x : X), (X -> Y) -> U. 15 | Proof. 16 | intros X Y E x. 17 | apply (fun f : X -> Y => E (f x)). 18 | Defined. 19 | 20 | Variable A : U. 21 | Variable B : A -> U. 22 | 23 | Definition lemma_on_transportf {X : U}(s_X : (P_0 _ B X) -> X)(E : X -> U)(x : A)(u : B x -> X){f_1 f_2 : X -> X}(e : Id f_1 f_2) : 24 | Id 25 | (transportf (pullbackalongeval E (dpair _ x u)) (comppathwithfun (P_2 _ _ e) s_X)) 26 | (transportf (fun f => E (s_X (dpair _ x (funcomp u f)))) e). 27 | Proof. 28 | intros. 29 | destruct e. 30 | unfold transportf. 31 | simpl. 32 | unfold P_1. 33 | unfold idfun. 34 | simpl. 35 | apply funextfun. 36 | intro t. 37 | apply refl. 38 | Defined. 39 | 40 | Definition lemma_on_transportb {X : U}(s_X : (P_0 _ B X) -> X)(E : X -> U)(x : A)(u : B x -> X){f_1 f_2 : (P_0 _ _ X) -> X}(e : Id f_1 f_2) : 41 | Id 42 | (transportb (pullbackalongeval E (dpair _ x u)) e) 43 | (transportb (fun z : (P_0 _ _ X) -> X => E (z (dpair _ x u))) e). 44 | Proof. 45 | intros. 46 | destruct e. 47 | unfold transportb. 48 | unfold transportf. 49 | simpl. 50 | unfold idfun. 51 | apply refl. 52 | Defined. 53 | 54 | Definition second_lemma_on_transportf {X : U}(s_X : (P_0 _ B X) -> X)(E : X -> U)(x : A)(u : B x -> X){f_1 f_2 : X -> X}(e : Id f_1 f_2) : 55 | forall (y : E (f_1 (s_X (dpair _ x u)))), Id 56 | (transportf (fun z : X -> X => E (z (s_X (dpair _ x u)))) e y) 57 | (transportf (fun z : (P_0 _ B X) -> X => E (z (dpair _ x u))) (compfunwithpath s_X e) y). 58 | Proof. 59 | intros. 60 | destruct e. 61 | unfold transportf. 62 | simpl. 63 | unfold idfun. 64 | apply refl. 65 | Defined. 66 | 67 | (** General version of diagram (G) *) 68 | 69 | Definition general_diagram_G (XX YY : P_Alg _ B)(ff gg : P_Alg_Map _ _ XX YY) 70 | (ee : P_Alg_2cell _ _ ff gg)(E : (p1 YY) -> U) : forall c : (P_0 _ _ (p1 XX)), Id 71 | (funcomp 72 | (transportb (pullbackalongeval E c) (p2 ff)) 73 | (transportf (pullbackalongeval E c) (compfunwithpath (p2 XX) (p1 ee)))) 74 | (funcomp 75 | (transportf (pullbackalongeval E c) (comppathwithfun (P_2 _ _ (p1 ee)) (p2 YY))) 76 | (transportb (pullbackalongeval E c) (p2 gg))). 77 | 78 | Proof. 79 | intros XX YY ff gg ee E c. 80 | apply (beck_chevalley_for_paths (pullbackalongeval E c) ). 81 | apply (pathsinv0). 82 | apply (p2 ee). 83 | Defined. 84 | 85 | 86 | (** General version of diagram (H) *) 87 | 88 | 89 | Definition top_shift (XX : P_Alg _ B)(E : (p1 XX) -> U) : 90 | forall (x : A)(u : B x -> (p1 XX)), (B x -> (p1 XX)) -> U. 91 | Proof. 92 | intros XX E x u. 93 | apply (fun f : B x -> (p1 XX) => forall y : B x, E (f y)). 94 | Defined. 95 | 96 | Definition bottom_shift (XX : P_Alg _ B)(E : (p1 XX) -> U) : 97 | forall (x : A)(u : B x -> (p1 XX)), (B x -> (p1 XX)) -> U. 98 | Proof. 99 | intros XX E x u. 100 | apply (fun f : B x -> (p1 XX) => E ((p2 XX) (dpair _ x f))). 101 | Defined. 102 | 103 | Definition general_diagram_H (XX : P_Alg _ B)(E : (p1 XX) -> U)(d : forall (x : A)(u : B x -> (p1 XX))(v : forall y : B x, E (u y)), E( (p2 XX) (dpair _ x u))) : 104 | forall (x : A)(u : B x -> (p1 XX)), 105 | Id 106 | (funcomp (transportb (top_shift XX E x u) (eta_path u)) (d x u)) 107 | (funcomp (d x (funcomp u (idfun (p1 XX)))) (transportb (bottom_shift XX E x u) (eta_path u))). 108 | 109 | Proof. 110 | intros. 111 | set (X := (p1 XX)). 112 | set (s_X := (p2 XX) : (P_0 _ B X) -> X). 113 | set (P := (top_shift XX E x u)). 114 | set (Q := (bottom_shift XX E x u)). 115 | set (s := fun f : B x -> X => (d x f)). 116 | apply (naturalityoftransportb P Q s (eta_path u)). 117 | Defined. 118 | 119 | (** We combine the previous observations on 120 | transport along etapath to simplify the 121 | expression of diagram (H) *) 122 | 123 | Definition lemma_to_simplify_general_diagram_H 124 | (XX : P_Alg _ B) 125 | (E : (p1 XX) -> U) 126 | (d : forall (x : A)(u : B x -> (p1 XX))(v : forall y : B x, E (u y)), E( (p2 XX) (dpair _ x u))) : 127 | forall (x : A)(u : B x -> (p1 XX)), Id (transportb (top_shift XX E x u) (eta_path u)) (idfun (top_shift XX E x u u)). 128 | Proof. 129 | intros. 130 | set (X := (p1 XX)). 131 | set (s_X := (p2 XX) : (P_0 _ B X) -> X). 132 | set (P := (top_shift XX E x u)). 133 | Check (transportb P (eta_path u)). 134 | assert (e_1 : Id 135 | (transportb P (eta_path u)) 136 | (pathsectiontransportb (B x) X E (eta_path u))). 137 | unfold pathsectiontransportb. 138 | apply funextsec. 139 | intro s. 140 | unfold P. 141 | unfold top_shift. 142 | unfold transportb. 143 | apply refl. 144 | apply (transportb (fun z => Id z (idfun (P u))) e_1). 145 | unfold P. 146 | apply (pathtransportbalongetaisidentity (B x) X E). 147 | Defined. 148 | 149 | 150 | Definition simplified_general_diagram_H 151 | (XX : P_Alg _ B) 152 | (E : (p1 XX) -> U) 153 | (d : forall (x : A)(u : B x -> (p1 XX))(v : forall y : B x, E (u y)), E( (p2 XX) (dpair _ x u))) : 154 | forall (x : A)(u : B x -> (p1 XX)), 155 | Id 156 | (funcomp (d x (funcomp u (idfun (p1 XX)))) (transportb (bottom_shift XX E x u) (eta_path u))) 157 | (d x u). 158 | 159 | Proof. 160 | intros. 161 | apply (transportf (fun z => Id z _ ) (general_diagram_H XX E d x u)). 162 | apply (transportb (fun z => Id (funcomp z _ ) _ ) (lemma_to_simplify_general_diagram_H XX E d x u)). 163 | unfold funcomp. 164 | unfold idfun. 165 | simpl. 166 | apply funextfun. 167 | intro v. 168 | apply refl. 169 | Defined. 170 | 171 | 172 | Definition super_simplified_general_diagram_H (XX : P_Alg _ B) 173 | (E : (p1 XX) -> U) 174 | (d : forall (x : A)(u : B x -> (p1 XX))(v : forall y : B x, E (u y)), E( (p2 XX) (dpair _ x u))) : 175 | forall (x : A)(u : B x -> (p1 XX)), 176 | Id 177 | (funcomp (d x (funcomp u (idfun (p1 XX)))) (transportb (fun z => E (z (dpair _ x u))) (idfunisalgmap _ _ XX))) 178 | (d x u). 179 | Proof. 180 | intros. 181 | set (e_1 := (transportb (fun z => E (z (dpair _ x u))) (idfunisalgmap _ _ XX))). 182 | set (e_2 := (transportb (bottom_shift XX E x u) (eta_path u))). 183 | assert (p : Id e_1 e_2). 184 | unfold e_1. 185 | unfold e_2. 186 | unfold bottom_shift. 187 | apply (first_and_second_fact _ _ XX E x u). 188 | apply (transportb (fun z => Id (funcomp (d x (funcomp u (idfun (p1 XX)))) z) (d x u)) p). 189 | apply (simplified_general_diagram_H XX E d x u). 190 | Defined. 191 | 192 | (** General version of diagram (K) *) 193 | 194 | Definition general_diagram_K (XX : P_Alg _ B)(E : (p1 XX) -> U)(d : forall (x : A)(u : B x -> (p1 XX))(v : forall y : B x, E (u y)), E( (p2 XX) (dpair _ x u))) : 195 | forall (f g : (p1 XX) -> (p1 XX))(e : Id f g)(x : A)(u : B x -> (p1 XX)), 196 | Id 197 | (funcomp 198 | (transportf (fun v : (p1 XX) -> (p1 XX) => forall y : B x, (E ( (funcomp u v) y))) e) 199 | (d x (funcomp u g))) 200 | (funcomp 201 | (d x (funcomp u f)) 202 | (transportf (fun v : (p1 XX) -> (p1 XX) => E ( (p2 XX) (dpair _ x (funcomp u v)))) e)). 203 | 204 | Proof. 205 | intros XX E d f g e x u. 206 | set (X := (p1 XX)). 207 | set (s_X := (p2 XX)). 208 | set (P := (fun v : X -> X => forall y : B x, (E ( (funcomp u v) y)))). 209 | set (Q := (fun v : X -> X => E (s_X (dpair _ x (funcomp u v))))). 210 | set (s := (fun v : X -> X => d x (funcomp u v))). 211 | apply (naturalityoftransportf P Q s e). 212 | Defined. 213 | 214 | Definition remark_on_general_diagram_K (XX : P_Alg _ B)(E : (p1 XX) -> U)(d : forall (x : A)(u : B x -> (p1 XX))(v : forall y : B x, E (u y)), E( (p2 XX) (dpair _ x u))) : 215 | forall (f g : (p1 XX) -> (p1 XX))(e : Id f g)(x : A)(u : B x -> (p1 XX))(v : forall y : B x, E (f ( u y))), 216 | Id ((transportf (fun v : (p1 XX) -> (p1 XX) => forall y : B x, (E ( (funcomp u v) y))) e) v) 217 | (fun y : B x => ((transportf (fun z => E (z (u y))) e) (v y))). 218 | Proof. 219 | intros. 220 | destruct e. 221 | unfold transportf. 222 | simpl. 223 | unfold idfun. 224 | apply funextsec. 225 | intro y. 226 | apply refl. 227 | Defined. 228 | 229 | End Preliminaries. 230 | 231 | (** ** From h-initial algebras to W-types *) 232 | 233 | 234 | Section From_h_initial_algebra_to_W_types. 235 | 236 | (** We fix the data for a polynomial functor *) 237 | 238 | Variable A : U. 239 | Variable B : A -> U. 240 | 241 | (** We assume to have a h-initial algebra *) 242 | 243 | Axiom WW : P_Alg _ B. 244 | Axiom is : ishinitial _ B WW. 245 | 246 | (** Some notation *) 247 | 248 | Definition W := p1 WW. 249 | Definition s_W := p2 WW : (P_0 _ B W) -> W. 250 | 251 | (** We define the introduction terms *) 252 | 253 | 254 | Definition sup (x : A)(u : B x -> W) : W := (s_W (dpair (fun a : A => (B a -> W)) x u)). 255 | 256 | (** To derive the elimination rule, we 257 | assume its premisses *) 258 | 259 | Variable E : W -> U. 260 | Variable d : forall (x : A)(u : B x -> W)(v : forall y : B x, E(u y)), E(sup x u). 261 | 262 | (** We begin by constructing an algebra 263 | structure on (Sigma w : W) E w *) 264 | 265 | Definition X := Sigma E. 266 | 267 | Definition s_X : (P_0 _ B X) -> X. 268 | Proof. 269 | intro c. 270 | destruct c as [x u]. 271 | split with (sup x (fun x => p1 (u x))). 272 | apply (d x (fun x => p1 (u x)) (fun y : B x => p2 (u y))). 273 | Defined. 274 | 275 | Definition XX := (dpair (isalg _ B) X s_X). 276 | 277 | (** We apply the h-initiality of W to get 278 | an algebra map from WW to XX *) 279 | 280 | 281 | Definition jj : P_Alg_Map _ _ WW XX. 282 | Proof. 283 | apply (p1 (is XX)). 284 | Defined. 285 | 286 | Definition j : W -> X := (p1 jj). 287 | 288 | Definition s_j : isalgmap _ _ WW XX j. 289 | Proof. 290 | unfold isalgmap. 291 | change (p2 WW) with s_W. 292 | change (p2 XX) with s_X. 293 | apply (p2 jj). 294 | Defined. 295 | 296 | Definition s_j_flat : forall w : (P_0 _ _ W), 297 | Id (j (s_W w)) (s_X (P_1 _ _ j w)). 298 | Proof. 299 | intros. 300 | apply (toforallpaths _ _ _ s_j w). 301 | Defined. 302 | 303 | (** We now show that the projection function 304 | p1 : (Sigma w : W) --> W is an algebra map *) 305 | 306 | Check p1. 307 | 308 | Definition isalgmapp1 : isalgmap _ B XX WW (@p1 W E). 309 | Proof. 310 | intros. 311 | unfold isalgmap. 312 | apply funextfun. 313 | intro c. 314 | destruct c as [x u]. 315 | apply refl. 316 | Defined. 317 | 318 | Definition pp := (dpair (isalgmap _ _ XX WW) (@p1 W E) isalgmapp1). 319 | 320 | (** By composition of j and p1 we get 321 | an algebra map from W to itself. 322 | However, we construct a specific 323 | proof that has good computational 324 | properties *) 325 | 326 | 327 | Definition sigma_j : forall c : (P_0 _ B W), 328 | Id (j (s_W c)) (s_X (P_1 _ _ j c)). 329 | Proof. 330 | apply (toforallpaths _ _ _ s_j). 331 | Defined. 332 | 333 | Definition sigma_j_1_2 : forall w : (P_0 _ B W), 334 | Sigma (fun e : Id (p1 (j (s_W w))) (p1 ((s_X (P_1 _ _ j w)))) => 335 | Id (transportf E e (p2 (j (s_W w)))) (p2 ((s_X (P_1 _ _ j w))))). 336 | Proof. 337 | intros. 338 | apply idsigmatosigmaid. 339 | apply sigma_j. 340 | Defined. 341 | 342 | Definition sigma_j_1 : forall w : (P_0 _ B W), 343 | Id (p1 (j (s_W w))) (p1 ((s_X (P_1 _ _ j w)))). 344 | Proof. 345 | intros. 346 | apply (p1 (sigma_j_1_2 w)). 347 | Defined. 348 | 349 | Definition sigma_j_2 : forall w : (P_0 _ B W), 350 | Id (transportf E (sigma_j_1 w) (p2 (j (s_W w)))) (p2 ((s_X (P_1 _ _ j w)))). 351 | Proof. 352 | intros. 353 | apply (p2 (sigma_j_1_2 w)). 354 | Defined. 355 | 356 | Definition isalgmapjjpp : isalgmap _ _ _ _ (funcomp j (@p1 W E)) 357 | := (funextfun _ _ sigma_j_1). 358 | 359 | 360 | Definition jjpp := (dpair _ (funcomp j (@p1 W E)) isalgmapjjpp) : P_Alg_Map _ _ WW WW. 361 | 362 | (** This will be useful in the following 363 | It is just a special case of the general 364 | results on global vs pointwise transport *) 365 | 366 | 367 | Definition lemma_on_sigma_j : forall (w : P_0 _ B W)(t : E ( p1 ( j (s_W w)))), 368 | Id 369 | (transportf (fun z : (P_0 _ _ W) -> W => E (z w)) isalgmapjjpp t) 370 | (transportf E (sigma_j_1 w) t). 371 | Proof. 372 | intro w. 373 | unfold isalgmapjjpp. 374 | intro t. 375 | apply pathsinv0. 376 | set (e := toforallpaths _ _ _ (pointwisetransportfhomotopy _ _ E sigma_j_1 w)). 377 | apply (e t). 378 | Defined. 379 | 380 | (** Exploiting again the h-initiality of W 381 | we obtain that the composite of jj and 382 | pp is equal to the identity map - and 383 | so there is an algebra 2-cell between 384 | them *) 385 | 386 | 387 | Definition ee : P_Alg_2cell _ _ jjpp (idalgmap _ _ WW). 388 | Proof. 389 | apply (weqfromaidalgmaptoalg2cell _ _ jjpp (idalgmap _ _ WW)). 390 | apply (proofirrelevance _ (is WW) jjpp (idalgmap _ _ WW)). 391 | Defined. 392 | 393 | Definition e := (p1 ee) : Id (funcomp j (@p1 W E)) (idfun W). 394 | Definition s_e := (p2 ee) : isalg2cell _ _ jjpp (idalgmap _ _ WW) e. 395 | 396 | (** With the data constructed we can 397 | define the elimination terms for W *) 398 | 399 | Definition w_rec : forall w : W, E w := 400 | (fun w : W => (transportf (fun z : W -> W => E (z w)) e (p2 (j w)))). 401 | 402 | (** We now construct the special cases of the general 403 | diagrams (G), (H) and (K) constructed above *) 404 | 405 | Section Calculations. 406 | 407 | Variable x : A. 408 | Variable u : B x -> W. 409 | 410 | (** Some useful abbreviations *) 411 | 412 | Definition v_1 := (fun y : B x => p2 ( j (u y))) : forall y : B x, E (p1 (j (u y))). 413 | Definition v_2 := (transportf (fun z : W -> W => forall y : B x, E (funcomp u z y)) e v_1) : forall y : B x, E (u y). 414 | 415 | Definition E_1 := (fun v : W -> W => forall y : B x, E (funcomp u v y)). 416 | Definition E_2 (y : B x) := (fun z : W -> W => E (z (u y))). 417 | Definition E_3 := (fun z : (P_0 _ _ W) -> W => E (z (dpair _ x u))). 418 | Definition E_4 := (fun v : W -> W => E ( s_W (dpair _ x (funcomp u v)))). 419 | Definition E_5 (w : W) := (fun z : W -> W => E (z w)). 420 | 421 | (** The special case of diagram (G) *) 422 | 423 | 424 | Definition special_diagram_G : 425 | Id 426 | (funcomp 427 | (transportb E_3 isalgmapjjpp) 428 | (transportf E_3 (compfunwithpath s_W e))) 429 | (funcomp 430 | (transportf E_3 (comppathwithfun (P_2 _ _ e) s_W)) 431 | (transportb E_3 (p2 (idalgmap A B WW)))). 432 | Proof. 433 | intros. 434 | unfold E_3. 435 | set (p := (general_diagram_G _ _ WW WW jjpp (idalgmap _ _ WW) ee E)). 436 | set (pxu := p (dpair _ x u)). 437 | change (fun z : P_0 A B W -> W => 438 | E (z (dpair (fun a : A => B a -> W) x u))) with (pullbackalongeval E (dpair (fun a : A => B a -> p1 WW) x u)). 439 | change (p2 jjpp) with isalgmapjjpp in pxu. 440 | change (p2 WW) with s_W in pxu. 441 | change (p1 ee) with e in pxu. 442 | apply pxu. 443 | Admitted. 444 | 445 | Definition simplified_special_diagram_G : 446 | Id 447 | (funcomp 448 | (transportb E_3 isalgmapjjpp) 449 | (transportf E_3 (compfunwithpath s_W e))) 450 | (funcomp 451 | (transportf E_4 e) 452 | (transportb E_3 (p2 (idalgmap A B WW)))). 453 | Proof. 454 | intros. 455 | apply (transportf (fun z => Id _ (funcomp z _)) (lemma_on_transportf A B s_W E x u e)). 456 | apply (transportb (fun z => Id _ (funcomp _ z)) (lemma_on_transportb A B s_W E x u (p2 (idalgmap A B WW)))). 457 | apply (special_diagram_G). 458 | Defined. 459 | 460 | (** The special case of diagram (H) *) 461 | 462 | 463 | Definition super_simplified_special_diagram_H : 464 | Id 465 | (funcomp (d x (funcomp u (idfun W))) (transportb E_3 (idfunisalgmap _ _ WW))) 466 | (d x u). 467 | Proof. 468 | intros. 469 | apply (super_simplified_general_diagram_H _ _ WW E d x u). 470 | Defined. 471 | 472 | 473 | (** The special case of diagram (K) *) 474 | 475 | Definition special_diagram_K : 476 | Id 477 | (funcomp 478 | (transportf E_1 e) 479 | (d x (funcomp u (idfun W)))) 480 | (funcomp 481 | (d x (funcomp u (funcomp j (@p1 W E)))) 482 | (transportf E_4 e)). 483 | 484 | 485 | Proof. 486 | intros. 487 | apply (general_diagram_K _ _ WW E d (funcomp j (@p1 W E)) (idfun W) e x u). 488 | Defined. 489 | 490 | Definition remark_on_special_diagram_K : 491 | Id 492 | (fun y : B x => transportf (E_2 y) e (p2 (j (u y)))) 493 | (fun y : B x => w_rec (u y)). 494 | Proof. 495 | intros. 496 | apply refl. 497 | Defined. 498 | 499 | Definition second_remark_on_special_diagram_K : 500 | Id 501 | (transportf E_1 e (fun y : B x => p2 (j (u y)))) 502 | (fun y : B x => w_rec ( u y)). 503 | Proof. 504 | intros. 505 | apply (remark_on_general_diagram_K _ _ (dpair _ W s_W) E d (funcomp j (@p1 W E)) (idfun W) e x u (fun y : B x => p2 (j ( u y)))). 506 | Defined. 507 | 508 | (** We now perform the long calculation that 509 | derives the propositional version of the 510 | computation rule for W-types *) 511 | 512 | 513 | (** Step 1 *) 514 | 515 | Definition step_1 : 516 | Id (d x u (fun y => w_rec (u y))) 517 | (d x u (fun y => transportf (E_2 y) e (v_1 y))). 518 | Proof. 519 | apply refl. 520 | Defined. 521 | 522 | (** Step 2 *) 523 | 524 | Definition step_2 : 525 | Id 526 | (d x u (fun y => transportf (E_2 y) e (v_1 y))) 527 | (d x u v_2). 528 | Proof. 529 | assert ( 530 | p : Id 531 | (transportf E_1 e v_1) 532 | (fun y => transportf (E_2 y) e (v_1 y))). 533 | apply (remark_on_general_diagram_K _ _ (dpair _ W s_W) E d (funcomp j (@p1 W E)) (idfun W) e x u v_1). 534 | apply (transportf (fun z => Id (d x u z) _) p). 535 | apply refl. 536 | Defined. 537 | 538 | (** Step 3 *) 539 | 540 | Definition step_3 : 541 | Id 542 | (d x u v_2) 543 | ((funcomp (d x (funcomp u (idfun W))) (transportb E_3 (idfunisalgmap _ _ WW))) v_2). 544 | Proof. 545 | set (alpha := toforallpaths _ _ _ super_simplified_special_diagram_H). 546 | apply (pathsinv0 (alpha (transportf E_1 e v_1))). 547 | Defined. 548 | 549 | (** Step 4 *) 550 | 551 | Definition step_4 : 552 | Id 553 | ((funcomp (d x (funcomp u (idfun W))) (transportb E_3 (idfunisalgmap _ _ WW))) v_2) 554 | ((transportb E_3 (idfunisalgmap _ _ WW)) (d x (funcomp u (idfun W)) v_2)). 555 | Proof. 556 | apply refl. 557 | Defined. 558 | 559 | (** Step 5 *) 560 | 561 | Definition lemma_for_step_5 : 562 | Id 563 | (d x (funcomp u (idfun W)) v_2) 564 | ((funcomp (d x (funcomp u (funcomp j (@p1 W E)))) (transportf E_4 e)) v_1). 565 | Proof. 566 | unfold v_1. 567 | unfold v_2. 568 | set (alpha := toforallpaths _ _ _ special_diagram_K). 569 | apply (alpha v_1). 570 | Defined. 571 | 572 | Definition step_5 : 573 | Id 574 | ((transportb (fun z => E (z (dpair _ x u))) (idfunisalgmap _ _ WW)) 575 | (d x (funcomp u (idfun W)) v_2)) 576 | ((transportb (fun z => E (z (dpair _ x u))) (idfunisalgmap _ _ WW)) 577 | ((funcomp (d x (funcomp u (funcomp j (@p1 W E)))) (transportf (fun v : W -> W => E ( s_W (dpair _ x (funcomp u v)))) e)) v_1)). 578 | Proof. 579 | apply maponpaths. 580 | apply lemma_for_step_5. 581 | Defined. 582 | 583 | (** Step 6 *) 584 | 585 | Definition step_6 : 586 | Id 587 | ((transportb E_3 (idfunisalgmap _ _ WW)) ((funcomp (d x (funcomp u (funcomp j (@p1 W E)))) (transportf E_4 e)) v_1)) 588 | ((funcomp (transportf E_4 e) (transportb E_3 (idfunisalgmap _ _ WW))) (d x (funcomp u (funcomp j (@p1 W E))) v_1)). 589 | Proof. 590 | unfold funcomp. 591 | simpl. 592 | apply refl. 593 | Defined. 594 | 595 | (** Step 7 *) 596 | 597 | Definition step_7 : 598 | Id 599 | ((funcomp 600 | (transportf E_4 e) 601 | (transportb E_3 (idfunisalgmap _ _ WW))) 602 | (d x (funcomp u (funcomp j (@p1 W E))) v_1)) 603 | ((funcomp 604 | (transportb E_3 isalgmapjjpp) 605 | (transportf E_3 (compfunwithpath s_W e))) 606 | (d x (funcomp u (funcomp j (@p1 W E))) v_1)). 607 | Proof. 608 | set (s := (d x (funcomp u (funcomp j (@p1 W E))) v_1)). 609 | set (alpha := (toforallpaths _ _ _ simplified_special_diagram_G)). 610 | apply pathsinv0. 611 | set (p := (alpha s)). 612 | change (P_0 A B W -> W) with (Sigma (fun a : A => B a -> p1 WW) -> (p1 WW)) in p. 613 | change (p2 (idalgmap A B WW)) with (idfunisalgmap A B WW) in p. 614 | apply p. 615 | Admitted. 616 | 617 | (** Step 8 *) 618 | 619 | 620 | Definition step_8 : 621 | Id 622 | (transportf E_3 (compfunwithpath s_W e) ((transportb E_3 isalgmapjjpp) (d x (funcomp u (funcomp j (@p1 W E))) v_1))) 623 | (transportf E_3 (compfunwithpath s_W e) ((transportb E_3 isalgmapjjpp) (p2 (s_X (dpair _ x (funcomp u j)))))). 624 | Proof. 625 | unfold s_X. 626 | apply refl. 627 | Defined. 628 | 629 | Definition steps_1_4 := pathscomp0 (pathscomp0 (pathscomp0 step_1 step_2) step_3) step_4. 630 | Definition steps_1_8 := (pathscomp0 (pathscomp0 (pathscomp0 (pathscomp0 steps_1_4 step_5) step_6) step_7) step_8). 631 | 632 | (** Step 9 *) 633 | 634 | Definition lemma_for_step_9 : 635 | Id 636 | (transportb E_3 isalgmapjjpp (p2 (s_X (dpair _ x (funcomp u j))))) 637 | (p2 (j (sup x u))). 638 | Proof. 639 | apply transposetransportfb. 640 | set (e := (lemma_on_sigma_j (dpair _ x u) (p2 (j (s_W (dpair _ x u)))))). 641 | apply (transportb (fun z => Id _ z) e). 642 | apply (pathsinv0 (sigma_j_2 (dpair _ x u))). 643 | Defined. 644 | 645 | Definition step_9 : 646 | Id 647 | (transportf E_3 (compfunwithpath s_W e) ((transportb E_3 isalgmapjjpp) (p2 (s_X (dpair _ x (funcomp u j)))))) 648 | (transportf E_3 (compfunwithpath s_W e) (p2 (j (sup x u)))). 649 | Proof. 650 | apply (transportf (fun z => Id _ (transportf E_3 (compfunwithpath s_W e) z)) lemma_for_step_9). 651 | apply refl. 652 | Defined. 653 | 654 | (** Step 10 *) 655 | 656 | Definition step_10 : 657 | Id 658 | (transportf E_3 (compfunwithpath s_W e) (p2 (j (sup x u)))) 659 | (w_rec (sup x u)). 660 | Proof. 661 | unfold w_rec. 662 | unfold E_3. 663 | apply pathsinv0. 664 | change (fun z : W -> W => E (z (sup x u))) with (pullbackalongeval E (sup x u)). 665 | unfold pullbackalongeval. 666 | apply (second_lemma_on_transportf _ _ s_W E x u e (p2 (j (sup x u)))). 667 | Defined. 668 | 669 | (** Putting it all together *) 670 | 671 | Definition step_9_10 := (pathscomp0 step_9 step_10). 672 | 673 | Definition w_comp_calculation := (pathscomp0 steps_1_8 step_9_10). 674 | 675 | End Calculations. 676 | 677 | (** The W-computation rule *) 678 | 679 | 680 | Definition w_comp : forall (x : A)(u : B x -> W), 681 | Id (w_rec (sup x u)) (d x u (fun y : B x => w_rec ( u y))). 682 | 683 | Proof. 684 | intros. 685 | apply (pathsinv0 (w_comp_calculation x u)). 686 | Defined. 687 | 688 | End From_h_initial_algebra_to_W_types. 689 | 690 | 691 | -------------------------------------------------------------------------------- /LICS2012/w_is_hinitial/polynomial_functors.v: -------------------------------------------------------------------------------- 1 | Add Rec LoadPath "../univalent_foundations/Generalities". 2 | Add Rec LoadPath "../identity". 3 | 4 | Unset Automatic Introduction. 5 | Require Export uu0. 6 | Require Export identity. 7 | 8 | (** * Polynomial functors and their algebras *) 9 | 10 | Section Polynomial_Functors. 11 | 12 | Variable A : U. 13 | Variable B : A -> U. 14 | 15 | (** The action of P on types *) 16 | 17 | Definition P_0 : U -> U := 18 | (fun X : U => Sigma (fun a : A => (B a -> X))). 19 | 20 | (** The action of P on functions *) 21 | 22 | Definition P_1 {X Y : U}(f : X -> Y) : (P_0 X) -> (P_0 Y) := 23 | (fun x => dpair _ (p1 x) ( funcomp (p2 x) f )). 24 | 25 | (** Action of P on paths *) 26 | 27 | Definition P_2 {X Y : U}{f g : X -> Y}: 28 | Id f g -> Id (P_1 f) (P_1 g). 29 | Proof. 30 | intros X Y f g e. 31 | destruct e. 32 | apply refl. 33 | Defined. 34 | 35 | (** Functoriality of P *) 36 | 37 | Definition functorPcomp {X Y Z : U}(f : X -> Y)(g : Y -> Z) : 38 | Id (funcomp (P_1 f) (P_1 g)) (P_1 (funcomp f g)). 39 | Proof. 40 | intros. 41 | unfold P_1. 42 | apply funextfun. 43 | intro c. 44 | destruct c as [x u]. 45 | simpl. 46 | unfold funcomp. 47 | simpl. 48 | apply refl. 49 | Defined. 50 | 51 | Definition functorPid (X : U) : Id (P_1 (idfun X)) (idfun (P_0 X)). 52 | Proof. 53 | intros. 54 | unfold P_1. 55 | apply funextfun. 56 | intro c. 57 | destruct c as [x u]. 58 | simpl. 59 | unfold funcomp. 60 | unfold idfun. 61 | apply (idfibertoidsigma). 62 | apply (pathsinv0 (eta_path u)). 63 | Defined. 64 | 65 | 66 | 67 | (** We define an action of P also on the 2-category of types, functions and homotopies 68 | The only thing to define is the action of P on homotopies For this we need an auxiliary map. *) 69 | 70 | Definition tau : forall (X Y : U)( f g : X -> Y)(x : A)(u : B x -> X) ( v : forall (y : B x), Id ( f (u y)) (g (u y)) ), 71 | Id (dpair _ x (funcomp u f)) (dpair (fun a : A => (B a -> Y)) x (funcomp u g)). 72 | Proof. 73 | intros. 74 | apply idfibertoidsigma. 75 | unfold funcomp. 76 | apply funextfun. 77 | apply v. 78 | Defined. 79 | 80 | (** We record the effect of the computation rules on tau *) 81 | 82 | Definition tau_comp (X Y : U)( f : X -> Y)(x : A)(u : B x -> X) : 83 | Id (tau X Y f f x u (fun y : B x => refl (f (u y)))) (refl (dpair _ x (funcomp u f))). 84 | Proof. 85 | intros. 86 | unfold tau. 87 | assert (e : Id (refl (funcomp u f)) (funextfun _ _ (fun y : B x => refl (f (u y))))). 88 | apply (homotinvweqweq0 (weqtoforallpaths _ (funcomp u f) (funcomp u f)) (refl (funcomp u f))). 89 | set (C := (fun p : (Id (funcomp u f) (funcomp u f)) => 90 | Id (idfibertoidsigma (fun a : A => B a -> Y) x (funcomp u f) (funcomp u f) p) 91 | (refl (dpair (fun a : A => B a -> Y) x (funcomp u f))))). 92 | apply (transportf C e). 93 | apply refl. 94 | Defined. 95 | 96 | (** The action of P on homotopies *) 97 | 98 | Definition P_2_h {X Y : U}{f g : X -> Y} : 99 | Hom f g -> Hom (P_1 f) (P_1 g). 100 | Proof. 101 | intros X Y f g alpha. 102 | unfold Hom. 103 | intro c. 104 | destruct c as [x u]. 105 | apply (tau X Y f g x u (fun y : B x => (alpha (u y)))). 106 | Defined. 107 | 108 | (** The result of applying toforallpaths to P(e), where e is a path *) 109 | 110 | Definition compareP2withP2h {X Y : U}{f g : X -> Y}(e : Id f g) : 111 | Id (toforallpaths _ _ _ ( P_2 e )) (P_2_h (toforallpaths _ _ _ e)). 112 | Proof. 113 | intros. 114 | destruct e. 115 | simpl. 116 | unfold toforallpaths. 117 | unfold P_2_h. 118 | apply funextsec. 119 | intro c. 120 | destruct c as [x u]. 121 | apply (transportb (fun e => Id (refl (P_1 f (dpair (fun a : A => B a -> X) x u))) e) (tau_comp _ _ f x u)). 122 | apply refl. 123 | Defined. 124 | 125 | (** The result of applying P_h(alpha), where alpha is a homotopy *) 126 | 127 | Definition compareP2withP2h2 {X Y : U}{f g : X -> Y}(alpha : Hom f g) : 128 | Id (P_2 (funextfun _ _ alpha)) (funextfun _ _ (P_2_h alpha)). 129 | Proof. 130 | intros. 131 | set (e := (funextfun _ _ alpha)). 132 | set (e_flat := (toforallpaths _ _ _ e)). 133 | assert (p_1 : Id e_flat alpha ). 134 | apply (homotweqinvweq (weqtoforallpaths _ f g) alpha). 135 | assert (p_2 : Id (funextfun _ _ (P_2_h alpha)) (funextfun _ _ (P_2_h e_flat))). 136 | apply (maponpaths (funextfun (P_1 f) (P_1 g))). 137 | apply (maponpaths P_2_h). 138 | apply (pathsinv0 p_1). 139 | apply (transportb (fun u => Id (P_2 e) u) p_2). 140 | assert (p_3 : Id (funextfun _ _ (P_2_h e_flat)) (funextfun _ _ (toforallpaths _ _ _ (P_2 e)))). 141 | apply maponpaths. 142 | apply (pathsinv0 (compareP2withP2h e)). 143 | apply (transportb (fun u => Id (P_2 e) u) p_3). 144 | apply (homotinvweqweq0 (weqtoforallpaths _ (P_1 f) (P_1 g)) (P_2 e)). 145 | Defined. 146 | 147 | (** The type of algebras of the functor *) 148 | 149 | Definition isalg := (fun X => (P_0 X -> X)). 150 | 151 | Definition P_Alg := Sigma isalg. 152 | 153 | (** The type of algebra maps between two algebras. An algebra map consists of 154 | a function between the underying types and a path witnessing the commutativity 155 | of the usual diagram *) 156 | 157 | Definition isalgmap (XX YY : P_Alg)(f : (p1 XX) -> (p1 YY)) : U := 158 | Id (funcomp (p2 XX) f) (funcomp (P_1 f) (p2 YY)). 159 | 160 | Definition P_Alg_Map (XX YY : P_Alg) : U := 161 | Sigma (fun f : (p1 XX) -> (p1 YY) => (isalgmap XX YY f)). 162 | 163 | (** The type of algebra 2-cells between two algebra maps. An algebra 2-cell is a pair 164 | consisting of a path between the underlying functions and a path witnessing a coherence 165 | condition *) 166 | 167 | Definition isalg2cell {XX YY : P_Alg}(ff gg : P_Alg_Map XX YY)(e : Id (p1 ff) (p1 gg)) := 168 | Id (pathscomp0 (p2 ff) (comppathwithfun (P_2 e) (p2 YY))) 169 | (pathscomp0 (compfunwithpath (p2 XX) e) (p2 gg)). 170 | 171 | 172 | Definition P_Alg_2cell {XX YY : P_Alg}(ff gg : P_Alg_Map XX YY) : U := 173 | Sigma (fun e : Id (p1 ff) (p1 gg) => (isalg2cell _ _ e)). 174 | 175 | (** We prove that identity functions have the structure of algebra maps. 176 | We also establish some useful facts about their structure paths *) 177 | 178 | Definition aux_construction (XX : P_Alg)(x : A)(u : B x -> (p1 XX))(v : B x -> (p1 XX))(e : Id u v) : 179 | Id ((p2 XX) (dpair _ x u)) ((p2 XX) (dpair _ x v)). 180 | Proof. 181 | intros. 182 | destruct XX as [X s_X]. 183 | apply maponpaths. 184 | apply maponpaths. 185 | apply e. 186 | Defined. 187 | 188 | Definition aux_comparison (XX : P_Alg)(x : A)(u : B x -> (p1 XX))(v : B x -> (p1 XX))(e : Id u v)(E : (p1 XX) -> U) : 189 | Id (transportb E (aux_construction XX x u v e)) (transportb (fun z => E ((p2 XX) (dpair _ x z))) e). 190 | Proof. 191 | intros. 192 | destruct XX as [X s_X]. 193 | destruct e. 194 | unfold transportf. 195 | simpl. 196 | apply refl. 197 | Defined. 198 | 199 | Definition homotopyforidfunisalgmap (XX : P_Alg) : 200 | forall c : (P_0 (p1 XX)), Id ((funcomp (p2 XX) (idfun (p1 XX))) c) ((funcomp (P_1 (idfun (p1 XX))) (p2 XX)) c). 201 | Proof. 202 | intros. 203 | destruct XX as [X s_X]. 204 | destruct c as [x u]. 205 | unfold funcomp. 206 | unfold idfun. 207 | unfold P_1. 208 | simpl. 209 | apply (aux_construction (dpair _ X s_X) x u (funcomp u (idfun X)) (eta_path u)). 210 | Defined. 211 | 212 | Definition idfunisalgmap : forall XX : P_Alg, isalgmap _ _ (idfun (p1 XX)). 213 | Proof. 214 | intro XX. 215 | apply (funextfun _ _ (homotopyforidfunisalgmap XX)). 216 | Defined. 217 | 218 | Definition idalgmap (XX : P_Alg) : P_Alg_Map XX XX := 219 | dpair _ (idfun (p1 XX)) (idfunisalgmap XX). 220 | 221 | (** We establish a simple fact regarding the transport along 222 | the 2-cell witnessing that identities are algebra maps *) 223 | 224 | Definition first_fact (XX : P_Alg)(E : (p1 XX) -> U)(x : A)(u : B x -> (p1 XX)) : 225 | Id 226 | (transportb E (homotopyforidfunisalgmap XX (dpair _ x u))) 227 | (transportb (fun z => E ((p2 XX) (dpair _ x z))) (eta_path u)). 228 | Proof. 229 | intros. 230 | destruct XX as [X s_X]. 231 | unfold homotopyforidfunisalgmap. 232 | apply (aux_comparison (dpair _ X s_X) x u (funcomp u (idfun X)) (eta_path u)). 233 | Defined. 234 | 235 | Definition second_fact (XX : P_Alg)(E : (p1 XX) -> U)(x : A)(u : B x -> (p1 XX)) : 236 | Id 237 | (transportb E (homotopyforidfunisalgmap XX (dpair _ x u))) 238 | (transportb (fun z => E (z (dpair _ x u))) (idfunisalgmap XX)). 239 | Proof. 240 | intros. 241 | unfold idfunisalgmap. 242 | apply (pointwisetransportbhomotopy _ _ E (homotopyforidfunisalgmap XX)). 243 | Defined. 244 | 245 | Definition first_and_second_fact (XX : P_Alg)(E : (p1 XX) -> U)(x : A)(u : B x -> (p1 XX)) : 246 | Id 247 | (transportb (fun z => E (z (dpair _ x u))) (idfunisalgmap XX)) 248 | (transportb (fun z => E ((p2 XX) (dpair _ x z))) (eta_path u)). 249 | Proof. 250 | intros. 251 | apply (pathscomp0 (pathsinv0 (second_fact XX E x u)) (first_fact XX E x u)). 252 | Defined. 253 | 254 | 255 | 256 | (** Composition of algebra maps *) 257 | 258 | Definition isalgmapfuncomp {XX YY ZZ : P_Alg} : 259 | forall (ff : P_Alg_Map XX YY)(gg : P_Alg_Map YY ZZ), 260 | isalgmap XX ZZ (funcomp (p1 ff) (p1 gg)). 261 | 262 | 263 | Proof. 264 | intros XX YY ZZ ff gg. 265 | destruct XX as [X s_X]. 266 | destruct YY as [Y s_Y]. 267 | destruct ZZ as [Z s_Z]. 268 | destruct ff as [f s_f]. 269 | destruct gg as [g s_g]. 270 | unfold p1 in f. 271 | unfold p1 in g. 272 | unfold isalgmap in s_f. 273 | unfold p2 in s_f. 274 | unfold isalgmap in s_g. 275 | unfold p2 in s_g. 276 | unfold isalgmap. 277 | unfold p2. 278 | apply (transportf (fun z => Id _ (funcomp z s_Z)) (functorPcomp f g)). 279 | change (funcomp (funcomp (P_1 f) (P_1 g)) s_Z) with (funcomp (P_1 f) (funcomp (P_1 g) s_Z)). 280 | apply (transportf (fun z => Id _ (funcomp (P_1 f) z)) s_g). 281 | change (funcomp s_X (funcomp f g)) with (funcomp (funcomp s_X f) g). 282 | apply (transportb (fun z => Id (funcomp z g) _) s_f). 283 | apply refl. 284 | Defined. 285 | 286 | Definition algmapcomp {XX YY ZZ : P_Alg} : 287 | (P_Alg_Map XX YY) -> (P_Alg_Map YY ZZ -> P_Alg_Map XX ZZ). 288 | Proof. 289 | intros XX YY ZZ ff gg. 290 | split with (funcomp (p1 ff) (p1 gg)). 291 | apply isalgmapfuncomp. 292 | Defined. 293 | 294 | (** The structure map of an algebra is an algebra map *) 295 | 296 | Definition PP : P_Alg -> P_Alg := 297 | fun XX => (dpair _ (P_0 (p1 XX)) (P_1 (p2 XX))). 298 | 299 | Definition isalgmapstructuremap (XX : P_Alg) : 300 | isalgmap (PP XX) XX (p2 XX). 301 | Proof. 302 | intros. 303 | destruct XX as [X s_X]. 304 | simpl. 305 | apply refl. 306 | Defined. 307 | 308 | Definition structurealgmap (XX : P_Alg) : P_Alg_Map (PP XX) XX. 309 | Proof. 310 | intros. 311 | split with (p2 XX). 312 | apply isalgmapstructuremap. 313 | Defined. 314 | 315 | (** We show that the identity path is an algebra 2-cell *) 316 | 317 | Definition idpathisalg2cell {XX YY : P_Alg}(ff : P_Alg_Map XX YY) : 318 | isalg2cell _ _ (refl (p1 ff)). 319 | Proof. 320 | intros. 321 | destruct XX as [X s_X]. 322 | destruct YY as [Y s_Y]. 323 | destruct ff as [f s_f]. 324 | simpl. 325 | unfold isalg2cell. 326 | simpl. 327 | apply pathscomp0rid. 328 | Defined. 329 | 330 | Definition idpath2cell {XX YY : P_Alg}(ff : P_Alg_Map XX YY) : P_Alg_2cell ff ff. 331 | Proof. 332 | intros. 333 | split with (refl (p1 ff)). 334 | apply (idpathisalg2cell ff). 335 | Defined. 336 | 337 | (** ** H-initiality and Lambek's lemma *) 338 | 339 | Definition ishinitial (XX : P_Alg) : Type := forall YY : P_Alg, iscontr (P_Alg_Map XX YY). 340 | 341 | (** Lambek's lemma *) 342 | 343 | Definition lambekslemma (XX : P_Alg) : 344 | ishinitial XX -> isweq (p2 XX). 345 | Proof. 346 | intros XX is. 347 | set (X := p1 XX). 348 | set (s_X := p2 XX). 349 | set (iscontr_hom_XX_PP_XX := is (PP XX)). 350 | set (tt := p1 iscontr_hom_XX_PP_XX). 351 | set (t := p1 tt). 352 | set (s_t := p2 tt). 353 | set (iscontr_hom_XX_XX := is XX). 354 | set (ss := structurealgmap XX). 355 | set (ttss := algmapcomp tt ss). 356 | set (id := idalgmap XX). 357 | assert (ee : Id ttss id). 358 | apply (proofirrelevance _ iscontr_hom_XX_XX ttss id). 359 | assert (p : Id (funcomp t s_X) (idfun X)). 360 | unfold ttss in ee. 361 | apply (idsigmatobase _ ttss id ee). 362 | assert (q : Id (funcomp s_X t) (idfun (P_0 X))). 363 | change ((fun f : p1 XX -> p1 (PP XX) => isalgmap XX (PP XX) f) (p1 tt)) with (isalgmap _ _ t) in s_t. 364 | apply (transportb (fun z => Id z _) s_t). 365 | change (p2 (PP XX)) with (P_1 s_X). 366 | apply (transportb (fun z => Id z _) (functorPcomp t s_X)). 367 | apply (transportb (fun z => Id (P_1 z) _) p). 368 | apply (functorPid X). 369 | apply (gradth s_X t). 370 | apply (toforallpaths _ _ _ q). 371 | apply (toforallpaths _ _ _ p). 372 | Defined. 373 | 374 | (** Uniquness up to weak equivalence of h-initial algebra *) 375 | 376 | Definition hinitialuniqueuptoweq {XX YY : P_Alg} : 377 | ishinitial XX -> (ishinitial YY -> weq (p1 XX) (p1 YY)). 378 | Proof. 379 | intros XX YY isX isY. 380 | set (iscontr_XX_YY := isX YY). 381 | set (iscontr_YY_XX := isY XX). 382 | set (ff := p1 (iscontr_XX_YY)). 383 | set (gg := p1 (iscontr_YY_XX)). 384 | assert (pp : Id (algmapcomp ff gg) (idalgmap XX)). 385 | apply (proofirrelevance _ (isX XX)). 386 | assert (qq : Id (algmapcomp gg ff) (idalgmap YY)). 387 | apply (proofirrelevance _ (isY YY)). 388 | set (X := p1 XX). 389 | set (Y := p1 YY). 390 | set (f := p1 ff). 391 | set (g := p1 gg). 392 | set (p := idsigmatobase _ _ _ pp). 393 | set (q := idsigmatobase _ _ _ qq). 394 | split with f. 395 | apply (gradth f g). 396 | apply (toforallpaths _ _ _ p). 397 | apply (toforallpaths _ _ _ q). 398 | Defined. 399 | 400 | 401 | (** ** Analysis of algebra 2-cells 402 | 403 | We compare 404 | 405 | - Paths between algebra maps 406 | - Pairs of paths involving transport 407 | - Algebra 2-cells 408 | 409 | Using this one shows that two algebra maps are equal iff 410 | there is an algebra 2-cell between them *) 411 | 412 | 413 | (** Alternative definition of algebra 2-cell. An alternative 414 | algebra 2-cell from (f,s_f) to (g,s_g) is a pair (e,s_e) 415 | where e : Id(f, g) and s_e : Id( e_!(s_f), s_g). *) 416 | 417 | Definition isalg2cellalt {XX YY : P_Alg}(ff gg : P_Alg_Map XX YY) := 418 | (fun e : Id (p1 ff) (p1 gg) => 419 | Id (transportf (isalgmap XX YY) e (p2 ff)) (p2 gg)). 420 | 421 | Definition P_Alg_2cellalt {XX YY : P_Alg}(ff gg : P_Alg_Map XX YY) := 422 | Sigma (isalg2cellalt ff gg). 423 | 424 | (** For each e : Id(f,g), the map isalg2cell(e) --> Id(e_!(s_f), s_g) *) 425 | 426 | Definition fiberwise2cellto2cellalt {XX YY : P_Alg}(ff gg : P_Alg_Map XX YY) : 427 | forall e : Id (p1 ff) (p1 gg), (isalg2cell ff gg e) -> (isalg2cellalt ff gg e). 428 | Proof. 429 | intros XX YY ff gg. 430 | destruct XX as [X s_X]. 431 | destruct YY as [Y s_Y]. 432 | destruct ff as [f s_f]. 433 | destruct gg as [g s_g]. 434 | simpl. 435 | intro e. 436 | destruct e. 437 | simpl. 438 | intro p. 439 | unfold isalg2cellalt. 440 | simpl. 441 | change (Id s_f s_g). 442 | apply (transportf (fun u => Id u s_g) (pathscomp0rid s_f)). 443 | apply p. 444 | Defined. 445 | 446 | (** For each e, the map constructed above is a weak equivalence *) 447 | 448 | Definition isweqfiberwise2cellto2cellalt {XX YY : P_Alg}(ff gg : P_Alg_Map XX YY) : 449 | forall e : Id (p1 ff) (p1 gg), isweq (fiberwise2cellto2cellalt ff gg e). 450 | Proof. 451 | intros XX YY ff gg. 452 | destruct XX as [X s_X]. 453 | destruct YY as [Y s_Y]. 454 | destruct ff as [f s_f]. 455 | destruct gg as [g s_g]. 456 | simpl. 457 | intro e. 458 | unfold fiberwise2cellto2cellalt. 459 | destruct e. 460 | simpl. 461 | apply 462 | (isweqtransportf (fun u => Id u s_g) (pathscomp0rid s_f)). 463 | Defined. 464 | 465 | Definition weqfiberwise2cellto2cellalt {XX YY : P_Alg}(ff gg : P_Alg_Map XX YY) : 466 | forall e : Id (p1 ff) (p1 gg), weq (isalg2cell ff gg e) (isalg2cellalt ff gg e). 467 | Proof. 468 | intros. 469 | split with (fiberwise2cellto2cellalt ff gg e). 470 | apply (isweqfiberwise2cellto2cellalt ff gg e). 471 | Defined. 472 | 473 | (** The map from standard to alternative 2-cells, taking total spaces *) 474 | 475 | Definition from2cellto2cellalt {XX YY : P_Alg} : 476 | forall (ff gg : P_Alg_Map XX YY), P_Alg_2cell ff gg -> P_Alg_2cellalt ff gg. 477 | Proof. 478 | intros XX YY ff gg ee. 479 | apply (totalfun _ _ (fiberwise2cellto2cellalt ff gg) ee). 480 | Defined. 481 | 482 | Definition isweqfrom2cellto2cellalt {XX YY : P_Alg} : 483 | forall (ff gg : P_Alg_Map XX YY), isweq (from2cellto2cellalt ff gg). 484 | Proof. 485 | intros. 486 | apply (isweqfibtototal _ _ (weqfiberwise2cellto2cellalt ff gg)). 487 | Defined. 488 | 489 | (** This map is a weak equivalence because it is fiberwise a weak equivalence *) 490 | 491 | Definition weqfrom2cellto2cellalt {XX YY : P_Alg} : 492 | forall (ff gg : P_Alg_Map XX YY), weq (P_Alg_2cell ff gg) (P_Alg_2cellalt ff gg). 493 | Proof. 494 | intros. 495 | split with (from2cellto2cellalt ff gg). 496 | apply (isweqfrom2cellto2cellalt ff gg). 497 | Defined. 498 | 499 | (** As a special case of the general results obtained before for Id/Sigma we get 500 | that there is a weak equivalence between alternative algebra 2-cells and paths 501 | between algebra maps *) 502 | 503 | Definition weqfrom2cellalttoidalgmap {XX YY : P_Alg} : 504 | forall (ff gg : P_Alg_Map XX YY), weq (P_Alg_2cellalt ff gg) (Id ff gg). 505 | Proof. 506 | intros. 507 | apply (weqsigmaidtoidsigma (isalgmap XX YY)). 508 | Defined. 509 | 510 | (* Composing with the previous weak equivalence, we obtain that there is a weak 511 | equivalence between algebra 2-cells and paths between algebra maps *) 512 | 513 | Definition weqfromalg2celltoidalgmap {XX YY : P_Alg} : 514 | forall (ff gg : P_Alg_Map XX YY), weq (P_Alg_2cell ff gg) (Id ff gg). 515 | Proof. 516 | intros. 517 | apply (weqcomp (weqfrom2cellto2cellalt ff gg) (weqfrom2cellalttoidalgmap ff gg)). 518 | Defined. 519 | 520 | Definition weqfromaidalgmaptoalg2cell {XX YY : P_Alg} : 521 | forall (ff gg : P_Alg_Map XX YY), weq (Id ff gg) (P_Alg_2cell ff gg). 522 | 523 | Proof. 524 | intros. 525 | apply (invweq (weqfromalg2celltoidalgmap ff gg)). 526 | Defined. 527 | 528 | 529 | 530 | 531 | (** For an algebra map ff, a map g and a path e : Id(f,g), we prove that there 532 | is an essentially unique way of of making g into an algebra map so that e 533 | becomes an algebra 2-cell. To do so, we define a type whose elements are all 534 | the possible such ways and prove it is contractible. *) 535 | (** 536 | Definition T {XX YY : P_Alg}(ff : P_Alg_Map XX YY)(g : (p1 XX) -> (p1 YY))(e : Id (p1 ff) g) : U := 537 | Sigma (fun s_g : (isalgmap _ _ g) => (isalg2cell ff (dpair _ g s_g) e)). 538 | 539 | (** Construction of an element of T *) 540 | 541 | Definition transportfalgmap {XX YY : P_Alg}(ff : P_Alg_Map XX YY)(g : (p1 XX) -> (p1 YY)) : 542 | forall (e : Id (p1 ff) g), (isalgmap _ _ g). 543 | Proof. 544 | intros. 545 | apply (transportf (isalgmap XX YY) e). 546 | apply (p2 ff). 547 | Defined. 548 | 549 | Definition transportfalgmapwith2cell {XX YY : P_Alg}(ff : P_Alg_Map XX YY)(g : (p1 XX) -> (p1 YY)) : 550 | forall (e : Id (p1 ff) g), T ff g e. 551 | Proof. 552 | intros. 553 | split with (transportfalgmap ff g e). 554 | destruct e. 555 | destruct ff as [f s_f]. 556 | simpl. 557 | unfold transportfalgmap. 558 | unfold transportf. 559 | simpl. unfold idfun. 560 | apply (idpathisalg2cell (dpair _ f s_f)). 561 | Defined. 562 | 563 | (* We now prove that T is contractible. To do this we define a type T' that is contractible 564 | by Vladimir Voevodsky's results and then show that T and T' are weakly equivalent *) 565 | 566 | Definition T' {XX YY : P_Alg}(ff : P_Alg_Map XX YY)(g : (p1 XX) -> (p1 YY))(e : Id (p1 ff) g) : Type := 567 | coconusfromt 568 | (isalgmap _ _ g) 569 | (pathscomp0 (pathsinv0 (compfunwithpath (p2 XX) e)) (pathscomp0 (p2 ff) (comppathwithfun (P_2 e) (p2 YY)))). 570 | 571 | Definition T'_is_contractible {XX YY : P_Alg}(ff : P_Alg_Map XX YY)(g : (p1 XX) -> (p1 YY))(e : Id (p1 ff) g) : 572 | iscontr (T' ff g e). 573 | Proof. intros. 574 | apply 575 | (iscontrcoconusfromt (isalgmap _ _ g) 576 | (pathscomp0 (pathsinv0 (compfunwithpath (p2 XX) e)) (pathscomp0 (p2 ff) (comppathwithfun (P_2 e) (p2 YY))))). 577 | Defined. 578 | 579 | (* The weak equivalence between T and T' is given by the fact that they are dependent sums 580 | over the same type of families of types that are fiberwise weakly equivalent. The fiberwise 581 | weak equivalence is simply given by the fact that path composition is a weak equivalence *) 582 | 583 | Definition weqfromTtoT' {XX YY : P_Alg}(ff : P_Alg_Map XX YY)(g : (p1 XX) -> (p1 YY))(e : Id (p1 ff) g) : 584 | weq (T ff g e ) (T' ff g e). 585 | Proof. 586 | intros XX YY ff g e. 587 | destruct XX as [X s_X]. 588 | destruct YY as [Y s_Y]. 589 | destruct ff as [f s_f]. 590 | simpl. 591 | apply weqfibtototal. 592 | intro s_g. 593 | simpl. 594 | apply weqleftcancellationlaw. 595 | Defined. 596 | 597 | Definition T_is_contractible {XX YY : P_Alg}(ff : P_Alg_Map XX YY)(g : (p1 XX) -> (p1 YY))(e : Id (p1 ff) g) : 598 | iscontr (T ff g e). 599 | Proof. intros. 600 | set (w := invweq (weqfromTtoT' ff g e)). 601 | apply (iscontrweqf w). 602 | apply (T'_is_contractible ff g e). 603 | Defined. 604 | 605 | (** We show that if we have an algebra 2-cell we find an element of T *) 606 | 607 | Definition fromalgebra2cellstoT {XX YY : P_Alg}{ff gg : P_Alg_Map XX YY}(ee : P_Alg_2cell ff gg) : 608 | T ff (p1 gg) (p1 ee). 609 | Proof. 610 | intros. 611 | split with (p2 gg). 612 | destruct gg as [g s_g]. 613 | apply (p2 ee). 614 | Defined. 615 | 616 | (** We use this to establish that for an algebra map ff, a map g and a path e : Id(f,g), all the paths s_g 617 | making g into an algebra map such that e becomes an algebra 2-cell are propositionally equal to the 618 | canonical way of making s_g into an algebra map, as given in transportfalgmap *) 619 | 620 | Definition fromcontrTtoessentialuniqueness {XX YY : P_Alg}(ff : P_Alg_Map XX YY)(g : (p1 XX) -> (p1 YY))(e : Id (p1 ff) g) : 621 | forall (s_g : isalgmap XX YY g), (isalg2cell ff (dpair _ g s_g) e) -> Id ( transportfalgmap ff g e) s_g. 622 | Proof. 623 | intros XX YY ff g e s_g s_e. 624 | set (gg := (dpair _ g s_g) : (P_Alg_Map XX YY)). 625 | set (ee := (dpair _ e s_e) : (P_Alg_2cell ff gg)). 626 | set (t_1 := (transportfalgmapwith2cell ff g e) : T ff g e). 627 | set (t_2 := (dpair _ s_g s_e) : T ff g e). 628 | assert (p : Id t_1 t_2). 629 | apply (proofirrelevancecontr (T_is_contractible ff g e) t_1 t_2). 630 | set (q := idsigmatosigmaid _ t_1 t_2 p). 631 | apply (p1 q). 632 | Defined. **) 633 | 634 | (** The type of algebra map homotopies *) 635 | 636 | Definition isalgmaphomotopy {X : U}{s_X : (P_0 X) -> X}{Y : U}{s_Y : (P_0 Y -> Y)}(f : X -> Y)(sigma_f : Hom (funcomp s_X f) (funcomp (P_1 f) s_Y)) 637 | (g : X -> Y) (sigma_g : Hom (funcomp s_X g) (funcomp (P_1 g) s_Y)) (alpha : Hom f g) : U := 638 | (forall c : (P_0 X), Id 639 | ((homcomp0 (compfunwithhomotopy s_X alpha) (sigma_g)) c) 640 | ((homcomp0 (sigma_f) (comphomotopywithfun (P_2_h alpha) s_Y)) c)). 641 | 642 | Definition immisalghomotopy {X : U}{s_X : (P_0 X) -> X}{Y : U}{s_Y : (P_0 Y -> Y)}(f : X -> Y)(sigma_f : Hom (funcomp s_X f) (funcomp (P_1 f) s_Y)) 643 | (g : X -> Y) (sigma_g : Hom (funcomp s_X g) (funcomp (P_1 g) s_Y)) (alpha : Hom f g) : 644 | (isalgmaphomotopy f sigma_f g sigma_g alpha) -> 645 | Id (homcomp0 (compfunwithhomotopy s_X alpha) (sigma_g)) 646 | (homcomp0 (sigma_f) (comphomotopywithfun (P_2_h alpha) s_Y)). 647 | Proof. 648 | intros X s_X Y s_Y f sigma_f g sigma_g alpha. 649 | intro is. 650 | apply funextsec. 651 | intro c. 652 | apply (is c). 653 | Defined. 654 | 655 | (* We show that if we have an algebra map homotopy we can construct an algebra 2-cell 656 | This is a long equational reasoning, which uses what has been done on relating paths 657 | and homotopies *) 658 | 659 | Definition alghomotopytoalg2cell : forall 660 | (X : U)(s_X : (P_0 X) -> X) 661 | (Y : U)(s_Y : (P_0 Y -> Y)) 662 | (f : X -> Y)(sigma_f : Hom (funcomp s_X f) (funcomp (P_1 f) s_Y)) 663 | (g : X -> Y)(sigma_g : Hom (funcomp s_X g) (funcomp (P_1 g) s_Y)) (alpha : Hom f g), 664 | (isalgmaphomotopy f sigma_f g sigma_g alpha) -> 665 | isalg2cell (dpair (isalgmap (dpair _ X s_X) (dpair _ Y s_Y)) f (funextfun _ _ sigma_f)) (dpair _ g (funextfun _ _ sigma_g)) (funextfun f g alpha). 666 | Proof. 667 | intros X s_X Y s_Y f sigma_f g sigma_g alpha. intro is. 668 | set (s_alpha := (immisalghomotopy f sigma_f g sigma_g alpha is)). 669 | change (p1 (dpair (fun X0 : U => P_0 X0 -> X0) X s_X)) with X. 670 | change (p1 (dpair (fun X0 : U => P_0 X0 -> X0) Y s_Y)) with Y. 671 | set (XX := (dpair (fun X0 : U => P_0 X0 -> X0) X s_X)). 672 | set (YY := (dpair (fun X0 : U => P_0 X0 -> X0) Y s_Y)). 673 | change (dpair (fun f0 : X -> Y => isalgmap XX YY f0) g 674 | (funextfun (funcomp s_X g) (funcomp (P_1 g) s_Y) sigma_g)) 675 | with (dpair (isalgmap XX YY) g 676 | (funextfun (funcomp s_X g) (funcomp (P_1 g) s_Y) sigma_g)). 677 | set (sigma_f_sharp := (funextfun (funcomp s_X f) (funcomp (P_1 f) s_Y) sigma_f)). 678 | set (sigma_g_sharp := (funextfun (funcomp s_X g) (funcomp (P_1 g) s_Y) sigma_g)). 679 | set (alpha_sharp := (funextfun f g alpha)). 680 | change (Id (pathscomp0 sigma_f_sharp (comppathwithfun (P_2 alpha_sharp ) s_Y)) (pathscomp0 (compfunwithpath s_X alpha_sharp) sigma_g_sharp)). 681 | assert (e_1 : Id (P_2 alpha_sharp) (funextfun _ _ (P_2_h alpha))). 682 | apply (compareP2withP2h2 alpha). 683 | apply (transportb (fun u => Id (pathscomp0 sigma_f_sharp (comppathwithfun u s_Y)) 684 | (pathscomp0 (compfunwithpath s_X alpha_sharp) sigma_g_sharp)) e_1). 685 | assert (e_2 : Id (funextfun _ _ (compfunwithhomotopy s_X alpha)) 686 | (compfunwithpath s_X alpha_sharp)). 687 | apply (comparehomotopycompwithfunwithpathcompwithfun s_X alpha). 688 | apply (transportf (fun u => Id 689 | (pathscomp0 sigma_f_sharp 690 | (comppathwithfun (funextfun (P_1 f) (P_1 g) (P_2_h alpha)) s_Y)) 691 | (pathscomp0 u sigma_g_sharp)) e_2). 692 | unfold sigma_g_sharp. 693 | assert (e_3 : Id 694 | (funextfun _ _ (homcomp0 (compfunwithhomotopy s_X alpha) sigma_g)) 695 | ((pathscomp0 (funextfun _ _ (compfunwithhomotopy s_X alpha))) (funextfun _ _ sigma_g))). 696 | apply (compcomphomcomppath _ _ _ (compfunwithhomotopy s_X alpha) sigma_g). 697 | apply (transportf (fun u => Id 698 | (pathscomp0 sigma_f_sharp 699 | (comppathwithfun (funextfun (P_1 f) (P_1 g) (P_2_h alpha)) s_Y)) u) e_3). 700 | assert (e_4 : Id 701 | (funextfun _ _ (comphomotopywithfun (P_2_h alpha) s_Y)) 702 | (comppathwithfun (funextfun _ _ (P_2_h alpha)) s_Y)). 703 | apply (comparefuncompwithpathwithfuncompwithhomot2 s_Y (P_2_h alpha)). 704 | apply (transportf (fun u => Id 705 | (pathscomp0 sigma_f_sharp 706 | u) 707 | (funextfun (funcomp s_X f) (funcomp (P_1 g) s_Y) 708 | (homcomp0 (compfunwithhomotopy s_X alpha) sigma_g))) e_4). 709 | assert (e_5 : Id 710 | (pathscomp0 sigma_f_sharp (funextfun _ _ (comphomotopywithfun (P_2_h alpha) s_Y))) 711 | (funextfun _ _ (homcomp0 sigma_f (comphomotopywithfun (P_2_h alpha) s_Y)))). 712 | apply (pathsinv0 (compcomphomcomppath _ _ _ sigma_f (comphomotopywithfun (P_2_h alpha) s_Y))). 713 | apply (transportb (fun u => Id 714 | u 715 | (funextfun (funcomp s_X f) (funcomp (P_1 g) s_Y) 716 | (homcomp0 (compfunwithhomotopy s_X alpha) sigma_g))) e_5). 717 | apply maponpaths. 718 | apply (pathsinv0 s_alpha). 719 | Defined. 720 | 721 | End Polynomial_Functors. -------------------------------------------------------------------------------- /LICS2012/w_is_hinitial/w_implies_hinitial.v: -------------------------------------------------------------------------------- 1 | Add Rec LoadPath "../univalent_foundations/Generalities". 2 | Add Rec LoadPath "../identity". 3 | Add Rec LoadPath "../inductive_types". 4 | 5 | Unset Automatic Introduction. 6 | Require Export uu0. 7 | Require Export identity. 8 | Require Export polynomial_functors. 9 | Require Export w. 10 | 11 | (** * From W-types to h-initiality *) 12 | 13 | Section From_W_types_to_h_initiality. 14 | 15 | Variable A : U. 16 | Variable B : A -> U. 17 | 18 | Notation W := (W A B). 19 | 20 | (** We prove that the rules for W-types give us a h-initial algebra *) 21 | 22 | Definition s_W : (P_0 A B W) -> W := 23 | fun c => match c with dpair x u => sup A B x u end. 24 | 25 | Definition WW := (dpair _ W s_W) : P_Alg A B. 26 | 27 | (** We consider another algebra. For simplicity we first prove the claim for algebras in canonical form *) 28 | 29 | Section Towards_contractibility. 30 | 31 | Variable E : U. 32 | Variable s_E : (P_0 _ B E) -> E. 33 | 34 | Definition EE := (dpair _ E s_E) : P_Alg _ B. 35 | 36 | (** The map j : W --> E, which we will show to be an algebra map 37 | It is defined by W-recursion, so we construct the eliminating term. *) 38 | 39 | 40 | Definition d_j : forall (x : A)(u : B x -> W)(v : B x -> E), E := 41 | fun (x : A)(u : B x -> W)(v : B x -> E) => s_E ( dpair _ x v ). 42 | 43 | Definition j : W -> E := (fun w => w_rec A B (fun _ => E) d_j w). 44 | 45 | (** The result of the W-computation rule on j. *) 46 | 47 | Definition w_comp_j (x : A)(u : B x -> W) : Id ( j ( sup A B x u ) )( d_j x u (funcomp u j )). 48 | Proof. 49 | intros. 50 | apply (w_beta A B (fun _ : W => E) d_j x u). 51 | Defined. 52 | 53 | (** Construction of a homotopy sigma_j which is used to show that j is an 54 | algebra map. *) 55 | 56 | Definition sigma_j : forall c : (P_0 _ B W), Id (j (s_W c)) ( s_E ((P_1 _ B j) c)). 57 | Proof. 58 | intro. 59 | destruct c as [x u]. 60 | apply (w_comp_j x u). 61 | Defined. 62 | 63 | Definition sigma_j_sharp : (isalgmap _ _ WW EE j). 64 | Proof. 65 | apply funextfun. 66 | apply sigma_j. 67 | Defined. 68 | 69 | (** We introduce a notation for the algebra map (j, sigma_j_sharp), which will be the center of the contraction *) 70 | 71 | Definition jj := (dpair _ j sigma_j_sharp) : (P_Alg_Map _ _ WW EE). 72 | 73 | (** We now assume that to have a algebra map kk : WW -> EE and we show that it is propositionally equal to jj 74 | For simplicity, we first prove this for algebra maps in canonical form *) 75 | 76 | Variable k : W -> E. 77 | Variable s_k : isalgmap _ _ WW EE k. 78 | Definition kk := (dpair _ k s_k) : P_Alg_Map _ _ WW EE. 79 | 80 | (** The homotopy associated to s_k *) 81 | 82 | Definition s_k_flat : forall x : P_0 _ _ W, Id ( k (s_W x)) ( s_E ( (P_1 _ _ k ) x)). 83 | Proof. 84 | apply weqtoforallpaths. 85 | apply s_k. 86 | Defined. 87 | 88 | (** Construction of the homotopy from j to k by W-elimination *) 89 | 90 | Definition d_theta (x : A)(u : B x -> W)(v : forall (y : B x), Id (j (u y)) (k (u y))) : 91 | Id (j ( sup A B x u)) (k ( sup A B x u )). 92 | Proof. 93 | intros. 94 | assert (e_1 : Id ((j ( sup A B x u))) (s_E (dpair _ x (funcomp u j)))). 95 | apply (sigma_j (dpair _ x u)). 96 | assert (e_2 : Id (s_E (dpair _ x (funcomp u j))) (s_E (dpair _ x (funcomp u k)))). 97 | apply maponpaths. 98 | apply (tau _ _ _ _ j k x u v). 99 | assert (e_3 : Id (s_E (dpair _ x (funcomp u k))) (k ( sup A B x u ))). 100 | apply (pathsinv0 (s_k_flat ( dpair _ x u))). 101 | apply (pathscomp0 (pathscomp0 e_1 e_2) e_3). 102 | Defined. 103 | 104 | (** The homotopy between j and k *) 105 | 106 | Definition theta : forall w : W, Id (j w) (k w) := 107 | (fun w : W => (w_rec A B (fun w : W => Id (j w) (k w)) d_theta w)). 108 | 109 | Definition theta_comp (x : A)(u : B x -> W) : 110 | Id (theta (sup A B x u) ) (d_theta x u (fun y : B x => theta ( u y )) ) := 111 | (w_beta A B (fun w : W => Id (j w) (k w)) d_theta x u). 112 | 113 | (** Verification that theta is a algebra map homotopy *) 114 | 115 | Definition s_theta : isalgmaphomotopy _ _ j sigma_j k s_k_flat theta. 116 | Proof. 117 | intros. 118 | intro c. 119 | destruct c as [x u]. 120 | apply cancellationlemma. 121 | apply (maponpaths (fun m : Id (j (sup A B x u)) (k (sup A B x u)) => (pathscomp0 m (s_k_flat (dpair _ x u))))). 122 | apply (theta_comp x u). 123 | Defined. 124 | 125 | (** The path p : Id k j associated to theta *) 126 | 127 | Definition p := (funextfun _ _ theta) : Id j k. 128 | 129 | (** The proof that p is an algebra 2-cell. This exploits the work on 130 | relating algebra map homotopies and algebra map 2-cells done earlier *) 131 | 132 | Definition s_p : isalg2cell _ _ jj kk p. 133 | Proof. 134 | set (sigma_j_sharp := (funextfun (funcomp s_W j) (funcomp (P_1 _ _ j) s_E) sigma_j)). 135 | set (s_k_flat_sharp := (funextfun (funcomp s_W k) (funcomp (P_1 _ _ k) s_E) s_k_flat)). 136 | set (useful := (alghomotopytoalg2cell _ _ W s_W E s_E j sigma_j k s_k_flat theta s_theta)). 137 | assert (almost_s_p : isalg2cell _ _ jj (dpair _ k s_k_flat_sharp) p). 138 | unfold jj. 139 | apply useful. 140 | assert (e : Id s_k s_k_flat_sharp). 141 | apply (homotinvweqweq0 (weqtoforallpaths _ (funcomp s_W k) (funcomp (P_1 _ _ k) s_E)) s_k). 142 | set (C := (fun u => isalg2cell _ _ jj 143 | (dpair (fun f : p1 WW -> p1 EE => isalgmap _ _ WW EE f) k 144 | u) p)). 145 | apply (transportb C e). 146 | apply useful. 147 | Defined. 148 | 149 | (** Proof that (j,alpha) is propositionally equal to kk *) 150 | 151 | Definition pq : Id jj kk. 152 | Proof. 153 | (apply 154 | (weqfromalg2celltoidalgmap _ _ jj kk (dpair _ p s_p))). 155 | Defined. 156 | 157 | 158 | 159 | End Towards_contractibility. 160 | 161 | 162 | 163 | (** Proof of h-initiality of W *) 164 | 165 | Theorem w_types_are_h_initial : ishinitial _ _ WW. 166 | Proof. 167 | unfold ishinitial. 168 | intro EE. 169 | destruct EE as [E s_E]. 170 | split with (jj E s_E). 171 | intro kk. 172 | destruct kk as [k s_k]. 173 | apply (pathsinv0 (pq E s_E k s_k)). 174 | Defined. 175 | 176 | End From_W_types_to_h_initiality. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Archive 2 | ======= 3 | 4 | Archived materials related to Homotopy Type Theory. 5 | Please do not alter the files stored here. --------------------------------------------------------------------------------