52dd6cf90b
This commit adds truncated 2-quotients, groupoid quotients, Eilenberg MacLane spaces, chain complexes, the long exact sequence of homotopy groups, the Freudenthal Suspension Theorem, Whitehead's principle, and the computation of homotopy groups of almost all spheres which are known in HoTT.
85 lines
2.9 KiB
Text
85 lines
2.9 KiB
Text
/-
|
||
Copyright (c) 2016 Jakob von Raumer. All rights reserved.
|
||
Released under Apache 2.0 license as described in the file LICENSE.
|
||
Authors: Jakob von Raumer, Ulrik Buchholtz
|
||
|
||
The Wedge Sum of Two pType Types
|
||
-/
|
||
import hit.pointed_pushout .connectedness types.unit
|
||
|
||
open eq pushout pointed unit trunc_index
|
||
|
||
definition pwedge (A B : Type*) : Type* := ppushout (pconst punit A) (pconst punit B)
|
||
|
||
namespace wedge
|
||
|
||
-- TODO maybe find a cleaner proof
|
||
protected definition unit (A : Type*) : A ≃* pwedge punit A :=
|
||
begin
|
||
fapply pequiv_of_pmap,
|
||
{ fapply pmap.mk, intro a, apply pinr a, apply respect_pt },
|
||
{ fapply is_equiv.adjointify, intro x, fapply pushout.elim_on x,
|
||
exact λ x, Point A, exact id, intro u, reflexivity,
|
||
intro x, fapply pushout.rec_on x, intro u, cases u, esimp, apply (glue unit.star)⁻¹,
|
||
intro a, reflexivity,
|
||
intro u, cases u, esimp, apply eq_pathover,
|
||
refine _ ⬝hp !ap_id⁻¹, fapply eq_hconcat, apply ap_compose inr,
|
||
krewrite elim_glue, fapply eq_hconcat, apply ap_idp, apply square_of_eq,
|
||
apply con.left_inv,
|
||
intro a, reflexivity},
|
||
end
|
||
end wedge
|
||
|
||
open trunc is_trunc is_conn function
|
||
|
||
namespace wedge_extension
|
||
section
|
||
-- The wedge connectivity lemma (Lemma 8.6.2)
|
||
parameters {A B : Type*} (n m : ℕ)
|
||
[cA : is_conn n A] [cB : is_conn m B]
|
||
(P : A → B → Type) [HP : Πa b, is_trunc (m + n) (P a b)]
|
||
(f : Πa : A, P a pt)
|
||
(g : Πb : B, P pt b)
|
||
(p : f pt = g pt)
|
||
|
||
include cA cB HP
|
||
private definition Q (a : A) : Type :=
|
||
fiber (λs : (Πb : B, P a b), s (Point B)) (f a)
|
||
|
||
private definition is_trunc_Q (a : A) : is_trunc (n.-1) (Q a) :=
|
||
begin
|
||
refine @is_conn.elim_general (m.-1) _ _ _ (P a) _ (f a),
|
||
rewrite [-succ_add_succ, of_nat_add_of_nat], intro b, apply HP
|
||
end
|
||
|
||
local attribute is_trunc_Q [instance]
|
||
private definition Q_sec : Πa : A, Q a :=
|
||
is_conn.elim (n.-1) Q (fiber.mk g p⁻¹)
|
||
|
||
protected definition ext : Π(a : A)(b : B), P a b :=
|
||
λa, fiber.point (Q_sec a)
|
||
|
||
protected definition β_left (a : A) : ext a (Point B) = f a :=
|
||
fiber.point_eq (Q_sec a)
|
||
|
||
private definition coh_aux : Σq : ext (Point A) = g,
|
||
β_left (Point A) = ap (λs : (Πb : B, P (Point A) b), s (Point B)) q ⬝ p⁻¹ :=
|
||
equiv.to_fun (fiber.fiber_eq_equiv (Q_sec (Point A)) (fiber.mk g p⁻¹))
|
||
(is_conn.elim_β (n.-1) Q (fiber.mk g p⁻¹))
|
||
|
||
protected definition β_right (b : B) : ext (Point A) b = g b :=
|
||
apd10 (sigma.pr1 coh_aux) b
|
||
|
||
private definition lem : β_left (Point A) = β_right (Point B) ⬝ p⁻¹ :=
|
||
begin
|
||
unfold β_right, unfold β_left,
|
||
krewrite (apd10_eq_ap_eval (sigma.pr1 coh_aux) (Point B)),
|
||
exact sigma.pr2 coh_aux,
|
||
end
|
||
|
||
protected definition coh
|
||
: (β_left (Point A))⁻¹ ⬝ β_right (Point B) = p :=
|
||
by rewrite [lem,con_inv,inv_inv,con.assoc,con.left_inv]
|
||
|
||
end
|
||
end wedge_extension
|