From 61901cff81e04546d690ca465d11ce6bb2b60762 Mon Sep 17 00:00:00 2001 From: Floris van Doorn Date: Fri, 20 Feb 2015 19:30:32 -0500 Subject: [PATCH] feat(hott): rename definition and cleanup in HoTT library also add more definitions in types.pi, types.path, algebra.precategory the (pre)category library still needs cleanup authors of this commit: @avigad, @javra, @fpvandoorn --- hott/algebra/category/basic.hlean | 29 +- hott/algebra/category/set.hlean | 20 +- hott/algebra/group.hlean | 184 +++--- hott/algebra/groupoid.hlean | 22 +- hott/algebra/precategory/basic.hlean | 30 +- hott/algebra/precategory/constructions.hlean | 285 ++------- hott/algebra/precategory/functor.hlean | 46 +- hott/algebra/precategory/iso.hlean | 14 +- hott/algebra/precategory/morphism.hlean | 100 ++- ...l_transformation.hlean => nat_trans.hlean} | 94 +-- hott/algebra/precategory/yoneda.hlean | 91 +++ hott/default.hlean | 8 - hott/equiv_precomp.hlean | 77 +-- hott/init/axioms/funext.hlean | 20 +- ...unext_from_ua.hlean => funext_of_ua.hlean} | 36 +- hott/init/axioms/funext_varieties.hlean | 53 +- hott/init/axioms/ua.hlean | 26 +- hott/init/bool.hlean | 2 + hott/init/datatypes.hlean | 1 + hott/init/default.hlean | 3 +- hott/init/equiv.hlean | 204 +++---- hott/init/function.hlean | 2 + hott/init/hedberg.hlean | 2 +- hott/init/logic.hlean | 19 +- hott/init/nat.hlean | 1 + hott/init/path.hlean | 475 +++++++-------- hott/init/priority.hlean | 1 + hott/init/relation.hlean | 2 + hott/init/reserved_notation.hlean | 1 + hott/init/tactic.hlean | 1 + hott/init/trunc.hlean | 195 +++--- hott/init/types/empty.hlean | 10 +- hott/init/types/prod.hlean | 12 +- hott/init/types/sigma.hlean | 6 +- hott/init/types/sum.hlean | 1 + hott/init/util.hlean | 3 +- hott/init/wf.hlean | 2 + hott/logic.hlean | 1 + hott/trunc.hlean | 61 -- hott/truncation.hlean | 2 +- hott/types/W.hlean | 42 +- hott/types/path.hlean | 572 ++++++++++++++++++ hott/types/pi.hlean | 157 +++-- hott/{ => types}/pointed.hlean | 25 +- hott/types/prod.hlean | 21 +- hott/types/sigma.hlean | 282 ++++----- hott/types/trunc.hlean | 119 ++++ src/library/constants.txt | 6 +- 48 files changed, 1971 insertions(+), 1395 deletions(-) rename hott/algebra/precategory/{natural_transformation.hlean => nat_trans.hlean} (55%) create mode 100644 hott/algebra/precategory/yoneda.hlean delete mode 100644 hott/default.hlean rename hott/init/axioms/{funext_from_ua.hlean => funext_of_ua.hlean} (79%) delete mode 100644 hott/trunc.hlean create mode 100644 hott/types/path.hlean rename hott/{ => types}/pointed.hlean (64%) create mode 100644 hott/types/trunc.hlean diff --git a/hott/algebra/category/basic.hlean b/hott/algebra/category/basic.hlean index bc7fe13d9e..01e5b8f313 100644 --- a/hott/algebra/category/basic.hlean +++ b/hott/algebra/category/basic.hlean @@ -4,7 +4,7 @@ import ..precategory.basic ..precategory.morphism ..precategory.iso -open precategory morphism is_equiv eq truncation nat sigma sigma.ops +open precategory morphism is_equiv eq is_trunc nat sigma sigma.ops -- A category is a precategory extended by a witness, -- that the function assigning to each isomorphism a path, @@ -27,16 +27,33 @@ namespace category set_option apply.class_instance false -- disable class instance resolution in the apply tactic - definition ob_1_type : is_trunc nat.zero .+1 ob := + definition ob_1_type : is_trunc (succ nat.zero) ob := begin - apply is_trunc_succ, intros (a, b), - fapply trunc_equiv, + apply is_trunc_succ_intro, intros (a, b), + fapply is_trunc_is_equiv_closed, exact (@path_of_iso _ _ a b), - apply inv_closed, + apply is_equiv_inv, apply is_hset_iso, end end category -- Bundled version of categories -inductive Category : Type := mk : Π (ob : Type), category ob → Category + +structure Category : Type := + (objects : Type) + (category_instance : category objects) + +namespace category + definition Mk {ob} (C) : Category := Category.mk ob C + --definition MK (a b c d e f g h i) : Category := Category.mk a (category.mk b c d e f g h i) + + definition objects [coercion] [reducible] := Category.objects + definition category_instance [instance] [coercion] [reducible] := Category.category_instance + +end category + +open category + +protected definition Category.eta (C : Category) : Category.mk C C = C := +Category.rec (λob c, idp) C diff --git a/hott/algebra/category/set.hlean b/hott/algebra/category/set.hlean index 761cd67d74..e632c57da6 100644 --- a/hott/algebra/category/set.hlean +++ b/hott/algebra/category/set.hlean @@ -3,9 +3,9 @@ -- Authors: Jakob von Raumer -- Category of sets -import .basic types.pi trunc +import .basic types.pi types.trunc -open truncation sigma sigma.ops pi function eq morphism precategory +open is_trunc sigma sigma.ops pi function eq morphism precategory open equiv namespace precategory @@ -15,13 +15,13 @@ namespace precategory definition set_precategory : precategory.{l+1 l} (Σ (A : Type.{l}), is_hset A) := begin fapply precategory.mk.{l+1 l}, - intros, apply (a.1 → a_1.1), - intros, apply trunc_pi, intros, apply b.2, + intros (a, a_1), apply (a.1 → a_1.1), + intros, apply is_trunc_pi, intros, apply b.2, intros, intro x, exact (a_1 (a_2 x)), intros, exact (λ (x : a.1), x), - intros, apply funext.path_pi, intro x, apply idp, - intros, apply funext.path_pi, intro x, apply idp, - intros, apply funext.path_pi, intro x, apply idp, + intros, apply funext.eq_of_homotopy, intro x, apply idp, + intros, apply funext.eq_of_homotopy, intro x, apply idp, + intros, apply funext.eq_of_homotopy, intro x, apply idp, end end precategory @@ -51,19 +51,19 @@ namespace category assert (C : precategory.{l+1 l} (Σ (A : Type.{l}), is_hset A)), apply precategory.set_precategory, apply category.mk, - assert (p : (λ A B p, (set_category_equiv_iso A B) ▹ iso_of_path p) = (λ A B p, @equiv_path A.1 B.1 p)), + assert (p : (λ A B p, (set_category_equiv_iso A B) ▹ iso_of_path p) = (λ A B p, @equiv_of_eq A.1 B.1 p)), apply is_equiv.adjointify, intros, apply (isomorphic.rec_on a_1), intros (iso', is_iso'), apply (is_iso.rec_on is_iso'), intros (f', f'sect, f'retr), - fapply sigma.path, + fapply sigma_eq, apply ua, fapply equiv.mk, exact iso', fapply is_equiv.adjointify, exact f', intros, apply (f'retr ▹ _), intros, apply (f'sect ▹ _), apply (@is_hprop.elim), - apply is_trunc_is_hprop, + apply is_hprop_is_trunc, intros, end -/ sorry diff --git a/hott/algebra/group.hlean b/hott/algebra/group.hlean index fc97286f5b..c6c7df1fd9 100644 --- a/hott/algebra/group.hlean +++ b/hott/algebra/group.hlean @@ -10,7 +10,7 @@ Various multiplicative and additive structures. Partially modeled on Isabelle's import algebra.binary -open eq truncation binary -- note: ⁻¹ will be overloaded +open eq is_trunc binary -- note: ⁻¹ will be overloaded namespace path_algebra @@ -117,11 +117,11 @@ theorem add_right_cancel [s : add_right_cancel_semigroup A] {a b c : A} : /- monoid -/ structure monoid [class] (A : Type) extends semigroup A, has_one A := -(mul_left_id : ∀a, mul one a = a) (mul_right_id : ∀a, mul a one = a) +(one_mul : ∀a, mul one a = a) (mul_one : ∀a, mul a one = a) -theorem mul_left_id [s : monoid A] (a : A) : 1 * a = a := !monoid.mul_left_id +theorem one_mul [s : monoid A] (a : A) : 1 * a = a := !monoid.one_mul -theorem mul_right_id [s : monoid A] (a : A) : a * 1 = a := !monoid.mul_right_id +theorem mul_one [s : monoid A] (a : A) : a * 1 = a := !monoid.mul_one structure comm_monoid [class] (A : Type) extends monoid A, comm_semigroup A @@ -129,11 +129,11 @@ structure comm_monoid [class] (A : Type) extends monoid A, comm_semigroup A /- additive monoid -/ structure add_monoid [class] (A : Type) extends add_semigroup A, has_zero A := -(add_left_id : ∀a, add zero a = a) (add_right_id : ∀a, add a zero = a) +(zero_add : ∀a, add zero a = a) (add_zero : ∀a, add a zero = a) -theorem add_left_id [s : add_monoid A] (a : A) : 0 + a = a := !add_monoid.add_left_id +theorem zero_add [s : add_monoid A] (a : A) : 0 + a = a := !add_monoid.zero_add -theorem add_right_id [s : add_monoid A] (a : A) : a + 0 = a := !add_monoid.add_right_id +theorem add_zero [s : add_monoid A] (a : A) : a + 0 = a := !add_monoid.add_zero structure add_comm_monoid [class] (A : Type) extends add_monoid A, add_comm_semigroup A @@ -144,7 +144,7 @@ structure add_comm_monoid [class] (A : Type) extends add_monoid A, add_comm_semi structure group [class] (A : Type) extends monoid A, has_inv A := (mul_left_inv : ∀a, mul (inv a) a = one) --- Note: with more work, we could derive the axiom mul_left_id +-- Note: with more work, we could derive the axiom one_mul section group @@ -157,28 +157,28 @@ section group calc a⁻¹ * (a * b) = a⁻¹ * a * b : mul_assoc ... = 1 * b : mul_left_inv - ... = b : mul_left_id + ... = b : one_mul theorem inv_mul_cancel_right (a b : A) : a * b⁻¹ * b = a := calc a * b⁻¹ * b = a * (b⁻¹ * b) : mul_assoc ... = a * 1 : mul_left_inv - ... = a : mul_right_id + ... = a : mul_one - theorem inv_unique {a b : A} (H : a * b = 1) : a⁻¹ = b := + theorem inv_eq_of_mul_eq_one {a b : A} (H : a * b = 1) : a⁻¹ = b := calc - a⁻¹ = a⁻¹ * 1 : mul_right_id + a⁻¹ = a⁻¹ * 1 : mul_one ... = a⁻¹ * (a * b) : H ... = b : inv_mul_cancel_left - theorem inv_one : 1⁻¹ = 1 := inv_unique (mul_left_id 1) + theorem inv_one : 1⁻¹ = 1 := inv_eq_of_mul_eq_one (one_mul 1) - theorem inv_inv (a : A) : (a⁻¹)⁻¹ = a := inv_unique (mul_left_inv a) + theorem inv_inv (a : A) : (a⁻¹)⁻¹ = a := inv_eq_of_mul_eq_one (mul_left_inv a) theorem inv_inj {a b : A} (H : a⁻¹ = b⁻¹) : a = b := calc a = (a⁻¹)⁻¹ : inv_inv - ... = b : inv_unique (H⁻¹ ▹ (mul_left_inv _)) + ... = b : inv_eq_of_mul_eq_one (H⁻¹ ▹ (mul_left_inv _)) --theorem inv_eq_inv_iff_eq (a b : A) : a⁻¹ = b⁻¹ ↔ a = b := --iff.intro (assume H, inv_inj H) (assume H, congr_arg _ H) @@ -201,57 +201,57 @@ section group calc a * (a⁻¹ * b) = a * a⁻¹ * b : mul_assoc ... = 1 * b : mul_right_inv - ... = b : mul_left_id + ... = b : one_mul theorem mul_inv_cancel_right (a b : A) : a * b * b⁻¹ = a := calc a * b * b⁻¹ = a * (b * b⁻¹) : mul_assoc ... = a * 1 : mul_right_inv - ... = a : mul_right_id + ... = a : mul_one theorem inv_mul (a b : A) : (a * b)⁻¹ = b⁻¹ * a⁻¹ := - inv_unique + inv_eq_of_mul_eq_one (calc a * b * (b⁻¹ * a⁻¹) = a * (b * (b⁻¹ * a⁻¹)) : mul_assoc ... = a * a⁻¹ : mul_inv_cancel_left ... = 1 : mul_right_inv) - theorem mul_inv_eq_one_imp_eq {a b : A} (H : a * b⁻¹ = 1) : a = b := + theorem eq_of_mul_inv_eq_one {a b : A} (H : a * b⁻¹ = 1) : a = b := calc a = a * b⁻¹ * b : inv_mul_cancel_right ... = 1 * b : H - ... = b : mul_left_id + ... = b : one_mul -- TODO: better names for the next eight theorems? (Also for additive ones.) - theorem mul_eq_imp_eq_mul_inv {a b c : A} (H : a * b = c) : a = c * b⁻¹ := + theorem eq_mul_inv_of_mul_eq {a b c : A} (H : a * b = c) : a = c * b⁻¹ := H ▹ !mul_inv_cancel_right⁻¹ - theorem mul_eq_imp_eq_inv_mul {a b c : A} (H : a * b = c) : b = a⁻¹ * c := + theorem eq_inv_mul_of_mul_eq {a b c : A} (H : a * b = c) : b = a⁻¹ * c := H ▹ !inv_mul_cancel_left⁻¹ - theorem eq_mul_imp_inv_mul_eq {a b c : A} (H : a = b * c) : b⁻¹ * a = c := + theorem inv_mul_eq_of_eq_mul {a b c : A} (H : a = b * c) : b⁻¹ * a = c := H⁻¹ ▹ !inv_mul_cancel_left - theorem eq_mul_imp_mul_inv_eq {a b c : A} (H : a = b * c) : a * c⁻¹ = b := + theorem mul_inv_eq_of_eq_mul {a b c : A} (H : a = b * c) : a * c⁻¹ = b := H⁻¹ ▹ !mul_inv_cancel_right - theorem mul_inv_eq_imp_eq_mul {a b c : A} (H : a * b⁻¹ = c) : a = c * b := - !inv_inv ▹ (mul_eq_imp_eq_mul_inv H) + theorem eq_mul_of_mul_inv_eq {a b c : A} (H : a * b⁻¹ = c) : a = c * b := + !inv_inv ▹ (eq_mul_inv_of_mul_eq H) - theorem inv_mul_eq_imp_eq_mul {a b c : A} (H : a⁻¹ * b = c) : b = a * c := - !inv_inv ▹ (mul_eq_imp_eq_inv_mul H) + theorem eq_mul_of_inv_mul_eq {a b c : A} (H : a⁻¹ * b = c) : b = a * c := + !inv_inv ▹ (eq_inv_mul_of_mul_eq H) - theorem eq_inv_mul_imp_mul_eq {a b c : A} (H : a = b⁻¹ * c) : b * a = c := - !inv_inv ▹ (eq_mul_imp_inv_mul_eq H) + theorem mul_eq_of_eq_inv_mul {a b c : A} (H : a = b⁻¹ * c) : b * a = c := + !inv_inv ▹ (inv_mul_eq_of_eq_mul H) - theorem eq_mul_inv_imp_mul_eq {a b c : A} (H : a = b * c⁻¹) : a * c = b := - !inv_inv ▹ (eq_mul_imp_mul_inv_eq H) + theorem mul_eq_of_eq_mul_inv {a b c : A} (H : a = b * c⁻¹) : a * c = b := + !inv_inv ▹ (mul_inv_eq_of_eq_mul H) --theorem mul_eq_iff_eq_inv_mul (a b c : A) : a * b = c ↔ b = a⁻¹ * c := - --iff.intro mul_eq_imp_eq_inv_mul eq_inv_mul_imp_mul_eq + --iff.intro eq_inv_mul_of_mul_eq mul_eq_of_eq_inv_mul --theorem mul_eq_iff_eq_mul_inv (a b c : A) : a * b = c ↔ a = c * b⁻¹ := - --iff.intro mul_eq_imp_eq_mul_inv eq_mul_inv_imp_mul_eq + --iff.intro eq_mul_inv_of_mul_eq mul_eq_of_eq_mul_inv definition group.to_left_cancel_semigroup [instance] : left_cancel_semigroup A := left_cancel_semigroup.mk (@group.mul A s) (@group.carrier_hset A s) (@group.mul_assoc A s) @@ -292,28 +292,28 @@ section add_group calc -a + (a + b) = -a + a + b : add_assoc ... = 0 + b : add_left_inv - ... = b : add_left_id + ... = b : zero_add theorem neg_add_cancel_right (a b : A) : a + -b + b = a := calc a + -b + b = a + (-b + b) : add_assoc ... = a + 0 : add_left_inv - ... = a : add_right_id + ... = a : add_zero - theorem neg_unique {a b : A} (H : a + b = 0) : -a = b := + theorem neq_eq_of_add_eq_zero {a b : A} (H : a + b = 0) : -a = b := calc - -a = -a + 0 : add_right_id + -a = -a + 0 : add_zero ... = -a + (a + b) : H ... = b : neg_add_cancel_left - theorem neg_zero : -0 = 0 := neg_unique (add_left_id 0) + theorem neg_zero : -0 = 0 := neq_eq_of_add_eq_zero (zero_add 0) - theorem neg_neg (a : A) : -(-a) = a := neg_unique (add_left_inv a) + theorem neg_neg (a : A) : -(-a) = a := neq_eq_of_add_eq_zero (add_left_inv a) theorem neg_inj {a b : A} (H : -a = -b) : a = b := calc a = -(-a) : neg_neg - ... = b : neg_unique (H⁻¹ ▹ (add_left_inv _)) + ... = b : neq_eq_of_add_eq_zero (H⁻¹ ▹ (add_left_inv _)) --theorem neg_eq_neg_iff_eq (a b : A) : -a = -b ↔ a = b := --iff.intro (assume H, neg_inj H) (assume H, congr_arg _ H) @@ -321,11 +321,11 @@ section add_group --theorem neg_eq_zero_iff_eq_zero (a b : A) : -a = 0 ↔ a = 0 := --neg_zero ▹ !neg_eq_neg_iff_eq - theorem eq_neg_imp_eq_neg {a b : A} (H : a = -b) : b = -a := + theorem eq_neq_of_eq_neg {a b : A} (H : a = -b) : b = -a := H⁻¹ ▹ (neg_neg b)⁻¹ --theorem eq_neg_iff_eq_neg (a b : A) : a = -b ↔ b = -a := - --iff.intro !eq_neg_imp_eq_neg !eq_neg_imp_eq_neg + --iff.intro !eq_neq_of_eq_neg !eq_neq_of_eq_neg theorem add_right_inv (a : A) : a + -a = 0 := calc @@ -336,50 +336,50 @@ section add_group calc a + (-a + b) = a + -a + b : add_assoc ... = 0 + b : add_right_inv - ... = b : add_left_id + ... = b : zero_add theorem add_neg_cancel_right (a b : A) : a + b + -b = a := calc a + b + -b = a + (b + -b) : add_assoc ... = a + 0 : add_right_inv - ... = a : add_right_id + ... = a : add_zero - theorem neg_add (a b : A) : -(a + b) = -b + -a := - neg_unique + theorem neq_add_rev (a b : A) : -(a + b) = -b + -a := + neq_eq_of_add_eq_zero (calc a + b + (-b + -a) = a + (b + (-b + -a)) : add_assoc ... = a + -a : add_neg_cancel_left ... = 0 : add_right_inv) - theorem add_eq_imp_eq_add_neg {a b c : A} (H : a + b = c) : a = c + -b := + theorem eq_add_neq_of_add_eq {a b c : A} (H : a + b = c) : a = c + -b := H ▹ !add_neg_cancel_right⁻¹ - theorem add_eq_imp_eq_neg_add {a b c : A} (H : a + b = c) : b = -a + c := + theorem eq_neg_add_of_add_eq {a b c : A} (H : a + b = c) : b = -a + c := H ▹ !neg_add_cancel_left⁻¹ - theorem eq_add_imp_neg_add_eq {a b c : A} (H : a = b + c) : -b + a = c := + theorem neg_add_eq_of_eq_add {a b c : A} (H : a = b + c) : -b + a = c := H⁻¹ ▹ !neg_add_cancel_left - theorem eq_add_imp_add_neg_eq {a b c : A} (H : a = b + c) : a + -c = b := + theorem add_neg_eq_of_eq_add {a b c : A} (H : a = b + c) : a + -c = b := H⁻¹ ▹ !add_neg_cancel_right - theorem add_neg_eq_imp_eq_add {a b c : A} (H : a + -b = c) : a = c + b := - !neg_neg ▹ (add_eq_imp_eq_add_neg H) + theorem eq_add_of_add_neg_eq {a b c : A} (H : a + -b = c) : a = c + b := + !neg_neg ▹ (eq_add_neq_of_add_eq H) - theorem neg_add_eq_imp_eq_add {a b c : A} (H : -a + b = c) : b = a + c := - !neg_neg ▹ (add_eq_imp_eq_neg_add H) + theorem eq_add_of_neg_add_eq {a b c : A} (H : -a + b = c) : b = a + c := + !neg_neg ▹ (eq_neg_add_of_add_eq H) - theorem eq_neg_add_imp_add_eq {a b c : A} (H : a = -b + c) : b + a = c := - !neg_neg ▹ (eq_add_imp_neg_add_eq H) + theorem add_eq_of_eq_neg_add {a b c : A} (H : a = -b + c) : b + a = c := + !neg_neg ▹ (neg_add_eq_of_eq_add H) - theorem eq_add_neg_imp_add_eq {a b c : A} (H : a = b + -c) : a + c = b := - !neg_neg ▹ (eq_add_imp_add_neg_eq H) + theorem add_eq_of_eq_add_neg {a b c : A} (H : a = b + -c) : a + c = b := + !neg_neg ▹ (add_neg_eq_of_eq_add H) --theorem add_eq_iff_eq_neg_add (a b c : A) : a + b = c ↔ b = -a + c := - --iff.intro add_eq_imp_eq_neg_add eq_neg_add_imp_add_eq + --iff.intro eq_neg_add_of_add_eq add_eq_of_eq_neg_add --theorem add_eq_iff_eq_add_neg (a b c : A) : a + b = c ↔ a = c + -b := - --iff.intro add_eq_imp_eq_add_neg eq_add_neg_imp_add_eq + --iff.intro eq_add_neq_of_add_eq add_eq_of_eq_add_neg definition add_group.to_left_cancel_semigroup [instance] : add_left_cancel_semigroup A := @@ -401,53 +401,53 @@ section add_group ... = (c + b) + -b : H ... = c : add_neg_cancel_right) - /- minus -/ + /- sub -/ -- TODO: derive corresponding facts for div in a field - definition minus [reducible] (a b : A) : A := a + -b + definition sub [reducible] (a b : A) : A := a + -b - infix `-` := minus + infix `-` := sub - theorem minus_self (a : A) : a - a = 0 := !add_right_inv + theorem sub_self (a : A) : a - a = 0 := !add_right_inv - theorem minus_add_cancel (a b : A) : a - b + b = a := !neg_add_cancel_right + theorem sub_add_cancel (a b : A) : a - b + b = a := !neg_add_cancel_right - theorem add_minus_cancel (a b : A) : a + b - b = a := !add_neg_cancel_right + theorem add_sub_cancel (a b : A) : a + b - b = a := !add_neg_cancel_right - theorem minus_eq_zero_imp_eq {a b : A} (H : a - b = 0) : a = b := + theorem eq_of_sub_eq_zero {a b : A} (H : a - b = 0) : a = b := calc - a = (a - b) + b : minus_add_cancel + a = (a - b) + b : sub_add_cancel ... = 0 + b : H - ... = b : add_left_id + ... = b : zero_add --theorem eq_iff_minus_eq_zero (a b : A) : a = b ↔ a - b = 0 := - --iff.intro (assume H, H ▹ !minus_self) (assume H, minus_eq_zero_imp_eq H) + --iff.intro (assume H, H ▹ !sub_self) (assume H, eq_of_sub_eq_zero H) - theorem zero_minus (a : A) : 0 - a = -a := !add_left_id + theorem zero_sub (a : A) : 0 - a = -a := !zero_add - theorem minus_zero (a : A) : a - 0 = a := (neg_zero⁻¹) ▹ !add_right_id + theorem sub_zero (a : A) : a - 0 = a := (neg_zero⁻¹) ▹ !add_zero - theorem minus_neg_eq_add (a b : A) : a - (-b) = a + b := !neg_neg ▹ idp + theorem sub_neg_eq_add (a b : A) : a - (-b) = a + b := !neg_neg ▹ idp - theorem neg_minus_eq (a b : A) : -(a - b) = b - a := - neg_unique + theorem neg_sub (a b : A) : -(a - b) = b - a := + neq_eq_of_add_eq_zero (calc a - b + (b - a) = a - b + b - a : add_assoc - ... = a - a : minus_add_cancel - ... = 0 : minus_self) + ... = a - a : sub_add_cancel + ... = 0 : sub_self) - theorem add_minus_eq (a b c : A) : a + (b - c) = a + b - c := !add_assoc⁻¹ + theorem add_sub (a b c : A) : a + (b - c) = a + b - c := !add_assoc⁻¹ - theorem minus_add_eq_minus_swap (a b c : A) : a - (b + c) = a - c - b := + theorem sub_add_eq_sub_sub_swap (a b c : A) : a - (b + c) = a - c - b := calc - a - (b + c) = a + (-c - b) : neg_add + a - (b + c) = a + (-c - b) : neq_add_rev ... = a - c - b : add_assoc --theorem minus_eq_iff_eq_add (a b c : A) : a - b = c ↔ a = c + b := - --iff.intro (assume H, add_neg_eq_imp_eq_add H) (assume H, eq_add_imp_add_neg_eq H) + --iff.intro (assume H, eq_add_of_add_neg_eq H) (assume H, add_neg_eq_of_eq_add H) --theorem eq_minus_iff_add_eq (a b c : A) : a = b - c ↔ a + c = b := - --iff.intro (assume H, eq_add_neg_imp_add_eq H) (assume H, add_eq_imp_eq_add_neg H) + --iff.intro (assume H, add_eq_of_eq_add_neg H) (assume H, eq_add_neq_of_add_eq H) --theorem minus_eq_minus_iff {a b c d : A} (H : a - b = c - d) : a = b ↔ c = d := --calc @@ -464,26 +464,26 @@ section add_comm_group variable [s : add_comm_group A] include s - theorem minus_add_eq (a b c : A) : a - (b + c) = a - b - c := - !add_comm ▹ !minus_add_eq_minus_swap + theorem sub_add_eq_sub_sub (a b c : A) : a - (b + c) = a - b - c := + !add_comm ▹ !sub_add_eq_sub_sub_swap - theorem neg_add_eq_minus (a b : A) : -a + b = b - a := !add_comm + theorem neq_add_eq_sub (a b : A) : -a + b = b - a := !add_comm - theorem neg_add_distrib (a b : A) : -(a + b) = -a + -b := !add_comm ▹ !neg_add + theorem neg_add_distrib (a b : A) : -(a + b) = -a + -b := !add_comm ▹ !neq_add_rev - theorem minus_add_right_comm (a b c : A) : a - b + c = a + c - b := !add_right_comm + theorem sub_add_eq_add_sub (a b c : A) : a - b + c = a + c - b := !add_right_comm - theorem minus_minus_eq (a b c : A) : a - b - c = a - (b + c) := + theorem sub_sub (a b c : A) : a - b - c = a - (b + c) := calc a - b - c = a + (-b + -c) : add_assoc ... = a + -(b + c) : neg_add_distrib ... = a - (b + c) : idp - theorem add_minus_cancel_left (a b c : A) : (c + a) - (c + b) = a - b := + theorem add_sub_add_left_eq_sub (a b c : A) : (c + a) - (c + b) = a - b := calc - (c + a) - (c + b) = c + a - c - b : minus_add_eq + (c + a) - (c + b) = c + a - c - b : sub_add_eq_sub_sub ... = a + c - c - b : add_comm a c - ... = a - b : add_minus_cancel + ... = a - b : add_sub_cancel end add_comm_group diff --git a/hott/algebra/groupoid.hlean b/hott/algebra/groupoid.hlean index ffcaff4acb..a3e50df216 100644 --- a/hott/algebra/groupoid.hlean +++ b/hott/algebra/groupoid.hlean @@ -4,7 +4,7 @@ -- Ported from Coq HoTT import .precategory.basic .precategory.morphism .group types.pi -open eq function prod sigma pi truncation morphism nat path_algebra unit prod sigma.ops +open eq function prod sigma pi is_trunc morphism nat path_algebra unit prod sigma.ops structure foo (A : Type) := (bsp : A) @@ -18,21 +18,21 @@ attribute all_iso [instance] universe variable l open precategory -definition path_groupoid (A : Type.{l}) +definition groupoid_of_1_type (A : Type.{l}) (H : is_trunc (nat.zero .+1) A) : groupoid.{l l} A := groupoid.mk (λ (a b : A), a = b) - (λ (a b : A), have ish : is_hset (a = b), from succ_is_trunc nat.zero a b, ish) + (λ (a b : A), have ish : is_hset (a = b), from is_trunc_eq nat.zero a b, ish) (λ (a b c : A) (p : b = c) (q : a = b), q ⬝ p) (λ (a : A), refl a) - (λ (a b c d : A) (p : c = d) (q : b = c) (r : a = b), concat_pp_p r q p) - (λ (a b : A) (p : a = b), concat_p1 p) - (λ (a b : A) (p : a = b), concat_1p p) + (λ (a b c d : A) (p : c = d) (q : b = c) (r : a = b), con.assoc r q p) + (λ (a b : A) (p : a = b), con_idp p) + (λ (a b : A) (p : a = b), idp_con p) (λ (a b : A) (p : a = b), @is_iso.mk A _ a b p (p⁻¹) - !concat_pV !concat_Vp) + !con.left_inv !con.right_inv) -- A groupoid with a contractible carrier is a group -definition group_of_contr {ob : Type} (H : is_contr ob) +definition group_of_is_contr_groupoid {ob : Type} (H : is_contr ob) (G : groupoid ob) : group (hom (center ob) (center ob)) := begin fapply group.mk, @@ -46,7 +46,7 @@ begin intro f, exact (morphism.inverse_compose f), end -definition group_of_unit (G : groupoid unit) : group (hom ⋆ ⋆) := +definition group_of_unit_groupoid (G : groupoid unit) : group (hom ⋆ ⋆) := begin fapply group.mk, intros (f, g), apply (comp f g), @@ -68,8 +68,8 @@ begin intros (a, b, c, g, h), exact (@group.mul A G g h), intro a, exact (@group.one A G), intros, exact ((@group.mul_assoc A G h g f)⁻¹), - intros, exact (@group.mul_left_id A G f), - intros, exact (@group.mul_right_id A G f), + intros, exact (@group.one_mul A G f), + intros, exact (@group.mul_one A G f), intros, apply is_iso.mk, apply mul_left_inv, apply mul_right_inv, diff --git a/hott/algebra/precategory/basic.hlean b/hott/algebra/precategory/basic.hlean index c26c13bb12..214aa62133 100644 --- a/hott/algebra/precategory/basic.hlean +++ b/hott/algebra/precategory/basic.hlean @@ -2,7 +2,7 @@ -- Released under Apache 2.0 license as described in the file LICENSE. -- Author: Floris van Doorn -open eq truncation +open eq is_trunc structure precategory [class] (ob : Type) : Type := (hom : ob → ob → Type) @@ -26,14 +26,12 @@ namespace precategory definition id [reducible] {a : ob} : hom a a := ID a - infixr `∘` := compose + infixr `∘` := comp infixl `⟶`:25 := hom -- input ⟶ using \--> (this is a different arrow than \-> (→)) variables {h : hom c d} {g : hom b c} {f : hom a b} {i : hom a a} - - --the following is the only theorem for which "include C" is necessary if C is a variable (why?) - theorem id_compose (a : ob) : (ID a) ∘ id = id := !id_left + theorem id_compose (a : ob) : ID a ∘ ID a = ID a := !id_left theorem left_id_unique (H : Π{b} {f : hom b a}, i ∘ f = f) : i = id := calc i = i ∘ id : id_right @@ -42,23 +40,29 @@ namespace precategory theorem right_id_unique (H : Π{b} {f : hom a b}, f ∘ i = f) : i = id := calc i = id ∘ i : id_left ... = id : H + + definition homset [reducible] (x y : ob) : hset := + hset.mk (hom x y) _ + end precategory -inductive Precategory : Type := mk : Π (ob : Type), precategory ob → Precategory +structure Precategory : Type := + (objects : Type) + (category_instance : precategory objects) namespace precategory definition Mk {ob} (C) : Precategory := Precategory.mk ob C definition MK (a b c d e f g h) : Precategory := Precategory.mk a (precategory.mk b c d e f g h) - definition objects [coercion] [reducible] (C : Precategory) : Type - := Precategory.rec (fun c s, c) C - - definition category_instance [instance] [coercion] [reducible] (C : Precategory) : precategory (objects C) - := Precategory.rec (fun c s, s) C + definition objects [coercion] [reducible] := Precategory.objects + definition category_instance [instance] [coercion] [reducible] := Precategory.category_instance + notation g `∘⁅` C `⁆` f := @compose (objects C) (category_instance C) _ _ _ g f + -- TODO: make this left associative + -- TODO: change this notation? end precategory open precategory -theorem Precategory.equal (C : Precategory) : Precategory.mk C C = C := - Precategory.rec (λ ob c, idp) C +protected definition Precategory.eta (C : Precategory) : Precategory.mk C C = C := +Precategory.rec (λob c, idp) C diff --git a/hott/algebra/precategory/constructions.hlean b/hott/algebra/precategory/constructions.hlean index a1a2b1e3be..f443f1ab37 100644 --- a/hott/algebra/precategory/constructions.hlean +++ b/hott/algebra/precategory/constructions.hlean @@ -5,15 +5,15 @@ -- This file contains basic constructions on precategories, including common precategories -import .natural_transformation +import .nat_trans import types.prod types.sigma types.pi -open eq prod eq eq.ops equiv truncation +open eq prod eq eq.ops equiv is_trunc funext namespace precategory namespace opposite - definition opposite {ob : Type} (C : precategory ob) : precategory ob := + definition opposite [reducible] {ob : Type} (C : precategory ob) : precategory ob := mk (λ a b, hom b a) (λ b a, !homH) (λ a b c f g, g ∘ f) @@ -22,7 +22,7 @@ namespace precategory (λ a b f, !id_right) (λ a b f, !id_left) - definition Opposite (C : Precategory) : Precategory := Mk (opposite C) + definition Opposite [reducible] (C : Precategory) : Precategory := Mk (opposite C) infixr `∘op`:60 := @compose _ (opposite _) _ _ _ @@ -40,13 +40,13 @@ namespace precategory begin apply (precategory.rec_on C), intros (hom', homH', comp', ID', assoc', id_left', id_right'), apply (ap (λassoc'', precategory.mk hom' @homH' comp' ID' assoc'' id_left' id_right')), - repeat ( apply funext.path_pi ; intros ), + repeat ( apply funext.eq_of_homotopy ; intros ), apply ap, apply (@is_hset.elim), apply !homH', end - theorem op_op : Opposite (Opposite C) = C := - (ap (Precategory.mk C) (op_op' C)) ⬝ !Precategory.equal + definition op_op : Opposite (Opposite C) = C := + (ap (Precategory.mk C) (op_op' C)) ⬝ !Precategory.eta end opposite @@ -86,27 +86,25 @@ namespace precategory namespace product section - open prod truncation + open prod is_trunc - definition prod_precategory {obC obD : Type} (C : precategory obC) (D : precategory obD) + definition prod_precategory [reducible] [instance] {obC obD : Type} (C : precategory obC) (D : precategory obD) : precategory (obC × obD) := mk (λ a b, hom (pr1 a) (pr1 b) × hom (pr2 a) (pr2 b)) - (λ a b, !trunc_prod) + (λ a b, !is_trunc_prod) (λ a b c g f, (pr1 g ∘ pr1 f , pr2 g ∘ pr2 f) ) (λ a, (id, id)) - (λ a b c d h g f, pair_path !assoc !assoc ) - (λ a b f, prod.path !id_left !id_left ) - (λ a b f, prod.path !id_right !id_right) + (λ a b c d h g f, pair_eq !assoc !assoc ) + (λ a b f, prod_eq !id_left !id_left ) + (λ a b f, prod_eq !id_right !id_right) - definition Prod_precategory (C D : Precategory) : Precategory := Mk (prod_precategory C D) + definition Prod_precategory [reducible] (C D : Precategory) : Precategory := Mk (prod_precategory C D) end end product namespace ops - - --notation `type`:max := Type_category - --notation 1 := Category_one --it was confusing for me (Floris) that no ``s are needed here + --notation 1 := Category_one --notation 2 := Category_two postfix `ᵒᵖ`:max := opposite.Opposite infixr `×c`:30 := product.Prod_precategory @@ -118,248 +116,55 @@ namespace precategory open ops namespace opposite - section open ops functor - set_option pp.universes true - - definition opposite_functor {C D : Precategory} (F : C ⇒ D) : Cᵒᵖ ⇒ Dᵒᵖ := - /-begin + definition opposite_functor [reducible] {C D : Precategory} (F : C ⇒ D) : Cᵒᵖ ⇒ Dᵒᵖ := + begin apply (@functor.mk (Cᵒᵖ) (Dᵒᵖ)), intro a, apply (respect_id F), intros, apply (@respect_comp C D) - end-/ sorry - end + end opposite namespace product section open ops functor - definition prod_functor {C C' D D' : Precategory} (F : C ⇒ D) (G : C' ⇒ D') : C ×c C' ⇒ D ×c D' := + definition prod_functor [reducible] {C C' D D' : Precategory} (F : C ⇒ D) (G : C' ⇒ D') : C ×c C' ⇒ D ×c D' := functor.mk (λ a, pair (F (pr1 a)) (G (pr2 a))) (λ a b f, pair (F (pr1 f)) (G (pr2 f))) - (λ a, pair_path !respect_id !respect_id) - (λ a b c g f, pair_path !respect_comp !respect_comp) + (λ a, pair_eq !respect_id !respect_id) + (λ a b c g f, pair_eq !respect_comp !respect_comp) end end product + definition precategory_hset [reducible] : precategory hset := + precategory.mk (λx y : hset, x → y) + _ + (λx y z g f a, g (f a)) + (λx a, a) + (λx y z w h g f, eq_of_homotopy (λa, idp)) + (λx y f, eq_of_homotopy (λa, idp)) + (λx y f, eq_of_homotopy (λa, idp)) + + definition Precategory_hset [reducible] : Precategory := + Precategory.mk hset precategory_hset + namespace ops infixr `×f`:30 := product.prod_functor infixr `ᵒᵖᶠ`:max := opposite.opposite_functor + abbreviation set := Precategory_hset end ops - section functor_category + section precategory_functor variables (C D : Precategory) - definition functor_category [fx : funext] : precategory (functor C D) := - mk (λa b, natural_transformation a b) - (λ a b, @natural_transformation.to_hset C D a b) - (λ a b c g f, natural_transformation.compose g f) - (λ a, natural_transformation.id) - (λ a b c d h g f, !natural_transformation.assoc) - (λ a b f, !natural_transformation.id_left) - (λ a b f, !natural_transformation.id_right) - end functor_category + definition precategory_functor [reducible] : precategory (functor C D) := + mk (λa b, nat_trans a b) + (λ a b, @nat_trans.to_hset C D a b) + (λ a b c g f, nat_trans.compose g f) + (λ a, nat_trans.id) + (λ a b c d h g f, !nat_trans.assoc) + (λ a b f, !nat_trans.id_left) + (λ a b f, !nat_trans.id_right) + end precategory_functor - namespace slice - open sigma function - variables {ob : Type} {C : precategory ob} {c : ob} - protected definition slice_obs (C : precategory ob) (c : ob) := Σ(b : ob), hom b c - variables {a b : slice_obs C c} - protected definition to_ob (a : slice_obs C c) : ob := pr1 a - protected definition to_ob_def (a : slice_obs C c) : to_ob a = pr1 a := rfl - protected definition ob_hom (a : slice_obs C c) : hom (to_ob a) c := pr2 a - -- protected theorem slice_obs_equal (H₁ : to_ob a = to_ob b) - -- (H₂ : eq.drec_on H₁ (ob_hom a) = ob_hom b) : a = b := - -- sigma.equal H₁ H₂ - - - protected definition slice_hom (a b : slice_obs C c) : Type := - Σ(g : hom (to_ob a) (to_ob b)), ob_hom b ∘ g = ob_hom a - - protected definition hom_hom (f : slice_hom a b) : hom (to_ob a) (to_ob b) := pr1 f - protected definition commute (f : slice_hom a b) : ob_hom b ∘ (hom_hom f) = ob_hom a := pr2 f - -- protected theorem slice_hom_equal (f g : slice_hom a b) (H : hom_hom f = hom_hom g) : f = g := - -- sigma.equal H !proof_irrel - - /- TODO wait for some helping lemmas - definition slice_category (C : precategory ob) (c : ob) : precategory (slice_obs C c) := - mk (λa b, slice_hom a b) - sorry - (λ a b c g f, dpair (hom_hom g ∘ hom_hom f) - (show ob_hom c ∘ (hom_hom g ∘ hom_hom f) = ob_hom a, - proof - calc - ob_hom c ∘ (hom_hom g ∘ hom_hom f) = (ob_hom c ∘ hom_hom g) ∘ hom_hom f : !assoc - ... = ob_hom b ∘ hom_hom f : {commute g} - ... = ob_hom a : {commute f} - qed)) - (λ a, dpair id !id_right) - (λ a b c d h g f, dpair_path !assoc sorry) - (λ a b f, sigma.path !id_left sorry) - (λ a b f, sigma.path !id_right sorry) - -/ - - - -- definition slice_category {ob : Type} (C : category ob) (c : ob) : category (Σ(b : ob), hom b c) - -- := - -- mk (λa b, Σ(g : hom (dpr1 a) (dpr1 b)), dpr2 b ∘ g = dpr2 a) - -- (λ a b c g f, dpair (dpr1 g ∘ dpr1 f) - -- (show dpr2 c ∘ (dpr1 g ∘ dpr1 f) = dpr2 a, - -- proof - -- calc - -- dpr2 c ∘ (dpr1 g ∘ dpr1 f) = (dpr2 c ∘ dpr1 g) ∘ dpr1 f : !assoc - -- ... = dpr2 b ∘ dpr1 f : {dpr2 g} - -- ... = dpr2 a : {dpr2 f} - -- qed)) - -- (λ a, dpair id !id_right) - -- (λ a b c d h g f, dpair_eq !assoc !proof_irrel) - -- (λ a b f, sigma.equal !id_left !proof_irrel) - -- (λ a b f, sigma.equal !id_right !proof_irrel) - -- We use !proof_irrel instead of rfl, to give the unifier an easier time - -exit - definition Slice_category [reducible] (C : Category) (c : C) := Mk (slice_category C c) - open category.ops - attribute slice_category [instance] - variables {D : Category} - definition forgetful (x : D) : (Slice_category D x) ⇒ D := - functor.mk (λ a, to_ob a) - (λ a b f, hom_hom f) - (λ a, rfl) - (λ a b c g f, rfl) - - definition postcomposition_functor {x y : D} (h : x ⟶ y) - : Slice_category D x ⇒ Slice_category D y := - functor.mk (λ a, dpair (to_ob a) (h ∘ ob_hom a)) - (λ a b f, dpair (hom_hom f) - (calc - (h ∘ ob_hom b) ∘ hom_hom f = h ∘ (ob_hom b ∘ hom_hom f) : assoc h (ob_hom b) (hom_hom f)⁻¹ - ... = h ∘ ob_hom a : congr_arg (λx, h ∘ x) (commute f))) - (λ a, rfl) - (λ a b c g f, dpair_eq rfl !proof_irrel) - - -- -- in the following comment I tried to have (A = B) in the type of a == b, but that doesn't solve the problems - -- definition heq2 {A B : Type} (H : A = B) (a : A) (b : B) := a == b - -- definition heq2.intro {A B : Type} {a : A} {b : B} (H : a == b) : heq2 (heq.type_eq H) a b := H - -- definition heq2.elim {A B : Type} {a : A} {b : B} (H : A = B) (H2 : heq2 H a b) : a == b := H2 - -- definition heq2.proof_irrel {A B : Prop} (a : A) (b : B) (H : A = B) : heq2 H a b := - -- hproof_irrel H a b - -- theorem functor.mk_eq2 {C D : Category} {obF obG : C → D} {homF homG idF idG compF compG} - -- (Hob : ∀x, obF x = obG x) - -- (Hmor : ∀(a b : C) (f : a ⟶ b), heq2 (congr_arg (λ x, x a ⟶ x b) (funext Hob)) (homF a b f) (homG a b f)) - -- : functor.mk obF homF idF compF = functor.mk obG homG idG compG := - -- hddcongr_arg4 functor.mk - -- (funext Hob) - -- (hfunext (λ a, hfunext (λ b, hfunext (λ f, !Hmor)))) - -- !proof_irrel - -- !proof_irrel - --- set_option pp.implicit true --- set_option pp.coercions true - - -- definition slice_functor : D ⇒ Category_of_categories := - -- functor.mk (λ a, Category.mk (slice_obs D a) (slice_category D a)) - -- (λ a b f, postcomposition_functor f) - -- (λ a, functor.mk_heq - -- (λx, sigma.equal rfl !id_left) - -- (λb c f, sigma.hequal sorry !heq.refl (hproof_irrel sorry _ _))) - -- (λ a b c g f, functor.mk_heq - -- (λx, sigma.equal (sorry ⬝ refl (dpr1 x)) sorry) - -- (λb c f, sorry)) - - --the error message generated here is really confusing: the type of the above refl should be - -- "@dpr1 D (λ (a_1 : D), a_1 ⟶ a) x = @dpr1 D (λ (a_1 : D), a_1 ⟶ c) x", but the second dpr1 is not even well-typed - - end slice - - -- section coslice - -- open sigma - - -- definition coslice {ob : Type} (C : category ob) (c : ob) : category (Σ(b : ob), hom c b) := - -- mk (λa b, Σ(g : hom (dpr1 a) (dpr1 b)), g ∘ dpr2 a = dpr2 b) - -- (λ a b c g f, dpair (dpr1 g ∘ dpr1 f) - -- (show (dpr1 g ∘ dpr1 f) ∘ dpr2 a = dpr2 c, - -- proof - -- calc - -- (dpr1 g ∘ dpr1 f) ∘ dpr2 a = dpr1 g ∘ (dpr1 f ∘ dpr2 a): symm !assoc - -- ... = dpr1 g ∘ dpr2 b : {dpr2 f} - -- ... = dpr2 c : {dpr2 g} - -- qed)) - -- (λ a, dpair id !id_left) - -- (λ a b c d h g f, dpair_eq !assoc !proof_irrel) - -- (λ a b f, sigma.equal !id_left !proof_irrel) - -- (λ a b f, sigma.equal !id_right !proof_irrel) - - -- -- theorem slice_coslice_opp {ob : Type} (C : category ob) (c : ob) : - -- -- coslice C c = opposite (slice (opposite C) c) := - -- -- sorry - -- end coslice - - section arrow - open sigma eq.ops - -- theorem concat_commutative_squares {ob : Type} {C : category ob} {a1 a2 a3 b1 b2 b3 : ob} - -- {f1 : a1 => b1} {f2 : a2 => b2} {f3 : a3 => b3} {g2 : a2 => a3} {g1 : a1 => a2} - -- {h2 : b2 => b3} {h1 : b1 => b2} (H1 : f2 ∘ g1 = h1 ∘ f1) (H2 : f3 ∘ g2 = h2 ∘ f2) - -- : f3 ∘ (g2 ∘ g1) = (h2 ∘ h1) ∘ f1 := - -- calc - -- f3 ∘ (g2 ∘ g1) = (f3 ∘ g2) ∘ g1 : assoc - -- ... = (h2 ∘ f2) ∘ g1 : {H2} - -- ... = h2 ∘ (f2 ∘ g1) : symm assoc - -- ... = h2 ∘ (h1 ∘ f1) : {H1} - -- ... = (h2 ∘ h1) ∘ f1 : assoc - - -- definition arrow {ob : Type} (C : category ob) : category (Σ(a b : ob), hom a b) := - -- mk (λa b, Σ(g : hom (dpr1 a) (dpr1 b)) (h : hom (dpr2' a) (dpr2' b)), - -- dpr3 b ∘ g = h ∘ dpr3 a) - -- (λ a b c g f, dpair (dpr1 g ∘ dpr1 f) (dpair (dpr2' g ∘ dpr2' f) (concat_commutative_squares (dpr3 f) (dpr3 g)))) - -- (λ a, dpair id (dpair id (id_right ⬝ (symm id_left)))) - -- (λ a b c d h g f, dtrip_eq2 assoc assoc !proof_irrel) - -- (λ a b f, trip.equal2 id_left id_left !proof_irrel) - -- (λ a b f, trip.equal2 id_right id_right !proof_irrel) - - -- make these definitions private? - variables {ob : Type} {C : category ob} - protected definition arrow_obs (ob : Type) (C : category ob) := Σ(a b : ob), hom a b - variables {a b : arrow_obs ob C} - protected definition src (a : arrow_obs ob C) : ob := dpr1 a - protected definition dst (a : arrow_obs ob C) : ob := dpr2' a - protected definition to_hom (a : arrow_obs ob C) : hom (src a) (dst a) := dpr3 a - - protected definition arrow_hom (a b : arrow_obs ob C) : Type := - Σ (g : hom (src a) (src b)) (h : hom (dst a) (dst b)), to_hom b ∘ g = h ∘ to_hom a - - protected definition hom_src (m : arrow_hom a b) : hom (src a) (src b) := dpr1 m - protected definition hom_dst (m : arrow_hom a b) : hom (dst a) (dst b) := dpr2' m - protected definition commute (m : arrow_hom a b) : to_hom b ∘ (hom_src m) = (hom_dst m) ∘ to_hom a - := dpr3 m - - definition arrow (ob : Type) (C : category ob) : category (arrow_obs ob C) := - mk (λa b, arrow_hom a b) - (λ a b c g f, dpair (hom_src g ∘ hom_src f) (dpair (hom_dst g ∘ hom_dst f) - (show to_hom c ∘ (hom_src g ∘ hom_src f) = (hom_dst g ∘ hom_dst f) ∘ to_hom a, - proof - calc - to_hom c ∘ (hom_src g ∘ hom_src f) = (to_hom c ∘ hom_src g) ∘ hom_src f : !assoc - ... = (hom_dst g ∘ to_hom b) ∘ hom_src f : {commute g} - ... = hom_dst g ∘ (to_hom b ∘ hom_src f) : symm !assoc - ... = hom_dst g ∘ (hom_dst f ∘ to_hom a) : {commute f} - ... = (hom_dst g ∘ hom_dst f) ∘ to_hom a : !assoc - qed) - )) - (λ a, dpair id (dpair id (!id_right ⬝ (symm !id_left)))) - (λ a b c d h g f, ndtrip_eq !assoc !assoc !proof_irrel) - (λ a b f, ndtrip_equal !id_left !id_left !proof_irrel) - (λ a b f, ndtrip_equal !id_right !id_right !proof_irrel) - - end arrow - -end category - - -- definition foo - -- : category (sorry) := - -- mk (λa b, sorry) - -- (λ a b c g f, sorry) - -- (λ a, sorry) - -- (λ a b c d h g f, sorry) - -- (λ a b f, sorry) - -- (λ a b f, sorry) +end precategory diff --git a/hott/algebra/precategory/functor.hlean b/hott/algebra/precategory/functor.hlean index 331770ea3a..20d02ebde7 100644 --- a/hott/algebra/precategory/functor.hlean +++ b/hott/algebra/precategory/functor.hlean @@ -4,7 +4,7 @@ import .basic types.pi -open function precategory eq prod equiv is_equiv sigma sigma.ops truncation +open function precategory eq prod equiv is_equiv sigma sigma.ops is_trunc open pi structure functor (C D : Precategory) : Type := @@ -49,25 +49,25 @@ namespace functor protected definition strict_cat_has_functor_hset [HD : is_hset (objects D)] : is_hset (functor C D) := begin - apply trunc_equiv, apply equiv.to_is_equiv, + apply is_trunc_is_equiv_closed, apply equiv.to_is_equiv, apply sigma_char, - apply trunc_sigma, apply trunc_pi, intros, exact HD, intro F, - apply trunc_sigma, apply trunc_pi, intro a, - apply trunc_pi, intro b, - apply trunc_pi, intro c, apply !homH, - intro H, apply trunc_prod, - apply trunc_pi, intro a, - apply succ_is_trunc, apply trunc_succ, apply !homH, - apply trunc_pi, intro a, - apply trunc_pi, intro b, - apply trunc_pi, intro c, - apply trunc_pi, intro g, - apply trunc_pi, intro f, - apply succ_is_trunc, apply trunc_succ, apply !homH, + apply is_trunc_sigma, apply is_trunc_pi, intros, exact HD, intro F, + apply is_trunc_sigma, apply is_trunc_pi, intro a, + apply is_trunc_pi, intro b, + apply is_trunc_pi, intro c, apply !homH, + intro H, apply is_trunc_prod, + apply is_trunc_pi, intro a, + apply is_trunc_eq, apply is_trunc_succ, apply !homH, + apply is_trunc_pi, intro a, + apply is_trunc_pi, intro b, + apply is_trunc_pi, intro c, + apply is_trunc_pi, intro g, + apply is_trunc_pi, intro f, + apply is_trunc_eq, apply is_trunc_succ, apply !homH, end -- The following lemmas will later be used to prove that the type of - -- precategories formes a precategory itself + -- precategories forms a precategory itself protected definition compose (G : functor D E) (F : functor C D) : functor C E := functor.mk (λ x, G (F x)) @@ -106,10 +106,10 @@ namespace functor apply (functor.rec_on G), intros (G1, G2, G3, G4), apply (functor.rec_on F), intros (F1, F2, F3, F4), fapply functor.congr, - apply funext.path_pi, intro a, + apply funext.eq_of_homotopy, intro a, apply (@is_hset.elim), apply !homH, - apply funext.path_pi, intro a, - repeat (apply funext.path_pi; intros), + apply funext.eq_of_homotopy, intro a, + repeat (apply funext.eq_of_homotopy; intros), apply (@is_hset.elim), apply !homH, end @@ -122,9 +122,9 @@ namespace functor begin apply (functor.rec_on F), intros (F1, F2, F3, F4), fapply functor.congr, - apply funext.path_pi, intro a, + apply funext.eq_of_homotopy, intro a, apply (@is_hset.elim), apply !homH, - repeat (apply funext.path_pi; intros), + repeat (apply funext.eq_of_homotopy; intros), apply (@is_hset.elim), apply !homH, end @@ -132,9 +132,9 @@ namespace functor begin apply (functor.rec_on F), intros (F1, F2, F3, F4), fapply functor.congr, - apply funext.path_pi, intro a, + apply funext.eq_of_homotopy, intro a, apply (@is_hset.elim), apply !homH, - repeat (apply funext.path_pi; intros), + repeat (apply funext.eq_of_homotopy; intros), apply (@is_hset.elim), apply !homH, end diff --git a/hott/algebra/precategory/iso.hlean b/hott/algebra/precategory/iso.hlean index 73ddae88ba..e5ce49cb44 100644 --- a/hott/algebra/precategory/iso.hlean +++ b/hott/algebra/precategory/iso.hlean @@ -4,7 +4,7 @@ import .basic .morphism types.sigma -open eq precategory sigma sigma.ops equiv is_equiv function truncation +open eq precategory sigma sigma.ops equiv is_equiv function is_trunc open prod namespace morphism @@ -45,20 +45,20 @@ namespace morphism -- The statement "f is an isomorphism" is a mere proposition definition is_hprop_of_is_iso : is_hset (is_iso f) := begin - apply trunc_equiv, + apply is_trunc_is_equiv_closed, apply (equiv.to_is_equiv (!sigma_char)), - apply trunc_sigma, + apply is_trunc_sigma, apply (!homH), - intro g, apply trunc_prod, - repeat (apply succ_is_trunc; apply trunc_succ; apply (!homH)), + intro g, apply is_trunc_prod, + repeat (apply is_trunc_eq; apply is_trunc_succ; apply (!homH)), end -- The type of isomorphisms between two objects is a set definition is_hset_iso : is_hset (a ≅ b) := begin - apply trunc_equiv, + apply is_trunc_is_equiv_closed, apply (equiv.to_is_equiv (!sigma_is_iso_equiv)), - apply trunc_sigma, + apply is_trunc_sigma, apply homH, intro f, apply is_hprop_of_is_iso, end diff --git a/hott/algebra/precategory/morphism.hlean b/hott/algebra/precategory/morphism.hlean index 462d390011..1b661c6f2e 100644 --- a/hott/algebra/precategory/morphism.hlean +++ b/hott/algebra/precategory/morphism.hlean @@ -4,7 +4,7 @@ import .basic -open eq precategory sigma sigma.ops equiv is_equiv function truncation +open eq precategory sigma sigma.ops equiv is_equiv function is_trunc namespace morphism variables {ob : Type} [C : precategory ob] include C @@ -39,16 +39,16 @@ namespace morphism theorem compose_section (f : a ⟶ b) [H : is_retraction f] : f ∘ section_of f = id := is_retraction.rec (λg h, h) H - theorem iso_imp_retraction [instance] (f : a ⟶ b) [H : is_iso f] : is_section f := + theorem is_section_of_is_iso [instance] (f : a ⟶ b) [H : is_iso f] : is_section f := is_section.mk !inverse_compose - theorem iso_imp_section [instance] (f : a ⟶ b) [H : is_iso f] : is_retraction f := + theorem is_retraction_of_is_iso [instance] (f : a ⟶ b) [H : is_iso f] : is_retraction f := is_retraction.mk !compose_inverse - theorem id_is_iso [instance] : is_iso (ID a) := + theorem is_iso_id [instance] : is_iso (ID a) := is_iso.mk !id_compose !id_compose - theorem inverse_is_iso [instance] (f : a ⟶ b) [H : is_iso f] : is_iso (f⁻¹) := + theorem is_iso_inverse [instance] (f : a ⟶ b) [H : is_iso f] : is_iso (f⁻¹) := is_iso.mk !compose_inverse !inverse_compose theorem left_inverse_eq_right_inverse {f : a ⟶ b} {g g' : hom b a} @@ -72,13 +72,13 @@ namespace morphism theorem inverse_eq_intro_left [H : is_iso f] (H2 : h ∘ f = id) : f⁻¹ = h := (left_inverse_eq_right_inverse H2 !compose_inverse)⁻¹ - theorem section_eq_retraction (f : a ⟶ b) [Hl : is_section f] [Hr : is_retraction f] : + theorem section_of_eq_retraction_of (f : a ⟶ b) [Hl : is_section f] [Hr : is_retraction f] : retraction_of f = section_of f := retraction_eq_intro !compose_section - theorem section_retraction_imp_iso (f : a ⟶ b) [Hl : is_section f] [Hr : is_retraction f] + theorem is_iso_of_is_retraction_of_is_section (f : a ⟶ b) [Hl : is_section f] [Hr : is_retraction f] : is_iso f := - is_iso.mk ((section_eq_retraction f) ▹ (retraction_compose f)) (compose_section f) + is_iso.mk ((section_of_eq_retraction_of f) ▹ (retraction_compose f)) (compose_section f) theorem inverse_unique (H H' : is_iso f) : @inverse _ _ _ _ f H = @inverse _ _ _ _ f H' := inverse_eq_intro_left !inverse_compose @@ -92,10 +92,10 @@ namespace morphism theorem section_of_id : section_of (ID a) = id := section_eq_intro !id_compose - theorem iso_of_id [H : is_iso (ID a)] : (ID a)⁻¹ = id := + theorem id_inverse [H : is_iso (ID a)] : (ID a)⁻¹ = id := inverse_eq_intro_left !id_compose - theorem composition_is_section [instance] [Hf : is_section f] [Hg : is_section g] + theorem is_section_comp [instance] [Hf : is_section f] [Hg : is_section g] : is_section (g ∘ f) := have aux : retraction_of g ∘ g ∘ f = (retraction_of g ∘ g) ∘ f, from !assoc, @@ -108,7 +108,7 @@ namespace morphism ... = retraction_of f ∘ f : {id_left f} ... = id : retraction_compose f) - theorem composition_is_retraction [instance] (Hf : is_retraction f) (Hg : is_retraction g) + theorem is_retraction_comp [instance] (Hf : is_retraction f) (Hg : is_retraction g) : is_retraction (g ∘ f) := have aux : f ∘ section_of f ∘ section_of g = (f ∘ section_of f) ∘ section_of g, from !assoc, @@ -121,20 +121,18 @@ namespace morphism ... = g ∘ section_of g : {id_left (section_of g)} ... = id : compose_section) - theorem composition_is_inverse [instance] (Hf : is_iso f) (Hg : is_iso g) : is_iso (g ∘ f) := - !section_retraction_imp_iso + theorem is_inverse_comp [instance] (Hf : is_iso f) (Hg : is_iso g) : is_iso (g ∘ f) := + !is_iso_of_is_retraction_of_is_section structure isomorphic (a b : ob) := (iso : hom a b) [is_iso : is_iso iso] infix `≅`:50 := morphism.isomorphic + attribute isomorphic.is_iso [instance] namespace isomorphic - -- openrelation - attribute is_iso [instance] - definition refl (a : ob) : a ≅ a := mk id @@ -144,8 +142,6 @@ namespace morphism definition trans ⦃a b c : ob⦄ (H1 : a ≅ b) (H2 : b ≅ c) : a ≅ c := mk (iso H2 ∘ iso H1) - --theorem is_equivalence_eq [instance] (T : Type) : is_equivalence isomorphic := - --is_equivalence.mk (is_reflexive.mk refl) (is_symmetric.mk symm) (is_transitive.mk trans) end isomorphic inductive is_mono [class] (f : a ⟶ b) : Type := @@ -153,12 +149,12 @@ namespace morphism inductive is_epi [class] (f : a ⟶ b) : Type := mk : (∀c (g h : hom b c), g ∘ f = h ∘ f → g = h) → is_epi f - theorem mono_elim [H : is_mono f] {g h : c ⟶ a} (H2 : f ∘ g = f ∘ h) : g = h + theorem is_mono.elim [H : is_mono f] {g h : c ⟶ a} (H2 : f ∘ g = f ∘ h) : g = h := is_mono.rec (λH3, H3 c g h H2) H - theorem epi_elim [H : is_epi f] {g h : b ⟶ c} (H2 : g ∘ f = h ∘ f) : g = h + theorem is_epi.elim [H : is_epi f] {g h : b ⟶ c} (H2 : g ∘ f = h ∘ f) : g = h := is_epi.rec (λH3, H3 c g h H2) H - theorem section_is_mono [instance] (f : a ⟶ b) [H : is_section f] : is_mono f := + theorem is_mono_of_is_section [instance] (f : a ⟶ b) [H : is_section f] : is_mono f := is_mono.mk (λ c g h H, calc @@ -170,7 +166,7 @@ namespace morphism ... = id ∘ h : retraction_compose f ... = h : id_left) - theorem retraction_is_epi [instance] (f : a ⟶ b) [H : is_retraction f] : is_epi f := + theorem is_epi_of_is_retraction [instance] (f : a ⟶ b) [H : is_retraction f] : is_epi f := is_epi.mk (λ c g h H, calc @@ -182,28 +178,24 @@ namespace morphism ... = h ∘ id : compose_section f ... = h : id_right) - --these theorems are now proven automatically using type classes - --should they be instances? - theorem id_is_mono : is_mono (ID a) - theorem id_is_epi : is_epi (ID a) - - theorem composition_is_mono [instance] [Hf : is_mono f] [Hg : is_mono g] : is_mono (g ∘ f) := + theorem is_mono_comp [instance] [Hf : is_mono f] [Hg : is_mono g] : is_mono (g ∘ f) := is_mono.mk (λ d h₁ h₂ H, have H2 : g ∘ (f ∘ h₁) = g ∘ (f ∘ h₂), from calc g ∘ (f ∘ h₁) = (g ∘ f) ∘ h₁ : !assoc ... = (g ∘ f) ∘ h₂ : H - ... = g ∘ (f ∘ h₂) : !assoc, mono_elim (mono_elim H2)) + ... = g ∘ (f ∘ h₂) : !assoc, is_mono.elim (is_mono.elim H2)) - theorem composition_is_epi [instance] [Hf : is_epi f] [Hg : is_epi g] : is_epi (g ∘ f) := + theorem is_epi_comp [instance] [Hf : is_epi f] [Hg : is_epi g] : is_epi (g ∘ f) := is_epi.mk (λ d h₁ h₂ H, have H2 : (h₁ ∘ g) ∘ f = (h₂ ∘ g) ∘ f, from calc (h₁ ∘ g) ∘ f = h₁ ∘ g ∘ f : !assoc ... = h₂ ∘ g ∘ f : H - ... = (h₂ ∘ g) ∘ f: !assoc, epi_elim (epi_elim H2)) + ... = (h₂ ∘ g) ∘ f: !assoc, is_epi.elim (is_epi.elim H2)) end morphism + namespace morphism --rewrite lemmas for inverses, modified from --https://github.com/JasonGross/HoTT-categories/blob/master/theories/Categories/Category/Morphisms.v @@ -237,7 +229,7 @@ namespace morphism ... = f ∘ id : inverse_compose q ... = f : id_right f - theorem inv_pp [H' : is_iso p] [Hpq : is_iso (q ∘ p)] : (q ∘ p)⁻¹ = p⁻¹ ∘ q⁻¹ := + theorem con_inv [H' : is_iso p] [Hpq : is_iso (q ∘ p)] : (q ∘ p)⁻¹ = p⁻¹ ∘ q⁻¹ := have H1 : (p⁻¹ ∘ q⁻¹) ∘ q ∘ p = p⁻¹ ∘ (q⁻¹ ∘ (q ∘ p)), from assoc (p⁻¹) (q⁻¹) (q ∘ p)⁻¹, have H2 : (p⁻¹) ∘ (q⁻¹ ∘ (q ∘ p)) = p⁻¹ ∘ p, from ap _ (compose_V_pp q p), have H3 : p⁻¹ ∘ p = id, from inverse_compose p, @@ -249,14 +241,14 @@ namespace morphism -- (p⁻¹ ∘ (q⁻¹)) ∘ q ∘ p = p⁻¹ ∘ (q⁻¹ ∘ (q ∘ p)) : assoc (p⁻¹) (q⁻¹) (q ∘ p)⁻¹ -- ... = (p⁻¹) ∘ p : congr_arg (λx, p⁻¹ ∘ x) (compose_V_pp q p) -- ... = id : inverse_compose p) - theorem inv_Vp [H' : is_iso g] : (q⁻¹ ∘ g)⁻¹ = g⁻¹ ∘ q := - inverse_involutive q ▹ inv_pp (q⁻¹) g + theorem inv_con_inv_left [H' : is_iso g] : (q⁻¹ ∘ g)⁻¹ = g⁻¹ ∘ q := + inverse_involutive q ▹ con_inv (q⁻¹) g - theorem inv_pV [H' : is_iso f] : (q ∘ f⁻¹)⁻¹ = f ∘ q⁻¹ := - inverse_involutive f ▹ inv_pp q (f⁻¹) + theorem inv_con_inv_right [H' : is_iso f] : (q ∘ f⁻¹)⁻¹ = f ∘ q⁻¹ := + inverse_involutive f ▹ con_inv q (f⁻¹) - theorem inv_VV [H' : is_iso r] : (q⁻¹ ∘ r⁻¹)⁻¹ = r ∘ q := - inverse_involutive r ▹ inv_Vp q (r⁻¹) + theorem inv_con_inv_inv [H' : is_iso r] : (q⁻¹ ∘ r⁻¹)⁻¹ = r ∘ q := + inverse_involutive r ▹ inv_con_inv_left q (r⁻¹) end section @@ -269,22 +261,22 @@ namespace morphism {y : d ⟶ b} {w : c ⟶ a} variable [Hq : is_iso q] include Hq - theorem moveR_Mp (H : y = q⁻¹ ∘ g) : q ∘ y = g := H⁻¹ ▹ compose_p_Vp q g - theorem moveR_pM (H : w = f ∘ q⁻¹) : w ∘ q = f := H⁻¹ ▹ compose_pV_p f q - theorem moveR_Vp (H : z = q ∘ p) : q⁻¹ ∘ z = p := H⁻¹ ▹ compose_V_pp q p - theorem moveR_pV (H : x = r ∘ q) : x ∘ q⁻¹ = r := H⁻¹ ▹ compose_pp_V r q - theorem moveL_Mp (H : q⁻¹ ∘ g = y) : g = q ∘ y := moveR_Mp (H⁻¹)⁻¹ - theorem moveL_pM (H : f ∘ q⁻¹ = w) : f = w ∘ q := moveR_pM (H⁻¹)⁻¹ - theorem moveL_Vp (H : q ∘ p = z) : p = q⁻¹ ∘ z := moveR_Vp (H⁻¹)⁻¹ - theorem moveL_pV (H : r ∘ q = x) : r = x ∘ q⁻¹ := moveR_pV (H⁻¹)⁻¹ - theorem moveL_1V (H : h ∘ q = id) : h = q⁻¹ := inverse_eq_intro_left H⁻¹ - theorem moveL_V1 (H : q ∘ h = id) : h = q⁻¹ := inverse_eq_intro_right H⁻¹ - theorem moveL_1M (H : i ∘ q⁻¹ = id) : i = q := moveL_1V H ⬝ inverse_involutive q - theorem moveL_M1 (H : q⁻¹ ∘ i = id) : i = q := moveL_V1 H ⬝ inverse_involutive q - theorem moveR_1M (H : id = i ∘ q⁻¹) : q = i := moveL_1M (H⁻¹)⁻¹ - theorem moveR_M1 (H : id = q⁻¹ ∘ i) : q = i := moveL_M1 (H⁻¹)⁻¹ - theorem moveR_1V (H : id = h ∘ q) : q⁻¹ = h := moveL_1V (H⁻¹)⁻¹ - theorem moveR_V1 (H : id = q ∘ h) : q⁻¹ = h := moveL_V1 (H⁻¹)⁻¹ + theorem con_eq_of_eq_inv_con (H : y = q⁻¹ ∘ g) : q ∘ y = g := H⁻¹ ▹ compose_p_Vp q g + theorem con_eq_of_eq_con_inv (H : w = f ∘ q⁻¹) : w ∘ q = f := H⁻¹ ▹ compose_pV_p f q + theorem inv_con_eq_of_eq_con (H : z = q ∘ p) : q⁻¹ ∘ z = p := H⁻¹ ▹ compose_V_pp q p + theorem con_inv_eq_of_eq_con (H : x = r ∘ q) : x ∘ q⁻¹ = r := H⁻¹ ▹ compose_pp_V r q + theorem eq_con_of_inv_con_eq (H : q⁻¹ ∘ g = y) : g = q ∘ y := con_eq_of_eq_inv_con (H⁻¹)⁻¹ + theorem eq_con_of_con_inv_eq (H : f ∘ q⁻¹ = w) : f = w ∘ q := con_eq_of_eq_con_inv (H⁻¹)⁻¹ + theorem eq_inv_con_of_con_eq (H : q ∘ p = z) : p = q⁻¹ ∘ z := inv_con_eq_of_eq_con (H⁻¹)⁻¹ + theorem eq_con_inv_of_con_eq (H : r ∘ q = x) : r = x ∘ q⁻¹ := con_inv_eq_of_eq_con (H⁻¹)⁻¹ + theorem eq_inv_of_con_eq_idp' (H : h ∘ q = id) : h = q⁻¹ := inverse_eq_intro_left H⁻¹ + theorem eq_inv_of_con_eq_idp (H : q ∘ h = id) : h = q⁻¹ := inverse_eq_intro_right H⁻¹ + theorem eq_of_con_inv_eq_idp (H : i ∘ q⁻¹ = id) : i = q := eq_inv_of_con_eq_idp' H ⬝ inverse_involutive q + theorem eq_of_inv_con_eq_idp (H : q⁻¹ ∘ i = id) : i = q := eq_inv_of_con_eq_idp H ⬝ inverse_involutive q + theorem eq_of_idp_eq_con_inv (H : id = i ∘ q⁻¹) : q = i := eq_of_con_inv_eq_idp (H⁻¹)⁻¹ + theorem eq_of_idp_eq_inv_con (H : id = q⁻¹ ∘ i) : q = i := eq_of_inv_con_eq_idp (H⁻¹)⁻¹ + theorem inv_eq_of_idp_eq_con (H : id = h ∘ q) : q⁻¹ = h := eq_inv_of_con_eq_idp' (H⁻¹)⁻¹ + theorem inv_eq_of_idp_eq_con' (H : id = q ∘ h) : q⁻¹ = h := eq_inv_of_con_eq_idp (H⁻¹)⁻¹ end end iso diff --git a/hott/algebra/precategory/natural_transformation.hlean b/hott/algebra/precategory/nat_trans.hlean similarity index 55% rename from hott/algebra/precategory/natural_transformation.hlean rename to hott/algebra/precategory/nat_trans.hlean index 5af8fa6e10..9eecc007b7 100644 --- a/hott/algebra/precategory/natural_transformation.hlean +++ b/hott/algebra/precategory/nat_trans.hlean @@ -2,27 +2,27 @@ -- Released under Apache 2.0 license as described in the file LICENSE. -- Author: Floris van Doorn, Jakob von Raumer -import .functor types.pi -open eq precategory functor truncation equiv sigma.ops sigma is_equiv function pi +import .functor +open eq precategory functor is_trunc equiv sigma.ops sigma is_equiv function pi -inductive natural_transformation {C D : Precategory} (F G : C ⇒ D) : Type := +inductive nat_trans {C D : Precategory} (F G : C ⇒ D) : Type := mk : Π (η : Π (a : C), hom (F a) (G a)) (nat : Π {a b : C} (f : hom a b), G f ∘ η a = η b ∘ F f), - natural_transformation F G + nat_trans F G -infixl `⟹`:25 := natural_transformation -- \==> +infixl `⟹`:25 := nat_trans -- \==> -namespace natural_transformation +namespace nat_trans variables {C D : Precategory} {F G H I : functor C D} definition natural_map [coercion] (η : F ⟹ G) : Π (a : C), F a ⟶ G a := - natural_transformation.rec (λ x y, x) η + nat_trans.rec (λ x y, x) η theorem naturality (η : F ⟹ G) : Π⦃a b : C⦄ (f : a ⟶ b), G f ∘ η a = η b ∘ F f := - natural_transformation.rec (λ x y, y) η + nat_trans.rec (λ x y, y) η protected definition compose (η : G ⟹ H) (θ : F ⟹ G) : F ⟹ H := - natural_transformation.mk + nat_trans.mk (λ a, η a ∘ θ a) (λ a b f, calc @@ -41,10 +41,10 @@ namespace natural_transformation (nat₁ : Π (a b : C) (f : hom a b), G f ∘ η₁ a = η₁ b ∘ F f) (nat₂ : Π (a b : C) (f : hom a b), G f ∘ η₂ a = η₂ b ∘ F f) (p₁ : η₁ = η₂) (p₂ : p₁ ▹ nat₁ = nat₂) - : @natural_transformation.mk C D F G η₁ nat₁ = @natural_transformation.mk C D F G η₂ nat₂ + : @nat_trans.mk C D F G η₁ nat₁ = @nat_trans.mk C D F G η₂ nat₂ := begin - apply (dcongr_arg2 (@natural_transformation.mk C D F G) p₁ p₂), + apply (apD011 (@nat_trans.mk C D F G) p₁ p₂), end set_option apply.class_instance false -- disable class instance resolution in the apply tactic @@ -52,45 +52,45 @@ namespace natural_transformation protected definition assoc (η₃ : H ⟹ I) (η₂ : G ⟹ H) (η₁ : F ⟹ G) : η₃ ∘n (η₂ ∘n η₁) = (η₃ ∘n η₂) ∘n η₁ := begin - apply (natural_transformation.rec_on η₃), intros (η₃1, η₃2), - apply (natural_transformation.rec_on η₂), intros (η₂1, η₂2), - apply (natural_transformation.rec_on η₁), intros (η₁1, η₁2), - fapply natural_transformation.congr, - apply funext.path_pi, intro a, + apply (nat_trans.rec_on η₃), intros (η₃1, η₃2), + apply (nat_trans.rec_on η₂), intros (η₂1, η₂2), + apply (nat_trans.rec_on η₁), intros (η₁1, η₁2), + fapply nat_trans.congr, + apply funext.eq_of_homotopy, intro a, apply assoc, - apply funext.path_pi, intro a, - apply funext.path_pi, intro b, - apply funext.path_pi, intro f, + apply funext.eq_of_homotopy, intro a, + apply funext.eq_of_homotopy, intro b, + apply funext.eq_of_homotopy, intro f, apply (@is_hset.elim), apply !homH, end - protected definition id {C D : Precategory} {F : functor C D} : natural_transformation F F := + protected definition id {C D : Precategory} {F : functor C D} : nat_trans F F := mk (λa, id) (λa b f, !id_right ⬝ (!id_left⁻¹)) - protected definition ID {C D : Precategory} (F : functor C D) : natural_transformation F F := + protected definition ID {C D : Precategory} (F : functor C D) : nat_trans F F := id protected definition id_left (η : F ⟹ G) : id ∘n η = η := begin - apply (natural_transformation.rec_on η), intros (η₁, nat₁), - fapply (natural_transformation.congr F G), - apply funext.path_pi, intro a, + apply (nat_trans.rec_on η), intros (η₁, nat₁), + fapply (nat_trans.congr F G), + apply funext.eq_of_homotopy, intro a, apply id_left, - apply funext.path_pi, intro a, - apply funext.path_pi, intro b, - apply funext.path_pi, intro f, + apply funext.eq_of_homotopy, intro a, + apply funext.eq_of_homotopy, intro b, + apply funext.eq_of_homotopy, intro f, apply (@is_hset.elim), apply !homH, end protected definition id_right (η : F ⟹ G) : η ∘n id = η := begin - apply (natural_transformation.rec_on η), intros (η₁, nat₁), - fapply (natural_transformation.congr F G), - apply funext.path_pi, intro a, + apply (nat_trans.rec_on η), intros (η₁, nat₁), + fapply (nat_trans.congr F G), + apply funext.eq_of_homotopy, intro a, apply id_right, - apply funext.path_pi, intro a, - apply funext.path_pi, intro b, - apply funext.path_pi, intro f, + apply funext.eq_of_homotopy, intro a, + apply funext.eq_of_homotopy, intro b, + apply funext.eq_of_homotopy, intro f, apply (@is_hset.elim), apply !homH, end @@ -99,34 +99,34 @@ namespace natural_transformation (Σ (η : Π (a : C), hom (F a) (G a)), Π (a b : C) (f : hom a b), G f ∘ η a = η b ∘ F f) ≃ (F ⟹ G) := begin fapply equiv.mk, - intro S, apply natural_transformation.mk, exact (S.2), + intro S, apply nat_trans.mk, exact (S.2), fapply adjointify, intro H, fapply sigma.mk, intro a, exact (H a), intros (a, b, f), exact (naturality H f), - intro H, apply (natural_transformation.rec_on H), + intro H, apply (nat_trans.rec_on H), intros (eta, nat), unfold function.id, - fapply natural_transformation.congr, + fapply nat_trans.congr, apply idp, - repeat ( apply funext.path_pi ; intro a ), + repeat ( apply funext.eq_of_homotopy ; intro a ), apply (@is_hset.elim), apply !homH, intro S, - fapply sigma.path, - apply funext.path_pi, intro a, + fapply sigma_eq, + apply funext.eq_of_homotopy, intro a, apply idp, - repeat ( apply funext.path_pi ; intro a ), + repeat ( apply funext.eq_of_homotopy ; intro a ), apply (@is_hset.elim), apply !homH, end protected definition to_hset : is_hset (F ⟹ G) := begin - apply trunc_equiv, apply (equiv.to_is_equiv !sigma_char), - apply trunc_sigma, - apply trunc_pi, intro a, exact (@homH (objects D) _ (F a) (G a)), - intro η, apply trunc_pi, intro a, - apply trunc_pi, intro b, apply trunc_pi, intro f, - apply succ_is_trunc, apply trunc_succ, exact (@homH (objects D) _ (F a) (G b)), + apply is_trunc_is_equiv_closed, apply (equiv.to_is_equiv !sigma_char), + apply is_trunc_sigma, + apply is_trunc_pi, intro a, exact (@homH (objects D) _ (F a) (G a)), + intro η, apply is_trunc_pi, intro a, + apply is_trunc_pi, intro b, apply is_trunc_pi, intro f, + apply is_trunc_eq, apply is_trunc_succ, exact (@homH (objects D) _ (F a) (G b)), end -end natural_transformation +end nat_trans diff --git a/hott/algebra/precategory/yoneda.hlean b/hott/algebra/precategory/yoneda.hlean new file mode 100644 index 0000000000..733678e212 --- /dev/null +++ b/hott/algebra/precategory/yoneda.hlean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Module: algebra.precategory.yoneda +Author: Floris van Doorn +-/ + +--note: modify definition in category.set +import .constructions .morphism + +open eq precategory equiv is_equiv is_trunc +open is_trunc.trunctype funext precategory.ops prod.ops + +set_option pp.beta true + +namespace yoneda + definition representable_functor_assoc [C : Precategory] {a1 a2 a3 a4 a5 a6 : C} (f1 : a5 ⟶ a6) (f2 : a4 ⟶ a5) (f3 : a3 ⟶ a4) (f4 : a2 ⟶ a3) (f5 : a1 ⟶ a2) : (f1 ∘ f2) ∘ f3 ∘ (f4 ∘ f5) = f1 ∘ (f2 ∘ f3 ∘ f4) ∘ f5 := + calc + (f1 ∘ f2) ∘ f3 ∘ f4 ∘ f5 = f1 ∘ f2 ∘ f3 ∘ f4 ∘ f5 : assoc + ... = f1 ∘ (f2 ∘ f3) ∘ f4 ∘ f5 : assoc + ... = f1 ∘ ((f2 ∘ f3) ∘ f4) ∘ f5 : assoc + ... = f1 ∘ (f2 ∘ f3 ∘ f4) ∘ f5 : assoc + + --disturbing behaviour: giving the type of f "(x ⟶ y)" explicitly makes the unifier loop + definition representable_functor (C : Precategory) : Cᵒᵖ ×c C ⇒ set := + functor.mk (λ(x : Cᵒᵖ ×c C), homset x.1 x.2) + (λ(x y : Cᵒᵖ ×c C) (f : _) (h : homset x.1 x.2), f.2 ∘⁅ C ⁆ (h ∘⁅ C ⁆ f.1)) + proof (λ(x : Cᵒᵖ ×c C), eq_of_homotopy (λ(h : homset x.1 x.2), !id_left ⬝ !id_right)) qed + -- (λ(x y z : Cᵒᵖ ×c C) (g : y ⟶ z) (f : x ⟶ y), eq_of_homotopy (λ(h : hom x.1 x.2), representable_functor_assoc g.2 f.2 h f.1 g.1)) + begin + intros (x, y, z, g, f), apply eq_of_homotopy, intro h, + exact (representable_functor_assoc g.2 f.2 h f.1 g.1), + end +end yoneda + +attribute precategory_functor [instance] [reducible] +namespace nat_trans + open morphism functor + variables {C D : Precategory} {F G : C ⇒ D} (η : F ⟹ G) (H : Π(a : C), is_iso (η a)) + include H + definition nat_trans_inverse : G ⟹ F := + nat_trans.mk + (λc, (η c)⁻¹) + (λc d f, + begin + apply iso.con_inv_eq_of_eq_con, + apply concat, rotate_left 1, apply assoc, + apply iso.eq_inv_con_of_con_eq, + apply inverse, + apply naturality, + end) + + definition nat_trans_left_inverse : nat_trans_inverse η H ∘ η = nat_trans.id := + begin + fapply (apD011 nat_trans.mk), + apply eq_of_homotopy, intro c, apply inverse_compose, + apply eq_of_homotopy, intros, apply eq_of_homotopy, intros, apply eq_of_homotopy, intros, fapply is_hset.elim + end + + definition nat_trans_right_inverse : η ∘ nat_trans_inverse η H = nat_trans.id := + begin + fapply (apD011 nat_trans.mk), + apply eq_of_homotopy, intro c, apply compose_inverse, + apply eq_of_homotopy, intros, apply eq_of_homotopy, intros, apply eq_of_homotopy, intros, fapply is_hset.elim + end + + definition nat_trans_is_iso.mk : is_iso η := + is_iso.mk (nat_trans_left_inverse η H) (nat_trans_right_inverse η H) + +end nat_trans + +-- Coq uses unit/counit definitions as basic + +-- open yoneda precategory.product precategory.opposite functor morphism +-- --universe levels are given explicitly because Lean uses 6 variables otherwise + +-- structure adjoint.{u v} [C D : Precategory.{u v}] (F : C ⇒ D) (G : D ⇒ C) : Type.{max u v} := +-- (nat_iso : (representable_functor D) ∘f (prod_functor (opposite_functor F) (functor.ID D)) ⟹ +-- (representable_functor C) ∘f (prod_functor (functor.ID (Cᵒᵖ)) G)) +-- (is_iso_nat_iso : is_iso nat_iso) + +-- infix `⊣`:55 := adjoint + +-- namespace adjoint +-- universe variables l1 l2 +-- variables [C D : Precategory.{l1 l2}] (F : C ⇒ D) (G : D ⇒ C) + + + +-- end adjoint diff --git a/hott/default.hlean b/hott/default.hlean deleted file mode 100644 index d6dda5b5cf..0000000000 --- a/hott/default.hlean +++ /dev/null @@ -1,8 +0,0 @@ --- Copyright (c) 2014 Jeremy Avigad. All rights reserved. --- Released under Apache 2.0 license as described in the file LICENSE. --- Author: Jeremy Avigad, Jakob von Raumer - --- hott.default --- ============ - --- A library for homotopy type theory diff --git a/hott/equiv_precomp.hlean b/hott/equiv_precomp.hlean index 067dae56f9..cc3ded13dc 100644 --- a/hott/equiv_precomp.hlean +++ b/hott/equiv_precomp.hlean @@ -1,60 +1,65 @@ --- Copyright (c) 2014 Jakob von Raumer. All rights reserved. --- Released under Apache 2.0 license as described in the file LICENSE. --- Author: Jakob von Raumer --- Ported from Coq HoTT +/- +Copyright (c) 2014 Jakob von Raumer. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Module: equiv_precomp +Author: Jakob von Raumer + +Ported from Coq HoTT +-/ +exit open eq function funext namespace is_equiv context --Precomposition of arbitrary functions with f - definition precomp {A B : Type} (f : A → B) (C : Type) (h : B → C) : A → C := h ∘ f + definition precompose {A B : Type} (f : A → B) (C : Type) (h : B → C) : A → C := h ∘ f --Postcomposition of arbitrary functions with f - definition postcomp {A B : Type} (f : A → B) (C : Type) (l : C → A) : C → B := f ∘ l + definition postcompose {A B : Type} (f : A → B) (C : Type) (l : C → A) : C → B := f ∘ l --Precomposing with an equivalence is an equivalence - definition precomp_closed [instance] {A B : Type} (f : A → B) [F : funext] [Hf : is_equiv f] (C : Type) - : is_equiv (precomp f C) := - adjointify (precomp f C) (λh, h ∘ f⁻¹) - (λh, path_pi (λx, ap h (sect f x))) - (λg, path_pi (λy, ap g (retr f y))) + definition arrow_equiv_arrow_of_equiv_dom [instance] {A B : Type} (f : A → B) [F : funext] [Hf : is_equiv f] (C : Type) + : is_equiv (precompose f C) := + adjointify (precompose f C) (λh, h ∘ f⁻¹) + (λh, eq_of_homotopy (λx, ap h (sect f x))) + (λg, eq_of_homotopy (λy, ap g (retr f y))) --Postcomposing with an equivalence is an equivalence - definition postcomp_closed [instance] {A B : Type} (f : A → B) [F : funext] [Hf : is_equiv f] (C : Type) - : is_equiv (postcomp f C) := - adjointify (postcomp f C) (λl, f⁻¹ ∘ l) - (λh, path_pi (λx, retr f (h x))) - (λg, path_pi (λy, sect f (g y))) + definition arrow_equiv_arrow_of_equiv_cod [instance] {A B : Type} (f : A → B) [F : funext] [Hf : is_equiv f] (C : Type) + : is_equiv (postcompose f C) := + adjointify (postcompose f C) (λl, f⁻¹ ∘ l) + (λh, eq_of_homotopy (λx, retr f (h x))) + (λg, eq_of_homotopy (λy, sect f (g y))) --Conversely, if pre- or post-composing with a function is always an equivalence, --then that function is also an equivalence. It's convenient to know --that we only need to assume the equivalence when the other type is --the domain or the codomain. - protected definition isequiv_precompose_eq {A B : Type} (f : A → B) (C D : Type) - (Ceq : is_equiv (precomp f C)) (Deq : is_equiv (precomp f D)) (k : C → D) (h : A → C) : - k ∘ (inv (precomp f C)) h = (inv (precomp f D)) (k ∘ h) := - let invD := inv (precomp f D) in - let invC := inv (precomp f C) in + private definition isequiv_precompose_eq {A B : Type} (f : A → B) (C D : Type) + (Ceq : is_equiv (precompose f C)) (Deq : is_equiv (precompose f D)) (k : C → D) (h : A → C) : + k ∘ (precompose f C)⁻¹ h = (precompose f D)⁻¹ (k ∘ h) := + let invD := inv (precompose f D) in + let invC := inv (precompose f C) in have eq1 : invD (k ∘ h) = k ∘ (invC h), - from calc invD (k ∘ h) = invD (k ∘ (precomp f C (invC h))) : retr (precomp f C) h + from calc invD (k ∘ h) = invD (k ∘ (precompose f C (invC h))) : retr (precompose f C) h ... = k ∘ (invC h) : !sect, eq1⁻¹ - definition from_isequiv_precomp {A B : Type} (f : A → B) (Aeq : is_equiv (precomp f A)) - (Beq : is_equiv (precomp f B)) : (is_equiv f) := - let invA := inv (precomp f A) in - let invB := inv (precomp f B) in + definition is_equiv_of_is_equiv_precomp {A B : Type} (f : A → B) (Aeq : is_equiv (precompose f A)) + (Beq : is_equiv (precompose f B)) : (is_equiv f) := + let invA := inv (precompose f A) in + let invB := inv (precompose f B) in let sect' : f ∘ (invA id) ∼ id := (λx, calc f (invA id x) = (f ∘ invA id) x : idp ... = invB (f ∘ id) x : apD10 (!isequiv_precompose_eq) - ... = invB (precomp f B id) x : idp - ... = x : apD10 (sect (precomp f B) id)) + ... = invB (precompose f B id) x : idp + ... = x : apD10 (sect (precompose f B) id)) in let retr' : (invA id) ∘ f ∼ id := (λx, - calc invA id (f x) = precomp f A (invA id) x : idp - ... = x : apD10 (retr (precomp f A) id)) in + calc invA id (f x) = precompose f A (invA id) x : idp + ... = x : apD10 (retr (precompose f A) id)) in adjointify f (invA id) sect' retr' end @@ -64,18 +69,18 @@ end is_equiv --Bundled versions of the previous theorems namespace equiv - definition precomp_closed [F : funext] {A B C : Type} {eqf : A ≃ B} + definition arrow_equiv_arrow_of_equiv_dom [F : funext] {A B C : Type} {eqf : A ≃ B} : (B → C) ≃ (A → C) := let f := to_fun eqf in let Hf := to_is_equiv eqf in - equiv.mk (is_equiv.precomp f C) - (@is_equiv.precomp_closed A B f F Hf C) + equiv.mk (is_equiv.precompose f C) + (@is_equiv.arrow_equiv_arrow_of_equiv_dom A B f F Hf C) - definition postcomp_closed [F : funext] {A B C : Type} {eqf : A ≃ B} + definition arrow_equiv_arrow_of_equiv_cod [F : funext] {A B C : Type} {eqf : A ≃ B} : (C → A) ≃ (C → B) := let f := to_fun eqf in let Hf := to_is_equiv eqf in - equiv.mk (is_equiv.postcomp f C) - (@is_equiv.postcomp_closed A B f F Hf C) + equiv.mk (is_equiv.postcompose f C) + (@is_equiv.arrow_equiv_arrow_of_equiv_cod A B f F Hf C) end equiv diff --git a/hott/init/axioms/funext.hlean b/hott/init/axioms/funext.hlean index d5c68242d2..a108450bde 100644 --- a/hott/init/axioms/funext.hlean +++ b/hott/init/axioms/funext.hlean @@ -10,25 +10,19 @@ open eq -- ------ -- Define function extensionality as a type class -inductive funext [class] : Type := - mk : (Π (A : Type) (P : A → Type ) (f g : Π x, P x), is_equiv (@apD10 A P f g)) - → funext +structure funext [class] : Type := +(elim : Π (A : Type) (P : A → Type ) (f g : Π x, P x), is_equiv (@apD10 A P f g)) + namespace funext - universe variables l k - variables [F : funext.{l k}] {A : Type.{l}} {P : A → Type.{k}} + attribute elim [instance] - include F - protected definition ap [instance] (f g : Π x, P x) : is_equiv (@apD10 A P f g) := - funext.rec_on F (λ(H : Π A P f g, _), !H) - - definition path_pi {f g : Π x, P x} : f ∼ g → f = g := + definition eq_of_homotopy [F : funext] {A : Type} {P : A → Type} {f g : Π x, P x} : f ∼ g → f = g := is_equiv.inv (@apD10 A P f g) - omit F - definition path_pi2 [F : funext] {A B : Type} {P : A → B → Type} + definition eq_of_homotopy2 [F : funext] {A B : Type} {P : A → B → Type} (f g : Πx y, P x y) : (Πx y, f x y = g x y) → f = g := - λ E, path_pi (λx, path_pi (E x)) + λ E, eq_of_homotopy (λx, eq_of_homotopy (E x)) end funext diff --git a/hott/init/axioms/funext_from_ua.hlean b/hott/init/axioms/funext_of_ua.hlean similarity index 79% rename from hott/init/axioms/funext_from_ua.hlean rename to hott/init/axioms/funext_of_ua.hlean index 973941e09c..0fd5278ccb 100644 --- a/hott/init/axioms/funext_from_ua.hlean +++ b/hott/init/axioms/funext_of_ua.hlean @@ -6,28 +6,28 @@ prelude import ..equiv ..datatypes ..types.prod import .funext_varieties .ua .funext -open eq function prod sigma truncation equiv is_equiv unit +open eq function prod is_trunc sigma equiv is_equiv unit context universe variables l - protected theorem ua_isequiv_postcompose {A B : Type.{l}} {C : Type} - {w : A → B} {H0 : is_equiv w} : is_equiv (@compose C A B w) := + private theorem ua_isequiv_postcompose {A B : Type.{l}} {C : Type} + {w : A → B} [H0 : is_equiv w] : is_equiv (@compose C A B w) := let w' := equiv.mk w H0 in - let eqinv : A = B := ((@is_equiv.inv _ _ _ (ua_is_equiv A B)) w') in - let eq' := equiv_path eqinv in + let eqinv : A = B := ((@is_equiv.inv _ _ _ (univalence A B)) w') in + let eq' := equiv_of_eq eqinv in is_equiv.adjointify (@compose C A B w) (@compose C B A (is_equiv.inv w)) (λ (x : C → B), have eqretr : eq' = w', - from (@retr _ _ (@equiv_path A B) (ua_is_equiv A B) w'), + from (@retr _ _ (@equiv_of_eq A B) (univalence A B) w'), have invs_eq : (to_fun eq')⁻¹ = (to_fun w')⁻¹, from inv_eq eq' w' eqretr, have eqfin : (to_fun eq') ∘ ((to_fun eq')⁻¹ ∘ x) = x, from (λ p, (@eq.rec_on Type.{l} A - (λ B' p', Π (x' : C → B'), (to_fun (equiv_path p')) - ∘ ((to_fun (equiv_path p'))⁻¹ ∘ x') = x') + (λ B' p', Π (x' : C → B'), (to_fun (equiv_of_eq p')) + ∘ ((to_fun (equiv_of_eq p'))⁻¹ ∘ x') = x') B p (λ x', idp)) ) eqinv x, have eqfin' : (to_fun w') ∘ ((to_fun eq')⁻¹ ∘ x) = x, @@ -38,7 +38,7 @@ context ) (λ (x : C → A), have eqretr : eq' = w', - from (@retr _ _ (@equiv_path A B) (ua_is_equiv A B) w'), + from (@retr _ _ (@equiv_of_eq A B) (univalence A B) w'), have invs_eq : (to_fun eq')⁻¹ = (to_fun w')⁻¹, from inv_eq eq' w' eqretr, have eqfin : (to_fun eq')⁻¹ ∘ ((to_fun eq') ∘ x) = x, @@ -52,10 +52,10 @@ context -- We are ready to prove functional extensionality, -- starting with the naive non-dependent version. - protected definition diagonal [reducible] (B : Type) : Type + private definition diagonal [reducible] (B : Type) : Type := Σ xy : B × B, pr₁ xy = pr₂ xy - protected definition isequiv_src_compose {A B : Type} + private definition isequiv_src_compose {A B : Type} : @is_equiv (A → diagonal B) (A → B) (compose (pr₁ ∘ pr1)) := @@ -66,7 +66,7 @@ context (λ xy, prod.rec_on xy (λ b c p, eq.rec_on p idp)))) - protected definition isequiv_tgt_compose {A B : Type} + private definition isequiv_tgt_compose {A B : Type} : @is_equiv (A → diagonal B) (A → B) (compose (pr₂ ∘ pr1)) := @@ -86,7 +86,7 @@ context have equiv1 [visible] : is_equiv precomp1, from @isequiv_src_compose A B, have equiv2 [visible] : Π x y, is_equiv (ap precomp1), - from is_equiv.ap_closed precomp1, + from is_equiv.is_equiv_ap precomp1, have H' : Π (x y : A → diagonal B), pr₁ ∘ pr1 ∘ x = pr₁ ∘ pr1 ∘ y → x = y, from (λ x y, is_equiv.inv (ap precomp1)), @@ -103,14 +103,14 @@ end -- Now we use this to prove weak funext, which as we know -- implies (with dependent eta) also the strong dependent funext. -theorem weak_funext_from_ua : weak_funext := +theorem weak_funext_of_ua : weak_funext := (λ (A : Type) (P : A → Type) allcontr, let U := (λ (x : A), unit) in have pequiv : Π (x : A), P x ≃ U x, - from (λ x, @equiv_contr_unit(P x) (allcontr x)), + from (λ x, @equiv_unit_of_is_contr (P x) (allcontr x)), have psim : Π (x : A), P x = U x, from (λ x, @is_equiv.inv _ _ - equiv_path (ua_is_equiv _ _) (pequiv x)), + equiv_of_eq (univalence _ _) (pequiv x)), have p : P = U, from @nondep_funext_from_ua A Type P U psim, have tU' : is_contr (A → unit), @@ -125,5 +125,5 @@ theorem weak_funext_from_ua : weak_funext := ) -- In the following we will proof function extensionality using the univalence axiom -definition funext_from_ua [instance] : funext := - funext_from_weak_funext (@weak_funext_from_ua) +definition funext_of_ua [instance] : funext := + funext_of_weak_funext (@weak_funext_of_ua) diff --git a/hott/init/axioms/funext_varieties.hlean b/hott/init/axioms/funext_varieties.hlean index e4b29b466a..96b3f5cf17 100644 --- a/hott/init/axioms/funext_varieties.hlean +++ b/hott/init/axioms/funext_varieties.hlean @@ -5,7 +5,7 @@ prelude import ..path ..trunc ..equiv .funext -open eq truncation sigma function +open eq is_trunc sigma function /- In hott.axioms.funext, we defined function extensionality to be the assertion that the map apD10 is an equivalence. We now prove that this follows @@ -27,14 +27,9 @@ definition weak_funext := -- The obvious implications are Funext -> NaiveFunext -> WeakFunext -- TODO: Get class inference to work locally definition naive_funext_from_funext [F : funext] : naive_funext := - (λ A P f g h, - have Fefg: is_equiv (@apD10 A P f g), - from (@funext.ap F A P f g), - have eq1 : _, from (@is_equiv.inv _ _ (@apD10 A P f g) Fefg h), - eq1 - ) + (λ A P f g h, funext.eq_of_homotopy h) -definition weak_funext_from_naive_funext : naive_funext → weak_funext := +definition weak_funext_of_naive_funext : naive_funext → weak_funext := (λ nf A P (Pc : Πx, is_contr (P x)), let c := λx, center (P x) in is_contr.mk c (λ f, @@ -55,10 +50,8 @@ context universes l k parameters (wf : weak_funext.{l k}) {A : Type.{l}} {B : A → Type.{k}} (f : Π x, B x) - protected definition idhtpy : f ∼ f := (λ x, idp) - - definition contr_basedhtpy [instance] : is_contr (Σ (g : Π x, B x), f ∼ g) := - is_contr.mk (sigma.mk f idhtpy) + definition is_contr_sigma_homotopy [instance] : is_contr (Σ (g : Π x, B x), f ∼ g) := + is_contr.mk (sigma.mk f (homotopy.refl f)) (λ dp, sigma.rec_on dp (λ (g : Π x, B x) (h : f ∼ g), let r := λ (k : Π x, Σ y, f x = y), @@ -66,47 +59,47 @@ context (λx, pr1 (k x)) (λx, pr2 (k x)) in let s := λ g h x, @sigma.mk _ (λy, f x = y) (g x) (h x) in have t1 : Πx, is_contr (Σ y, f x = y), - from (λx, !contr_basedpaths), + from (λx, !is_contr_sigma_eq), have t2 : is_contr (Πx, Σ y, f x = y), from !wf, have t3 : (λ x, @sigma.mk _ (λ y, f x = y) (f x) idp) = s g h, - from @path_contr (Π x, Σ y, f x = y) t2 _ _, + from @center_eq (Π x, Σ y, f x = y) t2 _ _, have t4 : r (λ x, sigma.mk (f x) idp) = r (s g h), from ap r t3, - have endt : sigma.mk f idhtpy = sigma.mk g h, + have endt : sigma.mk f (homotopy.refl f) = sigma.mk g h, from t4, endt ) ) - parameters (Q : Π g (h : f ∼ g), Type) (d : Q f idhtpy) + parameters (Q : Π g (h : f ∼ g), Type) (d : Q f (homotopy.refl f)) - definition htpy_ind (g : Πx, B x) (h : f ∼ g) : Q g h := - @transport _ (λ gh, Q (pr1 gh) (pr2 gh)) (sigma.mk f idhtpy) (sigma.mk g h) - (@path_contr _ contr_basedhtpy _ _) d + definition homotopy_ind (g : Πx, B x) (h : f ∼ g) : Q g h := + @transport _ (λ gh, Q (pr1 gh) (pr2 gh)) (sigma.mk f (homotopy.refl f)) (sigma.mk g h) + (@center_eq _ is_contr_sigma_homotopy _ _) d - local attribute htpy_ind [reducible] - definition htpy_ind_beta : htpy_ind f idhtpy = d := - (@path2_contr _ _ _ _ !path_contr idp)⁻¹ ▹ idp + local attribute homotopy_ind [reducible] + definition homotopy_ind_comp : homotopy_ind f (homotopy.refl f) = d := + (@hprop_eq _ _ _ _ !center_eq idp)⁻¹ ▹ idp end -- Now the proof is fairly easy; we can just use the same induction principle on both sides. universe variables l k -theorem funext_from_weak_funext (wf : weak_funext.{l k}) : funext.{l k} := +theorem funext_of_weak_funext (wf : weak_funext.{l k}) : funext.{l k} := funext.mk (λ A B f g, let eq_to_f := (λ g' x, f = g') in - let sim2path := htpy_ind _ f eq_to_f idp in - have t1 : sim2path f (idhtpy f) = idp, - proof htpy_ind_beta _ f eq_to_f idp qed, - have t2 : apD10 (sim2path f (idhtpy f)) = (idhtpy f), + let sim2path := homotopy_ind _ f eq_to_f idp in + have t1 : sim2path f (homotopy.refl f) = idp, + proof homotopy_ind_comp _ f eq_to_f idp qed, + have t2 : apD10 (sim2path f (homotopy.refl f)) = (homotopy.refl f), proof ap apD10 t1 qed, have sect : apD10 ∘ (sim2path g) ∼ id, - proof (htpy_ind _ f (λ g' x, apD10 (sim2path g' x) = x) t2) g qed, + proof (homotopy_ind _ f (λ g' x, apD10 (sim2path g' x) = x) t2) g qed, have retr : (sim2path g) ∘ apD10 ∼ id, - from (λ h, eq.rec_on h (htpy_ind_beta _ f _ idp)), + from (λ h, eq.rec_on h (homotopy_ind_comp _ f _ idp)), is_equiv.adjointify apD10 (sim2path g) sect retr) definition funext_from_naive_funext : naive_funext -> funext := - compose funext_from_weak_funext weak_funext_from_naive_funext + compose funext_of_weak_funext weak_funext_of_naive_funext diff --git a/hott/init/axioms/ua.hlean b/hott/init/axioms/ua.hlean index ed8bc55286..9379e5a31b 100644 --- a/hott/init/axioms/ua.hlean +++ b/hott/init/axioms/ua.hlean @@ -4,40 +4,38 @@ -- Ported from Coq HoTT prelude import ..path ..equiv -open eq equiv +open eq equiv is_equiv --Ensure that the types compared are in the same universe section universe variable l variables {A B : Type.{l}} - definition isequiv_path (H : A = B) := - (@is_equiv.transport Type (λX, X) A B H) + definition is_equiv_tr_of_eq (H : A = B) : is_equiv (transport (λX:Type, X) H) := + (@is_equiv_tr Type (λX, X) A B H) - definition equiv_path (H : A = B) : A ≃ B := - equiv.mk _ (isequiv_path H) + definition equiv_of_eq (H : A = B) : A ≃ B := + equiv.mk _ (is_equiv_tr_of_eq H) end -axiom ua_is_equiv (A B : Type) : is_equiv (@equiv_path A B) +axiom univalence (A B : Type) : is_equiv (@equiv_of_eq A B) --- Make the Equivalence given by the axiom an instance -protected definition inst [instance] (A B : Type) : is_equiv (@equiv_path A B) := -ua_is_equiv A B +attribute univalence [instance] -- This is the version of univalence axiom we will probably use most often definition ua {A B : Type} : A ≃ B → A = B := -@is_equiv.inv _ _ (@equiv_path A B) (inst A B) +(@equiv_of_eq A B)⁻¹ -- One consequence of UA is that we can transport along equivalencies of types -namespace Equiv +namespace equiv universe variable l - protected definition subst (P : Type → Type) {A B : Type.{l}} (H : A ≃ B) + protected definition transport_of_equiv (P : Type → Type) {A B : Type.{l}} (H : A ≃ B) : P A → P B := eq.transport P (ua H) -- We can use this for calculation evironments - calc_subst subst + calc_subst transport_of_equiv -end Equiv +end equiv diff --git a/hott/init/bool.hlean b/hott/init/bool.hlean index e24781b79a..38ca46b77c 100644 --- a/hott/init/bool.hlean +++ b/hott/init/bool.hlean @@ -1,6 +1,8 @@ /- Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. + +Module: init.bool Author: Leonardo de Moura -/ prelude diff --git a/hott/init/datatypes.hlean b/hott/init/datatypes.hlean index 68b8e521ef..6a8b2fb939 100644 --- a/hott/init/datatypes.hlean +++ b/hott/init/datatypes.hlean @@ -2,6 +2,7 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Module: init.datatypes Authors: Leonardo de Moura, Jakob von Raumer Basic datatypes diff --git a/hott/init/default.hlean b/hott/init/default.hlean index a0c9b5e745..90835e8c9c 100644 --- a/hott/init/default.hlean +++ b/hott/init/default.hlean @@ -2,6 +2,7 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Module: init.default Authors: Leonardo de Moura, Jakob von Raumer -/ prelude @@ -9,5 +10,5 @@ import init.datatypes init.reserved_notation init.tactic init.logic import init.bool init.num init.priority init.relation init.wf import init.types.sigma init.types.prod init.types.empty import init.trunc init.path init.equiv init.util -import init.axioms.ua init.axioms.funext init.axioms.funext_from_ua +import init.axioms.ua init.axioms.funext init.axioms.funext_of_ua import init.hedberg init.nat diff --git a/hott/init/equiv.hlean b/hott/init/equiv.hlean index 7af8b842ad..bfcd6190f9 100644 --- a/hott/init/equiv.hlean +++ b/hott/init/equiv.hlean @@ -1,13 +1,18 @@ --- Copyright (c) 2014 Microsoft Corporation. All rights reserved. --- Released under Apache 2.0 license as described in the file LICENSE. --- Author: Jeremy Avigad, Jakob von Raumer --- Ported from Coq HoTT +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Module: init.equiv +Author: Jeremy Avigad, Jakob von Raumer + +Ported from Coq HoTT +-/ + prelude import .path .function open eq function --- Equivalences --- ------------ +/- Equivalences -/ -- This is our definition of equivalence. In the HoTT-book it's called -- ihae (half-adjoint equivalence). @@ -18,37 +23,38 @@ structure is_equiv [class] {A B : Type} (f : A → B) := (adj : Πx, retr (f x) = ap f (sect x)) --- A more bundled version of equivalence to calculate with +-- A more bundled version of equivalence structure equiv (A B : Type) := (to_fun : A → B) (to_is_equiv : is_equiv to_fun) - -- Some instances and closure properties of equivalences -namespace is_equiv +namespace is_equiv + /- Some instances and closure properties of equivalences -/ postfix `⁻¹` := inv + section variables {A B C : Type} (f : A → B) (g : B → C) {f' : A → B} -- The identity function is an equivalence. - definition id_is_equiv : (@is_equiv A A id) := is_equiv.mk id (λa, idp) (λa, idp) (λa, idp) + definition is_equiv_id : (@is_equiv A A id) := is_equiv.mk id (λa, idp) (λa, idp) (λa, idp) -- The composition of two equivalences is, again, an equivalence. - protected definition compose [Hf : is_equiv f] [Hg : is_equiv g] : (is_equiv (g ∘ f)) := + definition is_equiv_compose [Hf : is_equiv f] [Hg : is_equiv g] : (is_equiv (g ∘ f)) := is_equiv.mk ((inv f) ∘ (inv g)) (λc, ap g (retr f (g⁻¹ c)) ⬝ retr g c) (λa, ap (inv f) (sect g (f a)) ⬝ sect f a) - (λa, (whiskerL _ (adj g (f a))) ⬝ - (ap_pp g _ _)⁻¹ ⬝ - ap02 g (concat_A1p (retr f) (sect g (f a))⁻¹ ⬝ + (λa, (whisker_left _ (adj g (f a))) ⬝ + (ap_con g _ _)⁻¹ ⬝ + ap02 g (ap_con_eq_con (retr f) (sect g (f a))⁻¹ ⬝ (ap_compose (inv f) f _ ◾ adj f a) ⬝ - (ap_pp f _ _)⁻¹ + (ap_con f _ _)⁻¹ ) ⬝ (ap_compose f g _)⁻¹ ) -- Any function equal to an equivalence is an equivlance as well. - definition path_closed [Hf : is_equiv f] (Heq : f = f') : (is_equiv f') := + definition is_equiv_eq_closed [Hf : is_equiv f] (Heq : f = f') : (is_equiv f') := eq.rec_on Heq Hf -- Any function pointwise equal to an equivalence is an equivalence as well. @@ -64,36 +70,35 @@ namespace is_equiv have eq1 : _ = _, from calc ap f secta ⬝ ff'a = retrfa ⬝ ff'a : ap _ (@adj _ _ f _ _) - ... = ap (f ∘ invf) ff'a ⬝ retrf'a : concat_A1p + ... = ap (f ∘ invf) ff'a ⬝ retrf'a : ap_con_eq_con ... = ap f (ap invf ff'a) ⬝ retrf'a : ap_compose invf f, have eq2 : _ = _, from calc retrf'a - = (ap f (ap invf ff'a))⁻¹ ⬝ (ap f secta ⬝ ff'a) : moveL_Vp _ _ _ (eq1⁻¹) - ... = ap f (ap invf ff'a)⁻¹ ⬝ (ap f secta ⬝ Hty a) : ap_V invf ff'a - ... = ap f (ap invf ff'a)⁻¹ ⬝ (Hty (invf (f a)) ⬝ ap f' secta) : concat_Ap - ... = (ap f (ap invf ff'a)⁻¹ ⬝ Hty (invf (f a))) ⬝ ap f' secta : concat_pp_p - ... = (ap f ((ap invf ff'a)⁻¹) ⬝ Hty (invf (f a))) ⬝ ap f' secta : ap_V - ... = (Hty (invf (f' a)) ⬝ ap f' ((ap invf ff'a)⁻¹)) ⬝ ap f' secta : concat_Ap - ... = (Hty (invf (f' a)) ⬝ (ap f' (ap invf ff'a))⁻¹) ⬝ ap f' secta : ap_V - ... = Hty (invf (f' a)) ⬝ ((ap f' (ap invf ff'a))⁻¹ ⬝ ap f' secta) : concat_pp_p, + = (ap f (ap invf ff'a))⁻¹ ⬝ (ap f secta ⬝ ff'a) : eq_inv_con_of_con_eq _ _ _ (eq1⁻¹) + ... = ap f (ap invf ff'a)⁻¹ ⬝ (ap f secta ⬝ Hty a) : ap_inv invf ff'a + ... = ap f (ap invf ff'a)⁻¹ ⬝ (Hty (invf (f a)) ⬝ ap f' secta) : ap_con_eq_con_ap + ... = (ap f (ap invf ff'a)⁻¹ ⬝ Hty (invf (f a))) ⬝ ap f' secta : con.assoc + ... = (ap f ((ap invf ff'a)⁻¹) ⬝ Hty (invf (f a))) ⬝ ap f' secta : ap_inv + ... = (Hty (invf (f' a)) ⬝ ap f' ((ap invf ff'a)⁻¹)) ⬝ ap f' secta : ap_con_eq_con_ap + ... = (Hty (invf (f' a)) ⬝ (ap f' (ap invf ff'a))⁻¹) ⬝ ap f' secta : ap_inv + ... = Hty (invf (f' a)) ⬝ ((ap f' (ap invf ff'a))⁻¹ ⬝ ap f' secta) : con.assoc, have eq3 : _ = _, from calc (Hty (invf (f' a)))⁻¹ ⬝ retrf'a - = (ap f' (ap invf ff'a))⁻¹ ⬝ ap f' secta : moveR_Vp _ _ _ eq2 - ... = (ap f' ((ap invf ff'a)⁻¹)) ⬝ ap f' secta : ap_V - ... = ap f' ((ap invf ff'a)⁻¹ ⬝ secta) : ap_pp, + = (ap f' (ap invf ff'a))⁻¹ ⬝ ap f' secta : inv_con_eq_of_eq_con _ _ _ eq2 + ... = (ap f' ((ap invf ff'a)⁻¹)) ⬝ ap f' secta : ap_inv + ... = ap f' ((ap invf ff'a)⁻¹ ⬝ secta) : ap_con, eq3) in is_equiv.mk (inv f) sect' retr' adj' -end is_equiv + end -namespace is_equiv context parameters {A B : Type} (f : A → B) (g : B → A) (ret : f ∘ g ∼ id) (sec : g ∘ f ∼ id) - definition adjointify_sect' : g ∘ f ∼ id := + private definition adjointify_sect' : g ∘ f ∼ id := (λx, ap g (ap f (inverse (sec x))) ⬝ ap g (ret (f x)) ⬝ sec x) - definition adjointify_adj' : Π (x : A), ret (f x) = ap f (adjointify_sect' x) := + private definition adjointify_adj' : Π (x : A), ret (f x) = ap f (adjointify_sect' x) := (λ (a : A), let fgretrfa := ap f (ap g (ret (f a))) in let fgfinvsect := ap f (ap g (ap f ((sec a)⁻¹))) in @@ -101,88 +106,84 @@ namespace is_equiv let retrfa := ret (f a) in have eq1 : ap f (sec a) = _, from calc ap f (sec a) - = idp ⬝ ap f (sec a) : !concat_1p⁻¹ - ... = (ret (f a) ⬝ (ret (f a)⁻¹)) ⬝ ap f (sec a) : {!concat_pV⁻¹} - ... = ((ret (fgfa))⁻¹ ⬝ ap (f ∘ g) (ret (f a))) ⬝ ap f (sec a) : {!concat_pA1⁻¹} + = idp ⬝ ap f (sec a) : !idp_con⁻¹ + ... = (ret (f a) ⬝ (ret (f a)⁻¹)) ⬝ ap f (sec a) : {!con.left_inv⁻¹} + ... = ((ret (fgfa))⁻¹ ⬝ ap (f ∘ g) (ret (f a))) ⬝ ap f (sec a) : {!con_ap_eq_con⁻¹} ... = ((ret (fgfa))⁻¹ ⬝ fgretrfa) ⬝ ap f (sec a) : {ap_compose g f _} - ... = (ret (fgfa))⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a)) : !concat_pp_p, + ... = (ret (fgfa))⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a)) : !con.assoc, have eq2 : ap f (sec a) ⬝ idp = (ret fgfa)⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a)), - from !concat_p1 ⬝ eq1, + from !con_idp ⬝ eq1, have eq3 : idp = _, from calc idp - = (ap f (sec a))⁻¹ ⬝ ((ret fgfa)⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a))) : moveL_Vp _ _ _ eq2 - ... = (ap f (sec a)⁻¹ ⬝ (ret fgfa)⁻¹) ⬝ (fgretrfa ⬝ ap f (sec a)) : !concat_p_pp - ... = (ap f ((sec a)⁻¹) ⬝ (ret fgfa)⁻¹) ⬝ (fgretrfa ⬝ ap f (sec a)) : {!ap_V⁻¹} - ... = ((ap f ((sec a)⁻¹) ⬝ (ret fgfa)⁻¹) ⬝ fgretrfa) ⬝ ap f (sec a) : !concat_p_pp - ... = ((retrfa⁻¹ ⬝ ap (f ∘ g) (ap f ((sec a)⁻¹))) ⬝ fgretrfa) ⬝ ap f (sec a) : {!concat_pA1⁻¹} + = (ap f (sec a))⁻¹ ⬝ ((ret fgfa)⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a))) : eq_inv_con_of_con_eq _ _ _ eq2 + ... = (ap f (sec a)⁻¹ ⬝ (ret fgfa)⁻¹) ⬝ (fgretrfa ⬝ ap f (sec a)) : !con.assoc' + ... = (ap f ((sec a)⁻¹) ⬝ (ret fgfa)⁻¹) ⬝ (fgretrfa ⬝ ap f (sec a)) : {!ap_inv⁻¹} + ... = ((ap f ((sec a)⁻¹) ⬝ (ret fgfa)⁻¹) ⬝ fgretrfa) ⬝ ap f (sec a) : !con.assoc' + ... = ((retrfa⁻¹ ⬝ ap (f ∘ g) (ap f ((sec a)⁻¹))) ⬝ fgretrfa) ⬝ ap f (sec a) : {!con_ap_eq_con⁻¹} ... = ((retrfa⁻¹ ⬝ fgfinvsect) ⬝ fgretrfa) ⬝ ap f (sec a) : {ap_compose g f _} - ... = (retrfa⁻¹ ⬝ (fgfinvsect ⬝ fgretrfa)) ⬝ ap f (sec a) : {!concat_p_pp⁻¹} - ... = retrfa⁻¹ ⬝ ap f (ap g (ap f ((sec a)⁻¹)) ⬝ ap g (ret (f a))) ⬝ ap f (sec a) : {!ap_pp⁻¹} - ... = retrfa⁻¹ ⬝ (ap f (ap g (ap f ((sec a)⁻¹)) ⬝ ap g (ret (f a))) ⬝ ap f (sec a)) : !concat_p_pp⁻¹ - ... = retrfa⁻¹ ⬝ ap f ((ap g (ap f ((sec a)⁻¹)) ⬝ ap g (ret (f a))) ⬝ sec a) : {!ap_pp⁻¹}, + ... = (retrfa⁻¹ ⬝ (fgfinvsect ⬝ fgretrfa)) ⬝ ap f (sec a) : {!con.assoc'⁻¹} + ... = retrfa⁻¹ ⬝ ap f (ap g (ap f ((sec a)⁻¹)) ⬝ ap g (ret (f a))) ⬝ ap f (sec a) : {!ap_con⁻¹} + ... = retrfa⁻¹ ⬝ (ap f (ap g (ap f ((sec a)⁻¹)) ⬝ ap g (ret (f a))) ⬝ ap f (sec a)) : !con.assoc'⁻¹ + ... = retrfa⁻¹ ⬝ ap f ((ap g (ap f ((sec a)⁻¹)) ⬝ ap g (ret (f a))) ⬝ sec a) : {!ap_con⁻¹}, have eq4 : ret (f a) = ap f ((ap g (ap f ((sec a)⁻¹)) ⬝ ap g (ret (f a))) ⬝ sec a), - from moveR_M1 _ _ eq3, + from eq_of_idp_eq_inv_con _ _ eq3, eq4) definition adjointify : is_equiv f := is_equiv.mk g ret adjointify_sect' adjointify_adj' end -end is_equiv -namespace is_equiv + section variables {A B: Type} (f : A → B) --The inverse of an equivalence is, again, an equivalence. - definition inv_closed [instance] [Hf : is_equiv f] : (is_equiv (inv f)) := + definition is_equiv_inv [instance] [Hf : is_equiv f] : (is_equiv (inv f)) := adjointify (inv f) f (sect f) (retr f) + end -end is_equiv - -namespace is_equiv - variables {A : Type} section - variables {B C : Type} (f : A → B) {f' : A → B} [Hf : is_equiv f] + variables {A B C : Type} (f : A → B) {f' : A → B} [Hf : is_equiv f] include Hf variable (g : B → C) - definition cancel_R (g : B → C) [Hgf : is_equiv (g ∘ f)] : (is_equiv g) := - have Hfinv [visible] : is_equiv (f⁻¹), from inv_closed f, - @homotopy_closed _ _ _ _ (is_equiv.compose (f⁻¹) (g ∘ f)) (λb, ap g (@retr _ _ f _ b)) + definition cancel_right (g : B → C) [Hgf : is_equiv (g ∘ f)] : (is_equiv g) := + have Hfinv [visible] : is_equiv (f⁻¹), from is_equiv_inv f, + @homotopy_closed _ _ _ _ (is_equiv_compose (f⁻¹) (g ∘ f)) (λb, ap g (@retr _ _ f _ b)) - definition cancel_L (g : C → A) [Hgf : is_equiv (f ∘ g)] : (is_equiv g) := - have Hfinv [visible] : is_equiv (f⁻¹), from inv_closed f, - @homotopy_closed _ _ _ _ (is_equiv.compose (f ∘ g) (f⁻¹)) (λa, sect f (g a)) + definition cancel_left (g : C → A) [Hgf : is_equiv (f ∘ g)] : (is_equiv g) := + have Hfinv [visible] : is_equiv (f⁻¹), from is_equiv_inv f, + @homotopy_closed _ _ _ _ (is_equiv_compose (f ∘ g) (f⁻¹)) (λa, sect f (g a)) --Rewrite rules - definition moveR_M {x : A} {y : B} (p : x = (inv f) y) : (f x = y) := + definition eq_of_eq_inv {x : A} {y : B} (p : x = (inv f) y) : (f x = y) := (ap f p) ⬝ (@retr _ _ f _ y) - definition moveL_M {x : A} {y : B} (p : (inv f) y = x) : (y = f x) := - (moveR_M f (p⁻¹))⁻¹ + definition eq_of_inv_eq {x : A} {y : B} (p : (inv f) y = x) : (y = f x) := + (eq_of_eq_inv f (p⁻¹))⁻¹ - definition moveR_V {x : B} {y : A} (p : x = f y) : (inv f) x = y := + definition inv_eq_of_eq {x : B} {y : A} (p : x = f y) : (inv f) x = y := ap (f⁻¹) p ⬝ sect f y - definition moveL_V {x : B} {y : A} (p : f y = x) : y = (inv f) x := - (moveR_V f (p⁻¹))⁻¹ + definition eq_inv_of_eq {x : B} {y : A} (p : f y = x) : y = (inv f) x := + (inv_eq_of_eq f (p⁻¹))⁻¹ - definition ap_closed [instance] (x y : A) : is_equiv (ap f) := + definition is_equiv_ap [instance] (x y : A) : is_equiv (ap f) := adjointify (ap f) (λq, (inverse (sect f x)) ⬝ ap (f⁻¹) q ⬝ sect f y) - (λq, !ap_pp - ⬝ whiskerR !ap_pp _ - ⬝ ((!ap_V ⬝ inverse2 ((adj f _)⁻¹)) + (λq, !ap_con + ⬝ whisker_right !ap_con _ + ⬝ ((!ap_inv ⬝ inverse2 ((adj f _)⁻¹)) ◾ (inverse (ap_compose (f⁻¹) f _)) ◾ (adj f _)⁻¹) - ⬝ concat_pA1_p (retr f) _ _ - ⬝ whiskerR !concat_Vp _ - ⬝ !concat_1p) - (λp, whiskerR (whiskerL _ ((ap_compose f (f⁻¹) _)⁻¹)) _ - ⬝ concat_pA1_p (sect f) _ _ - ⬝ whiskerR !concat_Vp _ - ⬝ !concat_1p) + ⬝ con_ap_con_eq_con_con (retr f) _ _ + ⬝ whisker_right !con.right_inv _ + ⬝ !idp_con) + (λp, whisker_right (whisker_left _ ((ap_compose f (f⁻¹) _)⁻¹)) _ + ⬝ con_ap_con_eq_con_con (sect f) _ _ + ⬝ whisker_right !con.right_inv _ + ⬝ !idp_con) -- The function equiv_rect says that given an equivalence f : A → B, -- and a hypothesis from B, one may always assume that the hypothesis @@ -192,7 +193,7 @@ namespace is_equiv -- once pulled back along an equivalence f : A → B, then it has a section -- over all of B. - definition equiv_rect (P : B -> Type) : + definition equiv_rect (P : B → Type) : (Πx, P (f x)) → (Πy, P y) := (λg y, eq.transport _ (retr f y) (g (f⁻¹ y))) @@ -200,18 +201,20 @@ namespace is_equiv (df : Π (x : A), P (f x)) (x : A) : equiv_rect f P df (f x) = df x := calc equiv_rect f P df (f x) = transport P (retr f (f x)) (df (f⁻¹ (f x))) : idp - ... = transport P (ap f (sect f x)) (df (f⁻¹ (f x))) : adj f + ... = transport P (eq.ap f (sect f x)) (df (f⁻¹ (f x))) : adj f ... = transport (P ∘ f) (sect f x) (df (f⁻¹ (f x))) : transport_compose ... = df x : apD df (sect f x) end --Transporting is an equivalence - protected definition transport [instance] (P : A → Type) {x y : A} (p : x = y) : (is_equiv (transport P p)) := - is_equiv.mk (transport P (p⁻¹)) (transport_pV P p) (transport_Vp P p) (transport_pVp P p) + definition is_equiv_tr [instance] {A : Type} (P : A → Type) {x y : A} (p : x = y) : (is_equiv (transport P p)) := + is_equiv.mk (transport P (p⁻¹)) (tr_inv_tr P p) (inv_tr_tr P p) (tr_inv_tr_lemma P p) + end is_equiv +open is_equiv namespace equiv attribute to_is_equiv [instance] @@ -224,42 +227,27 @@ namespace equiv private definition f : A → B := to_fun eqf private definition Hf [instance] : is_equiv f := to_is_equiv eqf - protected definition refl : A ≃ A := equiv.mk id is_equiv.id_is_equiv + protected definition refl : A ≃ A := equiv.mk id is_equiv.is_equiv_id - theorem trans (eqg: B ≃ C) : A ≃ C := + definition trans (eqg: B ≃ C) : A ≃ C := equiv.mk ((to_fun eqg) ∘ f) - (is_equiv.compose f (to_fun eqg)) + (is_equiv_compose f (to_fun eqg)) - theorem path_closed (f' : A → B) (Heq : to_fun eqf = f') : A ≃ B := - equiv.mk f' (is_equiv.path_closed f Heq) + definition equiv_of_eq_of_equiv (f' : A → B) (Heq : to_fun eqf = f') : A ≃ B := + equiv.mk f' (is_equiv.is_equiv_eq_closed f Heq) - theorem symm : B ≃ A := - equiv.mk (is_equiv.inv f) !is_equiv.inv_closed + definition symm : B ≃ A := + equiv.mk (is_equiv.inv f) !is_equiv.is_equiv_inv - theorem cancel_R (g : B → C) [Hgf : is_equiv (g ∘ f)] : B ≃ C := - equiv.mk g (is_equiv.cancel_R f _) - - theorem cancel_L (g : C → A) [Hgf : is_equiv (f ∘ g)] : C ≃ A := - equiv.mk g (is_equiv.cancel_L f _) - - protected theorem transport (P : A → Type) {x y : A} {p : x = y} : (P x) ≃ (P y) := - equiv.mk (transport P p) (is_equiv.transport P p) + definition equiv_ap (P : A → Type) {x y : A} {p : x = y} : (P x) ≃ (P y) := + equiv.mk (eq.transport P p) (is_equiv_tr P p) end - context - parameters {A B : Type} (eqf eqg : A ≃ B) - - private definition Hf [instance] : is_equiv (to_fun eqf) := to_is_equiv eqf - private definition Hg [instance] : is_equiv (to_fun eqg) := to_is_equiv eqg - - --We need this theorem for the funext_from_ua proof - theorem inv_eq (p : eqf = eqg) - : is_equiv.inv (to_fun eqf) = is_equiv.inv (to_fun eqg) := + --we need this theorem for the funext_of_ua proof + theorem inv_eq {A B : Type} (eqf eqg : A ≃ B) (p : eqf = eqg) : (to_fun eqf)⁻¹ = (to_fun eqg)⁻¹ := eq.rec_on p idp - end - -- calc enviroment -- Note: Calculating with substitutions needs univalence calc_trans equiv.trans diff --git a/hott/init/function.hlean b/hott/init/function.hlean index a537900a10..c318529318 100644 --- a/hott/init/function.hlean +++ b/hott/init/function.hlean @@ -1,6 +1,8 @@ /- Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. + +Module: init.function Author: Leonardo de Moura General operations on functions. diff --git a/hott/init/hedberg.hlean b/hott/init/hedberg.hlean index ce9c2799b0..503f5bee7f 100644 --- a/hott/init/hedberg.hlean +++ b/hott/init/hedberg.hlean @@ -8,7 +8,7 @@ Hedberg's Theorem: every type with decidable equality is a hset -/ prelude import init.trunc -open eq eq.ops nat truncation sigma +open eq eq.ops nat is_trunc sigma -- TODO(Leo): move const coll and path_coll to a different file? private definition const {A B : Type} (f : A → B) := ∀ x y, f x = f y diff --git a/hott/init/logic.hlean b/hott/init/logic.hlean index 1067fd16cc..1b326021aa 100644 --- a/hott/init/logic.hlean +++ b/hott/init/logic.hlean @@ -2,6 +2,7 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Module: init.logic Authors: Leonardo de Moura -/ prelude @@ -16,8 +17,7 @@ empty.rec (λ e, b) (H₂ H₁) definition mt {a b : Type} (H₁ : a → b) (H₂ : ¬b) : ¬a := assume Ha : a, absurd (H₁ Ha) H₂ --- not --- --- +/- not -/ protected definition not_empty : ¬ empty := assume H : empty, H @@ -35,8 +35,7 @@ assume Hna : ¬a, absurd (assume Ha : a, absurd Ha Hna) H definition not_of_not_implies {a b : Type} (H : ¬(a → b)) : ¬b := assume Hb : b, absurd (assume Ha : a, Hb) H --- eq --- -- +/- eq -/ notation a = b := eq a b definition rfl {A : Type} {a : A} := eq.refl a @@ -74,8 +73,7 @@ namespace lift lift.rec_on a (λ d, rfl) end lift --- ne --- -- +/- ne -/ definition ne {A : Type} (a b : A) := ¬(a = b) notation a ≠ b := ne a b @@ -115,8 +113,7 @@ end calc_trans ne.of_eq_of_ne calc_trans ne.of_ne_of_eq --- iff --- --- +/- iff -/ definition iff (a b : Type) := prod (a → b) (b → a) @@ -178,8 +175,7 @@ end iff calc_refl iff.refl calc_trans iff.trans --- inhabited --- --------- +/- inhabited -/ inductive inhabited [class] (A : Type) : Type := mk : A → inhabited A @@ -200,8 +196,7 @@ definition default (A : Type) [H : inhabited A] : A := destruct H (take a, a) end inhabited --- decidable --- --------- +/- decidable -/ inductive decidable.{l} [class] (p : Type.{l}) : Type.{l} := inl : p → decidable p, diff --git a/hott/init/nat.hlean b/hott/init/nat.hlean index 9ad758ab6e..aed5bd40cd 100644 --- a/hott/init/nat.hlean +++ b/hott/init/nat.hlean @@ -3,6 +3,7 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Floris van Doorn, Leonardo de Moura -/ + prelude import init.wf init.tactic init.hedberg init.util init.types.sum diff --git a/hott/init/path.hlean b/hott/init/path.hlean index 4a92903f9f..cf4d2cd128 100644 --- a/hott/init/path.hlean +++ b/hott/init/path.hlean @@ -1,19 +1,19 @@ --- Copyright (c) 2014 Microsoft Corporation. All rights reserved. --- Released under Apache 2.0 license as described in the file LICENSE. --- Author: Jeremy Avigad, Jakob von Raumer --- Ported from Coq HoTT --- --- TODO: things to test: --- o To what extent can we use opaque definitions outside the file? --- o Try doing these proofs with tactics. --- o Try using the simplifier on some of these proofs. +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Module: init.path +Author: Jeremy Avigad, Jakob von Raumer + +Ported from Coq HoTT +-/ + prelude import .function .datatypes .relation .tactic open function eq --- Path equality --- ---- -------- +/- Path equality -/ namespace eq variables {A B C : Type} {P : A → Type} {x y z t : A} @@ -21,6 +21,7 @@ namespace eq --notation a = b := eq a b notation x = y `:>`:50 A:49 := @eq A x y definition idp {a : A} := refl a + definition idpath (a : A) := refl a -- unbased path induction definition rec' [reducible] {P : Π (a b : A), (a = b) -> Type} @@ -31,8 +32,7 @@ namespace eq (H : Π (a : A), P a a idp) : P a b p := eq.rec (H a) p - -- Concatenation and inverse - -- ------------------------- + /- Concatenation and inverse -/ definition concat (p : x = y) (q : y = z) : x = z := eq.rec (λu, u) q p @@ -43,137 +43,133 @@ namespace eq notation p₁ ⬝ p₂ := concat p₁ p₂ notation p ⁻¹ := inverse p - -- The 1-dimensional groupoid structure - -- ------------------------------------ + /- The 1-dimensional groupoid structure -/ -- The identity path is a right unit. - definition concat_p1 (p : x = y) : p ⬝ idp = p := + definition con_idp (p : x = y) : p ⬝ idp = p := eq.rec_on p idp -- The identity path is a right unit. - definition concat_1p (p : x = y) : idp ⬝ p = p := + definition idp_con (p : x = y) : idp ⬝ p = p := eq.rec_on p idp -- Concatenation is associative. - definition concat_p_pp (p : x = y) (q : y = z) (r : z = t) : + definition con.assoc' (p : x = y) (q : y = z) (r : z = t) : p ⬝ (q ⬝ r) = (p ⬝ q) ⬝ r := eq.rec_on r (eq.rec_on q idp) - definition concat_pp_p (p : x = y) (q : y = z) (r : z = t) : + definition con.assoc (p : x = y) (q : y = z) (r : z = t) : (p ⬝ q) ⬝ r = p ⬝ (q ⬝ r) := eq.rec_on r (eq.rec_on q idp) -- The left inverse law. - definition concat_pV (p : x = y) : p ⬝ p⁻¹ = idp := + definition con.left_inv (p : x = y) : p ⬝ p⁻¹ = idp := eq.rec_on p idp -- The right inverse law. - definition concat_Vp (p : x = y) : p⁻¹ ⬝ p = idp := + definition con.right_inv (p : x = y) : p⁻¹ ⬝ p = idp := eq.rec_on p idp - -- Several auxiliary theorems about canceling inverses across associativity. These are somewhat - -- redundant, following from earlier theorems. + /- Several auxiliary theorems about canceling inverses across associativity. These are somewhat + redundant, following from earlier theorems. -/ - definition concat_V_pp (p : x = y) (q : y = z) : p⁻¹ ⬝ (p ⬝ q) = q := + definition inv_con_cancel_left (p : x = y) (q : y = z) : p⁻¹ ⬝ (p ⬝ q) = q := eq.rec_on q (eq.rec_on p idp) - definition concat_p_Vp (p : x = y) (q : x = z) : p ⬝ (p⁻¹ ⬝ q) = q := + definition con_inv_cancel_left (p : x = y) (q : x = z) : p ⬝ (p⁻¹ ⬝ q) = q := eq.rec_on q (eq.rec_on p idp) - definition concat_pp_V (p : x = y) (q : y = z) : (p ⬝ q) ⬝ q⁻¹ = p := + definition con_inv_cancel_right (p : x = y) (q : y = z) : (p ⬝ q) ⬝ q⁻¹ = p := eq.rec_on q (eq.rec_on p idp) - definition concat_pV_p (p : x = z) (q : y = z) : (p ⬝ q⁻¹) ⬝ q = p := + definition inv_con_cancel_right (p : x = z) (q : y = z) : (p ⬝ q⁻¹) ⬝ q = p := eq.rec_on q (take p, eq.rec_on p idp) p -- Inverse distributes over concatenation - definition inv_pp (p : x = y) (q : y = z) : (p ⬝ q)⁻¹ = q⁻¹ ⬝ p⁻¹ := + definition con_inv (p : x = y) (q : y = z) : (p ⬝ q)⁻¹ = q⁻¹ ⬝ p⁻¹ := eq.rec_on q (eq.rec_on p idp) - definition inv_Vp (p : y = x) (q : y = z) : (p⁻¹ ⬝ q)⁻¹ = q⁻¹ ⬝ p := + definition inv_con_inv_left (p : y = x) (q : y = z) : (p⁻¹ ⬝ q)⁻¹ = q⁻¹ ⬝ p := eq.rec_on q (eq.rec_on p idp) -- universe metavariables - definition inv_pV (p : x = y) (q : z = y) : (p ⬝ q⁻¹)⁻¹ = q ⬝ p⁻¹ := + definition inv_con_inv_right (p : x = y) (q : z = y) : (p ⬝ q⁻¹)⁻¹ = q ⬝ p⁻¹ := eq.rec_on p (take q, eq.rec_on q idp) q - definition inv_VV (p : y = x) (q : z = y) : (p⁻¹ ⬝ q⁻¹)⁻¹ = q ⬝ p := + definition inv_con_inv_inv (p : y = x) (q : z = y) : (p⁻¹ ⬝ q⁻¹)⁻¹ = q ⬝ p := eq.rec_on p (eq.rec_on q idp) -- Inverse is an involution. - definition inv_V (p : x = y) : p⁻¹⁻¹ = p := + definition inv_inv (p : x = y) : p⁻¹⁻¹ = p := eq.rec_on p idp - -- Theorems for moving things around in equations - -- ---------------------------------------------- + /- Theorems for moving things around in equations -/ - definition moveR_Mp (p : x = z) (q : y = z) (r : y = x) : - p = (r⁻¹ ⬝ q) → (r ⬝ p) = q := - eq.rec_on r (take p h, concat_1p _ ⬝ h ⬝ concat_1p _) p + definition con_eq_of_eq_inv_con (p : x = z) (q : y = z) (r : y = x) : + p = r⁻¹ ⬝ q → r ⬝ p = q := + eq.rec_on r (take p h, idp_con _ ⬝ h ⬝ idp_con _) p - definition moveR_pM (p : x = z) (q : y = z) (r : y = x) : + definition con_eq_of_eq_con_inv (p : x = z) (q : y = z) (r : y = x) : r = q ⬝ p⁻¹ → r ⬝ p = q := - eq.rec_on p (take q h, (concat_p1 _ ⬝ h ⬝ concat_p1 _)) q + eq.rec_on p (take q h, (con_idp _ ⬝ h ⬝ con_idp _)) q - definition moveR_Vp (p : x = z) (q : y = z) (r : x = y) : + definition inv_con_eq_of_eq_con (p : x = z) (q : y = z) (r : x = y) : p = r ⬝ q → r⁻¹ ⬝ p = q := - eq.rec_on r (take q h, concat_1p _ ⬝ h ⬝ concat_1p _) q + eq.rec_on r (take q h, idp_con _ ⬝ h ⬝ idp_con _) q - definition moveR_pV (p : z = x) (q : y = z) (r : y = x) : + definition con_inv_eq_of_eq_con (p : z = x) (q : y = z) (r : y = x) : r = q ⬝ p → r ⬝ p⁻¹ = q := - eq.rec_on p (take r h, concat_p1 _ ⬝ h ⬝ concat_p1 _) r + eq.rec_on p (take r h, con_idp _ ⬝ h ⬝ con_idp _) r - definition moveL_Mp (p : x = z) (q : y = z) (r : y = x) : + definition eq_con_of_inv_con_eq (p : x = z) (q : y = z) (r : y = x) : r⁻¹ ⬝ q = p → q = r ⬝ p := - eq.rec_on r (take p h, (concat_1p _)⁻¹ ⬝ h ⬝ (concat_1p _)⁻¹) p + eq.rec_on r (take p h, (idp_con _)⁻¹ ⬝ h ⬝ (idp_con _)⁻¹) p - definition moveL_pM (p : x = z) (q : y = z) (r : y = x) : + definition eq_con_of_con_inv_eq (p : x = z) (q : y = z) (r : y = x) : q ⬝ p⁻¹ = r → q = r ⬝ p := - eq.rec_on p (take q h, (concat_p1 _)⁻¹ ⬝ h ⬝ (concat_p1 _)⁻¹) q + eq.rec_on p (take q h, (con_idp _)⁻¹ ⬝ h ⬝ (con_idp _)⁻¹) q - definition moveL_Vp (p : x = z) (q : y = z) (r : x = y) : + definition eq_inv_con_of_con_eq (p : x = z) (q : y = z) (r : x = y) : r ⬝ q = p → q = r⁻¹ ⬝ p := - eq.rec_on r (take q h, (concat_1p _)⁻¹ ⬝ h ⬝ (concat_1p _)⁻¹) q + eq.rec_on r (take q h, (idp_con _)⁻¹ ⬝ h ⬝ (idp_con _)⁻¹) q - definition moveL_pV (p : z = x) (q : y = z) (r : y = x) : + definition eq_con_inv_of_con_eq (p : z = x) (q : y = z) (r : y = x) : q ⬝ p = r → q = r ⬝ p⁻¹ := - eq.rec_on p (take r h, (concat_p1 _)⁻¹ ⬝ h ⬝ (concat_p1 _)⁻¹) r + eq.rec_on p (take r h, (con_idp _)⁻¹ ⬝ h ⬝ (con_idp _)⁻¹) r - definition moveL_1M (p q : x = y) : + definition eq_of_con_inv_eq_idp (p q : x = y) : p ⬝ q⁻¹ = idp → p = q := - eq.rec_on q (take p h, (concat_p1 _)⁻¹ ⬝ h) p + eq.rec_on q (take p h, (con_idp _)⁻¹ ⬝ h) p - definition moveL_M1 (p q : x = y) : + definition eq_of_inv_con_eq_idp (p q : x = y) : q⁻¹ ⬝ p = idp → p = q := - eq.rec_on q (take p h, (concat_1p _)⁻¹ ⬝ h) p + eq.rec_on q (take p h, (idp_con _)⁻¹ ⬝ h) p - definition moveL_1V (p : x = y) (q : y = x) : + definition eq_inv_of_con_eq_idp' (p : x = y) (q : y = x) : p ⬝ q = idp → p = q⁻¹ := - eq.rec_on q (take p h, (concat_p1 _)⁻¹ ⬝ h) p + eq.rec_on q (take p h, (con_idp _)⁻¹ ⬝ h) p - definition moveL_V1 (p : x = y) (q : y = x) : + definition eq_inv_of_con_eq_idp (p : x = y) (q : y = x) : q ⬝ p = idp → p = q⁻¹ := - eq.rec_on q (take p h, (concat_1p _)⁻¹ ⬝ h) p + eq.rec_on q (take p h, (idp_con _)⁻¹ ⬝ h) p - definition moveR_M1 (p q : x = y) : + definition eq_of_idp_eq_inv_con (p q : x = y) : idp = p⁻¹ ⬝ q → p = q := - eq.rec_on p (take q h, h ⬝ (concat_1p _)) q + eq.rec_on p (take q h, h ⬝ (idp_con _)) q - definition moveR_1M (p q : x = y) : + definition eq_of_idp_eq_con_inv (p q : x = y) : idp = q ⬝ p⁻¹ → p = q := - eq.rec_on p (take q h, h ⬝ (concat_p1 _)) q + eq.rec_on p (take q h, h ⬝ (con_idp _)) q - definition moveR_1V (p : x = y) (q : y = x) : + definition inv_eq_of_idp_eq_con (p : x = y) (q : y = x) : idp = q ⬝ p → p⁻¹ = q := - eq.rec_on p (take q h, h ⬝ (concat_p1 _)) q + eq.rec_on p (take q h, h ⬝ (con_idp _)) q - definition moveR_V1 (p : x = y) (q : y = x) : + definition inv_eq_of_idp_eq_con' (p : x = y) (q : y = x) : idp = p ⬝ q → p⁻¹ = q := - eq.rec_on p (take q h, h ⬝ (concat_1p _)) q + eq.rec_on p (take q h, h ⬝ (idp_con _)) q - - -- Transport - -- --------- + /- Transport -/ definition transport [reducible] (P : A → Type) {x y : A} (p : x = y) (u : P x) : P y := eq.rec_on p u @@ -181,6 +177,9 @@ namespace eq -- This idiom makes the operation right associative. notation p `▹`:65 x:64 := transport _ p x + definition tr_inv [reducible] (P : A → Type) {x y : A} (p : x = y) (u : P y) : P x := + p⁻¹ ▹ u + definition ap ⦃A B : Type⦄ (f : A → B) {x y:A} (p : x = y) : f x = f y := eq.rec_on p idp @@ -191,6 +190,21 @@ namespace eq notation f ∼ g := homotopy f g + namespace homotopy + protected definition refl (f : Πx, P x) : f ∼ f := + λ x, idp + + protected definition symm {f g : Πx, P x} (H : f ∼ g) : g ∼ f := + λ x, inverse (H x) + + protected definition trans {f g h : Πx, P x} (H1 : f ∼ g) (H2 : g ∼ h) : f ∼ h := + λ x, concat (H1 x) (H2 x) + + calc_refl refl + calc_symm symm + calc_trans trans + end homotopy + definition apD10 {f g : Πx, P x} (H : f = g) : f ∼ g := λx, eq.rec_on H idp @@ -202,68 +216,64 @@ namespace eq definition apD (f : Πa:A, P a) {x y : A} (p : x = y) : p ▹ (f x) = f y := eq.rec_on p idp - - -- calc enviroment - -- --------------- + /- calc enviroment -/ calc_subst transport calc_trans concat calc_refl refl calc_symm inverse - -- More theorems for moving things around in equations - -- --------------------------------------------------- + /- More theorems for moving things around in equations -/ - definition moveR_transport_p (P : A → Type) {x y : A} (p : x = y) (u : P x) (v : P y) : + definition tr_eq_of_eq_inv_tr (P : A → Type) {x y : A} (p : x = y) (u : P x) (v : P y) : u = p⁻¹ ▹ v → p ▹ u = v := eq.rec_on p (take v, id) v - definition moveR_transport_V (P : A → Type) {x y : A} (p : y = x) (u : P x) (v : P y) : + definition inv_tr_eq_of_eq_tr (P : A → Type) {x y : A} (p : y = x) (u : P x) (v : P y) : u = p ▹ v → p⁻¹ ▹ u = v := eq.rec_on p (take u, id) u - definition moveL_transport_V (P : A → Type) {x y : A} (p : x = y) (u : P x) (v : P y) : + definition eq_inv_tr_of_tr_eq (P : A → Type) {x y : A} (p : x = y) (u : P x) (v : P y) : p ▹ u = v → u = p⁻¹ ▹ v := eq.rec_on p (take v, id) v - definition moveL_transport_p (P : A → Type) {x y : A} (p : y = x) (u : P x) (v : P y) : + definition eq_tr_of_inv_tr_eq (P : A → Type) {x y : A} (p : y = x) (u : P x) (v : P y) : p⁻¹ ▹ u = v → u = p ▹ v := eq.rec_on p (take u, id) u - -- Functoriality of functions - -- -------------------------- + /- Functoriality of functions -/ -- Here we prove that functions behave like functors between groupoids, and that [ap] itself is -- functorial. -- Functions take identity paths to identity paths - definition ap_1 (x : A) (f : A → B) : (ap f idp) = idp :> (f x = f x) := idp + definition ap_idp (x : A) (f : A → B) : (ap f idp) = idp :> (f x = f x) := idp - definition apD_1 (x : A) (f : Π x : A, P x) : apD f idp = idp :> (f x = f x) := idp + definition apD_idp (x : A) (f : Π x : A, P x) : apD f idp = idp :> (f x = f x) := idp -- Functions commute with concatenation. - definition ap_pp (f : A → B) {x y z : A} (p : x = y) (q : y = z) : + definition ap_con (f : A → B) {x y z : A} (p : x = y) (q : y = z) : ap f (p ⬝ q) = (ap f p) ⬝ (ap f q) := eq.rec_on q (eq.rec_on p idp) - definition ap_p_pp (f : A → B) {w x y z : A} (r : f w = f x) (p : x = y) (q : y = z) : + definition con_ap_con_eq_con_ap_con_ap (f : A → B) {w x y z : A} (r : f w = f x) (p : x = y) (q : y = z) : r ⬝ (ap f (p ⬝ q)) = (r ⬝ ap f p) ⬝ (ap f q) := - eq.rec_on q (take p, eq.rec_on p (concat_p_pp r idp idp)) p + eq.rec_on q (take p, eq.rec_on p (con.assoc' r idp idp)) p - definition ap_pp_p (f : A → B) {w x y z : A} (p : x = y) (q : y = z) (r : f z = f w) : + definition ap_con_con_eq_ap_con_ap_con (f : A → B) {w x y z : A} (p : x = y) (q : y = z) (r : f z = f w) : (ap f (p ⬝ q)) ⬝ r = (ap f p) ⬝ (ap f q ⬝ r) := - eq.rec_on q (eq.rec_on p (take r, concat_pp_p _ _ _)) r + eq.rec_on q (eq.rec_on p (take r, con.assoc _ _ _)) r -- Functions commute with path inverses. - definition inverse_ap (f : A → B) {x y : A} (p : x = y) : (ap f p)⁻¹ = ap f (p⁻¹) := + definition ap_inv' (f : A → B) {x y : A} (p : x = y) : (ap f p)⁻¹ = ap f (p⁻¹) := eq.rec_on p idp - definition ap_V {A B : Type} (f : A → B) {x y : A} (p : x = y) : ap f (p⁻¹) = (ap f p)⁻¹ := + definition ap_inv {A B : Type} (f : A → B) {x y : A} (p : x = y) : ap f (p⁻¹) = (ap f p)⁻¹ := eq.rec_on p idp -- [ap] itself is functorial in the first argument. - definition ap_idmap (p : x = y) : ap id p = p := + definition ap_id (p : x = y) : ap id p = p := eq.rec_on p idp definition ap_compose (f : A → B) (g : B → C) {x y : A} (p : x = y) : @@ -276,104 +286,103 @@ namespace eq eq.rec_on p idp -- The action of constant maps. - definition ap_const (p : x = y) (z : B) : + definition ap_constant (p : x = y) (z : B) : ap (λu, z) p = idp := eq.rec_on p idp -- Naturality of [ap]. - definition concat_Ap {f g : A → B} (p : Π x, f x = g x) {x y : A} (q : x = y) : + definition ap_con_eq_con_ap {f g : A → B} (p : Π x, f x = g x) {x y : A} (q : x = y) : (ap f q) ⬝ (p y) = (p x) ⬝ (ap g q) := - eq.rec_on q (concat_1p _ ⬝ (concat_p1 _)⁻¹) + eq.rec_on q (idp_con _ ⬝ (con_idp _)⁻¹) -- Naturality of [ap] at identity. - definition concat_A1p {f : A → A} (p : Πx, f x = x) {x y : A} (q : x = y) : + definition ap_con_eq_con {f : A → A} (p : Πx, f x = x) {x y : A} (q : x = y) : (ap f q) ⬝ (p y) = (p x) ⬝ q := - eq.rec_on q (concat_1p _ ⬝ (concat_p1 _)⁻¹) + eq.rec_on q (idp_con _ ⬝ (con_idp _)⁻¹) - definition concat_pA1 {f : A → A} (p : Πx, x = f x) {x y : A} (q : x = y) : + definition con_ap_eq_con {f : A → A} (p : Πx, x = f x) {x y : A} (q : x = y) : (p x) ⬝ (ap f q) = q ⬝ (p y) := - eq.rec_on q (concat_p1 _ ⬝ (concat_1p _)⁻¹) + eq.rec_on q (con_idp _ ⬝ (idp_con _)⁻¹) -- Naturality with other paths hanging around. - definition concat_pA_pp {f g : A → B} (p : Πx, f x = g x) {x y : A} (q : x = y) + definition con_ap_con_con_eq_con_con_ap_con {f g : A → B} (p : f ∼ g) {x y : A} (q : x = y) {w z : B} (r : w = f x) (s : g y = z) : (r ⬝ ap f q) ⬝ (p y ⬝ s) = (r ⬝ p x) ⬝ (ap g q ⬝ s) := eq.rec_on s (eq.rec_on q idp) - definition concat_pA_p {f g : A → B} (p : Πx, f x = g x) {x y : A} (q : x = y) + definition con_ap_con_eq_con_con_ap {f g : A → B} (p : f ∼ g) {x y : A} (q : x = y) {w : B} (r : w = f x) : (r ⬝ ap f q) ⬝ p y = (r ⬝ p x) ⬝ ap g q := eq.rec_on q idp -- TODO: try this using the simplifier, and compare proofs - definition concat_A_pp {f g : A → B} (p : Πx, f x = g x) {x y : A} (q : x = y) + definition ap_con_con_eq_con_ap_con {f g : A → B} (p : f ∼ g) {x y : A} (q : x = y) {z : B} (s : g y = z) : (ap f q) ⬝ (p y ⬝ s) = (p x) ⬝ (ap g q ⬝ s) := eq.rec_on s (eq.rec_on q (calc (ap f idp) ⬝ (p x ⬝ idp) = idp ⬝ p x : idp - ... = p x : concat_1p _ + ... = p x : idp_con _ ... = (p x) ⬝ (ap g idp ⬝ idp) : idp)) -- This also works: - -- eq.rec_on s (eq.rec_on q (concat_1p _ ▹ idp)) + -- eq.rec_on s (eq.rec_on q (idp_con _ ▹ idp)) - definition concat_pA1_pp {f : A → A} (p : Πx, f x = x) {x y : A} (q : x = y) + definition con_ap_con_con_eq_con_con_con {f : A → A} (p : f ∼ id) {x y : A} (q : x = y) {w z : A} (r : w = f x) (s : y = z) : (r ⬝ ap f q) ⬝ (p y ⬝ s) = (r ⬝ p x) ⬝ (q ⬝ s) := eq.rec_on s (eq.rec_on q idp) - definition concat_pp_A1p {g : A → A} (p : Πx, x = g x) {x y : A} (q : x = y) + definition con_con_ap_con_eq_con_con_con {g : A → A} (p : id ∼ g) {x y : A} (q : x = y) {w z : A} (r : w = x) (s : g y = z) : (r ⬝ p x) ⬝ (ap g q ⬝ s) = (r ⬝ q) ⬝ (p y ⬝ s) := eq.rec_on s (eq.rec_on q idp) - definition concat_pA1_p {f : A → A} (p : Πx, f x = x) {x y : A} (q : x = y) + definition con_ap_con_eq_con_con {f : A → A} (p : f ∼ id) {x y : A} (q : x = y) {w : A} (r : w = f x) : (r ⬝ ap f q) ⬝ p y = (r ⬝ p x) ⬝ q := eq.rec_on q idp - definition concat_A1_pp {f : A → A} (p : Πx, f x = x) {x y : A} (q : x = y) + definition ap_con_con_eq_con_con {f : A → A} (p : f ∼ id) {x y : A} (q : x = y) {z : A} (s : y = z) : (ap f q) ⬝ (p y ⬝ s) = (p x) ⬝ (q ⬝ s) := - eq.rec_on s (eq.rec_on q (concat_1p _ ▹ idp)) + eq.rec_on s (eq.rec_on q (idp_con _ ▹ idp)) - definition concat_pp_A1 {g : A → A} (p : Πx, x = g x) {x y : A} (q : x = y) + definition con_con_ap_eq_con_con {g : A → A} (p : id ∼ g) {x y : A} (q : x = y) {w : A} (r : w = x) : (r ⬝ p x) ⬝ ap g q = (r ⬝ q) ⬝ p y := eq.rec_on q idp - definition concat_p_A1p {g : A → A} (p : Πx, x = g x) {x y : A} (q : x = y) + definition con_ap_con_eq_con_con' {g : A → A} (p : id ∼ g) {x y : A} (q : x = y) {z : A} (s : g y = z) : p x ⬝ (ap g q ⬝ s) = q ⬝ (p y ⬝ s) := begin apply (eq.rec_on s), apply (eq.rec_on q), - apply (concat_1p (p x) ▹ idp) + apply (idp_con (p x) ▹ idp) end - -- Action of [apD10] and [ap10] on paths - -- ------------------------------------- + /- Action of [apD10] and [ap10] on paths -/ -- Application of paths between functions preserves the groupoid structure - definition apD10_1 (f : Πx, P x) (x : A) : apD10 (refl f) x = idp := idp + definition apD10_idp (f : Πx, P x) (x : A) : apD10 (refl f) x = idp := idp - definition apD10_pp {f f' f'' : Πx, P x} (h : f = f') (h' : f' = f'') (x : A) : + definition apD10_con {f f' f'' : Πx, P x} (h : f = f') (h' : f' = f'') (x : A) : apD10 (h ⬝ h') x = apD10 h x ⬝ apD10 h' x := eq.rec_on h (take h', eq.rec_on h' idp) h' - definition apD10_V {f g : Πx : A, P x} (h : f = g) (x : A) : + definition apD10_inv {f g : Πx : A, P x} (h : f = g) (x : A) : apD10 (h⁻¹) x = (apD10 h x)⁻¹ := eq.rec_on h idp - definition ap10_1 {f : A → B} (x : A) : ap10 (refl f) x = idp := idp + definition ap10_idp {f : A → B} (x : A) : ap10 (refl f) x = idp := idp - definition ap10_pp {f f' f'' : A → B} (h : f = f') (h' : f' = f'') (x : A) : - ap10 (h ⬝ h') x = ap10 h x ⬝ ap10 h' x := apD10_pp h h' x + definition ap10_con {f f' f'' : A → B} (h : f = f') (h' : f' = f'') (x : A) : + ap10 (h ⬝ h') x = ap10 h x ⬝ ap10 h' x := apD10_con h h' x - definition ap10_V {f g : A → B} (h : f = g) (x : A) : ap10 (h⁻¹) x = (ap10 h x)⁻¹ := - apD10_V h x + definition ap10_inv {f g : A → B} (h : f = g) (x : A) : ap10 (h⁻¹) x = (ap10 h x)⁻¹ := + apD10_inv h x -- [ap10] also behaves nicely on paths produced by [ap] definition ap_ap10 (f g : A → B) (h : B → C) (p : f = g) (a : A) : @@ -381,35 +390,34 @@ namespace eq eq.rec_on p idp - -- Transport and the groupoid structure of paths - -- --------------------------------------------- + /- Transport and the groupoid structure of paths -/ - definition transport_1 (P : A → Type) {x : A} (u : P x) : + definition tr_idp (P : A → Type) {x : A} (u : P x) : idp ▹ u = u := idp - definition transport_pp (P : A → Type) {x y z : A} (p : x = y) (q : y = z) (u : P x) : + definition tr_con (P : A → Type) {x y z : A} (p : x = y) (q : y = z) (u : P x) : p ⬝ q ▹ u = q ▹ p ▹ u := eq.rec_on q (eq.rec_on p idp) - definition transport_pV (P : A → Type) {x y : A} (p : x = y) (z : P y) : + definition tr_inv_tr (P : A → Type) {x y : A} (p : x = y) (z : P y) : p ▹ p⁻¹ ▹ z = z := - (transport_pp P (p⁻¹) p z)⁻¹ ⬝ ap (λr, transport P r z) (concat_Vp p) + (tr_con P (p⁻¹) p z)⁻¹ ⬝ ap (λr, transport P r z) (con.right_inv p) - definition transport_Vp (P : A → Type) {x y : A} (p : x = y) (z : P x) : + definition inv_tr_tr (P : A → Type) {x y : A} (p : x = y) (z : P x) : p⁻¹ ▹ p ▹ z = z := - (transport_pp P p (p⁻¹) z)⁻¹ ⬝ ap (λr, transport P r z) (concat_pV p) + (tr_con P p (p⁻¹) z)⁻¹ ⬝ ap (λr, transport P r z) (con.left_inv p) - definition transport_p_pp (P : A → Type) + definition tr_con_lemma (P : A → Type) {x y z w : A} (p : x = y) (q : y = z) (r : z = w) (u : P x) : - ap (λe, e ▹ u) (concat_p_pp p q r) ⬝ (transport_pp P (p ⬝ q) r u) ⬝ - ap (transport P r) (transport_pp P p q u) - = (transport_pp P p (q ⬝ r) u) ⬝ (transport_pp P q r (p ▹ u)) + ap (λe, e ▹ u) (con.assoc' p q r) ⬝ (tr_con P (p ⬝ q) r u) ⬝ + ap (transport P r) (tr_con P p q u) + = (tr_con P p (q ⬝ r) u) ⬝ (tr_con P q r (p ▹ u)) :> ((p ⬝ (q ⬝ r)) ▹ u = r ▹ q ▹ p ▹ u) := eq.rec_on r (eq.rec_on q (eq.rec_on p idp)) -- Here is another coherence lemma for transport. - definition transport_pVp (P : A → Type) {x y : A} (p : x = y) (z : P x) : - transport_pV P p (transport P p z) = ap (transport P p) (transport_Vp P p z) := + definition tr_inv_tr_lemma (P : A → Type) {x y : A} (p : x = y) (z : P x) : + tr_inv_tr P p (transport P p z) = ap (transport P p) (inv_tr_tr P p z) := eq.rec_on p idp -- Dependent transport in a doubly dependent type. @@ -428,17 +436,17 @@ namespace eq notation p `▹2`:65 x:64 := transport2 _ p _ x -- An alternative definition. - definition transport2_is_ap10 (Q : A → Type) {x y : A} {p q : x = y} (r : p = q) + definition tr2_eq_ap10 (Q : A → Type) {x y : A} {p q : x = y} (r : p = q) (z : Q x) : transport2 Q r z = ap10 (ap (transport Q) r) z := eq.rec_on r idp - definition transport2_p2p (P : A → Type) {x y : A} {p1 p2 p3 : x = y} + definition tr2_con (P : A → Type) {x y : A} {p1 p2 p3 : x = y} (r1 : p1 = p2) (r2 : p2 = p3) (z : P x) : transport2 P (r1 ⬝ r2) z = transport2 P r1 z ⬝ transport2 P r2 z := eq.rec_on r1 (eq.rec_on r2 idp) - definition transport2_V (Q : A → Type) {x y : A} {p q : x = y} (r : p = q) (z : Q x) : + definition tr2_inv (Q : A → Type) {x y : A} {p q : x = y} (r : p = q) (z : Q x) : transport2 Q (r⁻¹) z = ((transport2 Q r z)⁻¹) := eq.rec_on r idp @@ -448,19 +456,17 @@ namespace eq notation p `▹D2`:65 x:64 := transportD2 _ _ _ p _ _ x - definition concat_AT (P : A → Type) {x y : A} {p q : x = y} {z w : P x} (r : p = q) + definition ap_tr_con_tr2 (P : A → Type) {x y : A} {p q : x = y} {z w : P x} (r : p = q) (s : z = w) : ap (transport P p) s ⬝ transport2 P r w = transport2 P r z ⬝ ap (transport P q) s := - eq.rec_on r (concat_p1 _ ⬝ (concat_1p _)⁻¹) + eq.rec_on r (con_idp _ ⬝ (idp_con _)⁻¹) - -- TODO (from Coq library): What should this be called? - definition ap_transport {P Q : A → Type} {x y : A} (p : x = y) (f : Πx, P x → Q x) (z : P x) : + + definition fn_tr_eq_tr_fn {P Q : A → Type} {x y : A} (p : x = y) (f : Πx, P x → Q x) (z : P x) : f y (p ▹ z) = (p ▹ (f x z)) := eq.rec_on p idp - - -- Transporting in particular fibrations - -- ------------------------------------- + /- Transporting in particular fibrations -/ /- From the Coq HoTT library: @@ -472,12 +478,12 @@ namespace eq -/ -- Transporting in a constant fibration. - definition transport_const (p : x = y) (z : B) : transport (λx, B) p z = z := + definition tr_constant (p : x = y) (z : B) : transport (λx, B) p z = z := eq.rec_on p idp - definition transport2_const {p q : x = y} (r : p = q) (z : B) : - transport_const p z = transport2 (λu, B) r z ⬝ transport_const q z := - eq.rec_on r (concat_1p _)⁻¹ + definition tr2_constant {p q : x = y} (r : p = q) (z : B) : + tr_constant p z = transport2 (λu, B) r z ⬝ tr_constant q z := + eq.rec_on r (idp_con _)⁻¹ -- Transporting in a pulled back fibration. -- TODO: P can probably be implicit @@ -485,8 +491,8 @@ namespace eq transport (P ∘ f) p z = transport P (ap f p) z := eq.rec_on p idp - definition transport_precompose (f : A → B) (g g' : B → C) (p : g = g') : - transport (λh : B → C, g ∘ f = h ∘ f) p idp = ap (λh, h ∘ f) p := + definition ap_precompose (f : A → B) (g g' : B → C) (p : g = g') : + ap (λh, h ∘ f) p = transport (λh : B → C, g ∘ f = h ∘ f) p idp := eq.rec_on p idp definition apD10_ap_precompose (f : A → B) (g g' : B → C) (p : g = g') (a : A) : @@ -498,22 +504,20 @@ namespace eq eq.rec_on p idp -- A special case of [transport_compose] which seems to come up a lot. - definition transport_idmap_ap (P : A → Type) x y (p : x = y) (u : P x) : - transport P p u = transport (λz, z) (ap P p) u := + definition tr_eq_tr_id_ap (P : A → Type) x y (p : x = y) (u : P x) : + transport P p u = transport id (ap P p) u := eq.rec_on p idp - -- The behavior of [ap] and [apD] - -- ------------------------------ + /- The behavior of [ap] and [apD] -/ -- In a constant fibration, [apD] reduces to [ap], modulo [transport_const]. - definition apD_const (f : A → B) (p: x = y) : - apD f p = transport_const p (f x) ⬝ ap f p := + definition apD_eq_tr_constant_con_ap (f : A → B) (p: x = y) : + apD f p = tr_constant p (f x) ⬝ ap f p := eq.rec_on p idp - -- The 2-dimensional groupoid structure - -- ------------------------------------ + /- The 2-dimensional groupoid structure -/ -- Horizontal composition of 2-dimensional paths. definition concat2 {p p' : x = y} {q q' : y = z} (h : p = p') (h' : q = q') : @@ -527,127 +531,126 @@ namespace eq eq.rec_on h idp - -- Whiskering - -- ---------- + /- Whiskering -/ - definition whiskerL (p : x = y) {q r : y = z} (h : q = r) : p ⬝ q = p ⬝ r := + definition whisker_left (p : x = y) {q r : y = z} (h : q = r) : p ⬝ q = p ⬝ r := idp ◾ h - definition whiskerR {p q : x = y} (h : p = q) (r : y = z) : p ⬝ r = q ⬝ r := + definition whisker_right {p q : x = y} (h : p = q) (r : y = z) : p ⬝ r = q ⬝ r := h ◾ idp -- Unwhiskering, a.k.a. cancelling - definition cancelL {x y z : A} (p : x = y) (q r : y = z) : (p ⬝ q = p ⬝ r) → (q = r) := - eq.rec_on p (take r, eq.rec_on r (take q a, (concat_1p q)⁻¹ ⬝ a)) r q + definition cancel_left {x y z : A} (p : x = y) (q r : y = z) : (p ⬝ q = p ⬝ r) → (q = r) := + eq.rec_on p (take r, eq.rec_on r (take q a, (idp_con q)⁻¹ ⬝ a)) r q - definition cancelR {x y z : A} (p q : x = y) (r : y = z) : (p ⬝ r = q ⬝ r) → (p = q) := - eq.rec_on r (eq.rec_on p (take q a, a ⬝ concat_p1 q)) q + definition cancel_right {x y z : A} (p q : x = y) (r : y = z) : (p ⬝ r = q ⬝ r) → (p = q) := + eq.rec_on r (eq.rec_on p (take q a, a ⬝ con_idp q)) q -- Whiskering and identity paths. - definition whiskerR_p1 {p q : x = y} (h : p = q) : - (concat_p1 p)⁻¹ ⬝ whiskerR h idp ⬝ concat_p1 q = h := + definition whisker_right_idp_right {p q : x = y} (h : p = q) : + (con_idp p)⁻¹ ⬝ whisker_right h idp ⬝ con_idp q = h := eq.rec_on h (eq.rec_on p idp) - definition whiskerR_1p (p : x = y) (q : y = z) : - whiskerR idp q = idp :> (p ⬝ q = p ⬝ q) := + definition whisker_right_idp_left (p : x = y) (q : y = z) : + whisker_right idp q = idp :> (p ⬝ q = p ⬝ q) := eq.rec_on q idp - definition whiskerL_p1 (p : x = y) (q : y = z) : - whiskerL p idp = idp :> (p ⬝ q = p ⬝ q) := + definition whisker_left_idp_right (p : x = y) (q : y = z) : + whisker_left p idp = idp :> (p ⬝ q = p ⬝ q) := eq.rec_on q idp - definition whiskerL_1p {p q : x = y} (h : p = q) : - (concat_1p p) ⁻¹ ⬝ whiskerL idp h ⬝ concat_1p q = h := + definition whisker_left_idp_left {p q : x = y} (h : p = q) : + (idp_con p) ⁻¹ ⬝ whisker_left idp h ⬝ idp_con q = h := eq.rec_on h (eq.rec_on p idp) - definition concat2_p1 {p q : x = y} (h : p = q) : - h ◾ idp = whiskerR h idp :> (p ⬝ idp = q ⬝ idp) := + definition con2_idp {p q : x = y} (h : p = q) : + h ◾ idp = whisker_right h idp :> (p ⬝ idp = q ⬝ idp) := eq.rec_on h idp - definition concat2_1p {p q : x = y} (h : p = q) : - idp ◾ h = whiskerL idp h :> (idp ⬝ p = idp ⬝ q) := + definition idp_con2 {p q : x = y} (h : p = q) : + idp ◾ h = whisker_left idp h :> (idp ⬝ p = idp ⬝ q) := eq.rec_on h idp -- TODO: note, 4 inductions -- The interchange law for concatenation. - definition concat_concat2 {p p' p'' : x = y} {q q' q'' : y = z} + definition con2_con_con2 {p p' p'' : x = y} {q q' q'' : y = z} (a : p = p') (b : p' = p'') (c : q = q') (d : q' = q'') : (a ◾ c) ⬝ (b ◾ d) = (a ⬝ b) ◾ (c ⬝ d) := eq.rec_on d (eq.rec_on c (eq.rec_on b (eq.rec_on a idp))) - definition concat_whisker {x y z : A} (p p' : x = y) (q q' : y = z) (a : p = p') (b : q = q') : - (whiskerR a q) ⬝ (whiskerL p' b) = (whiskerL p b) ⬝ (whiskerR a q') := - eq.rec_on b (eq.rec_on a (concat_1p _)⁻¹) + definition whisker_right_con_whisker_left {x y z : A} (p p' : x = y) (q q' : y = z) (a : p = p') (b : q = q') : + (whisker_right a q) ⬝ (whisker_left p' b) = (whisker_left p b) ⬝ (whisker_right a q') := + eq.rec_on b (eq.rec_on a (idp_con _)⁻¹) -- Structure corresponding to the coherence equations of a bicategory. -- The "pentagonator": the 3-cell witnessing the associativity pentagon. definition pentagon {v w x y z : A} (p : v = w) (q : w = x) (r : x = y) (s : y = z) : - whiskerL p (concat_p_pp q r s) - ⬝ concat_p_pp p (q ⬝ r) s - ⬝ whiskerR (concat_p_pp p q r) s - = concat_p_pp p q (r ⬝ s) ⬝ concat_p_pp (p ⬝ q) r s := + whisker_left p (con.assoc' q r s) + ⬝ con.assoc' p (q ⬝ r) s + ⬝ whisker_right (con.assoc' p q r) s + = con.assoc' p q (r ⬝ s) ⬝ con.assoc' (p ⬝ q) r s := eq.rec_on s (eq.rec_on r (eq.rec_on q (eq.rec_on p idp))) -- The 3-cell witnessing the left unit triangle. definition triangulator (p : x = y) (q : y = z) : - concat_p_pp p idp q ⬝ whiskerR (concat_p1 p) q = whiskerL p (concat_1p q) := + con.assoc' p idp q ⬝ whisker_right (con_idp p) q = whisker_left p (idp_con q) := eq.rec_on q (eq.rec_on p idp) definition eckmann_hilton {x:A} (p q : idp = idp :> (x = x)) : p ⬝ q = q ⬝ p := - (!whiskerR_p1 ◾ !whiskerL_1p)⁻¹ - ⬝ (!concat_p1 ◾ !concat_p1) - ⬝ (!concat_1p ◾ !concat_1p) - ⬝ !concat_whisker - ⬝ (!concat_1p ◾ !concat_1p)⁻¹ - ⬝ (!concat_p1 ◾ !concat_p1)⁻¹ - ⬝ (!whiskerL_1p ◾ !whiskerR_p1) + (!whisker_right_idp_right ◾ !whisker_left_idp_left)⁻¹ + ⬝ (!con_idp ◾ !con_idp) + ⬝ (!idp_con ◾ !idp_con) + ⬝ !whisker_right_con_whisker_left + ⬝ (!idp_con ◾ !idp_con)⁻¹ + ⬝ (!con_idp ◾ !con_idp)⁻¹ + ⬝ (!whisker_left_idp_left ◾ !whisker_right_idp_right) -- The action of functions on 2-dimensional paths definition ap02 (f:A → B) {x y : A} {p q : x = y} (r : p = q) : ap f p = ap f q := eq.rec_on r idp - definition ap02_pp (f : A → B) {x y : A} {p p' p'' : x = y} (r : p = p') (r' : p' = p'') : + definition ap02_con (f : A → B) {x y : A} {p p' p'' : x = y} (r : p = p') (r' : p' = p'') : ap02 f (r ⬝ r') = ap02 f r ⬝ ap02 f r' := eq.rec_on r (eq.rec_on r' idp) - definition ap02_p2p (f : A → B) {x y z : A} {p p' : x = y} {q q' :y = z} (r : p = p') + definition ap02_con2 (f : A → B) {x y z : A} {p p' : x = y} {q q' :y = z} (r : p = p') (s : q = q') : - ap02 f (r ◾ s) = ap_pp f p q + ap02 f (r ◾ s) = ap_con f p q ⬝ (ap02 f r ◾ ap02 f s) - ⬝ (ap_pp f p' q')⁻¹ := + ⬝ (ap_con f p' q')⁻¹ := eq.rec_on r (eq.rec_on s (eq.rec_on q (eq.rec_on p idp))) -- eq.rec_on r (eq.rec_on s (eq.rec_on p (eq.rec_on q idp))) definition apD02 {p q : x = y} (f : Π x, P x) (r : p = q) : apD f p = transport2 P r (f x) ⬝ apD f q := - eq.rec_on r (concat_1p _)⁻¹ + eq.rec_on r (idp_con _)⁻¹ -- And now for a lemma whose statement is much longer than its proof. - definition apD02_pp (P : A → Type) (f : Π x:A, P x) {x y : A} + definition apD02_con (P : A → Type) (f : Π x:A, P x) {x y : A} {p1 p2 p3 : x = y} (r1 : p1 = p2) (r2 : p2 = p3) : apD02 f (r1 ⬝ r2) = apD02 f r1 - ⬝ whiskerL (transport2 P r1 (f x)) (apD02 f r2) - ⬝ concat_p_pp _ _ _ - ⬝ (whiskerR ((transport2_p2p P r1 r2 (f x))⁻¹) (apD f p3)) := + ⬝ whisker_left (transport2 P r1 (f x)) (apD02 f r2) + ⬝ con.assoc' _ _ _ + ⬝ (whisker_right ((tr2_con P r1 r2 (f x))⁻¹) (apD f p3)) := eq.rec_on r2 (eq.rec_on r1 (eq.rec_on p1 idp)) end eq namespace eq variables {A B C D E : Type} {a a' : A} {b b' : B} {c c' : C} {d d' : D} -theorem congr_arg2 (f : A → B → C) (Ha : a = a') (Hb : b = b') : f a b = f a' b' := +theorem ap011 (f : A → B → C) (Ha : a = a') (Hb : b = b') : f a b = f a' b' := eq.rec_on Ha (eq.rec_on Hb idp) -theorem congr_arg3 (f : A → B → C → D) (Ha : a = a') (Hb : b = b') (Hc : c = c') +theorem ap0111 (f : A → B → C → D) (Ha : a = a') (Hb : b = b') (Hc : c = c') : f a b c = f a' b' c' := -eq.rec_on Ha (congr_arg2 (f a) Hb Hc) +eq.rec_on Ha (ap011 (f a) Hb Hc) -theorem congr_arg4 (f : A → B → C → D → E) (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d') +theorem ap01111 (f : A → B → C → D → E) (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d') : f a b c d = f a' b' c' d' := -eq.rec_on Ha (congr_arg3 (f a) Hb Hc Hd) +eq.rec_on Ha (ap0111 (f a) Hb Hc Hd) end eq @@ -659,60 +662,8 @@ variables {a a' : A} {c : C a b} {c' : C a' b'} {d : D a b c} {d' : D a' b' c'} -theorem dcongr_arg2 (f : Πa, B a → F) (Ha : a = a') (Hb : (Ha ▹ b) = b') +theorem apD011 (f : Πa, B a → F) (Ha : a = a') (Hb : (Ha ▹ b) = b') : f a b = f a' b' := eq.rec_on Hb (eq.rec_on Ha idp) - /- From the Coq version: - - -- ** Tactics, hints, and aliases - - -- [concat], with arguments flipped. Useful mainly in the idiom [apply (concatR (expression))]. - -- Given as a notation not a definition so that the resultant terms are literally instances of - -- [concat], with no unfolding required. - Notation concatR := (λp q, concat q p). - - Hint Resolve - concat_1p concat_p1 concat_p_pp - inv_pp inv_V - : path_hints. - - (* First try at a paths db - We want the RHS of the equation to become strictly simpler - Hint Rewrite - ⬝concat_p1 - ⬝concat_1p - ⬝concat_p_pp (* there is a choice here !*) - ⬝concat_pV - ⬝concat_Vp - ⬝concat_V_pp - ⬝concat_p_Vp - ⬝concat_pp_V - ⬝concat_pV_p - (*⬝inv_pp*) (* I am not sure about this one - ⬝inv_V - ⬝moveR_Mp - ⬝moveR_pM - ⬝moveL_Mp - ⬝moveL_pM - ⬝moveL_1M - ⬝moveL_M1 - ⬝moveR_M1 - ⬝moveR_1M - ⬝ap_1 - (* ⬝ap_pp - ⬝ap_p_pp ?*) - ⬝inverse_ap - ⬝ap_idmap - (* ⬝ap_compose - ⬝ap_compose'*) - ⬝ap_const - (* Unsure about naturality of [ap], was absent in the old implementation*) - ⬝apD10_1 - :paths. - - Ltac hott_simpl := - autorewrite with paths in * |- * ; auto with path_hints. - - -/ end eq diff --git a/hott/init/priority.hlean b/hott/init/priority.hlean index 8a23b06957..705ecd7796 100644 --- a/hott/init/priority.hlean +++ b/hott/init/priority.hlean @@ -2,6 +2,7 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Module: init.priority Authors: Leonardo de Moura -/ prelude diff --git a/hott/init/relation.hlean b/hott/init/relation.hlean index ef673bcd5e..a175be5b8b 100644 --- a/hott/init/relation.hlean +++ b/hott/init/relation.hlean @@ -1,6 +1,8 @@ /- Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. + +Module: init.relation Authors: Leonardo de Moura -/ prelude diff --git a/hott/init/reserved_notation.hlean b/hott/init/reserved_notation.hlean index a4cddb53e8..b76aad921b 100644 --- a/hott/init/reserved_notation.hlean +++ b/hott/init/reserved_notation.hlean @@ -2,6 +2,7 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Module: init.reserved_notation Authors: Leonardo de Moura Basic datatypes diff --git a/hott/init/tactic.hlean b/hott/init/tactic.hlean index ce9883c9aa..d9d133f0ef 100644 --- a/hott/init/tactic.hlean +++ b/hott/init/tactic.hlean @@ -2,6 +2,7 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Module: init.tactic Author: Leonardo de Moura This is just a trick to embed the 'tactic language' as a Lean diff --git a/hott/init/trunc.hlean b/hott/init/trunc.hlean index d8ed45571d..4cf72e01c1 100644 --- a/hott/init/trunc.hlean +++ b/hott/init/trunc.hlean @@ -1,31 +1,38 @@ --- Copyright (c) 2014 Microsoft Corporation. All rights reserved. --- Released under Apache 2.0 license as described in the file LICENSE. --- Authors: Jeremy Avigad, Floris van Doorn --- Ported from Coq HoTT +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Module: init.trunc +Authors: Jeremy Avigad, Floris van Doorn + +Ported from Coq HoTT. +-/ + prelude import .path .logic .datatypes .equiv .types.empty .types.sigma open eq nat sigma unit -set_option pp.universes true --- Truncation levels --- ----------------- +/- Truncation levels -/ --- TODO: make everything universe polymorphic - --- TODO: everything definition with a hprop as codomain can be a theorem? +-- TODO: can we replace some definitions with a hprop as codomain by theorems? /- truncation indices -/ -namespace truncation +namespace is_trunc inductive trunc_index : Type₁ := minus_two : trunc_index, - trunc_S : trunc_index → trunc_index + succ : trunc_index → trunc_index - postfix `.+1`:(max+1) := trunc_index.trunc_S + /- + notation for trunc_index is -2, -1, 0, 1, ... + from 0 and up this comes from a coercion from num to trunc_index (via nat) + -/ + postfix `.+1`:(max+1) := trunc_index.succ postfix `.+2`:(max+1) := λn, (n .+1 .+1) notation `-2` := trunc_index.minus_two - notation `-1` := (-2.+1) + notation `-1` := -2.+1 + export [coercions] nat -- does this export namespace trunc_index definition add (n m : trunc_index) : trunc_index := @@ -35,20 +42,18 @@ namespace truncation trunc_index.rec_on n (λm, unit) (λ n p m, trunc_index.rec_on m (λ p, empty) (λ m q p, p m) p) m end trunc_index - -- Coq calls this `-2+`, but `+2+` looks more natural, since trunc_index_add 0 0 = 2 infix `+2+`:65 := trunc_index.add notation x <= y := trunc_index.leq x y notation x ≤ y := trunc_index.leq x y namespace trunc_index - definition succ_le {n m : trunc_index} (H : n ≤ m) : n.+1 ≤ m.+1 := H - definition succ_le_cancel {n m : trunc_index} (H : n.+1 ≤ m.+1) : n ≤ m := H + definition succ_le_succ {n m : trunc_index} (H : n ≤ m) : n.+1 ≤ m.+1 := H + definition le_of_succ_le_succ {n m : trunc_index} (H : n.+1 ≤ m.+1) : n ≤ m := H definition minus_two_le (n : trunc_index) : -2 ≤ n := star - definition not_succ_le_minus_two {n : trunc_index} (H : n .+1 ≤ -2) : empty := H + definition empty_of_succ_le_minus_two {n : trunc_index} (H : n .+1 ≤ -2) : empty := H end trunc_index - - definition nat_to_trunc_index [coercion] (n : nat) : trunc_index := + definition trunc_index.of_nat [coercion] (n : nat) : trunc_index := nat.rec_on n (-1.+1) (λ n k, k.+1) /- truncated types -/ @@ -62,29 +67,29 @@ namespace truncation (center : A) (contr : Π(a : A), center = a) definition is_trunc_internal (n : trunc_index) : Type → Type := - trunc_index.rec_on n (λA, contr_internal A) + trunc_index.rec_on n + (λA, contr_internal A) (λn trunc_n A, (Π(x y : A), trunc_n (x = y))) - structure is_trunc [class] (n : trunc_index) (A : Type) := - (to_internal : is_trunc_internal n A) +end is_trunc - -- should this be notation or definitions? - notation `is_contr` := is_trunc -2 - notation `is_hprop` := is_trunc -1 - notation `is_hset` := is_trunc (nat_to_trunc_index nat.zero) - -- definition is_contr := is_trunc -2 - -- definition is_hprop := is_trunc -1 - -- definition is_hset := is_trunc 0 +open is_trunc +structure is_trunc [class] (n : trunc_index) (A : Type) := + (to_internal : is_trunc_internal n A) +open nat num is_trunc.trunc_index +namespace is_trunc + + abbreviation is_contr := is_trunc -2 + abbreviation is_hprop := is_trunc -1 + abbreviation is_hset := is_trunc nat.zero variables {A B : Type} - -- TODO: rename to is_trunc_succ - definition is_trunc_succ (A : Type) (n : trunc_index) [H : ∀x y : A, is_trunc n (x = y)] + definition is_trunc_succ_intro (A : Type) (n : trunc_index) [H : ∀x y : A, is_trunc n (x = y)] : is_trunc n.+1 A := is_trunc.mk (λ x y, !is_trunc.to_internal) - -- TODO: rename to is_trunc_path - definition succ_is_trunc (n : trunc_index) [H : is_trunc (n.+1) A] (x y : A) : is_trunc n (x = y) := + definition is_trunc_eq (n : trunc_index) [H : is_trunc (n.+1) A] (x y : A) : is_trunc n (x = y) := is_trunc.mk (!is_trunc.to_internal x y) /- contractibility -/ @@ -98,157 +103,159 @@ namespace truncation definition contr [H : is_contr A] (a : A) : !center = a := @contr_internal.contr A !is_trunc.to_internal a - definition path_contr [H : is_contr A] (x y : A) : x = y := + definition center_eq [H : is_contr A] (x y : A) : x = y := contr x⁻¹ ⬝ (contr y) - definition path2_contr {A : Type} [H : is_contr A] {x y : A} (p q : x = y) : p = q := - have K : ∀ (r : x = y), path_contr x y = r, from (λ r, eq.rec_on r !concat_Vp), + definition hprop_eq {A : Type} [H : is_contr A] {x y : A} (p q : x = y) : p = q := + have K : ∀ (r : x = y), center_eq x y = r, from (λ r, eq.rec_on r !con.right_inv), K p⁻¹ ⬝ K q - definition contr_paths_contr [instance] {A : Type} [H : is_contr A] (x y : A) : is_contr (x = y) := - is_contr.mk !path_contr (λ p, !path2_contr) + definition is_contr_eq [instance] {A : Type} [H : is_contr A] (x y : A) : is_contr (x = y) + := + is_contr.mk !center_eq (λ p, !hprop_eq) /- truncation is upward close -/ -- n-types are also (n+1)-types - definition trunc_succ [instance] (A : Type) (n : trunc_index) [H : is_trunc n A] : is_trunc (n.+1) A := + definition is_trunc_succ [instance] (A : Type) (n : trunc_index) [H : is_trunc n A] : is_trunc (n.+1) A := trunc_index.rec_on n - (λ A (H : is_contr A), !is_trunc_succ) - (λ n IH A (H : is_trunc (n.+1) A), @is_trunc_succ _ _ (λ x y, IH _ !succ_is_trunc)) + (λ A (H : is_contr A), !is_trunc_succ_intro) + (λ n IH A (H : is_trunc (n.+1) A), @is_trunc_succ_intro _ _ (λ x y, IH _ !is_trunc_eq)) A H --in the proof the type of H is given explicitly to make it available for class inference - - definition trunc_leq (A : Type) (n m : trunc_index) (Hnm : n ≤ m) + definition is_trunc_of_leq (A : Type) (n m : trunc_index) (Hnm : n ≤ m) [Hn : is_trunc n A] : is_trunc m A := have base : ∀k A, k ≤ -2 → is_trunc k A → (is_trunc -2 A), from λ k A, trunc_index.cases_on k (λh1 h2, h2) - (λk h1 h2, empty.elim (is_trunc -2 A) (trunc_index.not_succ_le_minus_two h1)), + (λk h1 h2, empty.elim (is_trunc -2 A) (trunc_index.empty_of_succ_le_minus_two h1)), have step : Π (m : trunc_index) (IHm : Π (n : trunc_index) (A : Type), n ≤ m → is_trunc n A → is_trunc m A) (n : trunc_index) (A : Type) (Hnm : n ≤ m .+1) (Hn : is_trunc n A), is_trunc m .+1 A, from λm IHm n, trunc_index.rec_on n - (λA Hnm Hn, @trunc_succ A m (IHm -2 A star Hn)) + (λA Hnm Hn, @is_trunc_succ A m (IHm -2 A star Hn)) (λn IHn A Hnm (Hn : is_trunc n.+1 A), - @is_trunc_succ A m (λx y, IHm n (x = y) (trunc_index.succ_le_cancel Hnm) !succ_is_trunc)), + @is_trunc_succ_intro A m (λx y, IHm n (x = y) (trunc_index.le_of_succ_le_succ Hnm) !is_trunc_eq)), trunc_index.rec_on m base step n A Hnm Hn - -- the following cannot be instances in their current form, because it is looping - definition trunc_contr (A : Type) (n : trunc_index) [H : is_contr A] : is_trunc n A := + -- the following cannot be instances in their current form, because they are looping + definition is_trunc_of_is_contr (A : Type) (n : trunc_index) [H : is_contr A] : is_trunc n A := trunc_index.rec_on n H _ - definition trunc_hprop (A : Type) (n : trunc_index) [H : is_hprop A] + definition is_trunc_succ_of_is_hprop (A : Type) (n : trunc_index) [H : is_hprop A] : is_trunc (n.+1) A := - trunc_leq A -1 (n.+1) star + is_trunc_of_leq A -1 (n.+1) star - definition trunc_hset (A : Type) (n : trunc_index) [H : is_hset A] + definition is_trunc_succ_succ_of_is_hset (A : Type) (n : trunc_index) [H : is_hset A] : is_trunc (n.+2) A := - trunc_leq A nat.zero (n.+2) star + is_trunc_of_leq A nat.zero (n.+2) star /- hprops -/ definition is_hprop.elim [H : is_hprop A] (x y : A) : x = y := - @center _ !succ_is_trunc + @center _ !is_trunc_eq - definition contr_inhabited_hprop {A : Type} [H : is_hprop A] (x : A) : is_contr A := + definition is_contr_of_inhabited_hprop {A : Type} [H : is_hprop A] (x : A) : is_contr A := is_contr.mk x (λy, !is_hprop.elim) --Coq has the following as instance, but doesn't look too useful - definition hprop_inhabited_contr {A : Type} (H : A → is_contr A) : is_hprop A := - @is_trunc_succ A -2 + definition is_hprop_of_imp_is_contr {A : Type} (H : A → is_contr A) : is_hprop A := + @is_trunc_succ_intro A -2 (λx y, have H2 [visible] : is_contr A, from H x, - !contr_paths_contr) + !is_contr_eq) definition is_hprop.mk {A : Type} (H : ∀x y : A, x = y) : is_hprop A := - hprop_inhabited_contr (λ x, is_contr.mk x (H x)) + is_hprop_of_imp_is_contr (λ x, is_contr.mk x (H x)) /- hsets -/ definition is_hset.mk (A : Type) (H : ∀(x y : A) (p q : x = y), p = q) : is_hset A := - @is_trunc_succ _ _ (λ x y, is_hprop.mk (H x y)) + @is_trunc_succ_intro _ _ (λ x y, is_hprop.mk (H x y)) definition is_hset.elim [H : is_hset A] ⦃x y : A⦄ (p q : x = y) : p = q := - @is_hprop.elim _ !succ_is_trunc p q + @is_hprop.elim _ !is_trunc_eq p q /- instances -/ - definition contr_basedpaths [instance] {A : Type} (a : A) : is_contr (Σ(x : A), a = x) := + definition is_contr_sigma_eq [instance] {A : Type} (a : A) : is_contr (Σ(x : A), a = x) := is_contr.mk (sigma.mk a idp) (λp, sigma.rec_on p (λ b q, eq.rec_on q idp)) - definition unit_contr [instance] : is_contr unit := + definition is_contr_unit [instance] : is_contr unit := is_contr.mk star (λp, unit.rec_on p idp) - definition empty_hprop [instance] : is_hprop empty := + definition is_hprop_empty [instance] : is_hprop empty := is_hprop.mk (λx, !empty.elim x) /- truncated universe -/ structure trunctype (n : trunc_index) := (trunctype_type : Type) (is_trunc_trunctype_type : is_trunc n trunctype_type) - local attribute trunctype.trunctype_type [coercion] + attribute trunctype.trunctype_type [coercion] + attribute trunctype.is_trunc_trunctype_type [instance] notation n `-Type` := trunctype n - notation `hprop` := -1-Type - notation `hset` := 0-Type + abbreviation hprop := -1-Type + abbreviation hset := (-1.+1)-Type - definition hprop.mk := @trunctype.mk -1 - definition hset.mk := @trunctype.mk nat.zero - - --what does the following line in Coq do? - --Canonical Structure default_TruncType := fun n T P => (@BuildTruncType n T P). + protected definition hprop.mk := @trunctype.mk -1 + protected definition hset.mk := @trunctype.mk (-1.+1) /- interaction with equivalences -/ section open is_equiv equiv - --should we remove the following two theorems as they are special cases of "trunc_equiv" - definition equiv_preserves_contr (f : A → B) [Hf : is_equiv f] [HA: is_contr A] : (is_contr B) := - is_contr.mk (f (center A)) (λp, moveR_M f !contr) + --should we remove the following two theorems as they are special cases of + --"is_trunc_is_equiv_closed" + definition is_contr_is_equiv_closed (f : A → B) [Hf : is_equiv f] [HA: is_contr A] : (is_contr B) := + is_contr.mk (f (center A)) (λp, eq_of_eq_inv f !contr) - theorem contr_equiv (H : A ≃ B) [HA: is_contr A] : is_contr B := - @equiv_preserves_contr _ _ (to_fun H) (to_is_equiv H) _ + theorem is_contr_equiv_closed (H : A ≃ B) [HA: is_contr A] : is_contr B := + @is_contr_is_equiv_closed _ _ (to_fun H) (to_is_equiv H) _ - definition contr_equiv_contr [HA : is_contr A] [HB : is_contr B] : A ≃ B := + definition equiv_of_is_contr_of_is_contr [HA : is_contr A] [HB : is_contr B] : A ≃ B := equiv.mk (λa, center B) (is_equiv.adjointify (λa, center B) (λb, center A) contr contr) - definition trunc_equiv (n : trunc_index) (f : A → B) [H : is_equiv f] [HA : is_trunc n A] - : is_trunc n B := + definition is_trunc_is_equiv_closed (n : trunc_index) (f : A → B) [H : is_equiv f] + [HA : is_trunc n A] : is_trunc n B := trunc_index.rec_on n - (λA (HA : is_contr A) B f (H : is_equiv f), !equiv_preserves_contr) - (λn IH A (HA : is_trunc n.+1 A) B f (H : is_equiv f), @is_trunc_succ _ _ (λ x y : B, - IH (f⁻¹ x = f⁻¹ y) !succ_is_trunc (x = y) ((ap (f⁻¹))⁻¹) !inv_closed)) + (λA (HA : is_contr A) B f (H : is_equiv f), !is_contr_is_equiv_closed) + (λn IH A (HA : is_trunc n.+1 A) B f (H : is_equiv f), @is_trunc_succ_intro _ _ (λ x y : B, + IH (f⁻¹ x = f⁻¹ y) !is_trunc_eq (x = y) ((ap (f⁻¹))⁻¹) !is_equiv_inv)) A HA B f H - definition trunc_equiv' (n : trunc_index) (f : A ≃ B) [HA : is_trunc n A] : is_trunc n B := - trunc_equiv n (to_fun f) + definition is_trunc_equiv_closed (n : trunc_index) (f : A ≃ B) [HA : is_trunc n A] + : is_trunc n B := + is_trunc_is_equiv_closed n (to_fun f) - definition isequiv_iff_hprop [HA : is_hprop A] [HB : is_hprop B] (f : A → B) (g : B → A) - : is_equiv f := - is_equiv.adjointify f g (λb, !is_hprop.elim) (λa, !is_hprop.elim) + definition is_equiv_of_is_hprop [HA : is_hprop A] [HB : is_hprop B] (f : A → B) (g : B → A) + : is_equiv f := + is_equiv.mk g (λb, !is_hprop.elim) (λa, !is_hprop.elim) (λa, !is_hset.elim) - -- definition equiv_iff_hprop_uncurried [HA : is_hprop A] [HB : is_hprop B] : (A ↔ B) → (A ≃ B) := sorry + definition equiv_of_is_hprop [HA : is_hprop A] [HB : is_hprop B] (f : A → B) (g : B → A) + : A ≃ B := + equiv.mk f (is_equiv_of_is_hprop f g) - definition equiv_iff_hprop [HA : is_hprop A] [HB : is_hprop B] (f : A → B) (g : B → A) : A ≃ B := - equiv.mk f (isequiv_iff_hprop f g) + definition equiv_of_iff_of_is_hprop [HA : is_hprop A] [HB : is_hprop B] (H : A ↔ B) : A ≃ B := + equiv_of_is_hprop (iff.elim_left H) (iff.elim_right H) end /- interaction with the Unit type -/ -- A contractible type is equivalent to [Unit]. *) - definition equiv_contr_unit [H : is_contr A] : A ≃ unit := + definition equiv_unit_of_is_contr [H : is_contr A] : A ≃ unit := equiv.mk (λ (x : A), ⋆) (is_equiv.mk (λ (u : unit), center A) (λ (u : unit), unit.rec_on u idp) (λ (x : A), contr x) - (λ (x : A), (!ap_const)⁻¹)) + (λ (x : A), (!ap_constant)⁻¹)) -- TODO: port "Truncated morphisms" -end truncation +end is_trunc diff --git a/hott/init/types/empty.hlean b/hott/init/types/empty.hlean index 077c7cd59b..f9f221b519 100644 --- a/hott/init/types/empty.hlean +++ b/hott/init/types/empty.hlean @@ -1,6 +1,10 @@ --- Copyright (c) 2014 Microsoft Corporation. All rights reserved. --- Released under Apache 2.0 license as described in the file LICENSE. --- Author: Jeremy Avigad, Floris van Doorn, Jakob von Raumer +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Module: init.types.empty +Author: Jeremy Avigad, Floris van Doorn, Jakob von Raumer +-/ prelude import ..datatypes ..logic diff --git a/hott/init/types/prod.hlean b/hott/init/types/prod.hlean index 127759c2a3..407c552655 100644 --- a/hott/init/types/prod.hlean +++ b/hott/init/types/prod.hlean @@ -2,10 +2,11 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Module: init.types.prod Author: Leonardo de Moura, Jeremy Avigad -/ prelude -import ..wf +import ..wf ..num definition pair := @prod.mk @@ -14,6 +15,13 @@ namespace prod notation A * B := prod A B notation A × B := prod A B + namespace ops + postfix `.1`:(max+1) := pr1 + postfix `.2`:(max+1) := pr2 + abbreviation pr₁ := @pr1 + abbreviation pr₂ := @pr2 + end ops + namespace low_precedence_times reserve infixr `*`:30 -- conflicts with notation for multiplication @@ -21,7 +29,7 @@ namespace prod end low_precedence_times - -- TODO: add lemmas about flip to /hott/types/prod.hlean + -- TODO: add lemmas about flip to hott/types/prod.hlean definition flip {A B : Type} (a : A × B) : B × A := pair (pr2 a) (pr1 a) notation `pr₁` := pr1 diff --git a/hott/init/types/sigma.hlean b/hott/init/types/sigma.hlean index 316bb4d5eb..c09367b158 100644 --- a/hott/init/types/sigma.hlean +++ b/hott/init/types/sigma.hlean @@ -1,6 +1,8 @@ /- Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. + +Module: init.types.sigma Authors: Leonardo de Moura, Jeremy Avigad, Floris van Doorn -/ prelude @@ -12,12 +14,12 @@ mk :: (pr1 : A) (pr2 : B pr1) notation `Σ` binders `,` r:(scoped P, sigma P) := r namespace sigma - notation `pr₁` := pr1 - notation `pr₂` := pr2 notation `⟨`:max t:(foldr `,` (e r, mk e r)) `⟩`:0 := t --input ⟨ ⟩ as \< \> namespace ops postfix `.1`:(max+1) := pr1 postfix `.2`:(max+1) := pr2 + abbreviation pr₁ := @pr1 + abbreviation pr₂ := @pr2 end ops end sigma diff --git a/hott/init/types/sum.hlean b/hott/init/types/sum.hlean index 664a2b5e65..abf0c335dc 100644 --- a/hott/init/types/sum.hlean +++ b/hott/init/types/sum.hlean @@ -2,6 +2,7 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Module: init.types.sum Author: Leonardo de Moura, Jeremy Avigad -/ prelude diff --git a/hott/init/util.hlean b/hott/init/util.hlean index 4c36ab16e0..259d755f57 100644 --- a/hott/init/util.hlean +++ b/hott/init/util.hlean @@ -2,6 +2,7 @@ Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Module: init.util Author: Leonardo de Moura Auxiliary definitions used by automation @@ -9,7 +10,7 @@ Auxiliary definitions used by automation prelude import init.trunc -open truncation +open is_trunc definition eq_rec_eq.{l₁ l₂} {A : Type.{l₁}} {B : A → Type.{l₂}} [h : is_hset A] {a : A} (b : B a) (p : a = a) : b = @eq.rec.{l₂ l₁} A a (λ (a' : A) (h : a = a'), B a') b a p := diff --git a/hott/init/wf.hlean b/hott/init/wf.hlean index 27df72e532..9928e15b32 100644 --- a/hott/init/wf.hlean +++ b/hott/init/wf.hlean @@ -1,6 +1,8 @@ /- Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. + +Module: init.wf Author: Leonardo de Moura -/ prelude diff --git a/hott/logic.hlean b/hott/logic.hlean index a422a9e5be..879fbb80dd 100644 --- a/hott/logic.hlean +++ b/hott/logic.hlean @@ -1,3 +1,4 @@ +exit --javra: Maybe this should go somewhere else open eq diff --git a/hott/trunc.hlean b/hott/trunc.hlean deleted file mode 100644 index 11e78c0e61..0000000000 --- a/hott/trunc.hlean +++ /dev/null @@ -1,61 +0,0 @@ --- Copyright (c) 2015 Jakob von Raumer. All rights reserved. --- Released under Apache 2.0 license as described in the file LICENSE. --- Authors: Jakob von Raumer --- Truncation properties of truncatedness - -import types.pi - -open truncation sigma sigma.ops pi function eq equiv - -namespace truncation - - definition is_contr.sigma_char (A : Type) : - (Σ (center : A), Π (a : A), center = a) ≃ (is_contr A) := - begin - fapply equiv.mk, - intro S, apply is_contr.mk, exact S.2, - fapply is_equiv.adjointify, - intro H, apply sigma.mk, exact (@contr A H), - intro H, apply (is_trunc.rec_on H), intro Hint, - apply (contr_internal.rec_on Hint), intros (H1, H2), - apply idp, - intro S, apply (sigma.rec_on S), intros (H1, H2), - apply idp, - end - - set_option pp.implicit true - definition is_trunc.pi_char (n : trunc_index) (A : Type) : - (Π (x y : A), is_trunc n (x = y)) ≃ (is_trunc (n .+1) A) := - begin - fapply equiv.mk, - intro H, apply is_trunc_succ, - fapply is_equiv.adjointify, - intros (H, x, y), apply succ_is_trunc, - intro H, apply (is_trunc.rec_on H), intro Hint, apply idp, - intro P, - exact sorry, - end - - definition is_trunc_is_hprop {n : trunc_index} : - Π (A : Type), is_hprop (is_trunc n A) := - begin - apply (trunc_index.rec_on n), - intro A, - apply trunc_equiv, apply equiv.to_is_equiv, - apply is_contr.sigma_char, - apply (@is_hprop.mk), intros, - fapply sigma.path, apply x.2, - apply (@is_hprop.elim), - apply trunc_pi, intro a, - apply is_hprop.mk, intros (w, z), - assert (H : is_hset A), - apply trunc_succ, apply trunc_succ, - apply is_contr.mk, exact y.2, - fapply (@is_hset.elim A _ _ _ w z), - intros (n', IH, A), - apply trunc_equiv, - apply equiv.to_is_equiv, - apply is_trunc.pi_char, - end - -end truncation diff --git a/hott/truncation.hlean b/hott/truncation.hlean index 3491a94083..696594d234 100644 --- a/hott/truncation.hlean +++ b/hott/truncation.hlean @@ -2,7 +2,7 @@ -- Released under Apache 2.0 license as described in the file LICENSE. -- Authors: Jakob von Raumer -open truncation +open is_trunc -- Axiomatize the truncation operator as long as we do not have -- Higher inductive types diff --git a/hott/types/W.hlean b/hott/types/W.hlean index 3245c40e49..057dcc1338 100644 --- a/hott/types/W.hlean +++ b/hott/types/W.hlean @@ -22,10 +22,10 @@ namespace Wtype variables {A A' : Type.{u}} {B B' : A → Type.{v}} {C : Π(a : A), B a → Type} {a a' : A} {f : B a → W a, B a} {f' : B a' → W a, B a} {w w' : W(a : A), B a} - definition pr1 (w : W(a : A), B a) : A := + protected definition pr1 (w : W(a : A), B a) : A := Wtype.rec_on w (λa f IH, a) - definition pr2 (w : W(a : A), B a) : B (pr1 w) → W(a : A), B a := + protected definition pr2 (w : W(a : A), B a) : B (pr1 w) → W(a : A), B a := Wtype.rec_on w (λa f IH, f) namespace ops @@ -38,28 +38,28 @@ namespace Wtype protected definition eta (w : W a, B a) : ⟨w.1 , w.2⟩ = w := cases_on w (λa f, idp) - definition path_W_sup (p : a = a') (q : p ▹ f = f') : ⟨a, f⟩ = ⟨a', f'⟩ := + definition sup_eq_sup (p : a = a') (q : p ▹ f = f') : ⟨a, f⟩ = ⟨a', f'⟩ := path.rec_on p (λf' q, path.rec_on q idp) f' q - definition path_W (p : w.1 = w'.1) (q : p ▹ w.2 = w'.2) : w = w' := + protected definition Wtype_eq (p : w.1 = w'.1) (q : p ▹ w.2 = w'.2) : w = w' := cases_on w - (λw1 w2, cases_on w' (λ w1' w2', path_W_sup)) + (λw1 w2, cases_on w' (λ w1' w2', sup_eq_sup)) p q - definition pr1_path (p : w = w') : w.1 = w'.1 := + protected definition Wtype_eq_pr1 (p : w = w') : w.1 = w'.1 := path.rec_on p idp - definition pr2_path (p : w = w') : pr1_path p ▹ w.2 = w'.2 := + protected definition Wtype_eq_pr2 (p : w = w') : Wtype_eq_pr1 p ▹ w.2 = w'.2 := path.rec_on p idp namespace ops - postfix `..1`:(max+1) := pr1_path - postfix `..2`:(max+1) := pr2_path + postfix `..1`:(max+1) := Wtype_eq_pr1 + postfix `..2`:(max+1) := Wtype_eq_pr2 end ops open ops definition sup_path_W (p : w.1 = w'.1) (q : p ▹ w.2 = w'.2) - : dpair (path_W p q)..1 (path_W p q)..2 = dpair p q := + : dpair (Wtype_eq p q)..1 (Wtype_eq p q)..2 = dpair p q := begin reverts (p, q), apply (cases_on w), intros (w1, w2), @@ -68,14 +68,14 @@ namespace Wtype apply (path.rec_on q), apply idp end - definition pr1_path_W (p : w.1 = w'.1) (q : p ▹ w.2 = w'.2) : (path_W p q)..1 = p := + definition pr1_path_W (p : w.1 = w'.1) (q : p ▹ w.2 = w'.2) : (Wtype_eq p q)..1 = p := (!sup_path_W)..1 definition pr2_path_W (p : w.1 = w'.1) (q : p ▹ w.2 = w'.2) - : pr1_path_W p q ▹ (path_W p q)..2 = q := + : pr1_path_W p q ▹ (Wtype_eq p q)..2 = q := (!sup_path_W)..2 - definition eta_path_W (p : w = w') : path_W (p..1) (p..2) = p := + definition eta_path_W (p : w = w') : Wtype_eq (p..1) (p..2) = p := begin apply (path.rec_on p), apply (cases_on w), intros (w1, w2), @@ -83,7 +83,7 @@ namespace Wtype end definition transport_pr1_path_W {B' : A → Type} (p : w.1 = w'.1) (q : p ▹ w.2 = w'.2) - : transport (λx, B' x.1) (path_W p q) = transport B' p := + : transport (λx, B' x.1) (Wtype_eq p q) = transport B' p := begin reverts (p, q), apply (cases_on w), intros (w1, w2), @@ -93,7 +93,7 @@ namespace Wtype end definition path_W_uncurried (pq : Σ(p : w.1 = w'.1), p ▹ w.2 = w'.2) : w = w' := - destruct pq path_W + destruct pq Wtype_eq definition sup_path_W_uncurried (pq : Σ(p : w.1 = w'.1), p ▹ w.2 = w'.2) : dpair (path_W_uncurried pq)..1 (path_W_uncurried pq)..2 = pq := @@ -137,18 +137,18 @@ namespace Wtype /- truncatedness -/ open truncation - definition trunc_W [FUN : funext.{v (max 1 u v)}] (n : trunc_index) [HA : is_trunc (n.+1) A] - : is_trunc (n.+1) (W a, B a) := + definition trunc_W [instance] [FUN : funext.{v (max 1 u v)}] (n : trunc_index) + [HA : is_trunc (n.+1) A] : is_trunc (n.+1) (W a, B a) := begin fapply is_trunc_succ, intros (w, w'), apply (double_induction_on w w'), intros (a, a', f, f', IH), - fapply trunc_equiv', + fapply is_trunc_equiv_closed, apply equiv_path_W, - apply trunc_sigma, - fapply (succ_is_trunc n), + apply is_trunc_sigma, + fapply (is_trunc_eq n), intro p, revert IH, generalize f', --change to revert after simpl apply (path.rec_on p), intros (f', IH), - apply pi.trunc_path_pi, intro b, + apply pi.is_trunc_eq_pi, intro b, apply IH end diff --git a/hott/types/path.hlean b/hott/types/path.hlean new file mode 100644 index 0000000000..bc1f476ee0 --- /dev/null +++ b/hott/types/path.hlean @@ -0,0 +1,572 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn +Ported from Coq HoTT + +Theorems about path types (identity types) +-/ + +open eq sigma sigma.ops equiv is_equiv + +namespace path + /- Path spaces -/ + + /- The path spaces of a path space are not, of course, determined; they are just the + higher-dimensional structure of the original space. -/ + + /- Transporting in path spaces. + + There are potentially a lot of these lemmas, so we adopt a uniform naming scheme: + + - `l` means the left endpoint varies + - `r` means the right endpoint varies + - `F` means application of a function to that (varying) endpoint. + -/ + + variables {A B : Type} {a a1 a2 a3 a4 : A} {b b1 b2 : B} {f g : A → B} {h : B → A} + + definition transport_paths_l (p : a1 = a2) (q : a1 = a3) + : transport (λx, x = a3) p q = p⁻¹ ⬝ q := + begin + apply (eq.rec_on p), apply (eq.rec_on q), apply idp + end + + definition transport_paths_r (p : a2 = a3) (q : a1 = a2) + : transport (λx, a1 = x) p q = q ⬝ p := + begin + apply (eq.rec_on p), apply (eq.rec_on q), apply idp + end + + definition transport_paths_lr (p : a1 = a2) (q : a1 = a1) + : transport (λx, x = x) p q = p⁻¹ ⬝ q ⬝ p := + begin + apply (eq.rec_on p), + apply inverse, apply concat, + apply con_idp, + apply idp_con + end + + definition transport_paths_Fl (p : a1 = a2) (q : f a1 = b) + : transport (λx, f x = b) p q = (ap f p)⁻¹ ⬝ q := + begin + apply (eq.rec_on p), apply (eq.rec_on q), apply idp + end + + definition transport_paths_Fr (p : a1 = a2) (q : b = f a1) + : transport (λx, b = f x) p q = q ⬝ (ap f p) := + begin + apply (eq.rec_on p), apply idp + end + + definition transport_paths_FlFr (p : a1 = a2) (q : f a1 = g a1) + : transport (λx, f x = g x) p q = (ap f p)⁻¹ ⬝ q ⬝ (ap g p) := + begin + apply (eq.rec_on p), + apply inverse, apply concat, + apply con_idp, + apply idp_con + end + + definition transport_paths_FlFr_D {B : A → Type} {f g : Πa, B a} + (p : a1 = a2) (q : f a1 = g a1) + : transport (λx, f x = g x) p q = (apD f p)⁻¹ ⬝ ap (transport B p) q ⬝ (apD g p) := + begin + apply (eq.rec_on p), + apply inverse, + apply concat, apply con_idp, + apply concat, apply idp_con, + apply ap_id + end + + definition transport_paths_FFlr (p : a1 = a2) (q : h (f a1) = a1) + : transport (λx, h (f x) = x) p q = (ap h (ap f p))⁻¹ ⬝ q ⬝ p := + begin + apply (eq.rec_on p), + apply inverse, + apply concat, apply con_idp, + apply idp_con, + end + + definition transport_paths_lFFr (p : a1 = a2) (q : a1 = h (f a1)) + : transport (λx, x = h (f x)) p q = p⁻¹ ⬝ q ⬝ (ap h (ap f p)) := + begin + apply (eq.rec_on p), + apply inverse, + apply concat, apply con_idp, + apply idp_con, + end + + + /- The Functorial action of paths is [ap]. -/ + + /- Equivalences between path spaces -/ + + /- [ap_closed] is in init.equiv -/ + + definition equiv_ap (f : A → B) [H : is_equiv f] (a1 a2 : A) + : (a1 = a2) ≃ (f a1 = f a2) := + equiv.mk _ _ + + /- Path operations are equivalences -/ + + definition isequiv_path_inverse [instance] (a1 a2 : A) : is_equiv (@inverse A a1 a2) := + is_equiv.mk inverse inv_inv inv_inv (λp, eq.rec_on p idp) + + definition equiv_path_inverse (a1 a2 : A) : (a1 = a2) ≃ (a2 = a1) := + equiv.mk inverse _ + + definition isequiv_concat_l [instance] (p : a1 = a2) (a3 : A) + : is_equiv (@concat _ a1 a2 a3 p) := + is_equiv.mk (concat (p⁻¹)) + (con_inv_cancel_left p) + (inv_con_cancel_left p) + (eq.rec_on p (λq, eq.rec_on q idp)) + + definition equiv_concat_l (p : a1 = a2) (a3 : A) : (a1 = a3) ≃ (a2 = a3) := + equiv.mk (concat (p⁻¹)) _ + + definition isequiv_concat_r [instance] (p : a2 = a3) (a1 : A) + : is_equiv (λq : a1 = a2, q ⬝ p) := + is_equiv.mk (λq, q ⬝ p⁻¹) + (λq, inv_con_cancel_right q p) + (λq, con_inv_cancel_right q p) + (eq.rec_on p (λq, eq.rec_on q idp)) + + definition equiv_concat_r (p : a2 = a3) (a1 : A) : (a1 = a2) ≃ (a1 = a3) := + equiv.mk (λq, q ⬝ p) _ + + definition equiv_concat_lr {a1 a2 a3 a4 : A} (p : a1 = a2) (q : a3 = a4) + : (a1 = a3) ≃ (a2 = a4) := + equiv.trans (equiv_concat_l p a3) (equiv_concat_r q a2) + +/- BELOW STILL NEEDS TO BE PORTED FROM COQ HOTT -/ + + -- definition isequiv_whiskerL [instance] (p : a1 = a2) (q r : a2 = a3) + -- : is_equiv (@whisker_left A a1 a2 a3 p q r) := + -- begin + + -- end + -- /-begin + -- refine (isequiv_adjointify _ _ _ _). + -- - apply cancelL. + -- - intros k. unfold cancelL. + -- rewrite !whiskerL_pp. + -- refine ((_ @@ 1 @@ _) ⬝ whiskerL_pVL p k). + -- + destruct p, q; reflexivity. + -- + destruct p, r; reflexivity. + -- - intros k. unfold cancelL. + -- refine ((_ @@ 1 @@ _) ⬝ whiskerL_VpL p k). + -- + destruct p, q; reflexivity. + -- + destruct p, r; reflexivity. + -- end-/ + + -- definition equiv_whiskerL {A} {x y z : A} (p : x = y) (q r : y = z) + -- : (q = r) ≃ (p ⬝ q = p ⬝ r) := + -- equiv.mk _ _ (whisker_left p) _. + + -- definition equiv_cancelL {A} {x y z : A} (p : x = y) (q r : y = z) + -- : (p ⬝ q = p ⬝ r) ≃ (q = r) := + -- equiv_inverse (equiv_whiskerL p q r). + + -- definition isequiv_cancelL {A} {x y z : A} (p : x = y) (q r : y = z) + -- : is_equiv (cancel_left p q r). + -- /-begin + -- change (is_equiv (equiv_cancelL p q r)); exact _. + -- end-/ + + -- definition isequiv_whiskerR [instance] {A} {x y z : A} {p q : x = y} (r : y = z) + -- : is_equiv (λh, @whisker_right A x y z p q h r). + -- /-begin + -- refine (isequiv_adjointify _ _ _ _). + -- - apply cancelR. + -- - intros k. unfold cancelR. + -- rewrite !whiskerR_pp. + -- refine ((_ @@ 1 @@ _) ⬝ whiskerR_VpR k r). + -- + destruct p, r; reflexivity. + -- + destruct q, r; reflexivity. + -- - intros k. unfold cancelR. + -- refine ((_ @@ 1 @@ _) ⬝ whiskerR_pVR k r). + -- + destruct p, r; reflexivity. + -- + destruct q, r; reflexivity. + -- end-/ + + -- definition equiv_whiskerR {A} {x y z : A} (p q : x = y) (r : y = z) + -- : (p = q) ≃ (p ⬝ r = q ⬝ r) := + -- equiv.mk _ _ (λh, whisker_right h r) _. + + -- definition equiv_cancelR {A} {x y z : A} (p q : x = y) (r : y = z) + -- : (p ⬝ r = q ⬝ r) ≃ (p = q) := + -- equiv_inverse (equiv_whiskerR p q r). + + -- definition isequiv_cancelR {A} {x y z : A} (p q : x = y) (r : y = z) + -- : is_equiv (cancel_right p q r). + -- /-begin + -- change (is_equiv (equiv_cancelR p q r)); exact _. + -- end-/ + + -- /- We can use these to build up more complicated equivalences. + + -- In particular, all of the [move] family are equivalences. + + -- (Note: currently, some but not all of these [isequiv_] lemmas have corresponding [equiv_] lemmas. Also, they do *not* currently contain the computational content that e.g. the inverse of [moveR_Mp] is [moveL_Vp]; perhaps it would be useful if they did? -/ + + -- Global Instance isequiv_moveR_Mp + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) + -- : is_equiv (con_eq_of_eq_inv_con p q r). + -- /-begin + -- destruct r. + -- apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). + -- end-/ + + -- definition equiv_moveR_Mp + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) + -- : (p = r⁻¹ ⬝ q) ≃ (r ⬝ p = q) := + -- equiv.mk _ _ (con_eq_of_eq_inv_con p q r) _. + + -- Global Instance isequiv_moveR_pM + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) + -- : is_equiv (con_eq_of_eq_con_inv p q r). + -- /-begin + -- destruct p. + -- apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). + -- end-/ + + -- definition equiv_moveR_pM + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) + -- : (r = q ⬝ p⁻¹) ≃ (r ⬝ p = q) := + -- equiv.mk _ _ (con_eq_of_eq_con_inv p q r) _. + + -- Global Instance isequiv_moveR_Vp + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) + -- : is_equiv (inv_con_eq_of_eq_con p q r). + -- /-begin + -- destruct r. + -- apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). + -- end-/ + + -- definition equiv_moveR_Vp + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) + -- : (p = r ⬝ q) ≃ (r⁻¹ ⬝ p = q) := + -- equiv.mk _ _ (inv_con_eq_of_eq_con p q r) _. + + -- Global Instance isequiv_moveR_pV + -- {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) + -- : is_equiv (con_inv_eq_of_eq_con p q r). + -- /-begin + -- destruct p. + -- apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). + -- end-/ + + -- definition equiv_moveR_pV + -- {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) + -- : (r = q ⬝ p) ≃ (r ⬝ p⁻¹ = q) := + -- equiv.mk _ _ (con_inv_eq_of_eq_con p q r) _. + + -- Global Instance isequiv_moveL_Mp + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) + -- : is_equiv (eq_con_of_inv_con_eq p q r). + -- /-begin + -- destruct r. + -- apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). + -- end-/ + + -- definition equiv_moveL_Mp + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) + -- : (r⁻¹ ⬝ q = p) ≃ (q = r ⬝ p) := + -- equiv.mk _ _ (eq_con_of_inv_con_eq p q r) _. + + -- definition isequiv_moveL_pM + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) + -- : is_equiv (eq_con_of_con_inv_eq p q r). + -- /-begin + -- destruct p. + -- apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). + -- end-/ + + -- definition equiv_moveL_pM + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : + -- q ⬝ p⁻¹ = r ≃ q = r ⬝ p := + -- equiv.mk _ _ _ (isequiv_moveL_pM p q r). + + -- Global Instance isequiv_moveL_Vp + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) + -- : is_equiv (eq_inv_con_of_con_eq p q r). + -- /-begin + -- destruct r. + -- apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). + -- end-/ + + -- definition equiv_moveL_Vp + -- {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) + -- : r ⬝ q = p ≃ q = r⁻¹ ⬝ p := + -- equiv.mk _ _ (eq_inv_con_of_con_eq p q r) _. + + -- Global Instance isequiv_moveL_pV + -- {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) + -- : is_equiv (eq_con_inv_of_con_eq p q r). + -- /-begin + -- destruct p. + -- apply (isequiv_compose' _ (isequiv_concat_l _ _) _ (isequiv_concat_r _ _)). + -- end-/ + + -- definition equiv_moveL_pV + -- {A : Type} {x y z : A} (p : z = x) (q : y = z) (r : y = x) + -- : q ⬝ p = r ≃ q = r ⬝ p⁻¹ := + -- equiv.mk _ _ (eq_con_inv_of_con_eq p q r) _. + + -- definition isequiv_moveL_1M {A : Type} {x y : A} (p q : x = y) + -- : is_equiv (eq_of_con_inv_eq_idp p q). + -- /-begin + -- destruct q. apply isequiv_concat_l. + -- end-/ + + -- definition isequiv_moveL_M1 {A : Type} {x y : A} (p q : x = y) + -- : is_equiv (eq_of_inv_con_eq_idp p q). + -- /-begin + -- destruct q. apply isequiv_concat_l. + -- end-/ + + -- definition isequiv_moveL_1V {A : Type} {x y : A} (p : x = y) (q : y = x) + -- : is_equiv (eq_inv_of_con_eq_idp' p q). + -- /-begin + -- destruct q. apply isequiv_concat_l. + -- end-/ + + -- definition isequiv_moveL_V1 {A : Type} {x y : A} (p : x = y) (q : y = x) + -- : is_equiv (eq_inv_of_con_eq_idp p q). + -- /-begin + -- destruct q. apply isequiv_concat_l. + -- end-/ + + -- definition isequiv_moveR_M1 {A : Type} {x y : A} (p q : x = y) + -- : is_equiv (eq_of_idp_eq_inv_con p q). + -- /-begin + -- destruct p. apply isequiv_concat_r. + -- end-/ + + -- definition isequiv_moveR_1M {A : Type} {x y : A} (p q : x = y) + -- : is_equiv (eq_of_idp_eq_con_inv p q). + -- /-begin + -- destruct p. apply isequiv_concat_r. + -- end-/ + + -- definition isequiv_moveR_1V {A : Type} {x y : A} (p : x = y) (q : y = x) + -- : is_equiv (inv_eq_of_idp_eq_con p q). + -- /-begin + -- destruct p. apply isequiv_concat_r. + -- end-/ + + -- definition isequiv_moveR_V1 {A : Type} {x y : A} (p : x = y) (q : y = x) + -- : is_equiv (inv_eq_of_idp_eq_con' p q). + -- /-begin + -- destruct p. apply isequiv_concat_r. + -- end-/ + + -- definition isequiv_moveR_transport_p [instance] {A : Type} (P : A → Type) {x y : A} + -- (p : x = y) (u : P x) (v : P y) + -- : is_equiv (tr_eq_of_eq_inv_tr P p u v). + -- /-begin + -- destruct p. apply isequiv_idmap. + -- end-/ + + -- definition equiv_moveR_transport_p {A : Type} (P : A → Type) {x y : A} + -- (p : x = y) (u : P x) (v : P y) + -- : u = transport P p⁻¹ v ≃ transport P p u = v := + -- equiv.mk _ _ (tr_eq_of_eq_inv_tr P p u v) _. + + -- definition isequiv_moveR_transport_V [instance] {A : Type} (P : A → Type) {x y : A} + -- (p : y = x) (u : P x) (v : P y) + -- : is_equiv (inv_tr_eq_of_eq_tr P p u v). + -- /-begin + -- destruct p. apply isequiv_idmap. + -- end-/ + + -- definition equiv_moveR_transport_V {A : Type} (P : A → Type) {x y : A} + -- (p : y = x) (u : P x) (v : P y) + -- : u = transport P p v ≃ transport P p⁻¹ u = v := + -- equiv.mk _ _ (inv_tr_eq_of_eq_tr P p u v) _. + + -- definition isequiv_moveL_transport_V [instance] {A : Type} (P : A → Type) {x y : A} + -- (p : x = y) (u : P x) (v : P y) + -- : is_equiv (eq_inv_tr_of_tr_eq P p u v). + -- /-begin + -- destruct p. apply isequiv_idmap. + -- end-/ + + -- definition equiv_moveL_transport_V {A : Type} (P : A → Type) {x y : A} + -- (p : x = y) (u : P x) (v : P y) + -- : transport P p u = v ≃ u = transport P p⁻¹ v := + -- equiv.mk _ _ (eq_inv_tr_of_tr_eq P p u v) _. + + -- definition isequiv_moveL_transport_p [instance] {A : Type} (P : A → Type) {x y : A} + -- (p : y = x) (u : P x) (v : P y) + -- : is_equiv (eq_tr_of_inv_tr_eq P p u v). + -- /-begin + -- destruct p. apply isequiv_idmap. + -- end-/ + + -- definition equiv_moveL_transport_p {A : Type} (P : A → Type) {x y : A} + -- (p : y = x) (u : P x) (v : P y) + -- : transport P p⁻¹ u = v ≃ u = transport P p v := + -- equiv.mk _ _ (eq_tr_of_inv_tr_eq P p u v) _. + + -- definition isequiv_moveR_equiv_M [instance] [H : is_equiv A B f] (x : A) (y : B) + -- : is_equiv (@moveR_equiv_M A B f _ x y). + -- /-begin + -- unfold moveR_equiv_M. + -- refine (@isequiv_compose _ _ (ap f) _ _ (λq, q ⬝ retr f y) _). + -- end-/ + + -- definition equiv_moveR_equiv_M [H : is_equiv A B f] (x : A) (y : B) + -- : (x = f⁻¹ y) ≃ (f x = y) := + -- equiv.mk _ _ (@moveR_equiv_M A B f _ x y) _. + + -- definition isequiv_moveR_equiv_V [instance] [H : is_equiv A B f] (x : B) (y : A) + -- : is_equiv (@moveR_equiv_V A B f _ x y). + -- /-begin + -- unfold moveR_equiv_V. + -- refine (@isequiv_compose _ _ (ap f⁻¹) _ _ (λq, q ⬝ sect f y) _). + -- end-/ + + -- definition equiv_moveR_equiv_V [H : is_equiv A B f] (x : B) (y : A) + -- : (x = f y) ≃ (f⁻¹ x = y) := + -- equiv.mk _ _ (@moveR_equiv_V A B f _ x y) _. + + -- definition isequiv_moveL_equiv_M [instance] [H : is_equiv A B f] (x : A) (y : B) + -- : is_equiv (@moveL_equiv_M A B f _ x y). + -- /-begin + -- unfold moveL_equiv_M. + -- refine (@isequiv_compose _ _ (ap f) _ _ (λq, (retr f y)⁻¹ ⬝ q) _). + -- end-/ + + -- definition equiv_moveL_equiv_M [H : is_equiv A B f] (x : A) (y : B) + -- : (f⁻¹ y = x) ≃ (y = f x) := + -- equiv.mk _ _ (@moveL_equiv_M A B f _ x y) _. + + -- definition isequiv_moveL_equiv_V [instance] [H : is_equiv A B f] (x : B) (y : A) + -- : is_equiv (@moveL_equiv_V A B f _ x y). + -- /-begin + -- unfold moveL_equiv_V. + -- refine (@isequiv_compose _ _ (ap f⁻¹) _ _ (λq, (sect f y)⁻¹ ⬝ q) _). + -- end-/ + + -- definition equiv_moveL_equiv_V [H : is_equiv A B f] (x : B) (y : A) + -- : (f y = x) ≃ (y = f⁻¹ x) := + -- equiv.mk _ _ (@moveL_equiv_V A B f _ x y) _. + + -- /- Dependent paths -/ + + -- /- Usually, a dependent path over [p:x1=x2] in [P:A->Type] between [y1:P x1] and [y2:P x2] is a path [transport P p y1 = y2] in [P x2]. However, when [P] is a path space, these dependent paths have a more convenient description: rather than transporting the left side both forwards and backwards, we transport both sides of the equation forwards, forming a sort of "naturality square". + + -- We use the same naming scheme as for the transport lemmas. -/ + + -- definition dpath_path_l {A : Type} {x1 x2 y : A} + -- (p : x1 = x2) (q : x1 = y) (r : x2 = y) + -- : q = p ⬝ r + -- ≃ + -- transport (λx, x = y) p q = r. + -- /-begin + -- destruct p; simpl. + -- exact (equiv_concat_r (idp_con r) q). + -- end-/ + + -- definition dpath_path_r {A : Type} {x y1 y2 : A} + -- (p : y1 = y2) (q : x = y1) (r : x = y2) + -- : q ⬝ p = r + -- ≃ + -- transport (λy, x = y) p q = r. + -- /-begin + -- destruct p; simpl. + -- exact (equiv_concat_l (con_idp q)⁻¹ r). + -- end-/ + + -- definition dpath_path_lr {A : Type} {x1 x2 : A} + -- (p : x1 = x2) (q : x1 = x1) (r : x2 = x2) + -- : q ⬝ p = p ⬝ r + -- ≃ + -- transport (λx, x = x) p q = r. + -- /-begin + -- destruct p; simpl. + -- refine (equiv_compose' (B := (q ⬝ 1 = r)) _ _). + -- exact (equiv_concat_l (con_idp q)⁻¹ r). + -- exact (equiv_concat_r (idp_con r) (q ⬝ 1)). + -- end-/ + + -- definition dpath_path_Fl {A B : Type} {f : A → B} {x1 x2 : A} {y : B} + -- (p : x1 = x2) (q : f x1 = y) (r : f x2 = y) + -- : q = ap f p ⬝ r + -- ≃ + -- transport (λx, f x = y) p q = r. + -- /-begin + -- destruct p; simpl. + -- exact (equiv_concat_r (idp_con r) q). + -- end-/ + + -- definition dpath_path_Fr {A B : Type} {g : A → B} {x : B} {y1 y2 : A} + -- (p : y1 = y2) (q : x = g y1) (r : x = g y2) + -- : q ⬝ ap g p = r + -- ≃ + -- transport (λy, x = g y) p q = r. + -- /-begin + -- destruct p; simpl. + -- exact (equiv_concat_l (con_idp q)⁻¹ r). + -- end-/ + + -- definition dpath_path_FlFr {A B : Type} {f g : A → B} {x1 x2 : A} + -- (p : x1 = x2) (q : f x1 = g x1) (r : f x2 = g x2) + -- : q ⬝ ap g p = ap f p ⬝ r + -- ≃ + -- transport (λx, f x = g x) p q = r. + -- /-begin + -- destruct p; simpl. + -- refine (equiv_compose' (B := (q ⬝ 1 = r)) _ _). + -- exact (equiv_concat_l (con_idp q)⁻¹ r). + -- exact (equiv_concat_r (idp_con r) (q ⬝ 1)). + -- end-/ + + -- definition dpath_path_FFlr {A B : Type} {f : A → B} {g : B → A} + -- {x1 x2 : A} (p : x1 = x2) (q : g (f x1) = x1) (r : g (f x2) = x2) + -- : q ⬝ p = ap g (ap f p) ⬝ r + -- ≃ + -- transport (λx, g (f x) = x) p q = r. + -- /-begin + -- destruct p; simpl. + -- refine (equiv_compose' (B := (q ⬝ 1 = r)) _ _). + -- exact (equiv_concat_l (con_idp q)⁻¹ r). + -- exact (equiv_concat_r (idp_con r) (q ⬝ 1)). + -- end-/ + + -- definition dpath_path_lFFr {A B : Type} {f : A → B} {g : B → A} + -- {x1 x2 : A} (p : x1 = x2) (q : x1 = g (f x1)) (r : x2 = g (f x2)) + -- : q ⬝ ap g (ap f p) = p ⬝ r + -- ≃ + -- transport (λx, x = g (f x)) p q = r. + -- /-begin + -- destruct p; simpl. + -- refine (equiv_compose' (B := (q ⬝ 1 = r)) _ _). + -- exact (equiv_concat_l (con_idp q)⁻¹ r). + -- exact (equiv_concat_r (idp_con r) (q ⬝ 1)). + -- end-/ + + + -- /- Universal mapping property -/ + + -- definition isequiv_paths_ind [instance] [H : funext] {A : Type} (a : A) + -- (P : Πx, (a = x) → Type) + -- : is_equiv (paths_ind a P) | 0 := + -- isequiv_adjointify (paths_ind a P) (λf, f a 1) _ _. + -- /-begin + -- - intros f. + -- apply path_forall; intros x. + -- apply path_forall; intros p. + -- destruct p; reflexivity. + -- - intros u. reflexivity. + -- end-/ + + -- definition equiv_paths_ind [H : funext] {A : Type} (a : A) + -- (P : Πx, (a = x) → Type) + -- : P a 1 ≃ Πx p, P x p := + -- equiv.mk _ _ (paths_ind a P) _. + +end path diff --git a/hott/types/pi.hlean b/hott/types/pi.hlean index c9b4bf8218..daa82c9204 100644 --- a/hott/types/pi.hlean +++ b/hott/types/pi.hlean @@ -12,7 +12,7 @@ open eq equiv is_equiv funext namespace pi universe variables l k - variables {A A' : Type.{l}} {B : A → Type.{k}} {C : Πa, B a → Type} + variables {A A' : Type.{l}} {B : A → Type.{k}} {B' : A' → Type.{k}} {C : Πa, B a → Type} {D : Πa b, C a b → Type} {a a' a'' : A} {b b₁ b₂ : B a} {b' : B a'} {b'' : B a''} {f g : Πa, B a} @@ -24,75 +24,138 @@ namespace pi /- Now we show how these things compute. -/ - definition apD10_path_pi [H : funext] (h : f ∼ g) : apD10 (path_pi h) ∼ h := + definition apD10_eq_of_homotopy (h : f ∼ g) : apD10 (eq_of_homotopy h) ∼ h := apD10 (retr apD10 h) - definition path_pi_eta [H : funext] (p : f = g) : path_pi (apD10 p) = p := + definition eq_of_homotopy_eta (p : f = g) : eq_of_homotopy (apD10 p) = p := sect apD10 p - definition path_pi_idp [H : funext] : path_pi (λx : A, refl (f x)) = refl f := - !path_pi_eta + definition eq_of_homotopy_idp (f : Πa, B a) : eq_of_homotopy (λx : A, refl (f x)) = refl f := + !eq_of_homotopy_eta /- The identification of the path space of a dependent function space, up to equivalence, is of course just funext. -/ - definition path_equiv_homotopy [H : funext] (f g : Πx, B x) : (f = g) ≃ (f ∼ g) := - equiv.mk _ !funext.ap + definition eq_equiv_homotopy (f g : Πx, B x) : (f = g) ≃ (f ∼ g) := + equiv.mk _ !funext.elim - definition is_equiv_path_pi [instance] [H : funext] (f g : Πx, B x) - : is_equiv (@path_pi _ _ _ f g) := - inv_closed apD10 + definition is_equiv_eq_of_homotopy [instance] (f g : Πx, B x) + : is_equiv (@eq_of_homotopy _ _ _ f g) := + is_equiv_inv apD10 - definition homotopy_equiv_path [H : funext] (f g : Πx, B x) : (f ∼ g) ≃ (f = g) := - equiv.mk _ !is_equiv_path_pi + definition homotopy_equiv_eq (f g : Πx, B x) : (f ∼ g) ≃ (f = g) := + equiv.mk _ !is_equiv_eq_of_homotopy /- Transport -/ - protected definition transport (p : a = a') (f : Π(b : B a), C a b) + definition pi_transport (p : a = a') (f : Π(b : B a), C a b) : (transport (λa, Π(b : B a), C a b) p f) - ∼ (λb, transport (C a') !transport_pV (transportD _ _ p _ (f (p⁻¹ ▹ b)))) := + ∼ (λb, transport (C a') !tr_inv_tr (transportD _ _ p _ (f (p⁻¹ ▹ b)))) := eq.rec_on p (λx, idp) /- A special case of [transport_pi] where the type [B] does not depend on [A], and so it is just a fixed type [B]. -/ - definition transport_constant {C : A → A' → Type} (p : a = a') (f : Π(b : A'), C a b) - : (eq.transport (λa, Π(b : A'), C a b) p f) ∼ (λb, eq.transport (λa, C a b) p (f b)) := + definition pi_transport_constant {C : A → A' → Type} (p : a = a') (f : Π(b : A'), C a b) + : (transport (λa, Π(b : A'), C a b) p f) ∼ (λb, transport (λa, C a b) p (f b)) := eq.rec_on p (λx, idp) /- Maps on paths -/ /- The action of maps given by lambda. -/ - definition ap_lambdaD [H : funext] {C : A' → Type} (p : a = a') (f : Πa b, C b) : - ap (λa b, f a b) p = path_pi (λb, ap (λa, f a b) p) := + definition ap_lambdaD {C : A' → Type} (p : a = a') (f : Πa b, C b) : + ap (λa b, f a b) p = eq_of_homotopy (λb, ap (λa, f a b) p) := begin apply (eq.rec_on p), apply inverse, - apply path_pi_idp + apply eq_of_homotopy_idp end /- Dependent paths -/ /- with more implicit arguments the conclusion of the following theorem is - (Π(b : B a), transportD B C p b (f b) = g (eq.transport B p b)) ≃ - (eq.transport (λa, Π(b : B a), C a b) p f = g) -/ - definition dpath_pi [H : funext] (p : a = a') (f : Π(b : B a), C a b) (g : Π(b' : B a'), C a' b') - : (Π(b : B a), p ▹D (f b) = g (p ▹ b)) ≃ (p ▹ f = g) := - eq.rec_on p (λg, !homotopy_equiv_path) g + (Π(b : B a), transportD B C p b (f b) = g (transport B p b)) ≃ + (transport (λa, Π(b : B a), C a b) p f = g) -/ + definition heq_piD (p : a = a') (f : Π(b : B a), C a b) + (g : Π(b' : B a'), C a' b') : (Π(b : B a), p ▹D (f b) = g (p ▹ b)) ≃ (p ▹ f = g) := + eq.rec_on p (λg, !homotopy_equiv_eq) g - section open sigma sigma.ops + definition heq_pi {C : A → Type.{k}} (p : a = a') (f : Π(b : B a), C a) + (g : Π(b' : B a'), C a') : (Π(b : B a), p ▹ (f b) = g (p ▹ b)) ≃ (p ▹ f = g) := + eq.rec_on p (λg, !homotopy_equiv_eq) g + + + section + open sigma sigma.ops /- more implicit arguments: - (Π(b : B a), eq.transport C (sigma.path p idp) (f b) = g (p ▹ b)) ≃ - (Π(b : B a), transportD B (λ(a : A) (b : B a), C ⟨a, b⟩) p b (f b) = g (eq.transport B p b)) -/ - definition dpath_pi_sigma {C : (Σa, B a) → Type} (p : a = a') + (Π(b : B a), transport C (sigma_eq p idp) (f b) = g (p ▹ b)) ≃ + (Π(b : B a), transportD B (λ(a : A) (b : B a), C ⟨a, b⟩) p b (f b) = g (transport B p b)) -/ + definition heq_pi_sigma {C : (Σa, B a) → Type} (p : a = a') (f : Π(b : B a), C ⟨a, b⟩) (g : Π(b' : B a'), C ⟨a', b'⟩) : - (Π(b : B a), (sigma.path p idp) ▹ (f b) = g (p ▹ b)) ≃ (Π(b : B a), p ▹D (f b) = g (p ▹ b)) := + (Π(b : B a), (sigma_eq p idp) ▹ (f b) = g (p ▹ b)) ≃ (Π(b : B a), p ▹D (f b) = g (p ▹ b)) := eq.rec_on p (λg, !equiv.refl) g end - /- truncation -/ + /- Functorial action -/ + variables (f0 : A' → A) (f1 : Π(a':A'), B (f0 a') → B' a') - open truncation - definition trunc_pi [instance] [H : funext.{l k}] (B : A → Type.{k}) (n : trunc_index) + /- The functoriality of [forall] is slightly subtle: it is contravariant in the domain type and covariant in the codomain, but the codomain is dependent on the domain. -/ + + definition pi_functor : (Π(a:A), B a) → (Π(a':A'), B' a') := (λg a', f1 a' (g (f0 a'))) + + definition ap_pi_functor {g g' : Π(a:A), B a} (h : g ∼ g') + : ap (pi_functor f0 f1) (eq_of_homotopy h) = eq_of_homotopy (λa':A', (ap (f1 a') (h (f0 a')))) := + begin + apply (equiv_rect (@apD10 A B g g')), intro p, clear h, --revert p, revert g', + apply (eq.rec_on p), + apply concat, --(@concat _ _ (refl (pi_functor f0 f1 g))), + exact (ap (ap (pi_functor f0 f1)) (eq_of_homotopy_idp g)), + apply symm, apply eq_of_homotopy_idp + end + + /- Equivalences -/ + + definition is_equiv_pi_functor [instance] (f0 : A' → A) (f1 : Π(a':A'), B (f0 a') → B' a') + [H0 : is_equiv f0] [H1 : Πa', @is_equiv (B (f0 a')) (B' a') (f1 a')] + : is_equiv (pi_functor f0 f1) := + begin + apply (adjointify (pi_functor f0 f1) (pi_functor (f0⁻¹) + (λ(a : A) (b' : B' (f0⁻¹ a)), transport B (retr f0 a) ((f1 (f0⁻¹ a))⁻¹ b')))), + intro h, apply eq_of_homotopy, + unfold pi_functor, unfold function.compose, unfold function.id, + --first subgoal + intro a', + beta, + apply (tr_inv _ (adj f0 a')), + apply (transport (λx, f1 a' x = h a') (transport_compose B f0 (sect f0 a') _)), beta, + apply (tr_inv (λx, x = h a') (fn_tr_eq_tr_fn _ f1 _)), beta, unfold function.compose, + apply (tr_inv (λx, sect f0 a' ▹ x = h a') (retr (f1 _) _)), beta, unfold function.id, + apply apD, + --second subgoal + intro h, beta, + apply eq_of_homotopy, intro a, beta, + apply (tr_inv (λx, retr f0 a ▹ x = h a) (sect (f1 _) _)), unfold function.id, beta, + apply apD + end + + + definition pi_equiv_pi_of_is_equiv [H : is_equiv f0] [H1 : Πa', @is_equiv (B (f0 a')) (B' a') (f1 a')] + : (Πa, B a) ≃ (Πa', B' a') := + equiv.mk (pi_functor f0 f1) _ + + context + attribute inv [irreducible] --this is needed for the following class instance resolution + definition pi_equiv_pi (f0 : A' ≃ A) (f1 : Πa', (B (to_fun f0 a') ≃ B' a')) + : (Πa, B a) ≃ (Πa', B' a') := + pi_equiv_pi_of_is_equiv (to_fun f0) (λa', to_fun (f1 a')) + end + + definition pi_equiv_pi_id {P Q : A → Type} (g : Πa, P a ≃ Q a) : (Πa, P a) ≃ (Πa, Q a) := + pi_equiv_pi equiv.refl g. + + /- Truncatedness: any dependent product of n-types is an n-type -/ + + open is_trunc + definition is_trunc_pi [instance] [H : funext.{l k}] (B : A → Type.{k}) (n : trunc_index) [H : ∀a, is_trunc n (B a)] : is_trunc n (Πa, B a) := begin reverts (B, H), @@ -100,23 +163,37 @@ namespace pi intros (B, H), fapply is_contr.mk, intro a, apply center, - intro f, apply path_pi, + intro f, apply eq_of_homotopy, intro x, apply (contr (f x)), intros (n, IH, B, H), - fapply is_trunc_succ, intros (f, g), - fapply trunc_equiv', - apply equiv.symm, apply path_equiv_homotopy, + fapply is_trunc_succ_intro, intros (f, g), + fapply is_trunc_equiv_closed, + apply equiv.symm, apply eq_equiv_homotopy, apply IH, intro a, show is_trunc n (f a = g a), from - succ_is_trunc n (f a) (g a) + is_trunc_eq n (f a) (g a) end - definition trunc_path_pi [instance] [H : funext.{l k}] (n : trunc_index) (f g : Πa, B a) + definition is_trunc_eq_pi [instance] [H : funext.{l k}] (n : trunc_index) (f g : Πa, B a) [H : ∀a, is_trunc n (f a = g a)] : is_trunc n (f = g) := begin - apply trunc_equiv', apply equiv.symm, - apply path_equiv_homotopy + apply is_trunc_equiv_closed, apply equiv.symm, + apply eq_equiv_homotopy end + /- Symmetry of Π -/ + + definition is_equiv_flip [instance] {P : A → A' → Type} : is_equiv (@function.flip _ _ P) := + begin + fapply is_equiv.mk, + exact (@function.flip _ _ (function.flip P)), + repeat (intro f; apply idp) + end + + definition pi_comm_equiv {P : A → A' → Type} : (Πa b, P a b) ≃ (Πb a, P a b) := + equiv.mk (@function.flip _ _ P) _ + end pi + +attribute pi.is_trunc_pi [instance] diff --git a/hott/pointed.hlean b/hott/types/pointed.hlean similarity index 64% rename from hott/pointed.hlean rename to hott/types/pointed.hlean index 8c0c0818df..a4d7248e83 100644 --- a/hott/pointed.hlean +++ b/hott/types/pointed.hlean @@ -1,9 +1,14 @@ --- Copyright (c) 2014 Jakob von Raumer. All rights reserved. --- Released under Apache 2.0 license as described in the file LICENSE. --- Author: Jakob von Raumer --- Ported from Coq HoTT -import init.trunc -open eq prod truncation +/- +Copyright (c) 2014 Jakob von Raumer. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Module: types.pointed +Author: Jakob von Raumer + +Ported from Coq HoTT +-/ + +open eq prod is_trunc sigma structure is_pointed [class] (A : Type) := (point : A) @@ -13,7 +18,7 @@ namespace is_pointed -- Any contractible type is pointed protected definition contr [instance] [H : is_contr A] : is_pointed A := - is_pointed.mk (center A) + is_pointed.mk !center -- A pi type with a pointed target is pointed protected definition pi [instance] {P : A → Type} [H : Πx, is_pointed (P x)] @@ -22,12 +27,12 @@ namespace is_pointed -- A sigma type of pointed components is pointed protected definition sigma [instance] {P : A → Type} [G : is_pointed A] - [H : is_pointed (P (point A))] : is_pointed (Σx, P x) := - is_pointed.mk (sigma.mk (point A) (point (P (point A)))) + [H : is_pointed (P !point)] : is_pointed (Σx, P x) := + is_pointed.mk ⟨!point,!point⟩ protected definition prod [H1 : is_pointed A] [H2 : is_pointed B] : is_pointed (A × B) := - is_pointed.mk (prod.mk (point A) (point B)) + is_pointed.mk (!point,!point) protected definition loop_space (a : A) : is_pointed (a = a) := is_pointed.mk idp diff --git a/hott/types/prod.hlean b/hott/types/prod.hlean index 9ccf6b2fa8..6d0f13393d 100644 --- a/hott/types/prod.hlean +++ b/hott/types/prod.hlean @@ -7,8 +7,7 @@ Ported from Coq HoTT Theorems about products -/ -import init.trunc init.datatypes -open eq equiv is_equiv truncation prod +open eq equiv is_equiv is_trunc prod variables {A A' B B' C D : Type} {a a' a'' : A} {b b₁ b₂ b' b'' : B} {u v w : A × B} @@ -16,32 +15,32 @@ variables {A A' B B' C D : Type} namespace prod -- prod.eta is already used for the eta rule for strict equality - protected definition peta (u : A × B) : (pr₁ u , pr₂ u) = u := + protected definition eta (u : A × B) : (pr₁ u , pr₂ u) = u := destruct u (λu1 u2, idp) - definition pair_path (pa : a = a') (pb : b = b') : (a , b) = (a' , b') := + definition pair_eq (pa : a = a') (pb : b = b') : (a , b) = (a' , b') := eq.rec_on pa (eq.rec_on pb idp) - protected definition path : (pr₁ u = pr₁ v) → (pr₂ u = pr₂ v) → u = v := + definition prod_eq : (pr₁ u = pr₁ v) → (pr₂ u = pr₂ v) → u = v := begin apply (prod.rec_on u), intros (a₁, b₁), apply (prod.rec_on v), intros (a₂, b₂, H₁, H₂), - apply (transport _ (peta (a₁, b₁))), - apply (transport _ (peta (a₂, b₂))), - apply (pair_path H₁ H₂), + apply (transport _ (eta (a₁, b₁))), + apply (transport _ (eta (a₂, b₂))), + apply (pair_eq H₁ H₂), end /- Symmetry -/ - definition isequiv_flip [instance] (A B : Type) : is_equiv (@flip A B) := + definition is_equiv_flip [instance] (A B : Type) : is_equiv (@flip A B) := adjointify flip flip (λu, destruct u (λb a, idp)) (λu, destruct u (λa b, idp)) - definition symm_equiv (A B : Type) : A × B ≃ B × A := + definition prod_comm_equiv (A B : Type) : A × B ≃ B × A := equiv.mk flip _ - -- trunc_prod is defined in sigma + -- is_trunc_prod is defined in sigma end prod diff --git a/hott/types/sigma.hlean b/hott/types/sigma.hlean index b464b62a4b..388b6c21d0 100644 --- a/hott/types/sigma.hlean +++ b/hott/types/sigma.hlean @@ -17,7 +17,7 @@ namespace sigma {a a' a'' : A} {b b₁ b₂ : B a} {b' : B a'} {b'' : B a''} {u v w : Σa, B a} -- sigma.eta is already used for the eta rule for strict equality - protected definition peta (u : Σa, B a) : ⟨u.1 , u.2⟩ = u := + protected definition eta (u : Σa, B a) : ⟨u.1 , u.2⟩ = u := destruct u (λu1 u2, idp) definition eta2 (u : Σa b, C a b) : ⟨u.1, u.2.1, u.2.2⟩ = u := @@ -26,31 +26,31 @@ namespace sigma definition eta3 (u : Σa b c, D a b c) : ⟨u.1, u.2.1, u.2.2.1, u.2.2.2⟩ = u := destruct u (λu1 u2, destruct u2 (λu21 u22, destruct u22 (λu221 u222, idp))) - definition dpair_eq_dpair (p : a = a') (q : p ▹ b = b') : sigma.mk a b = sigma.mk a' b' := + definition dpair_eq_dpair (p : a = a') (q : p ▹ b = b') : ⟨a, b⟩ = ⟨a', b'⟩ := eq.rec_on p (λb b' q, eq.rec_on q idp) b b' q /- In Coq they often have to give u and v explicitly -/ - protected definition path (p : u.1 = v.1) (q : p ▹ u.2 = v.2) : u = v := + definition sigma_eq (p : u.1 = v.1) (q : p ▹ u.2 = v.2) : u = v := destruct u (λu1 u2, destruct v (λ v1 v2, dpair_eq_dpair)) p q /- Projections of paths from a total space -/ - definition path_pr1 (p : u = v) : u.1 = v.1 := + definition eq_pr1 (p : u = v) : u.1 = v.1 := ap pr1 p - postfix `..1`:(max+1) := path_pr1 + postfix `..1`:(max+1) := eq_pr1 - definition path_pr2 (p : u = v) : p..1 ▹ u.2 = v.2 := + definition eq_pr2 (p : u = v) : p..1 ▹ u.2 = v.2 := eq.rec_on p idp --Coq uses the following proof, which only computes if u,v are dpairs AND p is idp --(transport_compose B dpr1 p u.2)⁻¹ ⬝ apD dpr2 p - postfix `..2`:(max+1) := path_pr2 + postfix `..2`:(max+1) := eq_pr2 - definition dpair_sigma_path (p : u.1 = v.1) (q : p ▹ u.2 = v.2) - : sigma.mk (sigma.path p q)..1 (sigma.path p q)..2 = ⟨p, q⟩ := + private definition dpair_sigma_eq (p : u.1 = v.1) (q : p ▹ u.2 = v.2) + : ⟨(sigma_eq p q)..1, (sigma_eq p q)..2⟩ = ⟨p, q⟩ := begin reverts (p, q), apply (destruct u), intros (u1, u2), @@ -59,22 +59,22 @@ namespace sigma apply (eq.rec_on q), apply idp end - definition sigma_path_pr1 (p : u.1 = v.1) (q : p ▹ u.2 = v.2) : (sigma.path p q)..1 = p := - (!dpair_sigma_path)..1 + definition sigma_eq_pr1 (p : u.1 = v.1) (q : p ▹ u.2 = v.2) : (sigma_eq p q)..1 = p := + (!dpair_sigma_eq)..1 - definition sigma_path_pr2 (p : u.1 = v.1) (q : p ▹ u.2 = v.2) - : sigma_path_pr1 p q ▹ (sigma.path p q)..2 = q := - (!dpair_sigma_path)..2 + definition sigma_eq_pr2 (p : u.1 = v.1) (q : p ▹ u.2 = v.2) + : sigma_eq_pr1 p q ▹ (sigma_eq p q)..2 = q := + (!dpair_sigma_eq)..2 - definition sigma_path_eta (p : u = v) : sigma.path (p..1) (p..2) = p := + definition sigma_eq_eta (p : u = v) : sigma_eq (p..1) (p..2) = p := begin apply (eq.rec_on p), apply (destruct u), intros (u1, u2), apply idp end - definition transport_dpr1_sigma_path {B' : A → Type} (p : u.1 = v.1) (q : p ▹ u.2 = v.2) - : transport (λx, B' x.1) (sigma.path p q) = transport B' p := + definition tr_pr1_sigma_eq {B' : A → Type} (p : u.1 = v.1) (q : p ▹ u.2 = v.2) + : transport (λx, B' x.1) (sigma_eq p q) = transport B' p := begin reverts (p, q), apply (destruct u), intros (u1, u2), @@ -85,42 +85,42 @@ namespace sigma /- the uncurried version of sigma_eq. We will prove that this is an equivalence -/ - definition sigma_path_uncurried (pq : Σ(p : pr1 u = pr1 v), p ▹ (pr2 u) = pr2 v) : u = v := - destruct pq sigma.path + definition sigma_eq_uncurried (pq : Σ(p : pr1 u = pr1 v), p ▹ (pr2 u) = pr2 v) : u = v := + destruct pq sigma_eq - definition dpair_sigma_path_uncurried (pq : Σ(p : u.1 = v.1), p ▹ u.2 = v.2) - : sigma.mk (sigma_path_uncurried pq)..1 (sigma_path_uncurried pq)..2 = pq := - destruct pq dpair_sigma_path + definition dpair_sigma_eq_uncurried (pq : Σ(p : u.1 = v.1), p ▹ u.2 = v.2) + : sigma.mk (sigma_eq_uncurried pq)..1 (sigma_eq_uncurried pq)..2 = pq := + destruct pq dpair_sigma_eq - definition sigma_path_pr1_uncurried (pq : Σ(p : u.1 = v.1), p ▹ u.2 = v.2) - : (sigma_path_uncurried pq)..1 = pq.1 := - (!dpair_sigma_path_uncurried)..1 + definition sigma_eq_pr1_uncurried (pq : Σ(p : u.1 = v.1), p ▹ u.2 = v.2) + : (sigma_eq_uncurried pq)..1 = pq.1 := + (!dpair_sigma_eq_uncurried)..1 - definition sigma_path_pr2_uncurried (pq : Σ(p : u.1 = v.1), p ▹ u.2 = v.2) - : (sigma_path_pr1_uncurried pq) ▹ (sigma_path_uncurried pq)..2 = pq.2 := - (!dpair_sigma_path_uncurried)..2 + definition sigma_eq_pr2_uncurried (pq : Σ(p : u.1 = v.1), p ▹ u.2 = v.2) + : (sigma_eq_pr1_uncurried pq) ▹ (sigma_eq_uncurried pq)..2 = pq.2 := + (!dpair_sigma_eq_uncurried)..2 - definition sigma_path_eta_uncurried (p : u = v) : sigma_path_uncurried (sigma.mk p..1 p..2) = p := - !sigma_path_eta + definition sigma_eq_eta_uncurried (p : u = v) : sigma_eq_uncurried (sigma.mk p..1 p..2) = p := + !sigma_eq_eta - definition transport_sigma_path_dpr1_uncurried {B' : A → Type} + definition tr_sigma_eq_pr1_uncurried {B' : A → Type} (pq : Σ(p : u.1 = v.1), p ▹ u.2 = v.2) - : transport (λx, B' x.1) (@sigma_path_uncurried A B u v pq) = transport B' pq.1 := - destruct pq transport_dpr1_sigma_path + : transport (λx, B' x.1) (@sigma_eq_uncurried A B u v pq) = transport B' pq.1 := + destruct pq tr_pr1_sigma_eq - definition is_equiv_sigma_path [instance] (u v : Σa, B a) - : is_equiv (@sigma_path_uncurried A B u v) := - adjointify sigma_path_uncurried + definition is_equiv_sigma_eq [instance] (u v : Σa, B a) + : is_equiv (@sigma_eq_uncurried A B u v) := + adjointify sigma_eq_uncurried (λp, ⟨p..1, p..2⟩) - sigma_path_eta_uncurried - dpair_sigma_path_uncurried + sigma_eq_eta_uncurried + dpair_sigma_eq_uncurried - definition equiv_sigma_path (u v : Σa, B a) : (Σ(p : u.1 = v.1), p ▹ u.2 = v.2) ≃ (u = v) := - equiv.mk sigma_path_uncurried !is_equiv_sigma_path + definition equiv_sigma_eq (u v : Σa, B a) : (Σ(p : u.1 = v.1), p ▹ u.2 = v.2) ≃ (u = v) := + equiv.mk sigma_eq_uncurried !is_equiv_sigma_eq - definition dpair_eq_dpair_pp_pp (p1 : a = a' ) (q1 : p1 ▹ b = b' ) + definition dpair_eq_dpair_con (p1 : a = a' ) (q1 : p1 ▹ b = b' ) (p2 : a' = a'') (q2 : p2 ▹ b' = b'') : - dpair_eq_dpair (p1 ⬝ p2) (transport_pp B p1 p2 b ⬝ ap (transport B p2) q1 ⬝ q2) + dpair_eq_dpair (p1 ⬝ p2) (tr_con B p1 p2 b ⬝ ap (transport B p2) q1 ⬝ q2) = dpair_eq_dpair p1 q1 ⬝ dpair_eq_dpair p2 q2 := begin reverts (b', p2, b'', q1, q2), @@ -130,20 +130,20 @@ namespace sigma apply (eq.rec_on q2), apply idp end - definition sigma_path_pp_pp (p1 : u.1 = v.1) (q1 : p1 ▹ u.2 = v.2) + definition sigma_eq_con (p1 : u.1 = v.1) (q1 : p1 ▹ u.2 = v.2) (p2 : v.1 = w.1) (q2 : p2 ▹ v.2 = w.2) : - sigma.path (p1 ⬝ p2) (transport_pp B p1 p2 u.2 ⬝ ap (transport B p2) q1 ⬝ q2) - = sigma.path p1 q1 ⬝ sigma.path p2 q2 := + sigma_eq (p1 ⬝ p2) (tr_con B p1 p2 u.2 ⬝ ap (transport B p2) q1 ⬝ q2) + = sigma_eq p1 q1 ⬝ sigma_eq p2 q2 := begin reverts (p1, q1, p2, q2), apply (destruct u), intros (u1, u2), apply (destruct v), intros (v1, v2), apply (destruct w), intros, - apply dpair_eq_dpair_pp_pp + apply dpair_eq_dpair_con end local attribute dpair_eq_dpair [reducible] - definition dpair_eq_dpair_p1_1p (p : a = a') (q : p ▹ b = b') : + definition dpair_eq_dpair_con_idp (p : a = a') (q : p ▹ b = b') : dpair_eq_dpair p q = dpair_eq_dpair p idp ⬝ dpair_eq_dpair idp q := begin reverts (b', q), @@ -151,11 +151,11 @@ namespace sigma apply (eq.rec_on q), apply idp end - /- path_pr1 commutes with the groupoid structure. -/ + /- eq_pr1 commutes with the groupoid structure. -/ - definition path_pr1_idp (u : Σa, B a) : (refl u)..1 = refl (u.1) := idp - definition path_pr1_pp (p : u = v) (q : v = w) : (p ⬝ q) ..1 = (p..1) ⬝ (q..1) := !ap_pp - definition path_pr1_V (p : u = v) : p⁻¹ ..1 = (p..1)⁻¹ := !ap_V + definition eq_pr1_idp (u : Σa, B a) : (refl u) ..1 = refl (u.1) := idp + definition eq_pr1_con (p : u = v) (q : v = w) : (p ⬝ q) ..1 = (p..1) ⬝ (q..1) := !ap_con + definition eq_pr1_inv (p : u = v) : p⁻¹ ..1 = (p..1)⁻¹ := !ap_inv /- Applying dpair to one argument is the same as dpair_eq_dpair with reflexivity in the first place. -/ @@ -168,8 +168,8 @@ namespace sigma p ▹D c = transport (λu, C (u.1) (u.2)) (dpair_eq_dpair p idp) c := eq.rec_on p idp - definition sigma_path_eq_sigma_path {p1 q1 : a = a'} {p2 : p1 ▹ b = b'} {q2 : q1 ▹ b = b'} - (r : p1 = q1) (s : r ▹ p2 = q2) : sigma.path p1 p2 = sigma.path q1 q2 := + definition sigma_eq_eq_sigma_eq {p1 q1 : a = a'} {p2 : p1 ▹ b = b'} {q2 : q1 ▹ b = b'} + (r : p1 = q1) (s : r ▹ p2 = q2) : sigma_eq p1 p2 = sigma_eq q1 q2 := eq.rec_on r proof (λq2 s, eq.rec_on s idp) qed q2 @@ -182,20 +182,21 @@ namespace sigma /- A path between paths in a total space is commonly shown component wise. -/ - definition path_sigma_path {p q : u = v} (r : p..1 = q..1) (s : r ▹ p..2 = q..2) : p = q := + definition sigma_eq2 {p q : u = v} (r : p..1 = q..1) (s : r ▹ p..2 = q..2) + : p = q := begin reverts (q, r, s), apply (eq.rec_on p), apply (destruct u), intros (u1, u2, q, r, s), apply concat, rotate 1, - apply sigma_path_eta, - apply (sigma_path_eq_sigma_path r s) + apply sigma_eq_eta, + apply (sigma_eq_eq_sigma_eq r s) end /- In Coq they often have to give u and v explicitly when using the following definition -/ - definition path_sigma_path_uncurried {p q : u = v} + definition sigma_eq2_uncurried {p q : u = v} (rs : Σ(r : p..1 = q..1), transport (λx, transport B x u.2 = v.2) r p..2 = q..2) : p = q := - destruct rs path_sigma_path + destruct rs sigma_eq2 /- Transport -/ @@ -212,7 +213,7 @@ namespace sigma end /- The special case when the second variable doesn't depend on the first is simpler. -/ - definition transport_eq_deg {B : Type} {C : A → B → Type} (p : a = a') (bc : Σ(b : B), C a b) + definition tr_eq_nondep {B : Type} {C : A → B → Type} (p : a = a') (bc : Σ(b : B), C a b) : p ▹ bc = ⟨bc.1, p ▹ bc.2⟩ := begin apply (eq.rec_on p), @@ -222,7 +223,7 @@ namespace sigma /- Or if the second variable contains a first component that doesn't depend on the first. -/ - definition transport_eq_4deg {C : A → Type} {D : Π a:A, B a → C a → Type} (p : a = a') + definition tr_eq2_nondep {C : A → Type} {D : Π a:A, B a → C a → Type} (p : a = a') (bcd : Σ(b : B a) (c : C a), D a b c) : p ▹ bcd = ⟨p ▹ bcd.1, p ▹ bcd.2.1, p ▹D2 bcd.2.2⟩ := begin revert bcd, @@ -235,70 +236,71 @@ namespace sigma /- Functorial action -/ variables (f : A → A') (g : Πa, B a → B' (f a)) - protected definition functor (u : Σa, B a) : Σa', B' a' := + definition sigma_functor (u : Σa, B a) : Σa', B' a' := ⟨f u.1, g u.1 u.2⟩ /- Equivalences -/ - --TODO: remove explicit arguments of is_equiv - definition is_equiv_functor [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)] - : is_equiv (functor f g) := - adjointify (functor f g) - (functor (f⁻¹) (λ(a' : A') (b' : B' a'), + definition is_equiv_sigma_functor [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)] + : is_equiv (sigma_functor f g) := + adjointify (sigma_functor f g) + (sigma_functor (f⁻¹) (λ(a' : A') (b' : B' a'), ((g (f⁻¹ a'))⁻¹ (transport B' (retr f a'⁻¹) b')))) begin intro u', apply (destruct u'), intros (a', b'), - apply (sigma.path (retr f a')), + apply (sigma_eq (retr f a')), + -- rewrite retr, + -- end -- "rewrite retr (g (f⁻¹ a'))" apply concat, apply (ap (λx, (transport B' (retr f a') x))), apply (retr (g (f⁻¹ a'))), show retr f a' ▹ (((retr f a') ⁻¹) ▹ b') = b', - from transport_pV B' (retr f a') b' + from tr_inv_tr B' (retr f a') b' end begin intro u, apply (destruct u), intros (a, b), - apply (sigma.path (sect f a)), + apply (sigma_eq (sect f a)), show transport B (sect f a) (g (f⁻¹ (f a))⁻¹ (transport B' (retr f (f a)⁻¹) (g a b))) = b, from calc transport B (sect f a) (g (f⁻¹ (f a))⁻¹ (transport B' (retr f (f a)⁻¹) (g a b))) = g a⁻¹ (transport (B' ∘ f) (sect f a) (transport B' (retr f (f a)⁻¹) (g a b))) - : ap_transport (sect f a) (λ a, g a⁻¹) + : fn_tr_eq_tr_fn (sect f a) (λ a, g a⁻¹) ... = g a⁻¹ (transport B' (ap f (sect f a)) (transport B' (retr f (f a)⁻¹) (g a b))) : ap (g a⁻¹) !transport_compose ... = g a⁻¹ (transport B' (ap f (sect f a)) (transport B' (ap f (sect f a)⁻¹) (g a b))) : ap (λ x, g a⁻¹ (transport B' (ap f (sect f a)) (transport B' (x⁻¹) (g a b)))) (adj f a) - ... = g a⁻¹ (g a b) : {!transport_pV} + ... = g a⁻¹ (g a b) : {!tr_inv_tr} ... = b : sect (g a) b end - -- -- "rewrite ap_transport" - -- apply concat, apply inverse, apply (ap_transport (sect f a) (λ a, g a⁻¹)), + -- -- "rewrite fn_tr_eq_tr_fn" + -- apply concat, apply inverse, apply (fn_tr_eq_tr_fn (sect f a) (λ a, g a⁻¹)), -- apply concat, apply (ap (g a⁻¹)), -- -- "rewrite transport_compose" -- apply concat, apply transport_compose, -- -- "rewrite adj" - -- -- "rewrite transport_pV" + -- -- "rewrite tr_inv_tr" -- apply sect, - definition equiv_functor_of_is_equiv [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)] + definition sigma_equiv_sigma_of_is_equiv [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)] : (Σa, B a) ≃ (Σa', B' a') := - equiv.mk (functor f g) !is_equiv_functor + equiv.mk (sigma_functor f g) !is_equiv_sigma_functor - context --remove + context attribute inv [irreducible] - attribute function.compose [irreducible] --remove - definition equiv_functor (Hf : A ≃ A') (Hg : Π a, B a ≃ B' (to_fun Hf a)) : + attribute function.compose [irreducible] --this is needed for the following class inference problem + definition sigma_equiv_sigma (Hf : A ≃ A') (Hg : Π a, B a ≃ B' (to_fun Hf a)) : (Σa, B a) ≃ (Σa', B' a') := - equiv_functor_of_is_equiv (to_fun Hf) (λ a, to_fun (Hg a)) - end --remove + sigma_equiv_sigma_of_is_equiv (to_fun Hf) (λ a, to_fun (Hg a)) + end - definition equiv_functor_id {B' : A → Type} (Hg : Π a, B a ≃ B' a) : (Σa, B a) ≃ Σa, B' a := - equiv_functor equiv.refl Hg + definition sigma_equiv_sigma_id {B' : A → Type} (Hg : Π a, B a ≃ B' a) : (Σa, B a) ≃ Σa, B' a := + sigma_equiv_sigma equiv.refl Hg - definition ap_functor_sigma_dpair (p : a = a') (q : p ▹ b = b') - : ap (sigma.functor f g) (sigma.path p q) - = sigma.path (ap f p) - (transport_compose _ f p (g a b)⁻¹ ⬝ ap_transport p g b⁻¹ ⬝ ap (g a') q) := + definition ap_sigma_functor_eq_dpair (p : a = a') (q : p ▹ b = b') + : ap (sigma.sigma_functor f g) (sigma_eq p q) + = sigma_eq (ap f p) + (transport_compose _ f p (g a b)⁻¹ ⬝ fn_tr_eq_tr_fn p g b⁻¹ ⬝ ap (g a') q) := begin reverts (b', q), apply (eq.rec_on p), @@ -306,47 +308,47 @@ namespace sigma apply idp end - definition ap_functor_sigma (p : u.1 = v.1) (q : p ▹ u.2 = v.2) - : ap (sigma.functor f g) (sigma.path p q) - = sigma.path (ap f p) - (transport_compose B' f p (g u.1 u.2)⁻¹ ⬝ ap_transport p g u.2⁻¹ ⬝ ap (g v.1) q) := + definition ap_sigma_functor_eq (p : u.1 = v.1) (q : p ▹ u.2 = v.2) + : ap (sigma.sigma_functor f g) (sigma_eq p q) + = sigma_eq (ap f p) + (transport_compose B' f p (g u.1 u.2)⁻¹ ⬝ fn_tr_eq_tr_fn p g u.2⁻¹ ⬝ ap (g v.1) q) := begin reverts (p, q), apply (destruct u), intros (a, b), apply (destruct v), intros (a', b', p, q), - apply ap_functor_sigma_dpair + apply ap_sigma_functor_eq_dpair end /- definition 3.11.9(i): Summing up a contractible family of types does nothing. -/ - open truncation - definition is_equiv_dpr1 [instance] (B : A → Type) [H : Π a, is_contr (B a)] + open is_trunc + definition is_equiv_pr1 [instance] (B : A → Type) [H : Π a, is_contr (B a)] : is_equiv (@pr1 A B) := adjointify pr1 (λa, ⟨a, !center⟩) (λa, idp) - (λu, sigma.path idp !contr) + (λu, sigma_eq idp !contr) - definition equiv_of_all_contr [H : Π a, is_contr (B a)] : (Σa, B a) ≃ A := + definition sigma_equiv_of_is_contr_pr2 [H : Π a, is_contr (B a)] : (Σa, B a) ≃ A := equiv.mk pr1 _ /- definition 3.11.9(ii): Dually, summing up over a contractible type does nothing. -/ - definition equiv_center_of_contr (B : A → Type) [H : is_contr A] : (Σa, B a) ≃ B (center A) + definition sigma_equiv_of_is_contr_pr1 (B : A → Type) [H : is_contr A] : (Σa, B a) ≃ B (center A) := equiv.mk _ (adjointify (λu, contr u.1⁻¹ ▹ u.2) (λb, ⟨!center, b⟩) - (λb, ap (λx, x ▹ b) !path2_contr) - (λu, sigma.path !contr !transport_pV)) + (λb, ap (λx, x ▹ b) !hprop_eq) + (λu, sigma_eq !contr !tr_inv_tr)) /- Associativity -/ --this proof is harder than in Coq because we don't have eta definitionally for sigma - protected definition assoc_equiv (C : (Σa, B a) → Type) : (Σa b, C ⟨a, b⟩) ≃ (Σu, C u) := + definition sigma_assoc_equiv (C : (Σa, B a) → Type) : (Σa b, C ⟨a, b⟩) ≃ (Σu, C u) := -- begin -- apply equiv.mk, -- apply (adjointify (λav, ⟨⟨av.1, av.2.1⟩, av.2.2⟩) - -- (λuc, ⟨uc.1.1, uc.1.2, !peta⁻¹ ▹ uc.2⟩)), + -- (λuc, ⟨uc.1.1, uc.1.2, !eta⁻¹ ▹ uc.2⟩)), -- intro uc, apply (destruct uc), intro u, -- apply (destruct u), intros (a, b, c), -- apply idp, @@ -356,7 +358,7 @@ namespace sigma -- end equiv.mk _ (adjointify (λav, ⟨⟨av.1, av.2.1⟩, av.2.2⟩) - (λuc, ⟨uc.1.1, uc.1.2, !peta⁻¹ ▹ uc.2⟩) + (λuc, ⟨uc.1.1, uc.1.2, !eta⁻¹ ▹ uc.2⟩) proof (λuc, destruct uc (λu, destruct u (λa b c, idp))) qed proof (λav, destruct av (λa v, destruct v (λb c, idp))) qed) @@ -364,20 +366,21 @@ namespace sigma definition assoc_equiv_prod (C : (A × A') → Type) : (Σa a', C (a,a')) ≃ (Σu, C u) := equiv.mk _ (adjointify (λav, ⟨(av.1, av.2.1), av.2.2⟩) - (λuc, ⟨pr₁ (uc.1), pr₂ (uc.1), !prod.peta⁻¹ ▹ uc.2⟩) + (λuc, ⟨pr₁ (uc.1), pr₂ (uc.1), !prod.eta⁻¹ ▹ uc.2⟩) proof (λuc, destruct uc (λu, prod.destruct u (λa b c, idp))) qed proof (λav, destruct av (λa v, destruct v (λb c, idp))) qed) /- Symmetry -/ - definition symm_equiv_uncurried (C : A × A' → Type) : (Σa a', C (a, a')) ≃ (Σa' a, C (a, a')) := + + definition comm_equiv_uncurried (C : A × A' → Type) : (Σa a', C (a, a')) ≃ (Σa' a, C (a, a')) := calc (Σa a', C (a, a')) ≃ Σu, C u : assoc_equiv_prod - ... ≃ Σv, C (flip v) : equiv_functor !prod.symm_equiv + ... ≃ Σv, C (flip v) : sigma_equiv_sigma !prod_comm_equiv (λu, prod.destruct u (λa a', equiv.refl)) ... ≃ (Σa' a, C (a, a')) : assoc_equiv_prod - definition symm_equiv (C : A → A' → Type) : (Σa a', C a a') ≃ (Σa' a, C a a') := - symm_equiv_uncurried (λu, C (prod.pr1 u) (prod.pr2 u)) + definition sigma_comm_equiv (C : A → A' → Type) : (Σa a', C a a') ≃ (Σa' a, C a a') := + comm_equiv_uncurried (λu, C (prod.pr1 u) (prod.pr2 u)) definition equiv_prod (A B : Type) : (Σ(a : A), B) ≃ A × B := equiv.mk _ (adjointify @@ -386,10 +389,10 @@ namespace sigma proof (λp, prod.destruct p (λa b, idp)) qed proof (λs, destruct s (λa b, idp)) qed) - definition symm_equiv_deg (A B : Type) : (Σ(a : A), B) ≃ Σ(b : B), A := + definition comm_equiv_nondep (A B : Type) : (Σ(a : A), B) ≃ Σ(b : B), A := calc (Σ(a : A), B) ≃ A × B : equiv_prod - ... ≃ B × A : prod.symm_equiv + ... ≃ B × A : prod_comm_equiv ... ≃ Σ(b : B), A : equiv_prod /- ** Universal mapping properties -/ @@ -397,79 +400,78 @@ namespace sigma section open funext - --in Coq this can be done without function extensionality - definition is_equiv_sigma_rec [instance] [FUN : funext] (C : (Σa, B a) → Type) + definition is_equiv_sigma_rec [instance] (C : (Σa, B a) → Type) : is_equiv (@sigma.rec _ _ C) := adjointify _ (λ g a b, g ⟨a, b⟩) - (λ g, proof path_pi (λu, destruct u (λa b, idp)) qed) + (λ g, proof eq_of_homotopy (λu, destruct u (λa b, idp)) qed) (λ f, refl f) - definition equiv_sigma_rec [FUN : funext] (C : (Σa, B a) → Type) + definition equiv_sigma_rec (C : (Σa, B a) → Type) : (Π(a : A) (b: B a), C ⟨a, b⟩) ≃ (Πxy, C xy) := equiv.mk sigma.rec _ /- *** The negative universal property. -/ - definition coind_uncurried (fg : Σ(f : Πa, B a), Πa, C a (f a)) (a : A) : Σ(b : B a), C a b + protected definition coind_uncurried (fg : Σ(f : Πa, B a), Πa, C a (f a)) (a : A) + : Σ(b : B a), C a b := ⟨fg.1 a, fg.2 a⟩ - definition coind (f : Π a, B a) (g : Π a, C a (f a)) (a : A) : Σ(b : B a), C a b := + protected definition coind (f : Π a, B a) (g : Π a, C a (f a)) (a : A) : Σ(b : B a), C a b := coind_uncurried ⟨f, g⟩ a --is the instance below dangerous? --in Coq this can be done without function extensionality - definition is_equiv_coind [instance] [FUN : funext] (C : Πa, B a → Type) + definition is_equiv_coind [instance] (C : Πa, B a → Type) : is_equiv (@coind_uncurried _ _ C) := adjointify _ (λ h, ⟨λa, (h a).1, λa, (h a).2⟩) - (λ h, proof path_pi (λu, !peta) qed) + (λ h, proof eq_of_homotopy (λu, !eta) qed) (λfg, destruct fg (λ(f : Π (a : A), B a) (g : Π (x : A), C x (f x)), proof idp qed)) - definition equiv_coind [FUN : funext] : (Σ(f : Πa, B a), Πa, C a (f a)) ≃ (Πa, Σb, C a b) := + definition equiv_coind : (Σ(f : Πa, B a), Πa, C a (f a)) ≃ (Πa, Σb, C a b) := equiv.mk coind_uncurried _ end /- ** Subtypes (sigma types whose second components are hprops) -/ /- To prove equality in a subtype, we only need equality of the first component. -/ - definition path_hprop [H : Πa, is_hprop (B a)] (u v : Σa, B a) : u.1 = v.1 → u = v := - (sigma_path_uncurried ∘ (@inv _ _ pr1 (@is_equiv_dpr1 _ _ (λp, !succ_is_trunc)))) + definition subtype_eq [H : Πa, is_hprop (B a)] (u v : Σa, B a) : u.1 = v.1 → u = v := + (sigma_eq_uncurried ∘ (@inv _ _ pr1 (@is_equiv_pr1 _ _ (λp, !is_trunc.is_trunc_eq)))) - definition is_equiv_path_hprop [instance] [H : Πa, is_hprop (B a)] (u v : Σa, B a) - : is_equiv (path_hprop u v) := - !is_equiv.compose + definition is_equiv_subtype_eq [instance] [H : Πa, is_hprop (B a)] (u v : Σa, B a) + : is_equiv (subtype_eq u v) := + !is_equiv_compose - definition equiv_path_hprop [H : Πa, is_hprop (B a)] (u v : Σa, B a) : (u.1 = v.1) ≃ (u = v) + definition equiv_subtype [H : Πa, is_hprop (B a)] (u v : Σa, B a) : (u.1 = v.1) ≃ (u = v) := - equiv.mk !path_hprop _ + equiv.mk !subtype_eq _ /- truncatedness -/ - definition trunc_sigma [instance] (B : A → Type) (n : trunc_index) + definition is_trunc_sigma (B : A → Type) (n : trunc_index) [HA : is_trunc n A] [HB : Πa, is_trunc n (B a)] : is_trunc n (Σa, B a) := begin reverts (A, B, HA, HB), apply (trunc_index.rec_on n), intros (A, B, HA, HB), - fapply trunc_equiv', + fapply is_trunc.is_trunc_equiv_closed, apply equiv.symm, - apply equiv_center_of_contr, + apply sigma_equiv_of_is_contr_pr1, intros (n, IH, A, B, HA, HB), - fapply is_trunc_succ, intros (u, v), - fapply trunc_equiv', - apply equiv_sigma_path, + fapply is_trunc.is_trunc_succ_intro, intros (u, v), + fapply is_trunc.is_trunc_equiv_closed, + apply equiv_sigma_eq, apply IH, - apply succ_is_trunc, + apply is_trunc.is_trunc_eq, intro p, show is_trunc n (p ▹ u .2 = v .2), from - succ_is_trunc n (p ▹ u.2) (v.2), + is_trunc.is_trunc_eq n (p ▹ u.2) (v.2), end end sigma -open truncation sigma +attribute sigma.is_trunc_sigma [instance] -namespace prod - /- truncatedness -/ - definition trunc_prod [instance] (A B : Type) (n : trunc_index) - [HA : is_trunc n A] [HB : is_trunc n B] : is_trunc n (A × B) := - trunc_equiv' n !equiv_prod -end prod +open is_trunc sigma prod +/- truncatedness -/ +definition prod.is_trunc_prod [instance] (A B : Type) (n : trunc_index) + [HA : is_trunc n A] [HB : is_trunc n B] : is_trunc n (A × B) := +is_trunc.is_trunc_equiv_closed n !equiv_prod diff --git a/hott/types/trunc.hlean b/hott/types/trunc.hlean new file mode 100644 index 0000000000..ae76e92e48 --- /dev/null +++ b/hott/types/trunc.hlean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2015 Jakob von Raumer. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Module: types.trunc +Authors: Jakob von Raumer, Floris van Doorn + +Properties of is_trunc +-/ + +import types.pi types.path + +open sigma sigma.ops pi function eq equiv path funext + +namespace is_trunc + + definition is_contr.sigma_char (A : Type) : + (Σ (center : A), Π (a : A), center = a) ≃ (is_contr A) := + begin + fapply equiv.mk, + intro S, apply is_contr.mk, exact S.2, + fapply is_equiv.adjointify, + intro H, apply sigma.mk, exact (@contr A H), + intro H, apply (is_trunc.rec_on H), intro Hint, + apply (contr_internal.rec_on Hint), intros (H1, H2), + apply idp, + intro S, apply (sigma.rec_on S), intros (H1, H2), + apply idp, + end + + set_option pp.implicit true + definition is_trunc.pi_char (n : trunc_index) (A : Type) : + (Π (x y : A), is_trunc n (x = y)) ≃ (is_trunc (n .+1) A) := + begin + fapply equiv.mk, + intro H, apply is_trunc_succ_intro, + fapply is_equiv.adjointify, + intros (H, x, y), apply is_trunc_eq, + intro H, apply (is_trunc.rec_on H), intro Hint, apply idp, + intro P, + unfold compose, apply eq_of_homotopy, + exact sorry, + end + + definition is_hprop_is_trunc {n : trunc_index} : + Π (A : Type), is_hprop (is_trunc n A) := + begin + apply (trunc_index.rec_on n), + intro A, + apply is_trunc_is_equiv_closed, apply equiv.to_is_equiv, + apply is_contr.sigma_char, + apply (@is_hprop.mk), intros, + fapply sigma_eq, apply x.2, + apply (@is_hprop.elim), + apply is_trunc_pi, intro a, + apply is_hprop.mk, intros (w, z), + assert (H : is_hset A), + apply is_trunc_succ, apply is_trunc_succ, + apply is_contr.mk, exact y.2, + fapply (@is_hset.elim A _ _ _ w z), + intros (n', IH, A), + apply is_trunc_is_equiv_closed, + apply equiv.to_is_equiv, + apply is_trunc.pi_char, + end + + definition is_trunc_succ_of_imp_is_trunc_succ {A : Type} {n : trunc_index} (H : A → is_trunc (n.+1) A) + : is_trunc (n.+1) A := + @is_trunc_succ_intro _ _ (λx y, @is_trunc_eq _ _ (H x) x y) + + definition is_trunc_of_imp_is_trunc_of_leq {A : Type} {n : trunc_index} (Hn : -1 ≤ n) + (H : A → is_trunc n A) : is_trunc n A := + trunc_index.rec_on n (λHn H, empty.rec _ Hn) + (λn IH Hn, is_trunc_succ_of_imp_is_trunc_succ) + Hn H + + definition is_hset_of_axiom_K {A : Type} (K : Π{a : A} (p : a = a), p = idp) : is_hset A := + is_hset.mk _ (λa b p q, eq.rec_on q K p) + + theorem is_hset_of_relation.{u} {A : Type.{u}} (R : A → A → Type.{u}) + (mere : Π(a b : A), is_hprop (R a b)) (refl : Π(a : A), R a a) + (imp : Π{a b : A}, R a b → a = b) : is_hset A := + is_hset_of_axiom_K + (λa p, + have H2 : transport (λx, R a x → a = x) p (@imp a a) = @imp a a, from !apD, + have H3 : Π(r : R a a), transport (λx, a = x) p (imp r) + = imp (transport (λx, R a x) p r), from + to_fun (symm !heq_pi) H2, + have H4 : imp (refl a) ⬝ p = imp (refl a), from + calc + imp (refl a) ⬝ p = transport (λx, a = x) p (imp (refl a)) : transport_paths_r + ... = imp (transport (λx, R a x) p (refl a)) : H3 + ... = imp (refl a) : is_hprop.elim, + cancel_left (imp (refl a)) _ _ H4) + + definition relation_equiv_eq {A : Type} (R : A → A → Type) + (mere : Π(a b : A), is_hprop (R a b)) (refl : Π(a : A), R a a) + (imp : Π{a b : A}, R a b → a = b) (a b : A) : R a b ≃ a = b := + @equiv_of_is_hprop _ _ _ + (@is_trunc_eq _ _ (is_hset_of_relation R mere refl @imp) a b) + imp + (λp, p ▹ refl a) + + definition is_hset_of_double_neg_elim {A : Type} (H : Π(a b : A), ¬¬a = b → a = b) + : is_hset A := + is_hset_of_relation (λa b, ¬¬a = b) _ (λa n, n idp) H + + section + open decidable + definition is_hset_of_decidable_eq (A : Type) + [H : Π(a b : A), decidable (a = b)] : is_hset A := + is_hset_of_double_neg_elim (λa b, by_contradiction) + end + + definition is_trunc_of_axiom_K_of_leq {A : Type} (n : trunc_index) (H : -1 ≤ n) + (K : Π(a : A), is_trunc n (a = a)) : is_trunc (n.+1) A := + @is_trunc_succ_intro _ _ (λa b, is_trunc_of_imp_is_trunc_of_leq H (λp, eq.rec_on p !K)) + +end is_trunc diff --git a/src/library/constants.txt b/src/library/constants.txt index 6d10ee0be5..2418c0d0a3 100644 --- a/src/library/constants.txt +++ b/src/library/constants.txt @@ -101,9 +101,9 @@ tactic.unfold tactic.whnf true true.intro -truncation -truncation.is_trunc -truncation.nat_to_trunc_index +is_trunc +is_trunc +is_trunc.trunc_index.of_nat unit unit.star well_founded