michael/lean2
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(hott): rename definition and cleanup in HoTT library

Browse source 
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
This commit is contained in:
Floris van Doorn 2015-02-20 19:30:32 -05:00
parent 33e562a7ce
commit 61901cff81
48 changed files with 1971 additions and 1395 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
hott/algebra/category/basic.hlean
View file

@ -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

20
hott/algebra/category/set.hlean
View file

@ -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

184
hott/algebra/group.hlean
View file

@ -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

22
hott/algebra/groupoid.hlean
View file

@ -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,

30
hott/algebra/precategory/basic.hlean
View file

@ -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

285
hott/algebra/precategory/constructions.hlean
View file

@ -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

46
hott/algebra/precategory/functor.hlean
View file

@ -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

14
hott/algebra/precategory/iso.hlean
View file

@ -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

100
hott/algebra/precategory/morphism.hlean
View file

@ -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

94
hott/algebra/precategory/natural_transformation.hlean → hott/algebra/precategory/nat_trans.hlean
View file

@ -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

91
hott/algebra/precategory/yoneda.hlean Normal file
View file

@ -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

8
hott/default.hlean
View file

@ -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

77
hott/equiv_precomp.hlean
View file

@ -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

20
hott/init/axioms/funext.hlean
View file

@ -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

36
hott/init/axioms/funext_from_ua.hlean → hott/init/axioms/funext_of_ua.hlean
View file

@ -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)

53
hott/init/axioms/funext_varieties.hlean
View file

@ -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

26
hott/init/axioms/ua.hlean
View file

@ -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

2
hott/init/bool.hlean
View file

@ -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

1
hott/init/datatypes.hlean
View file

@ -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

3
hott/init/default.hlean
View file

@ -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

204
hott/init/equiv.hlean
View file

@ -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

2
hott/init/function.hlean
View file

@ -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.

2
hott/init/hedberg.hlean
View file

@ -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

19
hott/init/logic.hlean
View file

@ -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,

1
hott/init/nat.hlean
View file

@ -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

475
hott/init/path.hlean
View file

@ -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

1
hott/init/priority.hlean
View file

@ -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

2
hott/init/relation.hlean
View file

@ -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

1
hott/init/reserved_notation.hlean
View file

@ -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

1
hott/init/tactic.hlean
View file

@ -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

195
hott/init/trunc.hlean
View file

@ -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

10
hott/init/types/empty.hlean
View file

@ -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

12
hott/init/types/prod.hlean
View file

@ -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

6
hott/init/types/sigma.hlean
View file

@ -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

1
hott/init/types/sum.hlean
View file

@ -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

3
hott/init/util.hlean
View file

@ -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 :=

2
hott/init/wf.hlean
View file

@ -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

1
hott/logic.hlean
View file

@ -1,3 +1,4 @@
exit
--javra: Maybe this should go somewhere else
open eq

61
hott/trunc.hlean
View file

@ -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

2
hott/truncation.hlean
View file

@ -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

42
hott/types/W.hlean
View file

@ -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

572
hott/types/path.hlean Normal file
View file

@ -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

157
hott/types/pi.hlean
View file

@ -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]

25
hott/pointed.hlean → hott/types/pointed.hlean
View file

@ -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

21
hott/types/prod.hlean
View file

@ -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

282
hott/types/sigma.hlean
View file

@ -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

119
hott/types/trunc.hlean Normal file
View file

@ -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

6
src/library/constants.txt
View file

@ -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