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

backport some changes from lean 3

Browse source 
ap_compose' is reversed, and is_trunc_equiv_closed and variants don't have a type class argument anymore
This commit is contained in:
Floris van Doorn 2018-09-07 15:57:43 +02:00
parent 04c80c477f
commit afdcf7cb71
33 changed files with 190 additions and 211 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
hott/algebra/category/constructions/comma.hlean
View file

@ -34,7 +34,7 @@ namespace category
theorem is_trunc_comma_object (n : trunc_index) [HA : is_trunc n A]
[HB : is_trunc n B] [H : Π(s d : C), is_trunc n (hom s d)] : is_trunc n (comma_object S T) :=
by apply is_trunc_equiv_closed;apply comma_object_sigma_char
is_trunc_equiv_closed n !comma_object_sigma_char _
variables {S T}
definition comma_object_eq' {x y : comma_object S T} (p : ob1 x = ob1 y) (q : ob2 x = ob2 y)
@ -105,7 +105,7 @@ namespace category
theorem is_trunc_comma_morphism (n : trunc_index) [H1 : is_trunc n (ob1 x ⟶ ob1 y)]
[H2 : is_trunc n (ob2 x ⟶ ob2 y)] [Hp : Πm1 m2, is_trunc n (T m2 ∘ mor x = mor y ∘ S m1)]
: is_trunc n (comma_morphism x y) :=
by apply is_trunc_equiv_closed; apply comma_morphism_sigma_char
is_trunc_equiv_closed n !comma_morphism_sigma_char _
variables {x y z w}
definition comma_morphism_eq {f f' : comma_morphism x y}

2
hott/algebra/category/constructions/pushout.hlean
View file

@ -418,7 +418,7 @@ namespace category
{ exact Cpushout_functor_inl η},
{ exact Cpushout_functor_inr η}},
esimp, apply iso_pathover, apply hom_pathover,
rewrite [ap_compose' _ pr₁, ap_compose' _ pr₂, prod_eq_pr1, prod_eq_pr2],
rewrite [-ap_compose' _ pr₁, -ap_compose' _ pr₂, prod_eq_pr1, prod_eq_pr2],
rewrite [-+respect_hom_of_eq (precomposition_functor _ _), +hom_of_eq_eq_of_iso],
apply nat_trans_eq, intro c, esimp [category.to_precategory],
rewrite [+id_left, +id_right, Cpushout_functor_list_singleton] end end},

2
hott/algebra/category/constructions/rezk.hlean
View file

@ -114,7 +114,7 @@ namespace rezk
transport (elim_set Pe Pp Pcomp) (pth f) = Pp f :=
begin
rewrite [tr_eq_cast_ap_fn, ↑elim_set, ▸*],
rewrite [ap_compose' trunctype.carrier, elim_pth], apply tcast_tua_fn
rewrite [-ap_compose' trunctype.carrier, elim_pth], apply tcast_tua_fn
end
end

2
hott/algebra/category/functor/basic.hlean
View file

@ -185,7 +185,7 @@ namespace functor
local attribute trunctype.struct [instance] [priority 1] -- remove after #842 is closed
protected theorem is_set_functor [instance]
[HD : is_set D] : is_set (functor C D) :=
by apply is_trunc_equiv_closed; apply functor.sigma_char
is_trunc_equiv_closed 0 !functor.sigma_char _
end
/- higher equalities in the functor type -/

2
hott/algebra/category/functor/equivalence.hlean
View file

@ -283,7 +283,7 @@ namespace category
{ intro H, induction H with H1 H2, induction H1, induction H2, reflexivity},
{ intro H, induction H, reflexivity}
end,
apply is_trunc_equiv_closed_rev, exact f,
exact is_trunc_equiv_closed_rev -1 f _
end
theorem is_prop_is_isomorphism [instance] (F : C ⇒ D) : is_prop (is_isomorphism F) :=

6
hott/algebra/group_theory.hlean
View file

@ -84,7 +84,7 @@ namespace group
{ intro v, induction v, reflexivity},
{ intro φ, induction φ, reflexivity}
end,
apply is_trunc_equiv_closed_rev, exact H
exact is_trunc_equiv_closed_rev 0 H _
end
variables {G₁ G₂}
@ -297,7 +297,7 @@ namespace group
{ intro v, induction v, reflexivity },
{ intro φ, induction φ, reflexivity }
end,
apply is_trunc_equiv_closed_rev, exact H
exact is_trunc_equiv_closed_rev _ H _
end
definition trivial_homomorphism (A B : Group) : A →g B :=
@ -345,7 +345,7 @@ namespace group
mul_one := group_equiv_mul_one,
inv := group_equiv_inv,
mul_left_inv := group_equiv_mul_left_inv,
is_set_carrier := is_trunc_equiv_closed 0 f⦄
is_set_carrier := is_trunc_equiv_closed 0 f _ ⦄
end

2
hott/choice.hlean
View file

@ -56,7 +56,7 @@ namespace choice
begin
intro H, apply not_is_prop_bool_eq_bool,
apply @is_trunc_equiv_closed (x0 = x0),
apply equiv.symm !equiv_subtype
apply equiv.symm !equiv_subtype, exact _
end
definition is_set_x1 (x : X) : is_set x.1 :=

8
hott/cubical/square.hlean
View file

@ -529,7 +529,7 @@ namespace eq
definition is_trunc_square [instance] (n : trunc_index) [H : is_trunc n .+2 A]
: is_trunc n (square p₁₀ p₁₂ p₀₁ p₂₁) :=
is_trunc_equiv_closed_rev n !square_equiv_eq
is_trunc_equiv_closed_rev n !square_equiv_eq _
-- definition square_of_con_inv_hsquare {p₁ p₂ p₃ p₄ : a₁ = a₂}
-- {t : p₁ = p₂} {b : p₃ = p₄} {l : p₁ = p₃} {r : p₂ = p₄}
@ -634,6 +634,12 @@ namespace eq
induction q, esimp at r, induction r using idp_rec_on, exact hrfl
end
definition natural_square2 {A B X : Type} {C : A → B → Type}
{a a₂ : A} {b b₂ : B} {c : C a b} {c₂ : C a₂ b₂} {f : A → X} {g : B → X}
(h : Πa b, C a b → f a = g b) (p : a = a₂) (q : b = b₂) (r : transport11 C p q c = c₂) :
square (h a b c) (h a₂ b₂ c₂) (ap f p) (ap g q) :=
by induction p; induction q; induction r; exact vrfl
/- some higher coherence conditions -/

2
hott/hit/groupoid_quotient.hlean
View file

@ -145,7 +145,7 @@ section
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b) (x : Pe a), Pp (g ∘ f) x = Pp g (Pp f x))
{a b : G} (f : a ⟶ b) :
transport (elim_set Pe Pp Pcomp) (pth f) = Pp f :=
by rewrite [tr_eq_cast_ap_fn, ↑elim_set, ▸*, ap_compose' trunctype.carrier, elim_pth];
by rewrite [tr_eq_cast_ap_fn, ↑elim_set, ▸*, -ap_compose' trunctype.carrier, elim_pth];
apply tcast_tua_fn
end

2
hott/hit/prop_trunc.hlean
View file

@ -119,7 +119,7 @@ namespace one_step_tr
{ have q : trunc -1 ((tr_eq a a) = idp),
begin
refine to_fun !tr_eq_tr_equiv _,
refine @is_prop.elim _ _ _ _, apply is_trunc_equiv_closed, apply tr_eq_tr_equiv
refine @is_prop.elim _ _ _ _, exact is_trunc_equiv_closed -1 !tr_eq_tr_equiv _
end,
refine trunc.elim_on q _, clear q, intro p, exact !tr_eq_ne_idp p},
{ apply is_prop.elim}

8
hott/hit/pushout.hlean
View file

@ -184,7 +184,7 @@ namespace pushout
{ apply ap inl, reflexivity },
{ apply ap inr, reflexivity },
{ unfold F, unfold G, apply eq_pathover,
rewrite [ap_id,ap_compose' (quotient.elim _ _)],
rewrite [ap_id,-ap_compose' (quotient.elim _ _)],
krewrite elim_glue, krewrite elim_eq_of_rel, apply hrefl } },
{ intro q, induction q with z z z' fr,
{ induction z with a p, induction a with x x,
@ -192,7 +192,7 @@ namespace pushout
{ reflexivity } },
{ induction fr with a a' r p, induction r with x,
esimp, apply eq_pathover,
rewrite [ap_id,ap_compose' (pushout.elim _ _ _)],
rewrite [ap_id,-ap_compose' (pushout.elim _ _ _)],
krewrite elim_eq_of_rel, krewrite elim_glue, apply hrefl } }
end
end
@ -276,7 +276,7 @@ namespace pushout
{ apply ap inl, apply right_inv },
{ apply ap inr, apply right_inv },
{ apply eq_pathover,
rewrite [ap_id,ap_compose' (pushout.functor tl bl tr fh gh)],
rewrite [ap_id,-ap_compose' (pushout.functor tl bl tr fh gh)],
krewrite elim_glue,
rewrite [ap_inv,ap_con,ap_inv],
krewrite [pushout.ap_functor_inr], rewrite ap_con,
@ -307,7 +307,7 @@ namespace pushout
{ apply ap inl, apply left_inv },
{ apply ap inr, apply left_inv },
{ apply eq_pathover,
rewrite [ap_id,ap_compose'
rewrite [ap_id,-ap_compose'
(pushout.functor tl⁻¹ bl⁻¹ tr⁻¹ _ _)
(pushout.functor tl bl tr _ _)],
krewrite elim_glue,

140
hott/hit/quotient.hlean
View file

@ -212,96 +212,68 @@ namespace quotient
end flattening
section
open is_equiv equiv prod prod.ops
variables {A : Type} (R : A → A → Type)
{B : Type} (Q : B → B → Type)
(f : A → B) (k : Πa a' : A, R a a' → Q (f a) (f a'))
include f k
open is_equiv equiv prod function
variables {A : Type} {R : A → A → Type}
{B : Type} {Q : B → B → Type}
{C : Type} {S : C → C → Type}
(f : A → B) (k : Πa a' : A, R a a' → Q (f a) (f a'))
(g : B → C) (l : Πb b' : B, Q b b' → S (g b) (g b'))
protected definition functor [reducible] : quotient R → quotient Q :=
protected definition functor : quotient R → quotient Q :=
quotient.elim (λa, class_of Q (f a)) (λa a' r, eq_of_rel Q (k a a' r))
definition functor_class_of (a : A) :
quotient.functor f k (class_of R a) = class_of Q (f a) :=
by reflexivity
definition functor_eq_of_rel {a a' : A} (r : R a a') :
ap (quotient.functor f k) (eq_of_rel R r) = eq_of_rel Q (k a a' r) :=
elim_eq_of_rel _ _ r
protected definition functor_compose :
quotient.functor (g ∘ f) (λa a' r, l (f a) (f a') (k a a' r)) ~
quotient.functor g l ∘ quotient.functor f k :=
begin
intro x, induction x,
{ reflexivity },
{ apply eq_pathover, refine hdeg_square _ ⬝hp (ap_compose (quotient.functor g l) _ _)⁻¹,
refine !functor_eq_of_rel ⬝ !functor_eq_of_rel⁻¹ ⬝ ap02 _ !functor_eq_of_rel⁻¹ }
end
protected definition functor_homotopy {f f' : A → B} {k : Πa a' : A, R a a' → Q (f a) (f a')}
{k' : Πa a' : A, R a a' → Q (f' a) (f' a')} (h : f ~ f')
(h2 : Π(a a' : A) (r : R a a'), transport11 Q (h a) (h a') (k a a' r) = k' a a' r) :
quotient.functor f k ~ quotient.functor f' k' :=
begin
intro x, induction x with a a a' r,
{ exact ap (class_of Q) (h a) },
{ apply eq_pathover, refine !functor_eq_of_rel ⬝ph _ ⬝hp !functor_eq_of_rel⁻¹,
apply transpose, apply natural_square2 (eq_of_rel Q), apply h2 }
end
protected definition functor_id (x : quotient R) :
quotient.functor id (λa a' r, r) x = x :=
begin
induction x,
{ reflexivity },
{ apply eq_pathover_id_right, apply hdeg_square, apply functor_eq_of_rel }
end
variables [F : is_equiv f] [K : Πa a', is_equiv (k a a')]
include F K
protected definition functor_inv [reducible] : quotient Q → quotient R :=
quotient.elim (λb, class_of R (f⁻¹ b))
(λb b' q, eq_of_rel R ((k (f⁻¹ b) (f⁻¹ b'))⁻¹
((right_inv f b)⁻¹ ▸ (right_inv f b')⁻¹ ▸ q)))
protected definition is_equiv [instance]
: is_equiv (quotient.functor R Q f k):=
protected definition is_equiv [instance] : is_equiv (quotient.functor f k) :=
begin
fapply adjointify _ (quotient.functor_inv R Q f k),
{ intro qb, induction qb with b b b' q,
{ apply ap (class_of Q), apply right_inv },
{ apply eq_pathover, rewrite [ap_id,ap_compose' (quotient.elim _ _)],
do 2 krewrite elim_eq_of_rel, rewrite (right_inv (k (f⁻¹ b) (f⁻¹ b'))),
have H1 : pathover (λz : B × B, Q z.1 z.2)
((right_inv f b)⁻¹ ▸ (right_inv f b')⁻¹ ▸ q)
(prod_eq (right_inv f b) (right_inv f b')) q,
begin apply pathover_of_eq_tr, krewrite [prod_eq_inv,prod_eq_transport] end,
have H2 : square
(ap (λx : (Σz : B × B, Q z.1 z.2), class_of Q x.1.1)
(sigma_eq (prod_eq (right_inv f b) (right_inv f b')) H1))
(ap (λx : (Σz : B × B, Q z.1 z.2), class_of Q x.1.2)
(sigma_eq (prod_eq (right_inv f b) (right_inv f b')) H1))
(eq_of_rel Q ((right_inv f b)⁻¹ ▸ (right_inv f b')⁻¹ ▸ q))
(eq_of_rel Q q),
from
natural_square_tr (λw : (Σz : B × B, Q z.1 z.2), eq_of_rel Q w.2)
(sigma_eq (prod_eq (right_inv f b) (right_inv f b')) H1),
krewrite (ap_compose' (class_of Q)) at H2,
krewrite (ap_compose' (λz : B × B, z.1)) at H2,
rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
krewrite prod.ap_pr1 at H2, krewrite prod_eq_pr1 at H2,
krewrite (ap_compose' (class_of Q) (λx : (Σz : B × B, Q z.1 z.2), x.1.2)) at H2,
krewrite (ap_compose' (λz : B × B, z.2)) at H2,
rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
krewrite prod.ap_pr2 at H2, krewrite prod_eq_pr2 at H2,
apply H2 } },
{ intro qa, induction qa with a a a' r,
{ apply ap (class_of R), apply left_inv },
{ apply eq_pathover, rewrite [ap_id,(ap_compose' (quotient.elim _ _))],
do 2 krewrite elim_eq_of_rel,
have H1 : pathover (λz : A × A, R z.1 z.2)
((left_inv f a)⁻¹ ▸ (left_inv f a')⁻¹ ▸ r)
(prod_eq (left_inv f a) (left_inv f a')) r,
begin apply pathover_of_eq_tr, krewrite [prod_eq_inv,prod_eq_transport] end,
have H2 : square
(ap (λx : (Σz : A × A, R z.1 z.2), class_of R x.1.1)
(sigma_eq (prod_eq (left_inv f a) (left_inv f a')) H1))
(ap (λx : (Σz : A × A, R z.1 z.2), class_of R x.1.2)
(sigma_eq (prod_eq (left_inv f a) (left_inv f a')) H1))
(eq_of_rel R ((left_inv f a)⁻¹ ▸ (left_inv f a')⁻¹ ▸ r))
(eq_of_rel R r),
begin
exact
natural_square_tr (λw : (Σz : A × A, R z.1 z.2), eq_of_rel R w.2)
(sigma_eq (prod_eq (left_inv f a) (left_inv f a')) H1)
end,
krewrite (ap_compose' (class_of R)) at H2,
krewrite (ap_compose' (λz : A × A, z.1)) at H2,
rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
krewrite prod.ap_pr1 at H2, krewrite prod_eq_pr1 at H2,
krewrite (ap_compose' (class_of R) (λx : (Σz : A × A, R z.1 z.2), x.1.2)) at H2,
krewrite (ap_compose' (λz : A × A, z.2)) at H2,
rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
krewrite prod.ap_pr2 at H2, krewrite prod_eq_pr2 at H2,
have H3 :
(k (f⁻¹ (f a)) (f⁻¹ (f a')))⁻¹
((right_inv f (f a))⁻¹ ▸ (right_inv f (f a'))⁻¹ ▸ k a a' r)
= (left_inv f a)⁻¹ ▸ (left_inv f a')⁻¹ ▸ r,
begin
rewrite [adj f a,adj f a',ap_inv',ap_inv'],
rewrite [-(tr_compose _ f (left_inv f a')⁻¹ (k a a' r)),
-(tr_compose _ f (left_inv f a)⁻¹)],
rewrite [-(fn_tr_eq_tr_fn (left_inv f a')⁻¹ (λx, k a x) r),
-(fn_tr_eq_tr_fn (left_inv f a)⁻¹
(λx, k x (f⁻¹ (f a')))),
left_inv (k _ _)]
end,
rewrite H3, apply H2 } }
apply adjointify _ (quotient.functor f⁻¹ᶠ
(λb b' q, (k (f⁻¹ᶠ b) (f⁻¹ᶠ b'))⁻¹ᶠ (transport11 Q (right_inv f b)⁻¹ (right_inv f b')⁻¹ q))),
exact abstract begin intro x, refine (quotient.functor_compose _ _ _ _ x)⁻¹ ⬝ _ ⬝ quotient.functor_id x,
apply quotient.functor_homotopy (right_inv f), intros a a' r,
rewrite [right_inv (k _ _), -transport11_con, con.left_inv, con.left_inv] end end,
exact abstract begin intro x, refine (quotient.functor_compose _ _ _ _ x)⁻¹ ⬝ _ ⬝ quotient.functor_id x,
apply quotient.functor_homotopy (left_inv f), intros a a' r,
rewrite [adj f, adj f, -ap_inv, -ap_inv, transport11_ap,
-fn_transport11_eq_transport11_fn _ _ _ _ k, left_inv (k _ _), -transport11_con,
con.left_inv, con.left_inv] end end
end
end
@ -313,7 +285,7 @@ section
/- This could also be proved using ua, but then it wouldn't compute -/
protected definition equiv : quotient R ≃ quotient Q :=
equiv.mk (quotient.functor R Q f k) _
equiv.mk (quotient.functor f k) _
end

6
hott/homotopy/circle.hlean
View file

@ -309,7 +309,7 @@ namespace circle
definition homotopy_group_of_circle (n : ℕ) : πg[n+2] S¹* ≃g G0 :=
begin
refine @trivial_homotopy_add_of_is_set_loopn S¹* 1 n _,
apply is_trunc_equiv_closed_rev, apply base_eq_base_equiv
exact is_trunc_equiv_closed_rev _ base_eq_base_equiv _
end
definition eq_equiv_Z (x : S¹) : x = x ≃ ℤ :=
@ -326,8 +326,8 @@ namespace circle
proposition is_trunc_circle [instance] : is_trunc 1 S¹ :=
begin
apply is_trunc_succ_of_is_trunc_loop,
{ apply trunc_index.minus_one_le_succ},
{ intro x, apply is_trunc_equiv_closed_rev, apply eq_equiv_Z}
{ apply trunc_index.minus_one_le_succ },
{ intro x, exact is_trunc_equiv_closed_rev 0 !eq_equiv_Z _ }
end
proposition is_conn_circle [instance] : is_conn 0 S¹ :=

29
hott/homotopy/connectedness.hlean
View file

@ -24,16 +24,11 @@ namespace is_conn
: A ≃ B → is_conn n A → is_conn n B :=
begin
intros H C,
fapply @is_contr_equiv_closed (trunc n A) _,
apply trunc_equiv_trunc,
assumption
exact is_contr_equiv_closed (trunc_equiv_trunc n H) C,
end
theorem is_conn_of_le (A : Type) {n k : ℕ₋₂} (H : n ≤ k) [is_conn k A] : is_conn n A :=
begin
apply is_contr_equiv_closed,
apply trunc_trunc_equiv_left _ H
end
is_contr_equiv_closed (trunc_trunc_equiv_left _ H) _
theorem is_conn_fun_of_le {A B : Type} (f : A → B) {n k : ℕ₋₂} (H : n ≤ k)
[is_conn_fun k f] : is_conn_fun n f :=
@ -175,7 +170,7 @@ namespace is_conn
begin
intro a,
apply is_conn_equiv_closed n (equiv.symm (fiber_const_equiv A a₀ a)),
apply @is_contr_equiv_closed _ _ (tr_eq_tr_equiv n a₀ a),
apply is_contr_equiv_closed (tr_eq_tr_equiv n a₀ a) _,
end
end
@ -274,15 +269,11 @@ namespace is_conn
definition is_conn_trunc [instance] (A : Type) (n k : ℕ₋₂) [H : is_conn n A]
: is_conn n (trunc k A) :=
begin
apply is_trunc_equiv_closed, apply trunc_trunc_equiv_trunc_trunc
end
is_contr_equiv_closed !trunc_trunc_equiv_trunc_trunc _
definition is_conn_eq [instance] (n : ℕ₋₂) {A : Type} (a a' : A) [is_conn (n.+1) A] :
is_conn n (a = a') :=
begin
apply is_trunc_equiv_closed, apply tr_eq_tr_equiv,
end
is_contr_equiv_closed !tr_eq_tr_equiv _
definition is_conn_loop [instance] (n : ℕ₋₂) (A : Type*) [is_conn (n.+1) A] : is_conn n (Ω A) :=
!is_conn_eq
@ -346,8 +337,8 @@ namespace is_conn
definition is_conn_fun_lift_functor (n : ℕ₋₂) {A B : Type} (f : A → B) [is_conn_fun n f] :
is_conn_fun n (lift_functor f) :=
begin
intro b, cases b with b, apply is_trunc_equiv_closed_rev,
{ apply trunc_equiv_trunc, apply fiber_lift_functor}
intro b, cases b with b,
exact is_contr_equiv_closed_rev (trunc_equiv_trunc _ !fiber_lift_functor) _
end
open trunc_index
@ -378,7 +369,7 @@ namespace is_conn
apply @is_contr_of_inhabited_prop,
{ apply is_trunc_succ_intro,
refine trunc.rec _, intro a, refine trunc.rec _, intro a',
apply is_contr_equiv_closed !tr_eq_tr_equiv⁻¹ᵉ },
exact is_contr_equiv_closed !tr_eq_tr_equiv⁻¹ᵉ _ },
exact a
end
@ -460,7 +451,7 @@ namespace is_conn
definition is_contr_of_is_conn_of_is_trunc {n : ℕ₋₂} {A : Type} (H : is_trunc n A)
(K : is_conn n A) : is_contr A :=
is_contr_equiv_closed (trunc_equiv n A)
is_contr_equiv_closed (trunc_equiv n A) _
definition is_trunc_succ_succ_of_is_trunc_loop (n : ℕ₋₂) (A : Type*) (H : is_trunc (n.+1) (Ω A))
(H2 : is_conn 0 A) : is_trunc (n.+2) A :=
@ -477,7 +468,7 @@ namespace is_conn
rewrite [succ_add],
apply is_trunc_succ_succ_of_is_trunc_loop,
{ apply IH,
{ apply is_trunc_equiv_closed _ !loopn_succ_in },
{ exact is_trunc_equiv_closed _ !loopn_succ_in _ },
apply is_conn_loop },
exact is_conn_of_le _ (zero_le_of_nat m)
end

7
hott/homotopy/homotopy_group.hlean
View file

@ -31,10 +31,9 @@ namespace is_trunc
theorem trivial_homotopy_group_of_is_conn (A : Type*) {k n : ℕ} (H : k ≤ n) [is_conn n A]
: is_contr (π[k] A) :=
begin
have H3 : is_contr (ptrunc k A), from is_conn_of_le A (of_nat_le_of_nat H),
have H4 : is_contr (Ω[k](ptrunc k A)), from !is_trunc_loopn_of_is_trunc,
apply is_trunc_equiv_closed_rev,
{ apply equiv_of_pequiv (homotopy_group_pequiv_loop_ptrunc k A)}
have H3 : is_contr (ptrunc k A), from is_conn_of_le A (of_nat_le_of_nat H),
have H4 : is_contr (Ω[k](ptrunc k A)), from !is_trunc_loopn_of_is_trunc,
exact is_trunc_equiv_closed_rev _ (equiv_of_pequiv (homotopy_group_pequiv_loop_ptrunc k A)) _
end
-- Corollary 8.3.3

6
hott/homotopy/imaginaroid.hlean
View file

@ -70,7 +70,7 @@ section
{ reflexivity },
{ reflexivity },
{ apply eq_pathover, rewrite ap_id,
rewrite (ap_compose' (λy, -y)),
rewrite [-(ap_compose' (λy, -y))],
krewrite susp.elim_merid, rewrite ap_inv,
krewrite susp.elim_merid, rewrite neg_neg,
rewrite inv_inv, apply hrefl }
@ -85,7 +85,7 @@ section
{ reflexivity },
{ reflexivity },
{ apply eq_pathover, rewrite ap_id,
krewrite (ap_compose' (λy, y*)),
krewrite [-(ap_compose' (λy, y*))],
do 2 krewrite susp.elim_merid, rewrite neg_neg,
apply hrefl }
end
@ -96,7 +96,7 @@ section
{ reflexivity },
{ reflexivity },
{ apply eq_pathover,
krewrite [ap_compose' (λy, y*),ap_compose' (λy, -y) (λy, y*)],
krewrite [-ap_compose' (λy, y*),-ap_compose' (λy, -y) (λy, y*)],
do 3 krewrite susp.elim_merid, rewrite ap_inv, krewrite susp.elim_merid,
apply hrefl }
end

12
hott/homotopy/join.hlean
View file

@ -152,13 +152,13 @@ namespace join
{ apply ap inl, apply to_right_inv },
{ apply ap inr, apply to_right_inv },
{ apply eq_pathover, rewrite ap_id,
rewrite (ap_compose' (join.elim _ _ _)),
rewrite [-(ap_compose' (join.elim _ _ _))],
do 2 krewrite join.elim_glue, apply join.hsquare } },
{ intro x, induction x with a b a b,
{ apply ap inl, apply to_left_inv },
{ apply ap inr, apply to_left_inv },
{ apply eq_pathover, rewrite ap_id,
rewrite (ap_compose' (join.elim _ _ _)),
rewrite [-(ap_compose' (join.elim _ _ _))],
do 2 krewrite join.elim_glue, apply join.hsquare } }
end
@ -202,7 +202,7 @@ namespace join
{ reflexivity },
{ reflexivity },
{ esimp, apply eq_pathover, rewrite ap_id,
rewrite (ap_compose' (join.elim _ _ _)),
rewrite [-(ap_compose' (join.elim _ _ _))],
rewrite [susp.elim_merid,ap_con,ap_inv],
krewrite [join.elim_glue,join.elim_glue],
esimp, rewrite [inv_inv,idp_con],
@ -212,13 +212,13 @@ namespace join
{ apply glue },
{ induction b,
{ esimp, apply eq_pathover, rewrite ap_id,
rewrite (ap_compose' (susp.elim _ _ _)),
rewrite [-(ap_compose' (susp.elim _ _ _))],
krewrite join.elim_glue, rewrite ap_inv,
krewrite susp.elim_merid,
apply square_of_eq_top, apply inverse,
rewrite con.assoc, apply con.left_inv },
{ esimp, apply eq_pathover, rewrite ap_id,
rewrite (ap_compose' (susp.elim _ _ _)),
rewrite [-(ap_compose' (susp.elim _ _ _))],
krewrite join.elim_glue, esimp,
apply square_of_eq_top,
rewrite [idp_con,con.right_inv] } } }
@ -251,7 +251,7 @@ namespace join
induction x with a b a b, do 2 reflexivity,
apply eq_pathover, rewrite ap_id,
apply hdeg_square,
apply concat, apply ap_compose' (join.elim _ _ _),
apply concat, apply ap_compose (join.elim _ _ _),
krewrite [join.elim_glue, ap_inv, join.elim_glue], apply inv_inv,
end

4
hott/homotopy/quaternionic_hopf.hlean
View file

@ -62,9 +62,9 @@ namespace hopf
rewrite circle_star_eq, induction x,
{ reflexivity },
{ apply eq_pathover, rewrite ap_constant,
krewrite [ap_compose' (λz : S¹ × S¹, circle_mul z.1 z.2)
krewrite [-ap_compose' (λz : S¹ × S¹, circle_mul z.1 z.2)
(λa : S¹, (a, circle_star a))],
rewrite [ap_compose' (prod_functor (λa : S¹, a) circle_star)
rewrite [-ap_compose' (prod_functor (λa : S¹, a) circle_star)
(λa : S¹, (a, a))],
rewrite ap_diagonal,
krewrite [ap_prod_functor (λa : S¹, a) circle_star loop loop],

4
hott/homotopy/sphere2.hlean
View file

@ -43,7 +43,7 @@ namespace sphere
{ fapply equiv.mk,
{ exact cc_to_fn (LES_of_homotopy_groups complex_hopf) (n+3, 0)},
{ have H : is_trunc 1 (pfiber complex_hopf),
from @(is_trunc_equiv_closed_rev _ pfiber_complex_hopf) is_trunc_circle,
from is_trunc_equiv_closed_rev _ pfiber_complex_hopf is_trunc_circle,
refine LES_is_equiv_of_trivial complex_hopf (n+3) 0 _ _,
{ have H2 : 1 ≤[ℕ] n + 1, from !one_le_succ,
exact @trivial_ghomotopy_group_of_is_trunc _ _ _ H H2 },
@ -78,7 +78,7 @@ namespace sphere
begin
intro H,
note H2 := trivial_ghomotopy_group_of_is_trunc (S (n+1)) n n !le.refl,
have H3 : is_contr ℤ, from is_trunc_equiv_closed _ (equiv_of_isomorphism (πnSn (n+1))),
have H3 : is_contr ℤ, from is_trunc_equiv_closed _ (equiv_of_isomorphism (πnSn (n+1))) _,
have H4 : (0 : ℤ) ≠ (1 : ℤ), from dec_star,
apply H4,
apply is_prop.elim,

8
hott/homotopy/susp.hlean
View file

@ -180,14 +180,14 @@ namespace susp
abstract begin
intro sb, induction sb with b, do 2 reflexivity,
apply eq_pathover,
rewrite [ap_id,ap_compose' (susp_functor' f) (susp_functor' f⁻¹)],
rewrite [ap_id,-ap_compose' (susp_functor' f) (susp_functor' f⁻¹)],
krewrite [susp.elim_merid,susp.elim_merid], apply transpose,
apply susp.merid_square (right_inv f b)
end end
abstract begin
intro sa, induction sa with a, do 2 reflexivity,
apply eq_pathover,
rewrite [ap_id,ap_compose' (susp_functor' f⁻¹) (susp_functor' f)],
rewrite [ap_id,-ap_compose' (susp_functor' f⁻¹) (susp_functor' f)],
krewrite [susp.elim_merid,susp.elim_merid], apply transpose,
apply susp.merid_square (left_inv f a)
end end
@ -302,7 +302,7 @@ namespace susp
{ reflexivity },
{ reflexivity },
{ esimp, apply eq_pathover, apply hdeg_square,
xrewrite [ap_compose' f, ap_compose' (susp.elim (f x) (f x) (λ (a : f x = f x), a)),▸*],
xrewrite [-ap_compose' f, -ap_compose' (susp.elim (f x) (f x) (λ (a : f x = f x), a)),▸*],
xrewrite [+elim_merid, ap1_gen_idp_left] }},
{ reflexivity }
end
@ -330,7 +330,7 @@ namespace susp
{ reflexivity },
{ exact merid pt },
{ apply eq_pathover,
xrewrite [▸*, ap_id, ap_compose' (susp.elim north north (λa, a)), +elim_merid,▸*],
xrewrite [▸*, ap_id, -ap_compose' (susp.elim north north (λa, a)), +elim_merid,▸*],
apply square_of_eq, exact !idp_con ⬝ !inv_con_cancel_right⁻¹ }},
{ reflexivity }
end

4
hott/homotopy/vankampen.hlean
View file

@ -172,9 +172,9 @@ namespace pushout
{ rewrite [decode_list_pair, decode_list_nil], exact ap tr !con.left_inv},
{ apply decode_list_singleton},
{ apply decode_list_singleton},
{ rewrite [+decode_list_pair], induction h with p, apply ap tr, rewrite [-+ap_compose'],
{ rewrite [+decode_list_pair], induction h with p, apply ap tr, rewrite [+ap_compose'],
exact !ap_con_eq_con_ap⁻¹},
{ rewrite [+decode_list_pair], induction h with p, apply ap tr, rewrite [-+ap_compose'],
{ rewrite [+decode_list_pair], induction h with p, apply ap tr, rewrite [+ap_compose'],
apply ap_con_eq_con_ap}
end

2
hott/init/funext.hlean
View file

@ -243,7 +243,7 @@ namespace eq
equiv.mk apd10 _
definition eq_of_homotopy [reducible] : f ~ g → f = g :=
(@apd10 A P f g)⁻¹
(@apd10 A P f g)⁻¹ᶠ
definition apd10_eq_of_homotopy_fn (p : f ~ g) : apd10 (eq_of_homotopy p) = p :=
right_inv apd10 p

27
hott/init/path.hlean
View file

@ -14,7 +14,7 @@ open function eq
/- Path equality -/
namespace eq
variables {A B C : Type} {P : A → Type} {a a' x y z t : A} {b b' : B}
variables {A A' B B' C : Type} {P : A → Type} {a a' a'' x y z t : A} {b b' b'' : B}
--notation a = b := eq a b
notation x = y `:>`:50 A:49 := @eq A x y
@ -364,7 +364,7 @@ namespace eq
-- Sometimes we don't have the actual function [compose].
definition ap_compose' [unfold 8] (g : B → C) (f : A → B) {x y : A} (p : x = y) :
ap (λa, g (f a)) p = ap g (ap f p) :=
ap g (ap f p) = ap (λa, g (f a)) p :=
by induction p; reflexivity
-- The action of constant maps.
@ -403,7 +403,6 @@ namespace eq
(r ⬝ ap f q) ⬝ p y = (r ⬝ p x) ⬝ ap g q :=
by induction q; reflexivity
-- TODO: try this using the simplifier, and compare proofs
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) :=
@ -560,6 +559,28 @@ namespace eq
(p : a = a') (q : b = b') (z : P a b) : P a' b' :=
transport (P a') q (p ▸ z)
definition transport11_con (P : A → B → Type) (p : a = a') (p' : a' = a'') (q : b = b')
(q' : b' = b'') (z : P a b) :
transport11 P (p ⬝ p') (q ⬝ q') z = transport11 P p' q' (transport11 P p q z) :=
begin induction p', induction q', reflexivity end
definition transport11_compose (P : A' → B' → Type) (f : A → A') (g : B → B')
(p : a = a') (q : b = b') (z : P (f a) (g b)) :
transport11 (λa b, P (f a) (g b)) p q z = transport11 P (ap f p) (ap g q) z :=
by induction p; induction q; reflexivity
definition transport11_ap (P : A' → B' → Type) (f : A → A') (g : B → B')
(p : a = a') (q : b = b') (z : P (f a) (g b)) :
transport11 P (ap f p) (ap g q) z =
transport11 (λ(a : A) (b : B), P (f a) (g b)) p q z :=
(transport11_compose P f g p q z)⁻¹
definition fn_transport11_eq_transport11_fn (P : A → B → Type)
(Q : A → B → Type) (p : a = a') (q : b = b')
(f : Πa b, P a b → Q a b) (z : P a b) :
f a' b' (transport11 P p q z) = transport11 Q p q (f a b z) :=
by induction p; induction q; reflexivity
-- Transporting along higher-dimensional paths
definition transport2 [unfold 7] (P : A → Type) {x y : A} {p q : x = y} (r : p = q) (z : P x) :
p ▸ z = q ▸ z :=

1
hott/init/pathover.hlean
View file

@ -21,6 +21,7 @@ namespace eq
idpatho : pathover B b (refl a) b
notation b ` =[`:50 p:0 `] `:0 b₂:50 := pathover _ b p b₂
notation b ` =[`:50 p:0 `; `:0 B `] `:0 b₂:50 := pathover B b p b₂
definition idpo [reducible] [constructor] : b =[refl a] b :=
pathover.idpatho b

15
hott/init/trunc.hlean
View file

@ -271,9 +271,12 @@ namespace is_trunc
: (is_contr B) :=
is_contr.mk (f (center A)) (λp, eq_of_eq_inv !center_eq)
definition is_contr_equiv_closed (H : A ≃ B) [HA: is_contr A] : is_contr B :=
definition is_contr_equiv_closed (H : A ≃ B) (HA : is_contr A) : is_contr B :=
is_contr_is_equiv_closed (to_fun H)
definition is_contr_equiv_closed_rev (H : A ≃ B) (HB : is_contr B) : is_contr A :=
is_contr_equiv_closed H⁻¹ᵉ HB
definition equiv_of_is_contr_of_is_contr [HA : is_contr A] [HB : is_contr B] : A ≃ B :=
equiv.mk
(λa, center B)
@ -292,12 +295,10 @@ namespace is_trunc
[HA : is_trunc n B] : is_trunc n A :=
is_trunc_is_equiv_closed n f⁻¹
definition is_trunc_equiv_closed (n : ℕ₋₂) (f : A ≃ B) [HA : is_trunc n A]
: is_trunc n B :=
definition is_trunc_equiv_closed (n : ℕ₋₂) (f : A ≃ B) (HA : is_trunc n A) : is_trunc n B :=
is_trunc_is_equiv_closed n (to_fun f)
definition is_trunc_equiv_closed_rev (n : ℕ₋₂) (f : A ≃ B) [HA : is_trunc n B]
: is_trunc n A :=
definition is_trunc_equiv_closed_rev (n : ℕ₋₂) (f : A ≃ B) (HA : is_trunc n B) : is_trunc n A :=
is_trunc_is_equiv_closed n (to_inv f)
definition is_equiv_of_is_prop [constructor] [HA : is_prop A] [HB : is_prop B]
@ -318,7 +319,7 @@ namespace is_trunc
/- truncatedness of lift -/
definition is_trunc_lift [instance] [priority 1450] (A : Type) (n : ℕ₋₂)
[H : is_trunc n A] : is_trunc n (lift A) :=
is_trunc_equiv_closed _ !equiv_lift
is_trunc_equiv_closed _ !equiv_lift _
end
@ -341,7 +342,7 @@ namespace is_trunc
definition is_trunc_pathover [instance]
(n : ℕ₋₂) [H : is_trunc (n.+1) (C a)] : is_trunc n (c =[p] c₂) :=
is_trunc_equiv_closed_rev n !pathover_equiv_eq_tr
is_trunc_equiv_closed_rev n !pathover_equiv_eq_tr _
definition is_prop.elimo [H : is_prop (C a)] : c =[p] c₂ :=
pathover_of_eq_tr !is_prop.elim

5
hott/types/W.hlean
View file

@ -124,8 +124,9 @@ namespace Wtype
fapply is_trunc_equiv_closed,
{ apply equiv_path_W},
{ apply is_trunc_sigma,
intro p, cases p, esimp, apply is_trunc_equiv_closed_rev,
apply pathover_idp}
intro p, cases p,
apply is_trunc_equiv_closed_rev n !pathover_idp,
apply is_trunc_pi_eq, intro b, apply IH }
end
end Wtype

14
hott/types/equiv.hlean
View file

@ -42,11 +42,11 @@ namespace is_equiv
definition is_contr_right_coherence (u : Σ(g : B → A), f ∘ g ~ id)
: is_contr (Σ(η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a)) :=
begin
fapply is_trunc_equiv_closed,
{apply equiv.symm, apply sigma_pi_equiv_pi_sigma},
fapply is_trunc_equiv_closed,
{apply pi_equiv_pi_right, intro a,
apply (fiber_eq_equiv (fiber.mk (u.1 (f a)) (u.2 (f a))) (fiber.mk a idp))},
apply is_contr_equiv_closed_rev !sigma_pi_equiv_pi_sigma,
apply is_contr_equiv_closed,
{ apply pi_equiv_pi_right, intro a,
apply (fiber_eq_equiv (fiber.mk (u.1 (f a)) (u.2 (f a))) (fiber.mk a idp)) },
exact _
end
omit H
@ -77,7 +77,7 @@ namespace is_equiv
theorem is_prop_is_equiv [instance] : is_prop (is_equiv f) :=
is_prop_of_imp_is_contr
(λ(H : is_equiv f), is_trunc_equiv_closed -2 (equiv.symm !is_equiv.sigma_char'))
(λ(H : is_equiv f), is_contr_equiv_closed (equiv.symm !is_equiv.sigma_char') _)
definition inv_eq_inv {A B : Type} {f f' : A → B} {Hf : is_equiv f} {Hf' : is_equiv f'}
(p : f = f') : f⁻¹ = f'⁻¹ :=
@ -209,7 +209,7 @@ namespace is_equiv
begin
intro a,
apply is_equiv_of_is_contr_fun, intro q,
apply @is_contr_equiv_closed _ _ (fiber_total_equiv f q)
exact is_contr_equiv_closed (fiber_total_equiv f q) _
end
end is_equiv

4
hott/types/fiber.hlean
View file

@ -170,7 +170,7 @@ namespace fiber
fapply pequiv_of_equiv, esimp,
refine transport_fiber_equiv (g ∘* f) (respect_pt g)⁻¹ ⬝e fiber.equiv_postcompose f g (Point B),
esimp, apply (ap (fiber.mk (Point A))), refine !con.assoc ⬝ _, apply inv_con_eq_of_eq_con,
rewrite [▸*, con.assoc, con.right_inv, con_idp, -ap_compose'],
rewrite [▸*, con.assoc, con.right_inv, con_idp, ap_compose'],
exact ap_con_eq_con (λ x, ap g⁻¹ᵉ* (ap g (pleft_inv' g x)⁻¹) ⬝ ap g⁻¹ᵉ* (pright_inv g (g x)) ⬝
pleft_inv' g x) (respect_pt f)
end
@ -291,7 +291,7 @@ namespace fiber
-- this breaks certain proofs if it is an instance
definition is_trunc_fiber (n : ℕ₋₂) {A B : Type} (f : A → B) (b : B)
[is_trunc n A] [is_trunc (n.+1) B] : is_trunc n (fiber f b) :=
is_trunc_equiv_closed_rev n !fiber.sigma_char
is_trunc_equiv_closed_rev n !fiber.sigma_char _
definition is_trunc_pfiber (n : ℕ₋₂) {A B : Type*} (f : A →* B)
[is_trunc n A] [is_trunc (n.+1) B] : is_trunc n (pfiber f) :=

4
hott/types/fin.hlean
View file

@ -30,8 +30,8 @@ end
definition is_set_fin [instance] : is_set (fin n) :=
begin
assert H : Πa, is_set (a < n), exact _, -- I don't know why this is necessary
apply is_trunc_equiv_closed_rev, apply fin.sigma_char,
assert H : Πa, is_set (a < n), exact _,
apply is_trunc_equiv_closed_rev 0 !fin.sigma_char _,
end
definition eq_of_veq : Π {i j : fin n}, (val i) = j → i = j :=

32
hott/types/pi.hlean
View file

@ -269,28 +269,22 @@ namespace pi
[H : ∀a, is_trunc n (B a)] : is_trunc n (Πa, B a) :=
begin
revert B H,
eapply (trunc_index.rec_on n),
{intro B H,
fapply is_contr.mk,
intro a, apply center,
intro f, apply eq_of_homotopy,
intro x, apply (center_eq (f x))},
{intro n IH B H,
fapply is_trunc_succ_intro, intro 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
is_trunc_eq n (f a) (g a)}
induction n with n IH,
{ intros B H, apply is_contr.mk (λa, !center),
intro f, apply eq_of_homotopy,
intro x, apply (center_eq (f x)) },
{ intros B H, fapply is_trunc_succ_intro, intro 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
is_trunc_eq n (f a) (g a) }
end
local attribute is_trunc_pi [instance]
theorem is_trunc_pi_eq [instance] [priority 500] (n : trunc_index) (f g : Πa, B a)
theorem is_trunc_pi_eq (n : trunc_index) (f g : Πa, B a)
[H : ∀a, is_trunc n (f a = g a)] : is_trunc n (f = g) :=
begin
apply is_trunc_equiv_closed_rev,
apply eq_equiv_homotopy
end
is_trunc_equiv_closed_rev n !eq_equiv_homotopy _
theorem is_trunc_not [instance] (n : trunc_index) (A : Type) : is_trunc (n.+1) ¬A :=
by unfold not;exact _

4
hott/types/pointed.hlean
View file

@ -134,7 +134,7 @@ namespace pointed
definition passoc [constructor] (h : C →* D) (g : B →* C) (f : A →* B) : (h ∘* g) ∘* f ~* h ∘* (g ∘* f) :=
phomotopy.mk (λa, idp)
abstract !idp_con ⬝ whisker_right _ (!ap_con ⬝ whisker_right _ !ap_compose'⁻¹) ⬝ !con.assoc end
abstract !idp_con ⬝ whisker_right _ (!ap_con ⬝ whisker_right _ !ap_compose') ⬝ !con.assoc end
definition pid_pcompose [constructor] (f : A →* B) : pid B ∘* f ~* f :=
begin
@ -368,7 +368,7 @@ namespace pointed
definition is_trunc_ppi [instance] (n : ℕ₋₂) {A : Type*} (B : A → Type) (b₀ : B pt) [Πa, is_trunc n (B a)] :
is_trunc n (ppi B b₀) :=
is_trunc_equiv_closed_rev _ !ppi.sigma_char
is_trunc_equiv_closed_rev _ !ppi.sigma_char _
definition is_trunc_pmap [instance] (n : ℕ₋₂) (A B : Type*) [is_trunc n B] :
is_trunc n (A →* B) :=

6
hott/types/sigma.hlean
View file

@ -526,11 +526,9 @@ namespace sigma
begin
revert A B HA HB,
induction n with n IH,
{ intro A B HA HB, fapply is_trunc_equiv_closed_rev, apply sigma_equiv_of_is_contr_left},
{ intro A B HA HB, exact is_contr_equiv_closed_rev !sigma_equiv_of_is_contr_left _ },
{ intro A B HA HB, apply is_trunc_succ_intro, intro u v,
apply is_trunc_equiv_closed_rev,
apply sigma_eq_equiv,
exact IH _ _ _ _}
exact is_trunc_equiv_closed_rev n !sigma_eq_equiv (IH _ _ _ _) }
end
theorem is_trunc_subtype (B : A → Prop) (n : trunc_index)

27
hott/types/trunc.hlean
View file

@ -270,7 +270,7 @@ namespace trunc_index
equiv.MK add_two sub_two add_two_sub_two sub_two_add_two
definition is_set_trunc_index [instance] : is_set ℕ₋₂ :=
is_trunc_equiv_closed_rev 0 trunc_index_equiv_nat
is_trunc_equiv_closed_rev 0 trunc_index_equiv_nat _
end trunc_index open trunc_index
@ -333,8 +333,8 @@ namespace is_trunc
theorem is_trunc_trunctype [instance] (n : ℕ₋₂) : is_trunc n.+1 (n-Type) :=
begin
apply is_trunc_succ_intro, intro X Y,
fapply is_trunc_equiv_closed_rev, { apply trunctype_eq_equiv},
fapply is_trunc_equiv_closed_rev, { apply eq_equiv_equiv},
apply is_trunc_equiv_closed_rev _ !trunctype_eq_equiv,
apply is_trunc_equiv_closed_rev _ !eq_equiv_equiv,
induction n,
{ apply @is_contr_of_inhabited_prop,
{ apply is_trunc_equiv },
@ -649,16 +649,14 @@ namespace trunc
(n m : ℕ₋₂) [H : is_trunc n A] : is_trunc n (trunc m A) :=
begin
revert A m H, eapply (trunc_index.rec_on n),
{ clear n, intro A m H, apply is_contr_equiv_closed,
{ apply equiv.symm, apply trunc_equiv, apply (@is_trunc_of_le _ -2), apply minus_two_le} },
{ clear n, intro A m H, refine is_contr_equiv_closed_rev _ H,
{ apply trunc_equiv, apply (@is_trunc_of_le _ -2), apply minus_two_le} },
{ clear n, intro n IH A m H, induction m with m,
{ apply (@is_trunc_of_le _ -2), apply minus_two_le},
{ apply is_trunc_succ_intro, intro aa aa',
apply (@trunc.rec_on _ _ _ aa (λy, !is_trunc_succ_of_is_prop)),
eapply (@trunc.rec_on _ _ _ aa' (λy, !is_trunc_succ_of_is_prop)),
intro a a', apply (is_trunc_equiv_closed_rev),
{ apply tr_eq_tr_equiv},
{ exact (IH _ _ _)}}}
intro a a', apply is_trunc_equiv_closed_rev _ !tr_eq_tr_equiv (IH _ _ _) }}
end
/- equivalences between truncated types (see also hit.trunc) -/
@ -696,10 +694,7 @@ namespace trunc
theorem is_trunc_trunc_of_le (A : Type)
(n : ℕ₋₂) {m k : ℕ₋₂} (H : m ≤ k) [is_trunc n (trunc k A)] : is_trunc n (trunc m A) :=
begin
apply is_trunc_equiv_closed,
{ apply trunc_trunc_equiv_left, exact H},
end
is_trunc_equiv_closed _ (trunc_trunc_equiv_left _ H) _
definition trunc_functor_homotopy [unfold 7] {X Y : Type} (n : ℕ₋₂) {f g : X → Y}
(p : f ~ g) (x : trunc n X) : trunc_functor n f x = trunc_functor n g x :=
@ -855,8 +850,8 @@ namespace trunc
begin
fapply phomotopy.mk,
{ apply trunc_functor_compose},
{ esimp, refine !idp_con ⬝ _, refine whisker_right _ !ap_compose'⁻¹ᵖ ⬝ _,
esimp, refine whisker_right _ (ap_compose' tr g _) ⬝ _, exact !ap_con⁻¹},
{ esimp, refine !idp_con ⬝ _, refine whisker_right _ !ap_compose' ⬝ _,
esimp, refine whisker_right _ (ap_compose tr g _) ⬝ _, exact !ap_con⁻¹},
end
definition ptrunc_functor_pid [constructor] (X : Type*) (n : ℕ₋₂) :
@ -872,7 +867,7 @@ namespace trunc
begin
fapply phomotopy.mk,
{ intro x, esimp, refine !trunc_functor_cast ⬝ _, refine ap010 cast _ x,
refine !ap_compose'⁻¹ ⬝ !ap_compose'},
refine !ap_compose' ⬝ !ap_compose },
{ induction p, reflexivity},
end
@ -950,7 +945,7 @@ namespace trunc
begin
fapply phomotopy.mk,
{ intro a, induction a with a, reflexivity },
{ refine !idp_con ⬝ _ ⬝ !idp_con⁻¹, refine !ap_compose'⁻¹ ⬝ _, apply ap_id }
{ refine !idp_con ⬝ _ ⬝ !idp_con⁻¹, refine !ap_compose' ⬝ _, apply ap_id }
end
definition ptr_natural [constructor] (n : ℕ₋₂) {A B : Type*} (f : A →* B) :