Library HoTT.Modalities.Modality

Require Import HoTT.Basics HoTT.Types.
Require Import HFiber Extensions Factorization Limits.Pullback.
Require Export ReflectiveSubuniverse. (* Export because many of the lemmas and facts about reflective subuniverses are equally important for modalities. *)

Local Open Scope path_scope.

Modalities

Dependent eliminators

A dependent version of the reflection universal property. For later use we generalize it to refer to different subuniverses in the reflection and the elimination target.
Class ReflectsD@{i} (O' O : Subuniverse@{i}) (T : Type@{i})
      `{PreReflects@{i} O' T} :=
{
  extendable_to_OO :
     (Q : O_reflector O' T Type@{i}) {Q_inO : x, In O (Q x)},
      ooExtendableAlong (to O' T) Q
}.

In particular, from this we get a dependent eliminator.
Definition OO_ind {O' : Subuniverse} (O : Subuniverse)
           {A : Type} `{ReflectsD O' O A}
           (B : O_reflector O' A Type) {B_inO : oa, In O (B oa)}
           (f : a, B (to O' A a)) (oa : O_reflector O' A)
  : B oa
  := (fst (extendable_to_OO B 1%nat) f).1 oa.

Definition OO_ind_beta {O' O : Subuniverse} {A : Type} `{ReflectsD O' O A}
           (B : O_reflector O' A Type) {B_inO : oa, In O (B oa)}
           (f : a, B (to O' A a)) (a : A)
  : OO_ind O B f (to O' A a) = f a
  := (fst (extendable_to_OO B 1%nat) f).2 a.

Conversely, if O is closed under path-types, a dependent eliminator suffices to prove the whole dependent universal property.
Definition reflectsD_from_OO_ind@{i} {O' O : Subuniverse@{i}}
           {A : Type@{i}} `{PreReflects O' A}
           (OO_ind' : (B : O_reflector O' A Type@{i})
                             (B_inO : oa, In O (B oa))
                             (f : a, B (to O' A a))
                             oa, B oa)
           (OO_ind_beta' : (B : O_reflector O' A Type@{i})
                             (B_inO : oa, In O (B oa))
                             (f : a, B (to O' A a))
                             a, OO_ind' B B_inO f (to O' A a) = f a)
           (inO_paths' : (B : Type@{i}) (B_inO : In O B)
                      (z z' : B), In O (z = z'))
  : ReflectsD O' O A.
Proof.
  constructor.
  intros Q Q_inO n.
  revert Q Q_inO. simple_induction n n IHn; intros Q Q_inO.
  1:exact tt.
  split.
  - intros g.
     (OO_ind' Q _ g).
    rapply OO_ind_beta'.
  - intros h k.
    rapply IHn.
Defined.

In particular, this is the case if O is a reflective subuniverse.
Definition reflectsD_from_RSU {O' : Subuniverse} {O : ReflectiveSubuniverse}
           {A : Type} `{PreReflects O' A}
           (OO_ind' : (B : O_reflector O' A Type)
                             (B_inO : oa, In O (B oa))
                             (f : a, B (to O' A a))
                             oa, B oa)
           (OO_ind_beta' : (B : O_reflector O' A Type)
                             (B_inO : oa, In O (B oa))
                             (f : a, B (to O' A a))
                             a, OO_ind' B B_inO f (to O' A a) = f a)
  : ReflectsD O' O A
  := reflectsD_from_OO_ind OO_ind' OO_ind_beta' _.

Of course, with funext this becomes an actual equivalence.
Definition isequiv_oD_to_O
           {fs : Funext} (O' O : Subuniverse) {A : Type} `{ReflectsD O' O A}
           (B : O_reflector O' A Type) `{ a, In O (B a)}
  : IsEquiv (fun (h : oa, B oa) ⇒ h oD to O' A).
Proof.
  apply isequiv_ooextendable, extendable_to_OO; assumption.
Defined.

The strong order

Note the reversal of the order: O1 << O2 means that O2 has dependent eliminators into O1.
Class O_strong_leq (O1 O2 : ReflectiveSubuniverse)
  := reflectsD_strong_leq : A, ReflectsD O2 O1 A.
Global Existing Instance reflectsD_strong_leq.

Infix "<<" := O_strong_leq : subuniverse_scope.
Open Scope subuniverse_scope.

The strong order implies the weak order.
Global Instance O_leq_strong_leq {O1 O2 : ReflectiveSubuniverse} `{O1 << O2}
  : O1 O2.
Proof.
  intros A A_inO1.
  srapply inO_to_O_retract.
  - exact (OO_ind O1 (fun _:O2 AA) idmap).
  - intros a. srapply OO_ind_beta.
Defined.

The strong order is not obviously transitive, but it composes with the weak order on one side at least.
Definition O_strong_leq_trans_l (O1 O2 O3 : ReflectiveSubuniverse)
           `{O1 O2} `{O2 << O3}
  : O1 << O3.
Proof.
  intros A; constructor; intros B B_inO.
  apply (extendable_to_OO (O := O2)).
  intros x.
  srapply inO_leq; apply B_inO.
Defined.

Modalities

A modality is a reflective subuniverse with a dependent universal property with respect to itself.
Notation IsModality O := (O << O).

However, it's not clear what the best bundled definition of modality is. The obvious one { O : ReflectiveSubuniverse & IsModality O} has the advantage that bundling a reflective subuniverse into a modality and then unbundling it is definitionally the identity; but it is redundant, since the dependent universal property implies the non-dependent one, and in practice most modalities are constructed directly with a dependent eliminator. Thus, for now at least, we take the following definition, which in RSS is called a "uniquely eliminating modality".
Record Modality@{i} := Build_Modality'
{
  modality_subuniv : Subuniverse@{i} ;
  modality_prereflects : (T : Type@{i}),
      PreReflects modality_subuniv T ;
  modality_reflectsD : (T : Type@{i}),
      ReflectsD modality_subuniv modality_subuniv T ;
}.

Global Existing Instance modality_reflectsD.
We don't declare modality_subuniv as a coercion or modality_prereflects as a global instance, because we want them only to be found by way of the following "unbundling" coercion to reflective subuniverses.

Definition modality_to_reflective_subuniverse (O : Modality@{i})
  : ReflectiveSubuniverse@{i}.
Proof.
  refine (Build_ReflectiveSubuniverse
            (modality_subuniv O) (modality_prereflects O) _).
  intros T; constructor.
  intros Q Q_inO.
  srapply extendable_to_OO.
Defined.

Coercion modality_to_reflective_subuniverse : Modality >-> ReflectiveSubuniverse.

Unfortunately, sometimes modality_subuniv pops up anyway. The following hint helps typeclass inference look through it.
#[export]
Hint Extern 0 (In (modality_subuniv _) _) ⇒ progress change modality_subuniv with (rsu_subuniv o modality_to_reflective_subuniverse) in × : typeclass_instances.

Modalities are precisely the reflective subuniverses that are << themselves.
Global Instance ismodality_modality (O : Modality) : IsModality O.
Proof.
  intros A; exact _.
Defined.

Definition modality_ismodality (O : ReflectiveSubuniverse) `{IsModality O} : Modality.
Proof.
  rapply Build_Modality'.
Defined.

When combined with isequiv_oD_to_O, this yields Theorem 7.7.7 in the book.
Definition isequiv_oD_to_O_modality
           `{Funext} (O : Modality) {A : Type}
           (B : O A Type) `{ a, In O (B a)}
  : IsEquiv (fun (h : oa, B oa) ⇒ h oD to O A).
Proof.
  srapply (isequiv_oD_to_O O O).
Defined.

Of course, modalities have dependent eliminators.
Definition O_ind {O : Subuniverse} {A : Type} `{ReflectsD O O A}
  := @OO_ind O O A _ _.
Arguments O_ind {O A _ _} B {B_inO} f oa.
Definition O_ind_beta {O : Subuniverse} {A : Type} `{ReflectsD O O A}
  := @OO_ind_beta O O A _ _.
Arguments O_ind_beta {O A _ _} B {B_inO} f a.

Conversely, as remarked above, we can build a modality from a dependent eliminator as long as we assume the modal types are closed under paths. This is probably the most common way to define a modality, and one might argue that this would be a better definition of the bundled type Modality. For now we simply respect that by dignifying it with the unprimed constructor name Build_Modality.
Definition Build_Modality
           (In' : Type Type)
           (hprop_inO' : Funext T : Type, IsHProp (In' T))
           (inO_equiv_inO' : T U : Type,
               In' T f : T U, IsEquiv f In' U)
           (O_reflector' : Type Type)
           (O_inO' : T, In' (O_reflector' T))
           (to' : T, T O_reflector' T)
           (O_ind' : (A : Type) (B : O_reflector' A Type)
                            (B_inO : oa, In' (B oa))
                            (f : a, B (to' A a))
                            (z : O_reflector' A),
               B z)
           (O_ind_beta' : (A : Type) (B : O_reflector' A Type)
                                 (B_inO : oa, In' (B oa))
                                 (f : a, B (to' A a)) (a : A),
               O_ind' A B B_inO f (to' A a) = f a)
           (inO_paths' : (A : Type) (A_inO : In' A) (z z' : A),
               In' (z = z'))
  : Modality.
Proof.
  pose (O := Build_Subuniverse In' hprop_inO' inO_equiv_inO').
  simple refine (Build_Modality' O _ _); intros T.
  - exact (Build_PreReflects O T (O_reflector' T) (O_inO' T) (to' T)).
  - srapply reflectsD_from_OO_ind.
    + rapply O_ind'.
    + rapply O_ind_beta'.
    + rapply inO_paths'.
Defined.

A tactic that extends strip_reflections to modalities. It handles non-dependent elimination for reflective subuniverses and dependent elimination for modalities. strip_truncations does the same for truncations, but introduces fewer universe variables, so tends to work better when removing truncations.
Ltac strip_modalities :=
  
Search for hypotheses of type O X for some O such that the goal is O-local.
  progress repeat
    match goal with
    | [ T : _ |- _ ]
      ⇒ revert_opaque T;
        
Handle the non-dependent and dependent cases. The last case requires that O be a modality.
        refine (@O_rec _ _ _ _ _ _ _) || refine (@O_indpaths _ _ _ _ _ _ _ _ _) || refine (@O_ind _ _ _ _ _ _ _);
        
Ensure that we didn't generate more than one subgoal, i.e. that the goal was appropriately local.
        [];
        intro T
  end.

Dependent sums

A dependent elimination of a reflective subuniverse O' into O implies that the sum of a family of O-modal types over an O'-modal type is O'-modal. More specifically, for a particular such sum it suffices for the O'-reflection of that sum to dependently eliminate into O.
Global Instance inO_sigma_reflectsD
       {O' : ReflectiveSubuniverse} {O : Subuniverse}
       {A : Type} (B : A Type) `{!ReflectsD O' O (sig B)}
       `{In O' A} `{ a, In O (B a)}
  : In O' {x:A & B x}.
Proof.
  pose (h := fun x ⇒ @O_rec O' ({x:A & B x}) A _ _ _ pr1 x).
  assert (p := (fun zO_rec_beta pr1 z) : h o (to O' _) == pr1).
  pose (g := fun z ⇒ (transport B ((p z)^) z.2)).
  simpl in ×.
  pose (f := OO_ind O (fun x:O' (sig B) ⇒ B (h x)) g).
  pose (q := OO_ind_beta (fun x:O' (sig B) ⇒ B (h x)) g).
  apply inO_to_O_retract with (mu := fun w(h w; f w)).
  intros [x1 x2].
  simple refine (path_sigma B _ _ _ _); simpl.
  - apply p.
  - refine (ap _ (q (x1;x2)) @ _).
    unfold g; simpl. exact (transport_pV B _ _).
Defined.

Specialized to a modality, this yields the implication (ii) => (i) from Theorem 7.7.4 of the book, and also Corollary 7.7.8, part 2.
Global Instance inO_sigma (O : Modality)
           {A:Type} (B : A Type) `{In O A} `{ a, In O (B a)}
  : In O {x:A & B x}
  := _.

This implies that the composite of modal maps is modal.
Global Instance mapinO_compose {O : Modality} {A B C : Type} (f : A B) (g : B C)
       `{MapIn O _ _ f} `{MapIn O _ _ g}
  : MapIn O (g o f).
Proof.
  intros c.
  refine (inO_equiv_inO' _ (hfiber_compose f g c)^-1).
Defined.

It also implies Corollary 7.3.10 from the book, generalized to modalities. (Theorem 7.3.9 is true for any reflective subuniverse; we called it equiv_O_sigma_O.)
Corollary equiv_sigma_inO_O {O : Modality} {A : Type} `{In O A} (P : A Type)
  : {x:A & O (P x)} <~> O {x:A & P x}.
Proof.
  transitivity (O {x:A & O (P x)}).
  - rapply equiv_to_O.
  - apply equiv_O_sigma_O.
Defined.

Conversely, if the sum of a particular family of O-modal types over an O'-reflection is in O', then that family admits a dependent eliminator.
Definition extension_from_inO_sigma
           {O' : Subuniverse} (O : Subuniverse)
           {A:Type} `{Reflects O' A} (B: O_reflector O' A Type)
           {inO_sigma : In O' {z:O_reflector O' A & B z}}
           (g : x, B (to O' A x))
  : ExtensionAlong (to O' A) B g.
Proof.
  set (Z := sig B) in ×.
  pose (g' := (fun a:A(to O' A a ; g a)) : A Z).
  pose (f' := O_rec (O := O') g').
  pose (eqf := (O_rec_beta g') : f' o to O' A == g').
  pose (eqid := O_indpaths (pr1 o f') idmap (fun xap@{k i} pr1 (eqf x))).
   (fun ztransport B (eqid z) ((f' z).2)).
  intros a. unfold eqid.
  refine (_ @ pr2_path (O_rec_beta g' a)).
  refine (ap (fun ptransport B p (O_rec g' (to O' A a)).2) _).
  srapply O_indpaths_beta.
Defined.

And even a full equivalence of spaces of sections. This is stated in CORS Proposition 2.8 (but our version avoids funext by using ooExtendableAlong, as usual).
Definition ooextendable_from_inO_sigma
           {O' : ReflectiveSubuniverse} (O : Subuniverse)
           {A : Type} (B: O_reflector O' A Type)
           {inO_sigma : In O' {z:O_reflector O' A & B z}}
  : ooExtendableAlong (to O' A) B.
Proof.
  intros n; generalize dependent A.
  induction n as [|n IHn]; intros; [ exact tt | cbn ].
  refine (extension_from_inO_sigma O B , _).
  intros h k; nrapply IHn.
  set (Z := sig B) in ×.
  pose (W := sig (fun aB a × B a)).
  nrefine (inO_equiv_inO' (Pullback (A := W) (fun a:O_reflector O' A(a;(h a,k a)))
                                   (fun z:Z(z.1;(z.2,z.2)))) _).
  { refine (inO_pullback O' _ _).
    exact (inO_equiv_inO' _ (equiv_sigprod_pullback B B)^-1). }
  unfold Pullback.
The rest is just extracting paths from sigma- and product types and contracting a couple of based path spaces.
  apply equiv_functor_sigma_id; intros z; cbn.
  refine (_ oE equiv_functor_sigma_id _).
  2:intros; symmetry; apply equiv_path_sigma.
  refine (_ oE equiv_functor_sigma_id (fun zequiv_functor_sigma_id (fun p_))).
  2:symmetry; apply equiv_path_prod.
  cbn. make_equiv_contr_basedpaths.
Defined.

Thus, if this holds for all sigma-types, we get the dependent universal property. Making this an Instance causes typeclass search to spin. Note the slightly different hypotheses, which mean that we can't just use the previous result: here we need only assume that the O'-reflection of A exists rather than that O' is fully reflective, at the cost of assuming that O is fully reflective (although actually, closed under path-spaces would suffice).
Definition reflectsD_from_inO_sigma
           {O' : Subuniverse} (O : ReflectiveSubuniverse)
           {A : Type} `{Reflects O' A}
           (inO_sigma : (B: O_reflector O' A Type),
               ( oa, In O (B oa)) In O' {z:O_reflector O' A & B z})
  : ReflectsD O' O A.
Proof.
  constructor; intros B B_inO.
  intros n; generalize dependent A.
  induction n as [|n IHn]; intros; [ exact tt | cbn ].
  refine (extension_from_inO_sigma O B , _).
  intros h k; rapply IHn.
Defined.

In particular, we get the converse implication (i) => (ii) from Theorem 7.7.4 of the book: a reflective subuniverse closed under sigmas is a modality.
Definition modality_from_inO_sigma (O : ReflectiveSubuniverse)
           (H : (A:Type) (B:A Type)
                       {A_inO : In O A} `{ a, In O (B a)},
               (In O {x:A & B x}))
  : Modality.
Proof.
  refine (Build_Modality' O _ _).
  intros; srapply reflectsD_from_inO_sigma.
Defined.

Connectedness of the units

Dependent reflection can also be characterized by connectedness of the unit maps.
Global Instance conn_map_to_O_reflectsD {O' : Subuniverse} (O : ReflectiveSubuniverse)
       {A : Type} `{ReflectsD O' O A}
  : IsConnMap O (to O' A).
Proof.
  apply conn_map_from_extension_elim.
  intros P P_inO f.
  exact (fst (extendable_to_OO (O := O) P 1%nat) f).
Defined.

Definition reflectsD_from_conn_map_to_O {O' : Subuniverse} (O : ReflectiveSubuniverse)
           {A : Type} `{PreReflects O' A} `{IsConnMap O _ _ (to O' A)}
  : ReflectsD O' O A.
Proof.
  constructor; rapply ooextendable_conn_map_inO.
Defined.

In particular, if O1 << O2 then every O2-unit is O1-connected.
Global Instance conn_map_to_O_strong_leq
       {O1 O2 : ReflectiveSubuniverse} `{O1 << O2} (A : Type)
  : IsConnMap O1 (to O2 A)
  := _.

Thus, if O is a modality, then every O-unit is O-connected. This is Corollary 7.5.8 in the book.
Global Instance conn_map_to_O {O : Modality} (A : Type)
  : IsConnMap O (to O A)
  := _.

When O1 << O2, O_functor O2 preserves O1-connected maps.
Proposition conn_map_O_functor_strong_leq {O1 O2 : ReflectiveSubuniverse} (leq : O1 << O2)
  {X Y : Type} (f : X Y) `{IsConnMap O1 _ _ f}
  : IsConnMap O1 (O_functor O2 f).
Proof.
  rapply (cancelR_conn_map _ (to O2 _)).
  nrapply conn_map_homotopic.
  1: symmetry; apply to_O_natural.
  rapply conn_map_compose.
Defined.

Easy modalities

The book uses yet a different definition of modality, which requires an induction principle only into families of the form fun oa O (B oa), and similarly only that path-spaces of types O A are "modal" in the sense that the unit is an equivalence. As shown in section 1 of RSS, this is equivalent, roughly since every modal type A (in this sense) is equivalent to O A.
Our definitions are more convenient in formalized applications because in some examples (such as Trunc and closed modalities), there is a naturally occurring O_ind into all modal types that is not judgmentally equal to the one that can be constructed by passing through O and back again. Thus, when we apply general theorems about modalities to a particular modality such as Trunc, the proofs will reduce definitionally to "the way we would have proved them directly" if we didn't know about general modalities.
On the other hand, in other examples (such as ~~ and open modalities) it is easier to construct the latter weaker induction principle. Thus, we now show how to get from that to our definition of modality.

Section EasyModalities.

  Universe i.
  Context (O_reflector : Type@{i} Type@{i})
          (to : (T : Type@{i}), T O_reflector T)
          (O_indO
           : (A : Type@{i})
                    (B : O_reflector A Type@{i})
                    (f : a, O_reflector (B (to A a)))
                    (z : O_reflector A),
              O_reflector (B z))
          (O_indO_beta
           : (A : Type@{i})
                    (B : O_reflector A Type@{i})
                    (f : a, O_reflector (B (to A a))) (a : A),
              O_indO A B f (to A a) = f a)
          (inO_pathsO
           : (A : Type@{i}) (z z' : O_reflector A),
              IsEquiv (to (z = z'))).

  Local Definition In_easy : Type@{i} Type@{i}
    := fun AIsEquiv (to A).

  Local Definition O_ind_easy
             (A : Type) (B : O_reflector A Type)
             (B_inO : oa, In_easy (B oa))
    : ( a, B (to A a)) oa, B oa.
  Proof.
    simpl; intros f oa.
    pose (H := B_inO oa); unfold In_easy in H.
    apply ((to (B oa))^-1).
    apply O_indO.
    intros a; apply to, f.
  Defined.

  Local Definition O_ind_easy_beta
             (A : Type) (B : O_reflector A Type)
             (B_inO : oa, In_easy (B oa))
             (f : a : A, B (to A a)) (a:A)
  : O_ind_easy A B B_inO f (to A a) = f a.
  Proof.
    unfold O_ind_easy.
    apply moveR_equiv_V.
    apply @O_indO_beta with (f := fun xto _ (f x)).
  Qed.

  Local Definition O_inO_easy (A : Type) : In_easy (O_reflector A).
  Proof.
    refine (isequiv_adjointify (to (O_reflector A))
             (O_indO (O_reflector A) (fun _A) idmap) _ _).
    - intros x; pattern x; apply O_ind_easy.
      + intros oa; apply inO_pathsO.
      + intros a; apply ap.
        exact (O_indO_beta (O_reflector A) (fun _A) idmap a).
    - intros a.
      exact (O_indO_beta (O_reflector A) (fun _A) idmap a).
  Defined.

It seems to be surprisingly hard to show repleteness (without univalence). We basically have to manually develop enough functoriality of O and naturality of to O.
  Local Definition inO_equiv_inO_easy (A B : Type)
        (A_inO : In_easy A) (f : A B) (feq : IsEquiv f)
    : In_easy B.
  Proof.
    simple refine (isequiv_commsq (to A) (to B) f
             (O_ind_easy A (fun _O_reflector B) _ (fun ato B (f a))) _).
    - intros; apply O_inO_easy.
    - intros a; refine (O_ind_easy_beta A (fun _O_reflector B) _ _ a).
    - apply A_inO.
    - simple refine (isequiv_adjointify _
               (O_ind_easy B (fun _O_reflector A) _ (fun bto A (f^-1 b))) _ _);
        intros x.
      + apply O_inO_easy.
      + pattern x; refine (O_ind_easy B _ _ _ x); intros.
        × apply inO_pathsO.
        × simpl; abstract (repeat rewrite O_ind_easy_beta; apply ap, eisretr).
      + pattern x; refine (O_ind_easy A _ _ _ x); intros.
        × apply inO_pathsO.
        × simpl; abstract (repeat rewrite O_ind_easy_beta; apply ap, eissect).
  Defined.

  Local Definition inO_paths_easy (A : Type) (A_inO : In_easy A) (a a' : A)
    : In_easy (a = a').
  Proof.
    simple refine (inO_equiv_inO_easy (to A a = to A a') _ _
                                      (@ap _ _ (to A) a a')^-1 _).
    - apply inO_pathsO.
    - refine (@isequiv_ap _ _ _ A_inO _ _).
    - apply isequiv_inverse.
  Defined.

  Definition easy_modality : Modality
    := Build_Modality In_easy _ inO_equiv_inO_easy O_reflector O_inO_easy to O_ind_easy O_ind_easy_beta inO_paths_easy.

End EasyModalities.

The modal factorization system


Section ModalFact.
  Context `{fs : Funext} (O : Modality).

Lemma 7.6.4
  Definition image {A B : Type} (f : A B)
  : Factorization (@IsConnMap O) (@MapIn O) f.
  Proof.
    pose mapinO_pr1.
Slightly speeds up next line.
    refine (Build_Factorization {b : B & O (hfiber f b)}
                                (fun a(f a ; to O _ (a;1)))
                                pr1
                                (fun a ⇒ 1)
                                _ _).
    pose conn_map_functor_sigma.
Slightly speeds up next line.
    exact (conn_map_compose O
              (equiv_fibration_replacement f)
              (functor_sigma idmap (fun bto O (hfiber f b)))).
  Defined.

  Global Instance conn_map_factor1_image {A B : Type} (f : A B)
  : IsConnMap O (factor1 (image f))
    := inclass1 (image f).

  Global Instance inO_map_factor1_image {A B : Type} (f : A B)
  : MapIn O (factor2 (image f))
    := inclass2 (image f).

This is the composite of the three displayed equivalences at the beginning of the proof of Lemma 7.6.5. Note that it involves only a single factorization of f.
  Lemma O_hfiber_O_fact {A B : Type} {f : A B}
        (fact : Factorization (@IsConnMap O) (@MapIn O) f) (b : B)
  : O (hfiber (factor2 fact o factor1 fact) b)
      <~> hfiber (factor2 fact) b.
  Proof.
    refine (_ oE
             (equiv_O_functor O
               (hfiber_compose (factor1 fact) (factor2 fact) b))).
    nrefine (equiv_sigma_contr (fun wO (hfiber (factor1 fact) w.1)) oE _).
    - intros w; exact (inclass1 fact w.1).
    - nrefine ((equiv_sigma_inO_O (fun whfiber (factor1 fact) w.1))^-1)%equiv.
      exact (inclass2 fact b).
  Defined.

This is the corresponding first three of the displayed "mapsto"s in proof of Lemma 7.6.5, and also the last three in reverse order, generalized to an arbitrary path p. Note that it is much harder to prove than in the book, because we are working in the extra generality of a modality where O_ind_beta is only propositional.
  Lemma O_hfiber_O_fact_inverse_beta {A B : Type} {f : A B}
        (fact : Factorization (@IsConnMap O) (@MapIn O) f)
        (a : A) (b : B) (p : factor2 fact (factor1 fact a) = b)
  : (O_hfiber_O_fact fact b)^-1
      (factor1 fact a ; p) = to O _ (a ; p).
  Proof.
    set (g := factor1 fact); set (h := factor2 fact).
    apply moveR_equiv_V.
    unfold O_hfiber_O_fact.
    ev_equiv.
    apply moveL_equiv_M.
    transitivity (exist (fun (w : hfiber h b) ⇒ O (hfiber g w.1))
                         (g a; p) (to O (hfiber g (g a)) (a ; 1))).
    - apply moveR_equiv_V; reflexivity.
    - apply moveL_equiv_V.
      transitivity (to O _ (exist (fun (w : hfiber h b) ⇒ (hfiber g w.1))
                         (g a; p) (a ; 1))).
      + cbn; repeat rewrite O_rec_beta; reflexivity.
      + destruct p; symmetry; apply to_O_natural.
  Qed.

  Section TwoFactorizations.
    Context {A B : Type} (f : A B)
            (fact fact' : Factorization (@IsConnMap O) (@MapIn O) f).

    Let H := fun xfact_factors fact x @ (fact_factors fact' x)^.

Lemma 7.6.5, part 1.
    Definition equiv_O_factor_hfibers (b:B)
    : hfiber (factor2 fact) b <~> hfiber (factor2 fact') b.
    Proof.
      refine (O_hfiber_O_fact fact' b oE _).
      refine (_ oE (O_hfiber_O_fact fact b)^-1).
      apply equiv_O_functor.
      apply equiv_hfiber_homotopic.
      exact H.
    Defined.

Lemma 7.6.5, part 2.
    Definition equiv_O_factor_hfibers_beta (a : A)
    : equiv_O_factor_hfibers (factor2 fact (factor1 fact a))
                             (factor1 fact a ; 1)
      = (factor1 fact' a ; (H a)^).
    Proof.
      unfold equiv_O_factor_hfibers.
      ev_equiv.
      apply moveR_equiv_M.
      do 2 rewrite O_hfiber_O_fact_inverse_beta.
      unfold equiv_fun, equiv_O_functor.
      transitivity (to O _
                       (equiv_hfiber_homotopic
                          (factor2 fact o factor1 fact)
                          (factor2 fact' o factor1 fact') H
                          (factor2 fact (factor1 fact a)) (a;1))).
      - refine (to_O_natural O _ _).
      - apply ap.
        simpl.
        apply ap; auto with path_hints.
    Qed.

  End TwoFactorizations.

Theorem 7.6.6. Recall that a lot of hard work was done in Factorization.path_factorization.
  Definition O_factsys : FactorizationSystem.
  Proof.
    refine (Build_FactorizationSystem
              (@IsConnMap O) _ _ _
              (@MapIn O) _ _ _
              (@image) _).
    intros A B f fact fact'.
    simple refine (Build_PathFactorization fact fact' _ _ _ _).
    - refine (_ oE equiv_fibration_replacement (factor2 fact)).
      refine ((equiv_fibration_replacement (factor2 fact'))^-1 oE _).
      apply equiv_functor_sigma_id; intros b; simpl.
      apply equiv_O_factor_hfibers.
    - intros a; exact (pr1_path (equiv_O_factor_hfibers_beta f fact fact' a)).
    - intros x.
      exact ((equiv_O_factor_hfibers f fact fact' (factor2 fact x) (x ; 1)).2 ^).
    - intros a.
      apply moveR_pM.
      refine ((inv_V _)^ @ _ @ inv_V _); apply inverse2.
      refine (_ @ pr2_path (equiv_O_factor_hfibers_beta f fact fact' a)).
      refine (_ @ (transport_paths_Fl _ _)^).
      exact (inv_pp _ _ @ (1 @@ inv_V _)).
  Defined.

End ModalFact.