(*
  [TypeTheory.TypeCat_CompCat.TypeCat_ComprehensionCat]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).
*)

(**
This module defines a comprehension category induced by a (non-split) type category.

Main definition is

- [typecat_to_comprehension_cat] - comprehension category induced by a type category;

Important parts are:

- [typecat_disp] - displayed category induced by a type category (or rather by its object extension substructure);
- [typecat_disp_is_disp_univalent] - induced displayed category is univalent when [typecat_idtoiso_triangle] is an equivalence;
- [cleaving_typecat_disp] - induced displayed category is a fibration;

- [typecat_disp_functor] - a comprehension functor induced by a type category;
- [typecat_disp_functor_ff] - induced displayed functor is fully faithful;
- [typecat_disp_functor_is_cartesian] - induced displayed functor is cartesian.

*)

Require Import UniMath.MoreFoundations.PartA.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.Pullbacks.

Require Import TypeTheory.TypeCat.TypeCat.
Require Import TypeTheory.CompCats.FullyFaithfulDispFunctor.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Codomain.
Require Import UniMath.CategoryTheory.DisplayedCats.ComprehensionC.

Section TypeCat_ObjExt.

  (* Object extension structure is part of the definition of type category that includes:
   * - the type family [ty_typecat] : C → UU;
   * - for every Γ : C and A : Ty(Γ):
   *   - context extension [Γ ◂ A];
   *   - for every morphism f : Γ' --> Γ, reindexing mapping [reind_typecat];
   *   - projection morphism [dpr_typecat_obj_ext]: Γ ◂ A --> Γ.
   *)
  Definition typecat_obj_ext_structure (C : precategory)
    := ∑ (Ty : C → UU)
         (ext : ∏ (Γ : C), Ty Γ → C)
       (* dpr : *), ∏ Γ (A : Ty Γ), ext Γ A --> Γ.

  Definition Ty_obj_ext (C : precategory)
             (TC : typecat_obj_ext_structure C)
    : C → UU
    := pr1 TC.

  Coercion Ty_obj_ext : typecat_obj_ext_structure >-> Funclass.

  Definition obj_ext_typecat {C : precategory} {TC : typecat_obj_ext_structure C}
             (Γ : C) (A : TC Γ) : C
    := pr1 (pr2 TC) Γ A.

  Definition dpr_typecat_obj_ext {C : precategory}
             {TC : typecat_obj_ext_structure C} {Γ} (A : pr1 TC Γ)
    : obj_ext_typecat Γ A --> Γ
    := pr2 (pr2 TC) Γ A.

  Definition typecat_obj_ext_from_typecat (C : category) (TC : typecat_structure C)
    : typecat_obj_ext_structure _  := (_ ,, _ ,, @dpr_typecat _ TC).
  Coercion typecat_obj_ext_from_typecat : typecat_structure >-> typecat_obj_ext_structure.

End TypeCat_ObjExt.

Local Notation "'π' A" := (dpr_typecat_obj_ext A) (at level 5).

Section TypeCat_Comp_Ext_Compare.

  Context {C : precategory}.
  Context (TC : typecat_obj_ext_structure C).

  Definition typecat_comp_ext_compare
             {Γ : C} {A B : TC Γ}
    : (A = B) → z_iso (obj_ext_typecat Γ A) (obj_ext_typecat Γ B).
  Proof.
    intros p. induction p.
    apply identity_z_iso.
  Defined.

  Definition typecat_idtoiso_dpr
             {Γ : C} {A B : TC Γ}
             (p : A = B)
    : idtoiso (maponpaths (λ B, obj_ext_typecat Γ B) p) ;; π B = π A.
  Proof.
    induction p. apply id_left.
  Defined.

  Definition typecat_iso_triangle
             {Γ : C} (A B : TC Γ)
    := ∑ (i : z_iso (obj_ext_typecat Γ A) (obj_ext_typecat Γ B)),
       i ;; π B = π A.

  Definition typecat_iso_triangle_swap
             {Γ : C} {A B : TC Γ}
    : typecat_iso_triangle A B → typecat_iso_triangle B A.
  Proof.
    intros tr.
    exists (z_iso_inv_from_z_iso (pr1 tr)).
    etrans. apply maponpaths, pathsinv0, (pr2 tr).
    etrans. apply assoc.
    etrans. apply maponpaths_2, z_iso_after_z_iso_inv.
    apply id_left.
  Defined.

  Definition typecat_idtoiso_triangle
             {Γ : C} (A B : TC Γ)
    : (A = B) → typecat_iso_triangle A B.
  Proof.
    intros p. induction p.
    use tpair.
    - apply typecat_comp_ext_compare, (idpath _).
    - apply id_left.
  Defined.

End TypeCat_Comp_Ext_Compare.

Section TypeCat_Disp.

  (* Type category (or rather its object extension part)
   * induces a displayed category over C with
   * - objects over Γ : C being types A : Ty(Γ)
   * - morphisms from A' to A over f : Γ' --> Γ being a morphism
         ff : Γ.A' --> Γ.A making the square with projections and f commute.
   *)
  Definition typecat_disp_ob_mor
             {C : precategory} (TC : typecat_obj_ext_structure C)
  : disp_cat_ob_mor C.
  Proof.
    use tpair.
    - apply TC.
    - intros Γ' Γ A' A f.
      exact (∑ ff : obj_ext_typecat Γ' A' --> obj_ext_typecat Γ A,
                    ff ;; π A = π A' ;; f).
  Defined.

  Definition typecat_disp_id_comp
             {C : precategory} (TC : typecat_obj_ext_structure C)
    : disp_cat_id_comp _ (typecat_disp_ob_mor TC).
    split.
    + intros Γ A; cbn in *.
      use tpair.
      * apply identity.
      * cbn. etrans. apply id_left. apply pathsinv0, id_right.
    + intros ? ? ? ? ? ? ? ? ff gg; cbn in *.
      use tpair.
      * apply (pr1 ff ;; pr1 gg).
      * simpl.
        etrans. apply assoc'.
        etrans. apply maponpaths, (pr2 gg).
        etrans. apply assoc.
        etrans. apply maponpaths_2, (pr2 ff).
        apply assoc'.
  Defined.

  Definition typecat_disp_data
             {C : precategory} (TC : typecat_obj_ext_structure C)
    : disp_cat_data C
    := (typecat_disp_ob_mor TC,, typecat_disp_id_comp TC).

  (* NOTE: copied with slight modifications from https://github.com/UniMath/TypeTheory/blob/ad54ca1dad822e9c71acf35c27d0a39983269462/TypeTheory/Displayed_Cats/DisplayedCatFromCwDM.v#L78-L107  *)
  Definition typecat_disp_axioms
             {C : category} (TC : typecat_obj_ext_structure C)
    : disp_cat_axioms _ (typecat_disp_data TC).
  Proof.
    repeat apply tpair; intros; try apply homset_property.
    - (* id_left_disp *)
      apply subtypePath.
      { intro. apply homset_property. }
      etrans. apply id_left.
      etrans. 2: { use (transport_map (fun a : C⟦_,_⟧ => pr1)). }
      apply pathsinv0, transportf_const'.
    - (* id_right_disp *)
      apply subtypePath.
      { intro. apply homset_property. }
      etrans. apply id_right.
      etrans. 2: { use (transport_map (fun a : C⟦_,_⟧ => pr1)). }
      apply pathsinv0, transportf_const'.
    - (* assoc_disp *)
      apply subtypePath.
      { intro. apply homset_property. }
      etrans. apply assoc.
      etrans. 2: { use (transport_map (fun a : C⟦_,_⟧ => pr1)). }
      apply pathsinv0, transportf_const'.
    - (* homsets_disp *)
      apply (isofhleveltotal2 2).
      + apply homset_property.
      + intro. apply isasetaprop. apply homset_property.
  Qed.

  Definition typecat_disp
             {C : category} (TC : typecat_obj_ext_structure C)
    : disp_cat C
    := (typecat_disp_data TC,, typecat_disp_axioms TC).

  Section TypeCat_Disp_is_univalent.

    Context {C : category}.
    Context (TC : typecat_obj_ext_structure C).

    Definition typecat_is_triangle_to_idtoiso_fiber_disp
               {Γ : C} (A B : TC Γ)
      : typecat_iso_triangle _ A B → @z_iso_disp C (typecat_disp TC) _ _ (identity_z_iso Γ) A B.
    Proof.
      intros tr.
      set (i        := pr1 (pr1 tr) : C ⟦ obj_ext_typecat Γ A, obj_ext_typecat Γ B ⟧ ).
      set (iB_A     := pr2 tr : i ;; π B = π A).

      set (tr' := typecat_iso_triangle_swap TC tr).
      set (inv_i    := pr1 (pr1 tr') : C ⟦ obj_ext_typecat Γ B, obj_ext_typecat Γ A ⟧).
      set (inv_iA_B := pr2 tr' : inv_i ;; π A = π B).

      set (i_inv_i  := z_iso_inv_after_z_iso (pr1 tr) : i ;; inv_i = identity _).
      set (inv_i_i  := z_iso_after_z_iso_inv (pr1 tr) : inv_i ;; i = identity _).

      repeat use tpair.
      - exact i.
      - etrans. apply iB_A. apply pathsinv0, id_right.
      - exact inv_i.
      - simpl. etrans. apply inv_iA_B. apply pathsinv0, id_right.
      - use total2_paths_f.
        2: apply homset_property.
        etrans. apply inv_i_i.
        etrans. 2: { use (transport_map (fun a : C⟦_,_⟧ => pr1)). }
        apply pathsinv0, transportf_const'.
      - use total2_paths_f.
        2: apply homset_property.
        etrans. apply i_inv_i.
        etrans. 2: { use (transport_map (fun a : C⟦_,_⟧ => pr1)). }
        apply pathsinv0, transportf_const'.
    Defined.

    Definition idtoiso_fiber_disp_to_typecat_is_triangle
               {Γ : C} (A B : TC Γ)
      : @z_iso_disp C (typecat_disp TC) _ _ (identity_z_iso Γ) A B → typecat_iso_triangle _ A B.
    Proof.
      intros tr.
      set (i        := pr1 (pr1 tr) : C ⟦ obj_ext_typecat Γ A, obj_ext_typecat Γ B ⟧ ).
      set (iB_A     := pr2 (pr1 tr) : i ;; π B = π A ;; identity _).
      set (inv_i    := pr1 (pr1 (pr2 tr)) : C ⟦ obj_ext_typecat Γ B, obj_ext_typecat Γ A ⟧).
      set (inv_iA_B := pr2 (pr1 (pr2 tr))
                       : inv_i ;; π A = π B ;; identity _).
      set (inv_i_i  := maponpaths pr1 (pr1 (pr2 (pr2 tr))) : _).
      set (i_inv_i  := maponpaths pr1 (dirprod_pr2 (pr2 (pr2 tr))) : _).

      repeat use tpair.
      - exact i.
      - apply inv_i.
      - etrans. apply i_inv_i.
        etrans.
        { apply pathsinv0. use (transport_map (fun a : C⟦_,_⟧ => pr1)). }
        apply transportf_const'.
      - etrans. apply inv_i_i.
        etrans.
        { apply pathsinv0. use (transport_map (fun a : C⟦_,_⟧ => pr1)). }
        apply transportf_const'.
      - etrans. apply iB_A. apply id_right.
    Defined.

    Definition typecat_is_triangle_idtoiso_fiber_disp_isweq
               {Γ : C} (A B : TC Γ)
      : isweq (typecat_is_triangle_to_idtoiso_fiber_disp A B).
    Proof.
      use isweq_iso.
      - apply idtoiso_fiber_disp_to_typecat_is_triangle.
      - intros tr.
        use total2_paths_f.
        + apply z_iso_eq, idpath.
        + apply homset_property.
      - intros tr.
        apply eq_z_iso_disp.
        use total2_paths_f.
        + apply idpath.
        + apply homset_property.
    Defined.

    Definition typecat_is_triangle_idtoiso_fiber_disp_weq
               {Γ : C} (A B : TC Γ)
      : typecat_iso_triangle _ A B ≃ @z_iso_disp C (typecat_disp TC) _ _ (identity_z_iso Γ) A B
    := (_,, typecat_is_triangle_idtoiso_fiber_disp_isweq A B).

    Definition typecat_disp_is_disp_univalent
               (w' : ∏ (Γ : C) (A B : TC Γ), isweq (typecat_idtoiso_triangle _ A B))
      : is_univalent_disp (typecat_disp TC).
    Proof.
      apply is_univalent_disp_from_fibers.
      intros Γ A B.
      set (f := typecat_is_triangle_idtoiso_fiber_disp_weq A B).
      set (g := (typecat_idtoiso_triangle _ A B,, w' _ A B)).
      use weqhomot.
      { exact (weqcomp g f). }
      intros p. induction p.
      use total2_paths_f.
      - use total2_paths_f.
        + apply idpath.
        + apply homset_property.
      - apply isaprop_is_z_iso_disp.
    Defined.

    Definition typecat_disp_is_disp_univalent_implies_typecat_idtoiso_triangle_isweq
               (D_is_univalent : is_univalent_disp (typecat_disp TC))
      : ∏ (Γ : C) (A B : TC Γ), isweq (typecat_idtoiso_triangle _ A B).
    Proof.
      intros Γ A B.
      set (f := typecat_is_triangle_idtoiso_fiber_disp_weq A B).
      set (g := (idtoiso_fiber_disp ,, is_univalent_in_fibers_from_univalent_disp _ D_is_univalent _ A B)).
      use weqhomot.
      { exact (weqcomp g (invweq f)). }
      intros p. induction p.
      use total2_paths_f.
      - apply z_iso_eq, idpath.
      - apply homset_property.
    Defined.

  End TypeCat_Disp_is_univalent.

  Section TypeCat_Disp_Cleaving.

    Context {C : category}.

    (* NOTE: copied with slight modifications from https://github.com/UniMath/TypeTheory/blob/ad54ca1dad822e9c71acf35c27d0a39983269462/TypeTheory/Displayed_Cats/DisplayedCatFromCwDM.v#L114-L143 *)
    Definition pullback_is_cartesian
               (TC : typecat_obj_ext_structure C)
               {Γ Γ' : C} {f : Γ' --> Γ}
               {A : typecat_disp TC Γ} {A' : typecat_disp TC Γ'} (ff : A' -->[f] A)
      : (isPullback (pr2 ff)) -> is_cartesian ff.
    Proof.
      intros Hpb Δ g B hh.
      eapply iscontrweqf.
      2: {
        use Hpb.
        + exact (obj_ext_typecat Δ B).
        + exact (pr1 hh).
        + simpl in B. refine (π B ;; g).
        + etrans. apply (pr2 hh). apply assoc.
      }
      eapply weqcomp.
      2: apply weqtotal2asstol.
      apply weq_subtypes_iff.
      - intro. apply isapropdirprod; apply homset_property.
      - intro. apply (isofhleveltotal2 1).
        + apply homset_property.
        + intros. apply homsets_disp.
      - intros gg; split; intros H.
        + exists (pr2 H).
          apply subtypePath.
          intro; apply homset_property.
          exact (pr1 H).
        + split.
          * exact (maponpaths pr1 (pr2 H)).
          * exact (pr1 H).
    Defined.

    Lemma cleaving_typecat_disp
          (TC : typecat_structure C)
      : cleaving (typecat_disp TC).
    Proof.
      intros Γ Γ' f A.
      unfold cartesian_lift.
      exists (reind_typecat A f).
      use tpair.
      + use tpair.
        * use q_typecat.
        * apply dpr_q_typecat.
      + apply pullback_is_cartesian.
        eapply @is_symmetric_isPullback, reind_pb_typecat.
    Defined.
  End TypeCat_Disp_Cleaving.

End TypeCat_Disp.

Section TypeCat_Disp_Functor.

  Context {C : category}.

  Definition typecat_disp_functor_data
             (TC : typecat_obj_ext_structure C)
    : disp_functor_data
        (functor_identity C)
        (typecat_disp TC) (disp_codomain C).
  Proof.
    use tpair.
    - intros Γ A. exists (obj_ext_typecat Γ A). apply dpr_typecat_obj_ext.
    - intros Γ' Γ A' A f ff. apply ff.
  Defined.

  Definition typecat_disp_functor_axioms
             (TC : typecat_obj_ext_structure C)
    : disp_functor_axioms (typecat_disp_functor_data TC).
  Proof.
    use make_dirprod.
    - intros Γ A. cbn.
      apply maponpaths.
      apply homset_property.
    - intros Γ Δ Γ' A B A' f g ff gg.
      apply maponpaths.
      use total2_paths_f.
      + apply idpath.
      + apply homset_property.
  Defined.

  Definition typecat_disp_functor
             (TC : typecat_obj_ext_structure C)
    : disp_functor (functor_identity C) (typecat_disp TC) (disp_codomain C)
    := (typecat_disp_functor_data TC ,, typecat_disp_functor_axioms TC).

  Definition typecat_disp_functor_ff
             (TC : typecat_obj_ext_structure C)
    : disp_functor_ff (typecat_disp_functor TC).
  Proof.
    unfold disp_functor_ff.
    intros Γ Γ' A A' f.
    use isweq_iso.
    - apply idfun.
    - intros ff.
      use total2_paths_f.
      + apply idpath.
      + apply homset_property.
    - intros ff.
      use total2_paths_f.
      + apply idpath.
      + apply homset_property.
  Defined.

  Section TypeCat_Disp_Functor_is_cartesian.

    Definition typecat_disp_functor_is_cartesian
               (TC : typecat_structure C)
    : is_cartesian_disp_functor (typecat_disp_functor TC).
    Proof.
      use cartesian_functor_from_cleaving.
      { apply (cleaving_typecat_disp TC). }
      intros Γ Γ' f A.
      intros Δ g k hh.
      use iscontrweqf.
      3: {
        use (reind_pb_typecat A f (pr1 k)).
        - apply (pr2 k ;; g).
        - apply (pr1 hh).
        - etrans. apply assoc'. apply (! pr2 hh).
      }

      eapply weqcomp.
      2: apply weqtotal2asstol.
      apply weq_subtypes_iff.
      - intro. apply isapropdirprod; apply homset_property.
      - intro. apply (isofhleveltotal2 1).
        + apply homset_property.
        + intros. apply homsets_disp.
      - intros gg; split; intros H.
        + exists (pr1 H).
          apply subtypePath.
          intro; apply homset_property.
          exact (pr2 H).
        + split.
          * exact (pr1 H).
          * exact (maponpaths pr1 (pr2 H)).
    Defined.

  End TypeCat_Disp_Functor_is_cartesian.

End TypeCat_Disp_Functor.

Section ComprehensionCat_TypeCat.
  Context {C : category}.
  Context (CC : comprehension_cat_structure C).

  Let D := pr1 CC : disp_cat C.
  Let cleaving_D   := pr1 (pr2 CC) : cleaving D.
  Let comprehension_functor
    := pr1 (pr2 (pr2 CC))
       : disp_functor _ D (disp_codomain C).
  Let comprehension_functor_is_cartesian
    := pr2 (pr2 (pr2 CC))
       : is_cartesian_disp_functor comprehension_functor.

  Definition ty_from_comprehension_cat : C → UU
    := ob_disp D.

  Definition ext_from_comprehension_cat
             (Γ : C) (A : ty_from_comprehension_cat Γ)
    : C
    := pr1 (comprehension_functor Γ A).

  Definition reind_from_comprehension_cat
             (Γ : C) (A : ty_from_comprehension_cat Γ)
             (Γ' : C) (f : Γ' --> Γ)
    : ty_from_comprehension_cat Γ'
    := pr1 (cleaving_D Γ Γ' f A).

  Definition typecat1_from_comprehension_cat
    : typecat_structure1 C.
  Proof.
    repeat use tpair.
    - exact ty_from_comprehension_cat.
    - exact ext_from_comprehension_cat.
    - exact reind_from_comprehension_cat.
  Defined.

  Definition dpr_from_comprehension_cat
             (Γ : C) (A : ty_from_comprehension_cat Γ)
    : ext_from_comprehension_cat Γ A --> Γ
    := pr2 (comprehension_functor Γ A).

  Definition typecat_obj_ext_structure_from_comprehension_cat
    : typecat_obj_ext_structure C.
  Proof.
    repeat use tpair.
    - exact ty_from_comprehension_cat.
    - exact ext_from_comprehension_cat.
    - exact dpr_from_comprehension_cat.
  Defined.

  Definition q_square_from_comprehension_cat
             (Γ : C) (A : ty_from_comprehension_cat Γ)
             (Γ' : C) (f : Γ' --> Γ)
    : comprehension_functor Γ' (reind_from_comprehension_cat _ A _ f)
                            -->[ f ] comprehension_functor Γ A
    := disp_functor_on_morphisms comprehension_functor
                                 (pr1 (pr2 (cleaving_D Γ Γ' f A))).

  Definition q_square_from_comprehension_cat_is_cartesian
             (Γ : C) (A : ty_from_comprehension_cat Γ)
             (Γ' : C) (f : Γ' --> Γ)
    : is_cartesian (q_square_from_comprehension_cat _ A _ f).
  Proof.
    apply comprehension_functor_is_cartesian.
    apply cartesian_lift_is_cartesian.
  Defined.

  Definition q_from_comprehension_cat
             (Γ : C) (A : ty_from_comprehension_cat Γ)
             (Γ' : C) (f : Γ' --> Γ)
    : ext_from_comprehension_cat
        Γ' (reind_from_comprehension_cat Γ A Γ' f)
        --> ext_from_comprehension_cat Γ A
    := pr1 (q_square_from_comprehension_cat _ A _ f).

  Definition dpr_q_from_comprehension_cat
             (Γ : C) (A : ty_from_comprehension_cat Γ)
             (Γ' : C) (f : Γ' --> Γ)
    : q_from_comprehension_cat _ A _ f ;; dpr_from_comprehension_cat _ A
      = dpr_from_comprehension_cat _ (reind_from_comprehension_cat _ A _ f) ;; f
    := pr2 (q_square_from_comprehension_cat _ A _ f).

  Definition pullback_from_comprehension_cat
             (Γ : C) (A : ty_from_comprehension_cat Γ)
             (Γ' : C) (f : Γ' --> Γ)
    : isPullback (!dpr_q_from_comprehension_cat _ A _ f).
  Proof.
    intros Δ g k H.
    eapply iscontrweqf.
    2: {
      use (q_square_from_comprehension_cat_is_cartesian _ A _ f).
      - exact Γ'.
      - exact (identity _).
      - apply (Δ,, g).
      - use tpair.
        + apply k.
        + etrans. apply pathsinv0, H.
          apply pathsinv0, maponpaths, id_left.
    }
    apply invweq.
    eapply weqcomp.
    2: apply weqtotal2asstol.
    apply weq_subtypes_iff.
    - intro. apply isapropdirprod; apply homset_property.
    - intro. apply (isofhleveltotal2 1).
      + apply homset_property.
      + intros. apply homsets_disp.
    - intros gg; split; intros H'.
      + use tpair.
        * etrans. apply (pr1 H').
          apply pathsinv0, id_right.
        * apply subtypePath.
          intro; apply homset_property.
          exact (pr2 H').
      + split.
        * etrans. apply (pr1 H'). apply id_right.
        * etrans. apply (maponpaths pr1 (pr2 H')). apply idpath.
  Defined.

  Definition typecat_structure_from_comprehension_cat
    : typecat_structure C.
  Proof.
    exists typecat1_from_comprehension_cat.
    repeat use tpair.
    - exact dpr_from_comprehension_cat.
    - exact q_from_comprehension_cat.
    - exact dpr_q_from_comprehension_cat.
    - exact pullback_from_comprehension_cat.
  Defined.

End ComprehensionCat_TypeCat.

Section TypeCat_ComprehensionCat.

  Definition typecat_to_comprehension_cat_structure
             {C : category}
  : typecat_structure C → comprehension_cat_structure C.
  Proof.
    intros TC.
    exists (typecat_disp TC).
    exists (cleaving_typecat_disp _).
    exists (typecat_disp_functor _).
    apply typecat_disp_functor_is_cartesian.
  Defined.

  Definition typecat_to_comprehension_cat
    : typecat → comprehension_cat.
  Proof.
    intros TC.
    exists (pr1 TC).
    apply (typecat_to_comprehension_cat_structure (pr2 TC)).
  Defined.

  Definition typecat_from_comprehension_cat
    : comprehension_cat → typecat.
  Proof.
    intros CC.
    exists (pr1 CC).
    apply (typecat_structure_from_comprehension_cat (pr2 CC)).
  Defined.

  Definition fully_faithful_comprehension_cat_structure
             {C : category} (CC : comprehension_cat_structure C)
    := disp_functor_ff (pr1 (pr2 (pr2 CC))).

  Definition typecat_obj_ext_structure_disp_ff_functor_to_codomain_weq
             (C : category)
    : typecat_obj_ext_structure C ≃ ff_disp_functor (disp_codomain C).
  Proof.
    use weq_iso.
    - intros tc.
      exists (pr1 tc).
      intros Γ A.
      exists (obj_ext_typecat Γ A).
      apply (pr2 tc).
    - intros F.
      exists (pr1 F).
      use tpair.
      + intros Γ A.
        exact (pr1 (pr2 F Γ A)).
      + intros Γ A.
        exact (pr2 (pr2 F Γ A)).
    - intros ?. apply idpath.
    - intros ?. apply idpath.
  Defined.

End TypeCat_ComprehensionCat.


Require Import ListAux.
Lemma batchedq1consistent_ListCons0 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_0 u_0))/\(list_member  il_1 u_0)) -> (list_head  il_1 u_0)).
Proof. solve_push. Qed.

Lemma batchedq1consistent_ListCons1 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_0))) -> (not (u_0 = i_0))).
Proof. solve_push. Qed.

Lemma batchedq1consistent_ListCons2 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_0))) -> (not (list_head  il_1 u_0))).
Proof. solve_push. Qed.

Lemma batchedq1consistent_ListCons3 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_0))) -> (not (list_member  il_0 u_0))).
Proof. solve_push. Qed.


Require Import Syntax.
Require Import SemanticsStatic.
Require Import SemanticsDynamic.
Require Import ProofReactiveSystem.

Definition config_complete program :=
  forall P0 P1,
  ((peer_ties program) (P0, P1) = Single ->
   length (peer_instances_of_type program P1) = 1) /\
  ((peer_ties program) (P0, P1) = Optional ->
   length (peer_instances_of_type program P1) <= 1).

Lemma some_phi: forall program t T P0 P1,
  config_complete program ->
  peers_tied program P0 P1 ->
  exists t', Phi (peer_ties program) P0 P1 (peer_instances_of_type program P1) t T = Some t'.
Proof.
intros until P1.
intros H_complete H_tied.
destruct program as [ ties peers ].
unfold peers_tied in H_tied.
destruct H_tied as [ H_P0_tied H_P1_tied ].
simpl in H_P0_tied.
clear H_P1_tied.
unfold config_complete, peer_ties in H_complete.
destruct (ties (P0, P1)) eqn: H_tie.
- clear H_complete.
  induction (peer_instances_of_type (Program ties peers) P1) as [| p peers' IH_peers ].
  + simpl.
    rewrite H_tie.
    esplit.
    reflexivity.
  + simpl.
    rewrite H_tie.
    destruct IH_peers.
    simpl in H.
    rewrite H.
    esplit.
    reflexivity.
- apply H_complete in H_tie as H_peers_length.
  destruct (peer_instances_of_type (Program ties peers) P1) as [| p peers' ].
  + simpl.
    rewrite H_tie.
    esplit.
    reflexivity.
  + destruct peers'.
    * simpl.
      rewrite H_tie.
      esplit.
      reflexivity.
    * simpl in H_peers_length.
      apply le_S_n in H_peers_length.
      inversion H_peers_length.
- apply H_complete in H_tie as H_peers_length.
  destruct (peer_instances_of_type (Program ties peers) P1) as [| p peers' ].
  + inversion H_peers_length.
  + destruct peers'.
    * simpl.
      rewrite H_tie.
      esplit.
      reflexivity.
    * simpl in H_peers_length.
      congruence.
- congruence.
Qed.

Theorem progress_t: forall t T theta program Psi P rho,
  config_complete program ->
  program :: Psi; emptyPlaceEnv; emptyVarEnv; P |- t : T ->
  program :: Psi; emptyPlaceEnv; emptyVarEnv |- rho ->
  value_t t \/ exists t' theta' rho', program :: theta : P |> t; rho == theta' ==> t'; rho'.
Proof.
intros until rho.
intros H_complete H_typing H_reactive_typing.
remember emptyPlaceEnv as Delta.
remember emptyVarEnv as Gamma.
generalize dependent theta.
induction H_typing; intros; subst.
- destruct H.
  + unfold emptyVarEnv, idEmpty, Maps.p_empty in H.
    congruence.
  + destruct H.
    unfold emptyPlaceEnv, idEmpty, Maps.p_empty in H0.
    congruence.
- edestruct IHH_typing1; try assumption || reflexivity.
  + edestruct IHH_typing2; try assumption || reflexivity.
    * { inversion H; subst; inversion H_typing1; subst.
        - right. repeat esplit.
          apply E_App. assumption.
        - destruct H8; congruence.
      }
    * destruct H0 as [ t2' ], H0 as [ theta' ], H0 as [ rho' ].
      right. repeat esplit.
      apply EC_App_Right; eassumption.
  + destruct H as [ t1' ], H as [ theta' ], H as [ rho' ].
    right. repeat esplit.
    apply EC_App_Left. eassumption.
- left. apply v_lambda.
- edestruct IHH_typing1; try assumption || reflexivity.
  + edestruct IHH_typing2; try assumption || reflexivity.
    * left. apply v_cons; assumption.
    * destruct H0 as [ t1' ], H0 as [ theta' ], H0 as [ rho' ].
      right. repeat esplit.
      apply EC_Cons_Right; eassumption.
  + destruct H as [ t0' ], H as [ theta' ], H as [ rho' ].
    right. repeat esplit.
    apply EC_Cons_Left. eassumption.
- left. apply v_nil.
- edestruct IHH_typing; try assumption || reflexivity.
  + left. apply v_some. assumption.
  + destruct H as [ t' ], H as [ theta' ], H as [ rho' ].
    right. repeat esplit.
    apply EC_Some. eassumption.
- left. apply v_none.
- left. apply v_unit.
- left. apply v_peerApp.
- edestruct IHH_typing; try assumption || reflexivity.
  + pose proof some_phi.
    eapply H3 in H0; try assumption.
    destruct H0 as [ t' ].
    right. repeat esplit.
    eapply E_AsLocal; eassumption.
  + destruct H2 as [ t' ], H2 as [ theta' ], H2 as [ rho' ].
    right. repeat esplit.
    apply E_Remote. eassumption.
- edestruct IHH_typing2; try assumption || reflexivity.
  + inversion H1; subst; inversion H_typing2; subst.
    * { edestruct IHH_typing1; try assumption || reflexivity.
        - right. repeat esplit.
          apply E_AsLocalFrom; assumption || reflexivity.
        - destruct H2 as [ t0' ], H2 as [ theta' ], H2 as [ rho' ].
          right. repeat esplit.
          apply E_RemoteFrom. eassumption.
      }
    * destruct H9; congruence.
  + destruct H1 as [ t1' ], H1 as [ theta' ], H1 as [ rho' ].
    right. repeat esplit.
    apply EC_AsLocalFrom. eassumption.
- edestruct IHH_typing1; try assumption || reflexivity.
  + right. repeat esplit.
    apply E_Comp; assumption || reflexivity.
  + destruct H3 as [ t0' ], H3 as [ theta' ], H3 as [ rho' ].
    right. repeat esplit.
    apply EC_Comp. eassumption.
- edestruct IHH_typing3; try assumption || reflexivity.
  + inversion H2; subst; inversion H_typing3; subst.
    * { edestruct IHH_typing1; try assumption || reflexivity.
        - right. repeat esplit.
          apply E_CompFrom; assumption || reflexivity.
        - destruct H3 as [ t0' ], H3 as [ theta' ], H3 as [ rho' ].
          right. repeat esplit.
          apply EC_CompFrom_Left; eassumption.
      }
    * destruct H10; congruence.
  + destruct H2 as [ t2' ], H2 as [ theta' ], H2 as [ rho' ].
    right. repeat esplit.
    apply EC_CompFrom_Right. eassumption.
- left. apply v_reactApp.
- right. repeat esplit.
  eapply E_Signal.
  reflexivity.
- edestruct IHH_typing; try assumption || reflexivity.
  + right. repeat esplit.
    apply E_ReactiveVar; assumption || reflexivity.
  + destruct H as [ t' ], H as [ theta' ], H as [ rho' ].
    right. repeat esplit.
    eapply EC_Var. eassumption.
- edestruct IHH_typing; try assumption || reflexivity.
  + inversion H0; subst; inversion H_typing; subst;
      try solve [ destruct H; congruence ].
    unfold reactive_system_well_typed in H_reactive_typing.
    destruct H_reactive_typing as [ H1 H3 ].
    specialize H3 with r.
    assert (reactive_type r Psi <> Datatypes.None).
    * congruence.
    * apply reactive_env_type_domain in H4.
      rewrite <- H1 in H4.
      apply H3 in H4.
      destruct H4 as [ t' ], H4 as [ T' ], H4 as [ T'' ], H4 as [ P' ], H4.
      right. repeat esplit.
      eapply E_Now. eassumption.
  + destruct H0 as [ t' ], H0 as [ theta' ], H0 as [ rho' ].
    right. repeat esplit.
    eapply EC_Now. eassumption.
- edestruct IHH_typing1; try assumption || reflexivity.
  + edestruct IHH_typing2; try assumption || reflexivity.
    * inversion H; subst; inversion H_typing1; subst.
      right. repeat esplit.
      eapply E_Set; assumption || reflexivity.
    * destruct H0 as [ t2' ], H0 as [ theta' ], H0 as [ rho' ].
      right. repeat esplit.
      apply EC_Set_Right; eassumption.
  + destruct H as [ t1' ], H as [ theta' ], H as [ rho' ].
    right. repeat esplit.
    apply EC_Set_Left. eassumption.
- left. apply v_tnat.
Qed.

Theorem progress_s: forall s program Psi rho,
  config_complete program ->
  program :: Psi; emptyPlaceEnv |- s ->
  program :: Psi; emptyPlaceEnv; emptyVarEnv |- rho ->
  value_s s \/ exists s' theta rho', program :: s; rho == theta ==> s'; rho'.
Proof.
intros until rho.
intros H_complete H_typing H_reactive_typing.
remember emptyPlaceEnv as Delta.
destruct H_typing; intros; subst.
- left. apply v_pUnit.
- eapply progress_t in H_complete; try eassumption.
  destruct H_complete.
  + right. repeat esplit.
    apply E_Placed_Val.
    assumption.
  + destruct H0 as [ t' ], H0 as [ theta' ], H0 as [ rho' ].
    right. repeat esplit.
    eapply E_Placed.
    eassumption.
Qed.


From iris.heap_lang Require Export proofmode notation.

(* make these print *)
Notation NONE := (InjL (LitV LitUnit)).
Notation NONEV := (InjLV (LitV LitUnit)).
Notation SOME x := (InjR x).
Notation SOMEV x := (InjRV x).

Export Set Default Goal Selector "!".
Export Set Default Proof Using "Type".

Section proof.
Context `{!heapGS Σ}.

Lemma wp_frame (e: expr) (Φ Φ': val → iProp Σ) :
  WP e {{Φ}} ∗ (∀ r, Φ r -∗ Φ' r) ⊢ WP e {{Φ'}}.
Proof.
  iIntros "[Hwp Himpl]".
  iApply (wp_strong_mono with "Hwp [Himpl]").
  - auto.
  - auto.
  - iIntros (v) "HΦ !>".
    iApply "Himpl"; auto.
Qed.

Lemma wp_store_axiom (l: loc) (v0 v: val) :
  l ↦ v0 ⊢ WP (#l <- v) {{ λ _, l ↦ v }}.
Proof. iIntros "Hl". wp_store. auto. Qed.

Lemma wp_load_axiom (l: loc) (v: val) :
  l ↦ v ⊢ WP ! #l {{ λ r, ⌜r = v⌝ ∗ l ↦ v }}.
Proof. iIntros "Hl". wp_load. auto. Qed.

Lemma wp_free_axiom (l: loc) (v: val) :
  l ↦ v ⊢ WP Free #l {{ λ _, emp }}.
Proof. iIntros "Hl". wp_free. auto. Qed.

End proof.


Require Import POCS.

Record State :=
  mkState {
    stateDisk : disk;
    stateBadBlock : addr;
  }.

Definition read_spec a : Specification _ block unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' =>
      state' = state /\
      (a <> stateBadBlock state -> diskGet (stateDisk state) a ?|= eq r);
    recovered := fun _ state' => state' = state
  |}.

Definition write_spec a v : Specification _ _ unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' =>
      r = tt /\ state' = mkState (diskUpd (stateDisk state) a v) (stateBadBlock state);
    recovered := fun _ state' =>
      state' = state \/
      state' = mkState (diskUpd (stateDisk state) a v) (stateBadBlock state)
  |}.

Definition getBadBlock_spec : Specification _ addr unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' =>
      state' = state /\ r = stateBadBlock state;
    recovered := fun _ state' => state' = state
  |}.

Definition size_spec : Specification _ nat unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' =>
      state' = state /\ r = diskSize (stateDisk state);
    recovered := fun _ state' => state' = state
  |}.

Module Type BadBlockAPI.

  Axiom init : proc InitResult.
  Axiom read : addr -> proc block.
  Axiom write : addr -> block -> proc unit.
  Axiom getBadBlock : proc addr.
  Axiom size : proc nat.
  Axiom recover : proc unit.

  Axiom abstr : Abstraction State.

  Axiom init_ok : init_abstraction init recover abstr inited_any.
  Axiom read_ok : forall a, proc_spec (read_spec a) (read a) recover abstr.
  Axiom write_ok : forall a v, proc_spec (write_spec a v) (write a v) recover abstr.
  Axiom getBadBlock_ok : proc_spec getBadBlock_spec getBadBlock recover abstr.
  Axiom size_ok : proc_spec size_spec size recover abstr.
  Axiom recover_noop : rec_noop recover abstr no_wipe.

  Hint Resolve init_ok.
  Hint Resolve read_ok.
  Hint Resolve write_ok.
  Hint Resolve getBadBlock_ok.
  Hint Resolve size_ok.
  Hint Resolve recover_noop.

End BadBlockAPI.


(* This is a rewrite of the Ltac parts of standard library nsatz. We should
  periodically check whether we still need it -- once enough bugs get fixed
  in mailine, we hope to drop this implementation *)

Require Coq.nsatz.NsatzTactic.
Require Import Coq.Lists.List.

(** For compat with https://github.com/coq/coq/pull/12073 *)
Module Nsatz.
  Import Coq.nsatz.NsatzTactic.
  Notation check_correct := check_correct.
  Notation PEevalR := PEevalR.
  Notation psos_r1 := psos_r1.
  Notation psos_r1b := psos_r1b.
End Nsatz.

Generalizable All Variables.
Lemma cring_sub_diag_iff {R zero eq sub} `{cring:Cring.Cring (R:=R) (ring0:=zero) (ring_eq:=eq) (sub:=sub)}
  : forall x y, eq (sub x y) zero <-> eq x y.
Proof.
  split;intros Hx.
  { eapply Nsatz.psos_r1b. eapply Hx. }
  { eapply Nsatz.psos_r1. eapply Hx. }
Qed.

Ltac get_goal := lazymatch goal with |- ?g => g end.

Ltac nsatz_equation_implications_to_list eq zero g :=
  lazymatch g with
  | eq ?p zero => constr:(p::nil)
  | eq ?p zero -> ?g => let l := nsatz_equation_implications_to_list eq zero g in constr:(p::l)
  end.

Ltac nsatz_reify_equations eq zero :=
  let g := get_goal in
  let lb := nsatz_equation_implications_to_list eq zero g in
  lazymatch (eval red in (Ncring_tac.list_reifyl (lterm:=lb))) with
    (?variables, ?le) =>
    lazymatch (eval compute in (List.rev le)) with
    | ?reified_goal::?reified_givens => constr:((variables, reified_givens, reified_goal))
    end
  end.

Ltac nsatz_get_free_variables reified_package :=
  lazymatch reified_package with (?fv, _, _) => fv end.

Ltac nsatz_get_reified_givens reified_package :=
  lazymatch reified_package with (_, ?givens, _) => givens end.

Ltac nsatz_get_reified_goal reified_package :=
  lazymatch reified_package with (_, _, ?goal) => goal end.

Require Import Coq.setoid_ring.Ring_polynom.
(* Kludge for 8.4/8.5 compatibility *)
Module Import mynsatz_compute.
  Import Coq.nsatz.NsatzTactic.
  Global Ltac mynsatz_compute x := nsatz_compute x.
End mynsatz_compute.
Ltac nsatz_compute x := mynsatz_compute x.

Ltac nsatz_compute_to_goal sugar nparams reified_goal power reified_givens :=
  nsatz_compute (PEc sugar :: PEc nparams :: PEpow reified_goal power :: reified_givens).

Ltac nsatz_compute_get_leading_coefficient :=
  lazymatch goal with
    |- Logic.eq ((?a :: _ :: ?b) :: ?c) _ -> _ => a
  end.

Ltac nsatz_compute_get_certificate :=
  lazymatch goal with
    |- Logic.eq ((?a :: _ :: ?b) :: ?c) _ -> _ => constr:((c,b))
  end.

Ltac nsatz_rewrite_and_revert domain :=
  lazymatch type of domain with
  | @Integral_domain.Integral_domain ?F ?zero _ _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
    lazymatch goal with
    | |- eq _ zero => idtac
    | |- eq _ _ => rewrite <-(cring_sub_diag_iff (cring:=FCring))
    end;
    repeat match goal with
           | [H : eq _ zero |- _ ] => revert H
           | [H : eq _ _ |- _ ] => rewrite <-(cring_sub_diag_iff (cring:=FCring)) in H; revert H
           end
  end.

(** As per https://coq.inria.fr/bugs/show_bug.cgi?id=4851, [nsatz]
    cannot handle duplicate hypotheses.  So we clear them. *)
Ltac nsatz_clear_duplicates_for_bug_4851 domain :=
  lazymatch type of domain with
  | @Integral_domain.Integral_domain _ _ _ _ _ _ _ ?eq _ _ _ =>
    repeat match goal with
           | [ H : eq ?x ?y, H' : eq ?x ?y |- _ ] => clear H'
           end
  end.

Ltac nsatz_nonzero :=
  try solve [apply Integral_domain.integral_domain_one_zero
            |apply Integral_domain.integral_domain_minus_one_zero
            |trivial
            |assumption].

Ltac nsatz_domain_sugar_power domain sugar power :=
  let nparams := constr:(BinInt.Zneg BinPos.xH) in (* some symbols can be "parameters", treated as coefficients *)
  lazymatch type of domain with
  | @Integral_domain.Integral_domain ?F ?zero _ _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
    nsatz_clear_duplicates_for_bug_4851 domain;
    nsatz_rewrite_and_revert domain;
    let reified_package := nsatz_reify_equations eq zero in
    let fv := nsatz_get_free_variables reified_package in
    let interp := constr:(@Nsatz.PEevalR _ _ _ _ _ _ _ _ Fops fv) in
    let reified_givens := nsatz_get_reified_givens reified_package in
    let reified_goal := nsatz_get_reified_goal reified_package in
    nsatz_compute_to_goal sugar nparams reified_goal power reified_givens;
    let a := nsatz_compute_get_leading_coefficient in
    let crt := nsatz_compute_get_certificate in
    intros _ (* discard [nsatz_compute] output *); intros;
    apply (fun Haa refl cond => @Integral_domain.Rintegral_domain_pow _ _ _ _ _ _ _ _ _ _ _ domain (interp a) _ (BinNat.N.to_nat power) Haa (@Nsatz.check_correct _ _ _ _ _ _ _ _ _ _ FCring fv reified_givens (PEmul a (PEpow reified_goal power)) crt refl cond));
    [ nsatz_nonzero; cbv iota beta delta [Nsatz.PEevalR PEeval InitialRing.gen_phiZ InitialRing.gen_phiPOS]
    | solve [vm_cast_no_check (eq_refl true)] (* if this fails, the prover returned a bad certificate *)
    | solve [repeat (split; [assumption|]); exact I] ]
  end.

Ltac nsatz_guess_domain :=
  match goal with
  | |- ?eq _ _ => constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  | |- not (?eq _ _) =>  constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  | [H: ?eq _ _ |- _ ] =>  constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  | [H: not (?eq _ _) |- _] =>  constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  end.

Ltac nsatz_sugar_power sugar power :=
  let domain := nsatz_guess_domain in
  nsatz_domain_sugar_power domain sugar power.

Ltac nsatz_power power :=
  let power_N := (eval compute in (BinNat.N.of_nat power)) in
  nsatz_sugar_power BinInt.Z0 power_N.

Ltac nsatz := nsatz_power 1%nat.

Tactic Notation "nsatz" := nsatz.
Tactic Notation "nsatz" constr(n) := nsatz_power n.

(** If the goal is of the form [?x <> ?y] and assuming [?x = ?y]
    contradicts any hypothesis of the form [?x' <> ?y'], we turn this
    problem about inequalities into one about equalities and give it
    to [nsatz]. *)
Ltac nsatz_contradict_single_hypothesis domain :=
  lazymatch type of domain with
  | @Integral_domain.Integral_domain _ ?zero ?one _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
    unfold not in *;
    match goal with
    | [ H : eq _ _ -> False |- eq _ _ -> False ]
      => intro; apply H; nsatz
    | [ H : eq _ _ -> False |- False ]
      => apply H; nsatz
    end
  end.

Ltac nsatz_contradict :=
  let domain := nsatz_guess_domain in
  nsatz_contradict_single_hypothesis domain
  || (unfold not;
      intros;
      lazymatch type of domain with
      | @Integral_domain.Integral_domain _ ?zero ?one _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
        assert (eq one zero) as Hbad;
        [nsatz; nsatz_nonzero
        |destruct (Integral_domain.integral_domain_one_zero (Integral_domain:=domain) Hbad)]
      end).


(* -*- mode: coq; mode: visual-line -*- *)
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 :
    forall (Q : O_reflector O' T -> Type@{i}) {Q_inO : forall 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 : forall oa, In O (B oa)}
           (f : forall 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 : forall oa, In O (B oa)}
           (f : forall 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' : forall (B : O_reflector O' A -> Type@{i})
                             (B_inO : forall oa, In O (B oa))
                             (f : forall a, B (to O' A a))
                             oa, B oa)
           (OO_ind_beta' : forall (B : O_reflector O' A -> Type@{i})
                             (B_inO : forall oa, In O (B oa))
                             (f : forall a, B (to O' A a))
                             a, OO_ind' B B_inO f (to O' A a) = f a)
           (inO_paths' : forall (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.
    exists (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' : forall (B : O_reflector O' A -> Type)
                             (B_inO : forall oa, In O (B oa))
                             (f : forall a, B (to O' A a))
                             oa, B oa)
           (OO_ind_beta' : forall (B : O_reflector O' A -> Type)
                             (B_inO : forall oa, In O (B oa))
                             (f : forall 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) `{forall a, In O (B a)}
  : IsEquiv (fun (h : forall 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 : forall 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 A => A) 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 : forall (T : Type@{i}),
      PreReflects modality_subuniv T ;
  modality_reflectsD : forall (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.

(** 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 -> forall T : Type, IsHProp (In' T))
           (inO_equiv_inO' : forall T U : Type,
               In' T -> forall f : T -> U, IsEquiv f -> In' U)
           (O_reflector' : Type -> Type)
           (O_inO' : forall T, In' (O_reflector' T))
           (to' : forall T, T -> O_reflector' T)
           (O_ind' : forall (A : Type) (B : O_reflector' A -> Type)
                            (B_inO : forall oa, In' (B oa))
                            (f : forall a, B (to' A a))
                            (z : O_reflector' A),
               B z)
           (O_ind_beta' : forall (A : Type) (B : O_reflector' A -> Type)
                                 (B_inO : forall oa, In' (B oa))
                                 (f : forall a, B (to' A a)) (a : A),
               O_ind' A B B_inO f (to' A a) = f a)
           (inO_paths' : forall (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.

(** 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) `{forall a, In O (B a)}
  : IsEquiv (fun (h : forall oa, B oa) => h oD to O A).
Proof.
  srapply (isequiv_oD_to_O O O).
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} `{forall 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 z => O_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} `{forall 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 : forall 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 x => ap@{k i} pr1 (eqf x))).
  exists (fun z => transport B (eqid z) ((f' z).2)).
  intros a. unfold eqid.
  refine (_ @ pr2_path (O_rec_beta g' a)).
  refine (ap (fun p => transport 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 a => B 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 z => equiv_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 : forall (B: O_reflector O' A -> Type),
               (forall 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 : forall (A:Type) (B:A -> Type)
                       {A_inO : In O A} `{forall 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)
  := _.

(** ** 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.

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

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

  Local Definition O_ind_easy
             (A : Type) (B : O_reflector A -> Type)
             (B_inO : forall oa, In_easy (B oa))
    : (forall a, B (to A a)) -> forall 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 : forall oa, In_easy (B oa))
             (f : forall 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 x => to _ (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 a => to 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 b => to 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 b => to 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 w => O (hfiber (factor1 fact) w.1)) oE _).
    - intros w; exact (inclass1 fact w.1).
    - nrefine ((equiv_sigma_inO_O (fun w => hfiber (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 x => fact_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.


Require Import POCS.

Require Import TwoDiskAPI.
Require Import Common.OneDiskAPI.

(**
ReplicatedDisk provides a single-disk API on top of two disks, handling disk
failures with replication.

Your job will be to implement the core of the recovery procedure for the
replicated disk, and prove that the entire implementation is correct using your
recovery procedure. This lab is split into several parts. Unlike in previous
labs, the exercises do not proceed in order in the file; you'll first write
specifications and admit the correctness proof, and then you'll come back and
finish the proof.
*)

Module ReplicatedDisk (td : TwoDiskAPI) <: OneDiskAPI.

  (* EXERCISE (4a): implement read *)
  Definition read (a:addr) : proc block :=
    Ret block0.

  Definition write (a:addr) (b:block) : proc unit :=
    _ <- td.write d0 a b;
    _ <- td.write d1 a b;
    Ret tt.

  Definition size : proc nat :=
    msz <- td.size d0;
    match msz with
    | Working sz => Ret sz
    | Failed =>
      msz <- td.size d1;
      match msz with
      | Working sz => Ret sz
      | Failed => Ret 0
      end
    end.

  (** [sizeInit] computes the size during initialization; it may return None if
  the sizes of the underlying disks differ. *)
  Definition sizeInit : proc (option nat) :=
    sz1 <- td.size d0;
    sz2 <- td.size d1;
    match sz1 with
    | Working sz1 =>
      match sz2 with
      | Working sz2 =>
        if sz1 == sz2 then Ret (Some sz1) else Ret None
      | Failed => Ret (Some sz1)
      end
    | Failed =>
      match sz2 with
      | Working sz2 => Ret (Some sz2)
      | Failed => Ret None
      end
    end.

  (* Recursively initialize block a and below. For simplicity, we make the disks
  match by setting every block to [block0]. *)
  Fixpoint init_at (a:nat) : proc unit :=
    match a with
    | 0 => Ret tt
    | S a =>
      _ <- td.write d0 a block0;
      _ <- td.write d1 a block0;
      init_at a
    end.

  (* Initialize every disk block *)
  Definition init' : proc InitResult :=
    size <- sizeInit;
    match size with
    | Some sz =>
      _ <- init_at sz;
      Ret Initialized
    | None =>
      Ret InitFailed
    end.

  Definition init := then_init td.init init'.

  (**
   * Helper theorems and tactics for proofs.
   *)

  Theorem exists_tuple2 : forall A B (P: A * B -> Prop),
      (exists a b, P (a, b)) ->
      (exists p, P p).
  Proof.
    intros.
    repeat deex; eauto.
  Qed.

  Tactic Notation "eexist_tuple" ident(a) ident(b) :=
    match goal with
    | [ |- exists (_:?aT * ?bT), _ ] =>
      let a := fresh a in
      let b := fresh b in
      evar (a : aT);
      evar (b : bT);
      exists (a, b);
      subst a;
      subst b
    end.

  (* The [simplify] tactic performs a number of steps that should simplify and
  clean up your goals. *)
  Ltac simplify :=
    repeat match goal with
           | |- forall _, _ => intros
           | _ => deex
           | _ => destruct_tuple
           | [ u: unit |- _ ] => destruct u
           | |- _ /\ _ => split; [ solve [auto] | ]
           | |- _ /\ _ => split; [ | solve [auto] ]
           | |- exists (_: disk*(disk -> Prop)), _ => eexist_tuple d F
           | |- exists (_: disk*disk), _ => eexist_tuple d_0 d_1
           | |- exists (_: disk*_), _ => apply exists_tuple2
           | _ => progress simpl in *
           | _ => progress safe_intuition
           | _ => progress subst
           | _ => progress autorewrite with upd in *
           end.

  (* The [finish] tactic tries a number of techniques to solve the goal. *)
  Ltac finish :=
    repeat match goal with
           | _ => solve_false
           | _ => congruence
           | _ => solve [ intuition (subst; eauto; try congruence) ]
           | _ =>
             (* if we can solve all the side conditions automatically, then it's
             safe to run descend and create existential variables *)
             descend; (intuition eauto);
             lazymatch goal with
             | |- proc_spec _ _ _ _ => idtac
             | _ => fail
             end
           end.

  Ltac step :=
    step_proc; simplify; finish.

  (**
   * Specifications and proofs about our implementation of the replicated disk API,
   * without considering our recovery.
   *
   * These intermediate specifications separate reasoning about the
   * implementations from recovery behavior.
   *)

  Theorem both_disks_not_missing : forall (state: TwoDiskBaseAPI.State),
      disk0 state ?|= missing ->
      disk1 state ?|= missing ->
      False.
  Proof.
    destruct state; unfold missing; simpl; intuition auto.
  Qed.

  Hint Resolve both_disks_not_missing : false.

  Theorem missing0_implies_any : forall (state: TwoDiskBaseAPI.State) P,
      disk0 state ?|= missing ->
      disk0 state ?|= P.
  Proof.
    destruct state; unfold missing; simpl; intuition auto.
  Qed.

  Theorem missing1_implies_any : forall (state: TwoDiskBaseAPI.State) P,
      disk1 state ?|= missing ->
      disk1 state ?|= P.
  Proof.
    destruct state; unfold missing; simpl; intuition auto.
  Qed.

  Hint Resolve missing0_implies_any.
  Hint Resolve missing1_implies_any.

  (* EXERCISE (4a): prove this specification for read *)
  Theorem read_int_ok : forall a,
      proc_spec
        (fun d state =>
           {|
             pre := disk0 state ?|= eq d /\
                    disk1 state ?|= eq d;
             post :=
               fun r state' =>
                 diskGet d a ?|= eq r /\
                 disk0 state' ?|= eq d /\
                 disk1 state' ?|= eq d;
             recovered :=
               fun _ state' =>
                 disk0 state' ?|= eq d /\
                 disk1 state' ?|= eq d;
           |})
        (read a)
        td.recover
        td.abstr.
  Proof.
    unfold read.

    (* Hint: use step instead of step_proc to take advantage of the new
    automation in this lab. *)

    step.
  Admitted.

  Hint Resolve read_int_ok.

  (* EXERCISE (4a): complete and prove this specification for write *)
  Theorem write_int_ok : forall a b,
      proc_spec
        (fun d state =>
           {|
             pre :=
               disk0 state ?|= eq d /\
               disk1 state ?|= eq d;
             post :=
               fun r state' =>
                 r = tt /\
                 disk0 state' ?|= eq (diskUpd d a b) /\
                 disk1 state' ?|= eq (diskUpd d a b);
             recovered :=
               fun _ state' =>
                 (* EXERCISE (4a): write the recovered condition for write. Note
                 that this is the two-disk API's recovery, not the replicated
                 disk's recovery, so it should cover all the crash cases for
                 write *)
             True;
           |})
        (write a b)
        td.recover
        td.abstr.
  Proof.
    unfold write.

  Admitted.

  Hint Resolve write_int_ok.

  (* EXERCISE (4a): prove this specification for size *)
  Theorem size_int_ok :
    proc_spec
      (fun '(d_0, d_1) state =>
         {|
           pre :=
             disk0 state ?|= eq d_0 /\
             disk1 state ?|= eq d_1 /\
             diskSize d_0 = diskSize d_1;
           post :=
             fun r state' =>
               r = diskSize d_0 /\
               r = diskSize d_1 /\
               disk0 state' ?|= eq d_0 /\
               disk1 state' ?|= eq d_1;
           recovered :=
             fun _ state' =>
               disk0 state' ?|= eq d_0 /\
               disk1 state' ?|= eq d_1;
         |})
      (size)
      td.recover
      td.abstr.
  Proof.
    unfold size.

  Admitted.

  Hint Resolve size_int_ok.

  (* We provide a proof for [init]. *)

  Definition equal_after a (d_0 d_1: disk) :=
    diskSize d_0 = diskSize d_1 /\
    forall a', a <= a' -> diskGet d_0 a' = diskGet d_1 a'.

  Theorem le_eq_or_S_le : forall n m,
      n <= m ->
      n = m \/
      S n <= m /\ n <> m.
  Proof.
    intros.
    omega.
  Qed.

  Theorem equal_after_diskUpd : forall a d_0 d_1 b,
      equal_after (S a) d_0 d_1 ->
      equal_after a (diskUpd d_0 a b) (diskUpd d_1 a b).
  Proof.
    unfold equal_after; intuition.
    autorewrite with upd; eauto.
    apply le_eq_or_S_le in H; intuition subst.
    destruct (lt_dec a' (diskSize d_0)); autorewrite with upd.
    assert (a' < diskSize d_1) by congruence; autorewrite with upd; auto.
    assert (~a' < diskSize d_1) by congruence; autorewrite with upd; auto.
    autorewrite with upd; eauto.
  Qed.

  Hint Resolve equal_after_diskUpd.

  Theorem init_at_ok : forall a,
      proc_spec
        (fun '(d_0, d_1) state =>
           {| pre :=
                disk0 state ?|= eq d_0 /\
                disk1 state ?|= eq d_1 /\
                equal_after a d_0 d_1;
              post :=
                fun _ state' =>
                  exists d_0' d_1': disk,
                    disk0 state' ?|= eq d_0' /\
                    disk1 state' ?|= eq d_1' /\
                    equal_after 0 d_0' d_1';
              recovered :=
                fun _ state' => True;
           |})
        (init_at a)
        td.recover
        td.abstr.
  Proof.
    induction a; simpl; intros.
    - step.
    - step.

      step.
      destruct r; finish.
      + step.
        destruct r; simplify; finish.
      + step.
        destruct r; finish.
  Qed.

  Hint Resolve init_at_ok.

  Theorem sizeInit_ok :
      proc_spec
        (fun '(d_0, d_1) state =>
           {| pre :=
                disk0 state ?|= eq d_0 /\
                disk1 state ?|= eq d_1;
              post :=
                 fun r state' =>
                  exists d_0' d_1',
                    disk0 state' ?|= eq d_0' /\
                    disk1 state' ?|= eq d_1' /\
                    match r with
                    | Some sz => diskSize d_0' = sz /\ diskSize d_1' = sz
                    | None => True
                    end;
              recovered :=
                fun _ state' => True;
           |})
        (sizeInit)
        td.recover
        td.abstr.
  Proof.
    unfold sizeInit.
    step.
    destruct r.
    step.
    - destruct r.
      + destruct (diskSize d_0 == v).
        * step.
        * step.
      + step.
    - step.
      destruct r.
      + step.
      + step.
  Qed.

  Hint Resolve sizeInit_ok.

  Theorem equal_after_0_to_eq : forall d_0 d_1,
      equal_after 0 d_0 d_1 ->
      d_0 = d_1.
  Proof.
    unfold equal_after; intuition.
    eapply disk_ext_eq; intros.
    eapply H1; omega.
  Qed.

  Theorem equal_after_size : forall d_0 d_1,
      diskSize d_0 = diskSize d_1 ->
      equal_after (diskSize d_0) d_0 d_1.
  Proof.
    unfold equal_after; intuition.
    assert (~a' < diskSize d_0) by omega.
    assert (~a' < diskSize d_1) by congruence.
    autorewrite with upd; eauto.
  Qed.

  Hint Resolve equal_after_size.
  Hint Resolve equal_after_0_to_eq.

  Theorem init'_ok :
      proc_spec
        (fun '(d_0, d_1) state =>
           {| pre :=
                disk0 state ?|= eq d_0 /\
                disk1 state ?|= eq d_1;
              post :=
                fun r state' =>
                  match r with
                  | Initialized =>
                    exists d_0' d_1',
                    disk0 state' ?|= eq d_0' /\
                    disk1 state' ?|= eq d_1' /\
                    d_0' = d_1'
                  | InitFailed =>
                    True
                  end;
              recovered :=
                fun _ state' => True;
           |})
        (init')
        td.recover
        td.abstr.
  Proof.
    unfold init.
    step.
    descend; intuition eauto.
    destruct r; step.
    step.
  Qed.

  Hint Resolve init'_ok.

  (**
   * Recovery implementation.
   *
   * We provide the general structure for recovery: essentially, it consists of
   * a loop around [fixup] that terminates after either fixing an out-of-sync
   * disk block or when a disk has failed.
  *)

  (* [fixup] returns a [RecStatus] to implement early termination in [recovery_at]. *)
  Inductive RecStatus :=
  (* continue working, nothing interesting has happened *)
  | Continue
  (* some address has been repaired (or the recovery has exhausted the
     addresses) - only one address can be out of sync and thus only it must be
     recovered. *)
  (* OR, one of the disks has failed, so don't bother continuing recovery since
     the invariant is now trivially satisfied *)
  | RepairDoneOrFailed.

  (* EXERCISE (4c): implement [fixup], which should perform recovery for a
  single address and indicate whether to continue or not. *)
  Definition fixup (a:addr) : proc RecStatus :=
    Ret Continue.

  (* recursively performs recovery at [a-1], [a-2], down to 0 *)
  Fixpoint recover_at (a:addr) : proc unit :=
    match a with
    | 0 => Ret tt
    | S n =>
      s <- fixup n;
      match s with
      | Continue => recover_at n
      | RepairDoneOrFailed => Ret tt
      end
    end.

  Definition Recover : proc unit :=
    sz <- size;
    _ <- recover_at sz;
    Ret tt.

  (**
   * Theorems and recovery proofs.
   *)

  Theorem if_lt_dec : forall A n m (a a':A),
      n < m ->
      (if lt_dec n m then a else a') = a.
  Proof.
    intros.
    destruct (lt_dec n m); auto.
    contradiction.
  Qed.

  Theorem disks_eq_inbounds : forall (d: disk) a v v',
      a < diskSize d ->
      diskGet d a ?|= eq v ->
      diskGet d a ?|= eq v' ->
      v = v'.
  Proof.
    intros.
    case_eq (diskGet d a); intros.
    - rewrite H2 in *. simpl in *. congruence.
    - exfalso.
      eapply disk_inbounds_not_none; eauto.
  Qed.

  (* To make these specifications precise while also covering both the already
   * synced and diverged disks cases, we keep track of which input state we're
   * in from the input and use it to give an exact postcondition. *)
  Inductive DiskStatus :=
  | FullySynced
  | OutOfSync (a:addr) (b:block).

  Theorem diskUpd_maybe_same : forall (d:disk) a b,
      diskGet d a ?|= eq b ->
      diskUpd d a b = d.
  Proof.
    intros.
    destruct (diskGet d a) eqn:?; simpl in *; subst;
      autorewrite with upd;
      auto.
  Qed.

  Hint Rewrite diskUpd_maybe_same using (solve [ auto ]) : upd.
  Hint Resolve PeanoNat.Nat.lt_neq.
  Hint Resolve disks_eq_inbounds.

  (* EXERCISE (4c): write and admit a specification for [fixup]. *)
  Theorem fixup_ok : forall a,
      proc_spec
        (fun '(d, s) state =>
           {|
             pre :=
               a < diskSize d /\
               match s with
               | FullySynced => True
               | OutOfSync a' b => True
               end;
             post :=
               fun r state' =>
                 match s with
                 | FullySynced => True
                 | OutOfSync a' b => True
                 end;
             recovered :=
               fun _ state' =>
                 match s with
                 | FullySynced => True
                 | OutOfSync a' b => True
                 end;
           |})
        (fixup a)
        td.recover
        td.abstr.
  Proof.
    (* EXERCISE (4d): prove [fixup_ok] *)
  Admitted.

  Hint Resolve fixup_ok.

  Hint Resolve Lt.lt_n_Sm_le.

  (* EXERCISE (4c): specify and prove recover_at *)
  (* Hint: use [induction a] *)
  Theorem recover_at_ok : forall a,
      proc_spec
        (fun (_:unit) state =>
           {|
             pre := True;
             post :=
               fun r state' => True;
             recovered :=
               fun _ state' => True
           |})
        (recover_at a)
        td.recover
        td.abstr.
  Proof.
  Admitted.

  Hint Resolve recover_at_ok.

  (* EXERCISE (4b): write a spec for recovery *)
  Definition Recover_spec : Specification _ unit unit TwoDiskBaseAPI.State :=
    fun (_:unit) state =>
      {|
        pre := True;
        post := fun _ state' => True;
        recovered := fun _ state' => True;
      |}.

  (* EXERCISE (4c): prove recovery correct *)
  Theorem Recover_rok :
    proc_spec
      Recover_spec
      (Recover)
      td.recover
      td.abstr.
  Proof.
  Admitted.

  (* EXERCISE (4b): prove that your recovery specification is idempotent; that
  is, its recovered condition implies its precondition. *)
  Theorem Recover_spec_idempotent :
    idempotent Recover_spec.
  Proof.
    - unfold idempotent; intuition; simplify.
  Admitted.

  (* This proof combines your proof that recovery is correct and that its
  specification is idempotent to show recovery is correct even if re-run on
  every crash. *)
  Theorem Recover_ok :
    proc_loopspec
      Recover_spec
      (Recover)
      td.recover
      td.abstr.
  Proof.
    eapply idempotent_loopspec; simpl.
    - apply Recover_rok.
    - apply Recover_spec_idempotent.
  Qed.

  Hint Resolve Recover_ok.

  Definition recover: proc unit :=
    _ <- td.recover;
    Recover.

  (* As the final step in giving the correctness of the replicated disk
  operations, we prove recovery specs that include the replicated disk Recover
  function. *)

  Definition rd_abstraction (state: TwoDiskBaseAPI.State) (d:OneDiskAPI.State) : Prop :=
    disk0 state ?|= eq d /\
    disk1 state ?|= eq d.

  Definition abstr : Abstraction OneDiskAPI.State :=
    abstraction_compose td.abstr {| abstraction := rd_abstraction; |}.

  Theorem init_ok : init_abstraction init recover abstr inited_any.
  Proof.
    intros.
    eapply then_init_compose; eauto.
    eapply proc_spec_weaken; eauto.
    unfold spec_impl; intros.
    destruct state; simpl in *.

    - exists (d_0, d_1); simpl; intuition eauto.
      unfold rd_abstraction.
      destruct v; repeat deex; eauto.
    - exists (d_0, d_0); simpl; intuition eauto.
      unfold rd_abstraction.
      destruct v; repeat deex; eauto.
    - exists (d_1, d_1); simpl; intuition eauto.
      unfold rd_abstraction.
      destruct v; repeat deex; eauto.
  Qed.

  (* EXERCISE (4b): prove that read, write, and size are correct when combined
  with your recovery (using your specification but admitted proof). *)

  Theorem read_ok : forall a, proc_spec (read_spec a) (read a) recover abstr.
  Proof.
    intros.
    apply spec_abstraction_compose; simpl.
    eapply compose_recovery; eauto; simplify.
  Admitted.

  Theorem write_ok : forall a v, proc_spec (write_spec a v) (write a v) recover abstr.
  Proof.
    intros.
    apply spec_abstraction_compose; simpl.
    eapply compose_recovery; eauto; simplify.
  Admitted.

  Theorem size_ok : proc_spec size_spec size recover abstr.
  Proof.
    intros.
    apply spec_abstraction_compose; simpl.
    (* simplify is a bit too aggressive about existential variables here, so we
    provide some manual simplification here *)
    eapply compose_recovery; eauto.
    intros; apply exists_tuple2.
    destruct a; simpl in *.
  Admitted.

  (* This theorem shows that Ret does not modify the abstract state exposed by
  the replicated disk; the interesting part is that if recovery runs, then the
  only effect should be the wipe relation (the trivial relation [no_wipe] in
  this case) *)
  (* EXERCISE (4b): prove this theorem using your recovery spec *)
  Theorem recover_noop : rec_noop recover abstr no_wipe.
  Proof.
    eapply rec_noop_compose; eauto; simpl.
    autounfold; unfold rd_abstraction, Recover_spec; simplify.
  Admitted.

End ReplicatedDisk.