basics on homotopy cofibers

theories/Colimits/SpanPushout.v

@@ -1,5 +1,5 @@
 Require Import HoTT.Basics HoTT.Colimits.Pushout.
-Require Import Types.Paths.
+Require Import Types.Paths Types.Sigma Types.Prod HFiber Limits.Pullback.
 
 (** * Pushouts of "dependent spans". *)
 
@@ -121,3 +121,19 @@ Proof.
     2: apply spushout_rec_beta_spglue.
     apply H.
 Defined.
+
+(** Any pushout is equivalent to a span pushout. *)
+Definition equiv_pushout_spushout {X Y Z : Type} (f : X -> Y) (g : X -> Z)
+  : Pushout f g
+    <~> SPushout (fun (y : Y) (z : Z) => {x : X & f x = y /\ g x = z}).
+Proof.
+  snrapply equiv_pushout.
+  { nrefine (equiv_sigma_prod _ oE _).
+    apply equiv_double_fibration_replacement. }
+  1-4: reflexivity.
+Defined.
+
+(** There is a natural map from the total space of [Q] to the pushout product of [Q]. *)
+Definition spushout_sjoin_map {X Y : Type} (Q : X -> Y -> Type)
+  : {x : X & {y : Y & Q x y}} -> Pullback (spushl Q) (spushr Q)
+  := functor_sigma idmap (fun _ => functor_sigma idmap (fun _ => spglue Q)).

theories/HFiber.v

@@ -142,29 +142,21 @@ Defined.
 Definition equiv_fibration_replacement  {B C} (f:C ->B)
   : C <~> {y:B & hfiber f y}.
 Proof.
-  snrefine (Build_Equiv _ _ _ (
-    Build_IsEquiv C {y:B & {x:C & f x = y}}
-      (fun c => (f c; (c; idpath)))
-      (fun c => c.2.1)
-      _
-      (fun c => idpath)
-       _)).
-  - intros [? [? []]]; reflexivity.
-  - reflexivity.
+  make_equiv_contr_basedpaths.
+Defined.
+
+(** This is a useful variant for taking a "double fiber" of two maps. *)
+Definition equiv_double_fibration_replacement
+  {X Y Z : Type} (f : X -> Y) (g : X -> Z)
+  : X <~> {y : Y & {z : Z & {x : X & f x = y /\ g x = z}}}.
+Proof.
+  make_equiv_contr_basedpaths.
 Defined.
 
 Definition hfiber_fibration {X} (x : X) (P:X->Type)
   : P x <~> @hfiber (sig P) X pr1 x.
 Proof.
-  snrefine (Build_Equiv _ _ _
-    (Build_IsEquiv (P x) { z : sig P & z.1 = x }
-      (fun Px => ((x; Px); idpath))
-      (fun Px => transport P Px.2 Px.1.2)
-      _
-      (fun Px => idpath)
-      _)).
-  - intros [[] []]; reflexivity.
-  - reflexivity.
+  make_equiv_contr_basedpaths.
 Defined.
 
 (** ** Exercise 4.4: The unstable octahedral axiom. *)

theories/HoTT.v

@@ -151,7 +151,6 @@ Require Export HoTT.Homotopy.HomotopyGroup.
 Require Export HoTT.Homotopy.PinSn.
 Require Export HoTT.Homotopy.WhiteheadsPrinciple.
 Require Export HoTT.Homotopy.BlakersMassey.
-Require Export HoTT.Homotopy.Freudenthal.
 Require Export HoTT.Homotopy.Suspension.
 Require Export HoTT.Homotopy.Smash.
 Require Export HoTT.Homotopy.Wedge.

theories/Homotopy/BlakersMassey.v

@@ -1,6 +1,8 @@
-Require Import HoTT.Basics HoTT.Types.
+Require Import HoTT.Basics HoTT.Types HFiber.
 Require Import Colimits.Pushout.
 Require Import Colimits.SpanPushout.
+Require Import Homotopy.Suspension.
+Require Import Limits.Pullback.
 Require Import Homotopy.Join.Core.
 Require Import Truncations.
 
@@ -527,10 +529,10 @@ End GBM.
 (** ** The classical Blakers-Massey Theorem *)
 
 Global Instance blakers_massey `{Univalence} (m n : trunc_index)
-           {X Y : Type} (Q : X -> Y -> Type)
-           `{forall y, IsConnected m.+1 { x : X & Q x y } }
-           `{forall x, IsConnected n.+1 { y : Y & Q x y } }
-           (x : X) (y : Y)
+  {X Y : Type} (Q : X -> Y -> Type)
+  `{forall y, IsConnected m.+1 { x : X & Q x y } }
+  `{forall x, IsConnected n.+1 { y : Y & Q x y } }
+  (x : X) (y : Y)
   : IsConnMap (m +2+ n) (@spglue X Y Q x y).
 Proof.
   intros r.
@@ -539,3 +541,54 @@ Proof.
   1: intros; apply isconnected_join.
   all: exact _.
 Defined.
+
+(** A sigma functor is connected if its fibers are, so we have the following. *)
+Definition blakers_massey_total_map `{Univalence} (m n : trunc_index)
+  {X Y : Type} (Q : X -> Y -> Type)
+  `{forall y, IsConnected m.+1 { x : X & Q x y } }
+  `{forall x, IsConnected n.+1 { y : Y & Q x y } }
+  : IsConnMap (Tr (m +2+ n)) (spushout_sjoin_map Q)
+  := _.
+
+Definition blakers_massey_po `{Univalence} (m n : trunc_index)
+  {X Y Z : Type} (f : X -> Y) (g : X -> Z)
+  `{H1 : !IsConnMap n.+1 f} `{H2 : !IsConnMap m.+1 g}
+  : IsConnMap (m +2+ n) (pullback_corec (pglue (f:=f) (g:=g))).
+Proof.
+  (** We postcompose our map with an equivalence from the the pullback of the pushout of [f] and [g] to the pullback of an equivalent [SPushout] over a family [Q]. *)
+  pose (Q := fun y z => {x : X & f x = y /\ g x = z}).
+  snrapply cancelL_equiv_conn_map.
+  1: exact (Pullback (spushl Q) (spushr Q)).
+  1: by snrapply (equiv_pullback (equiv_pushout_spushout _ _)).
+  (** Next we precompose with the equivalence from the total space of [Q] to [X]. *)
+  rapply (cancelR_conn_map _ (equiv_double_fibration_replacement f g)^-1%equiv).
+  (** Next we prove that this composition is homotopic to [spushout_sjoin_map Q]. *)
+  snrapply (conn_map_homotopic _ (spushout_sjoin_map Q)).
+  { intros [y [z [x [[] []]]]].
+    snrapply (path_sigma' _ 1 (path_sigma' _ 1 _)); simpl; symmetry.
+    lhs nrapply concat_1p.
+    lhs nrapply concat_p1.
+    lhs nrapply functor_coeq_beta_cglue.
+    lhs nrapply concat_p1.
+    nrapply concat_1p. }
+  rapply blakers_massey_total_map.
+  (** What's left is to check that the partial total spaces of [Q] are connected, which we get since [f] and [g] are connected maps. We just have to strip off the irrelevant parts of [Q] to get the hfiber in each case. *)
+  - intros z.
+    nrefine (isconnected_equiv' _ _ _ (H2 z)).
+    make_equiv_contr_basedpaths.
+  - intros y.
+    nrefine (isconnected_equiv' _ _ _ (H1 y)).
+    make_equiv_contr_basedpaths.
+Defined.
+
+(** ** The Freudenthal Suspension Theorem *)
+
+(** The Freudenthal suspension theorem is a fairly trivial corollary of the Blakers-Massey theorem.  It says that [merid : X -> North = South] is highly connected. *)
+Global Instance freudenthal `{Univalence} (n : trunc_index)
+           (X : Type@{u}) `{IsConnected n.+1 X}
+  : IsConnMap (n +2+ n) (@merid X).
+Proof.
+  (* If we post-compose [merid : X -> North = South] with an equivalence [North = South <~> P], where [P] is the pullback of the inclusions [Unit -> Susp X] hitting [North] and [South], we get the canonical comparison map [X -> P] whose connectivity follows from the Blakers-Massey theorem. *)
+  rapply (cancelL_equiv_conn_map _ _ (equiv_pullback_unit_unit_paths _ _)^-1%equiv).
+  rapply blakers_massey_po.
+Defined.

theories/Homotopy/Cofiber.v

@@ -0,0 +1,150 @@
+Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Trunc Basics.Equivalences.
+Require Import Types.Unit Types.Paths Types.Universe Types.Sigma.
+Require Import Truncations.Core Truncations.Connectedness.
+Require Import Colimits.Pushout Homotopy.Suspension.
+Require Import Homotopy.NullHomotopy.
+Require Import HFiber Limits.Pullback BlakersMassey.
+
+Set Universe Minimization ToSet.
+
+(** * Homotopy Cofibers *)
+
+(** ** Definition *)
+
+(** Homotopy cofibers or mapping cones are spaces constructed from a map [f : X -> Y] by contracting the image of [f] inside [Y] to a point. They can be thought of as a kind of coimage or quotient. *)
+
+Definition Cofiber {X Y : Type} (f : X -> Y)
+  := Pushout f (const_tt X).
+
+(** *** Constructors *)
+
+(** Any element of [Y] can be included in the cofiber. *)
+Definition cofib {X Y : Type} (f : X -> Y) : Y -> Cofiber f
+  := pushl.
+
+(** We have a distinguised point in the cofiber, where the image of [f] is contracted to. *)
+Definition cf_apex {X Y : Type} (f : X -> Y) : Cofiber f
+  := pushr tt.
+
+(** Given an element [x : X], we have the path [cfglue f x] from the [f x] to the [cf_apex]. *)
+Definition cfglue {X Y : Type} (f : X -> Y) (x : X) : cofib f (f x) = cf_apex f
+  := pglue _.
+
+(** *** Induction and recursion principles *)
+
+(** The recursion principle for the cofiber of [f : X -> Y] requires a function [g : Y -> Z] such that [g o f] is null homotopic, i.e. constant. *)
+Definition cofiber_rec {X Y Z : Type} (f : X -> Y) (g : Y -> Z)
+  (null : NullHomotopy (g o f))
+  : Cofiber f -> Z.
+Proof.
+  snrapply Pushout_rec.
+  - exact g.
+  - intros; exact null.1.
+  - intros a.
+    exact (null.2 a).
+Defined.
+
+(** The induction principle is similar, although requries a dependent form of null homotopy. *)
+Definition cofiber_ind {X Y : Type} (f : X -> Y) (P : Cofiber f -> Type)
+  (g : forall y, P (cofib f y))
+  (null : exists b, forall x, transport P (cfglue f x) (g (f x)) = b)
+  : forall x, P x.
+Proof.
+  snrapply Pushout_ind.
+  - intros y; apply g.
+  - intros []; exact null.1.
+  - exact null.2.
+Defined.
+
+(** ** Functoriality *)
+
+Local Close Scope trunc_scope.
+
+(** The homotopy cofiber can be thought of as a functor from the category of arrows in [Type] to [Type]. *)
+
+(** 1-functorial action. *)
+Definition functor_cofiber {X Y X' Y' : Type} {f : X -> Y} {f' : X' -> Y'}
+  (g : X -> X') (h : Y -> Y') (p : h o f == f' o g)
+  : Cofiber f -> Cofiber f'
+  := functor_pushout g h idmap p (fun _ => idpath).
+
+(** 2-functorial action. *)
+Definition functor_cofiber_homotopy {X Y X' Y' : Type} {f : X -> Y} {f' : X' -> Y'}
+  {g g' : X -> X'} {h h' : Y -> Y'} {p : h o f == f' o g} {p' : h' o f == f' o g'}
+  (u : g == g') (v : h == h') 
+  (r : forall x, p x @ ap f' (u x) = v (f x) @ p' x)
+  : functor_cofiber g h p == functor_cofiber g' h' p'.
+Proof.
+  snrapply (functor_pushout_homotopic u v (fun _ => 1) r).
+  intro x; exact (concat_1p _ @ ap_const _ _).
+Defined.
+
+(** The cofiber functor preserves the identity map. *) 
+Definition functor_cofiber_idmap {X Y : Type} (f : X -> Y)
+  : functor_cofiber (f:=f) idmap idmap (fun _ => 1) == idmap
+  := functor_pushout_idmap.
+
+(** The cofiber functor preserves composition of squares. (When mapping parallel edges). *)
+Definition functor_cofiber_compose {X Y X' Y' X'' Y'' : Type}
+  {f : X -> Y} {f' : X' -> Y'} {f'' : X'' -> Y''}
+  {g : X -> X'} {g' : X' -> X''} {h : Y -> Y'} {h' : Y' -> Y''}
+  (p : h o f == f' o g) (p' : h' o f' == f'' o g')
+  : functor_cofiber (g' o g) (h' o h) (fun x => ap h' (p x) @ p' (g x))
+    == functor_cofiber g' h' p' o functor_cofiber g h p
+  := functor_pushout_compose g h idmap g' h' idmap p (fun _ => 1) p' (fun _ => 1).
+
+Local Open Scope trunc_scope.
+
+(** ** Connectivity of cofibers *)
+
+(** The cofiber of an [n]-conencted map is [n.+1]-connected. *)
+Definition isconnnected_cofiber (n : trunc_index) {X Y : Type} (f : X -> Y)
+  {fc : IsConnMap n f}
+  : IsConnected n.+1 (Cofiber f).
+Proof.
+  apply isconnected_from_elim.
+  intros C H' g.
+  exists (g (cf_apex _)).
+  snrapply cofiber_ind.
+  - rapply (conn_map_elim n f).
+    intros x.
+    exact (ap g (cfglue f x)).
+  - exists idpath.
+    intros x.
+    lhs snrapply transport_paths_Fl.
+    apply moveR_Vp.
+    rhs nrapply concat_p1.
+    nrapply conn_map_comp.
+Defined.
+
+(** ** Comparison of fibers and cofibers *)
+
+Definition fiber_to_path_cofiber {X Y : Type} (f : X -> Y) (y : Y)
+  : hfiber f y -> cofib f y = cf_apex f.
+Proof.
+  intros [x p].
+  lhs_V nrapply (ap (cofib f) p).
+  apply cfglue.
+Defined.
+
+(** Blakers-Massey implies that the comparison map is highly connected. *)
+Definition isconnected_fiber_to_cofiber `{Univalence}
+  (n m : trunc_index) {X Y : Type} {ac : IsConnected m.+1 X}
+  (f : X -> Y) {fc : IsConnMap n.+1 f} (y : Y)
+  : IsConnMap (m +2+ n) (fiber_to_path_cofiber f y).
+Proof.
+  (* It's enough to check the connectivity of [functor_sigma idmap (fiber_to_path_cofiber f)]. *)
+  revert y; snrapply conn_map_fiber.
+  (* We precompose with the equivalence [X <~> { y : Y & hfiber f y }]. *)
+  rapply (cancelR_conn_map _ (equiv_fibration_replacement _)).
+  (* The Sigma-type [{ y : Y & cofib f y = cf_apex f}] in the codomain is the fiber of the map [cofib f], and so it is equivalent to the pullback of the cospan in the pushout square defining [Cofiber f].  We postcompose with this equivalence. *)
+  snrapply (cancelL_equiv_conn_map _ _ (equiv_pullback_unit_hfiber _ _)^-1%equiv).
+  (* The composite is homotopic to the map from [blakers_massey_po], with the only difference being an extra [1 @ _]. *)
+  snrapply conn_map_homotopic.
+  3: rapply blakers_massey_po.
+  (* Use [compute.] to see the details of the goal. *)
+  intros x.
+  apply (ap (fun z => (f x; tt; z))).
+  unfold fiber_to_path_cofiber; simpl.
+  symmetry; apply concat_1p.
+Defined.

theories/Limits/Pullback.v

@@ -91,14 +91,30 @@ Defined.
 Definition equiv_pullback_unit_prod (A B : Type)
 : Pullback (const_tt A) (const_tt B) <~> A * B.
 Proof.
-  simple refine (equiv_adjointify _ _ _ _).
-  - intros [a [b _]]; exact (a , b).
-  - intros [a b]; exact (a ; b ; 1).
-  - intros [a b]; exact 1.
-  - intros [a [b p]]; simpl.
-    apply (path_sigma' _ 1); simpl.
-    apply (path_sigma' _ 1); simpl.
-    apply path_contr.
+  refine (equiv_sigma_prod0 A B oE _).
+  snrapply equiv_functor_sigma_id; intro a; cbn.
+  rapply equiv_sigma_contr.
+Defined.
+
+(** Pullback of [Unit] is equivalent to [hfiber]. *)
+Definition equiv_pullback_unit_hfiber {A B : Type} (f : A -> B) (g : Unit -> B)
+  : Pullback f g <~> hfiber f (g tt).
+Proof.
+  snrapply equiv_functor_sigma_id; intro a; cbn.
+  exact (equiv_contr_sigma (fun c => _ = g c)).
+Defined.
+
+(** The same for the symmetrical pullback. *)
+Definition equiv_pullback_unit_hfiber' {A B : Type} (f : Unit -> B) (g : A -> B)
+  : Pullback f g <~> hfiber g (f tt)
+  := equiv_pullback_unit_hfiber _ _ oE equiv_pullback_symm _ _.
+
+(** When both corners are [Unit] you get the path type. *)
+Definition equiv_pullback_unit_unit_paths {B : Type} (f g : Unit -> B)
+  : Pullback f g <~> (f tt = g tt).
+Proof.
+  refine (_ oE equiv_contr_sigma _).
+  exact (equiv_contr_sigma (fun c => _ = g c)).
 Defined.
 
 (** The property of a given commutative square being a pullback *)

theories/Pointed/pSusp.v

@@ -5,7 +5,7 @@ Require Import Pointed.Loops.
 Require Import Pointed.pTrunc.
 Require Import Pointed.pEquiv.
 Require Import Homotopy.Suspension.
-Require Import Homotopy.Freudenthal.
+Require Import Homotopy.BlakersMassey.
 Require Import Truncations.
 Require Import WildCat.