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

 The codomain displayed bicategory

 We look at the codomain displayed bicategory in this file.
 We restrict ourselves to locally groupoidal bicategories.
 1. The definition
 2. Displayed univalence

 ***************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
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.Examples.OneTypes.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Trivial.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Definition cod_1cell_path_help
           {B : bicat}
           {b c : B}
           (f₁ f₂ : B ⟦ b , c ⟧)
  : invertible_2cell f₁ f₂ ≃ invertible_2cell f₁ (id₁ _ · f₂).
Proof.
  use make_weq.
  - intro α.
    refine (α • linvunitor _ ,, _).
    is_iso.
    apply α.
  - use isweq_iso.
    + intro α.
      use make_invertible_2cell.
      * exact (α • lunitor _).
      * is_iso.
        apply property_from_invertible_2cell.
    + abstract
        (intro p ;
         use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
         cbn ;
         rewrite vassocl ;
         rewrite linvunitor_lunitor ;
         apply id2_right).
    + abstract
        (intros α ; cbn ;
         use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
         cbn ;
         rewrite vassocl ;
         rewrite lunitor_linvunitor ;
         apply id2_right).
Defined.

(**
 1. Definition of the displayed bicategory
 *)
Section CodomainArrow.
  Variable (B : bicat).

  Definition cod_disp_prebicat_1_id_comp_cells
    : disp_prebicat_1_id_comp_cells (prod_bicat B B).
  Proof.
    use tpair.
    - use tpair.
      + use tpair.
        * exact (λ X, pr2 X --> pr1 X).
        * exact (λ X Y fX fY f, invertible_2cell (fX · pr1 f) (pr2 f · fY)).
      + use tpair.
        * refine (λ X fX, (runitor _ • linvunitor _ ,, _)).
          is_iso.
        * refine (λ X Y Z f g fX fY fZ ff fg,
                 (lassociator _ _ _
                  • (pr1 ff ▹ _)
                  • rassociator _ _ _
                  • (_ ◃ pr1 fg)
                  • lassociator _ _ _
                  ,, _)).
          cbn ; is_iso.
          ** exact (pr2 ff).
          ** exact (pr2 fg).
    - exact (λ X Y f g α fX fY ff fg,
             pr1 ff • (pr2 α ▹ _)
             =
             (_ ◃ pr1 α) • pr1 fg).
  Defined.

  Definition cod_disp_prebicat_ops
    : disp_prebicat_ops cod_disp_prebicat_1_id_comp_cells.
  Proof.
    repeat split.
    - intros X Y f fX fY pf.
      simpl ; cbn.
      rewrite id2_rwhisker, id2_right.
      rewrite lwhisker_id2, id2_left.
      apply idpath.
    - intros X Y f fX fY pf.
      simpl ; cbn.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocr.
      rewrite runitor_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- linvunitor_assoc.
      rewrite lwhisker_hcomp.
      rewrite <- linvunitor_natural.
      rewrite !vassocl.
      rewrite lunitor_triangle.
      rewrite linvunitor_lunitor.
      apply id2_right.
    - intros X Y f fX fY pf.
      simpl ; cbn.
      rewrite !vassocl.
      rewrite runitor_rwhisker.
      rewrite lwhisker_vcomp.
      rewrite !vassocl.
      rewrite linvunitor_lunitor, id2_right.
      rewrite runitor_triangle.
      rewrite vcomp_runitor.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite left_unit_assoc.
      apply idpath.
    - intros X Y f fX fY pf.
      simpl ; cbn.
      rewrite !vassocr.
      rewrite lwhisker_hcomp.
      rewrite triangle_l_inv.
      rewrite <- rwhisker_hcomp.
      rewrite rwhisker_vcomp.
      rewrite !vassocr.
      rewrite rinvunitor_runitor, id2_left.
      rewrite <- linvunitor_assoc.
      rewrite lwhisker_hcomp.
      rewrite <- linvunitor_natural.
      rewrite !vassocl.
      rewrite linvunitor_assoc.
      rewrite !vassocl.
      rewrite rassociator_lassociator, id2_right.
      apply idpath.
    - intros X Y f fX fY pf.
      simpl ; cbn.
      rewrite !vassocr.
      rewrite rinvunitor_triangle.
      rewrite !rwhisker_hcomp.
      rewrite <- rinvunitor_natural.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- left_unit_inv_assoc.
      rewrite lwhisker_vcomp.
      rewrite !vassocr.
      rewrite rinvunitor_runitor, id2_left.
      rewrite lwhisker_hcomp.
      rewrite triangle_l_inv.
      apply idpath.
    - intros X₁ X₂ X₃ X₄ f g h fX₁ fX₂ fX₃ fX₄ pf pg ph.
      simpl ; cbn.
      rewrite <- !rwhisker_vcomp.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      use vcomp_move_L_pM.
      { is_iso. }
      simpl.
      etrans.
      {
        rewrite !vassocr.
        etrans.
        {
          do 8 apply maponpaths_2.
          apply lassociator_lassociator.
        }
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      etrans.
      {
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      rewrite !vassocr.
      use vcomp_move_R_Mp.
      { is_iso. }
      simpl.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        apply lassociator_lassociator.
      }
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite lwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      use vcomp_move_L_Mp.
      { is_iso. }
      simpl.
      etrans.
      {
        rewrite !vassocl.
        do 4 apply maponpaths.
        exact (!(lassociator_lassociator _ _ _ _)).
      }
      rewrite !vassocr.
      apply maponpaths_2.
      etrans.
      {
        rewrite !vassocl.
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite rassociator_lassociator, lwhisker_id2.
        apply id2_left.
      }
      rewrite rwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      use vcomp_move_R_pM.
      { is_iso. }
      simpl.
      rewrite !vassocr.
      use vcomp_move_L_Mp.
      { is_iso. }
      simpl.
      rewrite lassociator_lassociator.
      apply idpath.
    - intros X₁ X₂ X₃ X₄ f g h fX₁ fX₂ fX₃ fX₄ pf pg ph.
      simpl ; cbn.
      rewrite <- !rwhisker_vcomp.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      refine (!_).
      etrans.
      {
        do 7 apply maponpaths_2.
        rewrite lassociator_lassociator.
        apply idpath.
      }
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      use vcomp_move_L_pM.
      { is_iso. }
      simpl.
      etrans.
      {
        rewrite !vassocr.
        rewrite <- lassociator_lassociator.
        rewrite !vassocl.
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator, id2_rwhisker.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      etrans.
      {
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      use vcomp_move_L_pM.
      { is_iso. }
      simpl.
      etrans.
      {
        rewrite !vassocr.
        rewrite lassociator_lassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- lassociator_lassociator.
      rewrite vassocr.
      apply idpath.
    - intros X Y f g h p q fX fY pf pg ph pp pq.
      simpl ; cbn in *.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocr.
      rewrite pp.
      rewrite !vassocl.
      rewrite pq.
      rewrite !vassocr.
      apply maponpaths_2.
      apply lwhisker_vcomp.
    - intros X Y Z f g₁ g₂ p fX fY fZ pf pg₁ pg₂ pp.
      simpl ; cbn in *.
      rewrite !vassocr.
      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 <- rwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      exact pp.
    - intros X Y Z f₁ f₂ g p fX fY fZ pf₁ pf₂ pg pp.
      simpl ; cbn in *.
      rewrite !vassocr.
      rewrite rwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite rwhisker_rwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite rwhisker_vcomp.
      rewrite <- pp.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocl.
      rewrite vcomp_whisker.
      apply idpath.
  Qed.

  Definition cod_disp_prebicat_data
    : disp_prebicat_data (prod_bicat B B).
  Proof.
    use tpair.
    - exact cod_disp_prebicat_1_id_comp_cells.
    - exact cod_disp_prebicat_ops.
  Defined.

  Definition cod_disp_prebicat_laws
    : disp_prebicat_laws cod_disp_prebicat_data.
  Proof.
    repeat split ; intro ; intros ; apply B.
  Qed.

  Definition cod_disp_prebicat
    : disp_prebicat (prod_bicat B B).
  Proof.
    use tpair.
    - exact cod_disp_prebicat_data.
    - exact cod_disp_prebicat_laws.
  Defined.

  Definition cod_has_disp_cellset
    : has_disp_cellset cod_disp_prebicat.
  Proof.
    intros X Y f g p fX fY pf pg.
    apply isasetaprop.
    apply B.
  Qed.

  Definition cod_disp_bicat_help
    : disp_bicat (prod_bicat B B).
  Proof.
    use tpair.
    - exact cod_disp_prebicat.
    - exact cod_has_disp_cellset.
  Defined.

  Definition cod_disp_bicat
    : disp_bicat B
    := sigma_bicat _ _ cod_disp_bicat_help.
End CodomainArrow.

(** Some projections and builders *)
Definition dom
           {B : bicat}
           {X : B}
           (f : cod_disp_bicat B X)
  : B
  := pr1 f.

Definition ar
           {B : bicat}
           {X : B}
           (f : cod_disp_bicat B X)
  : dom f --> X
  := pr2 f.

Definition make_ar
           {B : bicat}
           {X Y : B}
           (f : X --> Y)
  : cod_disp_bicat B Y
  := (X ,, f).

Definition make_disp_1cell_cod
           {B : bicat}
           {X Y : B}
           {f : X --> Y}
           {dX : cod_disp_bicat B X}
           {dY : cod_disp_bicat B Y}
           (h : dom dX --> dom dY)
           (p : invertible_2cell (pr2 dX · f) (h · pr2 dY))
  : dX -->[ f ] dY
  := h ,, p.

Definition coherent_homot
           {B : bicat}
           {X Y : B}
           {f g : X --> Y}
           (α : f ==> g)
           {dX : cod_disp_bicat B X}
           {dY : cod_disp_bicat B Y}
           {df : dX -->[ f ] dY}
           {dg : dX -->[ g ] dY}
           (h : pr1 df ==> pr1 dg)
  : UU
  := pr12 df • (h ▹ pr2 dY)
     =
     (pr2 dX ◃ α) • pr12 dg.

Definition make_disp_2cell_cod
           {B : bicat}
           {X Y : B}
           {f g : X --> Y}
           {α : f ==> g}
           {dX : cod_disp_bicat B X}
           {dY : cod_disp_bicat B Y}
           {df : dX -->[ f ] dY}
           {dg : dX -->[ g ] dY}
           (h : pr1 df ==> pr1 dg)
           (hh : coherent_homot α h)
  : df ==>[ α ] dg
  := h ,, hh.

Definition is_disp_invertible_2cell_cod
           {B : bicat}
           {X Y : B}
           {f g : X --> Y}
           {α : invertible_2cell f g}
           {dX : cod_disp_bicat B X}
           {dY : cod_disp_bicat B Y}
           {ff : dX -->[ f ] dY}
           {gg : dX -->[ g ] dY}
           (αα : ff ==>[ α ] gg)
           (Hαα : is_invertible_2cell (pr1 αα))
  : is_disp_invertible_2cell α αα.
Proof.
  use tpair.
  - use tpair.
    + exact (Hαα^-1).
    + abstract
        (simpl ;
         use vcomp_move_R_Mp ; is_iso ;
         simpl ;
         rewrite !vassocl ;
         use vcomp_move_L_pM ; is_iso ;
         simpl ;
         refine (!_) ;
         apply αα).
  - split.
    + abstract
        (use subtypePath ; [ intro ; apply B | ] ;
         simpl ;
         unfold transportb ;
         rewrite pr1_transportf ;
         rewrite transportf_const ;
         unfold idfun ; cbn ;
         apply vcomp_rinv).
    + abstract
        (use subtypePath ; [ intro ; apply B | ] ;
         simpl ;
         unfold transportb ;
         rewrite pr1_transportf ;
         rewrite transportf_const ;
         cbn ;
         apply vcomp_linv).
Defined.

Definition transportf_cell_of_cod_over
           {B : bicat}
           {b₁ b₂ : B}
           {f₁ f₂ : b₁ --> b₂}
           {α β : f₁ ==> f₂}
           {h₁ : cod_disp_bicat B b₁}
           {h₂ : cod_disp_bicat B b₂}
           {ff₁ : h₁ -->[ f₁ ] h₂}
           {ff₂ : h₁ -->[ f₂ ] h₂}
           (p : α = β)
           (αα : ff₁ ==>[ α ] ff₂)
  : pr1 (transportf
           (λ z, ff₁ ==>[ z ] ff₂)
           p
           αα)
    =
    pr1 αα.
Proof.
  cbn.
  rewrite pr1_transportf, transportf_const.
  apply idpath.
Qed.

Definition transportb_cell_of_cod_over
           {B : bicat}
           {b₁ b₂ : B}
           {f₁ f₂ : b₁ --> b₂}
           {α β : f₁ ==> f₂}
           {h₁ : cod_disp_bicat B b₁}
           {h₂ : cod_disp_bicat B b₂}
           {ff₁ : h₁ -->[ f₁ ] h₂}
           {ff₂ : h₁ -->[ f₂ ] h₂}
           (p : α = β)
           (ββ : ff₁ ==>[ β ] ff₂)
  : pr1 (transportb
           (λ z, ff₁ ==>[ z ] ff₂)
           p
           ββ)
    =
    pr1 ββ.
Proof.
  apply transportf_cell_of_cod_over.
Qed.

Definition from_is_disp_invertible_2cell_cod
           {B : bicat}
           {X Y : B}
           {f g : X --> Y}
           {α : invertible_2cell f g}
           {dX : cod_disp_bicat B X}
           {dY : cod_disp_bicat B Y}
           {ff : dX -->[ f ] dY}
           {gg : dX -->[ g ] dY}
           (αα : ff ==>[ α ] gg)
           (Hαα : is_disp_invertible_2cell α αα)
  : is_invertible_2cell (pr1 αα).
Proof.
  use make_is_invertible_2cell.
  - exact (pr11 Hαα).
  - abstract
      (exact (maponpaths pr1 (pr12 Hαα) @ transportb_cell_of_cod_over _ _)).
  - abstract
      (exact (maponpaths pr1 (pr22 Hαα) @ transportb_cell_of_cod_over _ _)).
Defined.

Definition disp_locally_groupoid_cod
           (B : bicat)
           (inv_B : locally_groupoid B)
  : disp_locally_groupoid (cod_disp_bicat B).
Proof.
  intro ; intros.
  apply is_disp_invertible_2cell_cod.
  apply inv_B.
Defined.

Definition disp_locally_groupoid_cod_one_types
  : disp_locally_groupoid (cod_disp_bicat one_types).
Proof.
  use disp_locally_groupoid_cod.
  exact @one_type_2cell_iso.
Defined.

(**
 2. The univalence
*)
Section UnivalenceOfCodomain.
  Context (B : bicat).

  Definition cod_invertible_2_cell_to_disp_invertible_help
             {c₁ c₂ : B}
             {f : B ⟦ c₁, c₂ ⟧}
             {φ₁ : cod_disp_bicat B c₁}
             {φ₂ : cod_disp_bicat B c₂}
             {ψ₁ ψ₂ : φ₁ -->[ f] φ₂}
             (α : invertible_2cell (pr1 ψ₁) (pr1 ψ₂))
             (Hα : coherent_homot (id2_invertible_2cell f) (pr1 α))
    : disp_invertible_2cell (id2_invertible_2cell f) ψ₁ ψ₂.
  Proof.
    simple refine (_ ,, _).
    - use make_disp_2cell_cod.
      + exact (pr1 α).
      + exact Hα.
    - apply is_disp_invertible_2cell_cod.
      exact (pr2 α).
  Defined.

  Definition cod_invertible_2_cell_to_disp_invertible
             {c₁ c₂ : B}
             {f : B ⟦ c₁, c₂ ⟧}
             {φ₁ : cod_disp_bicat B c₁}
             {φ₂ : cod_disp_bicat B c₂}
             {ψ₁ ψ₂ : φ₁ -->[ f] φ₂}
    : (∑ (α : invertible_2cell (pr1 ψ₁) (pr1 ψ₂)),
       coherent_homot (id2_invertible_2cell f) (pr1 α))
      →
      disp_invertible_2cell (id2_invertible_2cell f) ψ₁ ψ₂.
  Proof.
    intro α.
    exact (cod_invertible_2_cell_to_disp_invertible_help _ (pr2 α)).
  Defined.

  Definition cod_disp_invertible_invertible_2_cell
             {c₁ c₂ : B}
             {f : B ⟦ c₁, c₂ ⟧}
             {φ₁ : cod_disp_bicat B c₁}
             {φ₂ : cod_disp_bicat B c₂}
             {ψ₁ ψ₂ : φ₁ -->[ f] φ₂}
    : disp_invertible_2cell (id2_invertible_2cell f) ψ₁ ψ₂
      →
      ∑ (α : invertible_2cell (pr1 ψ₁) (pr1 ψ₂)),
      coherent_homot (id2_invertible_2cell f) (pr1 α).
  Proof.
    intro α.
    simple refine ((_ ,, _) ,, _).
    - exact (pr11 α).
    - simpl.
      use make_is_invertible_2cell.
      + exact (pr1 (disp_inv_cell α)).
      + abstract
          (pose (maponpaths pr1 (disp_vcomp_rinv α)) as p ;
           cbn in p ;
           unfold transportb in p ;
           rewrite pr1_transportf, transportf_const in p ;
           exact p).
      + abstract
          (pose (maponpaths pr1 (disp_vcomp_linv α)) as p ;
           cbn in p ;
           unfold transportb in p ;
           rewrite pr1_transportf, transportf_const in p ;
           exact p).
    - exact (pr21 α).
  Defined.

  Definition cod_invertible_2_cell_weq_disp_invertible
             {c₁ c₂ : B}
             {f : B ⟦ c₁, c₂ ⟧}
             {φ₁ : cod_disp_bicat B c₁}
             {φ₂ : cod_disp_bicat B c₂}
             {ψ₁ ψ₂ : φ₁ -->[ f] φ₂}
    : (∑ (α : invertible_2cell (pr1 ψ₁) (pr1 ψ₂)),
       coherent_homot (id2_invertible_2cell f) (pr1 α))
      ≃
      disp_invertible_2cell (id2_invertible_2cell f) ψ₁ ψ₂.
  Proof.
    use make_weq.
    - exact cod_invertible_2_cell_to_disp_invertible.
    - use isweq_iso.
      + exact cod_disp_invertible_invertible_2_cell.
      + abstract
          (intro α ;
           use subtypePath ; [ intro ; apply B | ] ;
           use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
           apply idpath).
      + abstract
          (intro α ;
           use subtypePath ; [ intro ; apply isaprop_is_disp_invertible_2cell | ] ;
           use subtypePath ; [ intro ; apply B | ] ;
           apply idpath).
  Defined.

  Definition cod_2cell_path
             {c₁ c₂ : B}
             {f : B ⟦ c₁, c₂ ⟧}
             {φ₁ : cod_disp_bicat B c₁}
             {φ₂ : cod_disp_bicat B c₂}
             {ψ₁ ψ₂ : φ₁ -->[ f ] φ₂}
             (p : pr1 ψ₁ = pr1 ψ₂)
    : (transportf (λ x, invertible_2cell (pr2 φ₁ · f) (x · pr2 φ₂)) p (pr2 ψ₁) = pr2 ψ₂)
      ≃
      coherent_homot (id₂ f) (pr1 (idtoiso_2_1 (pr1 ψ₁) (pr1 ψ₂) p)).
  Proof.
    induction ψ₁ as [ψ₁ q₁].
    induction ψ₂ as [ψ₂ q₂].
    cbn in *.
    induction p.
    cbn.
    unfold coherent_homot.
    cbn.
    rewrite id2_rwhisker.
    rewrite id2_right.
    rewrite lwhisker_id2.
    rewrite id2_left.
    apply path_sigma_hprop.
    apply isaprop_is_invertible_2cell.
  Qed.

  Definition cod_disp_univalent_2_1
             (HB_2_1 : is_univalent_2_1 B)
    : disp_univalent_2_1 (cod_disp_bicat B).
  Proof.
    use fiberwise_local_univalent_is_univalent_2_1.
    intros c₁ c₂ f φ₁ φ₂ ψ₁ ψ₂.
    use weqhomot.
    - exact (cod_invertible_2_cell_weq_disp_invertible
             ∘ weqtotal2 (make_weq _ (HB_2_1 _ _ _ _)) cod_2cell_path
             ∘ total2_paths_equiv _ _ _)%weq.
    - intro p.
      induction p.
      use subtypePath.
      {
        intro ; apply isaprop_is_disp_invertible_2cell.
      }
      use subtypePath.
      {
        intro ; apply B.
      }
      apply idpath.
  Defined.

  Definition cod_1cell_path
             (HB_2_1 : is_univalent_2_1 B)
             {c : B}
             (f₁ f₂ : cod_disp_bicat B c)
             (p : pr1 f₁ = pr1 f₂)
    : (transportf (λ b, B ⟦ b, c ⟧) p (pr2 f₁) = pr2 f₂)
      ≃
      invertible_2cell (pr2 f₁) (idtoiso_2_0 _ _ p · pr2 f₂).
  Proof.
    induction f₁ as [ c₁ f₁ ].
    induction f₂ as [ c₂ f₂ ].
    cbn in *.
    induction p.
    exact (cod_1cell_path_help f₁ f₂ ∘ make_weq _ (HB_2_1 _ _ _ _))%weq.
  Defined.

  Section AdjEquivToDispAdjEquiv.
    Context {c : B}
            {f₁ f₂ : cod_disp_bicat B c}
            (e : adjoint_equivalence (pr1 f₁) (pr1 f₂))
            (α : invertible_2cell (pr2 f₁) (pr1 e · pr2 f₂)).

    Let l : pr1 f₁ --> pr1 f₂ := pr1 e.
    Let r : pr1 f₂ --> pr1 f₁ := left_adjoint_right_adjoint e.
    Let η : invertible_2cell (id₁ _) (l · r) := left_equivalence_unit_iso e.
    Let ε : invertible_2cell (r · l) (id₁ _) := left_equivalence_counit_iso e.

    Definition cod_adj_equiv_to_disp_adj_equiv_map
      : f₁ -->[ internal_adjoint_equivalence_identity c] f₂.
    Proof.
      use make_disp_1cell_cod.
      - exact l.
      - refine (runitor _ • α ,, _).
        is_iso.
        apply α.
    Defined.

    Definition cod_adj_equiv_to_disp_adj_equiv_right_adj
      : f₂ -->[ internal_adjoint_equivalence_identity c] f₁.
    Proof.
      use make_disp_1cell_cod.
      - exact r.
      - simpl.
        use make_invertible_2cell.
        + refine (runitor _
                  • linvunitor _
                  • (ε^-1 ▹ _)
                  • rassociator _ _ _
                  • (_ ◃ α^-1)).
        + is_iso.
    Defined.

    Definition cod_adj_equiv_to_disp_adj_equiv_unit
      : pr1 (id_disp f₁)
        ==>
        pr1 (cod_adj_equiv_to_disp_adj_equiv_map
        ;;
        cod_adj_equiv_to_disp_adj_equiv_right_adj)
      := η.

    Definition cod_adj_equiv_to_disp_adj_equiv_unit_homot
      : coherent_homot
          (left_adjoint_unit (internal_adjoint_equivalence_identity c))
          cod_adj_equiv_to_disp_adj_equiv_unit.
    Proof.
      unfold coherent_homot, cod_adj_equiv_to_disp_adj_equiv_unit ; 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 α.
      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.

    Definition cod_adj_equiv_to_disp_adj_equiv_counit
      : pr1 (cod_adj_equiv_to_disp_adj_equiv_right_adj
        ;;
        cod_adj_equiv_to_disp_adj_equiv_map)
        ==>
        pr1 (id_disp f₂)
      := pr2 (pr212 e).

    Definition cod_adj_equiv_to_disp_adj_equiv_counit_homot
      : coherent_homot
          (left_adjoint_counit
             (internal_adjoint_equivalence_identity c))
          cod_adj_equiv_to_disp_adj_equiv_counit.
    Proof.
      unfold coherent_homot, cod_adj_equiv_to_disp_adj_equiv_counit ; 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) (pr2 f₂) ▹ id₁ c
              • rassociator (pr112 e) (pr1 e · pr2 f₂) (id₁ c)
              • (pr112 e ◃ runitor (pr1 e · pr2 f₂))
              • lassociator (pr112 e) (pr1 e) (pr2 f₂)
              =
              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.

    Definition cod_adj_equiv_to_disp_adj_equiv_disp_adj
      : disp_left_adjoint_equivalence
          (internal_adjoint_equivalence_identity c)
          cod_adj_equiv_to_disp_adj_equiv_map.
    Proof.
      simple refine (_ ,, (_ ,, _)).
      - simple refine (_ ,, (_ ,, _)).
        + apply cod_adj_equiv_to_disp_adj_equiv_right_adj.
        + use make_disp_2cell_cod.
          * apply cod_adj_equiv_to_disp_adj_equiv_unit.
          * exact cod_adj_equiv_to_disp_adj_equiv_unit_homot.
        + use make_disp_2cell_cod.
          * apply cod_adj_equiv_to_disp_adj_equiv_counit.
          * exact cod_adj_equiv_to_disp_adj_equiv_counit_homot.
      - simple refine (_ ,, _).
        + cbn.
          use subtypePath.
          {
            intro.
            apply B.
          }
          cbn.
          etrans.
          {
            exact (pr1 (pr122 e)).
          }
          refine (!_).
          refine (@pr1_transportf _ (λ _, _) _ _ _ _ _ @ _).
          rewrite transportf_const.
          apply idpath.
        + cbn.
          use subtypePath.
          {
            intro.
            apply B.
          }
          cbn.
          etrans.
          {
            exact (pr2 (pr122 e)).
          }
          refine (!_).
          refine (@pr1_transportf _ (λ _, _) _ _ _ _ _ @ _).
          rewrite transportf_const.
          apply idpath.
      - split.
        + apply is_disp_invertible_2cell_cod ; cbn.
          apply η.
        + apply is_disp_invertible_2cell_cod ; cbn.
          apply ε.
    Qed.

    Definition cod_adj_equiv_to_disp_adj_equiv_help
      : disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) f₁ f₂.
    Proof.
      simple refine (_ ,, _).
      - exact cod_adj_equiv_to_disp_adj_equiv_map.
      - exact cod_adj_equiv_to_disp_adj_equiv_disp_adj.
    Defined.
  End AdjEquivToDispAdjEquiv.

  Definition cod_adj_equiv_to_disp_adj_equiv
             {c : B}
             {f₁ f₂ : cod_disp_bicat B c}
    : (∑ (y : adjoint_equivalence (pr1 f₁) (pr1 f₂)),
       invertible_2cell (pr2 f₁) (pr1 y · pr2 f₂))
      →
      disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) f₁ f₂.
  Proof.
    intro e.
    exact (cod_adj_equiv_to_disp_adj_equiv_help (pr1 e) (pr2 e)).
  Defined.

  Definition cod_disp_adj_equiv_to_adj_equiv
             {c : B}
             {f₁ f₂ : cod_disp_bicat B c}
    : disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) f₁ f₂
      →
      ∑ (y : adjoint_equivalence (pr1 f₁) (pr1 f₂)),
      invertible_2cell (pr2 f₁) (pr1 y · pr2 f₂).
  Proof.
    intro e.
    simple refine (_ ,, _).
    - simple refine (_ ,, _).
      + exact (pr11 e).
      + simpl.
        simple refine (_ ,, (_ ,, _)).
        * simple refine (_ ,, (_ ,, _)).
          ** exact (pr1 (pr112 e)).
          ** exact (pr11 (pr212 e)).
          ** exact (pr12 (pr212 e)).
        * split.
          ** abstract
               (refine (maponpaths pr1 (pr1 (pr122 e)) @ _) ;
                unfold transportb ;
                cbn ;
                refine (@pr1_transportf _ (λ _, _) _ _ _ _ _ @ _) ;
                rewrite transportf_const ;
                apply idpath).
          ** abstract
               (refine (maponpaths pr1 (pr2 (pr122 e)) @ _) ;
                unfold transportb ;
                cbn ;
                refine (@pr1_transportf _ (λ _, _) _ _ _ _ _ @ _) ;
                rewrite transportf_const ;
                apply idpath).
        * split.
          ** exact (from_is_disp_invertible_2cell_cod _ (pr12 (pr22 e))).
          ** exact (from_is_disp_invertible_2cell_cod _ (pr22 (pr22 e))).
    - refine (rinvunitor _ • pr121 e ,, _).
      is_iso.
      exact (pr221 e).
  Defined.

  Definition cod_adj_equiv_to_disp_to_adj
             (HB_2_1 : is_univalent_2_1 B)
             {c : B}
             {f₁ f₂ : cod_disp_bicat B c}
             (e : ∑ (y : adjoint_equivalence (pr1 f₁) (pr1 f₂)),
                  invertible_2cell (pr2 f₁) (pr1 y · pr2 f₂))
    : cod_disp_adj_equiv_to_adj_equiv
        (cod_adj_equiv_to_disp_adj_equiv e)
      =
      e.
  Proof.
    use total2_paths_f.
    - simpl.
      use subtypePath.
      {
        intro ; apply isaprop_left_adjoint_equivalence.
        exact HB_2_1.
      }
      apply idpath.
    - unfold subtypePath.
      etrans.
      {
        apply (transportf_total2_paths_f (λ x, invertible_2cell (pr2 f₁) (x · pr2 f₂))).
      }
      cbn.
      use subtypePath.
      {
        intro ; apply isaprop_is_invertible_2cell.
      }
      cbn.
      rewrite vassocr.
      rewrite rinvunitor_runitor.
      apply id2_left.
  Qed.

  Definition cod_disp_adj_to_adj_to_disp
             (HB_2_1 : is_univalent_2_1 B)
             {c : B}
             {f₁ f₂ : cod_disp_bicat B c}
             (e : disp_adjoint_equivalence
                    (internal_adjoint_equivalence_identity c)
                    f₁ f₂)
    : cod_adj_equiv_to_disp_adj_equiv
        (cod_disp_adj_equiv_to_adj_equiv e)
      =
      e.
  Proof.
    use subtypePath.
    {
      intro.
      use isaprop_disp_left_adjoint_equivalence.
      - exact HB_2_1.
      - apply cod_disp_univalent_2_1.
        exact HB_2_1.
    }
    cbn.
    unfold cod_adj_equiv_to_disp_adj_equiv_map, make_disp_1cell_cod.
    use maponpaths.
    use subtypePath.
    {
      intro ; apply isaprop_is_invertible_2cell.
    }
    cbn.
    rewrite vassocr.
    rewrite runitor_rinvunitor.
    apply id2_left.
  Qed.

  Definition cod_adj_equiv_weq_disp_adj_equiv
             (HB_2_1 : is_univalent_2_1 B)
             {c : B}
             (f₁ f₂ : cod_disp_bicat B c)
    : (∑ y : adjoint_equivalence (pr1 f₁) (pr1 f₂),
             invertible_2cell (pr2 f₁) (pr1 y · pr2 f₂))
      ≃
      disp_adjoint_equivalence (internal_adjoint_equivalence_identity c) f₁ f₂.
  Proof.
    use make_weq.
    - exact cod_adj_equiv_to_disp_adj_equiv.
    - use isweq_iso.
      + exact cod_disp_adj_equiv_to_adj_equiv.
      + exact (cod_adj_equiv_to_disp_to_adj HB_2_1).
      + exact (cod_disp_adj_to_adj_to_disp HB_2_1).
  Defined.

  Definition cod_disp_univalent_2_0
             (HB_2 : is_univalent_2 B)
    : disp_univalent_2_0 (cod_disp_bicat B).
  Proof.
    use fiberwise_univalent_2_0_to_disp_univalent_2_0.
    intros c f₁ f₂.
    use weqhomot.
    - exact (cod_adj_equiv_weq_disp_adj_equiv (pr2 HB_2) f₁ f₂
             ∘ weqtotal2 (make_weq _ (pr1 HB_2 _ _)) (cod_1cell_path (pr2 HB_2) f₁ f₂)
             ∘ total2_paths_equiv _ _ _)%weq.
    - intro p.
      cbn in p.
      induction p.
      use subtypePath.
      {
        intro.
        use isaprop_disp_left_adjoint_equivalence.
        - exact (pr2 HB_2).
        - apply cod_disp_univalent_2_1.
          exact (pr2 HB_2).
      }
      cbn ; unfold cod_adj_equiv_to_disp_adj_equiv_map, make_disp_1cell_cod ; cbn.
      apply maponpaths.
      use subtypePath.
      {
        intro ; apply isaprop_is_invertible_2cell.
      }
      cbn.
      rewrite id2_left.
      apply idpath.
  Qed.

  Definition cod_disp_univalent_2
             (HB_2 : is_univalent_2 B)
    : disp_univalent_2 (cod_disp_bicat B).
  Proof.
    split.
    - exact (cod_disp_univalent_2_0 HB_2).
    - exact (cod_disp_univalent_2_1 (pr2 HB_2)).
  Defined.
End UnivalenceOfCodomain.


(** Copyright (c) 2018 by Swirlds, Inc.
   Implemented by Karl Crary.
*)

Require Import Bool.
Require Import Nat.
Require Import List.
Require Import Omega.
Require Import Decide.

Require Import Tact.
Require Import Relation.
Require Import Weight.
Require Import Calculate.
Require Import Majority.
Require Export Hashgraph.

(** Peers *)

Lemma eq_peer_decide : forall (a b : peer), decidable (a = b).
Proof.
intros a b.
so (peer_eq_dec a b) as [Heq | Hneq]; [left | right]; auto.
Qed.

Lemma arbitrary_peer : inhabited peer.
Proof.
destruct number_of_peers as (p & _ & _ & Hlen).
destruct p as [| x p].
  {
  cbn in Hlen.
  so number_peers_minimum.
  omega.
  }
exact (inhabits x).
Qed.

Lemma distinct_peer :
  forall (P : peer -> Prop) a,
    majority stake P every
    -> exists b, P b /\ a <> b.
Proof.
intros P a Hmaj.
destruct Hmaj as (m & n & _ & HcardP & Hcardn & Hgt).
destruct HcardP as (p & Hdistp & Hp & Hweightp).
destruct p as [| b p].
  {
  cbn in Hweightp.
  subst m.
  omega.
  }
so (eq_peer_decide a b) as [Heq | Hneq].
2:{
  exists b.
  split; auto.
  apply Hp.
  left; auto.
  }
subst b.
destruct p as [| c p].
  {
  exfalso.
  apply (no_majority_stake a).
  exists m, n.
  do2 3 split; auto.
  exists (cons a nil).
  do2 2 split; auto.
  intros d.
  split.
    {
    intros <-.
    left; auto.
    }

    {
    intro H.
    destruct H; auto.
    destruct H.
    }
  }
exists c.
split.
  {
  apply Hp.
  right; left; auto.
  }

  {
  intros <-.
  invert Hdistp.
  intros H _.
  destruct H.
  left; auto.
  }
Qed.

Lemma honest_decide :
  forall a, decidable (honest a).
Proof.
intro a.
apply finite_decide.
  {
  exact eq_peer_decide.
  }
destruct supermajority_honest as (m & _ & _ & Hcard & _).
eapply weight_finite; eauto.
Qed.

(** Events *)

Lemma eq_event_decide : forall (x y : event), decidable (x = y).
Proof.
intros x y.
so (event_eq_dec x y) as [Heq | Hneq]; [left | right]; auto.
Qed.

(** Parents *)

Lemma initial_no_parent :
  forall x y, initial y -> parent x y -> False.
Proof.
intros x y Hinit Hparent.
invert Hparent.
  {
  intros z Hparents.
  destruct Hinit.
  exists x, z.
  auto.
  }

  {
  intros z Hparents.
  destruct Hinit.
  exists z, x.
  auto.
  }
Qed.

Lemma initial_no_self_parent :
  forall x y, initial y -> self_parent x y -> False.
Proof.
intros x y Hinit Hparent.
destruct Hparent as (z & Hparents).
destruct Hinit.
exists x, z.
auto.
Qed.

Lemma parents_self_parent :
  forall x y z,
    parents x y z -> self_parent x z.
Proof.
intros x y z H.
exists y; auto.
Qed.

Lemma parent_decide :
  forall x y, decidable (parent x y).
Proof.
intros x y.
so (initial_decide y) as [Hinit | (v & w & Hparents)].
  {
  right.
  intros H.
  eapply initial_no_parent; eauto.
  }
so (event_eq_dec x v) as [Heq | Hneqv].
  {
  subst x.
  left.
  eapply parent1; eauto.
  }
so (event_eq_dec x w) as [Heq | Hneqw].
  {
  subst x.
  left.
  eapply parent2; eauto.
  }
right.
intros Hparent.
invert Hparent.
  {
  intros z Hparents'.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  destruct Hneqv; auto.
  }

  {
  intros z Hparents'.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  destruct Hneqw; auto.
  }
Qed.

Lemma parent_finite :
  forall x, finite (fun y => parent y x).
Proof.
intros x.
so (initial_decide x) as [Hinit | (y & z & Hparents)].
  {
  exists nil.
  intros y.
  split.
    {
    intro H.
    eapply initial_no_parent; eauto.
    }

    {
    intro H.
    destruct H.
    }
  }
exists (cons y (cons z nil)).
intros w.
split.
  {
  intros Hwx.
  invert Hwx.
    {
    intros v Hparents'.
    so (parents_fun _#5 Hparents Hparents') as (<- & <-).
    left; auto.
    }

    {
    intros v Hparents'.
    so (parents_fun _#5 Hparents Hparents') as (<- & <-).
    right; left; auto.
    }
  }

  {
  intro H.
  destruct H as [Heq | [Heq | H]].
    {
    subst.
    eapply parent1; eauto.
    }

    {
    subst.
    eapply parent2; eauto.
    }

    {
    destruct H.
    }
  }
Qed.

Lemma self_parent_impl_parent :
  forall x y, self_parent x y -> parent x y.
Proof.
intros x y Hxy.
destruct Hxy as (z & H).
eapply parent1; eauto.
Qed.

Lemma self_parent_fun :
  forall x x' y,
    self_parent x y
    -> self_parent x' y
    -> x = x'.
Proof.
intros x x' y H H'.
destruct H as (z & H).
destruct H' as (z' & H').
so (parents_fun _#5 H H') as (<- & _).
reflexivity.
Qed.

Lemma self_parent_creator :
  forall x y, self_parent x y -> creator x = creator y.
Proof.
intros x y H.
destruct H as (z & H).
eapply parents_creator; eauto.
Qed.

Lemma self_parent_decide :
  forall x y, decidable (self_parent x y).
Proof.
intros x y.
so (initial_decide y) as [Hinit | (u & v & Hparents)].
  {
  right.
  intros (u & Hparents).
  apply Hinit; eauto.
  }

  {
  so (eq_event_decide x u) as [| Hneq].
    {
    subst u.
    left.
    exists v; auto.
    }

    {
    right.
    intros (w & Hparents').
    so (parents_fun _#5 Hparents Hparents') as (<- & _).
    destruct Hneq; auto.
    }
  }
Qed.

(** Paths *)

Lemma self_ancestor_impl_ancestor :
  forall x y, x $= y -> x @= y.
Proof.
intros x y H.
apply (star_mono _ self_parent); auto.
exact self_parent_impl_parent.
Qed.

Lemma strict_self_ancestor_impl_strict_ancestor :
  forall x y, x $ y -> x @ y.
Proof.
intros x y H.
apply (plus_mono _ self_parent); auto.
exact self_parent_impl_parent.
Qed.

Lemma self_parent_well_founded : well_founded self_parent.
Proof.
intros x.
wfinduct x using parent_well_founded.
intros x IH.
apply Acc_intro.
intros y Hyx.
apply IH.
apply self_parent_impl_parent; auto.
Qed.

Lemma strict_ancestor_well_founded : well_founded strict_ancestor.
Proof.
apply plus_well_founded.
apply parent_well_founded.
Qed.

Lemma strict_ancestor_parents :
  forall w x y z,
    parents x y z
    -> w @ z
    -> w @= x \/ w @= y.
Proof.
intros w x y z Hparents Hwz.
so (plus_plusr _#4 Hwz) as (v & Hwv & Hvz).
invert Hvz.
  {
  intros v' Hparents'.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  left; auto.
  }

  {
  intros v' Hparents'.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  right; auto.
  }
Qed.

Lemma strict_self_ancestor_parent :
  forall x y z,
    self_parent y z
    -> x $ z
    -> x $= y.
Proof.
intros x y z Hparent Hxz.
so (plus_plusr _#4 Hxz) as (v & Hxv & Hvz).
so (self_parent_fun _#3 Hparent Hvz); subst v.
exact Hxv.
Qed.

Lemma strict_ancestor_initial :
  forall x y, x @ y -> initial y -> False.
Proof.
intros x y Hxy Hinit.
destruct (plus_plusr _#4 Hxy) as (z & _ & Hzy).
eapply initial_no_parent; eauto.
Qed.

Lemma ancestor_initial :
  forall x y, x @= y -> initial y -> x = y.
Proof.
intros x y Hxy Hinit.
so (star_plus _#4 Hxy) as [Heq | Hxy']; auto.
exfalso.
eapply strict_ancestor_initial; eauto.
Qed.

Lemma self_ancestor_creator :
  forall x y, x $= y -> creator x = creator y.
Proof.
intros x y H.
induct H; auto.
(** step *)
{
intros x y z Hxy _ Heq.
transitivity (creator y); auto.
eapply self_parent_creator; eauto.
}
Qed.

Lemma strict_ancestor_irreflex :
  forall x, x @ x -> False.
Proof.
intros x Hxx.
eapply well_founded_impl_irrefl; eauto.
exact strict_ancestor_well_founded.
Qed.

(** Path decisions *)

Lemma strict_ancestor_finite : forall x, finite (fun y => y @ x).
Proof.
intro x.
apply finite_plus.
  { exact parent_well_founded. }

  { exact parent_decide. }

  { exact parent_finite. }
Qed.

Lemma ancestor_finite : forall x, finite (fun y => y @= x).
Proof.
intro x.
apply finite_star.
  { exact parent_well_founded. }

  { exact parent_decide. }

  { exact parent_finite. }
Qed.

Lemma ancestor_decide :
  forall x y,
    decidable (x @= y).
Proof.
intros x y.
wfinduct y using parent_well_founded.
intros y IH.
so (event_eq_dec x y) as [Heq | Hneq].
  {
  subst y.
  left.
  apply star_refl.
  }
so (initial_decide y) as [Hinit | Hparents].
  {
  right.
  intros Hxy.
  so (star_plus _#4 Hxy) as [Heq | Hxy'].
    {
    subst y.
    destruct Hneq; auto.
    }
  so (plus_plusr _#4 Hxy') as (z & _ & Hzy).
  destruct Hinit.
  invert Hzy; eauto.
  }
destruct Hparents as (v & w & Hparents).
so (IH _ (parent1 Hparents)) as [Hvy | Hnvy].
  {
  left.
  eapply star_trans; eauto.
  apply star_one.
  eapply parent1; eauto.
  }
so (IH _ (parent2 Hparents)) as [Hwy | Hnwy].
  {
  left.
  eapply star_trans; eauto.
  apply star_one.
  eapply parent2; eauto.
  }
right.
intro Hxy.
so (star_plus _#4 Hxy) as [? | Hxy'].
  {
  subst y.
  destruct Hneq; auto.
  }
so (plus_plusr _#4 Hxy') as (u & Hxu & Huy).
invert Huy.
  {
  intros u' Hparents'.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  destruct Hnvy; auto.
  }

  {
  intros u' Hparents'.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  destruct Hnwy; auto.
  }
Qed.

Lemma strict_ancestor_decide :
  forall x y,
    decidable (x @ y).
Proof.
intros x y.
so (ancestor_decide x y) as [Hxy | Hnxy].
  {
  so (star_plus _#4 Hxy) as [Heq | Hxy'].
    {
    subst y.
    right.
    unfold not.
    apply well_founded_impl_irrefl.
    exact strict_ancestor_well_founded.
    }
  left; auto.
  }

  {
  right.
  contradict Hnxy.
  apply plus_star; auto.
  }
Qed.

Lemma self_ancestor_decide :
  forall x y,
    decidable (x $= y).
Proof.
intros x y.
wfinduct y using self_parent_well_founded.
intros y IH.
so (event_eq_dec x y) as [Heq | Hneq].
  {
  subst y.
  left.
  apply star_refl.
  }
so (initial_decide y) as [Hinit | Hparents].
  {
  right.
  intros Hxy.
  so (star_plus _#4 Hxy) as [Heq | Hxy'].
    {
    subst y.
    destruct Hneq; auto.
    }
  so (plus_plusr _#4 Hxy') as (z & _ & Hzy).
  destruct Hinit.
  invert Hzy; eauto.
  }
destruct Hparents as (v & w & Hparents).
so (IH v (ex_intro _ _ Hparents)) as [Hvy | Hnvy].
  {
  left.
  eapply star_trans; eauto.
  apply star_one.
  exists w; auto.
  }
right.
intro Hxy.
so (star_plus _#4 Hxy) as [? | Hxy'].
  {
  subst y.
  destruct Hneq; auto.
  }
so (plus_plusr _#4 Hxy') as (u & Hxu & Huy).
destruct Huy as (u' & Hparents').
so (parents_fun _#5 Hparents Hparents') as (<- & <-).
destruct Hnvy; auto.
Qed.

Lemma self_ancestor_total :
  forall W x y,
    member W x
    -> member W y
    -> honest (creator x)
    -> creator x = creator y
    -> x $= y \/ y $= x.
Proof.
intros W x y Wx Wy Hhonest Heqcr.
so (self_ancestor_decide x y) as [| Hnxy]; auto.
so (self_ancestor_decide y x) as [| Hnyx]; auto.
exfalso.
destruct (world_forks W _ Hhonest).
exists x, y.
do2 3 split; auto.
do2 2 split; auto.
Qed.

Lemma self_ancestor_total' :
  forall W x y,
    member W x
    -> member W y
    -> honest (creator x)
    -> creator x = creator y
    -> x $= y \/ y $ x.
Proof.
intros W x y Wx Wy Hhonest Heqcr.
so (eq_event_decide x y) as [Heq | Hneq].
  {
  subst y.
  left.
  apply star_refl.
  }
so (self_ancestor_total _ _ _ Wx Wy Hhonest Heqcr) as [Hxy | Hyx]; auto.
right.
apply star_neq_plus; auto.
Qed.

(** Forks *)

Lemma fork_symm :
  forall x y, fork x y -> fork y x.
Proof.
intros x y H.
destruct H as (Heq & Hnxy & Hnyx).
do2 2 split; auto.
Qed.

Lemma fork_creator :
  forall x y, fork x y -> creator x = creator y.
Proof.
intros x y H.
destruct H; auto.
Qed.

Lemma fork_decide :
  forall x y, decidable (fork x y).
Proof.
intros x y.
apply dec_and.
  { apply eq_peer_decide. }
apply dec_and.
  {
  apply dec_not.
  apply self_ancestor_decide.
  }
apply dec_not.
apply self_ancestor_decide.
Qed.

(** Worlds *)

Definition realtime_before (s : sample) (x : event) : world.
Proof.
apply (mk_world (fun y => realtime s y x)).
  {
  intros z y Hzy Hyx.
  apply (realtime_trans _ _ y); auto.
  apply ancestor_realtime; auto.
  apply (realtime_member _ _ x); eauto.
  }

  {
  intros a Ha.
  intros (y & z & Hyx & Hzx & Hfork & Heqcr).
  subst a.
  destruct Hyx as (j & _ & -> & _).
  destruct Hzx as (k & _ & -> & _).
  apply (spawn_forks s j k); auto.
  }
Defined.

Lemma event_world : forall x, exists W, member W x.
Proof.
intros x.
so (no_orphans x) as (s & i & Hspawn).
exists (realtime_before s x).
subst x.
exists i, i.
auto.
Qed.

(** Textorder *)

Lemma textorder_decide :
  forall x y, decidable (Is_true (textorder x y)).
Proof.
intros x y.
apply Is_true_decide.
Qed.


Require Export prosa.behavior.all.
Require Export prosa.analysis.definitions.progress.
Require Export prosa.util.nat.

(** * Job Model Parameter for Jobs Exhibiting Self-Suspensions *)

(** We define a job's self-suspension parameter as follows: after having
    received a given number of units of service [rho], a job [j] may either
    self-suspend for a given duration [d], in which case [job_suspension j rho
    = d], or it may remain ready, in which case [job_suspension j rho =
    0]. Note that a job may self-suspend before having received any service,
    which is equivalent to release jitter. (Suspensions after a job has
    completed are meaningless and irrelevant.) *)
Class JobSuspension (Job : JobType) := job_suspension : Job -> work -> duration.

(** * Readiness of Self-Suspending Jobs *)

(** In the following section, we define the notion of "readiness" for
    self-suspending jobs based on the just-defined job-model parameter. *)
Section ReadinessOfSelfSuspendingJobs.
  (** Consider any kind of jobs... *)
  Context {Job : JobType}.

  (** ... and any kind of processor state. *)
  Context {PState : Type}.
  Context `{ProcessorState Job PState}.

  (** Suppose jobs have an arrival time, a cost, and that they exhibit
      self-suspensions. *)
  Context `{JobArrival Job} `{JobCost Job} `{JobSuspension Job}.

  (** We say that a job's last suspension (if any) of length [delay] "has
      passed" at a given time [t] (i.e., the job is ready again at time [t]) if
      the job arrived at least [delay] time units ago and has not progressed
      within the last [delay] time units. In other words, since a
      self-suspension can start only when a job progresses (i.e., when it
      receives some service), if a job has not been making progress in the last
      [delay] time units, then a self-suspension of length [delay] has
      necessarily ended at time [t]. *)
  Definition suspension_has_passed (sched : schedule PState) (j : Job) (t : instant) :=
    let delay := job_suspension j (service sched j t) in
    (job_arrival j + delay <= t) && no_progress_for sched j t delay.

  (** Based on [suspension_has_passed], we state the notion of readiness for
      self-suspending jobs: a job [t] is ready at time [t] in a schedule
      [sched] only if it is not self-suspended or complete at time [t]. *)
  Global Program Instance suspension_ready_instance : JobReady Job PState :=
    {
      job_ready sched j t := suspension_has_passed sched j t && ~~ completed_by sched j t
    }.
  Next Obligation.
    move: H3 => /andP [PASSED UNFINISHED].
    rewrite /pending. apply /andP. split => //.
    move: PASSED. rewrite /suspension_has_passed /has_arrived => /andP [ARR _].
    by move: ARR; apply leq_addk.
  Defined.

End ReadinessOfSelfSuspendingJobs.

(** * Total Suspension Time of a Job *)

(** Next, we define the notion of a job's cumulative and total suspension times. *)

Section TotalSuspensionTime.

  (** Consider any kind of jobs... *)
  Context {Job : JobType}.

  (** ...where each job has a cost and may exhibit self-suspensions. *)
  Context `{JobCost Job} `{JobSuspension Job}.

  (** A job's total self-suspension length is simply the sum of the lengths of
     all its suspensions. *)
  Definition total_suspension (j : Job) := \sum_(0 <= ρ < job_cost j) job_suspension j ρ.

End TotalSuspensionTime.


(*============================================ *)
(*   Nominal sets of semantic objects and      *)
(*      interpretation objects                 *)
(*============================================ *)

Require Import SemObjects IntObjects Target Nom Vector EnvExt Basics CustomTactics.
Require Import Program.Equality.

(** We use set of variables TSetMod (elements are natural numbers) *)
Module AtomN <: Atom.
  Module V := TSetMod.
  (* We left this as an axiom, but one can show this property by taking x = max(X)+1 *)
  Axiom Atom_inf : forall (X : V.t), {x : V.elt | ~ V.In x X}.
End AtomN.

Module NomN := Nominal AtomN.

(* -------------------------------------- *)
(* Nominal set of types                   *)
(* -------------------------------------- *)
Module PermTy <: NomN.NominalSet.
  Import NomN.
  Module V := Atom.V.
  Definition X := Ty.

  Fixpoint action (r : Perm) (ty : Ty) :=
    match ty with
    | Tv_Ty v => Tv_Ty ((perm r) v)
    | Arr_Ty t1 t2 => Arr_Ty (action r t1) (action r t2)
    end.

  Notation "r @ x" := (action r x) (at level 80).

  Lemma action_id : forall (x : X), (id_perm @ x) = x.
  Proof.
    intros x.
    induction x;simpl;try congruence;auto.
  Qed.

  Lemma action_compose : forall (x : X) (r r' : Perm), (r @ (r' @ x)) = ((r ∘p r') @ x).
  Proof.
    intros x r r'.
    induction x.
    + simpl. f_equal.
    + simpl. congruence.
  Qed.

  Fixpoint supp (ty : Ty) : V.t :=
    match ty with
    | Tv_Ty v => V.singleton v
    | Arr_Ty t1 t2 => V.union (supp t1) (supp t2)
    end.

  Import V.

  Lemma supp_spec :
    forall  (r : Perm)  (x : X),
      (forall (a : V.elt), In a (supp x) -> (perm r) a = a) -> (r @ x) = x.
  Proof.
    intros r x H.
    induction x.
    + simpl in *. rewrite H;auto with set. apply V.singleton_spec. reflexivity.
    + simpl in *. f_equal.
      * apply IHx1. intros. apply H. apply union_spec. auto.
      * apply IHx2. intros. apply H. apply union_spec. auto.
  Qed.

  Definition fresh a x := ~ In a (supp x).

  (* NOTE : this property seems to be very uniform, look it up in papers on nominal sets *)
  Lemma supp_action : forall r t,
      PermTy.supp (PermTy.action r t) = PFin.action r (PermTy.supp t).
  Proof.
    intros r t.
    induction t.
    + simpl. rewrite PFin.action_singleton. reflexivity.
    + simpl. rewrite PFin.equivar_union. rewrite IHt1. rewrite IHt2. reflexivity.
  Qed.

End PermTy.

(* ------------------------------------------------- *)
(* Nominal set of "plain" environments - finite maps *)
(* with no mutual inductive structure                *)
(* ------------------------------------------------- *)
Module PermPlainEnv <: NomN.NominalSet.
  Import NomN.
  Module V := Atom.V.

  Import EnvMod.

  Definition X := EnvMod.t Ty.
  Definition singleEnv (k : tid) (t : Ty) : X := EnvMod.add _ k t EnvMod.empty.

  Definition action (r : Perm) (x : X) :=
    EnvMod.En.map (PermTy.action r) x.

  Notation "r @ x" := (action r x) (at level 80).

  Hint Resolve EnvMod.En.find_1 EnvMod.En.find_2
       EnvMod.En.map_1 : env.

  Lemma action_id : forall (x : X), (id_perm @ x) = x.
  Proof.
    intros x.
    apply EnvMod.env_extensionality_alt.
    intros. split.
    + intros H. apply EnvMod.En.find_2 in H. unfold action in *.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *.
      destruct H as [a H']. destruct H'. subst. rewrite PermTy.action_id. auto with env.
    + intros H. unfold action in *.
      apply EnvMod.En.find_1.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *.
      exists v. rewrite PermTy.action_id. split;auto.
  Qed.

  Lemma action_compose : forall (x : X) (r r' : Perm), (r @ (r' @ x)) = ((r ∘p r') @ x).
  Proof.
    intros x r r'.
    apply EnvMod.env_extensionality_alt. intros.
    split;unfold action in *.
    + intros H.
      apply EnvMod.En.find_1. apply EnvMod.En.find_2 in H.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *. destruct H as [a H']. destruct H'.
      subst. rewrite EnvMod.FM.P.F.map_mapsto_iff in *.
      destruct H0 as [b H0']. destruct H0'.
      subst.
      exists b. split.
      * apply PermTy.action_compose.
      * auto.
    + intros H.
      apply EnvMod.En.find_1. apply EnvMod.En.find_2 in H.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *.
      destruct H as [a H']. destruct H'.
      rewrite <- PermTy.action_compose in *.
      exists (PermTy.action r' a).
      split;auto.
  Qed.

  Lemma action_singleton :
    forall r k v, (r @ (singleEnv k v)) = singleEnv k ((PermTy.action r) v).
  Proof.
    intros.
    apply env_extensionality_alt. intros k' v'.
    split; intros Hk'; compute in *;
      destruct (ID.compare k' k);tryfalse;auto.
  Qed.

  Definition supp (x : X) : V.t :=
    EnvMod.En.fold (fun k v v' => V.union (PermTy.supp v) v') x V.empty.

  Lemma in_env_in_supp (E : X) k e v :
    look k E = Some e -> V.In v (PermTy.supp e) -> V.In v (supp E).
  Proof.
    unfold supp.
    apply FM.P.fold_rec_weak with
        (P:= fun x y => look k x = Some e -> V.In v (PermTy.supp e) -> V.In v y).
    + intros m m' a H H1 H2 H3. intros. apply env_extensionality in H. subst. auto.
    + intros He Hv. tryfalse.
    + intros. rewrite V.union_spec in *.
      apply En.find_2 in H1. rewrite FM.P.F.add_mapsto_iff in *.
      destruct H1.
      * destruct H1. subst. auto.
      * destruct H1. right. apply H0; auto.
  Qed.

  Lemma supp_spec :
    forall  (r : Perm)  (x : X),
      (forall (a : V.elt), V.In a (supp x) -> (perm r) a = a) -> (r @ x) = x.
  Proof.
    intros r x Hs.
    unfold action in *.
    apply EnvMod.env_extensionality_alt. intros.
    split.
    + intros H. rewrite <- FM.P.F.find_mapsto_iff in *.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *. destruct H as [a H']. destruct H'.
      subst. rewrite PermTy.supp_spec;intros;auto.
      apply Hs. eapply in_env_in_supp;eauto.
    + intros Hv. rewrite <- FM.P.F.find_mapsto_iff in *.
      rewrite FM.P.F.map_mapsto_iff.
      exists v. split;auto. symmetry. apply PermTy.supp_spec.
      intros a Ha. apply Hs. eapply in_env_in_supp;eauto.
  Qed.

  Definition fresh a x := ~ V.In a (supp x).

  Definition all_fresh (vs : V.t) (x : X) := V.Disjoint vs (supp x).

  Lemma supp_action x r : supp (r @ x) = (PFin.action r) (supp x).
  Proof.
    unfold supp.
    apply FM.P.fold_rec_weak with
        (P:= fun x y =>
               En.fold (fun (_ : En.key) v v' =>
                          V.union (PermTy.supp v) v') (r @ x) V.empty =  PFin.action r y).
    + intros. apply env_extensionality in H. subst. assumption.
    + intros. reflexivity.
    + intros. unfold action. rewrite map_add;auto. rewrite FM.P.fold_add;intuition;auto.
      replace (map (PermTy.action r) m) with (r @ m) by reflexivity. rewrite H0.
      rewrite PFin.equivar_union. f_equal;intros. rewrite PermTy.supp_action. reflexivity.
      apply PermTy.supp_action.
      unfold FM.P.transpose_neqkey. intros.
      rewrite V.union_comm. rewrite V.union_assoc.
      replace (V.union a0 (PermTy.supp e0)) with
          (V.union (PermTy.supp e0) a0) by apply V.union_comm.
      reflexivity.
      apply En.map_2 in H1;auto.
  Qed.

  Lemma equivar_all_fresh : forall (vs :V.t) (x : X) (r : Perm),
      all_fresh vs x -> all_fresh (PFin.action r vs) (r @ x).
  Proof.
    intros vs x r H. unfold V.Disjoint, not in *. intros k H1.
    destruct r as [f Hf]. destruct Hf as [Hinj Hsupp].
    destruct H1 as [Hvs Hx]. rewrite supp_action in *.
    unfold PFin.action in *.
    rewrite V.set_map_iff in *. destruct Hvs as [k' Hvs']. destruct Hx.
    intuition;subst.
    (* NOTE : here we use the property that permutation is injective *)
    replace k' with x0 in * by (apply Hinj;auto).
    apply (H x0);auto.
  Qed.

  Hint Resolve map_spec En.map_1 En.map_2.

  Hint Unfold action.

  Lemma equivar_plus E E' r : (r @ (E ++ E')) = (r @ E) ++ (r @ E').
  Proof.
    apply env_extensionality_alt.
    intros. split;autounfold.
    + intros H. rewrite <- FM.P.F.find_mapsto_iff in *.
      rewrite FM.P.F.map_mapsto_iff in H.
      destruct H as [a H']. destruct H' as [Heq Ha].
      rewrite FM.P.update_mapsto_iff in *.
      destruct Ha.
      * subst. left. apply En.map_1;auto.
      * destruct H. right. split.
        ** subst. apply En.map_1;auto.
        ** subst. unfold not. intros. apply H0. rewrite FM.P.F.map_in_iff in *;auto.
    + intros. rewrite <- FM.P.F.find_mapsto_iff in *.
      rewrite FM.P.F.map_mapsto_iff in *.
      rewrite FM.P.update_mapsto_iff in *.
      destruct H.
      * rewrite FM.P.F.map_mapsto_iff in *.
        destruct H as [a H']. destruct H' as [Heq Ha].
        exists a. rewrite FM.P.update_mapsto_iff in *.
        intuition;auto.
      * destruct H. rewrite FM.P.F.map_mapsto_iff in *.
        destruct H as [a H']. destruct H' as [Heq Ha].
        exists a. rewrite FM.P.update_mapsto_iff in *.
        split;auto. right. rewrite FM.P.F.map_in_iff in *.
        intuition;auto.
  Qed.
End PermPlainEnv.

(* --------------------------------------- *)
(* Nominal set of semantic objects         *)
(* --------------------------------------- *)
Module PermSemOb <: NomN.NominalSet.
  Import NomN.
  Module V := Atom.V.

  Definition X := Env.

  Import VE.

  (* It is possible to define a permutation action on semantic objects as a function *)
  Fixpoint action (p : Perm) (E : X) :=
    match E with
    | EnvCtr te ve me mte => EnvCtr (PermPlainEnv.action p te)
                                    (PermPlainEnv.action p ve)
                                    (action_me p me) (action_mte p mte)
    end
  with action_me p me :=
         match me with
         | MEnvCtr {| v_size := nn;  keys := ks; vals := vs |} =>
           MEnvCtr {| v_size := nn;  keys := ks; vals := map (action_mod p) vs |}
         end
  with action_mte (p : Perm) mte:=
         match mte with
         | MTEnvCtr {| v_size := nn;  keys := ks; vals := vs |} =>
           MTEnvCtr {| v_size := nn;  keys := ks; vals := map (action_mty p) vs |}
         end
  with action_mod p (md : Mod) : Mod :=
         match md with
         | NonParamMod e => NonParamMod (action p e)
         | Ftor ts e mty => Ftor (PFin.action p ts) (action p e) (action_mty p mty)
         end
  with action_mty p (mty : MTy) : MTy :=
         match mty with
         | MSigma ts m => MSigma (PFin.action p ts) (action_mod p m)
         end.

  Notation "r @ x" := (action r x) (at level 80).

  Hint Resolve PermPlainEnv.action_id PFin.action_id.

  Lemma action_id : forall (x : X), (id_perm @ x) = x.
  Proof.
    intros x.
    induction x using Env_mut' with
        (P0 := fun me => (action_me id_perm me = me))
        (P1 := fun mte => (action_mte id_perm mte = mte))
        (P2 := fun m => (action_mod id_perm m = m))
        (P3 := fun mty => (action_mty id_perm mty = mty)); simpl;f_equal;auto.
    + destruct t0 as [n ks vs]. simpl in *. f_equal. f_equal.
      clear ks.
      dependent induction vs; auto.
      dependent destruction H. simpl.
      f_equal;auto.
    + destruct t0 as [n ks vs]. simpl in *. f_equal. f_equal.
      clear ks.
      dependent induction vs; auto.
      dependent destruction H. simpl.
      f_equal;auto.
  Qed.

  Lemma action_compose : forall (x : X) (r r' : Perm), (r @ (r' @ x)) = ((r ∘p r') @ x).
  Proof.
    Proof.
    intros x p p'.
    induction x using Env_mut' with
        (P0 := fun me => (action_me p (action_me p' me) = action_me (p ∘p p') me))
        (P1 := fun mte => (action_mte p (action_mte p' mte) = action_mte (p ∘p p') mte))
        (P2 := fun m => (action_mod p (action_mod p' m) = action_mod (p ∘p p') m))
        (P3 := fun mty => (action_mty p (action_mty p' mty) = action_mty (p ∘p p') mty)).
    - simpl. repeat rewrite PermPlainEnv.action_compose. rewrite IHx. rewrite IHx0. reflexivity.
    - destruct t0 as [n ks vs]. simpl in *. f_equal. f_equal.
      clear ks.
      dependent induction vs; auto.
      dependent destruction H. simpl.
      f_equal;auto.
    - destruct t0 as [n ks vs]. simpl in *. f_equal. f_equal.
      clear ks.
      dependent induction vs; auto.
      dependent destruction H. simpl.
      f_equal;auto.
    - simpl. congruence.
    - simpl. repeat rewrite PFin.action_compose. congruence.
    - simpl. repeat rewrite PFin.action_compose. congruence.
  Qed.

  Infix ":U:" := V.union (at level 40).

  (* This defintion works fine as well, although we call [fold_right]
     in the definition of [supp_mte] and [supp_mod], Coq is smart enough
     to figure out the decreasing argument *)
  Fixpoint supp E : V.t :=
    match E with
    | EnvCtr te ve me mte => (PermPlainEnv.supp te) :U:
                             (PermPlainEnv.supp ve) :U:
                             (supp_me me) :U:
                             (supp_mte mte)
    end
  with supp_me me :=
         match me with
         | MEnvCtr {| v_size := nn;  keys := ks; vals := vs |} =>
           fold_right (fun v v' => (supp_mod v) :U: v') vs V.empty
         end
  with supp_mte mte:=
         match mte with
         | MTEnvCtr {| v_size := nn;  keys := ks; vals := vs |} =>
           fold_right (fun v v' => (supp_mty v) :U: v') vs V.empty
         end
  with supp_mod (md : Mod) :=
         match md with
         | NonParamMod e => supp e
         | Ftor ts e mty => (PFin.supp ts) :U: (supp e) :U: (supp_mty mty)
         end
  with supp_mty (mty : MTy) :=
         match mty with
         | MSigma ts m => (PFin.supp ts) :U: (supp_mod m)
         end.

  Hint Resolve V.union_spec : set.

  Ltac solve_union_with H := apply H; repeat rewrite V.union_spec; auto with set.

  Lemma supp_spec :
    forall  (p : Perm)  (x : X),
      (forall (a : V.elt), V.In a (supp x) -> (perm p) a = a) -> (p @ x) = x.
  Proof.
    intros p.
    induction x using Env_mut' with
        (P0 := fun me =>
                 (forall (a : V.elt), V.In a (supp_me me) -> (perm p) a = a) ->
                 (action_me p me = me))
        (P1 := fun mte =>
                 (forall (a : V.elt), V.In a (supp_mte mte) -> (perm p) a = a) ->
                 (action_mte p mte = mte))
        (P2 := fun m =>
                 (forall (a : V.elt), V.In a (supp_mod m) -> (perm p) a = a) ->
                 (action_mod p m = m))
        (P3 := fun mty =>
                 (forall (a : V.elt), V.In a (supp_mty mty) -> (perm p) a = a) ->
                 (action_mty p mty = mty)).
    - intros. simpl in *. rewrite IHx; try (intros;solve_union_with H).
      rewrite IHx0; try (intros;solve_union_with H).
      repeat rewrite PermPlainEnv.supp_spec; try (intros; solve_union_with H). reflexivity.
    - intros H1. destruct t0 as [n ks vs]. simpl in *. f_equal. f_equal.
      clear ks.
      dependent induction vs; auto.
      dependent destruction H. simpl in *. f_equal.
      apply H. intros; solve_union_with H1.
      apply IHvs. assumption. intros; solve_union_with H1.
    - intros H1. destruct t0 as [n ks vs]. simpl in *. f_equal. f_equal. clear ks.
      dependent induction vs; auto.
      dependent destruction H. simpl in *. f_equal.
      apply H. intros. solve_union_with H1.
      apply IHvs. assumption. intros; solve_union_with H1.
    - intros. simpl in *. rewrite IHx;auto.
    - intros. simpl in *.
      rewrite IHx; try (intros; solve_union_with H).
      rewrite IHx0; try (intros; solve_union_with H).
      rewrite PFin.supp_spec;try (intros; solve_union_with H). reflexivity.
    - intros. simpl in *. rewrite PFin.supp_spec;try (intros; solve_union_with H).
      rewrite IHx; try (intros; solve_union_with H). reflexivity.
  Qed.

  Definition fresh x y := ~ V.In x (supp y).

  (* We also define a function that returns free variables in environment *)
  Fixpoint fvs E : V.t :=
    match E with
    | EnvCtr te ve me mte => (PermPlainEnv.supp te) :U:
                             (PermPlainEnv.supp ve) :U:
                             (fvs_me me) :U:
                             (fvs_mte mte)
    end
  with fvs_me me :=
         match me with
         | MEnvCtr {| v_size := nn;  keys := ks; vals := vs |} =>
           fold_right (fun v v' => (fvs_mod v) :U: v') vs V.empty
         end
  with fvs_mte mte:=
         match mte with
         | MTEnvCtr {| v_size := nn;  keys := ks; vals := vs |} =>
           fold_right (fun v v' => (fvs_mty v) :U: v') vs V.empty
         end
  with fvs_mod (md : Mod) :=
         match md with
         | NonParamMod e => fvs e
         | Ftor ts e mty => V.diff ((fvs e) :U: (fvs_mty mty)) ts
         end
  with fvs_mty (mty : MTy) :=
         match mty with
         | MSigma ts m => V.diff (fvs_mod m) ts
         end.
End PermSemOb.

Import EnvMod.
Import VE.
Import NomN.

Infix ":-:" := Atom.V.diff (at level 40).
Notation "r @ x" := (PFin.action r x) (at level 80) : set_scope.
Notation "r @ x" := (PermSemOb.action_mod r x) (at level 80) : env_scope.

Delimit Scope set_scope with S.
Delimit Scope env_scope with E.

(* -------------------------------------------------- *)
(* Alpha-equivalence of semantic objects in terms of  *)
(* permutations and freshness                         *)
(* -------------------------------------------------- *)
Inductive ae_env : Env -> Env -> Prop :=
| ae_env_c : forall (ve' ve : VEnv) (te' te : TEnv)
                    (me' me : MEnv) (mte' mte : MTEnv),
    ve' = ve ->
    te' = te ->
    ae_menv me' me ->
    ae_mte mte' mte ->
    ae_env (EnvCtr te' ve' me' mte') (EnvCtr te ve me mte)
  with
  ae_menv : MEnv -> MEnv -> Prop :=
  | ae_menv_c : forall (me' me : VE.VecEnv Mod),
      (forall mid (e' e : Mod),
          look mid (_to me') = Some e' ->
          look mid (_to me) = Some e ->
          ae_mod e' e) ->
      ae_menv (MEnvCtr me') (MEnvCtr me)
  with
  ae_mte : MTEnv -> MTEnv -> Prop :=
  | ae_mte_c : forall (mte' mte : VE.VecEnv MTy),
      (forall mtid (e' e : MTy),
          look mtid (_to mte') = Some e' ->
          look mtid (_to mte) = Some e ->
          ae_mty e' e) ->
      ae_mte (MTEnvCtr mte') (MTEnvCtr mte)
  with
  ae_mod : Mod -> Mod -> Prop :=
  | ae_mod_np : forall e' e,
      ae_env e' e -> ae_mod (NonParamMod e') (NonParamMod e)
  | ae_mod_ftor : forall t e e' mty mty',
      ae_env e e' ->
      ae_mty mty mty' ->
      ae_mod (Ftor t e' mty') (Ftor t e mty)
 with
 ae_mty : MTy -> MTy -> Prop :=
 | ae_mty_c : forall m m',
     forall (T T' : Atom.V.t) p,
       (forall a, Atom.V.In a ((PermSemOb.supp_mod m) :-: T)
                  -> (perm p) a = a) ->
    ae_mod (p @ m)%E m' ->
    T' = (p @ T)%S ->
    ae_mty (MSigma T' m') (MSigma T m).

Module PermIVEnv <: NomN.NominalSet.
  Import EnvMod.
  Import NomN.
  Import Atom.
  Import Coq.Program.Basics.

  Definition X := IVEnv.
  Definition singleEnv (k : tid) (t : label * Ty) : X := EnvMod.add _ k t EnvMod.empty.

  Definition action (r : Perm) (x : IVEnv) :=
    EnvMod.En.map (fun (v : label * Ty) => let (l,ty) := v in (l, (PermTy.action r) ty)) x.

  Notation "r @ x" := (action r x) (at level 80).

  Axiom action_id : forall (x : X), (id_perm @ x) = x.

  Axiom action_compose : forall (x : X) (r r' : Perm), (r @ (r' @ x)) = ((r ∘p r') @ x).

  Hint Resolve EnvMod.En.find_1 EnvMod.En.find_2
       EnvMod.En.map_1 : env.

  Definition supp (x : X) : V.t :=
    EnvMod.En.fold (fun k v v' => V.union ((PermTy.supp ∘ snd) v) v') x V.empty.
  Axiom supp_spec :
    forall  (r : Perm)  (x : X),
      (forall (a : V.elt), V.In a (supp x) -> (perm r) a = a) -> (r @ x) = x.

End PermIVEnv.

(* ---------------------------------------*)
(* Nominal set of interpretation objects  *)
(* (labels as atoms)                      *)
(* -------------------------------------- *)
Module PermIVEnvLabel <: NomN.NominalSet.
  Import EnvMod.
  Import NomN.
  Import Atom.
  Import Coq.Program.Basics.

  Definition X := IVEnv.

  Definition action (r : Perm) (x : IVEnv) : IVEnv :=
    EnvMod.En.map (fun (v : label * Ty) => let (l,ty) := v in ((perm r) l, ty)) x.

  Notation "r @ x" := (action r x) (at level 80).

  Lemma action_id : forall (x : X), (id_perm @ x) = x.
  Proof.
    intros x.
    apply EnvMod.env_extensionality_alt.
    intros. split.
    + intros H. apply EnvMod.En.find_2 in H. unfold action in *.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *.
      destruct H as [a H']. destruct H',a. subst. simpl. auto with env.
    + intros H. unfold action in *.
      apply EnvMod.En.find_1.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *.
      exists v. destruct v. simpl. split;auto.
  Qed.

  Lemma action_compose : forall (x : X) (r r' : Perm), (r @ (r' @ x)) = ((r ∘p r') @ x).
  Proof.
    intros x r r'.
    apply EnvMod.env_extensionality_alt. intros.
    split;unfold action in *.
    + intros H.
      apply EnvMod.En.find_1. apply EnvMod.En.find_2 in H.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *. destruct H as [a H']. destruct H'.
      subst. rewrite EnvMod.FM.P.F.map_mapsto_iff in *.
      destruct H0 as [b H0']. destruct H0'.
      subst.
      exists b. split.
      * destruct b. reflexivity.
      * destruct b. auto.
    + intros H.
      apply EnvMod.En.find_1. apply EnvMod.En.find_2 in H.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *.
      destruct H as [a H']. destruct H'.
      destruct a as [l ty]. simpl in *.
      exists ((perm r') l,ty).
      split.
      * auto.
      * rewrite EnvMod.FM.P.F.map_mapsto_iff in *.
        exists (l,ty). split;auto.
  Qed.

  Definition supp (x : X) : V.t :=
    EnvMod.En.fold (fun k v v' => V.union (V.singleton (fst v)) v') x V.empty.

  Lemma in_env_in_supp (E : X) k ty l :
    look k E = Some (l,ty) -> V.In l (supp E).
  Proof.
    unfold supp.
    apply FM.P.fold_rec_weak.
    + intros m m' a H H1 H2. apply env_extensionality in H. subst. auto.
    + intros He. tryfalse.
    + intros. rewrite V.union_spec in *.
      apply En.find_2 in H1. rewrite FM.P.F.add_mapsto_iff in *.
      destruct H1.
      * destruct H1. subst. simpl. auto with set.
      * destruct H1. right. apply H0; auto.
  Qed.

  Lemma supp_spec :
    forall  (r : Perm)  (x : X),
      (forall (a : V.elt), V.In a (supp x) -> (perm r) a = a) -> (r @ x) = x.
  Proof.
    intros r x Hs.
    unfold action in *.
    apply EnvMod.env_extensionality_alt. intros.
    split.
    + intros H. rewrite <- FM.P.F.find_mapsto_iff in *.
      rewrite EnvMod.FM.P.F.map_mapsto_iff in *. destruct H as [a H']. destruct H'.
      subst. destruct a. rewrite Hs;auto.
      eapply in_env_in_supp;eauto.
    + intros Hv. rewrite <- FM.P.F.find_mapsto_iff in *.
      rewrite FM.P.F.map_mapsto_iff.
      exists v. split;auto. destruct v. rewrite Hs. reflexivity. eapply in_env_in_supp;eauto.
  Qed.

End PermIVEnvLabel.

Module PermIEnvLabel <: NomN.NominalSet.
  Module V := AtomN.V.
  Import NomN.
  Import EnvMod.
  Import VE.

  Definition X : Type := IEnv.

  Fixpoint action (p :Perm) (ie : X) : X :=
    match ie with
    | IEnvCtr te ive ime mte => IEnvCtr te
                                        (PermIVEnvLabel.action p ive)
                                        (action_ime p ime)
                                        mte
    end
  with action_ime p ime :=
           match ime with
           | IMEnvCtr {| v_size := nn;  keys := ks; vals := vs |} =>
             IMEnvCtr {| v_size := nn;  keys := ks; vals := (Vector.map (action_imod p) vs) |}
           end
  with action_imod p (md : IMod) : IMod :=
         match md with
         | INonParamMod e => INonParamMod (action p e)
         | IFtor ie ts e mty mid mexp =>
           IFtor (action p ie) ts e mty mid mexp
         end.

  Notation "r @ x" := (action r x) (at level 80).

  Lemma action_id : forall (x : X), (id_perm @ x) = x.
  Proof.
    induction x using IEnv_mut with
            (P0 := fun ime => (action_ime id_perm ime = ime))
            (P1 := fun m => (action_imod id_perm m = m)).
    - simpl. rewrite PermIVEnvLabel.action_id. rewrite IHx. reflexivity.
    - destruct t0 as [n ks vs]. simpl in *. f_equal. f_equal.
      clear ks.
      dependent induction vs; auto.
      dependent destruction H. simpl.
      f_equal;auto.
    - simpl. congruence.
    - simpl. congruence.
  Qed.

  Lemma action_compose : forall (x : X) (r r' : Perm), (r @ (r' @ x)) = ((r ∘p r') @ x).
  Proof.
    intros x p p'.
    induction x using IEnv_mut with
            (P0 := fun ime => (action_ime p (action_ime p' ime) = action_ime (p ∘p p') ime))
            (P1 := fun m => (action_imod p (action_imod p' m) = action_imod (p ∘p p') m)).
    - simpl. rewrite PermIVEnvLabel.action_compose. rewrite IHx. reflexivity.
    - destruct t0 as [n ks vs]. simpl in *. f_equal. f_equal.
      clear ks.
      dependent induction vs; auto.
      dependent destruction H. simpl.
      f_equal;auto.
    - simpl. congruence.
    - simpl. congruence.
  Qed.

  Infix ":U:" := V.union (at level 40).

  Fixpoint supp (ie : X) : V.t :=
    match ie with
    | IEnvCtr te ive ime mte => (PermIVEnvLabel.supp ive) :U: (supp_ime ime)
    end
  with supp_ime ime :=
         match ime with
         | IMEnvCtr {| v_size := nn;  keys := ks; vals := vs |} =>
           fold_right (fun v v' => (supp_imod v) :U: v') vs V.empty
         end
  with supp_imod (md : IMod) : V.t :=
         match md with
         | INonParamMod ie => supp ie
         | IFtor ie ts e mty mid mexp => supp ie
         end.

  Lemma supp_spec :
    forall  (p : Perm)  (x : X),
      (forall (a : V.elt), V.In a (supp x) -> (perm p) a = a) -> (p @ x) = x.
  Proof.
    intros p.
    induction x using IEnv_mut with
        (P0 := fun ime =>
                 (forall (a : V.elt), V.In a (supp_ime ime) -> (perm p) a = a) ->
                 (action_ime p ime = ime))
        (P1 := fun m =>
                 (forall (a : V.elt), V.In a (supp_imod m) -> (perm p) a = a) ->
                 (action_imod p m = m)).
    - intros. simpl in *. rewrite IHx. rewrite PermIVEnvLabel.supp_spec. reflexivity.
      intros. auto with set. auto with set.
    - intros H1. destruct t0 as [n ks vs]. simpl in *. f_equal. f_equal.
      clear ks.
      dependent induction vs; auto.
      dependent destruction H. simpl in *.
      f_equal.  apply H; auto with set. apply IHvs;auto. intros. auto with set.
    - intros. simpl. rewrite IHx;auto.
    - intros. simpl. rewrite IHx;auto.
  Qed.

  Notation "a # x" := (~ V.In a (supp x)) (at level 40) : IEnv_scope.

End PermIEnvLabel.