Require Import DecSolve IL Annotation Liveness.Liveness TrueLiveness LengthEq.

Instance argsLive_dec Caller Callee Y Z
      : Computable (argsLive Caller Callee Y Z).
Proof.
  decide(length Y = length Z).
  - general induction Y; destruct Z as [|v Z]; isabsurd.
    + left; econstructor.
    + decide (v ∈ Callee -> live_op_sound a Caller);
      edestruct (IHY Caller Callee); try dec_solve; try eassumption;
      try inv an; eauto; try tauto.
  - right; intro. eapply argsLive_length in H. congruence.
Defined.

Local Hint Extern 1 =>
match goal with
  [ H : annotation _ _ |- annotation _ _ ] => inv H; eassumption
end.

Definition live_sound_dec i ZL Lv s slv
      : Computable (live_sound i ZL Lv s slv).
Proof.
  revert i ZL Lv slv.
  sind s; intros; destruct s; destruct slv;
    try solve [dec_right].
  - edestruct (IH s); eauto; [| dec_right ];
    ensure (getAnn slv\{{x}} ⊆ a);
    ensure (live_exp_sound e a);
    ensure (x ∈ getAnn slv); dec_solve.
  - edestruct (IH s1); eauto; [| dec_right ];
    edestruct (IH s2); eauto; [| dec_right ];
    ensure (live_op_sound e a);
    ensure (getAnn slv1 ⊆ a);
    ensure (getAnn slv2 ⊆ a); dec_solve.
  - destruct (get_dec Lv (counted l)) as [[blv ?]|?]; [| dec_right];
      destruct (get_dec ZL (counted l)) as [[Z ?]|?]; [| dec_right];
    decide (isImperative i); [ensure ((blv \ of_list Z) ⊆ a); [|cases in H6; eauto]|];
    ensure (forall n y, get Y n y -> live_op_sound y a);
      ensure (length Y = length Z);
    left; econstructor; eauto; cases; eauto.
  - decide(live_op_sound e a); try dec_solve.
  - edestruct (IH s); eauto; [| dec_solve];
      ensure (length F = length sa);
      ensure (getAnn slv ⊆ a).
    exploit (@indexwise_R_dec' _ _
                               (fun Zs a0 => live_sound i (fst ⊝ F ++ ZL)
                                                     (getAnn ⊝ sa ++ Lv)
                                                     (snd Zs) a0) F sa).
    intros. eapply IH; eauto.
    destruct H; [| dec_solve].
    exploit (@indexwise_R_dec' _ _
                               (fun Zs a0 =>  of_list (fst Zs)[<=]getAnn a0 /\
                                           NoDupA eq (fst Zs) /\
                                             (if isFunctional i then
                                                getAnn a0 \ of_list (fst Zs)[<=]a
                                              else True)) F sa).
    + intros.
      ensure (of_list (fst a0)[<=]getAnn b).
      ensure (NoDupA _eq (fst a0)).
      cases; [| dec_solve].
      ensure ( getAnn b \ of_list (fst a0)[<=]a); dec_solve.
    + destruct H; dec_solve.
Defined.

Hint Extern 5 =>
match goal with
| [ H : ?A = ?B, H' : ?A <> ?B |- _ ] => exfalso; eapply H', H
end.

Definition true_live_sound_dec i ZL Lv s slv
      : Computable (true_live_sound i ZL Lv s slv).
Proof.
  revert i ZL Lv slv.
  sind s; intros; destruct s; destruct slv;
    try solve [right; intro A; inversion A].
  - edestruct (IH s); eauto; [| dec_right ];
      ensure (getAnn slv \ singleton x ⊆ a);
      ensure (x ∈ getAnn slv \/ isCall e -> live_exp_sound e a); dec_solve.
  - ensure (live_op_sound e a);
      ensure (getAnn slv1 ⊆ a);
      ensure (getAnn slv2 ⊆ a).
    edestruct (IH s1); eauto; [ | dec_right].
    edestruct (IH s2); eauto; [ | dec_right].
    dec_solve.
  - destruct (get_dec ZL (counted l)) as [[Z ?]|?]; [| dec_right];
    destruct (get_dec Lv (counted l)) as [[blv ?]|?]; [| dec_right];
    ensure (argsLive a blv Y Z).
    exploit argsLive_length; eauto.
    decide (isImperative i); try dec_solve.
    + decide ((blv \ of_list Z) ⊆ a).
      * left; econstructor; eauto. cases; eauto.
      * dec_right. cases in H7. eauto.
    + left; econstructor; eauto. cases; eauto.
  - ensure (live_op_sound e a). dec_solve.
  - edestruct (IH s); eauto; [| dec_right];
      ensure (length F = length sa);
      ensure (getAnn slv ⊆ a).
    exploit (@indexwise_R_dec' _ _
                               (fun Zs a0 =>
                                  true_live_sound i (fst ⊝ F ++ ZL)
                                                  (getAnn ⊝ sa ++ Lv)
                                                  (snd Zs) a0) F sa).
    intros. eapply IH; eauto. destruct H; [| dec_right].
    decide (isFunctional i); [| left; econstructor; try cases; eauto].
    exploit (@indexwise_R_dec' _ _
                               (fun Zs a0 => getAnn a0 \ of_list (fst Zs)[<=]a) F sa).
    + intros.
      decide ( getAnn b \ of_list (fst a0)[<=]a).
      left; eauto. right; eauto.
    + destruct H. left; econstructor; try cases; eauto.
      dec_right. cases in H9; eauto.
Defined.


(*****************************************************************************

 Every display map bicategory gives rise to a displayed bicategory

 *****************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration.
Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration.
Require Import UniMath.Bicategories.Logic.DisplayMapBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain.
Require Import UniMath.Bicategories.Limits.Pullbacks.

Local Open Scope cat.

Section ArrowSubBicatToDispBicat.
  Context {B : bicat}
          (D : arrow_subbicat B).

  Definition disp_map_bicat_ob
             (y : B)
    : UU
    := ∑ (x : B) (h : x --> y), pred_ob D h.

  Definition make_disp_map_bicat_ob
             {x y : B}
             (h : x --> y)
             (H : pred_ob D h)
    : disp_map_bicat_ob y
    := (x ,, h ,, H).

  Definition disp_map_bicat_mor
             {y₁ y₂ : B}
             (h₁ : disp_map_bicat_ob y₁)
             (h₂ : disp_map_bicat_ob y₂)
             (g : y₁ --> y₂)
    : UU
    := ∑ (f : pr1 h₁ --> pr1 h₂),
       pred_mor D (pr12 h₁) (pr12 h₂) f
       ×
       invertible_2cell (pr12 h₁ · g) (f · pr12 h₂).

  Definition make_disp_map_bicat_mor
             {y₁ y₂ : B}
             {h₁ : disp_map_bicat_ob y₁}
             {h₂ : disp_map_bicat_ob y₂}
             (g : y₁ --> y₂)
             (f : pr1 h₁ --> pr1 h₂)
             (H : pred_mor D (pr12 h₁) (pr12 h₂) f)
             (γ : invertible_2cell (pr12 h₁ · g) (f · pr12 h₂))
    : disp_map_bicat_mor h₁ h₂ g
    := (f ,, H ,, γ).

  Definition disp_map_bicat_to_disp_cat_ob_mor
    : disp_cat_ob_mor B.
  Proof.
    simple refine (_ ,, _).
    - exact disp_map_bicat_ob.
    - exact (λ _ _, disp_map_bicat_mor).
  Defined.

  Definition disp_map_bicat_to_disp_cat_id_comp
    : disp_cat_id_comp B disp_map_bicat_to_disp_cat_ob_mor.
  Proof.
    split.
    - intros y h.
      use make_disp_map_bicat_mor.
      + exact (id₁ _).
      + apply id_pred_mor.
      + exact (comp_of_invertible_2cell
                 (runitor_invertible_2cell _)
                 (linvunitor_invertible_2cell _)).
    - intros y₁ y₂ y₃ g₁ g₂ h₁ h₂ h₃ f₁ f₂.
      use make_disp_map_bicat_mor.
      + exact (pr1 f₁ · pr1 f₂).
      + exact (comp_pred_mor
                 D
                 (pr12 f₁) (pr12 f₂)).
      + exact (comp_of_invertible_2cell
                 (lassociator_invertible_2cell _ _ _)
                 (comp_of_invertible_2cell
                    (rwhisker_of_invertible_2cell _ (pr22 f₁))
                    (comp_of_invertible_2cell
                       (rassociator_invertible_2cell _ _ _)
                       (comp_of_invertible_2cell
                          (lwhisker_of_invertible_2cell _ (pr22 f₂))
                          (lassociator_invertible_2cell _ _ _))))).
  Defined.

  Definition disp_map_bicat_to_disp_cat_data
    : disp_cat_data B
    := (disp_map_bicat_to_disp_cat_ob_mor ,, disp_map_bicat_to_disp_cat_id_comp).

  Definition disp_map_bicat_cell
             {y₁ y₂ : B}
             {g₁ g₂ : y₁ --> y₂}
             {h₁ : disp_map_bicat_ob y₁}
             {h₂ : disp_map_bicat_ob y₂}
             (f₁ : disp_map_bicat_mor h₁ h₂ g₁)
             (f₂ : disp_map_bicat_mor h₁ h₂ g₂)
             (β : g₁ ==> g₂)
    : UU
    := ∑ (α : pr1 f₁ ==> pr1 f₂),
       pr122 f₁ • (α ▹ _)
       =
       (_ ◃ β) • pr122 f₂.

  Definition make_disp_map_bicat_cell
             {y₁ y₂ : B}
             {g₁ g₂ : y₁ --> y₂}
             {β : g₁ ==> g₂}
             {h₁ : disp_map_bicat_ob y₁}
             {h₂ : disp_map_bicat_ob y₂}
             {f₁ : disp_map_bicat_mor h₁ h₂ g₁}
             {f₂ : disp_map_bicat_mor h₁ h₂ g₂}
             (α : pr1 f₁ ==> pr1 f₂)
             (p : pr122 f₁ • (α ▹ _)
                  =
                  (_ ◃ β) • pr122 f₂)
    : disp_map_bicat_cell f₁ f₂ β
    := (α ,, p).

  Definition disp_map_bicat_to_disp_prebicat_1_id_comp_cells
    : disp_prebicat_1_id_comp_cells B.
  Proof.
    refine (disp_map_bicat_to_disp_cat_data ,, _).
    exact (λ y₁ y₂ g₁ g₂ β h₁ h₂ f₁ f₂, disp_map_bicat_cell f₁ f₂ β).
  Defined.

  Definition disp_map_bicat_to_disp_prebicat_ops
    : disp_prebicat_ops disp_map_bicat_to_disp_prebicat_1_id_comp_cells.
  Proof.
    repeat split.
    - intros x y f hx hy hf ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (id2 _).
      + abstract
          (rewrite id2_rwhisker, lwhisker_id2 ;
           rewrite id2_left, id2_right ;
           apply idpath).
    - intros x y f hx hy hf ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (lunitor _).
      + abstract
          (cbn ;
           rewrite <- rwhisker_vcomp ;
           rewrite !vassocr ;
           rewrite runitor_rwhisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite lunitor_triangle ;
           rewrite vcomp_lunitor ;
           rewrite !vassocr ;
           rewrite <- linvunitor_assoc ;
           rewrite linvunitor_lunitor ;
           apply id2_left).
    - intros x y f hx hy hf ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (runitor _).
      + abstract
          (cbn ;
           rewrite <- !lwhisker_vcomp ;
           rewrite !vassocl ;
           rewrite runitor_rwhisker ;
           rewrite lwhisker_vcomp ;
           rewrite linvunitor_lunitor ;
           rewrite lwhisker_id2 ;
           rewrite id2_right ;
           rewrite runitor_triangle ;
           rewrite vcomp_runitor ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           exact (!(left_unit_assoc _ _))).
    - intros x y f hx hy hf ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (linvunitor _).
      + abstract
          (cbn ;
           rewrite <- !rwhisker_vcomp ;
           rewrite !vassocl ;
           rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite runitor_rwhisker ;
           rewrite !vassocr ;
           rewrite lwhisker_vcomp ;
           rewrite linvunitor_lunitor ;
           rewrite lwhisker_id2 ;
           rewrite id2_left ;
           rewrite <- linvunitor_assoc ;
           rewrite lwhisker_hcomp ;
           rewrite <- linvunitor_natural ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite linvunitor_assoc ;
           rewrite !vassocl ;
           rewrite rassociator_lassociator ;
           rewrite id2_right ;
           apply idpath).
    - intros x y f hx hy hf ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (rinvunitor _).
      + abstract
          (cbn ;
           rewrite <- !lwhisker_vcomp ;
           rewrite !vassocl ;
           rewrite !lwhisker_hcomp ;
           rewrite triangle_l_inv ;
           rewrite <- !lwhisker_hcomp, <- rwhisker_hcomp ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite !vassocl ;
           rewrite runitor_triangle ;
           rewrite vcomp_runitor ;
           refine (!(id2_left _) @ _) ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite !vassocl ;
           rewrite <- left_unit_assoc ;
           rewrite lwhisker_vcomp ;
           rewrite rinvunitor_runitor ;
           rewrite lwhisker_id2 ;
           apply idpath).
    - intros x₁ x₂ x₃ x₄ f g k hx₁ hx₂ hx₃ hx₄ hf hg hk ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (rassociator _ _ _).
      + abstract
          (cbn ;
           rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp ;
           rewrite !vassocl ;
           use vcomp_move_L_pM ; [ is_iso | ] ;
           cbn ;
           rewrite !vassocr ;
           rewrite lassociator_lassociator ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !vassocr ;
           rewrite rwhisker_rwhisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           use vcomp_move_L_pM ; [ is_iso | ] ;
           cbn ;
           rewrite !vassocr ;
           rewrite <- lassociator_lassociator ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite rwhisker_vcomp ;
           rewrite lassociator_rassociator ;
           rewrite id2_rwhisker ;
           rewrite id2_left ;
           rewrite !vassocr ;
           rewrite <- rwhisker_lwhisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           use vcomp_move_L_pM ; [ is_iso | ] ;
           cbn ;
           rewrite !vassocr ;
           rewrite lassociator_lassociator ;
           rewrite !vassocl ;
           rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite lassociator_rassociator ;
           rewrite id2_left ;
           rewrite !vassocr ;
           rewrite <- lwhisker_lwhisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !vassocr ;
           rewrite <- lassociator_lassociator ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite rwhisker_vcomp ;
           rewrite lassociator_rassociator ;
           rewrite id2_rwhisker ;
           apply id2_right).
    - intros x₁ x₂ x₃ x₄ f g k hx₁ hx₂ hx₃ hx₄ hf hg hk ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (lassociator _ _ _).
      + abstract
          (cbn ;
           rewrite <- !rwhisker_vcomp, <- !lwhisker_vcomp ;
           rewrite !vassocr ;
           rewrite lassociator_lassociator ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !vassocr ;
           rewrite rwhisker_rwhisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           use vcomp_move_R_pM ; [ is_iso | ] ;
           cbn ;
           rewrite !vassocr ;
           rewrite <- lassociator_lassociator ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite rwhisker_vcomp ;
           rewrite lassociator_rassociator ;
           rewrite id2_rwhisker ;
           rewrite id2_left ;
           rewrite !vassocr ;
           rewrite <- rwhisker_lwhisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           use vcomp_move_R_pM ; [ is_iso | ] ;
           cbn ;
           rewrite !vassocr ;
           rewrite lassociator_lassociator ;
           rewrite !vassocl ;
           rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
           rewrite lassociator_rassociator ;
           rewrite id2_left ;
           rewrite !vassocr ;
           rewrite <- lwhisker_lwhisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite <- lassociator_lassociator ;
           rewrite !vassocl ;
           apply idpath).
    - intros x₁ x₂ f g h α β hx₁ hx₂ hf hg hh hα hβ ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (pr1 hα • pr1 hβ).
      + abstract
          (cbn ;
           rewrite <- !rwhisker_vcomp ;
           rewrite <- !lwhisker_vcomp ;
           rewrite !vassocr ;
           rewrite (pr2 hα) ;
           rewrite !vassocl ;
           rewrite (pr2 hβ) ;
           apply idpath).
    - intros x₁ x₂ x₃ f₁ f₂ g α hx₁ hx₂ hx₃ hf₁ hf₂ hg hα ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (_ ◃ pr1 hα).
      + abstract
          (cbn ;
           rewrite !vassocl ;
           rewrite <- rwhisker_lwhisker ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite lwhisker_lwhisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !vassocr ;
           rewrite <- vcomp_whisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !vassocr ;
           rewrite <- lwhisker_lwhisker_rassociator ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite !lwhisker_vcomp ;
           apply maponpaths ;
           exact (pr2 hα)).
    - intros x₁ x₂ x₃ f₁ f₂ g α hx₁ hx₂ hx₃ hf₁ hf₂ hg hα ; cbn in *.
      use make_disp_map_bicat_cell.
      + exact (pr1 hα ▹ _).
      + abstract
          (cbn ;
           rewrite !vassocl ;
           rewrite rwhisker_rwhisker ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite rwhisker_lwhisker ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite <- vcomp_whisker ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite !vassocl ;
           rewrite <- rwhisker_rwhisker_alt ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite !rwhisker_vcomp ;
           apply maponpaths ;
           exact (pr2 hα)).
  Defined.

  Definition transportf_disp_map_bicat_cell
             {y₁ y₂ : B}
             {g₁ g₂ : y₁ --> y₂}
             {β₁ β₂ : g₁ ==> g₂}
             (p : β₁ = β₂)
             {h₁ : disp_map_bicat_ob y₁}
             {h₂ : disp_map_bicat_ob y₂}
             {f₁ : disp_map_bicat_mor h₁ h₂ g₁}
             {f₂ : disp_map_bicat_mor h₁ h₂ g₂}
             (γ : disp_map_bicat_cell f₁ f₂ β₁)
    : pr1 (transportf
             (λ α, disp_map_bicat_cell f₁ f₂ α)
             p
             γ)
      =
      pr1 γ.
  Proof.
    induction p.
    apply idpath.
  Qed.

  Definition transportb_disp_map_bicat_cell
             {y₁ y₂ : B}
             {g₁ g₂ : y₁ --> y₂}
             {β₁ β₂ : g₁ ==> g₂}
             (p : β₁ = β₂)
             {h₁ : disp_map_bicat_ob y₁}
             {h₂ : disp_map_bicat_ob y₂}
             {f₁ : disp_map_bicat_mor h₁ h₂ g₁}
             {f₂ : disp_map_bicat_mor h₁ h₂ g₂}
             (γ : disp_map_bicat_cell f₁ f₂ β₂)
    : pr1 (transportb
             (λ α, disp_map_bicat_cell f₁ f₂ α)
             p
             γ)
      =
      pr1 γ.
  Proof.
    induction p.
    apply idpath.
  Qed.

  Definition disp_map_bicat_to_disp_prebicat_data
    : disp_prebicat_data B
    := (disp_map_bicat_to_disp_prebicat_1_id_comp_cells
        ,,
        disp_map_bicat_to_disp_prebicat_ops).

  Definition disp_map_bicat_to_disp_prebicat_laws
    : disp_prebicat_laws disp_map_bicat_to_disp_prebicat_data.
  Proof.
    repeat split
    ; intro ; intros
    ; cbn in *
    ; (use subtypePath ; [ intro ; apply cellset_property | ]) ; cbn
    ; rewrite transportb_disp_map_bicat_cell ; cbn.
    - apply id2_left.
    - apply id2_right.
    - apply vassocr.
    - apply lwhisker_id2.
    - apply id2_rwhisker.
    - apply lwhisker_vcomp.
    - apply rwhisker_vcomp.
    - apply vcomp_lunitor.
    - apply vcomp_runitor.
    - apply lwhisker_lwhisker.
    - apply rwhisker_lwhisker.
    - apply rwhisker_rwhisker.
    - apply vcomp_whisker.
    - apply lunitor_linvunitor.
    - apply linvunitor_lunitor.
    - apply runitor_rinvunitor.
    - apply rinvunitor_runitor.
    - apply lassociator_rassociator.
    - apply rassociator_lassociator.
    - apply runitor_rwhisker.
    - apply lassociator_lassociator.
  Qed.

  Definition disp_map_bicat_to_disp_prebicat
    : disp_prebicat B
    := (disp_map_bicat_to_disp_prebicat_data
        ,,
        disp_map_bicat_to_disp_prebicat_laws).

  Definition disp_map_bicat_to_disp_bicat
    : disp_bicat B.
  Proof.
    refine (disp_map_bicat_to_disp_prebicat ,, _).
    intro ; intros.
    use isaset_total2.
    - apply cellset_property.
    - intro.
      apply isasetaprop.
      apply cellset_property.
  Defined.

  Definition disp_2cells_isaprop_if_contained_in_faithful
             (HD : contained_in_faithful D)
    : disp_2cells_isaprop disp_map_bicat_to_disp_bicat.
  Proof.
    intros x y f g α xx yy ff gg.
    use invproofirrelevance.
    intros αα ββ.
    use subtypePath.
    {
      intro.
      apply cellset_property.
    }
    apply (faithful_1cell_eq_cell (HD _ _ _ (pr22 yy))).
    use (vcomp_lcancel (pr22 ff)) ; [ apply property_from_invertible_2cell | ].
    exact (pr2 αα @ !(pr2 ββ)).
  Qed.

  (** Displayed invertible 2-cells *)
  Definition is_invertible_to_is_disp_invertible
             {x y : B}
             {f g : x --> y}
             {α : f ==> g}
             (Hα : is_invertible_2cell α)
             {hx : disp_map_bicat_to_disp_bicat x}
             {hy : disp_map_bicat_to_disp_bicat y}
             {hf : hx -->[ f ] hy}
             {hg : hx -->[ g ] hy}
             (αα : hf ==>[ α ] hg)
             (Hαα : is_invertible_2cell (pr1 αα))
    : is_disp_invertible_2cell Hα αα.
  Proof.
    simple refine (_ ,, _ ,, _).
    - use make_disp_map_bicat_cell.
      + exact (Hαα^-1).
      + abstract
          (use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
           rewrite !vassocl ;
           rewrite (pr2 αα) ;
           rewrite !vassocr ;
           rewrite lwhisker_vcomp ;
           rewrite vcomp_linv ;
           rewrite lwhisker_id2 ;
           rewrite id2_left ;
           apply idpath).
    - abstract
        (use subtypePath ; [ intro ; apply cellset_property | ] ; cbn ;
         rewrite transportb_disp_map_bicat_cell ; cbn ;
         apply vcomp_rinv).
    - abstract
        (use subtypePath ; [ intro ; apply cellset_property | ] ; cbn ;
         rewrite transportb_disp_map_bicat_cell ; cbn ;
         apply vcomp_linv).
  Defined.

  Definition is_disp_invertible_to_is_invertible
             {x y : B}
             {f g : x --> y}
             {α : f ==> g}
             (Hα : is_invertible_2cell α)
             {hx : disp_map_bicat_to_disp_bicat x}
             {hy : disp_map_bicat_to_disp_bicat y}
             {hf : hx -->[ f ] hy}
             {hg : hx -->[ g ] hy}
             (αα : hf ==>[ α ] hg)
             (Hαα : is_disp_invertible_2cell Hα αα)
    : is_invertible_2cell (pr1 αα).
  Proof.
    use make_is_invertible_2cell.
    - exact (pr11 Hαα).
    - abstract
        (exact (maponpaths pr1 (pr12 Hαα) @ transportb_disp_map_bicat_cell _ _)).
    - abstract
        (exact (maponpaths pr1 (pr22 Hαα) @ transportb_disp_map_bicat_cell _ _)).
  Defined.

  Definition make_disp_map_disp_invertible_2cell
             {x y : B}
             {f g : x --> y}
             {γ : f ==> g}
             (Hγ : is_invertible_2cell γ)
             {hx : disp_map_bicat_to_disp_bicat x}
             {hy : disp_map_bicat_to_disp_bicat y}
             {hf : hx -->[ f ] hy}
             {hg : hx -->[ g ] hy}
             (hγ : hf ==>[ γ ] hg)
             (Hhγ : is_invertible_2cell (pr1 hγ))
    : disp_invertible_2cell (make_invertible_2cell Hγ) hf hg.
  Proof.
    refine (hγ ,, _).
    use is_invertible_to_is_disp_invertible.
    exact Hhγ.
  Defined.

  Definition disp_map_inv_2cell_to_disp_invertible_2cell
             {x y : B}
             {f g : x --> y}
             {γ : invertible_2cell f g}
             {hx : disp_map_bicat_to_disp_bicat x}
             {hy : disp_map_bicat_to_disp_bicat y}
             {hf : hx -->[ f ] hy}
             {hg : hx -->[ g ] hy}
             (α : ∑ (hγ : hf ==>[ γ ] hg), is_invertible_2cell (pr1 hγ))
    : disp_invertible_2cell γ hf hg.
  Proof.
    use make_disp_map_disp_invertible_2cell.
    - exact (pr1 α).
    - exact (pr2 α).
  Defined.

  Definition disp_map_disp_invertible_2cell_to_inv_2cell
             {x y : B}
             {f g : x --> y}
             {γ : invertible_2cell f g}
             {hx : disp_map_bicat_to_disp_bicat x}
             {hy : disp_map_bicat_to_disp_bicat y}
             {hf : hx -->[ f ] hy}
             {hg : hx -->[ g ] hy}
             (α : disp_invertible_2cell γ hf hg)
    : ∑ (hγ : hf ==>[ γ ] hg), is_invertible_2cell (pr1 hγ).
  Proof.
    refine (pr1 α ,, _).
    use is_disp_invertible_to_is_invertible.
    - exact (pr2 γ).
    - exact (pr2 α).
  Defined.

  Definition disp_map_inv_2cell_weq_disp_invertible_2cell
             {x y : B}
             {f g : x --> y}
             (γ : invertible_2cell f g)
             {hx : disp_map_bicat_to_disp_bicat x}
             {hy : disp_map_bicat_to_disp_bicat y}
             (hf : hx -->[ f ] hy)
             (hg : hx -->[ g ] hy)
    : (∑ (hγ : hf ==>[ γ ] hg), is_invertible_2cell (pr1 hγ))
      ≃
      disp_invertible_2cell γ hf hg.
  Proof.
    use make_weq.
    - exact disp_map_inv_2cell_to_disp_invertible_2cell.
    - use isweq_iso.
      + exact disp_map_disp_invertible_2cell_to_inv_2cell.
      + abstract
          (intro α ;
           use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
           apply idpath).
      + abstract
          (intro α ;
           use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ;
           apply idpath).
  Defined.

  (**
   3. Local Univalence
   *)
  Local Definition refactor_weq
        {x y : B}
        {f g : x --> y}
        (γ : invertible_2cell f g)
        {hx : disp_map_bicat_to_disp_bicat x}
        {hy : disp_map_bicat_to_disp_bicat y}
        (hf : hx -->[ f ] hy)
        (hg : hx -->[ g ] hy)
    : (∑ (γe : invertible_2cell (pr1 hf) (pr1 hg)),
       pr122 hf • (γe ▹ pr12 hy) = (pr12 hx ◃ γ) • pr122 hg)
      ≃
      ∑ (hγ : hf ==>[ γ ] hg), is_invertible_2cell (pr1 hγ).
  Proof.
    use make_weq.
    - exact (λ α, ((pr11 α ,, pr2 α) ,, pr21 α)).
    - use isweq_iso.
      + exact (λ α, (pr11 α ,, pr2 α) ,, pr21 α).
      + intro ; apply idpath.
      + intro ; apply idpath.
  Defined.

  Local Definition weq_on_fam
        (HD : arrow_subbicat_props D)
        {x y : B}
        {f : x --> y}
        {hx : disp_map_bicat_to_disp_bicat x}
        {hy : disp_map_bicat_to_disp_bicat y}
        (hf hg : hx -->[ f] hy)
        (p : pr1 hf = pr1 hg)
    : (transportf
         (λ z,
          pred_mor D (pr12 hx) (pr12 hy) z
          ×
          invertible_2cell (pr12 hx · f) (z · pr12 hy))
         p
         (pr2 hf)
       =
       pr2 hg)
      ≃
      (pr122 hf • (idtoiso_2_1 (pr1 hf) (pr1 hg) p ▹ pr12 hy)
       =
       (pr12 hx ◃ id₂ f) • pr122 hg).
  Proof.
    induction hf as [ hf₁ hf₂ ].
    induction hg as [ hg₁ hg₂ ].
    cbn in *.
    induction p ; cbn.
    use weqimplimpl.
    - intro p.
      induction p.
      rewrite id2_rwhisker, lwhisker_id2, id2_left, id2_right.
      apply idpath.
    - intro p.
      use pathsdirprod.
      + apply (pr2 HD).
      + rewrite id2_rwhisker, lwhisker_id2, id2_left, id2_right in p.
        use subtypePath.
        {
          intro ; apply isaprop_is_invertible_2cell.
        }
        exact p.
    - use isasetdirprod.
      + apply isasetaprop.
        apply (pr2 HD).
      + apply isaset_invertible_2cell.
    - apply cellset_property.
  Qed.

  Definition disp_map_disp_univalent_2_1
             (HD : arrow_subbicat_props D)
             (HB_2_1 : is_univalent_2_1 B)
    : disp_univalent_2_1 disp_map_bicat_to_disp_bicat.
  Proof.
    intros x y f g p hx hy hf hg.
    induction p.
    use weqhomot.
    - refine (disp_map_inv_2cell_weq_disp_invertible_2cell _ _ _
             ∘ refactor_weq _ _ _
             ∘ weqtotal2
                 (make_weq _ (HB_2_1 _ _ _ _))
                 _
             ∘ total2_paths_equiv _ _ _)%weq.
      exact (weq_on_fam HD _ _).
    - abstract
        (intro p ;
         induction p ;
         use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ;
         cbn ;
         use subtypePath ; [ intro ; apply cellset_property | ] ;
         apply idpath).
  Defined.

  (**
   4. Adjoint equivalences
   *)
  Section AdjEquivToDispAdjEquiv.
    Context (HB : is_univalent_2 B)
            {x : B}
            {hx hy : disp_map_bicat_to_disp_bicat x}
            (e : adjoint_equivalence (pr1 hx) (pr1 hy))
            (com : invertible_2cell (pr12 hx) (e · pr12 hy)).

    Local Definition adj_equiv_to_disp_adj_equiv_left_adj
      : hx -->[ internal_adjoint_equivalence_identity x] hy.
    Proof.
      use make_disp_map_bicat_mor.
      - exact e.
      - apply (arrow_subbicat_contains_equiv_over_id HB D).
        + exact e.
        + exact com.
      - exact (comp_of_invertible_2cell
                 (runitor_invertible_2cell _)
                 com).
    Defined.

    Local Notation "'L'" := adj_equiv_to_disp_adj_equiv_left_adj.

    Local Definition adj_equiv_to_disp_adj_equiv_right_adj
      : hy -->[ internal_adjoint_equivalence_identity x] hx.
    Proof.
      use make_disp_map_bicat_mor.
      - exact (left_adjoint_right_adjoint e).
      - pose (einv := inv_adjequiv e).
        apply (arrow_subbicat_contains_equiv_over_id
                 HB D).
        + exact (pr2 einv).
        + exact (comp_of_invertible_2cell
                   (linvunitor_invertible_2cell _)
                   (comp_of_invertible_2cell
                      (rwhisker_of_invertible_2cell
                         _
                         (left_equivalence_unit_iso einv))
                      (comp_of_invertible_2cell
                         (rassociator_invertible_2cell _ _ _)
                         (lwhisker_of_invertible_2cell
                            _
                            (inv_of_invertible_2cell com))))).
      - refine (runitor _
                • linvunitor _
                • ((left_equivalence_counit_iso e)^-1 ▹ _)
                • rassociator _ _ _
                • (_ ◃ com^-1) ,, _).
        is_iso.
    Defined.

    Local Notation "'R'" := adj_equiv_to_disp_adj_equiv_right_adj.

    Local Lemma adj_equiv_to_disp_adj_equiv_unit_coh
      : pr122 (id_disp hx) • (left_adjoint_unit e ▹ pr12 hx)
        =
        (pr12 hx ◃ left_adjoint_unit (internal_adjoint_equivalence_identity x))
        • pr122 (L ;; R)%mor_disp.
    Proof.
      cbn.
      rewrite !vassocr.
      refine (!_).
      etrans.
      {
        do 4 apply maponpaths_2.
        rewrite lwhisker_hcomp.
        rewrite triangle_l_inv.
        rewrite <- rwhisker_hcomp.
        apply idpath.
      }
      rewrite !rwhisker_vcomp.
      rewrite !vassocr.
      rewrite rinvunitor_runitor.
      rewrite id2_left.
      rewrite !vassocl.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      rewrite lwhisker_lwhisker.
      rewrite !vassocr.
      use vcomp_move_R_Mp.
      {
        is_iso.
      }
      cbn.
      refine (!_).
      etrans.
      {
        rewrite !vassocl.
        rewrite vcomp_whisker.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite lwhisker_hcomp.
          rewrite <- linvunitor_natural.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- vcomp_runitor.
        apply idpath.
      }
      rewrite !vassocl.
      apply maponpaths ; clear com.
      rewrite <- runitor_triangle.
      rewrite !vassocl.
      do 2 apply maponpaths.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      use vcomp_move_R_pM.
      {
        is_iso.
      }
      cbn.
      refine (!_).
      rewrite linvunitor_assoc.
      rewrite !vassocl.
      rewrite <- rwhisker_rwhisker_alt.
      rewrite !vassocr.
      etrans.
      {
        apply maponpaths_2.
        rewrite !vassocl.
        rewrite rwhisker_vcomp.
        apply maponpaths.
        assert (linvunitor (pr1 e) • (pr121 (pr2 e) ▹ pr1 e)
                =
                rinvunitor _ • (pr1 e ◃ (pr222 (pr2 e))^-1) • lassociator _ _ _)
          as p.
        {
          refine (_ @ id2_left _).
          use vcomp_move_L_Mp.
          {
            is_iso.
          }
          cbn.
          rewrite !vassocr.
          exact (pr1 (pr122 e)).
        }
        apply maponpaths.
        exact p.
      }
      unfold left_adjoint_right_adjoint.
      use vcomp_move_R_Mp.
      {
        is_iso.
      }
      cbn.
      rewrite <- lassociator_lassociator.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      refine (_ @ id2_right _).
      use vcomp_move_L_pM.
      {
        is_iso.
      }
      cbn.
      rewrite !vassocr.
      rewrite rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite lunitor_lwhisker.
        rewrite rwhisker_vcomp.
        rewrite runitor_rinvunitor.
        apply id2_rwhisker.
      }
      rewrite id2_left.
      rewrite rwhisker_vcomp.
      rewrite lwhisker_vcomp.
      rewrite vcomp_rinv.
      rewrite lwhisker_id2.
      rewrite id2_rwhisker.
      apply idpath.
    Qed.

    Local Definition adj_equiv_to_disp_adj_equiv_unit
      : id_disp hx
        ==>[ left_adjoint_unit (internal_adjoint_equivalence_identity x) ]
        L ;; R.
    Proof.
      use make_disp_map_bicat_cell.
      - exact (left_adjoint_unit e).
      - exact adj_equiv_to_disp_adj_equiv_unit_coh.
    Defined.

    Local Notation "'η'" := adj_equiv_to_disp_adj_equiv_unit.

    Local Lemma adj_equiv_to_disp_adj_equiv_counit_coh
      : pr122 (R ;; L)%mor_disp
        • (left_adjoint_counit e ▹ pr12 hy)
        =
        (pr12 hy ◃ left_adjoint_counit (internal_adjoint_equivalence_identity x))
        • pr122 (id_disp hy).
    Proof.
      cbn.
      rewrite !vassocl.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocr.
      rewrite runitor_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite !vassocr.
        rewrite vcomp_runitor.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
      }
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      assert (rassociator (pr112 e) (pr1 e) (pr12 hy) ▹ id₁ _
              • rassociator (pr112 e) (pr1 e · pr12 hy) (id₁ _)
              • (pr112 e ◃ runitor (pr1 e · pr12 hy))
              • lassociator (pr112 e) (pr1 e) (pr12 hy)
              =
              runitor _)
        as p.
      {
        rewrite !vassocl.
        rewrite !left_unit_assoc.
        rewrite !vassocl.
        rewrite <- vcomp_runitor.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rassociator_lassociator.
          rewrite id2_left.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite rassociator_lassociator.
        rewrite id2_rwhisker.
        apply id2_left.
      }
      rewrite <- !rwhisker_vcomp.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        exact p.
      }
      rewrite <- vcomp_runitor.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite !rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite !id2_rwhisker.
        apply idpath.
      }
      rewrite id2_left.
      rewrite vcomp_runitor.
      apply idpath.
    Qed.

    Local Definition adj_equiv_to_disp_adj_equiv_counit
      : R ;; L
        ==>[ left_adjoint_counit (internal_adjoint_equivalence_identity x) ]
        id_disp hy.
    Proof.
      use make_disp_map_bicat_cell.
      - exact (left_adjoint_counit e).
      - exact adj_equiv_to_disp_adj_equiv_counit_coh.
    Defined.

    Local Notation "'ε'" := adj_equiv_to_disp_adj_equiv_counit.

    Local Definition adj_equiv_to_disp_adj_equiv_data
      : @disp_left_adjoint_data
          B
          disp_map_bicat_to_disp_bicat
          _ _
          (internal_adjoint_equivalence_identity x)
          (internal_adjoint_equivalence_identity x)
          hx hy
          L
      := (R ,, (η ,, ε)).

    Local Definition adj_equiv_to_disp_adj_equiv_adjoint_axioms
      : disp_left_adjoint_axioms
          (internal_adjoint_equivalence_identity x)
          adj_equiv_to_disp_adj_equiv_data.
    Proof.
      split.
      - simpl.
        use subtypePath.
        {
          intro.
          apply cellset_property.
        }
        rewrite transportb_disp_map_bicat_cell.
        cbn.
        apply (pr2 e).
      - simpl.
        use subtypePath.
        {
          intro.
          apply cellset_property.
        }
        rewrite transportb_disp_map_bicat_cell.
        cbn.
        apply (pr2 e).
    Qed.

    Local Definition adj_equiv_to_disp_adj_equiv_equivalence_axioms
      : disp_left_equivalence_axioms
          (internal_adjoint_equivalence_identity x)
          adj_equiv_to_disp_adj_equiv_data.
    Proof.
      split.
      - apply is_invertible_to_is_disp_invertible.
        apply (pr2 e).
      - apply is_invertible_to_is_disp_invertible.
        apply (pr2 e).
    Defined.

    Definition disp_map_bicat_adj_equiv_to_disp_adj_equiv
      : disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) hx hy.
    Proof.
      simple refine (L ,, (_ ,, (_ ,, _))).
      - exact adj_equiv_to_disp_adj_equiv_data.
      - exact adj_equiv_to_disp_adj_equiv_adjoint_axioms.
      - exact adj_equiv_to_disp_adj_equiv_equivalence_axioms.
    Defined.
  End AdjEquivToDispAdjEquiv.

  Section DispAdjEquivToAdjEquiv.
    Context {x : B}
            {hx hy : disp_map_bicat_to_disp_bicat x}
            (e : disp_adjoint_equivalence
                   (internal_adjoint_equivalence_identity x)
                   hx hy).

    Local Definition disp_adj_equiv_to_left_adj_data
      : left_adjoint_data (pr11 e)
      := (pr1 (pr112 e) ,, (pr11 (pr212 e) ,, pr12 (pr212 e))).

    Local Definition disp_adj_equiv_to_left_adjoint_axioms
      : left_adjoint_axioms disp_adj_equiv_to_left_adj_data.
    Proof.
      split.
      - pose (maponpaths pr1 (pr1 (pr122 e))) as p.
        cbn in p.
        rewrite transportb_disp_map_bicat_cell in p.
        exact p.
      - pose (maponpaths pr1 (pr2 (pr122 e))) as p.
        cbn in p.
        rewrite transportb_disp_map_bicat_cell in p.
        exact p.
    Qed.

    Local Definition disp_adj_equiv_to_left_equivalence_axioms
      : left_equivalence_axioms disp_adj_equiv_to_left_adj_data.
    Proof.
      split.
      - exact (is_disp_invertible_to_is_invertible _ _ (pr1 (pr222 e))).
      - exact (is_disp_invertible_to_is_invertible _ _ (pr2 (pr222 e))).
    Defined.

    Local Definition disp_adj_equiv_to_left_adj_equiv
      : left_adjoint_equivalence (pr11 e).
    Proof.
      refine (disp_adj_equiv_to_left_adj_data ,, _).
      split.
      - exact disp_adj_equiv_to_left_adjoint_axioms.
      - exact disp_adj_equiv_to_left_equivalence_axioms.
    Defined.

    Definition disp_adj_equiv_to_adj_equiv
      : adjoint_equivalence (pr1 hx) (pr1 hy)
      := (pr11 e ,, disp_adj_equiv_to_left_adj_equiv).

    Definition disp_adj_equiv_to_adj_equiv_comm
      : invertible_2cell
          (pr12 hx)
          (disp_adj_equiv_to_adj_equiv · pr12 hy)
      := comp_of_invertible_2cell
           (rinvunitor_invertible_2cell _)
           (pr221 e).

    Definition disp_map_bicat_disp_adj_equiv_to_adj_equiv_pair
      : ∑ (e : adjoint_equivalence (pr1 hx) (pr1 hy)),
        invertible_2cell
          (pr12 hx)
          (e · pr12 hy)
      := disp_adj_equiv_to_adj_equiv
         ,,
         disp_adj_equiv_to_adj_equiv_comm.
  End DispAdjEquivToAdjEquiv.

  Definition adj_equiv_to_disp_adj_equiv_to_adj_equiv
             (HB : is_univalent_2 B)
             {x : B}
             {hx hy : disp_map_bicat_to_disp_bicat x}
             (z : ∑ (e : adjoint_equivalence (pr1 hx) (pr1 hy)),
                  invertible_2cell (pr12 hx) (pr1 e · pr12 hy))
    : disp_map_bicat_disp_adj_equiv_to_adj_equiv_pair
        (disp_map_bicat_adj_equiv_to_disp_adj_equiv
           HB (pr1 z) (pr2 z))
      =
      z.
  Proof.
    use total2_paths_f.
    - simpl.
      use subtypePath.
      {
        intro ; apply isaprop_left_adjoint_equivalence.
        exact (pr2 HB).
      }
      apply idpath.
    - use subtypePath.
      {
        intro ; apply isaprop_is_invertible_2cell.
      }
      unfold invertible_2cell.
      rewrite pr1_transportf.
      unfold subtypePath.
      unfold adjoint_equivalence.
      etrans.
      {
        apply (@transportf_total2_paths_f
                 (pr1 hx --> pr1 hy)
                 left_adjoint_equivalence
                 (λ x, pr12 hx ==> x · pr12 hy)).
      }
      cbn.
      rewrite vassocr.
      rewrite rinvunitor_runitor.
      apply id2_left.
  Qed.

  Definition disp_adj_equiv_to_adj_equiv_to_disp_adj_equiv
             (HB : is_univalent_2 B)
             (HD : arrow_subbicat_props D)
             {x : B}
             {hx hy : disp_map_bicat_to_disp_bicat x}
             (z : disp_adjoint_equivalence
                    (internal_adjoint_equivalence_identity x)
                    hx hy)
    : disp_map_bicat_adj_equiv_to_disp_adj_equiv
        HB
        (disp_adj_equiv_to_adj_equiv z)
        (disp_adj_equiv_to_adj_equiv_comm z)
      =
      z.
  Proof.
    use subtypePath.
    {
      intro.
      use isaprop_disp_left_adjoint_equivalence.
      - exact (pr2 HB).
      - apply disp_map_disp_univalent_2_1.
        + exact HD.
        + exact (pr2 HB).
    }
    cbn.
    refine (maponpaths (λ z, _ ,, z) _).
    use pathsdirprod.
    - apply HD.
    - use subtypePath.
      {
        intro ; apply isaprop_is_invertible_2cell.
      }
      cbn.
      rewrite vassocr.
      rewrite runitor_rinvunitor.
      apply id2_left.
  Qed.

  Definition adj_equiv_weq_disp_adj_equiv
             (HB : is_univalent_2 B)
             (HD : arrow_subbicat_props D)
             {x : B}
             (hx hy : disp_map_bicat_to_disp_bicat x)
    : (∑ (e : adjoint_equivalence (pr1 hx) (pr1 hy)),
       invertible_2cell (pr12 hx) (e · pr12 hy))
      ≃
      disp_adjoint_equivalence (internal_adjoint_equivalence_identity x) hx hy.
  Proof.
    use make_weq.
    - exact (λ e, disp_map_bicat_adj_equiv_to_disp_adj_equiv HB (pr1 e) (pr2 e)).
    - use isweq_iso.
      + exact disp_map_bicat_disp_adj_equiv_to_adj_equiv_pair.
      + exact (adj_equiv_to_disp_adj_equiv_to_adj_equiv HB).
      + exact (disp_adj_equiv_to_adj_equiv_to_disp_adj_equiv HB HD).
  Defined.

  (**
   5. Global univalence
   *)
  Definition weq_fam_global
             (HB_2_1 : is_univalent_2_1 B)
             (HD : arrow_subbicat_props D)
             {x : B}
             (hx hy : disp_map_bicat_to_disp_bicat x)
             (p : pr1 hx = pr1 hy)
    : (transportf
         (λ z, ∑ (h : z --> x), pred_ob D h)
         p
         (pr2 hx)
       =
       pr2 hy)
      ≃
      invertible_2cell
        (pr12 hx)
        (pr1 (idtoiso_2_0 (pr1 hx) (pr1 hy) p) · pr12 hy).
  Proof.
    induction hx as [ hx₁ [ hx₂ hx₃ ] ].
    induction hy as [ hy₁ [ hy₂ hy₃ ] ].
    cbn in *.
    induction p ; cbn.
    refine (_ ∘ path_sigma_hprop _ _ _ _)%weq.
    - apply HD.
    - exact (cod_1cell_path_help hx₂ hy₂
             ∘ make_weq
                 _
                 (HB_2_1 _ _ _ _))%weq.
  Defined.

  Definition disp_map_bicat_disp_univalent_2_0
             (HB : is_univalent_2 B)
             (HD : arrow_subbicat_props D)
    : disp_univalent_2_0 disp_map_bicat_to_disp_bicat.
  Proof.
    use fiberwise_univalent_2_0_to_disp_univalent_2_0.
    intros x hx hy.
    use weqhomot.
    - exact (adj_equiv_weq_disp_adj_equiv HB HD hx hy
             ∘ weqtotal2
                 (make_weq _ (pr1 HB _ _))
                 (weq_fam_global (pr2 HB) HD _ _)
             ∘ total2_paths_equiv _ _ _)%weq.
    - intro p.
      cbn in p.
      induction p.
      use subtypePath.
      {
        intro.
        use isaprop_disp_left_adjoint_equivalence.
        - exact (pr2 HB).
        - apply disp_map_disp_univalent_2_1.
          + exact HD.
          + exact (pr2 HB).
      }
      cbn.
      refine (maponpaths (λ z, _ ,, z) _).
      use pathsdirprod.
      + apply HD.
      + use subtypePath.
        {
          intro ; apply isaprop_is_invertible_2cell.
        }
        cbn.
        rewrite id2_left.
        apply idpath.
  Qed.

  Definition disp_map_bicat_disp_univalent_2
             (HB : is_univalent_2 B)
             (HD : arrow_subbicat_props D)
    : disp_univalent_2 disp_map_bicat_to_disp_bicat.
  Proof.
    split.
    - apply disp_map_bicat_disp_univalent_2_0.
      + exact HB.
      + exact HD.
    - apply disp_map_disp_univalent_2_1.
      + exact HD.
      + exact (pr2 HB).
  Defined.
End ArrowSubBicatToDispBicat.

Definition cod_sfibs
           (B : bicat)
  : disp_bicat B
  := disp_map_bicat_to_disp_bicat (sfib_subbicat B).

Definition cod_sopfibs
           (B : bicat)
  : disp_bicat B
  := disp_map_bicat_to_disp_bicat (sopfib_subbicat B).


Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import Cover.
Require Import MemorySplit.
Require Import MemoryMerge.
Require Import FulfillStep.

Set Implicit Arguments.

Inductive message_same_kind: forall (msg_src msg_tgt: Message.t), Prop :=
| message_same_kind_non_reserve
    msg_src msg_tgt
    (MSG_SRC: msg_src <> Message.reserve)
    (MSG_TGT: msg_tgt <> Message.reserve):
    message_same_kind msg_src msg_tgt
| message_same_kind_reserve:
    message_same_kind Message.reserve Message.reserve
.
#[local] Hint Constructors message_same_kind: core.

Global Program Instance message_same_kind_Equivalence: Equivalence message_same_kind.
Next Obligation.
  ii. destruct x; eauto; econs 1; ss.
Qed.
Next Obligation.
  ii. inv H; eauto.
Qed.
Next Obligation.
  ii. inv H; inv H0; eauto.
Qed.

Lemma le_message_same_kind
      msg_src msg_tgt
      (LE: Message.le msg_src msg_tgt):
  message_same_kind msg_src msg_tgt.
Proof.
  inv LE; eauto; econs 1; ss.
Qed.

Inductive sim_memory (mem_src mem_tgt:Memory.t): Prop :=
| sim_memory_intro
    (COVER: forall loc ts, covered loc ts mem_src <-> covered loc ts mem_tgt)
    (MSG: forall loc from_tgt to msg_tgt
            (GET: Memory.get loc to mem_tgt = Some (from_tgt, msg_tgt)),
        exists from_src msg_src,
          <<GET: Memory.get loc to mem_src = Some (from_src, msg_src)>> /\
          <<MSG: Message.le msg_src msg_tgt>>)
    (RESERVE: forall loc from to,
        Memory.get loc to mem_src = Some (from, Message.reserve) <->
        Memory.get loc to mem_tgt = Some (from, Message.reserve))
.

Global Program Instance sim_memory_PreOrder: PreOrder sim_memory.
Next Obligation.
  econs; try refl. i. esplits; eauto. refl.
Qed.
Next Obligation.
  ii. inv H. inv H0. econs; try etrans; eauto. i.
  exploit MSG0; eauto. i. des.
  exploit MSG; eauto. i. des.
  esplits; eauto. etrans; eauto.
Qed.

Lemma sim_memory_get
      loc from_tgt to msg_tgt mem_src mem_tgt
      (SIM: sim_memory mem_src mem_tgt)
      (GET: Memory.get loc to mem_tgt = Some (from_tgt, msg_tgt)):
  exists from_src msg_src,
    <<GET: Memory.get loc to mem_src = Some (from_src, msg_src)>> /\
    <<MSG: Message.le msg_src msg_tgt>>.
Proof.
  eapply SIM. eauto.
Qed.

Lemma sim_memory_get_message_same_kind
      loc
      from_src to_src msg_src mem_src
      from_tgt to_tgt msg_tgt mem_tgt
      ts
      (SIM: sim_memory mem_src mem_tgt)
      (GET_SRC: Memory.get loc to_src mem_src = Some (from_src, msg_src))
      (GET_TGT: Memory.get loc to_tgt mem_tgt = Some (from_tgt, msg_tgt))
      (ITV_SRC: Interval.mem (from_src, to_src) ts)
      (ITV_TGT: Interval.mem (from_tgt, to_tgt) ts):
  message_same_kind msg_src msg_tgt.
Proof.
  destruct (classic (msg_src = Message.reserve));
    destruct (classic (msg_tgt = Message.reserve)); subst; eauto.
  - inv SIM. rewrite RESERVE in GET_SRC.
    exploit Memory.get_disjoint; [exact GET_SRC|exact GET_TGT|..]. i. des; try congr.
    exfalso. apply (x0 ts); auto.
  - inv SIM. rewrite <- RESERVE in GET_TGT.
    exploit Memory.get_disjoint; [exact GET_SRC|exact GET_TGT|..]. i. des; try congr.
    exfalso. apply (x0 ts); auto.
Qed.

Lemma sim_memory_get_inv
      loc from_src to_src msg_src mem_src
      mem_tgt
      (INHABITED_SRC: Memory.inhabited mem_src)
      (INHABITED_TGT: Memory.inhabited mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (GET_SRC: Memory.get loc to_src mem_src = Some (from_src, msg_src)):
  exists from_tgt to_tgt msg_tgt,
    <<FROM: Time.le from_tgt from_src>> /\
    <<TO: Time.le to_src to_tgt>> /\
    <<GET_TGT: Memory.get loc to_tgt mem_tgt = Some (from_tgt, msg_tgt)>> /\
    <<MSG: message_same_kind msg_src msg_tgt>>.
Proof.
  destruct (Time.eq_dec to_src Time.bot).
  { subst. rewrite INHABITED_SRC in GET_SRC. inv GET_SRC.
    esplits; try refl. apply INHABITED_TGT. }
  dup SIM. inv SIM0. dup COVER. specialize (COVER0 loc to_src). des.
  exploit COVER0.
  { econs; eauto. econs; try refl.
    exploit Memory.get_ts; eauto. i. des; subst; timetac. }
  intros x. dup x. inv x0. esplits; eauto.
  - destruct (Time.le_lt_dec from from_src); ss.
    dup COVER. specialize (COVER2 loc from). des. exploit COVER2.
    { econs; eauto.
      exploit Memory.get_ts; try exact GET_SRC. i. des; ss.
      inv ITV. econs; eauto. econs. ss. }
    intros x0. inv x0.
    destruct (Time.eq_dec to0 from).
    + subst. exploit MSG; try exact GET0. i. des.
      exploit Memory.get_disjoint; [exact GET_SRC|exact GET1|..]. i. des.
      * subst. inv ITV. timetac.
      * exfalso. apply (x1 from).
        { inv ITV. econs; eauto. s. econs; eauto. }
        { econs; try refl. s.
          exploit Memory.get_ts; try exact GET1. i. des; ss.
          subst. inv ITV0. inv FROM. }
    + exploit Memory.get_disjoint; [exact GET|exact GET0|..]. i. des.
      * subst. inv ITV0. timetac.
      * exfalso. destruct (Time.le_lt_dec to to0).
        { apply (x1 to).
          - econs; try refl.
            exploit Memory.get_ts; try exact GET. i. des; ss.
            subst. inv ITV0. inv FROM.
          - econs; eauto. inv ITV0. ss.
            exploit Memory.get_ts; try exact GET. i. des; ss.
            + subst. inv l.
            + eapply TimeFacts.lt_le_lt; eauto. econs; eauto. }
        { apply (x1 to0).
          - inv ITV0. econs; ss.
            + inv TO; ss. inv H. congr.
            + econs. ss.
          - econs; try refl.
            exploit Memory.get_ts; try exact GET0. i. des; ss.
            subst. inv ITV0. ss. inv TO; inv H. inv FROM. }
  - inv ITV. ss.
  - eapply sim_memory_get_message_same_kind; eauto.
    exploit Memory.get_ts; try exact GET_SRC. i. des; try congr.
    econs; eauto. refl.
Qed.

Lemma sim_memory_max_ts
      mem_src mem_tgt loc
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt):
  Memory.max_ts loc mem_src = Memory.max_ts loc mem_tgt.
Proof.
  inv SIM. inv CLOSED_SRC. inv CLOSED_TGT.
  clear MSG RESERVE CLOSED CLOSED0.
  apply TimeFacts.antisym.
  - specialize (COVER loc (Memory.max_ts loc mem_src)). des.
    exploit Memory.max_ts_spec; try eapply (INHABITED loc). i. des.
    exploit Memory.get_ts; eauto. i. des.
    { rewrite x1. apply Time.bot_spec. }
    exploit COVER.
    { econs; eauto. econs; eauto. refl. }
    intros x. inv x. exploit Memory.max_ts_spec; try exact GET0. i. des.
    inv ITV. ss. etrans; eauto.
  - specialize (COVER loc (Memory.max_ts loc mem_tgt)). des.
    exploit Memory.max_ts_spec; try eapply (INHABITED0 loc). i. des.
    exploit Memory.get_ts; eauto. i. des.
    { rewrite x1. apply Time.bot_spec. }
    exploit COVER0.
    { econs; eauto. econs; eauto. refl. }
    intros x. inv x. exploit Memory.max_ts_spec; try exact GET0. i. des.
    inv ITV. ss. etrans; eauto.
Qed.

(* TODO: remove max_concrete *)

(* Lemma sim_memory_max_concrete_ts *)
(*       mem_src mem_tgt *)
(*       loc mts_src mts_tgt *)
(*       (SIM: sim_memory mem_src mem_tgt) *)
(*       (CLOSED_SRC: Memory.closed mem_src) *)
(*       (CLOSED_TGT: Memory.closed mem_tgt) *)
(*       (MAX_SRC: Memory.max_concrete_ts mem_src loc mts_src) *)
(*       (MAX_TGT: Memory.max_concrete_ts mem_tgt loc mts_tgt): *)
(*   mts_src = mts_tgt. *)
(* Proof. *)
(*   apply TimeFacts.antisym. *)
(*   - inv MAX_SRC. des. *)
(*     exploit sim_memory_get_inv; eauto. *)
(*     { apply CLOSED_SRC. } *)
(*     { apply CLOSED_TGT. } *)
(*     i. des. inv MSG. *)
(*     exploit Memory.max_concrete_ts_spec; eauto. i. des. *)
(*     etrans; eauto. *)
(*   - inv MAX_TGT. des. *)
(*     inv SIM. exploit MSG; eauto. i. des. inv MSG0. *)
(*     exploit Memory.max_concrete_ts_spec; eauto. i. des. ss. *)
(* Qed. *)

(* Lemma sim_memory_max_concrete_timemap *)
(*       mem_src mem_tgt mtm_src mtm_tgt *)
(*       (CLOSED_SRC: Memory.closed mem_src) *)
(*       (CLOSED_TGT: Memory.closed mem_tgt) *)
(*       (SIM: sim_memory mem_src mem_tgt) *)
(*       (MAX_SRC: Memory.max_concrete_timemap mem_src mtm_src) *)
(*       (MAX_TGT: Memory.max_concrete_timemap mem_tgt mtm_tgt): *)
(*   mtm_src = mtm_tgt. *)
(* Proof. *)
(*   extensionality loc. *)
(*   specialize (MAX_SRC loc). *)
(*   specialize (MAX_TGT loc). *)
(*   eapply sim_memory_max_concrete_ts; eauto. *)
(* Qed. *)

(* Lemma sim_memory_max_concrete_view *)
(*       mem_src mem_tgt mview_src mview_tgt *)
(*       (CLOSED_SRC: Memory.closed mem_src) *)
(*       (CLOSED_TGT: Memory.closed mem_tgt) *)
(*       (SIM: sim_memory mem_src mem_tgt) *)
(*       (MAX_SRC: Memory.max_concrete_view mem_src mview_src) *)
(*       (MAX_TGT: Memory.max_concrete_view mem_tgt mview_tgt): *)
(*   mview_src = mview_tgt. *)
(* Proof. *)
(*   inv MAX_SRC. inv MAX_TGT. *)
(*   exploit sim_memory_max_concrete_timemap; try exact SIM; eauto. i. *)
(*   subst. ss. *)
(* Qed. *)

Lemma split_sim_memory
      mem0 loc ts1 ts2 ts3 val2 released2 val3 released3 mem1
      (SPLIT: Memory.split mem0 loc ts1 ts2 ts3 (Message.concrete val2 released2) (Message.concrete val3 released3) mem1):
  sim_memory mem1 mem0.
Proof.
  econs; i.
  - eapply split_covered. eauto.
  - exploit Memory.split_get0; eauto. i. des.
    erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. congr.
    + guardH o. des. subst. rewrite GET1 in GET. inv GET.
      esplits; eauto. refl.
    + esplits; eauto. refl.
  - exploit Memory.split_get0; eauto. i. des.
    erewrite Memory.split_o; eauto.
    repeat condtac; ss; split; i; try congr.
    + des. subst. rewrite GET in H. inv H.
    + guardH o. des. subst. rewrite GET0 in H. inv H.
Qed.

Lemma lower_sim_memory
      mem1 loc from to msg1 msg2 mem2
      (LOWER: Memory.lower mem1 loc from to msg1 msg2 mem2):
  sim_memory mem2 mem1.
Proof.
  econs; i.
  - eapply lower_covered. eauto.
  - i. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst.
      exploit Memory.lower_get0; eauto. i. des.
      rewrite GET0 in GET. inv GET.
      inv MSG_LE; esplits; eauto.
    + esplits; eauto. refl.
  - split; i.
    + revert H. erewrite Memory.lower_o; eauto. condtac; ss.
      i. des. subst. inv H. inv LOWER. inv LOWER0. inv MSG_LE.
      unfold Memory.get, Cell.get. rewrite GET2. ss.
    + erewrite Memory.lower_o; eauto. condtac; ss.
      des. subst. inv LOWER. inv LOWER0.
      unfold Memory.get, Cell.get in H. rewrite H in GET2. inv GET2.
      inv MSG_LE. ss.
Qed.

Lemma promise_lower_sim_memory
      promises1 mem1 loc from to msg1 msg2 promises2 mem2
      (PROMISE: Memory.promise promises1 mem1 loc from to msg2 promises2 mem2 (Memory.op_kind_lower msg1)):
  sim_memory mem2 mem1.
Proof.
  inv PROMISE. eapply lower_sim_memory; eauto.
Qed.

Lemma sim_memory_add
      mem1_src mem1_tgt msg_src
      mem2_src mem2_tgt msg_tgt
      loc from to
      (MSG: Message.le msg_src msg_tgt)
      (SRC: Memory.add mem1_src loc from to msg_src mem2_src)
      (TGT: Memory.add mem1_tgt loc from to msg_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs; i.
  - rewrite add_covered; [|eauto]. rewrite (@add_covered mem2_tgt); [|eauto].
    econs; i; des; (try by right).
    + left. eapply COVER. eauto.
    + left. eapply COVER. eauto.
  - revert GET. erewrite Memory.add_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.add_o; eauto. condtac; ss.
    + erewrite (@Memory.add_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.add_o in H; try exact SRC.
      erewrite Memory.add_o; try exact TGT. condtac; ss.
      * des. subst. inv H. inv MSG. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.add_o in H; try exact TGT.
      erewrite Memory.add_o; try exact SRC. condtac; ss.
      * des. subst. inv H. inv MSG. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_split
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc ts1 ts2 ts3 msg2_src msg3_src msg2_tgt msg3_tgt
      (MSG: Message.le msg2_src msg2_tgt)
      (SRC: Memory.split mem1_src loc ts1 ts2 ts3 msg2_src msg3_src mem2_src)
      (TGT: Memory.split mem1_tgt loc ts1 ts2 ts3 msg2_tgt msg3_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs; i.
  - rewrite split_covered; [|eauto]. rewrite (@split_covered mem2_tgt); [|eauto].
    apply COVER.
  - revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.split_o; eauto. condtac; ss.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss.
      i. inv GET. guardH o. guardH o0. des. subst.
      exploit Memory.split_get0; try exact SRC; eauto. i. des.
      exploit Memory.split_get0; try exact TGT; eauto. i. des.
      exploit MSG0; eauto. i. des. rewrite GET0 in GET7. inv GET7.
      esplits; eauto.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss. eauto.
  - split; i.
    + erewrite Memory.split_o in H; try exact SRC.
      erewrite Memory.split_o; try exact TGT. repeat condtac; ss.
      * des. subst. inv H. inv MSG. ss.
      * guardH o. des. subst. inv H.
        exploit Memory.split_get0; try exact SRC. i. des.
        exploit Memory.split_get0; try exact TGT. i. des.
        rewrite RESERVE in GET0. rewrite GET0 in GET4. inv GET4. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.split_o in H; try exact TGT.
      erewrite Memory.split_o; try exact SRC. repeat condtac; ss.
      * des. subst. inv H. inv MSG. ss.
      * guardH o. des. subst. inv H.
        exploit Memory.split_get0; try exact SRC. i. des.
        exploit Memory.split_get0; try exact TGT. i. des.
        rewrite <- RESERVE in GET4. rewrite GET0 in GET4. inv GET4. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_lower
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc from to msg1_src msg2_src msg1_tgt msg2_tgt
      (MSG: Message.le msg2_src msg2_tgt)
      (SRC: Memory.lower mem1_src loc from to msg1_src msg2_src mem2_src)
      (TGT: Memory.lower mem1_tgt loc from to msg1_tgt msg2_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  dup SIM. inv SIM0. econs; i.
  - rewrite lower_covered; [|eauto]. rewrite (@lower_covered mem2_tgt); [|eauto].
    apply COVER.
  - revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.lower_o; eauto. condtac; ss.
    + erewrite (@Memory.lower_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.lower_o in H; try exact SRC.
      erewrite Memory.lower_o; try exact TGT. condtac; ss.
      * des. subst. inv H. inv MSG. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.lower_o in H; try exact TGT.
      erewrite Memory.lower_o; try exact SRC. condtac; ss.
      * des. subst. inv H. inv MSG. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_remove
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc from to msg_src msg_tgt
      (SRC: Memory.remove mem1_src loc from to msg_src mem2_src)
      (TGT: Memory.remove mem1_tgt loc from to msg_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  dup SIM. inv SIM0. econs; i.
  - rewrite remove_covered; [|eauto]. rewrite (@remove_covered mem2_tgt); [|eauto].
    rewrite COVER. refl.
  - revert GET. erewrite Memory.remove_o; eauto. condtac; ss.
    erewrite (@Memory.remove_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.remove_o in H; try exact SRC.
      erewrite Memory.remove_o; try exact TGT. condtac; ss.
      rewrite <- RESERVE. ss.
    + erewrite Memory.remove_o in H; try exact TGT.
      erewrite Memory.remove_o; try exact SRC. condtac; ss.
      rewrite RESERVE. ss.
Qed.

Lemma sim_memory_closed_timemap
      mem_src mem_tgt
      tm
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_timemap tm mem_tgt):
  Memory.closed_timemap tm mem_src.
Proof.
  ii. exploit TGT; eauto. i. des.
  exploit sim_memory_get; eauto. i. des.
  inv MSG. eauto.
Qed.

Lemma sim_memory_closed_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_view view mem_tgt):
  Memory.closed_view view mem_src.
Proof.
  econs.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
Qed.

Lemma sim_memory_closed_opt_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_opt_view view mem_tgt):
  Memory.closed_opt_view view mem_src.
Proof.
  inv TGT; econs. eapply sim_memory_closed_view; eauto.
Qed.

Lemma sim_memory_closed_message
      mem_src mem_tgt
      msg
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_message msg mem_tgt):
  Memory.closed_message msg mem_src.
Proof.
  inv TGT; ss. econs. eapply sim_memory_closed_opt_view; eauto.
Qed.

(* cap *)

Lemma sim_memory_adjacent_src
      mem_src mem_tgt
      loc from1 to1 from2 to2
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (ADJ: Memory.adjacent loc from1 to1 from2 to2 mem_src)
      (TS: Time.lt to1 from2):
  exists from1' to2',
    Memory.adjacent loc from1' to1 from2 to2' mem_tgt.
Proof.
  dup SIM. inv SIM0. inv ADJ. clear RESERVE TS0.
  assert (GET1_TGT: exists from1' m1', Memory.get loc to1 mem_tgt = Some (from1', m1')).
  { exploit Memory.get_ts; try exact GET1. i. des.
    { subst. esplits. eapply CLOSED_TGT. }
    destruct (COVER loc to1). exploit H.
    { econs; try exact GET1. econs; eauto. refl. }
    intros x. inv x. inv ITV. ss. inv TO; cycle 1.
    { inv H1. esplits; eauto. }
    exfalso.
    destruct (Time.le_lt_dec to from2).
    { exploit MSG; eauto. i. des.
      exploit (EMPTY to); eauto. i. congr. }
    destruct (COVER loc from2). exploit H3.
    { econs; eauto. econs; ss.
      - etrans; eauto.
      - econs; ss.
    }
    intros x. inv x. inv ITV. ss. inv TO.
    - exploit Memory.get_ts; try exact GET2. i. des.
      { subst. inv FROM0. }
      exploit Memory.get_ts; try exact GET0. i. des.
      { subst. inv H4. }
      exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
      { timetac. }
      destruct (Time.le_lt_dec to2 to0).
      + apply (x3 to2); econs; ss; try refl.
        etrans; try exact FROM0. ss.
      + apply (x3 to0); econs; ss; try refl.
        econs. ss.
    - inv H4. exploit (EMPTY to0); eauto; try refl. i. congr.
  }
  assert (GET2_TGT: exists to2' m2', Memory.get loc to2' mem_tgt = Some (from2, m2')).
  { exploit Memory.get_ts; try exact GET2. i. des.
    { subst. inv TS. }
    exploit Memory.max_ts_spec; try exact GET2. i. des.
    clear from msg GET.
    erewrite sim_memory_max_ts in MAX; eauto.
    exploit TimeFacts.lt_le_lt; try exact x0; try exact MAX. i.
    exploit Memory.next_exists; try exact x1; try eapply CLOSED_TGT. i. des.
    destruct (TimeFacts.le_lt_dec from from2).
    - inv l; cycle 1.
      { inv H. esplits; eauto. }
      destruct (COVER loc from2). exploit H1.
      { econs; try exact x2. econs; ss. econs; ss. }
      intros x. inv x. inv ITV. ss. inv TO; cycle 1.
      { inv H2. exploit (EMPTY to0); eauto; try refl. i. congr. }
      exploit Memory.get_disjoint; [exact GET2|exact GET|..]. i. des.
      { subst. timetac. }
      exfalso.
      destruct (TimeFacts.le_lt_dec to2 to0).
      + apply (x5 to2); econs; ss; try refl.
        etrans; try exact FROM. ss.
      + apply (x5 to0); econs; ss; try refl.
        * econs. ss.
        * etrans; eauto.
    - destruct (TimeFacts.le_lt_dec to2 from).
      + destruct (COVER loc to2). exploit H.
        { econs; eauto. econs; ss. refl. }
        intros x. inv x. inv ITV. ss.
        exploit (x4 to0); eauto; try congr.
        { eapply TimeFacts.lt_le_lt; try exact TO; ss. }
        destruct (Time.le_lt_dec to to0); ss.
        exploit Memory.get_ts; try exact x2. i. des.
        { subst. inv x3. }
        exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
        { subst. timetac. }
        exfalso.
        apply (x6 to); econs; ss; try refl.
        etrans; try exact FROM.
        eapply TimeFacts.le_lt_lt; try exact x5. ss.
      + destruct (COVER loc from). exploit H.
        { econs; try exact GET2. econs; ss. econs. ss. }
        intros x. inv x. inv ITV. ss.
        destruct (TimeFacts.le_lt_dec to to0).
        * exploit Memory.get_ts; try exact x2. i. des.
          { subst. inv x3. }
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. timetac. }
          exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
          { subst. timetac. }
          exfalso.
          apply (x7 to); econs; ss; try refl.
          eapply TimeFacts.lt_le_lt; try exact FROM. econs. ss.
        * exploit (x4 to0); ss; try congr.
          eapply TimeFacts.lt_le_lt; try exact TO; ss.
  }
  des. esplits. econs; eauto; i.
  { exploit Memory.get_ts; try exact GET2_TGT. i. des.
    - subst. inv TS.
    - etrans; eauto. }
  destruct (Memory.get loc ts mem_tgt) as [[]|] eqn:GET; ss.
  exfalso.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv TS1. }
  destruct (COVER loc ts). exploit H0.
  { econs; eauto. econs; ss. refl. }
  intros x. inv x. inv ITV. ss.
  destruct (TimeFacts.le_lt_dec to from2).
  { exploit (EMPTY to); try congr.
    eapply TimeFacts.lt_le_lt; try exact TS1. ss. }
  exploit Memory.get_ts; try exact GET2. i. des.
  { subst. inv TS. }
  exploit Memory.get_ts; try exact GET0. i. des.
  { subst. inv l. }
  exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
  { subst. timetac. }
  destruct (TimeFacts.le_lt_dec to2 to).
  - apply (x3 to2); econs; ss; try refl.
    etrans; try exact x1.
    eapply TimeFacts.lt_le_lt; try exact TS2. ss.
  - apply (x3 to); econs; ss; try refl. econs. ss.
Qed.

Lemma sim_memory_adjacent_tgt
      mem_src mem_tgt
      loc from1 to1 from2 to2
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (ADJ: Memory.adjacent loc from1 to1 from2 to2 mem_tgt)
      (TS: Time.lt to1 from2):
  exists from1' to2',
    Memory.adjacent loc from1' to1 from2 to2' mem_src.
Proof.
  dup SIM. inv SIM0. inv ADJ. clear RESERVE TS0.
  assert (GET1_SRC: exists from1' m1', Memory.get loc to1 mem_src = Some (from1', m1')).
  { exploit MSG; try exact GET1. i. des. eauto. }
  assert (GET2_SRC: exists to2' m2', Memory.get loc to2' mem_src = Some (from2, m2')).
  { exploit Memory.get_ts; try exact GET2. i. des.
    { subst. inv TS. }
    exploit Memory.max_ts_spec; try exact GET2. i. des.
    clear from msg GET.
    erewrite <- sim_memory_max_ts in MAX; eauto.
    exploit TimeFacts.lt_le_lt; try exact x0; try exact MAX. i.
    exploit Memory.next_exists; try exact x1; try eapply CLOSED_SRC. i. des.
    destruct (TimeFacts.le_lt_dec from from2).
    - inv l; cycle 1.
      { inv H. esplits; eauto. }
      destruct (COVER loc from2). exploit H0.
      { econs; try exact x2. econs; ss. econs; ss. }
      intros x. inv x. inv ITV. ss. inv TO; cycle 1.
      { inv H2. exploit (EMPTY to0); eauto; try refl. i. congr. }
      exploit Memory.get_disjoint; [exact GET2|exact GET|..]. i. des.
      { subst. timetac. }
      exfalso.
      destruct (TimeFacts.le_lt_dec to2 to0).
      + apply (x5 to2); econs; ss; try refl.
        etrans; try exact FROM. ss.
      + apply (x5 to0); econs; ss; try refl.
        * econs. ss.
        * etrans; eauto.
    - destruct (TimeFacts.le_lt_dec to2 from).
      + destruct (COVER loc to2). exploit H0.
        { econs; eauto. econs; ss. refl. }
        intros x. inv x. inv ITV. ss.
        exploit (x4 to0); eauto; try congr.
        { eapply TimeFacts.lt_le_lt; try exact TO; ss. }
        destruct (Time.le_lt_dec to to0); ss.
        exploit Memory.get_ts; try exact x2. i. des.
        { subst. inv x3. }
        exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
        { subst. timetac. }
        exfalso.
        apply (x6 to); econs; ss; try refl.
        etrans; try exact FROM.
        eapply TimeFacts.le_lt_lt; try exact x5. ss.
      + destruct (COVER loc from). exploit H0.
        { econs; try exact GET2. econs; ss. econs. ss. }
        intros x. inv x. inv ITV. ss.
        destruct (TimeFacts.le_lt_dec to to0).
        * exploit Memory.get_ts; try exact x2. i. des.
          { subst. inv x3. }
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. timetac. }
          exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
          { subst. timetac. }
          exfalso.
          apply (x7 to); econs; ss; try refl.
          eapply TimeFacts.lt_le_lt; try exact FROM. econs. ss.
        * exploit (x4 to0); ss; try congr.
          eapply TimeFacts.lt_le_lt; try exact TO; ss.
  }
  des. esplits. econs; eauto; i.
  { exploit Memory.get_ts; try exact GET2_SRC. i. des.
    - subst. inv TS.
    - etrans; eauto. }
  destruct (Memory.get loc ts mem_src) as [[]|] eqn:GET; ss.
  exfalso.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv TS1. }
  destruct (COVER loc ts). exploit H.
  { econs; eauto. econs; ss. refl. }
  intros x. inv x. inv ITV. ss.
  destruct (TimeFacts.le_lt_dec to from2).
  { exploit (EMPTY to); try congr.
    eapply TimeFacts.lt_le_lt; try exact TS1. ss. }
  exploit Memory.get_ts; try exact GET2. i. des.
  { subst. inv TS. }
  exploit Memory.get_ts; try exact GET0. i. des.
  { subst. inv l. }
  exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
  { subst. timetac. }
  destruct (TimeFacts.le_lt_dec to2 to).
  - apply (x3 to2); econs; ss; try refl.
    etrans; try exact x1.
    eapply TimeFacts.lt_le_lt; try exact TS2. ss.
  - apply (x3 to); econs; ss; try refl. econs. ss.
Qed.

Lemma sim_memory_cap_get_src
      mem1_src mem2_src
      mem1_tgt mem2_tgt
      loc from to msg
      (MEM1: sim_memory mem1_src mem1_tgt)
      (CAP_SRC: Memory.cap mem1_src mem2_src)
      (CAP_TGT: Memory.cap mem1_tgt mem2_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (GET1_SRC: Memory.get loc to mem1_src = None)
      (GET2_SRC: Memory.get loc to mem2_src = Some (from, msg)):
  <<MSG: msg = Message.reserve>> /\
  <<GET1_TGT: Memory.get loc to mem1_tgt = None>> /\
  <<GET2_TGT: Memory.get loc to mem2_tgt = Some (from, msg)>>.
Proof.
  exploit Memory.cap_inv; try exact CAP_SRC; eauto. i. des; try congr.
  - subst.
    exploit sim_memory_adjacent_src; try exact x1; eauto. i. des.
    inv CAP_TGT. exploit MIDDLE; eauto. i. splits; auto.
    inv x3. apply EMPTY; eauto. refl.
  - subst.
    erewrite sim_memory_max_ts; eauto.
    inv CAP_TGT. splits; auto.
    destruct (Memory.get loc (Time.incr (Memory.max_ts loc mem1_tgt)) mem1_tgt) as [[]|] eqn:MAX; ss.
    exploit Memory.max_ts_spec; eauto. i. des.
    specialize (Time.incr_spec (Memory.max_ts loc mem1_tgt)). i. timetac.
Qed.

Lemma sim_memory_cap_get_tgt
      mem1_src mem2_src
      mem1_tgt mem2_tgt
      loc from to msg
      (MEM1: sim_memory mem1_src mem1_tgt)
      (CAP_SRC: Memory.cap mem1_src mem2_src)
      (CAP_TGT: Memory.cap mem1_tgt mem2_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (GET1_TGT: Memory.get loc to mem1_tgt = None)
      (GET2_TGT: Memory.get loc to mem2_tgt = Some (from, msg)):
  <<MSG: msg = Message.reserve>> /\
  <<GET1_SRC: Memory.get loc to mem1_src = None>> /\
  <<GET2_SRC: Memory.get loc to mem2_src = Some (from, msg)>>.
Proof.
  exploit Memory.cap_inv; try exact CAP_TGT; eauto. i. des; try congr.
  - subst.
    exploit sim_memory_adjacent_tgt; try exact x1; eauto. i. des.
    inv CAP_SRC. exploit MIDDLE; eauto. i. splits; auto.
    inv x3. apply EMPTY; eauto. refl.
  - subst.
    erewrite <- sim_memory_max_ts; eauto.
    inv CAP_SRC. splits; auto.
    destruct (Memory.get loc (Time.incr (Memory.max_ts loc mem1_src)) mem1_src) as [[]|] eqn:MAX; ss.
    exploit Memory.max_ts_spec; eauto. i. des.
    specialize (Time.incr_spec (Memory.max_ts loc mem1_src)). i. timetac.
Qed.

Lemma sim_memory_cap
      mem1_src mem2_src
      mem1_tgt mem2_tgt
      (MEM1: sim_memory mem1_src mem1_tgt)
      (CAP_SRC: Memory.cap mem1_src mem2_src)
      (CAP_TGT: Memory.cap mem1_tgt mem2_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  econs; i; try split; i.
  - inv H.
    destruct (Memory.get loc to mem1_src) as [[]|] eqn:GET1.
    + inv CAP_SRC. exploit SOUND; eauto. intros x.
      rewrite x in GET. inv GET.
      eapply cap_covered; eauto.
      inv MEM1. rewrite <- COVER.
      econs; eauto.
    + exploit sim_memory_cap_get_src; eauto. i. des.
      econs; eauto.
  - inv H.
    destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
    + inv CAP_TGT. exploit SOUND; eauto. intros x.
      rewrite x in GET. inv GET.
      eapply cap_covered; eauto.
      inv MEM1. rewrite COVER.
      econs; eauto.
    + exploit sim_memory_cap_get_tgt; eauto. i. des.
      econs; eauto.
  - destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
    + inv CAP_TGT. exploit SOUND; eauto. intros x.
      rewrite x in GET. inv GET.
      inv MEM1. exploit MSG; eauto. i. des.
      inv CAP_SRC. exploit SOUND; eauto. i.
      esplits; eauto.
    + exploit sim_memory_cap_get_tgt; eauto. i. des.
      esplits; eauto. refl.
  - destruct (Memory.get loc to mem1_src) as [[]|] eqn:GET1.
    + inv CAP_SRC. exploit SOUND; eauto. intros x.
      rewrite x in H. inv H.
      inv MEM1. rewrite RESERVE in GET1.
      inv CAP_TGT. exploit SOUND0; eauto.
    + exploit sim_memory_cap_get_src; eauto. i. des. auto.
  - destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
    + inv CAP_TGT. exploit SOUND; eauto. intros x.
      rewrite x in H. inv H.
      inv MEM1. rewrite <- RESERVE in GET1.
      inv CAP_SRC. exploit SOUND0; eauto.
    + exploit sim_memory_cap_get_tgt; eauto. i. des. auto.
Qed.

(* fulfill_step *)

Lemma fulfill_write_sim_memory
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2
      (FULFILL: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem1)
      (ORD: Ordering.le ord Ordering.relaxed)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1):
  exists released' mem2',
    <<STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released' ord lc2 sc2 mem2' (Memory.op_kind_lower (Message.concrete val released))>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem1>>.
Proof.
  inv FULFILL.
  exploit TViewFacts.write_future_fulfill;
    try exact REL_CLOSED; try exact SC1; eauto; try by apply WF1.
  { apply WF1. eapply Memory.remove_get0. eauto. }
  i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; (try by econs; try exact REL_LE; try refl); eauto;
      try eapply WF1; try by econs; eauto.
  { econs. inv REL_LE; try apply Time.bot_spec.
    cut (Time.le (View.rlx (View.unwrap (Some lhs)) loc)
                 (View.rlx (View.unwrap (Some rhs)) loc)).
    { i. etrans; eauto.
      cut (Memory.message_to (Message.concrete val (Some rhs)) loc to).
      { i. inv H1. auto. }
      eapply MEM1. apply WF1. eapply Memory.remove_get0. eauto. }
    destruct lhs; destruct rhs; inv LE; ss. }
  i. des.
  esplits; eauto.
  - econs; eauto.
    i. destruct ord; inv ORD; inv H.
  - eapply promise_lower_sim_memory; eauto.
Qed.

Lemma promise_fulfill_write_sim_memory
      lc0 sc0 mem0 loc from to val releasedm released ord lc1 lc2 sc2 mem2 kind
      (PROMISE: Local.promise_step lc0 mem0 loc from to (Message.concrete val released) lc1 mem2 kind)
      (FULFILL: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (ORD: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc0))
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0):
  exists released' mem2',
    <<STEP: Local.write_step lc0 sc0 mem0 loc from to val releasedm released' ord lc2 sc2 mem2' kind>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem2>> /\
    <<REL: released' = TView.write_released (Local.tview lc0) sc0 loc to releasedm ord>>.
Proof.
  exploit Local.promise_step_future; eauto. i. des.
  inv PROMISE. inv FULFILL. ss.
  exploit TViewFacts.write_future_fulfill; try exact REL_WF; eauto; try by apply WF2.
  { eapply Memory.future_closed_opt_view; eauto. }
  { eapply Memory.promise_get2; eauto. inv PROMISE0; ss. }
  s. i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; (try by econs; try exact REL_LE; try refl); eauto;
      try apply WF2; try by econs; eauto.
  { econs. inv REL_LE; try apply Time.bot_spec.
    cut (Time.le (View.rlx (View.unwrap (Some lhs)) loc)
                 (View.rlx (View.unwrap (Some rhs)) loc)).
    { i. etrans; eauto.
      cut (Memory.message_to (Message.concrete val (Some rhs)) loc to).
      { i. inv H1. auto. }
      eapply CLOSED2. apply WF2. eapply Memory.remove_get0. eauto. }
    destruct lhs; destruct rhs; inv LE; ss. }
  i. des.
  esplits; eauto.
  - econs; eauto. econs; eauto.
    eapply MemoryMerge.promise_promise_promise; eauto.
  - eapply promise_lower_sim_memory; eauto.
Qed.


From Formalisation Require Import Nom ProgramLogic Inject Monotone.
From Formalisation Require Import EquationalTheory.

Section adequacy.

  Context {atom : Type}.

  Definition NomG := @NomG atom.

  Class Sound {X} (run : MonSem X) (e : NomG X) :=
    mk_sound {
        mono : Monotone run;
        sound : forall s sres v Q,
          run s = Res (sres, v) ->
            ⊢ wp e (fun v => <absorb> Q v) -∗
              injectSL (pos s) (pos sres) -∗ <absorb> Q v
      }.

  Lemma bind_soundness : forall X (e : NomG X) rune Y (k : X -> NomG Y) runk,
      Sound rune e ->
      (forall v, Sound (runk v) (k v)) ->
      Sound (run_bind rune runk) (let! v := e in
                                  k v).
  Proof.
    intros X e rune Y k runk [mono_e sound_e] sound_k.
    constructor. eapply bind_mono. eapply mono_e. intro. eapply (sound_k x).
    intros s sres v Q RUN.
    iIntros "wp HA". unfold_MonSem. destruct (rune s) as [[s_res res]| |] eqn:P.
    pose P as grow_e. eapply mono_e in grow_e as [P0 _].
    pose RUN as grow_k. eapply sound_k in grow_k as [P1 _].
    unfold injectSL. rewrite (inject_union (pos s_res)). 2-3 : lia.
    iDestruct (big_sepS_union with "HA") as "[HA HB]". eapply inject_disjoint.
    destruct (sound_k res) as [mono_k wp_k].
    iDestruct (bind_wp with "wp") as "wp".
    iDestruct (sound_e with "[wp] HA") as ">HA". eapply P.
    iApply (wp_consequence with "wp"). iIntros (v0) "HA". iApply "HA".
    iApply (wp_k with "HA HB"); auto. all : inversion RUN.
  Qed.

  Lemma ret_soundness : forall X x,
      @Sound X (Nom.run_ret x) (ret x).
  Proof.
    intros. constructor. eapply ret_mono.
    intros. inversion H. iIntros "HA HB". iApply "HA".
  Qed.

  Lemma fail_soundness : forall X,
      @Sound X run_fail fail.
  Proof. intros. constructor. eapply fail_mono. intros. inversion H. Qed.

  Lemma length_soundness : Sound run_length Nom.length.
  Proof.
    constructor. eapply length_mono.
    intros. simpl in *. iIntros "HA HB". iApply "HA".
  Qed.

  Lemma read_soundness : forall s n a, Sound (run_read s n a) (Nom.read s n).
  Proof.
    constructor. eapply read_mono.
    intros. simpl in *. iIntros "HA HB". iApply "HA".
  Qed.

  Lemma incl_exists `{count : Countable X} : forall (s1 s2 : gset X),
      s1 ⊆ s2 -> ∃ s3, s1 ∪ s3 = s2 /\ s1 ## s3.
  Proof.
    induction s1 as [| y Y not_in IH] using set_ind_L.
    - intros. exists s2. split. rewrite union_empty_l_L. reflexivity. apply disjoint_empty_l.
    - intros. apply union_subseteq in H as [P0 P1].
      apply IH in P1 as [s3 P2].
      exists (s3 ∖ {[y]}). destruct P2 as [P2 P4].
      rewrite <- P2.
      rewrite <- union_assoc_L. rewrite union_comm_L. rewrite <- union_assoc_L. split.
      + f_equal. rewrite difference_union_L. rewrite union_comm_L.
        destruct (subseteq_union_L {[y]} s3). apply H. clear H H0. intros x P3. inversion P3.
        apply lookup_singleton_Some in H0 as [H0 _]. subst.
        apply elem_of_subseteq_singleton in P0.
        apply elem_of_union in P0. destruct P0; auto.
        apply not_in in H. exfalso. apply H.
      + apply disjoint_union_l. split.
        * apply disjoint_difference_r1. auto.
        * apply disjoint_difference_r2. auto.
  Qed.

  Lemma take_soundness_2 : forall n s s_res res,
      run_take n s = Res (s_res, res) ->
      inject (pos res) (pos res + len res) ⊆ inject (pos s) (pos s_res).
  Proof.
    unfold run_take. unfold_MonSem. intros. destruct (n <=? len s) eqn:P.
    - inversion_clear H. simpl. reflexivity.
    - inversion H.
  Qed.

  Lemma take_soundness : forall n, Sound (run_take n) (Nom.take n).
  Proof.
    intros. constructor. apply take_mono.
    simpl. intros. iIntros "wp HA".
    eapply take_soundness_2 in H. unfold injectSL.
    eapply incl_exists in H as [set_diff [P4 P5]]. rewrite <- P4.
    iDestruct (big_sepS_union with "HA") as "[HA _]". eapply P5.
    iApply ("wp" with "[HA]"). iApply (inject_IsFresh with "HA"); reflexivity.
  Qed.

  Lemma run_incl : forall X (run : forall {X}, NomG X -> list atom -> MonSem X)
                     (e : NomG X) (a : list atom) s1 s2 v start,
      Monotone (run e a) ->
      run e a s1 = Res (s2, v) ->
      inject start (pos s2) ⊆ inject start (pos s1 + len s1) .
  Proof.
    intros X run e a s1 s2 v start run_mono RUN.
    eapply run_mono in RUN. apply inject_mono_r. lia.
  Qed.

  Lemma inject_incl `{count : Countable X}: forall (s1 s2 : gset X),
      s1 ⊆ s2 -> ⊢ ([∗ set] n ∈ s2, & n) -∗
                  ([∗ set] n ∈ s1, & n) ∗ ([∗ set] n ∈ (s2 ∖ s1), & n).
  Proof.
    intros. epose (s := H). apply incl_exists in s as [s3 [P0 P1]].
    eapply union_difference_L in H. subst.
    rewrite difference_union_distr_l_L.
    rewrite difference_diag_L. rewrite union_empty_l_L.
    iIntros "HA". iDestruct (big_sepS_union with "HA") as "[HA HB]". exact P1.
    apply disjoint_sym in P1. rewrite difference_disjoint_L. 2 : exact P1.
    iFrame.
  Qed.

  Lemma alt_soundness : forall X (c1 c2 : NomG X) data fuel,
      Sound (run fuel c1 data) c1 ->
      Sound (run fuel c2 data) c2 ->
      Sound (run_alt (@run atom fuel) c1 c2 data) (Nom.alt c1 c2).
  Proof.
    intros X c1 c2 data fuel [mono_c1 sound_c1] [mono_c2 sound_c2].
    constructor. apply alt_mono; auto.
    simpl. intros s res v Q RUN. iIntros "wp HA". iNorm.
    unfold run_alt in RUN. unfold_MonSem.
    destruct (run fuel c1 data s) as [[sres1 res1] | |] eqn:Pc1.
    - inversion RUN. subst. iDestruct "wp" as "[wp _]".
      iDestruct (sound_c1 with "wp") as "HB"; eauto.
      iApply ("HB" with "HA").
    - iDestruct "wp" as "[_ wp]".
      iDestruct (sound_c2 with "wp") as "HB"; eauto.
      iApply ("HB" with "HA").
    - inversion RUN.
  Qed.

  Lemma scope_soundness : forall X range (c : NomG X) data fuel,
      Sound (run fuel c data) c ->
      Sound (run_local (@run atom fuel) (Some range) c data) (Nom.scope range c).
  Proof.
    intros X range c data fuel [mono_c sound_c].
    constructor. apply scope_mono. auto.
    simpl. intros s res v Q RUN. iIntros "[HB wp] _".
    unfold run_local in RUN. unfold_MonSem.
    destruct (run fuel c data range) as [[sres1 res1] | |] eqn:Pc;
      inversion RUN. subst.
    iDestruct (IsFresh_injectSL with "HB") as "HB".
    iDestruct (inject_incl with "HB") as "[HB _]".
    eapply run_incl. eapply mono_c. eapply Pc.
    iDestruct (sound_c with "wp HB") as "$". eapply Pc.
  Qed.

  Lemma peek_soundness : forall X (c : NomG X) data fuel,
      Sound (run fuel c data) c ->
      Sound (run_local (@run atom fuel) None c data) (Nom.peek c).
  Proof.
    intros X c data fuel [mono_c sound_c].
    constructor. apply peek_mono. auto.
    simpl. intros s res v Q RUN. iIntros "HB _". iApply "HB".
  Qed.

  Lemma no_NoRes : forall fuel0 X (c : X -> NomG X) x s0 fuel data,
                     (fix sem_repeat_none (n : nat) (x : X) {struct n} : MonSem X :=
             match n with
             | 0%nat => λ _ : span, NoFuel
             | S n0 =>
                 λ s : span,
                   match
                     match run fuel (c x) data s with
                     | Res (s0, x1) => sem_repeat_none n0 x1 s0
                     | NoRes => NoRes
                     | NoFuel => NoFuel
                     end
                   with
                   | Res (s0, v) => Res (s0, v)
                   | NoRes => Res (s, x)
                   | NoFuel => NoFuel
                   end
             end) fuel0 x s0 <> NoRes.
  Proof.
    induction fuel0; simpl; intros. auto.
    destruct (run fuel (c x) data s0). destruct x0.
    2-3 : auto. destruct ((fix sem_repeat_none (n : nat) (x1 : X) {struct n} : MonSem X :=
       match n with
       | 0%nat => λ _ : span, NoFuel
       | S n0 =>
           λ s1 : span,
             match
               match run fuel (c x1) data s1 with
               | Res (s2, x3) => sem_repeat_none n0 x3 s2
               | NoRes => NoRes
               | NoFuel => NoFuel
               end
             with
             | Res (s2, v) => Res (s2, v)
             | NoRes => Res (s1, x1)
             | NoFuel => NoFuel
             end
       end) fuel0 x0 s). destruct x1.
    auto. auto. auto.
  Qed.

  Lemma repeat_none_soundness : forall fuel0 X (c : X -> NomG X) b data fuel,
          (∀ (res : X) data fuel, Sound (run fuel (c res) data) (c res)) ->
          Sound ((fix sem_repeat_none (n : nat) (x : X) {struct n} : MonSem X :=
               match n with
               | 0%nat => λ _ : span, NoFuel
               | S n0 =>
                   run_try_with (let* v := run fuel (c x) data in sem_repeat_none n0 v)
                     (Nom.run_ret x)
               end) fuel0 b) (Nom.repeat None c b).
  Proof.
    induction fuel0; simpl; intros.
    - constructor. constructor; intros. inversion H0. intros. inversion H0.
    - constructor. eapply try_with_mono. 2 : eapply ret_mono.
      eapply bind_mono. eapply H. intro. eapply mono_repeat_none_aux.
      intros. eapply H.
      simpl. intros. unfold_MonSem.
      destruct (run fuel (c b) data s) eqn:?. destruct x.
      + epose (grow := Heqr). destruct (H b data fuel) as [mono0 sound0].
        eapply mono0 in grow as [P0 P1].
        destruct ((fix sem_repeat_none (n : nat) (x : X) {struct n} : MonSem X :=
            match n with
            | 0%nat => λ _ : span, NoFuel
            | S n0 =>
                λ s : span,
                  match
                    match run fuel (c x) data s with
                    | Res (s0, x1) => sem_repeat_none n0 x1 s0
                    | NoRes => NoRes
                    | NoFuel => NoFuel
                    end
                  with
                  | Res (s0, v) => Res (s0, v)
                  | NoRes => Res (s, x)
                  | NoFuel => NoFuel
                  end
            end) fuel0 x s0) eqn:?. destruct x0.
        * destruct (IHfuel0 X _ x data fuel H).
          epose (grow := Heqr0). eapply mono1 in grow as [P2 P3]. clear mono0 mono1.
          inversion H0. subst. iIntros. iNorm. iDestruct "HE" as "#HE".
          unfold injectSL. rewrite (inject_union (pos s0)). 2-3 : lia.
          iDestruct (big_sepS_union with "HG") as "[HB HA]". eapply inject_disjoint.
          iDestruct (sound0 with "[HC] HB") as ">HB". eapply Heqr.
          iDestruct ("HE" with "HC") as "HA". iApply (wp_consequence with "HA").
          iIntros (v0) "HA". iApply "HA".
          iApply (sound1 with "[HF HB] HA"). eauto. simpl. iExists x0.
          iFrame. iApply "HE".
        * eapply no_NoRes in Heqr0. contradiction.
        * inversion H0.
      + inversion H0. subst. iIntros. iNorm.
        iClear "HE". iApply "HF". iDestruct (injectSL_emp with "HG") as "HA". lia.
        iApply "HC".
      + inversion H0.
  Qed.

  Lemma repeat_None_soundness : forall fuel0 X (c : X -> NomG X) b data,
      (∀ (res : X) data fuel, Sound (run fuel (c res) data) (c res)) ->
      Sound (run fuel0 (Nom.repeat None c b) data) (Nom.repeat None c b).
  Proof.
    simpl. intros. constructor.
    - eapply bind_mono. eapply mono_repeat_none_aux.
      intros. eapply run_mono. intro. eapply ret_mono.
    - simpl. intros. eapply repeat_none_soundness. eapply H.
      unfold_MonSem.
      destruct ((fix sem_repeat_none (n : nat) (x : X) {struct n} : MonSem X :=
       match n with
       | 0%nat => λ _ : span, NoFuel
       | S n0 =>
           λ s0 : span,
             match
               match run fuel0 (c x) data s0 with
               | Res (s1, x1) => sem_repeat_none n0 x1 s1
               | NoRes => NoRes
               | NoFuel => NoFuel
               end
             with
             | Res (s1, v0) => Res (s1, v0)
             | NoRes => Res (s0, x)
             | NoFuel => NoFuel
             end
       end) fuel0 b s) eqn:?. destruct x.
      + erewrite Heqr. auto.
      + inversion H0.
      + inversion H0.
  Qed.

  Lemma soundness : forall X (e : NomG X),
    forall (a : list atom) fuel, Sound (run fuel e a) e.
  Proof.

    Ltac rm_fuel fuel :=
      destruct fuel;
      [ let s := fresh "s" in
        let res := fresh "res" in
        let x := fresh "x" in
        let Q := fresh "Q" in
        let H := fresh "H" in
        constructor; [constructor; intros s res x H; inversion H |
                       intros s res x Q H; inversion H]
      | idtac].

    Ltac IsSound H fuel :=
      rm_fuel fuel; simpl run; eapply bind_soundness; [eapply H; auto; eapply run_mono | eauto].

    eapply (Nom_ind (fun X e => forall a fuel, Sound (run fuel e a) e)); intros.
    - destruct fuel; simpl; eapply ret_soundness.
    - rm_fuel fuel.
      simpl run. constructor. eapply fail_mono. intros. inversion H.
    - eapply bind_soundness. eapply length_soundness. intro. eapply H.
    - eapply bind_soundness. eapply take_soundness. intro. eapply H.
    - eapply bind_soundness. eapply read_soundness. intro. eapply H.
    - eapply bind_soundness. eapply alt_soundness. eapply H. eapply H0.
      intro. eapply H1.
    - eapply bind_soundness. eapply scope_soundness. eapply H.
      intro. eapply H0.
    - eapply bind_soundness. eapply peek_soundness. eapply H.
      intro. eapply H0.
    - destruct o.
      + constructor. eapply run_monotone. revert b.
        induction n using N.peano_ind; intros.
        * rewrite run_bind_monsem in H1. simpl in *.
          unfold_MonSem. iIntros "HA HB". iNorm.
          destruct (H0 b a fuel). iClear "HE". iApply (sound0 with "[HC HF] HB"). eauto.
          iApply ("HF" with "HC").
        * rewrite repeat_some_next_step in H1. rewrite run_bind_monsem in H1.
          simpl. iIntros "HA HB". iNorm. iDestruct "HE" as "#HE".
          unfold_MonSem.
          destruct (run fuel (c b) a s) eqn:?. destruct x0. 2-3 : inversion H1.
          destruct (H b a fuel).
          pose (grow := Heqr). eapply run_mono in grow as [P0 P1].
          pose (grow := H1). eapply run_mono in grow as [P2 P3].
          unfold injectSL. rewrite (inject_union (pos s0)). 2-3 : lia.
          iDestruct (big_sepS_union with "HB") as "[HB HA]". eapply inject_disjoint.
          iDestruct (sound0 with "[HC] HB") as ">HB". eapply Heqr.
          iDestruct ("HE" with "HC") as "HC". iApply (wp_consequence with "HC").
          iIntros (v0) "HA". iApply "HA".
          iApply (IHn with "[HF HB] HA"); eauto.
          simpl. iExists x. iFrame. iApply "HE".
      + eapply bind_soundness. 2 : intro. 2 : eapply H0.
        eapply repeat_none_soundness. eapply H.
  Qed.

  Lemma soundness_triple : forall X e H (Q : X -> iProp),
    forall (a : list atom) (v : X) s s' fuel,
      run fuel e a s = Res (s', v) ->
      ⊢ (H -∗ wp e (fun v => <absorb> Q v)) -∗
        H ∗ injectSL (pos s) (pos s') -∗ <absorb> Q v.
  Proof.
    intros. iIntros "HA [HB HC]". edestruct soundness.
    iApply (sound0 with "[HA HB] HC"). eauto.
    iApply ("HA" with "HB").
  Qed.

  Theorem soundness' : forall X e H (Q : X -> iProp) fuel,
      {{ H }} e {{ v; <absorb> Q v }} ->
      forall (a : list atom) (v : X) s s',
        run fuel e a s = Res (s', v) ->
        ⊢ H ∗ injectSL (pos s) (pos s') -∗ <absorb> Q v.
  Proof.
    intros X e H Q fuel triple a v s s' RUN.
    iApply soundness_triple. eapply RUN. iApply triple.
  Qed.

  Theorem soundness_pure : forall X e H (Q : X -> Prop) fuel,
      {{ H }} e {{ v; ⌜ Q v ⌝ }} ->
      forall (a : list atom) (v : X) s s',
        run fuel e a s = Res (s', v) ->
        ⊢ H ∗ injectSL (pos s) (pos s') -∗ ⌜ Q v ⌝.
  Proof.
    intros X e H Q fuel triple a v s s' RUN.
    iIntros "HA". iApply bi.absorbingly_pure.
    iApply (soundness' _ _ _ (fun v => ⌜ Q v ⌝)).
    eapply consequence_rule; eauto. eauto. iFrame.
  Qed.

  Corollary adequacy_pure_run : forall X e (Q : X -> Prop) fuel,
      {{ emp }} e {{ v; ⌜Q v⌝ }} ->
      forall (a : list atom) (v : X) s' s,
        run fuel e a s = Res (s', v) ->
        Q v.
  Proof.
    intros. eapply SepSet.soundness_pure.
    iIntros "HA". iApply soundness_pure; eauto.
    iSplitR; auto. iApply big_op_ctx. iApply "HA".
  Qed.

  Corollary adequacy_pure : forall X e (Q : X -> Prop) fuel,
      {{ emp }} e {{ v; ⌜Q v⌝ }} ->
      forall (a : list atom) (v : X),
        parse e fuel a = Some v ->
        Q v.
  Proof.
    unfold parse. intros X e Q fuel TRIPLE a x RUN.
    destruct (run fuel e) as [[t v]| |]eqn:?.
    - injection RUN. intro. subst. eapply adequacy_pure_run; eauto.
    - inversion RUN.
    - inversion RUN.
  Qed.

End adequacy.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C G Aprime Aprimeprime Bprime Cprime Bprimeprime Bprimeprimeprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprimeprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ G Aprime /\ (wd_ G Aprimeprime /\ (wd_ G Bprimeprime /\ (wd_ Aprime Bprimeprime /\ (wd_ Bprimeprime Bprimeprimeprime /\ (wd_ G Bprimeprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (wd_ A G /\ (wd_ Aprimeprime A /\ (col_ Aprime Bprime Bprimeprimeprime /\ (col_ G Bprimeprime Bprimeprimeprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ G Aprime Aprimeprime /\ (col_ Aprimeprime A G /\ (col_ Aprime B C /\ col_ Aprime Bprimeprime Aprime)))))))))))))))))))))))))))))))) -> col_ G A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.